New DiskU and DiskIO monitors

Ignore-this: b72a9ad54c9ae478f2c3fbdcda4d26c8
New monitors for disk usage and throughput, replacing Disk.

darcs-hash:20100204015455-748be-41e03ee9dff0e3e9e3725aae8a3e07c6facb70dc.gz

4 files changed, 195 insertions, 80 deletions

diff --git a/Plugins/Monitors.hs b/Plugins/Monitors.hs
index 4943b69..c8d7e83 100644
--- a/Plugins/Monitors.hs
+++ b/Plugins/Monitors.hs
@@ -37,7 +37,8 @@ data Monitors = Weather  Station    Args Rate
               | MultiCpu Args       Rate
               | Battery  Args       Rate
               | BatteryP [String]   Args Rate
-              | Disk     DiskSpec   Args Rate
+              | DiskU    DiskSpec   Args Rate
+              | DiskIO   DiskSpec   Args Rate
               | Thermal  Zone       Args Rate
               | CpuFreq  Args       Rate
               | CoreTemp Args       Rate
@@ -64,16 +65,18 @@ instance Exec Monitors where
     alias (BatteryP  _ _ _)= "battery"
     alias (CpuFreq    _ _) = "cpufreq"
     alias (CoreTemp   _ _) = "coretemp"
