diff options
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Disk.hs | 165 | ||||
| -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 | ||||
| -rw-r--r-- | src/Xmobar/Plugins/Monitors/Net/FreeBSD.hsc | 1 | ||||
| -rw-r--r-- | xmobar.cabal | 4 |
6 files changed, 617 insertions, 125 deletions
diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs index debc522..47d1eac 100644 --- a/src/Xmobar/Plugins/Monitors/Disk.hs +++ b/src/Xmobar/Plugins/Monitors/Disk.hs @@ -12,20 +12,25 @@ -- ----------------------------------------------------------------------------- +{-# LANGUAGE CPP #-} + module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where import Xmobar.Plugins.Monitors.Common -import Xmobar.System.StatFS - -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +#if defined(freebsd_HOST_OS) +import qualified Xmobar.Plugins.Monitors.Disk.FreeBSD as MD +#else +import qualified Xmobar.Plugins.Monitors.Disk.Linux as MD +#endif -import Control.Exception (SomeException, handle) import Control.Monad (zipWithM) -import qualified Data.ByteString.Lazy.Char8 as B -import Data.List (isPrefixOf, find) -import Data.Maybe (catMaybes) -import System.Directory (canonicalizePath, doesFileExist) import System.Console.GetOpt +import Data.List (find) + +import Xmobar.Plugins.Monitors.Disk.Common ( + DevName + , Path + ) data DiskIOOpts = DiskIOOpts { totalIconPattern :: Maybe IconPattern @@ -93,103 +98,12 @@ diskUConfig = mkMConfig "" , "usedbar", "usedvbar", "usedipat" ] -type DevName = String -type Path = String -type DevDataRef = IORef [(DevName, [Float])] - -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') - speedToStr :: Float -> String speedToStr = showWithUnits 2 1 . (/ 1024) sizeToStr :: Integer -> String sizeToStr = showWithUnits 3 0 . fromIntegral -findTempl :: DevName -> Path -> [(String, String)] -> String -findTempl dev path disks = - case find devOrPath disks of - Just (_, t) -> t - Nothing -> "" - where devOrPath (d, _) = d == dev || d == path - -devTemplates :: [(String, String)] - -> [(DevName, Path)] - -> [(DevName, [Float])] - -> [(String, [Float])] -devTemplates disks mounted dat = - map (\(d, p) -> (findTempl d p disks, findData d)) mounted - where findData dev = case find ((==dev) . fst) dat of - Nothing -> [0, 0, 0] - Just (_, xs) -> xs - runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String runDiskIO' opts (tmp, xs) = do s <- mapM (showWithColors speedToStr) xs @@ -202,37 +116,25 @@ runDiskIO' opts (tmp, xs) = do setConfigValue tmp template parseTemplate $ s ++ b ++ vb ++ ipat -runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String +runDiskIO :: MD.DevDataRef -> [(String, String)] -> [String] -> Monitor String runDiskIO dref disks argv = do opts <- io $ parseOptsWith dioOptions dioDefaultOpts argv - dev <- io $ mountedOrDiskDevices (map fst disks) - dat <- io $ mountedData dref (map fst dev) - strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat + stats <- io $ MD.fetchDataIO dref disks + mounted <- io $ MD.fetchDataUsage disks + strs <- mapM (runDiskIO' opts) $ devTemplates disks (map fst mounted) stats return $ (if contiguous opts then concat else unwords) strs startDiskIO :: [(String, String)] -> [String] -> Int -> (String -> IO ()) -> IO () startDiskIO disks args rate cb = do - dev <- mountedOrDiskDevices (map fst disks) - dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) - _ <- mountedData dref (map fst dev) + dref <- MD.initializeDevDataRef disks runM args diskIOConfig (runDiskIO dref disks) rate cb -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] - -runDiskU' :: DiskUOpts -> String -> String -> Monitor String -runDiskU' opts tmp path = do +runDiskU' :: DiskUOpts -> String -> [Integer] -> Monitor String +runDiskU' opts tmp stat = do setConfigValue tmp template - [total, free, diff] <- io (handle ign $ fsStats path) - let strs = map sizeToStr [free, diff] + let [total, free, diff] = stat + strs = map sizeToStr [free, diff] freep = if total > 0 then free * 100 `div` total else 0 fr = fromIntegral freep / 100 s <- zipWithM showWithColors' strs [freep, 100 - freep] @@ -244,12 +146,27 @@ runDiskU' opts tmp path = do uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) uipat <- showIconPattern (usedIconPattern opts) (1 - fr) parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] - where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] - runDiskU :: [(String, String)] -> [String] -> Monitor String runDiskU disks argv = do - devs <- io $ mountedDevices (map fst disks) opts <- io $ parseOptsWith duOptions duDefaultOpts argv - strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs + stats <- io $ MD.fetchDataUsage disks + strs <- mapM (\((d, p), stat) -> runDiskU' opts (findTempl d p disks) stat) stats return $ (if contiguousU opts then concat else unwords) strs + +findTempl :: DevName -> Path -> [(String, String)] -> String +findTempl dev path disks = + case find devOrPath disks of + Just (_, t) -> t + Nothing -> "" + where devOrPath (d, _) = d == dev || d == path + +devTemplates :: [(String, String)] + -> [(DevName, Path)] + -> [(DevName, [Float])] + -> [(String, [Float])] +devTemplates disks mounted dat = + map (\(d, p) -> (findTempl d p disks, findData d)) mounted + where findData dev = case find ((==dev) . fst) dat of + Nothing -> [0, 0, 0] + Just (_, xs) -> xs 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) diff --git a/src/Xmobar/Plugins/Monitors/Net/FreeBSD.hsc b/src/Xmobar/Plugins/Monitors/Net/FreeBSD.hsc index ab446e3..4d6c144 100644 --- a/src/Xmobar/Plugins/Monitors/Net/FreeBSD.hsc +++ b/src/Xmobar/Plugins/Monitors/Net/FreeBSD.hsc @@ -29,7 +29,6 @@ import Control.Exception (catch, SomeException(..)) import Foreign (Int32, plusPtr) import Foreign.C.Types (CUIntMax, CUChar) import Foreign.C.String (peekCString) -import Foreign.ForeignPtr () import Foreign.Storable (Storable, alignment, sizeOf, peek, poke) import System.BSD.Sysctl (OID, sysctlPrepareOid, sysctlReadInt, sysctlPeek) diff --git a/xmobar.cabal b/xmobar.cabal index bcb70f9..3799d64 100644 --- a/xmobar.cabal +++ b/xmobar.cabal @@ -159,6 +159,7 @@ library Xmobar.Plugins.Monitors.Cpu.Common, Xmobar.Plugins.Monitors.CpuFreq, Xmobar.Plugins.Monitors.Disk, + Xmobar.Plugins.Monitors.Disk.Common, Xmobar.Plugins.Monitors.Mem, Xmobar.Plugins.Monitors.MultiCoreTemp, Xmobar.Plugins.Monitors.MultiCpu, @@ -297,9 +298,11 @@ library -- enables freebsd specific code extra-libraries: procstat , kvm + , geom build-depends: bsd-sysctl other-modules: Xmobar.Plugins.Monitors.Batt.FreeBSD, Xmobar.Plugins.Monitors.Cpu.FreeBSD, + Xmobar.Plugins.Monitors.Disk.FreeBSD, Xmobar.Plugins.Monitors.Mem.FreeBSD, Xmobar.Plugins.Monitors.Net.FreeBSD, Xmobar.Plugins.Monitors.Swap.FreeBSD, @@ -308,6 +311,7 @@ library else other-modules: Xmobar.Plugins.Monitors.Batt.Linux, Xmobar.Plugins.Monitors.Cpu.Linux, + Xmobar.Plugins.Monitors.Disk.Linux, Xmobar.Plugins.Monitors.Mem.Linux, Xmobar.Plugins.Monitors.Net.Linux, Xmobar.Plugins.Monitors.Swap.Linux, |