-----------------------------------------------------------------------------
-- |
-- Module      :  Plugins.Monitors.Disk.Linux
-- Copyright   :  (c) 2010, 2011, 2012, 2014, 2018, 2019 Jose A Ortega Ruiz
-- License     :  BSD-style (see LICENSE)
--
-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
-- Stability   :  unstable
-- Portability :  unportable
--
--  Disk usage and throughput monitors for Xmobar
--
-----------------------------------------------------------------------------

module Xmobar.Plugins.Monitors.Disk.Linux
  (
    fetchDataIO
  , fetchDataUsage
  , initializeDevDataRef
  , DevDataRef
  ) where

import Data.IORef (
  IORef
  , newIORef
  , readIORef
  , writeIORef
  )

import Xmobar.System.StatFS (
  getFileSystemStats
  , fsStatByteCount
  , fsStatBytesAvailable
  , fsStatBytesUsed
  )
import qualified Data.ByteString.Lazy.Char8 as B
import Data.List (isPrefixOf, find)
import Data.Maybe (catMaybes)
import System.Directory (canonicalizePath, doesFileExist)
import Control.Exception (SomeException, handle)

import Xmobar.Plugins.Monitors.Disk.Common (
  DevName
  , Path
  )

type DevDataRef = IORef [(DevName, [Float])]

fsStats :: String -> IO [Integer]
fsStats :: DevName -> IO [Integer]
fsStats DevName
path = do
  stats <- DevName -> IO (Maybe FileSystemStats)
getFileSystemStats DevName
path
  case stats of
    Maybe FileSystemStats
Nothing -> [Integer] -> IO [Integer]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Integer
0, Integer
0, Integer
0]
    Just FileSystemStats
f -> let tot :: Integer
tot = FileSystemStats -> Integer
fsStatByteCount FileSystemStats
f
                  free :: Integer
free = FileSystemStats -> Integer
fsStatBytesAvailable FileSystemStats
f
                  used :: Integer
used = FileSystemStats -> Integer
fsStatBytesUsed FileSystemStats
f
              in [Integer] -> IO [Integer]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Integer
tot, Integer
free, Integer
used]

mountedDevices :: [String] -> IO [(DevName, Path)]
mountedDevices :: [DevName] -> IO [(DevName, DevName)]
mountedDevices [DevName]
req = do
  s <- DevName -> IO ByteString
B.readFile DevName
"/etc/mtab"
  parse `fmap` mapM mbcanon (devs s)
  where
    mbcanon :: (DevName, b) -> IO (Maybe (DevName, b))
mbcanon (DevName
d, b
p) = DevName -> IO Bool
doesFileExist DevName
d IO Bool
-> (Bool -> IO (Maybe (DevName, b))) -> IO (Maybe (DevName, b))
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Bool
e ->
                     if Bool
e
                        then (DevName, b) -> Maybe (DevName, b)
forall a. a -> Maybe a
Just ((DevName, b) -> Maybe (DevName, b))
-> IO (DevName, b) -> IO (Maybe (DevName, b))
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (DevName, b) -> IO (DevName, b)
forall {b}. (DevName, b) -> IO (DevName, b)
canon (DevName
d,b
p)
                        else Maybe (DevName, b) -> IO (Maybe (DevName, b))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (DevName, b)
forall a. Maybe a
Nothing
    canon :: (DevName, b) -> IO (DevName, b)
