{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module System.Taffybar.NetMonitor (
netMonitorNew,
netMonitorNewWith,
netMonitorMultiNew,
netMonitorMultiNewWith,
defaultNetFormat
) where
import Data.IORef
import Graphics.UI.Gtk
import System.Information.Network (getNetInfo)
import System.Taffybar.Widgets.PollingLabel
import Text.Printf (printf)
import Text.StringTemplate
import Data.Maybe (catMaybes)
import qualified Data.Traversable as T
defaultNetFormat :: String
defaultNetFormat = "▼ $inAuto$ ▲ $outAuto$"
netMonitorNew :: Double
-> String
-> IO Widget
netMonitorNew interval interface = netMonitorMultiNew interval [interface]
netMonitorNewWith :: Double
-> String
-> Int
-> String
-> IO Widget
netMonitorNewWith interval interface prec template = netMonitorMultiNewWith interval [interface] prec template
netMonitorMultiNew :: Double
-> [String]
-> IO Widget
netMonitorMultiNew interval interfaces = netMonitorMultiNewWith interval interfaces 3 defaultNetFormat
netMonitorMultiNewWith :: Double
-> [String]
-> Int
-> String
-> IO Widget
netMonitorMultiNewWith interval interfaces prec template = do
interfaceRefs <- T.forM interfaces $ \i -> (i,) <$> newIORef (0, 0)
let showResult = showInfo template prec <$> calculateNetUse interfaceRefs
label <- pollingLabelNew "" interval showResult
widgetShowAll label
return (toWidget label)
where
calculateNetUse ifaceRefs = do
mIfaceInfos <- T.forM ifaceRefs $ \(i, ref) -> do
mIfaceInfo <- getNetInfo i
return $ fmap (\ifaceInfo -> (ref, ifaceInfo)) mIfaceInfo
speeds <- T.forM (catMaybes mIfaceInfos) $ \(ref, ifaceInfo) -> do
let ii = case ifaceInfo of
[info1, info2] -> (info1, info2)
_ -> (0, 0)
calcSpeed interval ref ii
return $ foldr (\(d, u) (dsum, usum) -> (dsum + d, usum + u)) (0, 0) speeds
calcSpeed :: Double -> IORef (Int, Int) -> (Int, Int) -> IO (Double, Double)
calcSpeed interval sample result@(r1, r2) = do
(s1, s2) <- readIORef sample
writeIORef sample result
return (max 0 (fromIntegral (r1 - s1) / interval), max 0 (fromIntegral (r2 - s2) / interval))
showInfo :: String -> Int -> (Double, Double) -> String
showInfo template prec (incomingb, outgoingb) =
let
attribs = [ ("inB", show incomingb)
, ("inKB", toKB prec incomingb)
, ("inMB", toMB prec incomingb)
, ("inAuto", toAuto prec incomingb)
, ("outB", show outgoingb)
, ("outKB", toKB prec outgoingb)
, ("outMB", toMB prec outgoingb)
, ("outAuto", toAuto prec outgoingb)
]
in
render . setManyAttrib attribs $ newSTMP template
toKB :: Int -> Double -> String
toKB prec = setDigits prec . (/1024)
toMB :: Int -> Double -> String
toMB prec = setDigits prec . (/ (1024 * 1024))
setDigits :: Int -> Double -> String
setDigits dig a = printf format a
where format = "%." ++ show dig ++ "f"
toAuto :: Int -> Double -> String
toAuto prec value = printf "%.*f%s" p v unit
where value' = max 0 value
mag :: Int
mag = if value' == 0 then 0 else max 0 $ min 4 $ floor $ logBase 1024 value'
v = value' / 1024 ** fromIntegral mag
unit = case mag of
0 -> "B/s"
1 -> "KiB/s"
2 -> "MiB/s"
3 -> "GiB/s"
4 -> "TiB/s"
_ -> "??B/s"
p :: Int
p = max 0 $ floor $ fromIntegral prec - logBase 10 v