{-# LANGUAGE OverloadedStrings #-}
module Xmobar.Plugins.Monitors.Net (
startNet
, startDynNet
) where
import Xmobar.Plugins.Monitors.Common
import Data.IORef (IORef, newIORef, readIORef, writeIORef)
import Data.Monoid ((<>))
import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)
import Data.Word (Word64)
import Control.Monad (forM, filterM)
import System.Directory (getDirectoryContents, doesFileExist)
import System.FilePath ((</>))
import System.Console.GetOpt
import System.IO.Error (catchIOError)
import System.IO.Unsafe (unsafeInterleaveIO)
import qualified Data.ByteString.Char8 as B
type DevList = [String]
parseDevList :: String -> DevList
parseDevList = splitOnComma
where splitOnComma [] = [[]]
splitOnComma (',':xs) = [] : splitOnComma xs
splitOnComma (x:xs) =
let rest = splitOnComma xs
in (x : head rest) : tail rest
data NetOpts = NetOpts
{ rxIconPattern :: Maybe IconPattern
, txIconPattern :: Maybe IconPattern
, onlyDevList :: Maybe DevList
}
defaultOpts :: NetOpts
defaultOpts = NetOpts
{ rxIconPattern = Nothing
, txIconPattern = Nothing
, onlyDevList = Nothing
}
options :: [OptDescr (NetOpts -> NetOpts)]
options =
[ Option "" ["rx-icon-pattern"] (ReqArg (\x o ->
o { rxIconPattern = Just $ parseIconPattern x }) "") ""
, Option "" ["tx-icon-pattern"] (ReqArg (\x o ->
o { txIconPattern = Just $ parseIconPattern x }) "") ""
, Option "" ["devices"] (ReqArg (\x o ->
o { onlyDevList = Just $ parseDevList x }) "") ""
]
parseOpts :: [String] -> IO NetOpts
parseOpts argv =
case getOpt Permute options argv of
(o, _, []) -> return $ foldr id defaultOpts o
(_, _, errs) -> ioError . userError $ concat errs
data UnitPerSec = Bs | KBs | MBs | GBs deriving (Eq,Enum,Ord)
data NetValue = NetValue Float UnitPerSec deriving (Eq,Show)
instance Show UnitPerSec where
show Bs = "B/s"
show KBs = "KB/s"
show MBs = "MB/s"
show GBs = "GB/s"
data NetDev num = N String (NetDevInfo num) | NA deriving (Eq,Show,Read)
data NetDevInfo num = NI | ND num num deriving (Eq,Show,Read)
type NetDevRawTotal = NetDev Word64
type NetDevRate = NetDev Float
type NetDevRef = IORef (NetDevRawTotal, UTCTime)
instance Ord num => Ord (NetDev num) where
compare NA NA = EQ
compare NA _ = LT
compare _ NA = GT
compare (N _ i1) (N _ i2) = i1 `compare` i2
instance Ord num => Ord (NetDevInfo num) where
compare NI NI = EQ
compare NI ND {} = LT
compare ND {} NI = GT
compare (ND x1 y1) (ND x2 y2) = x1 `compare` x2 <> y1 `compare` y2
netConfig :: IO MConfig
netConfig = mkMConfig
"<dev>: <rx>KB|<tx>KB"
["dev", "rx", "tx", "rxbar", "rxvbar", "rxipat", "txbar", "txvbar", "txipat"]
operstateDir :: String -> FilePath
operstateDir d = "/sys/class/net" </> d </> "operstate"
existingDevs :: IO [String]
existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev
where isDev d | d `elem` excludes = return False
| otherwise = doesFileExist (operstateDir d)
excludes = [".", "..", "lo"]
isUp :: String -> IO Bool
isUp d = flip catchIOError (const $ return False) $ do
operstate <- B.readFile (operstateDir d)
return $! (head . B.lines) operstate `elem` ["up", "unknown"]
readNetDev :: [String] -> IO NetDevRawTotal
readNetDev ~[d, x, y] = do
up <- unsafeInterleaveIO $ isUp d
return $ N d (if up then ND (r x) (r y) else NI)
where r s | s == "" = 0
| otherwise = read s
netParser :: B.ByteString -> IO [NetDevRawTotal]
netParser = mapM (readNetDev . splitDevLine) . readDevLines
where readDevLines = drop 2 . B.lines
splitDevLine = map B.unpack . selectCols . filter (not . B.null) . B.splitWith (`elem` [' ',':'])
selectCols cols = map (cols!!) [0,1,9]
findNetDev :: String -> IO NetDevRawTotal
findNetDev dev = do
nds <- B.readFile "/proc/net/dev" >>= netParser
case filter isDev nds of
x:_ -> return x
_ -> return NA
where isDev (N d _) = d == dev
isDev NA = False
formatNet :: Maybe IconPattern -> Float -> Monitor (String, String, String, String)
formatNet mipat d = do
s <- getConfigValue useSuffix
dd <- getConfigValue decDigits
let str True v = showDigits dd d' ++ show u
where (NetValue d' u) = byteNetVal v
str False v = showDigits dd $ v / 1024
b <- showLogBar 0.9 d
vb <- showLogVBar 0.9 d
ipat <- showLogIconPattern mipat 0.9 d
x <- showWithColors (str s) d
return (x, b, vb, ipat)
printNet :: NetOpts -> NetDevRate -> Monitor String
printNet opts nd =
case nd of
N d (ND r t) -> do
(rx, rb, rvb, ripat) <- formatNet (rxIconPattern opts) r
(tx, tb, tvb, tipat) <- formatNet (txIconPattern opts) t
parseTemplate [d,rx,tx,rb,rvb,ripat,tb,tvb,tipat]
N _ NI -> return ""
NA -> getConfigValue naString
parseNet :: NetDevRef -> String -> IO NetDevRate
parseNet nref nd = do
(n0, t0) <- readIORef nref
n1 <- findNetDev nd
t1 <- getCurrentTime
writeIORef nref (n1, t1)
let scx = realToFrac (diffUTCTime t1 t0)
scx' = if scx > 0 then scx else 1
rate da db = takeDigits 2 $ fromIntegral (db - da) / scx'
diffRate (N d (ND ra ta)) (N _ (ND rb tb)) = N d (ND (rate ra rb) (rate ta tb))
diffRate (N d NI) _ = N d NI
diffRate _ (N d NI) = N d NI
diffRate _ _ = NA
return $ diffRate n0 n1
runNet :: NetDevRef -> String -> [String] -> Monitor String
runNet nref i argv = do
dev <- io $ parseNet nref i
opts <- io $ parseOpts argv
printNet opts dev
parseNets :: [(NetDevRef, String)] -> IO [NetDevRate]
parseNets = mapM $ uncurry parseNet
runNets :: [(NetDevRef, String)] -> [String] -> Monitor String
runNets refs argv = do
opts <- io $ parseOpts argv
dev <- io $ parseActive $ filterRefs opts refs
printNet opts dev
where parseActive refs' = fmap selectActive (parseNets refs')
refInDevList opts' (_, refname') = case onlyDevList opts' of
Just theList -> refname' `elem` theList
Nothing -> True
filterRefs opts' refs' = case filter (refInDevList opts') refs' of
[] -> refs'
xs -> xs
selectActive = maximum
startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO ()
startNet i a r cb = do
t0 <- getCurrentTime
nref <- newIORef (NA, t0)
_ <- parseNet nref i
runM a netConfig (runNet nref i) r cb
startDynNet :: [String] -> Int -> (String -> IO ()) -> IO ()
startDynNet a r cb = do
devs <- existingDevs
refs <- forM devs $ \d -> do
t <- getCurrentTime
nref <- newIORef (NA, t)
_ <- parseNet nref d
return (nref, d)
runM a netConfig (runNets refs) r cb
byteNetVal :: Float -> NetValue
byteNetVal v
| v < 1024**1 = NetValue v Bs
| v < 1024**2 = NetValue (v/1024**1) KBs
| v < 1024**3 = NetValue (v/1024**2) MBs
| otherwise = NetValue (v/1024**3) GBs