canon (DevName
d, b
p) = do {d' <- DevName -> IO DevName
canonicalizePath DevName
d; return (d', p)}
    devs :: ByteString -> [(DevName, DevName)]
devs = ((DevName, DevName) -> Bool)
-> [(DevName, DevName)] -> [(DevName, DevName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (DevName, DevName) -> Bool
forall {b}. (DevName, b) -> Bool
isDev ([(DevName, DevName)] -> [(DevName, DevName)])
-> (ByteString -> [(DevName, DevName)])
-> ByteString
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> (DevName, DevName))
-> [ByteString] -> [(DevName, DevName)]
forall a b. (a -> b) -> [a] -> [b]
map ([ByteString] -> (DevName, DevName)
firstTwo ([ByteString] -> (DevName, DevName))
-> (ByteString -> [ByteString]) -> ByteString -> (DevName, DevName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
B.words) ([ByteString] -> [(DevName, DevName)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
B.lines
    parse :: [Maybe (DevName, DevName)] -> [(DevName, DevName)]
parse = ((DevName, DevName) -> (DevName, DevName))
-> [(DevName, DevName)] -> [(DevName, DevName)]
forall a b. (a -> b) -> [a] -> [b]
map (DevName, DevName) -> (DevName, DevName)
forall {a} {b}. ([a], b) -> ([a], b)
undev ([(DevName, DevName)] -> [(DevName, DevName)])
-> ([Maybe (DevName, DevName)] -> [(DevName, DevName)])
-> [Maybe (DevName, DevName)]
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DevName, DevName) -> Bool)
-> [(DevName, DevName)] -> [(DevName, DevName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (DevName, DevName) -> Bool
isReq ([(DevName, DevName)] -> [(DevName, DevName)])
-> ([Maybe (DevName, DevName)] -> [(DevName, DevName)])
-> [Maybe (DevName, DevName)]
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (DevName, DevName)] -> [(DevName, DevName)]
forall a. [Maybe a] -> [a]
catMaybes
    firstTwo :: [ByteString] -> (DevName, DevName)
firstTwo (ByteString
a:ByteString
b:[ByteString]
_) = (ByteString -> DevName
B.unpack ByteString
a, ByteString -> DevName
B.unpack ByteString
b)
    firstTwo [ByteString]
_ = (DevName
"", DevName
"")
    isDev :: (DevName, b) -> Bool
isDev (DevName
d, b
_) = DevName
"/dev/" DevName -> DevName -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` DevName
d
    isReq :: (DevName, DevName) -> Bool
isReq (DevName
d, DevName
p) = DevName
p DevName -> [DevName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DevName]
req Bool -> Bool -> Bool
|| Int -> DevName -> DevName
forall a. Int -> [a] -> [a]
drop Int
5 DevName
d DevName -> [DevName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DevName]
req
    undev :: ([a], b) -> ([a], b)
undev ([a]
d, b
f) = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
5 [a]
d, b
f)

diskDevices :: [String] -> IO [(DevName, Path)]
diskDevices :: [DevName] -> IO [(DevName, DevName)]
diskDevices [DevName]
req = do
  s <- DevName -> IO ByteString
B.readFile DevName
"/proc/diskstats"
  parse `fmap` mapM canon (devs s)
  where
    canon :: (DevName, b) -> IO (DevName, b)
canon (DevName
d, b
p) = do {d' <- DevName -> IO DevName
canonicalizePath DevName
d; return (d', p)}
    devs :: ByteString -> [(DevName, DevName)]
devs = (ByteString -> (DevName, DevName))
-> [ByteString] -> [(DevName, DevName)]
forall a b. (a -> b) -> [a] -> [b]
map ([ByteString] -> (DevName, DevName)
third ([ByteString] -> (DevName, DevName))
-> (ByteString -> [ByteString]) -> ByteString -> (DevName, DevName)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
B.words) ([ByteString] -> [(DevName, DevName)])
-> (ByteString -> [ByteString])
-> ByteString
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
B.lines
    parse :: [(DevName, DevName)] -> [(DevName, DevName)]
parse = ((DevName, DevName) -> (DevName, DevName))
-> [(DevName, DevName)] -> [(DevName, DevName)]
forall a b. (a -> b) -> [a] -> [b]
map (DevName, DevName) -> (DevName, DevName)
forall {a} {b}. ([a], b) -> ([a], b)
undev ([(DevName, DevName)] -> [(DevName, DevName)])
-> ([(DevName, DevName)] -> [(DevName, DevName)])
-> [(DevName, DevName)]
-> [(DevName, DevName)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((DevName, DevName) -> Bool)
-> [(DevName, DevName)] -> [(DevName, DevName)]
forall a. (a -> Bool) -> [a] -> [a]
filter (DevName, DevName) -> Bool
isReq
    third :: [ByteString] -> (DevName, DevName)
third (ByteString
_:ByteString
_:ByteString
c:[ByteString]
_) = (DevName
"/dev/" DevName -> DevName -> DevName
forall a. [a] -> [a] -> [a]
++ ByteString -> DevName
B.unpack ByteString
c, ByteString -> DevName
B.unpack ByteString
c)
    third [ByteString]
_ = (DevName
"", DevName
"")
    isReq :: (DevName, DevName) -> Bool
isReq (DevName
d, DevName
p) = DevName
p DevName -> [DevName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DevName]
req Bool -> Bool -> Bool
|| Int -> DevName -> DevName
forall a. Int -> [a] -> [a]
drop Int
5 DevName
d DevName -> [DevName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [DevName]
req
    undev :: ([a], b) -> ([a], b)
undev ([a]
d, b
f) = (Int -> [a] -> [a]
forall a. Int -> [a] -> [a]
drop Int
5 [a]
d, b
f)

mountedOrDiskDevices :: [String] -> IO [(DevName, Path)]
mountedOrDiskDevices :: [DevName] -> IO [(DevName, DevName)]
mountedOrDiskDevices [DevName]
req = do
  mnt <- [DevName] -> IO [(DevName, DevName)]
mountedDevices [DevName]
req
  case mnt of
       []    -> [DevName] -> IO [(DevName, DevName)]
diskDevices [DevName]
req
       [(DevName, DevName)]
other -> [(DevName, DevName)] -> IO [(DevName, DevName)]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [(DevName, DevName)]
other

diskData :: IO [(DevName, [Float])]
diskData :: IO [(DevName, [Float])]
diskData = do
  s <- DevName -> IO ByteString
B.readFile DevName
"/proc/diskstats"
  let extract [DevName]
ws = ([DevName] -> DevName
forall a. HasCallStack => [a] -> a
head [DevName]
ws, (DevName -> b) -> [DevName] -> [b]
forall a b. (a -> b) -> [a] -> [b]
map DevName -> b
forall a. Read a => DevName -> a
read ([DevName] -> [DevName]
forall a. HasCallStack => [a] -> [a]
tail [DevName]
ws))
  return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s)

mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])]
mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])]
mountedData DevDataRef
dref [DevName]
devs = do
  dt <- DevDataRef -> IO [(DevName, [Float])]
forall a. IORef a -> IO a
readIORef DevDataRef
dref
  dt' <- diskData
  writeIORef dref dt'
  return $ map (parseDev (zipWith diff dt' dt)) devs
  where diff :: (a, [c]) -> (a, [c]) -> (a, [c])
diff (a
dev, [c]
xs) (a
_, [c]
ys) = (a
dev, (c -> c -> c) -> [c] -> [c] -> [c]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (-) [c]
xs [c]
ys)


parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float])
parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float])
parseDev [(DevName, [Float])]
dat DevName
dev =
  case ((DevName, [Float]) -> Bool)
-> [(DevName, [Float])] -> Maybe (DevName, [Float])
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find ((DevName -> DevName -> Bool
forall a. Eq a => a -> a -> Bool
==DevName
dev) (DevName -> Bool)
-> ((DevName, [Float]) -> DevName) -> (DevName, [Float]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DevName, [Float]) -> DevName
forall a b. (a, b) -> a
fst) [(DevName, [Float])]
dat of
    Maybe (DevName, [Float])
Nothing -> (DevName
dev, [Float
0, Float
0, Float
0])
    Just (DevName
_, [Float]
xs) ->
      let r :: Float
r = Float
4096 Float -> Float -> Float
forall a. Num a => a -> a -> a
* [Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
2
          w :: Float
w = Float
4096 Float -> Float -> Float
forall a. Num a => a -> a -> a
* [Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
6
          t :: Float
t = Float
r Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
w
          rSp :: Float
rSp = Float -> Float -> Float
forall {a}. (Eq a, Fractional a) => a -> a -> a
speed Float
r ([Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
3)
          wSp :: Float
wSp = Float -> Float -> Float
forall {a}. (Eq a, Fractional a) => a -> a -> a
speed Float
w ([Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
7)
          sp :: Float
sp =  Float -> Float -> Float
forall {a}. (Eq a, Fractional a) => a -> a -> a
speed Float
t ([Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
3 Float -> Float -> Float
forall a. Num a => a -> a -> a
+ [Float]
xs [Float] -> Int -> Float
forall a. HasCallStack => [a] -> Int -> a
!! Int
7)
          speed :: a -> a -> a
speed a
x a
d = if a
d a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
0 then a
0 else a
x a -> a -> a
forall a. Fractional a => a -> a -> a
/ a
d
          dat' :: [Float]
dat' = if [Float] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Float]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
6
                 then [Float
sp, Float
rSp, Float
wSp, Float
t, Float
r, Float
w]
                 else [Float
0, Float
0, Float
0, Float
0, Float
0, Float
0]
      in (DevName
dev, [Float]
dat')

fetchDataIO :: DevDataRef -> [(String, String)] -> IO [(String, [Float])]
fetchDataIO :: DevDataRef -> [(DevName, DevName)] -> IO [(DevName, [Float])]
fetchDataIO DevDataRef
dref [(DevName, DevName)]
disks = do
  dev <- [DevName] -> IO [(DevName, DevName)]
mountedOrDiskDevices (((DevName, DevName) -> DevName)
-> [(DevName, DevName)] -> [DevName]
forall a b. (a -> b) -> [a] -> [b]
map (DevName, DevName) -> DevName
forall a b. (a, b) -> a
fst [(DevName, DevName)]
disks)
  mountedData dref (map fst dev)

fetchDataUsage :: [(String, String)] -> IO [((String, String), [Integer])]
fetchDataUsage :: [(DevName, DevName)] -> IO [((DevName, DevName), [Integer])]
fetchDataUsage [(DevName, DevName)]
disks = do
  devs <- [DevName] -> IO [(DevName, DevName)]
mountedDevices (((DevName, DevName) -> DevName)
-> [(DevName, DevName)] -> [DevName]
forall a b. (a -> b) -> [a] -> [b]
map (DevName, DevName) -> DevName
forall a b. (a, b) -> a
fst [(DevName, DevName)]
disks)
  mapM fetchStats devs
  where
    fetchStats :: (String, String) -> IO ((String, String), [Integer])
    fetchStats :: (DevName, DevName) -> IO ((DevName, DevName), [Integer])
fetchStats (DevName
dev, DevName
path) = do
      stats <- (SomeException -> IO [Integer]) -> IO [Integer] -> IO [Integer]
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle SomeException -> IO [Integer]
ign (IO [Integer] -> IO [Integer]) -> IO [Integer] -> IO [Integer]
forall a b. (a -> b) -> a -> b
$ DevName -> IO [Integer]
fsStats DevName
path
      return ((dev, path), stats)
    ign :: SomeException -> IO [Integer]
ign = IO [Integer] -> SomeException -> IO [Integer]
forall a b. a -> b -> a
const ([Integer] -> IO [Integer]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [Integer
0, Integer
0, Integer
0]) :: SomeException -> IO [Integer]

initializeDevDataRef :: [(String, String)] -> IO DevDataRef
initializeDevDataRef :: [(DevName, DevName)] -> IO DevDataRef
initializeDevDataRef [(DevName, DevName)]
disks = do
  dev <- [DevName] -> IO [(DevName, DevName)]
mountedOrDiskDevices (((DevName, DevName) -> DevName)
-> [(DevName, DevName)] -> [DevName]
forall a b. (a -> b) -> [a] -> [b]
map (DevName, DevName) -> DevName
forall a b. (a, b) -> a
fst [(DevName, DevName)]
disks)
  newIORef (map (\(DevName, DevName)
d -> ((DevName, DevName) -> DevName
forall a b. (a, b) -> a
fst (DevName, DevName)
d, Float -> [Float]
forall a. a -> [a]
repeat Float
0)) dev)