diff options
Diffstat (limited to 'src/Plugins')
29 files changed, 2644 insertions, 0 deletions
diff --git a/src/Plugins/CommandReader.hs b/src/Plugins/CommandReader.hs new file mode 100644 index 0000000..7c7c92d --- /dev/null +++ b/src/Plugins/CommandReader.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.CommandReader +-- Copyright : (c) John Goerzen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from external commands +-- note: stderr is lost here +-- +----------------------------------------------------------------------------- + +module Plugins.CommandReader where + +import System.IO +import Plugins +import System.Process(runInteractiveCommand, getProcessExitCode) + +data CommandReader = CommandReader String String + deriving (Read, Show) + +instance Exec CommandReader where + alias (CommandReader _ a) = a + start (CommandReader p _) cb = do + (hstdin, hstdout, hstderr, ph) <- runInteractiveCommand p + hClose hstdin + hClose hstderr + hSetBinaryMode hstdout False + hSetBuffering hstdout LineBuffering + forever ph (hGetLineSafe hstdout >>= cb) + where forever ph a = + do a + ec <- getProcessExitCode ph + case ec of + Nothing -> forever ph a + Just _ -> cb "EXITED" diff --git a/src/Plugins/Date.hs b/src/Plugins/Date.hs new file mode 100644 index 0000000..bfcb132 --- /dev/null +++ b/src/Plugins/Date.hs @@ -0,0 +1,37 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Date +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A date plugin for Xmobar +-- +-- Usage example: in template put +-- +-- > Run Date "%a %b %_d %Y <fc=#ee9a00> %H:%M:%S</fc>" "Mydate" 10 +-- +----------------------------------------------------------------------------- + +module Plugins.Date (Date(..)) where + +import Plugins + +import System.Locale +import System.Time + +data Date = Date String String Int + deriving (Read, Show) + +instance Exec Date where + alias (Date _ a _) = a + run (Date f _ _) = date f + rate (Date _ _ r) = r + +date :: String -> IO String +date format = do + t <- toCalendarTime =<< getClockTime + return $ formatCalendarTime defaultTimeLocale format t diff --git a/src/Plugins/EWMH.hs b/src/Plugins/EWMH.hs new file mode 100644 index 0000000..d5b70cb --- /dev/null +++ b/src/Plugins/EWMH.hs @@ -0,0 +1,264 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE CPP, RecordWildCards, NamedFieldPuns, GeneralizedNewtypeDeriving #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.EWMH +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- An experimental plugin to display EWMH pager information +-- +----------------------------------------------------------------------------- + +module Plugins.EWMH (EWMH(..)) where + +import Control.Monad.State +import Control.Monad.Reader +import Graphics.X11 hiding (Modifier, Color) +import Graphics.X11.Xlib.Extras +import Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar, CLong) +import XUtil (nextEvent') + +import Data.List (intersperse, intercalate) + +import Data.Map (Map) +import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set + + +data EWMH = EWMH | EWMHFMT Component deriving (Read, Show) + +instance Exec EWMH where + alias EWMH = "EWMH" + + start ew cb = allocaXEvent $ \ep -> execM $ do + d <- asks display + r <- asks root + + liftIO xSetErrorHandler + + liftIO $ selectInput d r propertyChangeMask + handlers' <- mapM (\(a, h) -> liftM2 (,) (getAtom a) (return h)) handlers + mapM_ ((=<< asks root) . snd) handlers' + + forever $ do + liftIO . cb . fmtOf ew =<< get + liftIO $ nextEvent' d ep + e <- liftIO $ getEvent ep + case e of + PropertyEvent { ev_atom = a, ev_window = w } -> do + case lookup a handlers' of + Just f -> f w + _ -> return () + _ -> return () + + return () + +defaultPP = Sep (Text " : ") [ Workspaces [Color "white" "black" :% Current, Hide :% Empty] + , Layout + , Color "#00ee00" "" :$ Short 120 :$ WindowName] + +fmtOf EWMH = flip fmt defaultPP +fmtOf (EWMHFMT f) = flip fmt f + +sep :: [a] -> [[a]] -> [a] +sep x xs = intercalate x $ filter (not . null) xs + +fmt :: EwmhState -> Component -> String +fmt e (Text s) = s +fmt e (l :+ r) = fmt e l ++ fmt e r +fmt e (m :$ r) = modifier m $ fmt e r +fmt e (Sep c xs) = sep (fmt e c) $ map (fmt e) xs +fmt e WindowName = windowName $ Map.findWithDefault initialClient (activeWindow e) (clients e) +fmt e Layout = layout e +fmt e (Workspaces opts) = sep " " + [foldr ($) n [modifier m | (m :% a) <- opts, a `elem` as] + | (n, as) <- attrs] + where + stats i = [ (Current, i == currentDesktop e) + , (Empty, Set.notMember i nonEmptys && i /= currentDesktop e) + -- TODO for visible , (Visibl + ] + attrs :: [(String, [WsType])] + attrs = [(n, [s | (s, b) <- stats i, b]) | (i, n) <- zip [0 ..] (desktopNames e)] + nonEmptys = Set.unions . map desktops . Map.elems $ clients e + +modifier :: Modifier -> (String -> String) +modifier Hide = const "" +modifier (Color fg bg) = \x -> concat ["<fc=", fg, if null bg then "" else "," ++ bg + , ">", x, "</fc>"] +modifier (Short n) = take n +modifier (Wrap l r) = \x -> l ++ x ++ r + +data Component = Text String + | Component :+ Component + | Modifier :$ Component + | Sep Component [Component] + | WindowName + | Layout + | Workspaces [WsOpt] + deriving (Read, Show) + +infixr 0 :$ +infixr 5 :+ + +data Modifier = Hide + | Color String String + | Short Int + | Wrap String String + deriving (Read, Show) + +data WsOpt = Modifier :% WsType + | WSep Component + deriving (Read, Show) +infixr 0 :% + +data WsType = Current | Empty | Visible + deriving (Read, Show, Eq) + +data EwmhConf = C { root :: Window + , display :: Display } + +data EwmhState = S { currentDesktop :: CLong + , activeWindow :: Window + , desktopNames :: [String] + , layout :: String + , clients :: Map Window Client } + deriving Show + +data Client = Cl { windowName :: String + , desktops :: Set CLong } + deriving Show + +getAtom :: String -> M Atom +getAtom s = do + d <- asks display + liftIO $ internAtom d s False + +windowProperty32 :: String -> Window -> M (Maybe [CLong]) +windowProperty32 s w = do + (C {display}) <- ask + a <- getAtom s + liftIO $ getWindowProperty32 display a w + +windowProperty8 :: String -> Window -> M (Maybe [CChar]) +windowProperty8 s w = do + (C {display}) <- ask + a <- getAtom s + liftIO $ getWindowProperty8 display a w + +initialState :: EwmhState +initialState = S 0 0 [] [] Map.empty + +initialClient :: Client +initialClient = Cl "" Set.empty + +handlers, clientHandlers :: [(String, Updater)] +handlers = [ ("_NET_CURRENT_DESKTOP", updateCurrentDesktop) + , ("_NET_DESKTOP_NAMES", updateDesktopNames ) + , ("_NET_ACTIVE_WINDOW", updateActiveWindow) + , ("_NET_CLIENT_LIST", updateClientList) + ] ++ clientHandlers + +clientHandlers = [ ("_NET_WM_NAME", updateName) + , ("_NET_WM_DESKTOP", updateDesktop) ] + +newtype M a = M (ReaderT EwmhConf (StateT EwmhState IO) a) + deriving (Monad, Functor, MonadIO, MonadReader EwmhConf, MonadState EwmhState) + +execM :: M a -> IO a +execM (M m) = do + d <- openDisplay "" + r <- rootWindow d (defaultScreen d) + let conf = C r d + evalStateT (runReaderT m (C r d)) initialState + +type Updater = Window -> M () + +updateCurrentDesktop, updateDesktopNames, updateActiveWindow :: Updater +updateCurrentDesktop _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_CURRENT_DESKTOP" root + case mwp of + Just [x] -> modify (\s -> s { currentDesktop = x }) + _ -> return () + +updateActiveWindow _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_ACTIVE_WINDOW" root + case mwp of + Just [x] -> modify (\s -> s { activeWindow = fromIntegral x }) + _ -> return () + +updateDesktopNames _ = do + (C {root}) <- ask + mwp <- windowProperty8 "_NET_DESKTOP_NAMES" root + case mwp of + Just xs -> modify (\s -> s { desktopNames = parse xs }) + _ -> return () + where + dropNull ('\0':xs) = xs + dropNull xs = xs + + split [] = [] + split xs = case span (/= '\0') xs of + (x, ys) -> x : split (dropNull ys) + parse = split . decodeCChar + +updateClientList _ = do + (C {root}) <- ask + mwp <- windowProperty32 "_NET_CLIENT_LIST" root + case mwp of + Just xs -> do + cl <- gets clients + let cl' = Map.fromList $ map (flip (,) initialClient . fromIntegral) xs + dels = Map.difference cl cl' + new = Map.difference cl' cl + modify (\s -> s { clients = Map.union (Map.intersection cl cl') cl'}) + mapM_ unmanage (map fst $ Map.toList dels) + mapM_ listen (map fst $ Map.toList cl') + mapM_ update (map fst $ Map.toList new) + _ -> return () + where + unmanage w = asks display >>= \d -> liftIO $ selectInput d w 0 + listen w = asks display >>= \d -> liftIO $ selectInput d w propertyChangeMask + update w = mapM_ (($ w) . snd) clientHandlers + +modifyClient :: Window -> (Client -> Client) -> M () +modifyClient w f = modify (\s -> s { clients = Map.alter f' w $ clients s }) + where + f' Nothing = Just $ f initialClient + f' (Just x) = Just $ f x + +updateName w = do + mwp <- windowProperty8 "_NET_WM_NAME" w + case mwp of + Just xs -> modifyClient w (\c -> c { windowName = decodeCChar xs }) + _ -> return () + +updateDesktop w = do + mwp <- windowProperty32 "_NET_WM_DESKTOP" w + case mwp of + Just x -> modifyClient w (\c -> c { desktops = Set.fromList x }) + _ -> return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Plugins/HelloWorld.hs b/src/Plugins/HelloWorld.hs new file mode 100644 index 0000000..df5cff6 --- /dev/null +++ b/src/Plugins/HelloWorld.hs @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.HelloWorld +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin example for Xmobar, a text based status bar +-- +----------------------------------------------------------------------------- + +module Plugins.HelloWorld where + +import Plugins + +data HelloWorld = HelloWorld + deriving (Read, Show) + +instance Exec HelloWorld where + alias HelloWorld = "helloWorld" + run HelloWorld = return "<fc=red>Hello World!!</fc>" diff --git a/src/Plugins/MBox.hs b/src/Plugins/MBox.hs new file mode 100644 index 0000000..65a8bb3 --- /dev/null +++ b/src/Plugins/MBox.hs @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.MBox +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail in mbox files. +-- +----------------------------------------------------------------------------- + +module Plugins.MBox (MBox(..)) where + +import Prelude hiding (catch) +import Plugins +import Plugins.Utils (changeLoop, expandHome) + +import Control.Monad (when) +import Control.Concurrent.STM +import Control.Exception (SomeException, handle, evaluate) + +import System.Console.GetOpt +import System.Directory (doesFileExist) +import System.FilePath ((</>)) +import System.INotify (Event(..), EventVariety(..), initINotify, addWatch) + +import qualified Data.ByteString.Lazy.Char8 as B + +data Options = Options + { oAll :: Bool + , oUniq :: Bool + , oDir :: FilePath + , oPrefix :: String + , oSuffix :: String + } + +defaults :: Options +defaults = Options { + oAll = False, oUniq = False, oDir = "", oPrefix = "", oSuffix = "" + } + +options :: [OptDescr (Options -> Options)] +options = + [ Option "a" ["all"] (NoArg (\o -> o { oAll = True })) "" + , Option "u" [] (NoArg (\o -> o { oUniq = True })) "" + , Option "d" ["dir"] (ReqArg (\x o -> o { oDir = x }) "") "" + , Option "p" ["prefix"] (ReqArg (\x o -> o { oPrefix = x }) "") "" + , Option "s" ["suffix"] (ReqArg (\x o -> o { oSuffix = x }) "") "" + ] + +parseOptions :: [String] -> IO Options +parseOptions args = + case getOpt Permute options args of + (o, _, []) -> return $ foldr id defaults o + (_, _, errs) -> ioError . userError $ concat errs + +-- | A list of display names, paths to mbox files and display colours, +-- followed by a list of options. +data MBox = MBox [(String, FilePath, String)] [String] String + deriving (Read, Show) + +instance Exec MBox where + alias (MBox _ _ a) = a + start (MBox boxes args _) cb = do + + opts <- parseOptions args + let showAll = oAll opts + prefix = oPrefix opts + suffix = oSuffix opts + uniq = oUniq opts + names = map (\(t, _, _) -> t) boxes + colors = map (\(_, _, c) -> c) boxes + extractPath (_, f, _) = expandHome $ oDir opts </> f + events = [CloseWrite] + + i <- initINotify + vs <- mapM (\b -> do + f <- extractPath b + exists <- doesFileExist f + n <- if exists then countMails f else return (-1) + v <- newTVarIO (f, n) + when exists $ + addWatch i events f (handleNotification v) >> return () + return v) + boxes + + changeLoop (mapM (fmap snd . readTVar) vs) $ \ns -> + let s = unwords [ showC uniq m n c | (m, n, c) <- zip3 names ns colors + , showAll || n > 0 ] + in cb (if null s then "" else prefix ++ s ++ suffix) + +showC :: Bool -> String -> Int -> String -> String +showC u m n c = + if c == "" then msg else "<fc=" ++ c ++ ">" ++ msg ++ "</fc>" + where msg = m ++ if not u || n > 1 then show n else "" + +countMails :: FilePath -> IO Int +countMails f = + handle ((\_ -> evaluate 0) :: SomeException -> IO Int) + (do txt <- B.readFile f + evaluate $! length . filter (B.isPrefixOf from) . B.lines $ txt) + where from = B.pack "From " + +handleNotification :: TVar (FilePath, Int) -> Event -> IO () +handleNotification v _ = do + (p, _) <- atomically $ readTVar v + n <- countMails p + atomically $ writeTVar v (p, n) diff --git a/src/Plugins/Mail.hs b/src/Plugins/Mail.hs new file mode 100644 index 0000000..38cdaae --- /dev/null +++ b/src/Plugins/Mail.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Mail +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <sjanssen@cse.unl.edu> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for checking mail. +-- +----------------------------------------------------------------------------- + +module Plugins.Mail where + +import Prelude hiding (catch) +import Plugins +import Plugins.Utils (expandHome, changeLoop) + +import Control.Monad +import Control.Concurrent.STM + +import System.Directory +import System.FilePath +import System.INotify + +import Data.List (isPrefixOf) +import Data.Set (Set) +import qualified Data.Set as S + +-- | A list of mail box names and paths to maildirs. +data Mail = Mail [(String, FilePath)] + deriving (Read, Show) + +instance Exec Mail where + start (Mail ms) cb = do + vs <- mapM (const $ newTVarIO S.empty) ms + + let ts = map fst ms + rs = map ((</> "new") . snd) ms + ev = [Move, MoveIn, MoveOut, Create, Delete] + + ds <- mapM expandHome rs + i <- initINotify + zipWithM_ (\d v -> addWatch i ev d (handle v)) ds vs + + forM_ (zip ds vs) $ \(d, v) -> do + s <- fmap (S.fromList . filter (not . isPrefixOf ".")) + $ getDirectoryContents d + atomically $ modifyTVar v (S.union s) + + changeLoop (mapM (fmap S.size . readTVar) vs) $ \ns -> + cb . unwords $ [m ++ ":" ++ show n + | (m, n) <- zip ts ns + , n /= 0 ] + +modifyTVar :: TVar a -> (a -> a) -> STM () +modifyTVar v f = readTVar v >>= writeTVar v . f + +handle :: TVar (Set String) -> Event -> IO () +handle v e = atomically $ modifyTVar v $ case e of + Created {} -> create + MovedIn {} -> create + Deleted {} -> delete + MovedOut {} -> delete + _ -> id + where + delete = S.delete (filePath e) + create = S.insert (filePath e) diff --git a/src/Plugins/Monitors.hs b/src/Plugins/Monitors.hs new file mode 100644 index 0000000..9887d74 --- /dev/null +++ b/src/Plugins/Monitors.hs @@ -0,0 +1,119 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins.Monitors +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- The system monitor plugin for Xmobar. +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors where + +import Plugins + +import Plugins.Monitors.Common ( runM ) +import Plugins.Monitors.Weather +import Plugins.Monitors.Net +import Plugins.Monitors.Mem +import Plugins.Monitors.Swap +import Plugins.Monitors.Cpu +import Plugins.Monitors.MultiCpu +import Plugins.Monitors.Batt +import Plugins.Monitors.Thermal +import Plugins.Monitors.CpuFreq +import Plugins.Monitors.CoreTemp +import Plugins.Monitors.Disk +import Plugins.Monitors.Top +import Plugins.Monitors.Uptime +#ifdef IWLIB +import Plugins.Monitors.Wireless +#endif +#ifdef LIBMPD +import Plugins.Monitors.MPD +#endif + +data Monitors = Weather Station Args Rate + | Network Interface Args Rate + | Memory Args Rate + | Swap Args Rate + | Cpu Args Rate + | MultiCpu Args Rate + | Battery Args Rate + | BatteryP [String] Args Rate + | DiskU DiskSpec Args Rate + | DiskIO DiskSpec Args Rate + | Thermal Zone Args Rate + | CpuFreq Args Rate + | CoreTemp Args Rate + | TopProc Args Rate + | TopMem Args Rate + | Uptime Args Rate +#ifdef IWLIB + | Wireless Interface Args Rate +#endif +#ifdef LIBMPD + | MPD Args Rate +#endif + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Station = String +type Zone = String +type Interface = String +type Rate = Int +type DiskSpec = [(String, String)] + +instance Exec Monitors where + alias (Weather s _ _) = s + alias (Network i _ _) = i + alias (Thermal z _ _) = z + alias (Memory _ _) = "memory" + alias (Swap _ _) = "swap" + alias (Cpu _ _) = "cpu" + alias (MultiCpu _ _) = "multicpu" + alias (Battery _ _) = "battery" + alias (BatteryP _ _ _)= "battery" + alias (CpuFreq _ _) = "cpufreq" + alias (TopProc _ _) = "top" + alias (TopMem _ _) = "topmem" + alias (CoreTemp _ _) = "coretemp" + alias (DiskU _ _ _) = "disku" + alias (DiskIO _ _ _) = "diskio" + alias (Uptime _ _) = "uptime" +#ifdef IWLIB + alias (Wireless i _ _) = i ++ "wi" +#endif +#ifdef LIBMPD + alias (MPD _ _) = "mpd" +#endif + start (Weather s a r) = runM (a ++ [s]) weatherConfig runWeather r + start (Network i a r) = runM (a ++ [i]) netConfig runNet r + start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r + start (Memory a r) = runM a memConfig runMem r + start (Swap a r) = runM a swapConfig runSwap r + start (Cpu a r) = runM a cpuConfig runCpu r + start (MultiCpu a r) = runM a multiCpuConfig runMultiCpu r + start (Battery a r) = runM a battConfig runBatt r + start (BatteryP s a r) = runM a battConfig (runBatt' s) r + start (CpuFreq a r) = runM a cpuFreqConfig runCpuFreq r + start (CoreTemp a r) = runM a coreTempConfig runCoreTemp r + start (DiskU s a r) = runM a diskUConfig (runDiskU s) r + start (DiskIO s a r) = runM a diskIOConfig (runDiskIO s) r + start (TopMem a r) = runM a topMemConfig runTopMem r + start (Uptime a r) = runM a uptimeConfig runUptime r + start (TopProc a r) = startTop a r +#ifdef IWLIB + start (Wireless i a r) = runM (a ++ [i]) wirelessConfig runWireless r +#endif +#ifdef LIBMPD + start (MPD a r) = runM a mpdConfig runMPD r +#endif diff --git a/src/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs new file mode 100644 index 0000000..11b2d6c --- /dev/null +++ b/src/Plugins/Monitors/Batt.hs @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Batt +-- Copyright : (c) Andrea Rossato, 2010 Petr Rockai, 2010 Jose A Ortega +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A battery monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where + +import qualified Data.ByteString.Lazy.Char8 as B +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) +import System.Console.GetOpt + +data BattOpts = BattOpts + { onString :: String + , offString :: String + , posColor :: Maybe String + , lowWColor :: Maybe String + , mediumWColor :: Maybe String + , highWColor :: Maybe String + , lowThreshold :: Float + , highThreshold :: Float + } + +defaultOpts :: BattOpts +defaultOpts = BattOpts + { onString = "On" + , offString = "Off" + , posColor = Nothing + , lowWColor = Nothing + , mediumWColor = Nothing + , highWColor = Nothing + , lowThreshold = -12 + , highThreshold = -10 + } + +options :: [OptDescr (BattOpts -> BattOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "p" ["positive"] (ReqArg (\x o -> o { posColor = Just x }) "") "" + , Option "l" ["low"] (ReqArg (\x o -> o { lowWColor = Just x }) "") "" + , Option "m" ["medium"] (ReqArg (\x o -> o { mediumWColor = Just x }) "") "" + , Option "h" ["high"] (ReqArg (\x o -> o { highWColor = Just x }) "") "" + , Option "L" ["lowt"] (ReqArg (\x o -> o { lowThreshold = read x }) "") "" + , Option "H" ["hight"] (ReqArg (\x o -> o { highThreshold = read x }) "") "" + ] + +parseOpts :: [String] -> IO BattOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +data Result = Result Float Float Float String | NA + +base :: String +base = "/sys/class/power_supply" + +battConfig :: IO MConfig +battConfig = mkMConfig + "Batt: <watts>, <left>% / <timeleft>" -- template + ["leftbar", "left", "acstatus", "timeleft", "watts"] -- replacements + +data Files = Files + { f_full :: String + , f_now :: String + , f_voltage :: String + , f_current :: String + } | NoFiles + +data Battery = Battery + { full :: Float + , now :: Float + , voltage :: Float + , current :: Float + } + +batteryFiles :: String -> IO Files +batteryFiles bat = + do is_charge <- fileExist $ prefix ++ "/charge_now" + is_energy <- fileExist $ prefix ++ "/energy_now" + return $ case (is_charge, is_energy) of + (True, _) -> files "/charge" + (_, True) -> files "/energy" + _ -> NoFiles + where prefix = base ++ "/" ++ bat + files ch = Files { f_full = prefix ++ ch ++ "_full" + , f_now = prefix ++ ch ++ "_now" + , f_current = prefix ++ "/current_now" + , f_voltage = prefix ++ "/voltage_now" } + +haveAc :: IO (Maybe Bool) +haveAc = do know <- fileExist $ base ++ "/AC/online" + if know + then do s <- B.unpack `fmap` catRead (base ++ "/AC/online") + return $ Just $ s == "1\n" + else return Nothing + +readBattery :: Files -> IO Battery +readBattery NoFiles = return $ Battery 0 0 0 0 +readBattery files = + do a <- grab $ f_full files -- microwatthours + b <- grab $ f_now files + c <- grab $ f_voltage files -- microvolts + d <- grab $ f_current files -- microwatts (huh!) + return $ Battery (3600 * a / 1000000) -- wattseconds + (3600 * b / 1000000) -- wattseconds + (c / 1000000) -- volts + (d / c) -- amperes + where grab = fmap (read . B.unpack) . catRead + +readBatteries :: BattOpts -> [Files] -> IO Result +readBatteries opts bfs = + do bats <- mapM readBattery (take 3 bfs) + ac' <- haveAc + let ac = (ac' == Just True) + sign = if ac then 1 else -1 + left = sum (map now bats) / sum (map full bats) + watts = sign * sum (map voltage bats) * sum (map current bats) + time = if watts == 0 then 0 else sum $ map time' bats -- negate sign + time' b = (if ac then full b - now b else now b) / (sign * watts) + acstr = case ac' of + Nothing -> "?" + Just True -> onString opts + Just False -> offString opts + return $ if isNaN left then NA else Result left watts time acstr + +runBatt :: [String] -> Monitor String +runBatt = runBatt' ["BAT0","BAT1","BAT2"] + +runBatt' :: [String] -> [String] -> Monitor String +runBatt' bfs args = do + opts <- io $ parseOpts args + c <- io $ readBatteries opts =<< mapM batteryFiles bfs + case c of + Result x w t s -> + do l <- fmtPercent x + parseTemplate (l ++ s:[fmtTime $ floor t, fmtWatts w opts]) + NA -> return "N/A" + where fmtPercent :: Float -> Monitor [String] + fmtPercent x = do + p <- showPercentWithColors x + b <- showPercentBar (100 * x) x + return [b, p] + fmtWatts x o = color x o $ showDigits 1 x ++ "W" + fmtTime :: Integer -> String + fmtTime x = hours ++ ":" ++ if length minutes == 2 + then minutes else '0' : minutes + where hours = show (x `div` 3600) + minutes = show ((x `mod` 3600) `div` 60) + maybeColor Nothing _ = "" + maybeColor (Just c) str = "<fc=" ++ c ++ ">" ++ str ++ "</fc>" + color x o | x >= 0 = maybeColor (posColor o) + | x >= highThreshold o = maybeColor (highWColor o) + | x >= lowThreshold o = maybeColor (mediumWColor o) + | otherwise = maybeColor (lowWColor o) 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] "" diff --git a/src/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs new file mode 100644 index 0000000..80e7700 --- /dev/null +++ b/src/Plugins/Monitors/CoreCommon.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreCommon +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- The common part for cpu core monitors (e.g. cpufreq, coretemp) +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CoreCommon where + +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) +import System.IO (withFile, IOMode(ReadMode), hGetLine) +import System.Directory +import Data.Char (isDigit) +import Data.List (isPrefixOf) + +-- | +-- Function checks the existence of first file specified by pattern and if the +-- file doesn't exists failure message is shown, otherwise the data retrieval +-- is performed. +checkedDataRetrieval :: (Num a, Ord a, Show a) => + String -> String -> String -> String -> (Double -> a) + -> (a -> String) -> Monitor String +checkedDataRetrieval failureMessage dir file pattern trans fmt = do + exists <- io $ fileExist $ concat [dir, "/", pattern, "0/", file] + case exists of + False -> return failureMessage + True -> retrieveData dir file pattern trans fmt + +-- | +-- Function retrieves data from files in directory dir specified by +-- pattern. String values are converted to double and 'trans' applied +-- to each one. Final array is processed by template parser function +-- and returned as monitor string. +retrieveData :: (Num a, Ord a, Show a) => + String -> String -> String -> (Double -> a) -> (a -> String) -> + Monitor String +retrieveData dir file pattern trans fmt = do + count <- io $ dirCount dir pattern + contents <- io $ mapM getGuts $ files count + values <- mapM (showWithColors fmt) $ map conversion contents + parseTemplate values + where + getGuts f = withFile f ReadMode hGetLine + dirCount path str = getDirectoryContents path + >>= return . length + . filter (\s -> str `isPrefixOf` s + && isDigit (last s)) + files count = map (\i -> concat [dir, "/", pattern, show i, "/", file]) + [0 .. count - 1] + conversion = trans . (read :: String -> Double) + diff --git a/src/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs new file mode 100644 index 0000000..a24b284 --- /dev/null +++ b/src/Plugins/Monitors/CoreTemp.hs @@ -0,0 +1,41 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CoreTemp +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A core temperature monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CoreTemp where + +import Plugins.Monitors.Common +import Plugins.Monitors.CoreCommon + +-- | +-- Core temperature default configuration. Default template contains only one +-- core temperature, user should specify custom template in order to get more +-- core frequencies. +coreTempConfig :: IO MConfig +coreTempConfig = mkMConfig + "Temp: <core0>C" -- template + (zipWith (++) (repeat "core") (map show [0 :: Int ..])) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the core temperature +-- (or temperatures) +runCoreTemp :: [String] -> Monitor String +runCoreTemp _ = do + let dir = "/sys/bus/platform/devices" + file = "temp1_input" + pattern = "coretemp." + divisor = 1e3 :: Double + failureMessage = "CoreTemp: N/A" + checkedDataRetrieval failureMessage dir file pattern (/divisor) show + diff --git a/src/Plugins/Monitors/Cpu.hs b/src/Plugins/Monitors/Cpu.hs new file mode 100644 index 0000000..ab89246 --- /dev/null +++ b/src/Plugins/Monitors/Cpu.hs @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Cpu +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Cpu where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B + +cpuConfig :: IO MConfig +cpuConfig = mkMConfig + "Cpu: <total>%" + ["bar","total","user","nice","system","idle"] + +cpuData :: IO [Float] +cpuData = do s <- B.readFile "/proc/stat" + return $ cpuParser s + +cpuParser :: B.ByteString -> [Float] +cpuParser = + map (read . B.unpack) . tail . B.words . head . B.lines + +parseCPU :: IO [Float] +parseCPU = + do (a,b) <- doActionTwiceWithDelay 750000 cpuData + let dif = zipWith (-) b a + tot = foldr (+) 0 dif + percent = map (/ tot) dif + return percent + +formatCpu :: [Float] -> Monitor [String] +formatCpu [] = return $ repeat "" +formatCpu xs = do + let t = foldr (+) 0 $ take 3 xs + b <- showPercentBar (100 * t) t + ps <- showPercentsWithColors (t:xs) + return (b:ps) + +runCpu :: [String] -> Monitor String +runCpu _ = + do c <- io parseCPU + l <- formatCpu c + parseTemplate l diff --git a/src/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs new file mode 100644 index 0000000..4f01922 --- /dev/null +++ b/src/Plugins/Monitors/CpuFreq.hs @@ -0,0 +1,43 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CpuFreq +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A cpu frequency monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.CpuFreq where + +import Plugins.Monitors.Common +import Plugins.Monitors.CoreCommon + +-- | +-- Cpu frequency default configuration. Default template contains only one +-- core frequency, user should specify custom template in order to get more +-- cpu frequencies. +cpuFreqConfig :: IO MConfig +cpuFreqConfig = mkMConfig + "Freq: <cpu0>" -- template + (zipWith (++) (repeat "cpu") (map show [0 :: Int ..])) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the cpu frequency (or +-- frequencies) +runCpuFreq :: [String] -> Monitor String +runCpuFreq _ = do + let dir = "/sys/devices/system/cpu" + file = "cpufreq/scaling_cur_freq" + pattern = "cpu" + divisor = 1e6 :: Double + failureMessage = "CpuFreq: N/A" + fmt x | x < 1 = show (round (x * 1000) :: Integer) ++ "MHz" + | otherwise = showDigits 1 x ++ "GHz" + checkedDataRetrieval failureMessage dir file pattern (/divisor) fmt + diff --git a/src/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs new file mode 100644 index 0000000..f3a7a2a --- /dev/null +++ b/src/Plugins/Monitors/Disk.hs @@ -0,0 +1,137 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk +-- Copyright : (c) 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 Plugins.Monitors.Disk ( diskUConfig, runDiskU + , diskIOConfig, runDiskIO + ) where + +import Plugins.Monitors.Common +import StatFS + +import Control.Monad (zipWithM) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, find, intercalate) + +diskIOConfig :: IO MConfig +diskIOConfig = mkMConfig "" ["total", "read", "write", + "totalbar", "readbar", "writebar"] + +diskUConfig :: IO MConfig +diskUConfig = mkMConfig "" + ["size", "free", "used", "freep", "usedp", "freebar", "usedbar"] + +type DevName = String +type Path = String + +mountedDevices :: [String] -> IO [(DevName, Path)] +mountedDevices req = do + s <- B.readFile "/etc/mtab" + return (parse s) + where + parse = map undev . filter isDev . map (firstTwo . B.words) . B.lines + firstTwo (a:b:_) = (B.unpack a, B.unpack b) + firstTwo _ = ("", "") + isDev (d, p) = "/dev/" `isPrefixOf` d && + (p `elem` req || drop 5 d `elem` req) + undev (d, f) = (drop 5 d, f) + +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 :: [DevName] -> IO [(DevName, [Float])] +mountedData devs = do + (dt, dt') <- doActionTwiceWithDelay 750000 diskData + 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') + +fsStats :: String -> IO [Integer] +fsStats path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [-1, -1, -1] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] + +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' :: (String, [Float]) -> Monitor String +runDiskIO' (tmp, xs) = do + s <- mapM (showWithColors speedToStr) xs + b <- mapM (showLogBar 0.8) xs + setConfigValue tmp template + parseTemplate $ s ++ b + +runDiskIO :: [(String, String)] -> [String] -> Monitor String +runDiskIO disks _ = do + mounted <- io $ mountedDevices (map fst disks) + dat <- io $ mountedData (map fst mounted) + strs <- mapM runDiskIO' $ devTemplates disks mounted dat + return $ intercalate " " strs + +runDiskU' :: String -> String -> Monitor String +runDiskU' tmp path = do + setConfigValue tmp template + fstats <- io $ fsStats path + let strs = map sizeToStr fstats + freep = (fstats !! 1) * 100 `div` head fstats + fr = fromIntegral freep / 100 + s <- zipWithM showWithColors' strs [100, freep, 100 - freep] + sp <- showPercentsWithColors [fr, 1 - fr] + fb <- showPercentBar (fromIntegral freep) fr + ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) + parseTemplate $ s ++ sp ++ [fb, ub] + +runDiskU :: [(String, String)] -> [String] -> Monitor String +runDiskU disks _ = do + devs <- io $ mountedDevices (map fst disks) + strs <- mapM (\(d, p) -> runDiskU' (findTempl d p disks) p) devs + return $ intercalate " " strs diff --git a/src/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs new file mode 100644 index 0000000..daf0ed4 --- /dev/null +++ b/src/Plugins/Monitors/MPD.hs @@ -0,0 +1,115 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MPD +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- MPD status and song +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.MPD ( mpdConfig, runMPD ) where + +import Plugins.Monitors.Common +import System.Console.GetOpt +import qualified Network.MPD as M + +mpdConfig :: IO MConfig +mpdConfig = mkMConfig "MPD: <state>" + [ "bar", "state", "statei", "volume", "length" + , "lapsed", "remaining", "plength", "ppos", "file" + , "name", "artist", "composer", "performer" + , "album", "title", "track", "genre" + ] + +data MOpts = MOpts + { mPlaying :: String + , mStopped :: String + , mPaused :: String + , mHost :: String + , mPort :: Integer + , mPassword :: String + } + +defaultOpts :: MOpts +defaultOpts = MOpts + { mPlaying = ">>" + , mStopped = "><" + , mPaused = "||" + , mHost = "127.0.0.1" + , mPort = 6600 + , mPassword = "" + } + +options :: [OptDescr (MOpts -> MOpts)] +options = + [ Option "P" ["playing"] (ReqArg (\x o -> o { mPlaying = x }) "") "" + , Option "S" ["stopped"] (ReqArg (\x o -> o { mStopped = x }) "") "" + , Option "Z" ["paused"] (ReqArg (\x o -> o { mPaused = x }) "") "" + , Option "h" ["host"] (ReqArg (\x o -> o { mHost = x }) "") "" + , Option "p" ["port"] (ReqArg (\x o -> o { mPort = read x }) "") "" + , Option "x" ["password"] (ReqArg (\x o -> o { mPassword = x }) "") "" + ] + +runMPD :: [String] -> Monitor String +runMPD args = do + opts <- io $ mopts args + let mpd = M.withMPDEx (mHost opts) (mPort opts) (mPassword opts) + status <- io $ mpd M.status + song <- io $ mpd M.currentSong + s <- parseMPD status song opts + parseTemplate s + +mopts :: [String] -> IO MOpts +mopts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseMPD :: M.Response M.Status -> M.Response (Maybe M.Song) -> MOpts + -> Monitor [String] +parseMPD (Left e) _ _ = return $ show e:repeat "" +parseMPD (Right st) song opts = do + songData <- parseSong song + bar <- showPercentBar (100 * b) b + return $ [bar, ss, si, vol, len, lap, remain, plen, ppos] ++ songData + where s = M.stState st + ss = show s + si = stateGlyph s opts + vol = int2str $ M.stVolume st + (p, t) = M.stTime st + [lap, len, remain] = map showTime [floor p, t, max 0 (t - floor p)] + b = if t > 0 then realToFrac $ p / fromIntegral t else 0 + plen = int2str $ M.stPlaylistLength st + ppos = maybe "" (int2str . (+1)) $ M.stSongPos st + +stateGlyph :: M.State -> MOpts -> String +stateGlyph s o = + case s of + M.Playing -> mPlaying o + M.Paused -> mPaused o + M.Stopped -> mStopped o + +parseSong :: M.Response (Maybe M.Song) -> Monitor [String] +parseSong (Left _) = return $ repeat "" +parseSong (Right Nothing) = return $ repeat "" +parseSong (Right (Just s)) = + let join [] = "" + join (x:xs) = foldl (\a o -> a ++ ", " ++ o) x xs + str sel = maybe "" join (M.sgGet sel s) + sels = [ M.Name, M.Artist, M.Composer, M.Performer + , M.Album, M.Title, M.Track, M.Genre ] + fields = M.sgFilePath s : map str sels + in mapM showWithPadding fields + +showTime :: Integer -> String +showTime t = int2str minutes ++ ":" ++ int2str seconds + where minutes = t `div` 60 + seconds = t `mod` 60 + +int2str :: (Num a, Ord a) => a -> String +int2str x = if x < 10 then '0':sx else sx where sx = show x diff --git a/src/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs new file mode 100644 index 0000000..5c55ee2 --- /dev/null +++ b/src/Plugins/Monitors/Mem.hs @@ -0,0 +1,59 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Mem +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A memory monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where + +import Plugins.Monitors.Common + +memConfig :: IO MConfig +memConfig = mkMConfig + "Mem: <usedratio>% (<cache>M)" -- template + ["usedbar", "freebar", "usedratio", "total", + "free", "buffer", "cache", "rest", "used"] -- available replacements + +fileMEM :: IO String +fileMEM = readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let content = map words $ take 4 $ lines file + [total, free, buffer, cache] = map (\line -> (read $ line !! 1 :: Float) / 1024) content + rest = free + buffer + cache + used = total - rest + usedratio = used / total + return [usedratio, total, free, buffer, cache, rest, used] + +totalMem :: IO Float +totalMem = fmap ((*1024) . (!!1)) parseMEM + +usedMem :: IO Float +usedMem = fmap ((*1024) . (!!6)) parseMEM + +formatMem :: [Float] -> Monitor [String] +formatMem (r:xs) = + do let f = showDigits 0 + rr = 100 * r + ub <- showPercentBar rr r + fb <- showPercentBar (100 - rr) (1 - r) + rs <- showPercentWithColors r + s <- mapM (showWithColors f) xs + return (ub:fb:rs:s) +formatMem _ = return $ replicate 9 "N/A" + +runMem :: [String] -> Monitor String +runMem _ = + do m <- io parseMEM + l <- formatMem m + parseTemplate l diff --git a/src/Plugins/Monitors/MultiCpu.hs b/src/Plugins/Monitors/MultiCpu.hs new file mode 100644 index 0000000..535196a --- /dev/null +++ b/src/Plugins/Monitors/MultiCpu.hs @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.MultiCpu +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A multi-cpu monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.MultiCpu(multiCpuConfig, runMultiCpu) where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, transpose, unfoldr) + +multiCpuConfig :: IO MConfig +multiCpuConfig = + mkMConfig "Cpu: <total>%" $ + map ("auto" ++) monitors + ++ [ k ++ n | n <- "" : map show [0 :: Int ..] + , k <- monitors] + where monitors = ["bar","total","user","nice","system","idle"] + + +cpuData :: IO [[Float]] +cpuData = do s <- B.readFile "/proc/stat" + return $ cpuParser s + +cpuParser :: B.ByteString -> [[Float]] +cpuParser = map parseList . cpuLists + where cpuLists = takeWhile isCpu . map B.words . B.lines + isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w + isCpu _ = False + parseList = map (read . B.unpack) . tail + +parseCpuData :: IO [[Float]] +parseCpuData = + do (as, bs) <- doActionTwiceWithDelay 950000 cpuData + let p0 = zipWith percent bs as + return p0 + +percent :: [Float] -> [Float] -> [Float] +percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] + where dif = zipWith (-) b a + tot = foldr (+) 0 dif + +formatMultiCpus :: [[Float]] -> Monitor [String] +formatMultiCpus [] = return $ repeat "" +formatMultiCpus xs = fmap concat $ mapM formatCpu xs + +formatCpu :: [Float] -> Monitor [String] +formatCpu xs + | length xs < 4 = showPercentsWithColors $ replicate 6 0.0 + | otherwise = let t = foldr (+) 0 $ take 3 xs + in do b <- showPercentBar (100 * t) t + ps <- showPercentsWithColors (t:xs) + return (b:ps) + +splitEvery :: (Eq a) => Int -> [a] -> [[a]] +splitEvery n = unfoldr (\x -> if x == [] + then Nothing + else Just $ splitAt n x) + +groupData :: [String] -> [[String]] +groupData = transpose . tail . splitEvery 6 + +formatAutoCpus :: [String] -> Monitor [String] +formatAutoCpus [] = return $ replicate 6 "" +formatAutoCpus xs = return $ map unwords (groupData xs) + +runMultiCpu :: [String] -> Monitor String +runMultiCpu _ = + do c <- io parseCpuData + l <- formatMultiCpus c + a <- formatAutoCpus l + parseTemplate (a ++ l) diff --git a/src/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs new file mode 100644 index 0000000..d9cd534 --- /dev/null +++ b/src/Plugins/Monitors/Net.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Net +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A net device monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Net (netConfig, runNet) where + +import Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B + +data NetDev = NA + | ND { netDev :: String + , netRx :: Float + , netTx :: Float + } deriving (Eq,Show,Read) + +interval :: Int +interval = 500000 + +netConfig :: IO MConfig +netConfig = mkMConfig + "<dev>: <rx>KB|<tx>KB" -- template + ["dev", "rx", "tx", "rxbar", "txbar"] -- available replacements + +-- Given a list of indexes, take the indexed elements from a list. +getNElements :: [Int] -> [a] -> [a] +getNElements ns as = map (as!!) ns + +-- Split into words, with word boundaries indicated by the given predicate. +-- Drops delimiters. Duplicates 'Data.List.Split.wordsBy'. +-- +-- > map (wordsBy (`elem` " :")) ["lo:31174097 31174097", "eth0: 43598 88888"] +-- +-- will become @[["lo","31174097","31174097"], ["eth0","43598","88888"]]@ +wordsBy :: (a -> Bool) -> [a] -> [[a]] +wordsBy f s = case dropWhile f s of + [] -> [] + s' -> w : wordsBy f s'' where (w, s'') = break f s' + +readNetDev :: [String] -> NetDev +readNetDev [] = NA +readNetDev xs = + ND (xs !! 0) (r (xs !! 1)) (r (xs !! 2)) + where r s | s == "" = 0 + | otherwise = read s / 1024 + +fileNET :: IO [NetDev] +fileNET = + do f <- B.readFile "/proc/net/dev" + return $ netParser f + +netParser :: B.ByteString -> [NetDev] +netParser = + map (readNetDev . getNElements [0,1,9] . wordsBy (`elem` " :") . B.unpack) . drop 2 . B.lines + +formatNet :: Float -> Monitor (String, String) +formatNet d = do + s <- getConfigValue useSuffix + let str = if s then (++"Kb/s") . showDigits 1 else showDigits 1 + b <- showLogBar 0.9 d + x <- showWithColors str d + return (x, b) + +printNet :: NetDev -> Monitor String +printNet nd = + case nd of + ND d r t -> do (rx, rb) <- formatNet r + (tx, tb) <- formatNet t + parseTemplate [d,rx,tx,rb,tb] + NA -> return "N/A" + +parseNET :: String -> IO [NetDev] +parseNET nd = + do (a,b) <- doActionTwiceWithDelay interval fileNET + let netRate f da db = takeDigits 2 $ (f db - f da) * fromIntegral (1000000 `div` interval) + diffRate (da,db) = ND (netDev da) + (netRate netRx da db) + (netRate netTx da db) + return $ filter (\d -> netDev d == nd) $ map diffRate $ zip a b + +runNet :: [String] -> Monitor String +runNet nd = + do pn <- io $ parseNET $ head nd + n <- case pn of + [x] -> return x + _ -> return NA + printNet n diff --git a/src/Plugins/Monitors/Swap.hs b/src/Plugins/Monitors/Swap.hs new file mode 100644 index 0000000..e466dbb --- /dev/null +++ b/src/Plugins/Monitors/Swap.hs @@ -0,0 +1,55 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Swap +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A swap usage monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Swap where + +import Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +swapConfig :: IO MConfig +swapConfig = mkMConfig + "Swap: <usedratio>%" -- template + ["usedratio", "total", "used", "free"] -- available replacements + +fileMEM :: IO B.ByteString +fileMEM = B.readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let li i l + | l /= [] = head l !! i + | otherwise = B.empty + fs s l + | l == [] = False + | otherwise = head l == B.pack s + get_data s = flip (/) 1024 . read . B.unpack . li 1 . filter (fs s) + st = map B.words . B.lines $ file + tot = get_data "SwapTotal:" st + free = get_data "SwapFree:" st + return [(tot - free) / tot, tot, tot - free, free] + +formatSwap :: [Float] -> Monitor [String] +formatSwap (r:xs) = + do other <- mapM (showWithColors (showDigits 2)) xs + ratio <- showPercentWithColors r + return $ ratio:other +formatSwap _ = return $ replicate 4 "N/A" + +runSwap :: [String] -> Monitor String +runSwap _ = + do m <- io parseMEM + l <- formatSwap m + parseTemplate l diff --git a/src/Plugins/Monitors/Thermal.hs b/src/Plugins/Monitors/Thermal.hs new file mode 100644 index 0000000..a3ffe6d --- /dev/null +++ b/src/Plugins/Monitors/Thermal.hs @@ -0,0 +1,42 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Thermal +-- Copyright : (c) Juraj Hercek +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Juraj Hercek <juhe_haskell@hck.sk> +-- Stability : unstable +-- Portability : unportable +-- +-- A thermal monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Thermal where + +import qualified Data.ByteString.Lazy.Char8 as B +import Plugins.Monitors.Common +import System.Posix.Files (fileExist) + +-- | Default thermal configuration. +thermalConfig :: IO MConfig +thermalConfig = mkMConfig + "Thm: <temp>C" -- template + ["temp"] -- available replacements + +-- | Retrieves thermal information. Argument is name of thermal directory in +-- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to +-- template (either default or user specified). +runThermal :: [String] -> Monitor String +runThermal args = do + let zone = head args + file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" + exists <- io $ fileExist file + case exists of + False -> return $ "Thermal (" ++ zone ++ "): N/A" + True -> do number <- io $ B.readFile file + >>= return . (read :: String -> Int) + . stringParser (1, 0) + thermal <- showWithColors show number + parseTemplate [ thermal ] + diff --git a/src/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs new file mode 100644 index 0000000..e45210c --- /dev/null +++ b/src/Plugins/Monitors/Top.hs @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Top +-- Copyright : (c) Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Process activity and memory consumption monitors +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE ForeignFunctionInterface #-} + +module Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where + +import Plugins.Monitors.Common + +import Control.Exception (SomeException, handle) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.List (sortBy, foldl') +import Data.Ord (comparing) +import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import System.Directory (getDirectoryContents) +import System.FilePath ((</>)) +import System.IO (IOMode(ReadMode), hGetLine, withFile) +import System.Posix.Unistd (SysVar(ClockTick), getSysVar) + +import Foreign.C.Types + +maxEntries :: Int +maxEntries = 10 + +intStrs :: [String] +intStrs = map show [1..maxEntries] + +topMemConfig :: IO MConfig +topMemConfig = mkMConfig "<both1>" + [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]] + +topConfig :: IO MConfig +topConfig = mkMConfig "<both1>" + ("no" : [ k ++ n | n <- intStrs + , k <- [ "name", "cpu", "both" + , "mname", "mem", "mboth"]]) + +foreign import ccall "unistd.h getpagesize" + c_getpagesize :: CInt + +pageSize :: Float +pageSize = fromIntegral c_getpagesize / 1024 + +processes :: IO [FilePath] +processes = fmap (filter isPid) (getDirectoryContents "/proc") + where isPid = (`elem` ['0'..'9']) . head + +getProcessData :: FilePath -> IO [String] +getProcessData pidf = + handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords + where readWords = fmap words . hGetLine + ign = const (return []) :: SomeException -> IO [String] + +handleProcesses :: ([String] -> a) -> IO [a] +handleProcesses f = + fmap (foldl' (\a p -> if length p < 15 then a else f p : a) []) + (processes >>= mapM getProcessData) + +showInfo :: String -> String -> Float -> Monitor [String] +showInfo nm sms mms = do + mnw <- getConfigValue maxWidth + mxw <- getConfigValue minWidth + let lsms = length sms + nmw = mnw - lsms - 1 + nmx = mxw - lsms - 1 + rnm = if nmw > 0 then padString nmw nmx " " True nm else nm + mstr <- showWithColors' sms mms + both <- showWithColors' (rnm ++ " " ++ sms) mms + return [nm, mstr, both] + +processName :: [String] -> String +processName = drop 1 . init . (!!1) + +sortTop :: [(String, Float)] -> [(String, Float)] +sortTop = sortBy (flip (comparing snd)) + +type MemInfo = (String, Float) + +meminfo :: [String] -> MemInfo +meminfo fs = (processName fs, pageSize * parseFloat (fs!!23)) + +meminfos :: IO [MemInfo] +meminfos = handleProcesses meminfo + +showMemInfo :: Float -> MemInfo -> Monitor [String] +showMemInfo scale (nm, rss) = + showInfo nm (showWithUnits 2 1 rss) (100 * rss / sc) + where sc = if scale > 0 then scale else 100 + +showMemInfos :: [MemInfo] -> Monitor [[String]] +showMemInfos ms = mapM (showMemInfo tm) ms + where tm = sum (map snd ms) + +runTopMem :: [String] -> Monitor String +runTopMem _ = do + mis <- io meminfos + pstr <- showMemInfos (sortTop mis) + parseTemplate $ concat pstr + +type Pid = Int +type TimeInfo = (String, Float) +type TimeEntry = (Pid, TimeInfo) +type Times = [TimeEntry] +type TimesRef = IORef (Times, UTCTime) + +timeMemEntry :: [String] -> (TimeEntry, MemInfo) +timeMemEntry fs = ((p, (n, t)), (n, r)) + where p = parseInt (head fs) + n = processName fs + t = parseFloat (fs!!13) + parseFloat (fs!!14) + (_, r) = meminfo fs + +timeMemEntries :: IO [(TimeEntry, MemInfo)] +timeMemEntries = handleProcesses timeMemEntry + +timeMemInfos :: IO (Times, [MemInfo], Int) +timeMemInfos = fmap res timeMemEntries + where res x = (sortBy (comparing fst) $ map fst x, map snd x, length x) + +combine :: Times -> Times -> Times +combine _ [] = [] +combine [] ts = ts +combine l@((p0, (n0, t0)):ls) r@((p1, (n1, t1)):rs) + | p0 == p1 && n0 == n1 = (p0, (n0, t1 - t0)) : combine ls rs + | p0 <= p1 = combine ls r + | otherwise = (p1, (n1, t1)) : combine l rs + +take' :: Int -> [a] -> [a] +take' m l = let !r = tk m l in length l `seq` r + where tk 0 _ = [] + tk _ [] = [] + tk n (x:xs) = let !r = tk (n - 1) xs in x : r + +topProcesses :: TimesRef -> Float -> IO (Int, [TimeInfo], [MemInfo]) +topProcesses tref scale = do + (t0, c0) <- readIORef tref + (t1, mis, len) <- timeMemInfos + c1 <- getCurrentTime + let scx = realToFrac (diffUTCTime c1 c0) * scale + !scx' = if scx > 0 then scx else scale + nts = map (\(_, (nm, t)) -> (nm, min 100 (t / scx'))) (combine t0 t1) + !t1' = take' (length t1) t1 + !nts' = take' maxEntries (sortTop nts) + !mis' = take' maxEntries (sortTop mis) + writeIORef tref (t1', c1) + return (len, nts', mis') + +showTimeInfo :: TimeInfo -> Monitor [String] +showTimeInfo (n, t) = showInfo n (showDigits 0 t) t + +showTimeInfos :: [TimeInfo] -> Monitor [[String]] +showTimeInfos = mapM showTimeInfo + +runTop :: TimesRef -> Float -> [String] -> Monitor String +runTop tref scale _ = do + (no, ps, ms) <- io $ topProcesses tref scale + pstr <- showTimeInfos ps + mstr <- showMemInfos ms + parseTemplate $ show no : concat (zipWith (++) pstr mstr) ++ repeat "N/A" + +startTop :: [String] -> Int -> (String -> IO ()) -> IO () +startTop a r cb = do + cr <- getSysVar ClockTick + c <- getCurrentTime + tref <- newIORef ([], c) + let scale = fromIntegral cr / 100 + _ <- topProcesses tref scale + runM a topConfig (runTop tref scale) r cb diff --git a/src/Plugins/Monitors/Uptime.hs b/src/Plugins/Monitors/Uptime.hs new file mode 100644 index 0000000..8524bcc --- /dev/null +++ b/src/Plugins/Monitors/Uptime.hs @@ -0,0 +1,50 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Plugins.Monitors.Uptime +-- Copyright : (c) 2010 Jose Antonio Ortega Ruiz +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : unportable +-- Created: Sun Dec 12, 2010 20:26 +-- +-- +-- Uptime +-- +------------------------------------------------------------------------------ + + +module Plugins.Monitors.Uptime (uptimeConfig, runUptime) where + +import Plugins.Monitors.Common + +import qualified Data.ByteString.Lazy.Char8 as B + +uptimeConfig :: IO MConfig +uptimeConfig = mkMConfig "Up <days>d <hours>h <minutes>m" + ["days", "hours", "minutes", "seconds"] + +readUptime :: IO Float +readUptime = + fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime") + +secsPerDay :: Integer +secsPerDay = 24 * 3600 + +uptime :: Monitor [String] +uptime = do + t <- io readUptime + u <- getConfigValue useSuffix + let tsecs = floor t + secs = tsecs `mod` secsPerDay + days = tsecs `quot` secsPerDay + hours = secs `quot` 3600 + mins = (secs `mod` 3600) `div` 60 + ss = secs `mod` 60 + str x s = if u then show x ++ s else show x + mapM (`showWithColors'` days) + [str days "d", str hours "h", str mins "m", str ss "s"] + +runUptime :: [String] -> Monitor String +runUptime _ = uptime >>= parseTemplate diff --git a/src/Plugins/Monitors/Weather.hs b/src/Plugins/Monitors/Weather.hs new file mode 100644 index 0000000..1277438 --- /dev/null +++ b/src/Plugins/Monitors/Weather.hs @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Weather +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A weather monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Weather where + +import Plugins.Monitors.Common + +import Control.Monad (when) +import System.Process +import System.Exit +import System.IO + +import Text.ParserCombinators.Parsec + + +weatherConfig :: IO MConfig +weatherConfig = mkMConfig + "<station>: <tempC>C, rh <rh>% (<hour>)" -- template + ["station" -- available replacements + , "stationState" + , "year" + , "month" + , "day" + , "hour" + , "wind" + , "visibility" + , "skyCondition" + , "tempC" + , "tempF" + , "dewPoint" + , "rh" + , "pressure" + ] + +data WeatherInfo = + WI { stationPlace :: String + , stationState :: String + , year :: String + , month :: String + , day :: String + , hour :: String + , wind :: String + , visibility :: String + , skyCondition :: String + , tempC :: Int + , tempF :: Int + , dewPoint :: String + , humidity :: Int + , pressure :: Int + } deriving (Show) + +pTime :: Parser (String, String, String, String) +pTime = do y <- getNumbersAsString + char '.' + m <- getNumbersAsString + char '.' + d <- getNumbersAsString + char ' ' + (h:hh:mi:mimi) <- getNumbersAsString + char ' ' + return (y, m, d ,([h]++[hh]++":"++[mi]++mimi)) + +pTemp :: Parser (Int, Int) +pTemp = do let num = digit <|> char '-' <|> char '.' + f <- manyTill num $ char ' ' + manyTill anyChar $ char '(' + c <- manyTill num $ char ' ' + skipRestOfLine + return $ (floor (read c :: Double), floor (read f :: Double)) + +pRh :: Parser Int +pRh = do s <- manyTill digit $ (char '%' <|> char '.') + return $ read s + +pPressure :: Parser Int +pPressure = do manyTill anyChar $ char '(' + s <- manyTill digit $ char ' ' + skipRestOfLine + return $ read s + +parseData :: Parser [WeatherInfo] +parseData = + do st <- getAllBut "," + space + ss <- getAllBut "(" + skipRestOfLine >> getAllBut "/" + (y,m,d,h) <- pTime + w <- getAfterString "Wind: " + v <- getAfterString "Visibility: " + sk <- getAfterString "Sky conditions: " + skipTillString "Temperature: " + (tC,tF) <- pTemp + dp <- getAfterString "Dew Point: " + skipTillString "Relative Humidity: " + rh <- pRh + skipTillString "Pressure (altimeter): " + p <- pPressure + manyTill skipRestOfLine eof + return $ [WI st ss y m d h w v sk tC tF dp rh p] + +defUrl :: String +defUrl = "http://weather.noaa.gov/pub/data/observations/metar/decoded/" + +getData :: String -> IO String +getData url= + do (i,o,e,p) <- runInteractiveCommand ("curl " ++ defUrl ++ url ++ ".TXT") + exit <- waitForProcess p + let closeHandles = do hClose o + hClose i + hClose e + case exit of + ExitSuccess -> do str <- hGetContents o + when (str == str) $ return () + closeHandles + return str + _ -> do closeHandles + return "Could not retrieve data" + +formatWeather :: [WeatherInfo] -> Monitor String +formatWeather [(WI st ss y m d h w v sk tC tF dp r p)] = + do cel <- showWithColors show tC + far <- showWithColors show tF + parseTemplate [st, ss, y, m, d, h, w, v, sk, cel, far, dp, show r , show p ] +formatWeather _ = return "N/A" + +runWeather :: [String] -> Monitor String +runWeather str = + do d <- io $ getData $ head str + i <- io $ runP parseData d + formatWeather i diff --git a/src/Plugins/Monitors/Wireless.hs b/src/Plugins/Monitors/Wireless.hs new file mode 100644 index 0000000..4ac0c10 --- /dev/null +++ b/src/Plugins/Monitors/Wireless.hs @@ -0,0 +1,34 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Wireless +-- Copyright : (c) Jose Antonio Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose Antonio Ortega Ruiz +-- Stability : unstable +-- Portability : unportable +-- +-- A monitor reporting ESSID and link quality for wireless interfaces +-- +----------------------------------------------------------------------------- + +module Plugins.Monitors.Wireless (wirelessConfig, runWireless) where + +import Plugins.Monitors.Common +import IWlib + +wirelessConfig :: IO MConfig +wirelessConfig = + mkMConfig "<essid> <quality>" ["essid", "quality", "qualitybar"] + +runWireless :: [String] -> Monitor String +runWireless (iface:_) = do + wi <- io $ getWirelessInfo iface + let essid = wiEssid wi + qlty = wiQuality wi + fqlty = fromIntegral qlty + e = if essid == "" then "N/A" else essid + q <- if qlty >= 0 then showWithColors show qlty else showWithPadding "" + qb <- showPercentBar fqlty (fqlty / 100) + parseTemplate [e, q, qb] +runWireless _ = return ""
\ No newline at end of file diff --git a/src/Plugins/PipeReader.hs b/src/Plugins/PipeReader.hs new file mode 100644 index 0000000..3fd0dd4 --- /dev/null +++ b/src/Plugins/PipeReader.hs @@ -0,0 +1,28 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.PipeReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from named pipes +-- +----------------------------------------------------------------------------- + +module Plugins.PipeReader where + +import System.IO +import Plugins + +data PipeReader = PipeReader String String + deriving (Read, Show) + +instance Exec PipeReader where + alias (PipeReader _ a) = a + start (PipeReader p _) cb = do + h <- openFile p ReadWriteMode + forever (hGetLineSafe h >>= cb) + where forever a = a >> forever a diff --git a/src/Plugins/StdinReader.hs b/src/Plugins/StdinReader.hs new file mode 100644 index 0000000..2ee217e --- /dev/null +++ b/src/Plugins/StdinReader.hs @@ -0,0 +1,33 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from stdin +-- +----------------------------------------------------------------------------- + +module Plugins.StdinReader where + +import Prelude hiding (catch) +import System.Posix.Process +import System.Exit +import System.IO +import Control.Exception (SomeException(..),catch) +import Plugins + +data StdinReader = StdinReader + deriving (Read, Show) + +instance Exec StdinReader where + start StdinReader cb = do + cb =<< catch (hGetLineSafe stdin) (\(SomeException e) -> do hPrint stderr e; return "") + eof <- hIsEOF stdin + if eof + then exitImmediately ExitSuccess + else start StdinReader cb diff --git a/src/Plugins/Utils.hs b/src/Plugins/Utils.hs new file mode 100644 index 0000000..1dbcd40 --- /dev/null +++ b/src/Plugins/Utils.hs @@ -0,0 +1,39 @@ +------------------------------------------------------------------------------ +-- | +-- Module: Plugins.Utils +-- Copyright: (c) 2010 Jose Antonio Ortega Ruiz +-- License: BSD3-style (see LICENSE) +-- +-- Maintainer: Jose A Ortega Ruiz <jao@gnu.org> +-- Stability: unstable +-- Portability: unportable +-- Created: Sat Dec 11, 2010 20:55 +-- +-- +-- Miscellaneous utility functions +-- +------------------------------------------------------------------------------ + + +module Plugins.Utils (expandHome, changeLoop) where + +import Control.Monad +import Control.Concurrent.STM + +import System.Environment +import System.FilePath + + +expandHome :: FilePath -> IO FilePath +expandHome ('~':'/':path) = fmap (</> path) (getEnv "HOME") +expandHome p = return p + +changeLoop :: Eq a => STM a -> (a -> IO ()) -> IO () +changeLoop s f = atomically s >>= go + where + go old = do + f old + go =<< atomically (do + new <- s + guard (new /= old) + return new) diff --git a/src/Plugins/XMonadLog.hs b/src/Plugins/XMonadLog.hs new file mode 100644 index 0000000..3461e26 --- /dev/null +++ b/src/Plugins/XMonadLog.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.StdinReader +-- Copyright : (c) Spencer Janssen +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Spencer Janssen <spencerjanssen@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin to display information from _XMONAD_LOG, specified at +-- http://code.haskell.org/XMonadContrib/XMonad/Hooks/DynamicLog.hs +-- +----------------------------------------------------------------------------- + +module Plugins.XMonadLog (XMonadLog(..)) where + +import Control.Monad +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Plugins +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar) +import XUtil (nextEvent') + + +data XMonadLog = XMonadLog | XPropertyLog String + deriving (Read, Show) + +instance Exec XMonadLog where + alias XMonadLog = "XMonadLog" + alias (XPropertyLog atom) = atom + + start x cb = do + let atom = case x of + XMonadLog -> "_XMONAD_LOG" + XPropertyLog a -> a + d <- openDisplay "" + xlog <- internAtom d atom False + + root <- rootWindow d (defaultScreen d) + selectInput d root propertyChangeMask + + let update = do + mwp <- getWindowProperty8 d xlog root + maybe (return ()) (cb . decodeCChar) mwp + + update + + allocaXEvent $ \ep -> forever $ do + nextEvent' d ep + e <- getEvent ep + case e of + PropertyEvent { ev_atom = a } | a == xlog -> update + _ -> return () + + return () + +decodeCChar :: [CChar] -> String +#ifdef UTF8 +#undef UTF8 +decodeCChar = UTF8.decode . map fromIntegral +#define UTF8 +#else +decodeCChar = map (toEnum . fromIntegral) +#endif diff --git a/src/Plugins/helloworld.config b/src/Plugins/helloworld.config new file mode 100644 index 0000000..3818bfa --- /dev/null +++ b/src/Plugins/helloworld.config @@ -0,0 +1,12 @@ +Config { font = "-misc-fixed-*-*-*-*-10-*-*-*-*-*-*-*" + , bgColor = "#000000" + , fgColor = "#BFBFBF" + , position = TopW C 90 + , commands = [ Run Cpu [] 10 + , Run Weather "LIPB" [] 36000 + , Run HelloWorld + ] + , sepChar = "%" + , alignSep = "}{" + , template = "%cpu% } %helloWorld% { %LIPB% | <fc=yellow>%date%</fc>" + } |