-    alias (Disk     _ _ _) = "disk"
-    start (Weather  s a r) = runM (a ++ [s]) weatherConfig  runWeather  r
-    start (Network  i a r) = runM (a ++ [i]) netConfig      runNet      r
-    start (Thermal  z a r) = runM (a ++ [z]) thermalConfig  runThermal  r
-    start (Memory     a r) = runM a          memConfig      runMem      r
-    start (Swap       a r) = runM a          swapConfig     runSwap     r
-    start (Cpu        a r) = runM a          cpuConfig      runCpu      r
-    start (MultiCpu   a r) = runM a          multiCpuConfig runMultiCpu r
-    start (Battery    a r) = runM a          battConfig     runBatt     r
-    start (BatteryP s a r) = runM a          battConfig    (runBatt' s) r
-    start (CpuFreq    a r) = runM a          cpuFreqConfig  runCpuFreq  r
-    start (CoreTemp   a r) = runM a          coreTempConfig runCoreTemp r
-    start (Disk     s a r) = runM a          diskConfig     (runDisk s) r
+    alias (DiskU    _ _ _) = "disku"
+    alias (DiskIO   _ _ _) = "diskio"
+    start (Weather  s a r) = runM (a ++ [s]) weatherConfig  runWeather    r
+    start (Network  i a r) = runM (a ++ [i]) netConfig      runNet        r
+    start (Thermal  z a r) = runM (a ++ [z]) thermalConfig  runThermal    r
+    start (Memory     a r) = runM a          memConfig      runMem        r
+    start (Swap       a r) = runM a          swapConfig     runSwap       r
+    start (Cpu        a r) = runM a          cpuConfig      runCpu        r
+    start (MultiCpu   a r) = runM a          multiCpuConfig runMultiCpu   r
+    start (Battery    a r) = runM a          battConfig     runBatt       r
+    start (BatteryP s a r) = runM a          battConfig    (runBatt' s)   r
+    start (CpuFreq    a r) = runM a          cpuFreqConfig  runCpuFreq    r
+    start (CoreTemp   a r) = runM a          coreTempConfig runCoreTemp   r
+    start (DiskU    s a r) = runM a          diskUConfig    (runDiskU s)  r
+    start (DiskIO   s a r) = runM a          diskIOConfig   (runDiskIO s) r
diff --git a/Plugins/Monitors/Common.hs b/Plugins/Monitors/Common.hs
index 060a5bc..a102036 100644
--- a/Plugins/Monitors/Common.hs
+++ b/Plugins/Monitors/Common.hs
@@ -36,7 +36,9 @@ module Plugins.Monitors.Common (
                        -- ** String Manipulation
                        -- $strings
                        , showWithColors
+                       , showWithColors'
                        , showPercentsWithColors
+                       , showWithUnits
                        , takeDigits
                        , showDigits
                        , floatToPercent
@@ -291,6 +293,14 @@ showDigits :: Int -> Float -> String
 showDigits d n =
     showFFloat (Just d) n ""
 
+showWithUnits :: Int -> Int -> Float -> String
+showWithUnits d n x
+  | x < 0 = "-" ++ showWithUnits d n (-x)
+  | n > 3 || x < 10^d = show (round x :: Int) ++ units n
+  | x <= 1024 = showDigits d (x/1024) ++ units (n+1)
+  | otherwise = showWithUnits d (n+1) (x/1024)
+  where units = (!!) ["B", "K", "M", "G", "T"]
+
 padString :: Int -> Int -> String -> Bool -> String -> String
 padString mnw mxw pad pr s =
   let len = length s
@@ -339,6 +349,9 @@ showWithColors f x =
               [col normalColor | x > ll ] ++
               [col lowColor    | True]
 
+showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String
+showWithColors' str v = showWithColors (const str) v
+
 showPercentsWithColors :: [Float] -> Monitor [String]
 showPercentsWithColors fs =
   do fstrs <- mapM floatToPercent fs
diff --git a/Plugins/Monitors/Disk.hs b/Plugins/Monitors/Disk.hs
index 4f42218..3a9a70f 100644
--- a/Plugins/Monitors/Disk.hs
+++ b/Plugins/Monitors/Disk.hs
@@ -8,36 +8,41 @@
 -- Stability   :  unstable
 -- Portability :  unportable
 --
--- A disk usage monitor for Xmobar
+--  Disk usage and throughput monitors for Xmobar
 --
 -----------------------------------------------------------------------------
 
-module Plugins.Monitors.Disk (diskConfig, runDisk) where
+module Plugins.Monitors.Disk ( diskUConfig, runDiskU
+                             , diskIOConfig, runDiskIO
+                             ) where
 
-import qualified Data.ByteString.Lazy.Char8 as B
 import Plugins.Monitors.Common
+import Plugins.Monitors.StatFS
+
+import Control.Monad (zipWithM)
+import qualified Data.ByteString.Lazy.Char8 as B
 import Data.List (isPrefixOf, find, intercalate)
-import Numeric (floatToDigits)
 
-diskConfig :: IO MConfig
-diskConfig = mkMConfig "" ["total", "read", "write"]
+diskIOConfig :: IO MConfig
+diskIOConfig = mkMConfig "" ["total", "read", "write"]
+
+diskUConfig :: IO MConfig
+diskUConfig = mkMConfig "" ["size", "free", "used", "freep", "usedp"]
 
 type DevName = String
 type Path = String
 
-mountedDevices :: IO [(DevName, Path)]
-mountedDevices = do
+mountedDevices :: [String] -> IO [(DevName, Path)]
+mountedDevices req = do
   s <- B.readFile "/etc/mtab"
-  return (parseMountedDevices s)
-
-parseMountedDevices :: B.ByteString -> [(DevName, Path)]
-parseMountedDevices =
-  map undev . filter isDev . map (firstTwo . B.words) . B.lines
-    where
-      firstTwo (a:b:_) = (B.unpack a, B.unpack b)
-      firstTwo _ = ("", "")
-      isDev (d, _) = "/dev/" `isPrefixOf` d
-      undev (d, f) = (drop 5 d, f)
+  return (parse s)
+  where
+    parse = map undev . filter isDev . map (firstTwo . B.words) . B.lines
+    firstTwo (a:b:_) = (B.unpack a, B.unpack b)
+    firstTwo _ = ("", "")
+    isDev (d, p) = "/dev/" `isPrefixOf` d &&
+                   (p `elem` req || drop 5 d `elem` req)
+    undev (d, f) = (drop 5 d, f)
 
 diskData :: IO [(DevName, [Float])]
 diskData = do
@@ -45,51 +50,39 @@ diskData = do
   let extract ws = (head ws, map read (tail ws))
   return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s)
 
-mountedData :: [String] -> IO [(DevName, Path, [Float])]
-mountedData xs = do
-  devs <- mountedDevices
+mountedData :: [DevName] -> IO [(DevName, [Float])]
+mountedData devs = do
   (dt, dt') <- doActionTwiceWithDelay 950000 diskData
-  return $ parseData xs devs dt dt'
-
-parseData :: [String] -> [(DevName, Path)]
-             -> [(DevName, [Float])] -> [(DevName, [Float])]
-             -> [(DevName, Path, [Float])]
-parseData reqs mounted dat dat2 =
-  let rm = filter isRequested mounted
-      isRequested (dev, path) = dev `elem` reqs || path `elem` reqs
-      findDat d = find ((==d) .fst)
-      format (dev, path) =
-        let f1 = findDat dev dat
-            f2 = findDat dev dat2
-        in
-         case (f1, f2) of
-          (Just (_, x), Just (_, y)) -> formatDev path (dev, zipWith (-) y x)
-          _ -> (dev, path, [0, 0, 0])
-  in map format rm
-
-formatDev :: Path -> (DevName, [Float]) -> (DevName, Path, [Float])
-formatDev path (dev, xs) =
-  let rSp = speed (xs !! 2) (xs !! 3)
-      wSp = speed (xs !! 6) (xs !! 7)
-      sp =  speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7)
-      speed x t = if t == 0 then 0 else 500 * x / t
-      dat = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0]
-  in (dev, path, dat)
-
-speedToStr :: Int -> Float -> String
-speedToStr n x
-  | n > 2 || x < 103 = show (round x :: Int) ++ units n
-  | x < 1024 = "0." ++ s2 (fst (floatToDigits 10 (x/1024))) ++ units (n+1)
-  | otherwise = speedToStr (n+1) (x/1024)
-  where units = (!!) ["B", "K", "M", "T"]
-        s2 (a:b:_) = show a ++ show b
-        s2 as = show (head as) ++ "0"
-
-runDisk' :: String -> [Float] -> Monitor String
-runDisk' tmp xs = do
-  setConfigValue tmp template
-  s <- mapM (showWithColors (speedToStr 1)) xs
-  parseTemplate s
+  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 rSp = speed (xs !! 2) (xs !! 3)
+          wSp = speed (xs !! 6) (xs !! 7)
+          sp =  speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7)
+          speed x t = if t == 0 then 0 else 500 * x / t
+          dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0]
+      in (dev, dat')
+
+fsStats :: String -> IO [Integer]
+fsStats path = do
+  stats <- getFileSystemStats path
+  case stats of
+    Nothing -> return [-1, -1, -1]
+    Just f -> let tot = fsStatByteCount f
+                  free = fsStatBytesAvailable f
+                  used = fsStatBytesUsed f
+              in return [tot, free, used]
+
+speedToStr :: Float -> String
+speedToStr = showWithUnits 2 1
+
+sizeToStr :: Integer -> String
+sizeToStr = showWithUnits 3 0 . fromIntegral
 
 findTempl :: DevName -> Path -> [(String, String)] -> String
 findTempl dev path disks =
@@ -98,8 +91,42 @@ findTempl dev path disks =
     Nothing -> ""
   where devOrPath (d, _) = d == dev || d == path
 
-runDisk :: [(String, String)] -> [String] -> Monitor String
-runDisk disks _ = do
-  dat <- io $ mountedData (map fst disks)
-  strs <- mapM (\(d, p, xs) -> runDisk' (findTempl d p disks) xs) dat
+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' :: (String, [Float]) -> Monitor String
+runDiskIO' (tmp, xs) = do
+  s <- mapM (showWithColors speedToStr) xs
+  setConfigValue tmp template
+  parseTemplate s
+
+runDiskIO :: [(String, String)] -> [String] -> Monitor String
+runDiskIO disks _ = do
+  mounted <- io $ mountedDevices (map fst disks)
+  dat <- io $ mountedData (map fst mounted)
+  strs <- mapM runDiskIO' $ devTemplates disks mounted dat
+  return $ intercalate " " strs
+
+runDiskU' :: String -> String -> Monitor String
+runDiskU' tmp path = do
+  setConfigValue tmp template
+  fstats <- io $ fsStats path
+  let strs = map sizeToStr fstats
+      freep = (fstats !! 1) * 100 `div` head fstats
+      fr = fromIntegral freep / 100
+  s <- zipWithM showWithColors' strs [100, freep, 100 - freep]
+  sp <- showPercentsWithColors [fr, 1 - fr]
+  parseTemplate $ s ++ sp
+
+runDiskU :: [(String, String)] -> [String] -> Monitor String
+runDiskU disks _ = do
+  devs <- io $ mountedDevices (map fst disks)
+  strs <- mapM (\(d, p) -> runDiskU' (findTempl d p disks) p) devs
   return $ intercalate " " strs
diff --git a/Plugins/Monitors/StatFS.hsc b/Plugins/Monitors/StatFS.hsc
new file mode 100644
index 0000000..ad3b659
--- /dev/null
+++ b/Plugins/Monitors/StatFS.hsc
@@ -0,0 +1,72 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.StatFS
+-- Copyright   :  (c) Jose A Ortega Ruiz
+-- License     :  BSD-style (see LICENSE)
+--
+-- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org>
+-- Stability   :  unstable
+-- Portability :  unportable
+--
+--  A binding to C's statvfs(2)
+--
+-----------------------------------------------------------------------------
+
+{-# LANGUAGE CPP, ForeignFunctionInterface, EmptyDataDecls #-}
+
+
+module Plugins.Monitors.StatFS (FileSystemStats(..), getFileSystemStats) where
+
+import Foreign
+import Foreign.C.Types
+import Foreign.C.String
+import Foreign.Storable
+import Data.ByteString (useAsCString)
+import Data.ByteString.Char8 (pack)
+
+#include <sys/vfs.h>
+
+data FileSystemStats = FileSystemStats {
+  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, Eq)
+
+data CStatfs
+
+foreign import ccall unsafe "sys/vfs.h statfs64"
+  c_statfs :: CString -> Ptr CStatfs -> IO CInt
+
+toI :: CLong -> Integer
+toI = toInteger
+
+getFileSystemStats :: String -> IO (Maybe FileSystemStats)
+getFileSystemStats path =
+  allocaBytes (#size struct statfs) $ \vfs ->
+  useAsCString (pack path) $ \cpath -> do
+    res <- c_statfs cpath vfs
+    case res of
+      -1 -> return Nothing
+      _  -> do
+        bsize <- (#peek struct statfs, f_bsize) vfs
+        bcount <- (#peek struct statfs, f_blocks) vfs
+        bfree <- (#peek struct statfs, f_bfree) vfs
+        bavail <- (#peek struct statfs, f_bavail) vfs
+        let bpb = toI bsize
+        return $ Just FileSystemStats
+                       { fsStatBlockSize = bpb
+                       , fsStatBlockCount = toI bcount
+                       , fsStatByteCount = toI bcount * bpb
+                       , fsStatBytesFree = toI bfree * bpb
+                       , fsStatBytesAvailable = toI bavail * bpb
+                       , fsStatBytesUsed = toI (bcount - bfree) * bpb
+                       }