diff options
Diffstat (limited to 'src/Xmobar/Plugins/Monitors/Disk')
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Disk/Common.hs | 21 | ||||
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc | 403 | ||||
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Disk/Linux.hs | 148 |
3 files changed, 572 insertions, 0 deletions
diff --git a/src/Xmobar/Plugins/Monitors/Disk/Common.hs b/src/Xmobar/Plugins/Monitors/Disk/Common.hs new file mode 100644 index 0000000..cdfb73c --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk/Common.hs @@ -0,0 +1,21 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk.Common +-- 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.Common ( + DevName + , Path + ) where + +type DevName = String +type Path = String diff --git a/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc b/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc new file mode 100644 index 0000000..296ba6c --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk/FreeBSD.hsc @@ -0,0 +1,403 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NumDecimals #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk.Freebsd +-- 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.FreeBSD + ( + fetchDataIO + , fetchDataUsage + , initializeDevDataRef + , DevDataRef + ) where + +import Data.IORef ( + IORef + , newIORef + , readIORef + , writeIORef + ) + +import Xmobar.Plugins.Monitors.Disk.Common ( + DevName + , Path + ) + +import qualified Control.Exception.Extensible as E +import qualified Data.List as DL +import qualified Data.Map as DM +import qualified Data.Set as DS +import Data.Time.Clock.POSIX +import Foreign +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.String +import Foreign.C.Types +import System.BSD.Sysctl + +#include <sys/sysctl.h> +#include <sys/mount.h> +#include <devstat.h> +#include <libgeom.h> + +foreign import ccall unsafe "sys/mount.h getfsstat" c_getfsstat :: Ptr STATFS -> CInt -> CInt -> IO CInt +foreign import ccall unsafe "geom_stats_open" c_geom_stats_open :: IO CInt +foreign import ccall unsafe "geom_stats_snapshot_get" c_geom_stats_snapshot_get :: IO (Ptr GSNAP) +foreign import ccall unsafe "&geom_stats_snapshot_free" c_geom_stats_snapshot_free :: FinalizerPtr GSNAP +foreign import ccall unsafe "geom_stats_snapshot_next" c_geom_stats_snapshot_next :: Ptr GSNAP -> IO (Ptr DEVSTAT) +foreign import ccall unsafe "geom_gettree" c_geom_gettree :: Ptr GMESH -> IO CInt +foreign import ccall unsafe "geom_lookupid" c_geom_lookupid :: Ptr GMESH -> Ptr VOIDPTR -> IO (Ptr GIDENT) +foreign import ccall unsafe "&geom_deletetree" c_geom_deletetree :: FinalizerPtr GMESH +foreign import ccall unsafe "geom_stats_snapshot_timestamp" c_geom_stats_snapshot_timestamp :: Ptr GSNAP -> Ptr Timespec -> IO CInt + +type DevDataRef = IORef (DM.Map String DevStatData) + +data STATFS +data StatFs = StatFs !(ForeignPtr STATFS) + deriving (Eq, Show) + +data DEVSTAT +data DevStat = DevStat !(ForeignPtr DEVSTAT) + deriving (Eq, Show) + +data GMESH +data GMesh = GMesh !(ForeignPtr GMESH) + +data GSNAP +data GSnap = GSnap !(ForeignPtr GSNAP) + +data GIDENT +data VOIDPTR +data Timespec + +data DevStatData = DevStatData { + devname :: String + , readDevStat :: Int64 + , writeDevStat :: Int64 + , devstatId :: Ptr VOIDPTR + , devStatTime :: Rational + } + deriving (Show, Eq) + +data StatFsData = StatFsData + { + fsMntFromName :: String + , fsMntOnName :: String + , fsStatBlockSize :: Integer + -- ^ Optimal transfer block size. + , fsStatBlockCount :: Integer + -- ^ Total data blocks in file system. + , fsStatByteCount :: Integer + -- ^ Total bytes in file system. + , fsStatBytesFree :: Integer + -- ^ Free bytes in file system. + , fsStatBytesAvailable :: Integer + -- ^ Free bytes available to non-superusers. + , fsStatBytesUsed :: Integer + -- ^ Bytes used. + } + deriving (Show, Read, Eq) + +data GIdentData = GIdentData + { + lgPtr :: Ptr VOIDPTR + , lgWhat :: CInt + } + deriving (Show, Eq) + +instance Storable GIdentData where + alignment _ = #{alignment struct gident} + sizeOf _ = #{size struct gident} + peek ptr = do + gIdentLgPtr <- #{peek struct gident, lg_ptr} ptr :: IO (Ptr VOIDPTR) + gIdentLgWhat <- #{peek struct gident, lg_what} ptr :: IO CInt + return GIdentData { + lgPtr=gIdentLgPtr + , lgWhat=gIdentLgWhat + } + + poke _ _ = pure () + +instance Storable DevStatData where + alignment _ = #{alignment struct devstat} + sizeOf _ = #{size struct devstat} + peek ptr = do + device_id <- #{peek struct devstat, id} ptr :: IO (Ptr VOIDPTR) + device_name <- peekCString $ #{ptr struct devstat, device_name} ptr + unit_number <- #{peek struct devstat, unit_number} ptr :: IO Int + bytes_values <- peekArray 4 $ #{ptr struct devstat, bytes} ptr :: IO [CUIntMax] + let + read_value = bytes_values !! #{const DEVSTAT_READ} + write_value = bytes_values !! #{const DEVSTAT_WRITE} + return DevStatData { + devname=concat [device_name, show unit_number] + , readDevStat=fromInteger . toInteger $ read_value + , writeDevStat=fromInteger . toInteger $ write_value + , devstatId=device_id + , devStatTime=0 + } + + + poke _ _ = pure () + +instance Storable StatFsData where + alignment _ = #{alignment struct statfs} + sizeOf _ = #{size struct statfs} + peek ptr = do + fmntfromname <- peekCString $ #{ptr struct statfs, f_mntfromname} ptr + fmntonname <- peekCString $ #{ptr struct statfs, f_mntonname} ptr + bsize <- #{peek struct statfs, f_bsize} ptr + bcount <- #{peek struct statfs, f_blocks} ptr + bfree <- #{peek struct statfs, f_bfree} ptr + bavail <- #{peek struct statfs, f_bavail} ptr + let + bpb = toI bsize + return $ StatFsData { + fsMntFromName = fmntfromname + , fsMntOnName = fmntonname + , fsStatBlockSize = bpb + , fsStatBlockCount = toI bcount + , fsStatByteCount = toI bcount * bpb + , fsStatBytesFree = toI bfree * bpb + , fsStatBytesAvailable = toI bavail * bpb + , fsStatBytesUsed = toI (bcount - bfree) * bpb + } + + poke _ _ = pure () + + +toI :: CULong -> Integer +toI = toInteger + +mountCount :: IO CInt +mountCount = c_getfsstat nullPtr 0 #{const MNT_NOWAIT} + +getMountInfo :: IO [StatFsData] +getMountInfo = do + cmountcount <- mountCount + let + cbytes = cmountcount * #{size struct statfs} + bytes = fromInteger . toInteger $ cbytes + mountcount = fromInteger . toInteger $ cmountcount + allocaBytes bytes $ \vfs -> do + c_getfsstat vfs cbytes #{const MNT_NOWAIT} + peekArray mountcount $ castPtr vfs :: IO [StatFsData] + +cTimeToInteger :: CTime -> Integer +cTimeToInteger (CTime n) = fromIntegral n + +getSnapshotTime :: GSnap -> IO Integer +getSnapshotTime (GSnap snap_fp) = do + allocaBytes #{const sizeof(struct timespec)} $ \p_ts -> do + withForeignPtr snap_fp $ \snap_ptr -> do + throwErrnoIfMinus1_ "geom_stats_snapshot_timestamp" + $ c_geom_stats_snapshot_timestamp snap_ptr p_ts + u_sec <- #{peek struct timespec,tv_sec} p_ts :: IO CTime + u_nsec <- #{peek struct timespec,tv_nsec} p_ts :: IO CLong + return (cTimeToInteger u_sec * 1e12 + fromIntegral u_nsec * 1e3) + +checkGeomStat' :: GIdentData -> GSnap -> DevStatData -> [DevStatData] -> IO [DevStatData] +checkGeomStat' gident_data gsnap stat acc + | (lgWhat gident_data) /= #{const ISPROVIDER} = return acc + | otherwise = do + lgNamePtr <- #{peek struct gprovider, lg_name} $ lgPtr gident_data + lgName <- peekCString $ castPtr lgNamePtr + lgTime <- toRational <$> getSnapshotTime gsnap + return $ stat + { + devname=concat ["/dev/", lgName] + , devStatTime= lgTime / 1e12 + } : acc + + +checkGeomStat :: Ptr GIDENT -> GSnap -> DevStatData -> [DevStatData] -> IO [DevStatData] +checkGeomStat gident_ptr gsnap stat acc + | gident_ptr == nullPtr = return acc + | otherwise = do + gIdent <- peek $ castPtr gident_ptr :: IO GIdentData + checkGeomStat' gIdent gsnap stat acc + + +getGeomStats' :: GMesh -> GSnap -> Ptr DEVSTAT -> [DevStatData] -> IO [DevStatData] +getGeomStats' gmeshD@(GMesh gmesh_fp) gsnapD@(GSnap snap_fp) ptr acc + | ptr == nullPtr = return acc + | otherwise = do + withForeignPtr snap_fp $ \snap_ptr -> do + acc' <- withForeignPtr gmesh_fp $ \gmesh_ptr -> do + stat <- (peek $ castPtr ptr) :: IO DevStatData + gIdentPtr <- c_geom_lookupid gmesh_ptr (devstatId stat) + checkGeomStat gIdentPtr gsnapD stat acc + nextStatPtr <- c_geom_stats_snapshot_next snap_ptr + getGeomStats' gmeshD gsnapD nextStatPtr acc' + +getGeomStats :: IO [DevStatData] +getGeomStats = do + gmesh_fp <- mallocForeignPtrBytes bytesmesh + addForeignPtrFinalizer c_geom_deletetree gmesh_fp + c_geom_stats_open + withForeignPtr gmesh_fp $ \gmesh_ptr -> do + c_geom_gettree gmesh_ptr + snap_ptr <- c_geom_stats_snapshot_get + snap_fp <- newForeignPtr c_geom_stats_snapshot_free snap_ptr + withForeignPtr snap_fp $ \snap_ptr' -> do + nextStatPtr <- c_geom_stats_snapshot_next snap_ptr' + getGeomStats' (GMesh gmesh_fp) (GSnap snap_fp) nextStatPtr [] + where + bytesmesh = #{size struct gmesh} + + +readGeomStats :: DM.Map String DevStatData -> IO (DM.Map String DevStatData) +readGeomStats acc = do + (Prelude.foldr (\x-> DM.insert (devname x) x) acc) <$> getGeomStats + +defaultDevStatData :: DevStatData +defaultDevStatData = DevStatData + { + devname = "" + , readDevStat = 0 + , writeDevStat = 0 + , devstatId = nullPtr + , devStatTime = 0 + } + +sysctlNextOid :: [Int32] -> IO [Int32] +sysctlNextOid oid = do + let query_oid = #{const CTL_SYSCTL} : #{const CTL_SYSCTL_NEXT} : oid + E.catch (sysctlPeekArray query_oid :: IO [Int32]) (\(E.SomeException _) -> return []) + +sysctlOidToName :: [Int32] -> IO String +sysctlOidToName oid = do + let query_oid = #{const CTL_SYSCTL} : #{const CTL_SYSCTL_NAME} : oid + nameO <- sysctlReadString query_oid + return nameO + +fetchZfsStat :: [Int32] -> DM.Map (String, String) DevStatData -> [String] -> IO (DM.Map (String, String) DevStatData) +fetchZfsStat oid acc (_ : _ : poolName : "dataset" : refName : "nread" : []) = do + readsB <- sysctlReadLong oid + let val = DM.findWithDefault defaultDevStatData (poolName, refName) acc + val' = val + { + readDevStat = readsB + } + return $ DM.insert (poolName, refName) val' acc + +fetchZfsStat oid acc (_ : _ : poolName : "dataset" : refName : "nwritten" : []) = do + writesB <- sysctlReadLong oid + let val = DM.findWithDefault defaultDevStatData (poolName, refName) acc + val' = val + { + writeDevStat = writesB + } + return $ DM.insert (poolName, refName) val' acc + +fetchZfsStat oid acc (_ : _ : poolName : "dataset" : refName : "dataset_name" : []) = do + datasetName <- sysctlReadString oid + datasetTime <- toRational <$> getPOSIXTime + let val = DM.findWithDefault defaultDevStatData (poolName, refName) acc + val' = val + { + devname = datasetName + , devStatTime = datasetTime + } + return $ DM.insert (poolName, refName) val' acc + +fetchZfsStat _ acc _ = return acc + +readZfsStat' :: [Int32] -> [Int32] -> DM.Map (String, String) DevStatData -> IO (DM.Map (String, String) DevStatData) +readZfsStat' mainOid actOid acc + | mainOid `DL.isPrefixOf` actOid = do + nameDS <- sysctlOidToName actOid + let nameArr = splitOnDot nameDS + acc' <- fetchZfsStat actOid acc nameArr + nextOid <- sysctlNextOid actOid + readZfsStat' mainOid nextOid acc' + + | otherwise = return acc + +splitOnDot :: String -> [String] +splitOnDot [] = [[]] +splitOnDot ('.':xs) = [] : splitOnDot xs +splitOnDot (x:xs) = + let rest = splitOnDot xs + in (x : head rest) : tail rest + +readZfsStats :: DM.Map DevName DevStatData -> IO (DM.Map DevName DevStatData) +readZfsStats acc = do + mainO <- sysctlNameToOid "kstat.zfs" + mainOid <- sysctlExtractOid mainO + (DM.foldr (\x-> DM.insert (devname x) x) acc) <$> (readZfsStat' mainOid mainOid $ DM.empty) + +readDevsStats :: IO (DM.Map DevName DevStatData) +readDevsStats = do + geomStats <- readGeomStats DM.empty + readZfsStats geomStats + +extractDataIO :: DM.Map String DevStatData -> DM.Map String DevStatData -> String -> (DevName, [Float]) +extractDataIO currs prevs disk = (disk, diffStat) + where + diffStat = [sp, rSp, wSp, fromInteger t, fromInteger r, fromInteger w] + r = toInteger $ (readDevStat curr) - (readDevStat prev) + w = toInteger $ (writeDevStat curr) - (writeDevStat prev) + t = r + w + rSp = speed r diffTime + wSp = speed w diffTime + sp = speed t diffTime + curr = DM.findWithDefault defaultDevStatData disk currs + prev = DM.findWithDefault defaultDevStatData disk prevs + diffTime = (devStatTime curr) - (devStatTime prev) + speed :: Integer -> Rational -> Float + speed _ 0 = 0 + speed x d = (fromInteger x) / (realToFrac d) + +fetchDataIO :: DevDataRef -> [(String, String)] -> IO [(DevName, [Float])] +fetchDataIO dref disks = do + currStats <- readDevsStats + prevStats <- readIORef dref + writeIORef dref currStats + return $ map (extractDataIO currStats prevStats) $ mountedOrDiskDevices disks currStats + +fetchDataUsage :: [(String, String)] -> IO [((DevName, Path), [Integer])] +fetchDataUsage disks = Prelude.map extractStat <$> Prelude.filter isReq <$> getMountInfo + where + req = Prelude.map fst disks + isReq :: StatFsData -> Bool + isReq stat = (fsMntOnName stat) `elem` req + || Prelude.drop 5 (fsMntFromName stat) `elem` req + || (fsMntFromName stat) `elem` req + extractStat :: StatFsData -> ((String, String), [Integer]) + extractStat stat = ((fsMntFromName stat, fsMntOnName stat) + , [ + fsStatByteCount stat + , fsStatBytesFree stat + , fsStatBytesUsed stat + ] + ) + +initializeDevDataRef :: [(String, String)] -> IO DevDataRef +initializeDevDataRef _ = do + stats <- readDevsStats + newIORef stats + +mountedOrDiskDevices :: [(DevName, Path)] -> DM.Map String DevStatData -> [DevName] +mountedOrDiskDevices mounted devs = DS.elems $ mountedOrDiskDevices' mountedAcc (DM.keys devs) + where + mountedAcc = mountedOrDiskDevices' DS.empty (map fst mounted) + +mountedOrDiskDevices' :: DS.Set DevName -> [DevName] -> DS.Set DevName +mountedOrDiskDevices' acc [] = acc +mountedOrDiskDevices' acc (x:xs) = mountedOrDiskDevices' (DS.insert x acc) xs diff --git a/src/Xmobar/Plugins/Monitors/Disk/Linux.hs b/src/Xmobar/Plugins/Monitors/Disk/Linux.hs new file mode 100644 index 0000000..aacb648 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk/Linux.hs @@ -0,0 +1,148 @@ +----------------------------------------------------------------------------- +-- | +-- 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 path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [0, 0, 0] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] + +mountedDevices :: [String] -> IO [(DevName, Path)] +mountedDevices req = do + s <- B.readFile "/etc/mtab" + parse `fmap` mapM mbcanon (devs s) + where + mbcanon (d, p) = doesFileExist d >>= \e -> + if e + then Just `fmap` canon (d,p) + else return Nothing + canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} + devs = filter isDev . map (firstTwo . B.words) . B.lines + parse = map undev . filter isReq . catMaybes + firstTwo (a:b:_) = (B.unpack a, B.unpack b) + firstTwo _ = ("", "") + isDev (d, _) = "/dev/" `isPrefixOf` d + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +diskDevices :: [String] -> IO [(DevName, Path)] +diskDevices req = do + s <- B.readFile "/proc/diskstats" + parse `fmap` mapM canon (devs s) + where + canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} + devs = map (third . B.words) . B.lines + parse = map undev . filter isReq + third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c) + third _ = ("", "") + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] +mountedOrDiskDevices req = do + mnt <- mountedDevices req + case mnt of + [] -> diskDevices req + other -> return other + +diskData :: IO [(DevName, [Float])] +diskData = do + s <- B.readFile "/proc/diskstats" + let extract ws = (head ws, map read (tail ws)) + return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) + +mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])] +mountedData dref devs = do + dt <- readIORef dref + dt' <- diskData + writeIORef dref dt' + return $ map (parseDev (zipWith diff dt' dt)) devs + where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) + + +parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) +parseDev dat dev = + case find ((==dev) . fst) dat of + Nothing -> (dev, [0, 0, 0]) + Just (_, xs) -> + let r = 4096 * xs !! 2 + w = 4096 * xs !! 6 + t = r + w + rSp = speed r (xs !! 3) + wSp = speed w (xs !! 7) + sp = speed t (xs !! 3 + xs !! 7) + speed x d = if d == 0 then 0 else x / d + dat' = if length xs > 6 + then [sp, rSp, wSp, t, r, w] + else [0, 0, 0, 0, 0, 0] + in (dev, dat') + +fetchDataIO :: DevDataRef -> [(String, String)] -> IO [(String, [Float])] +fetchDataIO dref disks = do + dev <- mountedOrDiskDevices (map fst disks) + mountedData dref (map fst dev) + +fetchDataUsage :: [(String, String)] -> IO [((String, String), [Integer])] +fetchDataUsage disks = do + devs <- mountedDevices (map fst disks) + mapM fetchStats devs + where + fetchStats :: (String, String) -> IO ((String, String), [Integer]) + fetchStats (dev, path) = do + stats <- handle ign $ fsStats path + return ((dev, path), stats) + ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] + +initializeDevDataRef :: [(String, String)] -> IO DevDataRef +initializeDevDataRef disks = do + dev <- mountedOrDiskDevices (map fst disks) + newIORef (map (\d -> (fst d, repeat 0)) dev) |