Back to app/src, since it seems they're the default convention for stack

1 files changed, 241 insertions, 0 deletions

diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs
new file mode 100644
index 0000000..3f89629
--- /dev/null
+++ b/src/Xmobar/Plugins/Monitors/Disk.hs
@@ -0,0 +1,241 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Plugins.Monitors.Disk
+-- Copyright   :  (c) 2010, 2011, 2012, 2014, 2018 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 (diskUConfig, runDiskU, startDiskIO) where
+
+import Xmobar.Plugins.Monitors.Common
+import Xmobar.System.StatFS
+
+import Data.IORef (IORef, newIORef, readIORef, writeIORef)
+
+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
+
+data DiskIOOpts = DiskIOOpts
+  { totalIconPattern :: Maybe IconPattern
+  , writeIconPattern :: Maybe IconPattern
+  , readIconPattern :: Maybe IconPattern
+  }
+
+parseDiskIOOpts :: [String] -> IO DiskIOOpts
+parseDiskIOOpts argv =
+  case getOpt Permute options argv of
+    (o, _, []) -> return $ foldr id defaultOpts o
+    (_, _, errs) -> ioError . userError $ concat errs
+ where defaultOpts = DiskIOOpts
+          { totalIconPattern = Nothing
+          , writeIconPattern = Nothing
+          , readIconPattern = Nothing
+          }
+       options =
+          [ Option "" ["total-icon-pattern"] (ReqArg (\x o ->
+             o { totalIconPattern = Just $ parseIconPattern x}) "") ""
+          , Option "" ["write-icon-pattern"] (ReqArg (\x o ->
+             o { writeIconPattern = Just $ parseIconPattern x}) "") ""
+          , Option "" ["read-icon-pattern"] (ReqArg (\x o ->
+             o { readIconPattern = Just $ parseIconPattern x}) "") ""
+          ]
+
+diskIOConfig :: IO MConfig
+diskIOConfig = mkMConfig "" ["total", "read", "write"
+                            ,"totalbar", "readbar", "writebar"
+                            ,"totalvbar", "readvbar", "writevbar"
+                            ,"totalipat", "readipat", "writeipat"
+                            ]
+
+data DiskUOpts = DiskUOpts
+  { freeIconPattern :: Maybe IconPattern
+  , usedIconPattern :: Maybe IconPattern
+  }
+
+parseDiskUOpts :: [String] -> IO DiskUOpts
+parseDiskUOpts argv =
+  case getOpt Permute options argv of
+    (o, _, []) -> return $ foldr id defaultOpts o
+    (_, _, errs) -> ioError . userError $ concat errs
+ where defaultOpts = DiskUOpts
+          { freeIconPattern = Nothing
+          , usedIconPattern = Nothing
+          }
+       options =
+          [ Option "" ["free-icon-pattern"] (ReqArg (\x o ->
+             o { freeIconPattern = Just $ parseIconPattern x}) "") ""
+          , Option "" ["used-icon-pattern"] (ReqArg (\x o ->
+             o { usedIconPattern = Just $ parseIconPattern x}) "") ""
+          ]
+
+diskUConfig :: IO MConfig
+diskUConfig = mkMConfig ""
+              [ "size", "free", "used", "freep", "usedp"
+              , "freebar", "freevbar", "freeipat"
+              , "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 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')
+
+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 =
+  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
+  b <- mapM (showLogBar 0.8) xs
+  vb <- mapM (showLogVBar 0.8) xs
+  ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v)
+        $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs
+  setConfigValue tmp template
+  parseTemplate $ s ++ b ++ vb ++ ipat
+
+runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String
+runDiskIO dref disks argv = do
+  opts <- io $ parseDiskIOOpts argv
+  dev <- io $ mountedOrDiskDevices (map fst disks)
+  dat <- io $ mountedData dref (map fst dev)
+  strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat
+  return $ 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)
+  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
+  setConfigValue tmp template
+  [total, free, diff] <-  io (handle ign $ fsStats path)
+  let 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]
+  sp <- showPercentsWithColors [fr, 1 - fr]
+  fb <- showPercentBar (fromIntegral freep) fr
+  fvb <- showVerticalBar (fromIntegral freep) fr
+  fipat <- showIconPattern (freeIconPattern opts) fr
+  ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr)
+  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 $ parseDiskUOpts argv
+  strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs
+  return $ unwords strs