summaryrefslogtreecommitdiffhomepage
path: root/src/Plugins/Monitors/Common.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Plugins/Monitors/Common.hs')
-rw-r--r--src/Plugins/Monitors/Common.hs446
1 files changed, 446 insertions, 0 deletions
diff --git a/src/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs
new file mode 100644
index 0000000..cc1a6a7
--- /dev/null
+++ b/src/Plugins/Monitors/Common.hs
@@ -0,0 +1,446 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Plugins.Monitors.Common
+-- Copyright : (c) Andrea Rossato
+-- License : BSD-style (see LICENSE)
+--
+-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org>
+-- Stability : unstable
+-- Portability : unportable
+--
+-- Utilities for creating monitors for Xmobar
+--
+-----------------------------------------------------------------------------
+
+module Plugins.Monitors.Common (
+ -- * Monitors
+ -- $monitor
+ Monitor
+ , MConfig (..)
+ , Opts (..)
+ , setConfigValue
+ , getConfigValue
+ , mkMConfig
+ , runM
+ , io
+ -- * Parsers
+ -- $parsers
+ , runP
+ , skipRestOfLine
+ , getNumbers
+ , getNumbersAsString
+ , getAllBut
+ , getAfterString
+ , skipTillString
+ , parseTemplate
+ -- ** String Manipulation
+ -- $strings
+ , padString
+ , showWithPadding
+ , showWithColors
+ , showWithColors'
+ , showPercentWithColors
+ , showPercentsWithColors
+ , showPercentBar
+ , showLogBar
+ , showWithUnits
+ , takeDigits
+ , showDigits
+ , floatToPercent
+ , parseFloat
+ , parseInt
+ , stringParser
+ -- * Threaded Actions
+ -- $thread
+ , doActionTwiceWithDelay
+ , catRead
+ ) where
+
+
+import Control.Concurrent
+import Control.Monad.Reader
+import qualified Data.ByteString.Lazy.Char8 as B
+import Data.IORef
+import qualified Data.Map as Map
+import Data.List
+import Numeric
+import Text.ParserCombinators.Parsec
+import System.Console.GetOpt
+import Control.Exception (SomeException,handle)
+import System.Process (readProcess)
+
+import Plugins
+-- $monitor
+
+type Monitor a = ReaderT MConfig IO a
+
+data MConfig =
+ MC { normalColor :: IORef (Maybe String)
+ , low :: IORef Int
+ , lowColor :: IORef (Maybe String)
+ , high :: IORef Int
+ , highColor :: IORef (Maybe String)
+ , template :: IORef String
+ , export :: IORef [String]
+ , ppad :: IORef Int
+ , minWidth :: IORef Int
+ , maxWidth :: IORef Int
+ , padChars :: IORef String
+ , padRight :: IORef Bool
+ , barBack :: IORef String
+ , barFore :: IORef String
+ , barWidth :: IORef Int
+ , useSuffix :: IORef Bool
+ }
+
+-- | from 'http:\/\/www.haskell.org\/hawiki\/MonadState'
+type Selector a = MConfig -> IORef a
+
+sel :: Selector a -> Monitor a
+sel s =
+ do hs <- ask
+ liftIO $ readIORef (s hs)
+
+mods :: Selector a -> (a -> a) -> Monitor ()
+mods s m =
+ do v <- ask
+ io $ modifyIORef (s v) m
+
+setConfigValue :: a -> Selector a -> Monitor ()
+setConfigValue v s =
+ mods s (\_ -> v)
+
+getConfigValue :: Selector a -> Monitor a
+getConfigValue = sel
+
+mkMConfig :: String
+ -> [String]
+ -> IO MConfig
+mkMConfig tmpl exprts =
+ do lc <- newIORef Nothing
+ l <- newIORef 33
+ nc <- newIORef Nothing
+ h <- newIORef 66
+ hc <- newIORef Nothing
+ t <- newIORef tmpl
+ e <- newIORef exprts
+ p <- newIORef 0
+ mn <- newIORef 0
+ mx <- newIORef 0
+ pc <- newIORef " "
+ pr <- newIORef False
+ bb <- newIORef ":"
+ bf <- newIORef "#"
+ bw <- newIORef 10
+ up <- newIORef False
+ return $ MC nc l lc h hc t e p mn mx pc pr bb bf bw up
+
+data Opts = HighColor String
+ | NormalColor String
+ | LowColor String
+ | Low String
+ | High String
+ | Template String
+ | PercentPad String
+ | MinWidth String
+ | MaxWidth String
+ | Width String
+ | PadChars String
+ | PadAlign String
+ | BarBack String
+ | BarFore String
+ | BarWidth String
+ | UseSuffix String
+
+options :: [OptDescr Opts]
+options =
+ [ Option "H" ["High"] (ReqArg High "number" ) "The high threshold"
+ , Option "L" ["Low"] (ReqArg Low "number" ) "The low threshold"
+ , Option "h" ["high"] (ReqArg HighColor "color number" ) "Color for the high threshold: ex \"#FF0000\""
+ , Option "n" ["normal"] (ReqArg NormalColor "color number" ) "Color for the normal threshold: ex \"#00FF00\""
+ , Option "l" ["low"] (ReqArg LowColor "color number" ) "Color for the low threshold: ex \"#0000FF\""
+ , Option "t" ["template"] (ReqArg Template "output template" ) "Output template."
+ , Option "S" ["suffix"] (ReqArg UseSuffix "True/False" ) "Use % to display percents or other suffixes."
+ , Option "p" ["ppad"] (ReqArg PercentPad "percent padding") "Minimum percentage width."
+ , Option "m" ["minwidth"] (ReqArg MinWidth "minimum width" ) "Minimum field width"
+ , Option "M" ["maxwidth"] (ReqArg MaxWidth "maximum width" ) "Maximum field width"
+ , Option "w" ["width"] (ReqArg Width "fixed width" ) "Fixed field width"
+ , Option "c" ["padchars"] (ReqArg PadChars "padding chars" ) "Characters to use for padding"
+ , Option "a" ["align"] (ReqArg PadAlign "padding alignment") "'l' for left padding, 'r' for right"
+ , Option "b" ["bback"] (ReqArg BarBack "bar background" ) "Characters used to draw bar backgrounds"
+ , Option "f" ["bfore"] (ReqArg BarFore "bar foreground" ) "Characters used to draw bar foregrounds"
+ , Option "W" ["bwidth"] (ReqArg BarWidth "bar width" ) "Bar width"
+ ]
+
+doArgs :: [String]
+ -> ([String] -> Monitor String)
+ -> Monitor String
+doArgs args action =
+ case getOpt Permute options args of
+ (o, n, []) -> do doConfigOptions o
+ action n
+ (_, _, errs) -> return (concat errs)
+
+doConfigOptions :: [Opts] -> Monitor ()
+doConfigOptions [] = io $ return ()
+doConfigOptions (o:oo) =
+ do let next = doConfigOptions oo
+ nz s = let x = read s in max 0 x
+ bool = (`elem` ["True", "true", "Yes", "yes", "On", "on"])
+ (case o of
+ High h -> setConfigValue (read h) high
+ Low l -> setConfigValue (read l) low
+ HighColor c -> setConfigValue (Just c) highColor
+ NormalColor c -> setConfigValue (Just c) normalColor
+ LowColor c -> setConfigValue (Just c) lowColor
+ Template t -> setConfigValue t template
+ PercentPad p -> setConfigValue (nz p) ppad
+ MinWidth w -> setConfigValue (nz w) minWidth
+ MaxWidth w -> setConfigValue (nz w) maxWidth
+ Width w -> setConfigValue (nz w) minWidth >>
+ setConfigValue (nz w) maxWidth
+ PadChars s -> setConfigValue s padChars
+ PadAlign a -> setConfigValue ("r" `isPrefixOf` a) padRight
+ BarBack s -> setConfigValue s barBack
+ BarFore s -> setConfigValue s barFore
+ BarWidth w -> setConfigValue (nz w) barWidth
+ UseSuffix u -> setConfigValue (bool u) useSuffix) >> next
+
+runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int
+ -> (String -> IO ()) -> IO ()
+runM args conf action r cb = handle (cb . showException) loop
+ where ac = doArgs args action
+ loop = conf >>= runReaderT ac >>= cb >> tenthSeconds r >> loop
+
+showException :: SomeException -> String
+showException = ("error: "++) . show . flip asTypeOf undefined
+
+io :: IO a -> Monitor a
+io = liftIO
+
+-- $parsers
+
+runP :: Parser [a] -> String -> IO [a]
+runP p i =
+ case parse p "" i of
+ Left _ -> return []
+ Right x -> return x
+
+getAllBut :: String -> Parser String
+getAllBut s =
+ manyTill (noneOf s) (char $ head s)
+
+getNumbers :: Parser Float
+getNumbers = skipMany space >> many1 digit >>= \n -> return $ read n
+
+getNumbersAsString :: Parser String
+getNumbersAsString = skipMany space >> many1 digit >>= \n -> return n
+
+skipRestOfLine :: Parser Char
+skipRestOfLine =
+ do many $ noneOf "\n\r"
+ newline
+
+getAfterString :: String -> Parser String
+getAfterString s =
+ do { try $ manyTill skipRestOfLine $ string s
+ ; manyTill anyChar newline
+ } <|> return ""
+
+skipTillString :: String -> Parser String
+skipTillString s =
+ manyTill skipRestOfLine $ string s
+
+-- | Parses the output template string
+templateStringParser :: Parser (String,String,String)
+templateStringParser =
+ do { s <- nonPlaceHolder
+ ; com <- templateCommandParser
+ ; ss <- nonPlaceHolder
+ ; return (s, com, ss)
+ }
+ where
+ nonPlaceHolder = liftM concat . many $
+ many1 (noneOf "<") <|> colorSpec
+
+-- | Recognizes color specification and returns it unchanged
+colorSpec :: Parser String
+colorSpec = try (string "</fc>") <|> try (
+ do string "<fc="
+ s <- many1 (alphaNum <|> char ',' <|> char '#')
+ char '>'
+ return $ "<fc=" ++ s ++ ">")
+
+-- | Parses the command part of the template string
+templateCommandParser :: Parser String
+templateCommandParser =
+ do { char '<'
+ ; com <- many $ noneOf ">"
+ ; char '>'
+ ; return com
+ }
+
+-- | Combines the template parsers
+templateParser :: Parser [(String,String,String)]
+templateParser = many templateStringParser --"%")
+
+-- | Takes a list of strings that represent the values of the exported
+-- keys. The strings are joined with the exported keys to form a map
+-- to be combined with 'combine' to the parsed template. Returns the
+-- final output of the monitor.
+parseTemplate :: [String] -> Monitor String
+parseTemplate l =
+ do t <- getConfigValue template
+ s <- io $ runP templateParser t
+ e <- getConfigValue export
+ let m = Map.fromList . zip e $ l
+ return $ combine m s
+
+-- | Given a finite "Map" and a parsed templatet produces the
+-- | resulting output string.
+combine :: Map.Map String String -> [(String, String, String)] -> String
+combine _ [] = []
+combine m ((s,ts,ss):xs) =
+ s ++ str ++ ss ++ combine m xs
+ where str = Map.findWithDefault err ts m
+ err = "<" ++ ts ++ " not found!>"
+
+-- $strings
+
+type Pos = (Int, Int)
+
+takeDigits :: Int -> Float -> Float
+takeDigits d n =
+ fromIntegral (round (n * fact) :: Int) / fact
+ where fact = 10 ^ d
+
+showDigits :: (RealFloat a) => Int -> a -> 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 + 1) = 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
+ rmin = if mnw <= 0 then 1 else mnw
+ rmax = if mxw <= 0 then max len rmin else mxw
+ (rmn, rmx) = if rmin <= rmax then (rmin, rmax) else (rmax, rmin)
+ rlen = min (max rmn len) rmx
+ in if rlen < len then
+ take rlen s
+ else let ps = take (rlen - len) (cycle pad)
+ in if pr then s ++ ps else ps ++ s
+
+parseFloat :: String -> Float
+parseFloat s = case readFloat s of
+ (v, _):_ -> v
+ _ -> 0
+
+parseInt :: String -> Int
+parseInt s = case readDec s of
+ (v, _):_ -> v
+ _ -> 0
+
+floatToPercent :: Float -> Monitor String
+floatToPercent n =
+ do pad <- getConfigValue ppad
+ pc <- getConfigValue padChars
+ pr <- getConfigValue padRight
+ up <- getConfigValue useSuffix
+ let p = showDigits 0 (n * 100)
+ ps = if up then "%" else ""
+ return $ padString pad pad pc pr p ++ ps
+
+stringParser :: Pos -> B.ByteString -> String
+stringParser (x,y) =
+ B.unpack . li x . B.words . li y . B.lines
+ where li i l | length l > i = l !! i
+ | otherwise = B.empty
+
+setColor :: String -> Selector (Maybe String) -> Monitor String
+setColor str s =
+ do a <- getConfigValue s
+ case a of
+ Nothing -> return str
+ Just c -> return $
+ "<fc=" ++ c ++ ">" ++ str ++ "</fc>"
+
+showWithPadding :: String -> Monitor String
+showWithPadding s =
+ do mn <- getConfigValue minWidth
+ mx <- getConfigValue maxWidth
+ p <- getConfigValue padChars
+ pr <- getConfigValue padRight
+ return $ padString mn mx p pr s
+
+colorizeString :: (Num a, Ord a) => a -> String -> Monitor String
+colorizeString x s = do
+ h <- getConfigValue high
+ l <- getConfigValue low
+ let col = setColor s
+ [ll,hh] = map fromIntegral $ sort [l, h] -- consider high < low
+ head $ [col highColor | x > hh ] ++
+ [col normalColor | x > ll ] ++
+ [col lowColor | True]
+
+showWithColors :: (Num a, Ord a) => (a -> String) -> a -> Monitor String
+showWithColors f x = showWithPadding (f x) >>= colorizeString x
+
+showWithColors' :: (Num a, Ord a) => String -> a -> Monitor String
+showWithColors' str = showWithColors (const str)
+
+showPercentsWithColors :: [Float] -> Monitor [String]
+showPercentsWithColors fs =
+ do fstrs <- mapM floatToPercent fs
+ zipWithM (showWithColors . const) fstrs (map (*100) fs)
+
+showPercentWithColors :: Float -> Monitor String
+showPercentWithColors f = liftM head $ showPercentsWithColors [f]
+
+showPercentBar :: Float -> Float -> Monitor String
+showPercentBar v x = do
+ bb <- getConfigValue barBack
+ bf <- getConfigValue barFore
+ bw <- getConfigValue barWidth
+ let len = min bw $ round (fromIntegral bw * x)
+ s <- colorizeString v (take len $ cycle bf)
+ return $ s ++ take (bw - len) (cycle bb)
+
+showLogBar :: Float -> Float -> Monitor String
+showLogBar f v = do
+ h <- fromIntegral `fmap` getConfigValue high
+ l <- fromIntegral `fmap` getConfigValue low
+ bw <- fromIntegral `fmap` getConfigValue barWidth
+ let [ll, hh] = sort [l, h]
+ choose x | x == 0.0 = 0
+ | x <= ll = 1 / bw
+ | otherwise = f + logBase 2 (x / hh) / bw
+ showPercentBar v $ choose v
+
+-- $threads
+
+doActionTwiceWithDelay :: Int -> IO [a] -> IO ([a], [a])
+doActionTwiceWithDelay delay action =
+ do v1 <- newMVar []
+ forkIO $! getData action v1 0
+ v2 <- newMVar []
+ forkIO $! getData action v2 delay
+ threadDelay (delay `div` 3 * 4)
+ a <- readMVar v1
+ b <- readMVar v2
+ return (a,b)
+
+getData :: IO a -> MVar a -> Int -> IO ()
+getData action var d =
+ do threadDelay d
+ s <- action
+ modifyMVar_ var (\_ -> return $! s)
+
+catRead :: FilePath -> IO B.ByteString
+catRead file = B.pack `fmap` readProcess "/bin/cat" [file] ""