add disk monitor for freebsd

1 files changed, 41 insertions, 124 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