diff options
Diffstat (limited to 'src/Xmobar/Plugins')
38 files changed, 4764 insertions, 0 deletions
diff --git a/src/Xmobar/Plugins/BufferedPipeReader.hs b/src/Xmobar/Plugins/BufferedPipeReader.hs new file mode 100644 index 0000000..65ecea2 --- /dev/null +++ b/src/Xmobar/Plugins/BufferedPipeReader.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.BufferedPipeReader +-- Copyright : (c) Jochen Keil +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jochen Keil <jochen dot keil at gmail dot com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading (temporarily) from named pipes with reset +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.BufferedPipeReader(BufferedPipeReader(..)) where + +import Control.Monad(forM_, when, void) +import Control.Concurrent +import Control.Concurrent.STM +import System.IO +import System.IO.Unsafe(unsafePerformIO) + +import Xmobar.Utils(hGetLineSafe) +import Xmobar.Run.Commands +import Xmobar.System.Signal +import Xmobar.System.Environment + +data BufferedPipeReader = BufferedPipeReader String [(Int, Bool, String)] + deriving (Read, Show) + +{-# NOINLINE signal #-} +signal :: MVar SignalType +signal = unsafePerformIO newEmptyMVar + +instance Exec BufferedPipeReader where + alias ( BufferedPipeReader a _ ) = a + + trigger br@( BufferedPipeReader _ _ ) sh = + takeMVar signal >>= sh . Just >> trigger br sh + + start ( BufferedPipeReader _ ps ) cb = do + + (chan, str, rst) <- initV + forM_ ps $ \p -> forkIO $ reader p chan + writer chan str rst + + where + initV :: IO (TChan (Int, Bool, String), TVar (Maybe String), TVar Bool) + initV = atomically $ do + tc <- newTChan + ts <- newTVar Nothing + tb <- newTVar False + return (tc, ts, tb) + + reader :: (Int, Bool, FilePath) -> TChan (Int, Bool, String) -> IO () + reader p@(to, tg, fp) tc = do + fp' <- expandEnv fp + openFile fp' ReadWriteMode >>= hGetLineSafe >>= \dt -> + atomically $ writeTChan tc (to, tg, dt) + reader p tc + + writer :: TChan (Int, Bool, String) + -> TVar (Maybe String) -> TVar Bool -> IO () + writer tc ts otb = do + (to, tg, dt, ntb) <- update + cb dt + when tg $ putMVar signal $ Reveal 0 + when (to /= 0) $ sfork $ reset to tg ts ntb + writer tc ts ntb + + where + sfork :: IO () -> IO () + sfork f = void (forkIO f) + + update :: IO (Int, Bool, String, TVar Bool) + update = atomically $ do + (to, tg, dt) <- readTChan tc + when (to == 0) $ writeTVar ts $ Just dt + writeTVar otb False + tb <- newTVar True + return (to, tg, dt, tb) + + reset :: Int -> Bool -> TVar (Maybe String) -> TVar Bool -> IO () + reset to tg ts tb = do + threadDelay ( to * 100 * 1000 ) + readTVarIO tb >>= \b -> when b $ do + when tg $ putMVar signal $ Hide 0 + readTVarIO ts >>= maybe (return ()) cb diff --git a/src/Xmobar/Plugins/CommandReader.hs b/src/Xmobar/Plugins/CommandReader.hs new file mode 100644 index 0000000..69c8e0c --- /dev/null +++ b/src/Xmobar/Plugins/CommandReader.hs @@ -0,0 +1,40 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.CommandReader(CommandReader(..)) where + +import System.IO +import Xmobar.Run.Commands +import Xmobar.Utils (hGetLineSafe) +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/Xmobar/Plugins/Date.hs b/src/Xmobar/Plugins/Date.hs new file mode 100644 index 0000000..62a4ee7 --- /dev/null +++ b/src/Xmobar/Plugins/Date.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Date (Date(..)) where + +import Xmobar.Run.Commands + +#if ! MIN_VERSION_time(1,5,0) +import System.Locale +#endif +import Data.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 = fmap (formatTime defaultTimeLocale format) getZonedTime diff --git a/src/Xmobar/Plugins/DateZone.hs b/src/Xmobar/Plugins/DateZone.hs new file mode 100644 index 0000000..7215713 --- /dev/null +++ b/src/Xmobar/Plugins/DateZone.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DoAndIfThenElse #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.DateZone +-- Copyright : (c) Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner <martin@perner.cc> +-- Stability : unstable +-- Portability : unportable +-- +-- A date plugin with localization and location support for Xmobar +-- +-- Based on Plugins.Date +-- +-- Usage example: in template put +-- +-- > Run DateZone "%a %H:%M:%S" "de_DE.UTF-8" "UTC" "utcDate" 10 +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.DateZone (DateZone(..)) where + +import Xmobar.Run.Commands +import Xmobar.Utils(tenthSeconds) + +#ifdef DATEZONE +import Control.Concurrent.STM + +import System.IO.Unsafe + +import Data.Time.Format +import Data.Time.LocalTime +import Data.Time.LocalTime.TimeZone.Olson +import Data.Time.LocalTime.TimeZone.Series + +import Xmobar.System.Localize + +#if ! MIN_VERSION_time(1,5,0) +import System.Locale (TimeLocale) +#endif +#else +import System.IO +import Xmobar.Plugins.Date +#endif + + + +data DateZone = DateZone String String String String Int + deriving (Read, Show) + +instance Exec DateZone where + alias (DateZone _ _ _ a _) = a +#ifndef DATEZONE + start (DateZone f _ _ a r) cb = do + hPutStrLn stderr $ "Warning: DateZone plugin needs -fwith_datezone."++ + " Using Date plugin instead." + start (Date f a r) cb +#else + start (DateZone f l z _ r) cb = do + lock <- atomically $ takeTMVar localeLock + setupTimeLocale l + locale <- getTimeLocale + atomically $ putTMVar localeLock lock + if z /= "" then do + timeZone <- getTimeZoneSeriesFromOlsonFile ("/usr/share/zoneinfo/" ++ z) + go (dateZone f locale timeZone) + else + go (date f locale) + + where go func = func >>= cb >> tenthSeconds r >> go func + +{-# NOINLINE localeLock #-} +-- ensures that only one plugin instance sets the locale +localeLock :: TMVar Bool +localeLock = unsafePerformIO (newTMVarIO False) + +date :: String -> TimeLocale -> IO String +date format loc = getZonedTime >>= return . formatTime loc format + +dateZone :: String -> TimeLocale -> TimeZoneSeries -> IO String +dateZone format loc timeZone = getZonedTime >>= return . formatTime loc format . utcToLocalTime' timeZone . zonedTimeToUTC +-- zonedTime <- getZonedTime +-- return $ formatTime loc format $ utcToLocalTime' timeZone $ zonedTimeToUTC zonedTime +#endif diff --git a/src/Xmobar/Plugins/EWMH.hs b/src/Xmobar/Plugins/EWMH.hs new file mode 100644 index 0000000..4a443d6 --- /dev/null +++ b/src/Xmobar/Plugins/EWMH.hs @@ -0,0 +1,265 @@ +{-# OPTIONS_GHC -w #-} +{-# LANGUAGE CPP, NamedFieldPuns, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TupleSections, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.EWMH (EWMH(..)) where + +import Control.Applicative (Applicative(..)) +import Control.Monad.State +import Control.Monad.Reader +import Graphics.X11 hiding (Modifier, Color) +import Graphics.X11.Xlib.Extras +import Xmobar.Run.Commands +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar, CLong) +import Xmobar.Utils (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 } -> + 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, Applicative, 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 ((, 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 . fst) (Map.toList dels) + mapM_ (listen . fst) (Map.toList cl') + mapM_ (update . 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/Xmobar/Plugins/Kbd.hs b/src/Xmobar/Plugins/Kbd.hs new file mode 100644 index 0000000..f4dad36 --- /dev/null +++ b/src/Xmobar/Plugins/Kbd.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Kbd +-- Copyright : (c) Martin Perner +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Martin Perner <martin@perner.cc> +-- Stability : unstable +-- Portability : unportable +-- +-- A keyboard layout indicator for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Kbd(Kbd(..)) where + +import Data.List (isPrefixOf, findIndex) +import Data.Maybe (fromJust) +import Control.Monad (forever) +import Graphics.X11.Xlib +import Graphics.X11.Xlib.Extras + +import Xmobar.Run.Commands +import Xmobar.Utils (nextEvent') +import Xmobar.System.Kbd + + +-- 'Bad' prefixes of layouts +noLaySymbols :: [String] +noLaySymbols = ["group", "inet", "ctr", "pc", "ctrl"] + + +-- splits the layout string into the actual layouts +splitLayout :: String -> [String] +splitLayout s = splitLayout' noLaySymbols $ split s '+' + +splitLayout' :: [String] -> [String] -> [String] +-- end of recursion, remove empty strings +splitLayout' [] s = map (takeWhile (/= ':')) $ filter (not . null) s +-- remove current string if it has a 'bad' prefix +splitLayout' bad s = + splitLayout' (tail bad) [x | x <- s, not $ isPrefixOf (head bad) x] + +-- split String at each Char +split :: String -> Char -> [String] +split [] _ = [""] +split (c:cs) delim + | c == delim = "" : rest + | otherwise = (c : head rest) : tail rest + where + rest = split cs delim + +-- replaces input string if on search list (exact match) with corresponding +-- element on replacement list. +-- +-- if not found, return string unchanged +searchReplaceLayout :: KbdOpts -> String -> String +searchReplaceLayout opts s = let c = findIndex (\x -> fst x == s) opts in + case c of + Nothing -> s + x -> let i = fromJust x in snd $ opts!!i + +-- returns the active layout +getKbdLay :: Display -> KbdOpts -> IO String +getKbdLay dpy opts = do + lay <- getLayoutStr dpy + curLay <- getKbdLayout dpy + return $ searchReplaceLayout opts $ splitLayout lay!!curLay + + + +newtype Kbd = Kbd [(String, String)] + deriving (Read, Show) + +instance Exec Kbd where + alias (Kbd _) = "kbd" + start (Kbd opts) cb = do + + dpy <- openDisplay "" + + -- initial set of layout + cb =<< getKbdLay dpy opts + + -- enable listing for + -- group changes + _ <- xkbSelectEventDetails dpy xkbUseCoreKbd xkbStateNotify xkbAllStateComponentsMask xkbGroupStateMask + -- layout/geometry changes + _ <- xkbSelectEvents dpy xkbUseCoreKbd xkbNewKeyboardNotifyMask xkbNewKeyboardNotifyMask + + allocaXEvent $ \e -> forever $ do + nextEvent' dpy e + _ <- getEvent e + cb =<< getKbdLay dpy opts + + closeDisplay dpy + return () diff --git a/src/Xmobar/Plugins/Locks.hs b/src/Xmobar/Plugins/Locks.hs new file mode 100644 index 0000000..19bce20 --- /dev/null +++ b/src/Xmobar/Plugins/Locks.hs @@ -0,0 +1,64 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Locks +-- Copyright : (c) Patrick Chilton +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Patrick Chilton <chpatrick@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin that displays the status of the lock keys. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Locks(Locks(..)) where + +import Graphics.X11 +import Data.List +import Data.Bits +import Control.Monad +import Graphics.X11.Xlib.Extras +import Xmobar.Run.Commands +import Xmobar.System.Kbd +import Xmobar.Utils (nextEvent') + +data Locks = Locks + deriving (Read, Show) + +locks :: [ ( KeySym, String )] +locks = [ ( xK_Caps_Lock, "CAPS" ) + , ( xK_Num_Lock, "NUM" ) + , ( xK_Scroll_Lock, "SCROLL" ) + ] + +run' :: Display -> Window -> IO String +run' d root = do + modMap <- getModifierMapping d + ( _, _, _, _, _, _, _, m ) <- queryPointer d root + + ls <- filterM ( \( ks, _ ) -> do + kc <- keysymToKeycode d ks + return $ case find (elem kc . snd) modMap of + Nothing -> False + Just ( i, _ ) -> testBit m (fromIntegral i) + ) locks + + return $ unwords $ map snd ls + +instance Exec Locks where + alias Locks = "locks" + start Locks cb = do + d <- openDisplay "" + root <- rootWindow d (defaultScreen d) + _ <- xkbSelectEventDetails d xkbUseCoreKbd xkbIndicatorStateNotify m m + + allocaXEvent $ \ep -> forever $ do + cb =<< run' d root + nextEvent' d ep + getEvent ep + + closeDisplay d + return () + where + m = xkbAllStateComponentsMask diff --git a/src/Xmobar/Plugins/MBox.hs b/src/Xmobar/Plugins/MBox.hs new file mode 100644 index 0000000..4bd0ebd --- /dev/null +++ b/src/Xmobar/Plugins/MBox.hs @@ -0,0 +1,131 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.MBox (MBox(..)) where + +import Prelude +import Xmobar.Run.Commands +#ifdef INOTIFY +import Xmobar.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 + +#if MIN_VERSION_hinotify(0,3,10) +import qualified Data.ByteString.Char8 as BS (ByteString, pack) +pack :: String -> BS.ByteString +pack = BS.pack +#else +pack :: String -> String +pack = id +#endif + +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 + +#else +import System.IO +#endif + +-- | 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 +#ifndef INOTIFY + start _ _ = + hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify" ++ + " but the MBox plugin requires it" +#else + 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 (pack 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 (\(SomeException _) -> evaluate 0) + (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) +#endif diff --git a/src/Xmobar/Plugins/Mail.hs b/src/Xmobar/Plugins/Mail.hs new file mode 100644 index 0000000..d59e70d --- /dev/null +++ b/src/Xmobar/Plugins/Mail.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Mail(Mail(..)) where + +import Xmobar.Run.Commands +#ifdef INOTIFY +import Xmobar.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 + +#if MIN_VERSION_hinotify(0,3,10) +import qualified Data.ByteString.Char8 as BS (ByteString, pack, unpack) +unpack :: BS.ByteString -> String +unpack = BS.unpack +pack :: String -> BS.ByteString +pack = BS.pack +#else +unpack :: String -> String +unpack = id +pack :: String -> String +pack = id +#endif +#else +import System.IO +#endif + + +-- | A list of mail box names and paths to maildirs. +data Mail = Mail [(String, FilePath)] String + deriving (Read, Show) + +instance Exec Mail where + alias (Mail _ a) = a +#ifndef INOTIFY + start _ _ = + hPutStrLn stderr $ "Warning: xmobar is not compiled with -fwith_inotify," + ++ " but the Mail plugin requires it." +#else + 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)) (map pack 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 ] + +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 ((unpack . filePath) e) + create = S.insert ((unpack . filePath) e) +#endif diff --git a/src/Xmobar/Plugins/MarqueePipeReader.hs b/src/Xmobar/Plugins/MarqueePipeReader.hs new file mode 100644 index 0000000..a48e81c --- /dev/null +++ b/src/Xmobar/Plugins/MarqueePipeReader.hs @@ -0,0 +1,71 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.MarqueePipeReader +-- Copyright : (c) Reto Habluetzel +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A plugin for reading from named pipes for long texts with marquee +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.MarqueePipeReader where + +import System.IO (openFile, IOMode(ReadWriteMode), Handle) +import Xmobar.System.Environment +import Xmobar.Utils(tenthSeconds, hGetLineSafe) +import Xmobar.Run.Commands(Exec(alias, start)) +import System.Posix.Files (getFileStatus, isNamedPipe) +import Control.Concurrent(forkIO, threadDelay) +import Control.Concurrent.STM (TChan, atomically, writeTChan, tryReadTChan, newTChan) +import Control.Exception +import Control.Monad(forever, unless) +import Control.Applicative ((<$>)) + +type Length = Int -- length of the text to display +type Rate = Int -- delay in tenth seconds +type Separator = String -- if text wraps around, use separator + +data MarqueePipeReader = MarqueePipeReader String (Length, Rate, Separator) String + deriving (Read, Show) + +instance Exec MarqueePipeReader where + alias (MarqueePipeReader _ _ a) = a + start (MarqueePipeReader p (len, rate, sep) _) cb = do + (def, pipe) <- split ':' <$> expandEnv p + unless (null def) (cb def) + checkPipe pipe + h <- openFile pipe ReadWriteMode + line <- hGetLineSafe h + chan <- atomically newTChan + forkIO $ writer (toInfTxt line sep) sep len rate chan cb + forever $ pipeToChan h chan + where + split c xs | c `elem` xs = let (pre, post) = span (c /=) xs + in (pre, dropWhile (c ==) post) + | otherwise = ([], xs) + +pipeToChan :: Handle -> TChan String -> IO () +pipeToChan h chan = do + line <- hGetLineSafe h + atomically $ writeTChan chan line + +writer :: String -> Separator -> Length -> Rate -> TChan String -> (String -> IO ()) -> IO () +writer txt sep len rate chan cb = do + cb (take len txt) + mbnext <- atomically $ tryReadTChan chan + case mbnext of + Just new -> writer (toInfTxt new sep) sep len rate chan cb + Nothing -> tenthSeconds rate >> writer (drop 1 txt) sep len rate chan cb + +toInfTxt :: String -> String -> String +toInfTxt line sep = concat (repeat $ line ++ " " ++ sep ++ " ") + +checkPipe :: FilePath -> IO () +checkPipe file = handle (\(SomeException _) -> waitForPipe) $ do + status <- getFileStatus file + unless (isNamedPipe status) waitForPipe + where waitForPipe = threadDelay 1000 >> checkPipe file diff --git a/src/Xmobar/Plugins/Monitors.hs b/src/Xmobar/Plugins/Monitors.hs new file mode 100644 index 0000000..fe909d8 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Xmobar.Plugins.Monitors +-- Copyright : (c) 2010, 2011, 2012, 2013, 2017, 2018 Jose Antonio Ortega Ruiz +-- (c) 2007-10 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 Xmobar.Plugins.Monitors where + +import Xmobar.Run.Commands + +import Xmobar.Plugins.Monitors.Common (runM, runMD) +#ifdef WEATHER +import Xmobar.Plugins.Monitors.Weather +#endif +import Xmobar.Plugins.Monitors.Net +import Xmobar.Plugins.Monitors.Mem +import Xmobar.Plugins.Monitors.Swap +import Xmobar.Plugins.Monitors.Cpu +import Xmobar.Plugins.Monitors.MultiCpu +import Xmobar.Plugins.Monitors.Batt +import Xmobar.Plugins.Monitors.Bright +import Xmobar.Plugins.Monitors.Thermal +import Xmobar.Plugins.Monitors.ThermalZone +import Xmobar.Plugins.Monitors.CpuFreq +import Xmobar.Plugins.Monitors.CoreTemp +import Xmobar.Plugins.Monitors.Disk +import Xmobar.Plugins.Monitors.Top +import Xmobar.Plugins.Monitors.Uptime +import Xmobar.Plugins.Monitors.CatInt +#ifdef UVMETER +import Xmobar.Plugins.Monitors.UVMeter +#endif +#ifdef IWLIB +import Xmobar.Plugins.Monitors.Wireless +#endif +#ifdef LIBMPD +import Xmobar.Plugins.Monitors.MPD +import Xmobar.Plugins.Monitors.Common (runMBD) +#endif +#ifdef ALSA +import Xmobar.Plugins.Monitors.Volume +import Xmobar.Plugins.Monitors.Alsa +#endif +#ifdef MPRIS +import Xmobar.Plugins.Monitors.Mpris +#endif + +data Monitors = Network Interface Args Rate + | DynNetwork Args Rate + | BatteryP Args Args Rate + | BatteryN Args Args Rate Alias + | Battery Args Rate + | DiskU DiskSpec Args Rate + | DiskIO DiskSpec Args Rate + | Thermal Zone Args Rate + | ThermalZone ZoneNo Args Rate + | Memory Args Rate + | Swap Args Rate + | Cpu Args Rate + | MultiCpu Args Rate + | Brightness Args Rate + | CpuFreq Args Rate + | CoreTemp Args Rate + | TopProc Args Rate + | TopMem Args Rate + | Uptime Args Rate + | CatInt Int FilePath Args Rate +#ifdef WEATHER + | Weather Station Args Rate +#endif +#ifdef UVMETER + | UVMeter Station Args Rate +#endif +#ifdef IWLIB + | Wireless Interface Args Rate +#endif +#ifdef LIBMPD + | MPD Args Rate + | AutoMPD Args +#endif +#ifdef ALSA + | Volume String String Args Rate + | Alsa String String Args +#endif +#ifdef MPRIS + | Mpris1 String Args Rate + | Mpris2 String Args Rate +#endif + deriving (Show,Read,Eq) + +type Args = [String] +type Program = String +type Alias = String +type Station = String +type Zone = String +type ZoneNo = Int +type Interface = String +type Rate = Int +type DiskSpec = [(String, String)] + +instance Exec Monitors where +#ifdef WEATHER + alias (Weather s _ _) = s +#endif + alias (Network i _ _) = i + alias (DynNetwork _ _) = "dynnetwork" + alias (Thermal z _ _) = z + alias (ThermalZone z _ _) = "thermal" ++ show z + alias (Memory _ _) = "memory" + alias (Swap _ _) = "swap" + alias (Cpu _ _) = "cpu" + alias (MultiCpu _ _) = "multicpu" + alias (Battery _ _) = "battery" + alias BatteryP {} = "battery" + alias (BatteryN _ _ _ a)= a + alias (Brightness _ _) = "bright" + alias (CpuFreq _ _) = "cpufreq" + alias (TopProc _ _) = "top" + alias (TopMem _ _) = "topmem" + alias (CoreTemp _ _) = "coretemp" + alias DiskU {} = "disku" + alias DiskIO {} = "diskio" + alias (Uptime _ _) = "uptime" + alias (CatInt n _ _ _) = "cat" ++ show n +#ifdef UVMETER + alias (UVMeter s _ _) = "uv " ++ s +#endif +#ifdef IWLIB + alias (Wireless i _ _) = i ++ "wi" +#endif +#ifdef LIBMPD + alias (MPD _ _) = "mpd" + alias (AutoMPD _) = "autompd" +#endif +#ifdef ALSA + alias (Volume m c _ _) = m ++ ":" ++ c + alias (Alsa m c _) = "alsa:" ++ m ++ ":" ++ c +#endif +#ifdef MPRIS + alias (Mpris1 _ _ _) = "mpris1" + alias (Mpris2 _ _ _) = "mpris2" +#endif + start (Network i a r) = startNet i a r + start (DynNetwork a r) = startDynNet a r + start (Cpu a r) = startCpu a r + start (MultiCpu a r) = startMultiCpu a r + start (TopProc a r) = startTop a r + start (TopMem a r) = runM a topMemConfig runTopMem r +#ifdef WEATHER + start (Weather s a r) = runMD (a ++ [s]) weatherConfig runWeather r weatherReady +#endif + start (Thermal z a r) = runM (a ++ [z]) thermalConfig runThermal r + start (ThermalZone z a r) = + runM (a ++ [show z]) thermalZoneConfig runThermalZone r + start (Memory a r) = runM a memConfig runMem r + start (Swap a r) = runM a swapConfig runSwap r + start (Battery a r) = runM a battConfig runBatt r + start (BatteryP s a r) = runM a battConfig (runBatt' s) r + start (BatteryN s a r _) = runM a battConfig (runBatt' s) r + start (Brightness a r) = runM a brightConfig runBright 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) = startDiskIO s a r + start (Uptime a r) = runM a uptimeConfig runUptime r + start (CatInt _ s a r) = runM a catIntConfig (runCatInt s) r +#ifdef UVMETER + start (UVMeter s a r) = runM (a ++ [s]) uvConfig runUVMeter r +#endif +#ifdef IWLIB + start (Wireless i a r) = runM a wirelessConfig (runWireless i) r +#endif +#ifdef LIBMPD + start (MPD a r) = runMD a mpdConfig runMPD r mpdReady + start (AutoMPD a) = runMBD a mpdConfig runMPD mpdWait mpdReady +#endif +#ifdef ALSA + start (Volume m c a r) = runM a volumeConfig (runVolume m c) r + start (Alsa m c a) = startAlsaPlugin m c a +#endif +#ifdef MPRIS + start (Mpris1 s a r) = runM a mprisConfig (runMPRIS1 s) r + start (Mpris2 s a r) = runM a mprisConfig (runMPRIS2 s) r +#endif diff --git a/src/Xmobar/Plugins/Monitors/Alsa.hs b/src/Xmobar/Plugins/Monitors/Alsa.hs new file mode 100644 index 0000000..21a2786 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Alsa.hs @@ -0,0 +1,146 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Alsa +-- Copyright : (c) 2018 Daniel Schüssler +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Event-based variant of the Volume plugin. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Alsa + ( startAlsaPlugin + , withMonitorWaiter + , parseOptsIncludingMonitorArgs + , AlsaOpts(aoAlsaCtlPath) + ) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception +import Control.Monad +import Xmobar.Plugins.Monitors.Common +import qualified Xmobar.Plugins.Monitors.Volume as Volume; +import System.Console.GetOpt +import System.Directory +import System.Exit +import System.IO +import System.Process + +data AlsaOpts = AlsaOpts + { aoVolumeOpts :: Volume.VolumeOpts + , aoAlsaCtlPath :: Maybe FilePath + } + +defaultOpts :: AlsaOpts +defaultOpts = AlsaOpts Volume.defaultOpts Nothing + +alsaCtlOptionName :: String +alsaCtlOptionName = "alsactl" + +options :: [OptDescr (AlsaOpts -> AlsaOpts)] +options = + Option "" [alsaCtlOptionName] (ReqArg (\x o -> + o { aoAlsaCtlPath = Just x }) "") "" + : fmap (fmap modifyVolumeOpts) Volume.options + where + modifyVolumeOpts f o = o { aoVolumeOpts = f (aoVolumeOpts o) } + +parseOpts :: [String] -> IO AlsaOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +parseOptsIncludingMonitorArgs :: [String] -> IO AlsaOpts +parseOptsIncludingMonitorArgs args = + -- Drop generic Monitor args first + case getOpt Permute [] args of + (_, args', _) -> parseOpts args' + +startAlsaPlugin :: String -> String -> [String] -> (String -> IO ()) -> IO () +startAlsaPlugin mixerName controlName args cb = do + opts <- parseOptsIncludingMonitorArgs args + + let run args2 = do + -- Replicating the reparsing logic used by other plugins for now, + -- but it seems the option parsing could be floated out (actually, + -- GHC could in principle do it already since getOpt is pure, but + -- it would have to inline 'runMBD', 'doArgs' and 'parseOpts' to see + -- it, which probably isn't going to happen with the default + -- optimization settings). + opts2 <- io $ parseOpts args2 + Volume.runVolumeWith (aoVolumeOpts opts2) mixerName controlName + + withMonitorWaiter mixerName (aoAlsaCtlPath opts) $ \wait_ -> + runMB args Volume.volumeConfig run wait_ cb + +withMonitorWaiter :: String -> Maybe FilePath -> (IO () -> IO a) -> IO a +withMonitorWaiter mixerName alsaCtlPath cont = do + mvar <- newMVar () + + path <- determineAlsaCtlPath + + bracket (async $ readerThread mvar path) cancel $ \a -> do + + -- Throw on this thread if there's an exception + -- on the reader thread. + link a + + cont $ takeMVar mvar + + where + + readerThread mvar path = + let createProc = (proc "stdbuf" ["-oL", path, "monitor", mixerName]) + {std_out = CreatePipe} + in + withCreateProcess createProc $ \_ (Just alsaOut) _ _ -> do + hSetBuffering alsaOut LineBuffering + + forever $ do + c <- hGetChar alsaOut + when (c == '\n') $ + -- This uses 'tryPutMVar' because 'putMVar' would make 'runVolume' run + -- once for each event. But we want it to run only once after a burst + -- of events. + void $ tryPutMVar mvar () + + defaultPath = "/usr/sbin/alsactl" + + determineAlsaCtlPath = + case alsaCtlPath of + Just path -> do + found <- doesFileExist path + if found + then pure path + else throwIO . ErrorCall $ + "Specified alsactl file " ++ path ++ " does not exist" + + Nothing -> do + (ec, path, err) <- readProcessWithExitCode "which" ["alsactl"] "" + unless (null err) $ hPutStrLn stderr err + case ec of + ExitSuccess -> pure $ trimTrailingNewline path + ExitFailure _ -> do + found <- doesFileExist defaultPath + if found + then pure defaultPath + else throwIO . ErrorCall $ + "alsactl not found in PATH or at " ++ + show defaultPath ++ + "; please specify with --" ++ + alsaCtlOptionName ++ "=/path/to/alsactl" + + +-- This is necessarily very inefficient on 'String's +trimTrailingNewline :: String -> String +trimTrailingNewline x = + case reverse x of + '\n' : '\r' : y -> reverse y + '\n' : y -> reverse y + _ -> x diff --git a/src/Xmobar/Plugins/Monitors/Batt.hs b/src/Xmobar/Plugins/Monitors/Batt.hs new file mode 100644 index 0000000..80f4275 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Batt.hs @@ -0,0 +1,247 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Batt +-- Copyright : (c) 2010, 2011, 2012, 2013, 2015, 2016, 2018 Jose A Ortega +-- (c) 2010 Andrea Rossato, Petr Rockai +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A battery monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where + +import Control.Exception (SomeException, handle) +import Xmobar.Plugins.Monitors.Common +import System.FilePath ((</>)) +import System.IO (IOMode(ReadMode), hGetLine, withFile) +import System.Posix.Files (fileExist) +import System.Console.GetOpt +import Data.List (sort, sortBy, group) +import Data.Maybe (fromMaybe) +import Data.Ord (comparing) +import Text.Read (readMaybe) + +data BattOpts = BattOpts + { onString :: String + , offString :: String + , idleString :: String + , posColor :: Maybe String + , lowWColor :: Maybe String + , mediumWColor :: Maybe String + , highWColor :: Maybe String + , lowThreshold :: Float + , highThreshold :: Float + , onlineFile :: FilePath + , scale :: Float + , onIconPattern :: Maybe IconPattern + , offIconPattern :: Maybe IconPattern + , idleIconPattern :: Maybe IconPattern + } + +defaultOpts :: BattOpts +defaultOpts = BattOpts + { onString = "On" + , offString = "Off" + , idleString = "On" + , posColor = Nothing + , lowWColor = Nothing + , mediumWColor = Nothing + , highWColor = Nothing + , lowThreshold = 10 + , highThreshold = 12 + , onlineFile = "AC/online" + , scale = 1e6 + , onIconPattern = Nothing + , offIconPattern = Nothing + , idleIconPattern = Nothing + } + +options :: [OptDescr (BattOpts -> BattOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "i" ["idle"] (ReqArg (\x o -> o { idleString = 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 }) "") "" + , Option "f" ["online"] (ReqArg (\x o -> o { onlineFile = x }) "") "" + , Option "s" ["scale"] (ReqArg (\x o -> o {scale = read x}) "") "" + , Option "" ["on-icon-pattern"] (ReqArg (\x o -> + o { onIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["off-icon-pattern"] (ReqArg (\x o -> + o { offIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["idle-icon-pattern"] (ReqArg (\x o -> + o { idleIconPattern = Just $ parseIconPattern 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 Status = Charging | Discharging | Full | Idle | Unknown deriving (Read, Eq) + +data Result = Result Float Float Float Status | NA + +sysDir :: FilePath +sysDir = "/sys/class/power_supply" + +battConfig :: IO MConfig +battConfig = mkMConfig + "Batt: <watts>, <left>% / <timeleft>" -- template + ["leftbar", "leftvbar", "left", "acstatus", "timeleft", "watts", "leftipat"] -- replacements + +data Files = Files + { fFull :: String + , fNow :: String + , fVoltage :: String + , fCurrent :: String + , fStatus :: String + , isCurrent :: Bool + } | NoFiles deriving Eq + +data Battery = Battery + { full :: !Float + , now :: !Float + , power :: !Float + , status :: !String + } + +safeFileExist :: String -> String -> IO Bool +safeFileExist d f = handle noErrors $ fileExist (d </> f) + where noErrors = const (return False) :: SomeException -> IO Bool + +batteryFiles :: String -> IO Files +batteryFiles bat = + do is_charge <- exists "charge_now" + is_energy <- if is_charge then return False else exists "energy_now" + is_power <- exists "power_now" + plain <- exists (if is_charge then "charge_full" else "energy_full") + let cf = if is_power then "power_now" else "current_now" + sf = if plain then "" else "_design" + return $ case (is_charge, is_energy) of + (True, _) -> files "charge" cf sf is_power + (_, True) -> files "energy" cf sf is_power + _ -> NoFiles + where prefix = sysDir </> bat + exists = safeFileExist prefix + files ch cf sf ip = Files { fFull = prefix </> ch ++ "_full" ++ sf + , fNow = prefix </> ch ++ "_now" + , fCurrent = prefix </> cf + , fVoltage = prefix </> "voltage_now" + , fStatus = prefix </> "status" + , isCurrent = not ip} + +haveAc :: FilePath -> IO Bool +haveAc f = + handle onError $ withFile (sysDir </> f) ReadMode (fmap (== "1") . hGetLine) + where onError = const (return False) :: SomeException -> IO Bool + +readBattery :: Float -> Files -> IO Battery +readBattery _ NoFiles = return $ Battery 0 0 0 "Unknown" +readBattery sc files = + do a <- grab $ fFull files + b <- grab $ fNow files + d <- grab $ fCurrent files + s <- grabs $ fStatus files + let sc' = if isCurrent files then sc / 10 else sc + a' = max a b -- sometimes the reported max charge is lower than + return $ Battery (3600 * a' / sc') -- wattseconds + (3600 * b / sc') -- wattseconds + (d / sc') -- watts + s -- string: Discharging/Charging/Full + where grab f = handle onError $ withFile f ReadMode (fmap read . hGetLine) + onError = const (return (-1)) :: SomeException -> IO Float + grabs f = handle onError' $ withFile f ReadMode hGetLine + onError' = const (return "Unknown") :: SomeException -> IO String + +-- sortOn is only available starting at ghc 7.10 +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = + map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x)) + +mostCommonDef :: Eq a => a -> [a] -> a +mostCommonDef x xs = head $ last $ [x] : sortOn length (group xs) + +readBatteries :: BattOpts -> [Files] -> IO Result +readBatteries opts bfs = + do let bfs' = filter (/= NoFiles) bfs + bats <- mapM (readBattery (scale opts)) (take 3 bfs') + ac <- haveAc (onlineFile opts) + let sign = if ac then 1 else -1 + ft = sum (map full bats) + left = if ft > 0 then sum (map now bats) / ft else 0 + watts = sign * sum (map power bats) + time = if watts == 0 then 0 else max 0 (sum $ map time' bats) + mwatts = if watts == 0 then 1 else sign * watts + time' b = (if ac then full b - now b else now b) / mwatts + statuses :: [Status] + statuses = map (fromMaybe Unknown . readMaybe) + (sort (map status bats)) + acst = mostCommonDef Unknown $ filter (Unknown/=) statuses + racst | acst /= Unknown = acst + | time == 0 = Idle + | ac = Charging + | otherwise = Discharging + return $ if isNaN left then NA else Result left watts time racst + +runBatt :: [String] -> Monitor String +runBatt = runBatt' ["BAT", "BAT0", "BAT1", "BAT2"] + +runBatt' :: [String] -> [String] -> Monitor String +runBatt' bfs args = do + opts <- io $ parseOpts args + c <- io $ readBatteries opts =<< mapM batteryFiles bfs + suffix <- getConfigValue useSuffix + d <- getConfigValue decDigits + nas <- getConfigValue naString + case c of + Result x w t s -> + do l <- fmtPercent x + ws <- fmtWatts w opts suffix d + si <- getIconPattern opts s x + parseTemplate (l ++ [fmtStatus opts s nas, fmtTime $ floor t, ws, si]) + NA -> getConfigValue naString + where fmtPercent :: Float -> Monitor [String] + fmtPercent x = do + let x' = minimum [1, x] + p <- showPercentWithColors x' + b <- showPercentBar (100 * x') x' + vb <- showVerticalBar (100 * x') x' + return [b, vb, p] + fmtWatts x o s d = do + ws <- showWithPadding $ showDigits d x ++ (if s then "W" else "") + return $ color x o ws + 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) + fmtStatus opts Idle _ = idleString opts + fmtStatus _ Unknown na = na + fmtStatus opts Full _ = idleString opts + fmtStatus opts Charging _ = onString opts + fmtStatus opts Discharging _ = offString opts + maybeColor Nothing str = str + 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) + getIconPattern opts st x = do + let x' = minimum [1, x] + case st of + Unknown -> showIconPattern (offIconPattern opts) x' + Idle -> showIconPattern (idleIconPattern opts) x' + Full -> showIconPattern (idleIconPattern opts) x' + Charging -> showIconPattern (onIconPattern opts) x' + Discharging -> showIconPattern (offIconPattern opts) x' diff --git a/src/Xmobar/Plugins/Monitors/Bright.hs b/src/Xmobar/Plugins/Monitors/Bright.hs new file mode 100644 index 0000000..fe72219 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Bright.hs @@ -0,0 +1,99 @@ +----------------------------------------------------------------------------- +---- | +---- Module : Plugins.Monitors.Birght +---- Copyright : (c) Martin Perner +---- License : BSD-style (see LICENSE) +---- +---- Maintainer : Martin Perner <martin@perner.cc> +---- Stability : unstable +---- Portability : unportable +---- +---- A screen brightness monitor for Xmobar +---- +------------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Bright (brightConfig, runBright) where + +import Control.Applicative ((<$>)) +import Control.Exception (SomeException, handle) +import qualified Data.ByteString.Lazy.Char8 as B +import System.FilePath ((</>)) +import System.Posix.Files (fileExist) +import System.Console.GetOpt + +import Xmobar.Plugins.Monitors.Common + +data BrightOpts = BrightOpts { subDir :: String + , currBright :: String + , maxBright :: String + , curBrightIconPattern :: Maybe IconPattern + } + +defaultOpts :: BrightOpts +defaultOpts = BrightOpts { subDir = "acpi_video0" + , currBright = "actual_brightness" + , maxBright = "max_brightness" + , curBrightIconPattern = Nothing + } + +options :: [OptDescr (BrightOpts -> BrightOpts)] +options = [ Option "D" ["device"] (ReqArg (\x o -> o { subDir = x }) "") "" + , Option "C" ["curr"] (ReqArg (\x o -> o { currBright = x }) "") "" + , Option "M" ["max"] (ReqArg (\x o -> o { maxBright = x }) "") "" + , Option "" ["brightness-icon-pattern"] (ReqArg (\x o -> + o { curBrightIconPattern = Just $ parseIconPattern x }) "") "" + ] + +-- from Batt.hs +parseOpts :: [String] -> IO BrightOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +sysDir :: FilePath +sysDir = "/sys/class/backlight/" + +brightConfig :: IO MConfig +brightConfig = mkMConfig "<percent>" -- template + ["vbar", "percent", "bar", "ipat"] -- replacements + +data Files = Files { fCurr :: String + , fMax :: String + } + | NoFiles + +brightFiles :: BrightOpts -> IO Files +brightFiles opts = do + is_curr <- fileExist $ fCurr files + is_max <- fileExist $ fCurr files + return (if is_curr && is_max then files else NoFiles) + where prefix = sysDir </> subDir opts + files = Files { fCurr = prefix </> currBright opts + , fMax = prefix </> maxBright opts + } + +runBright :: [String] -> Monitor String +runBright args = do + opts <- io $ parseOpts args + f <- io $ brightFiles opts + c <- io $ readBright f + case f of + NoFiles -> return "hurz" + _ -> fmtPercent opts c >>= parseTemplate + where fmtPercent :: BrightOpts -> Float -> Monitor [String] + fmtPercent opts c = do r <- showVerticalBar (100 * c) c + s <- showPercentWithColors c + t <- showPercentBar (100 * c) c + d <- showIconPattern (curBrightIconPattern opts) c + return [r,s,t,d] + +readBright :: Files -> IO Float +readBright NoFiles = return 0 +readBright files = do + currVal<- grab $ fCurr files + maxVal <- grab $ fMax files + return (currVal / maxVal) + where grab f = handle handler (read . B.unpack <$> B.readFile f) + handler = const (return 0) :: SomeException -> IO Float + diff --git a/src/Xmobar/Plugins/Monitors/CatInt.hs b/src/Xmobar/Plugins/Monitors/CatInt.hs new file mode 100644 index 0000000..781eded --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CatInt.hs @@ -0,0 +1,25 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.CatInt +-- Copyright : (c) Nathaniel Wesley Filardo +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Nathaniel Wesley Filardo +-- Stability : unstable +-- Portability : unportable +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.CatInt where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.Plugins.Monitors.CoreCommon + +catIntConfig :: IO MConfig +catIntConfig = mkMConfig "<v>" ["v"] + +runCatInt :: FilePath -> [String] -> Monitor String +runCatInt p _ = + let failureMessage = "Cannot read: " ++ show p + fmt x = show (truncate x :: Int) + in checkedDataRetrieval failureMessage [[p]] Nothing id fmt diff --git a/src/Xmobar/Plugins/Monitors/Common.hs b/src/Xmobar/Plugins/Monitors/Common.hs new file mode 100644 index 0000000..f683874 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Common.hs @@ -0,0 +1,545 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Common +-- Copyright : (c) 2010, 2011, 2013, 2016, 2017, 2018 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 Andrea Rossato +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Utilities used by xmobar's monitors +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Common ( + -- * Monitors + -- $monitor + Monitor + , MConfig (..) + , Opts (..) + , setConfigValue + , getConfigValue + , mkMConfig + , runM + , runMD + , runMB + , runMBD + , io + -- * Parsers + -- $parsers + , runP + , skipRestOfLine + , getNumbers + , getNumbersAsString + , getAllBut + , getAfterString + , skipTillString + , parseTemplate + , parseTemplate' + -- ** String Manipulation + -- $strings + , IconPattern + , parseIconPattern + , padString + , showWithPadding + , showWithColors + , showWithColors' + , showPercentWithColors + , showPercentsWithColors + , showPercentBar + , showVerticalBar + , showIconPattern + , showLogBar + , showLogVBar + , showLogIconPattern + , showWithUnits + , takeDigits + , showDigits + , floatToPercent + , parseFloat + , parseInt + , stringParser + ) where + + +import Control.Applicative ((<$>)) +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 Data.Char +import Numeric +import Text.ParserCombinators.Parsec +import System.Console.GetOpt +import Control.Exception (SomeException,handle) + +import Xmobar.Utils + +-- $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 + , decDigits :: IORef Int + , minWidth :: IORef Int + , maxWidth :: IORef Int + , maxWidthEllipsis :: IORef String + , padChars :: IORef String + , padRight :: IORef Bool + , barBack :: IORef String + , barFore :: IORef String + , barWidth :: IORef Int + , useSuffix :: IORef Bool + , naString :: IORef String + , maxTotalWidth :: IORef Int + , maxTotalWidthEllipsis :: IORef String + } + +-- | 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 (const 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 + d <- newIORef 0 + mn <- newIORef 0 + mx <- newIORef 0 + mel <- newIORef "" + pc <- newIORef " " + pr <- newIORef False + bb <- newIORef ":" + bf <- newIORef "#" + bw <- newIORef 10 + up <- newIORef False + na <- newIORef "N/A" + mt <- newIORef 0 + mtel <- newIORef "" + return $ MC nc l lc h hc t e p d mn mx mel pc pr bb bf bw up na mt mtel + +data Opts = HighColor String + | NormalColor String + | LowColor String + | Low String + | High String + | Template String + | PercentPad String + | DecDigits String + | MinWidth String + | MaxWidth String + | Width String + | WidthEllipsis String + | PadChars String + | PadAlign String + | BarBack String + | BarFore String + | BarWidth String + | UseSuffix String + | NAString String + | MaxTotalWidth String + | MaxTotalWidthEllipsis 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 "d" ["ddigits"] (ReqArg DecDigits "decimal digits") "Number of decimal digits to display." + , 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 "e" ["maxwidthellipsis"] (ReqArg WidthEllipsis "Maximum width ellipsis") "Ellipsis to be added to the field when it has reached its max 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" + , Option "x" ["nastring"] (ReqArg NAString "N/A string") "String used when the monitor is not available" + , Option "T" ["maxtwidth"] (ReqArg MaxTotalWidth "Maximum total width") "Maximum total width" + , Option "E" ["maxtwidthellipsis"] (ReqArg MaxTotalWidthEllipsis "Maximum total width ellipsis") "Ellipsis to be added to the total text when it has reached its max width." + ] + +doArgs :: [String] -> ([String] -> Monitor String) -> ([String] -> Monitor Bool) -> Monitor String +doArgs args action detect = + case getOpt Permute options args of + (o, n, []) -> do doConfigOptions o + ready <- detect n + if ready + then action n + else return "<Waiting...>" + (_, _, 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 + DecDigits d -> setConfigValue (nz d) decDigits + MinWidth w -> setConfigValue (nz w) minWidth + MaxWidth w -> setConfigValue (nz w) maxWidth + Width w -> setConfigValue (nz w) minWidth >> + setConfigValue (nz w) maxWidth + WidthEllipsis e -> setConfigValue e maxWidthEllipsis + 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 + NAString s -> setConfigValue s naString + MaxTotalWidth w -> setConfigValue (nz w) maxTotalWidth + MaxTotalWidthEllipsis e -> setConfigValue e maxTotalWidthEllipsis) >> next + +runM :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int + -> (String -> IO ()) -> IO () +runM args conf action r = runMB args conf action (tenthSeconds r) + +runMD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> Int + -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () +runMD args conf action r = runMBD args conf action (tenthSeconds r) + +runMB :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () + -> (String -> IO ()) -> IO () +runMB args conf action wait = runMBD args conf action wait (\_ -> return True) + +runMBD :: [String] -> IO MConfig -> ([String] -> Monitor String) -> IO () + -> ([String] -> Monitor Bool) -> (String -> IO ()) -> IO () +runMBD args conf action wait detect cb = handle (cb . showException) loop + where ac = doArgs args action detect + loop = conf >>= runReaderT ac >>= cb >> wait >> 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 = fmap concat . many $ + many1 (noneOf "<") <|> colorSpec <|> iconSpec + +-- | 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 ++ ">") + +-- | Recognizes icon specification and returns it unchanged +iconSpec :: Parser String +iconSpec = try (do string "<icon=" + i <- manyTill (noneOf ">") (try (string "/>")) + return $ "<icon=" ++ i ++ "/>") + +-- | 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 --"%") + +trimTo :: Int -> String -> String -> (Int, String) +trimTo n p "" = (n, p) +trimTo n p ('<':cs) = trimTo n p' s + where p' = p ++ "<" ++ takeWhile (/= '>') cs ++ ">" + s = drop 1 (dropWhile (/= '>') cs) +trimTo 0 p s = trimTo 0 p (dropWhile (/= '<') s) +trimTo n p s = let p' = takeWhile (/= '<') s + s' = dropWhile (/= '<') s + in + if length p' <= n + then trimTo (n - length p') (p ++ p') s' + else trimTo 0 (p ++ take n p') s' + +-- | 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, trimmed to MaxTotalWidth if that +-- configuration value is positive. +parseTemplate :: [String] -> Monitor String +parseTemplate l = + do t <- getConfigValue template + e <- getConfigValue export + w <- getConfigValue maxTotalWidth + ell <- getConfigValue maxTotalWidthEllipsis + let m = Map.fromList . zip e $ l + s <- parseTemplate' t m + let (n, s') = if w > 0 && length s > w + then trimTo (w - length ell) "" s + else (1, s) + return $ if n > 0 then s' else s' ++ ell + +-- | Parses the template given to it with a map of export values and combines +-- them +parseTemplate' :: String -> Map.Map String String -> Monitor String +parseTemplate' t m = + do s <- io $ runP templateParser t + combine m s + +-- | Given a finite "Map" and a parsed template t produces the +-- | resulting output string as the output of the monitor. +combine :: Map.Map String String -> [(String, String, String)] -> Monitor String +combine _ [] = return [] +combine m ((s,ts,ss):xs) = + do next <- combine m xs + str <- case Map.lookup ts m of + Nothing -> return $ "<" ++ ts ++ ">" + Just r -> let f "" = r; f n = n; in f <$> parseTemplate' r m + return $ s ++ str ++ ss ++ next + +-- $strings + +type IconPattern = Int -> String + +parseIconPattern :: String -> IconPattern +parseIconPattern path = + let spl = splitOnPercent path + in \i -> intercalate (show i) spl + where splitOnPercent [] = [[]] + splitOnPercent ('%':'%':xs) = [] : splitOnPercent xs + splitOnPercent (x:xs) = + let rest = splitOnPercent xs + in (x : head rest) : tail rest + +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 -> String +padString mnw mxw pad pr ellipsis 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 ++ ellipsis + 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 + ellipsis <- getConfigValue maxWidthEllipsis + return $ padString mn mx p pr ellipsis 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 = fmap 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) + +showIconPattern :: Maybe IconPattern -> Float -> Monitor String +showIconPattern Nothing _ = return "" +showIconPattern (Just str) x = return $ str $ convert $ 100 * x + where convert val + | t <= 0 = 0 + | t > 8 = 8 + | otherwise = t + where t = round val `div` 12 + +showVerticalBar :: Float -> Float -> Monitor String +showVerticalBar v x = colorizeString v [convert $ 100 * x] + where convert :: Float -> Char + convert val + | t <= 9600 = ' ' + | t > 9608 = chr 9608 + | otherwise = chr t + where t = 9600 + (round val `div` 12) + +logScaling :: Float -> Float -> Monitor Float +logScaling f v = do + h <- fromIntegral `fmap` getConfigValue high + l <- fromIntegral `fmap` getConfigValue low + bw <- fromIntegral `fmap` getConfigValue barWidth + let [ll, hh] = sort [l, h] + scaled x | x == 0.0 = 0 + | x <= ll = 1 / bw + | otherwise = f + logBase 2 (x / hh) / bw + return $ scaled v + +showLogBar :: Float -> Float -> Monitor String +showLogBar f v = logScaling f v >>= showPercentBar v + +showLogVBar :: Float -> Float -> Monitor String +showLogVBar f v = logScaling f v >>= showVerticalBar v + +showLogIconPattern :: Maybe IconPattern -> Float -> Float -> Monitor String +showLogIconPattern str f v = logScaling f v >>= showIconPattern str diff --git a/src/Xmobar/Plugins/Monitors/CoreCommon.hs b/src/Xmobar/Plugins/Monitors/CoreCommon.hs new file mode 100644 index 0000000..a84198e --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CoreCommon.hs @@ -0,0 +1,138 @@ +{-# LANGUAGE CPP, PatternGuards #-} + +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.CoreCommon where + +#if __GLASGOW_HASKELL__ < 800 +import Control.Applicative +#endif + +import Data.Char hiding (Space) +import Data.Function +import Data.List +import Data.Maybe +import Xmobar.Plugins.Monitors.Common +import System.Directory + +checkedDataRetrieval :: (Ord a, Num a) + => String -> [[String]] -> Maybe (String, String -> Int) + -> (Double -> a) -> (a -> String) -> Monitor String +checkedDataRetrieval msg paths lbl trans fmt = + fmap (fromMaybe msg . listToMaybe . catMaybes) $ + mapM (\p -> retrieveData p lbl trans fmt) paths + +retrieveData :: (Ord a, Num a) + => [String] -> Maybe (String, String -> Int) + -> (Double -> a) -> (a -> String) -> Monitor (Maybe String) +retrieveData path lbl trans fmt = do + pairs <- map snd . sortBy (compare `on` fst) <$> + (mapM readFiles =<< findFilesAndLabel path lbl) + if null pairs + then return Nothing + else Just <$> ( parseTemplate + =<< mapM (showWithColors fmt . trans . read) pairs + ) + +-- | Represents the different types of path components +data Comp = Fix String + | Var [String] + deriving Show + +-- | Used to represent parts of file names separated by slashes and spaces +data CompOrSep = Slash + | Space + | Comp String + deriving (Eq, Show) + +-- | Function to turn a list of of strings into a list of path components +pathComponents :: [String] -> [Comp] +pathComponents = joinComps . drop 2 . intercalate [Space] . map splitParts + where + splitParts p | (l, _:r) <- break (== '/') p = Comp l : Slash : splitParts r + | otherwise = [Comp p] + + joinComps = uncurry joinComps' . partition isComp + + isComp (Comp _) = True + isComp _ = False + + fromComp (Comp s) = s + fromComp _ = error "fromComp applied to value other than (Comp _)" + + joinComps' cs [] = [Fix $ fromComp $ head cs] -- cs should have only one element here, + -- but this keeps the pattern matching + -- exhaustive + joinComps' cs (p:ps) = let (ss, ps') = span (== p) ps + ct = if null ps' || (p == Space) then length ss + 1 + else length ss + (ls, rs) = splitAt (ct+1) cs + c = case p of + Space -> Var $ map fromComp ls + Slash -> Fix $ intercalate "/" $ map fromComp ls + _ -> error "Should not happen" + in if null ps' then [c] + else c:joinComps' rs (drop ct ps) + +-- | Function to find all files matching the given path and possible label file. +-- The path must be absolute (start with a leading slash). +findFilesAndLabel :: [String] -> Maybe (String, String -> Int) + -> Monitor [(String, Either Int (String, String -> Int))] +findFilesAndLabel path lbl = catMaybes + <$> ( mapM addLabel . zip [0..] . sort + =<< recFindFiles (pathComponents path) "/" + ) + where + addLabel (i, f) = maybe (return $ Just (f, Left i)) + (uncurry (justIfExists f)) + lbl + + justIfExists f s t = let f' = take (length f - length s) f ++ s + in ifthen (Just (f, Right (f', t))) Nothing <$> io (doesFileExist f') + + recFindFiles [] d = ifthen [d] [] + <$> io (if null d then return False else doesFileExist d) + recFindFiles ps d = ifthen (recFindFiles' ps d) (return []) + =<< io (if null d then return True else doesDirectoryExist d) + + recFindFiles' [] _ = error "Should not happen" + recFindFiles' (Fix p:ps) d = recFindFiles ps (d ++ "/" ++ p) + recFindFiles' (Var p:ps) d = concat + <$> ((mapM (recFindFiles ps + . (\f -> d ++ "/" ++ f)) + . filter (matchesVar p)) + =<< io (getDirectoryContents d) + ) + + matchesVar [] _ = False + matchesVar [v] f = v == f + matchesVar (v:vs) f = let f' = drop (length v) f + f'' = dropWhile isDigit f' + in and [ v `isPrefixOf` f + , not (null f') + , isDigit (head f') + , matchesVar vs f'' + ] + +-- | Function to read the contents of the given file(s) +readFiles :: (String, Either Int (String, String -> Int)) + -> Monitor (Int, String) +readFiles (fval, flbl) = (,) <$> either return (\(f, ex) -> fmap ex + $ io $ readFile f) flbl + <*> io (readFile fval) + +-- | Function that captures if-then-else +ifthen :: a -> a -> Bool -> a +ifthen thn els cnd = if cnd then thn else els diff --git a/src/Xmobar/Plugins/Monitors/CoreTemp.hs b/src/Xmobar/Plugins/Monitors/CoreTemp.hs new file mode 100644 index 0000000..48fe428 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CoreTemp.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.CoreTemp where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.Plugins.Monitors.CoreCommon + + +import Data.Char (isDigit) + +-- | +-- 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 + (map ((++) "core" . show) [0 :: Int ..]) -- available + -- replacements + +-- | +-- Function retrieves monitor string holding the core temperature +-- (or temperatures) +runCoreTemp :: [String] -> Monitor String +runCoreTemp _ = do + dn <- getConfigValue decDigits + failureMessage <- getConfigValue naString + let path = ["/sys/bus/platform/devices/coretemp.", "/temp", "_input"] + path' = ["/sys/bus/platform/devices/coretemp.", "/hwmon/hwmon", "/temp", "_input"] + lbl = Just ("_label", read . dropWhile (not . isDigit)) + divisor = 1e3 :: Double + show' = showDigits (max 0 dn) + checkedDataRetrieval failureMessage [path, path'] lbl (/divisor) show' diff --git a/src/Xmobar/Plugins/Monitors/Cpu.hs b/src/Xmobar/Plugins/Monitors/Cpu.hs new file mode 100644 index 0000000..6befe7d --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Cpu.hs @@ -0,0 +1,88 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Cpu +-- Copyright : (c) 2011, 2017 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 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 Xmobar.Plugins.Monitors.Cpu (startCpu) where + +import Xmobar.Plugins.Monitors.Common +import qualified Data.ByteString.Lazy.Char8 as B +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Console.GetOpt + +newtype CpuOpts = CpuOpts + { loadIconPattern :: Maybe IconPattern + } + +defaultOpts :: CpuOpts +defaultOpts = CpuOpts + { loadIconPattern = Nothing + } + +options :: [OptDescr (CpuOpts -> CpuOpts)] +options = + [ Option "" ["load-icon-pattern"] (ReqArg (\x o -> + o { loadIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO CpuOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +cpuConfig :: IO MConfig +cpuConfig = mkMConfig + "Cpu: <total>%" + ["bar","vbar","ipat","total","user","nice","system","idle","iowait"] + +type CpuDataRef = IORef [Int] + +cpuData :: IO [Int] +cpuData = cpuParser `fmap` B.readFile "/proc/stat" + +cpuParser :: B.ByteString -> [Int] +cpuParser = map (read . B.unpack) . tail . B.words . head . B.lines + +parseCpu :: CpuDataRef -> IO [Float] +parseCpu cref = + do a <- readIORef cref + b <- cpuData + writeIORef cref b + let dif = zipWith (-) b a + tot = fromIntegral $ sum dif + percent = map ((/ tot) . fromIntegral) dif + return percent + +formatCpu :: CpuOpts -> [Float] -> Monitor [String] +formatCpu _ [] = return $ replicate 8 "" +formatCpu opts xs = do + let t = sum $ take 3 xs + b <- showPercentBar (100 * t) t + v <- showVerticalBar (100 * t) t + d <- showIconPattern (loadIconPattern opts) t + ps <- showPercentsWithColors (t:xs) + return (b:v:d:ps) + +runCpu :: CpuDataRef -> [String] -> Monitor String +runCpu cref argv = + do c <- io (parseCpu cref) + opts <- io $ parseOpts argv + l <- formatCpu opts c + parseTemplate l + +startCpu :: [String] -> Int -> (String -> IO ()) -> IO () +startCpu a r cb = do + cref <- newIORef [] + _ <- parseCpu cref + runM a cpuConfig (runCpu cref) r cb diff --git a/src/Xmobar/Plugins/Monitors/CpuFreq.hs b/src/Xmobar/Plugins/Monitors/CpuFreq.hs new file mode 100644 index 0000000..1afedfa --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/CpuFreq.hs @@ -0,0 +1,44 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.CpuFreq where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.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>" (map ((++) "cpu" . show) [0 :: Int ..]) + + +-- | +-- Function retrieves monitor string holding the cpu frequency (or +-- frequencies) +runCpuFreq :: [String] -> Monitor String +runCpuFreq _ = do + suffix <- getConfigValue useSuffix + ddigits <- getConfigValue decDigits + let path = ["/sys/devices/system/cpu/cpu", "/cpufreq/scaling_cur_freq"] + divisor = 1e6 :: Double + fmt x | x < 1 = if suffix then mhzFmt x ++ "MHz" + else ghzFmt x + | otherwise = ghzFmt x ++ if suffix then "GHz" else "" + mhzFmt x = show (round (x * 1000) :: Integer) + ghzFmt = showDigits ddigits + failureMessage <- getConfigValue naString + checkedDataRetrieval failureMessage [path] Nothing (/divisor) fmt diff --git a/src/Xmobar/Plugins/Monitors/Disk.hs b/src/Xmobar/Plugins/Monitors/Disk.hs new file mode 100644 index 0000000..3f89629 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Disk.hs @@ -0,0 +1,241 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Disk +-- Copyright : (c) 2010, 2011, 2012, 2014, 2018 Jose A Ortega Ruiz +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- Disk usage and throughput monitors for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where + +import Xmobar.Plugins.Monitors.Common +import Xmobar.System.StatFS + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) + +import Control.Exception (SomeException, handle) +import Control.Monad (zipWithM) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, find) +import Data.Maybe (catMaybes) +import System.Directory (canonicalizePath, doesFileExist) +import System.Console.GetOpt + +data DiskIOOpts = DiskIOOpts + { totalIconPattern :: Maybe IconPattern + , writeIconPattern :: Maybe IconPattern + , readIconPattern :: Maybe IconPattern + } + +parseDiskIOOpts :: [String] -> IO DiskIOOpts +parseDiskIOOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + where defaultOpts = DiskIOOpts + { totalIconPattern = Nothing + , writeIconPattern = Nothing + , readIconPattern = Nothing + } + options = + [ Option "" ["total-icon-pattern"] (ReqArg (\x o -> + o { totalIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["write-icon-pattern"] (ReqArg (\x o -> + o { writeIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["read-icon-pattern"] (ReqArg (\x o -> + o { readIconPattern = Just $ parseIconPattern x}) "") "" + ] + +diskIOConfig :: IO MConfig +diskIOConfig = mkMConfig "" ["total", "read", "write" + ,"totalbar", "readbar", "writebar" + ,"totalvbar", "readvbar", "writevbar" + ,"totalipat", "readipat", "writeipat" + ] + +data DiskUOpts = DiskUOpts + { freeIconPattern :: Maybe IconPattern + , usedIconPattern :: Maybe IconPattern + } + +parseDiskUOpts :: [String] -> IO DiskUOpts +parseDiskUOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + where defaultOpts = DiskUOpts + { freeIconPattern = Nothing + , usedIconPattern = Nothing + } + options = + [ Option "" ["free-icon-pattern"] (ReqArg (\x o -> + o { freeIconPattern = Just $ parseIconPattern x}) "") "" + , Option "" ["used-icon-pattern"] (ReqArg (\x o -> + o { usedIconPattern = Just $ parseIconPattern x}) "") "" + ] + +diskUConfig :: IO MConfig +diskUConfig = mkMConfig "" + [ "size", "free", "used", "freep", "usedp" + , "freebar", "freevbar", "freeipat" + , "usedbar", "usedvbar", "usedipat" + ] + +type DevName = String +type Path = String +type DevDataRef = IORef [(DevName, [Float])] + +mountedDevices :: [String] -> IO [(DevName, Path)] +mountedDevices req = do + s <- B.readFile "/etc/mtab" + parse `fmap` mapM mbcanon (devs s) + where + mbcanon (d, p) = doesFileExist d >>= \e -> + if e + then Just `fmap` canon (d,p) + else return Nothing + canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} + devs = filter isDev . map (firstTwo . B.words) . B.lines + parse = map undev . filter isReq . catMaybes + firstTwo (a:b:_) = (B.unpack a, B.unpack b) + firstTwo _ = ("", "") + isDev (d, _) = "/dev/" `isPrefixOf` d + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +diskDevices :: [String] -> IO [(DevName, Path)] +diskDevices req = do + s <- B.readFile "/proc/diskstats" + parse `fmap` mapM canon (devs s) + where + canon (d, p) = do {d' <- canonicalizePath d; return (d', p)} + devs = map (third . B.words) . B.lines + parse = map undev . filter isReq + third (_:_:c:_) = ("/dev/" ++ B.unpack c, B.unpack c) + third _ = ("", "") + isReq (d, p) = p `elem` req || drop 5 d `elem` req + undev (d, f) = (drop 5 d, f) + +mountedOrDiskDevices :: [String] -> IO [(DevName, Path)] +mountedOrDiskDevices req = do + mnt <- mountedDevices req + case mnt of + [] -> diskDevices req + other -> return other + +diskData :: IO [(DevName, [Float])] +diskData = do + s <- B.readFile "/proc/diskstats" + let extract ws = (head ws, map read (tail ws)) + return $ map (extract . map B.unpack . drop 2 . B.words) (B.lines s) + +mountedData :: DevDataRef -> [DevName] -> IO [(DevName, [Float])] +mountedData dref devs = do + dt <- readIORef dref + dt' <- diskData + writeIORef dref dt' + return $ map (parseDev (zipWith diff dt' dt)) devs + where diff (dev, xs) (_, ys) = (dev, zipWith (-) xs ys) + +parseDev :: [(DevName, [Float])] -> DevName -> (DevName, [Float]) +parseDev dat dev = + case find ((==dev) . fst) dat of + Nothing -> (dev, [0, 0, 0]) + Just (_, xs) -> + let rSp = speed (xs !! 2) (xs !! 3) + wSp = speed (xs !! 6) (xs !! 7) + sp = speed (xs !! 2 + xs !! 6) (xs !! 3 + xs !! 7) + speed x t = if t == 0 then 0 else 500 * x / t + dat' = if length xs > 6 then [sp, rSp, wSp] else [0, 0, 0] + in (dev, dat') + +speedToStr :: Float -> String +speedToStr = showWithUnits 2 1 + +sizeToStr :: Integer -> String +sizeToStr = showWithUnits 3 0 . fromIntegral + +findTempl :: DevName -> Path -> [(String, String)] -> String +findTempl dev path disks = + case find devOrPath disks of + Just (_, t) -> t + Nothing -> "" + where devOrPath (d, _) = d == dev || d == path + +devTemplates :: [(String, String)] + -> [(DevName, Path)] + -> [(DevName, [Float])] + -> [(String, [Float])] +devTemplates disks mounted dat = + map (\(d, p) -> (findTempl d p disks, findData d)) mounted + where findData dev = case find ((==dev) . fst) dat of + Nothing -> [0, 0, 0] + Just (_, xs) -> xs + +runDiskIO' :: DiskIOOpts -> (String, [Float]) -> Monitor String +runDiskIO' opts (tmp, xs) = do + s <- mapM (showWithColors speedToStr) xs + b <- mapM (showLogBar 0.8) xs + vb <- mapM (showLogVBar 0.8) xs + ipat <- mapM (\(f,v) -> showLogIconPattern (f opts) 0.8 v) + $ zip [totalIconPattern, readIconPattern, writeIconPattern] xs + setConfigValue tmp template + parseTemplate $ s ++ b ++ vb ++ ipat + +runDiskIO :: DevDataRef -> [(String, String)] -> [String] -> Monitor String +runDiskIO dref disks argv = do + opts <- io $ parseDiskIOOpts argv + dev <- io $ mountedOrDiskDevices (map fst disks) + dat <- io $ mountedData dref (map fst dev) + strs <- mapM (runDiskIO' opts) $ devTemplates disks dev dat + return $ unwords strs + +startDiskIO :: [(String, String)] -> + [String] -> Int -> (String -> IO ()) -> IO () +startDiskIO disks args rate cb = do + dev <- mountedOrDiskDevices (map fst disks) + dref <- newIORef (map (\d -> (fst d, repeat 0)) dev) + _ <- mountedData dref (map fst dev) + runM args diskIOConfig (runDiskIO dref disks) rate cb + +fsStats :: String -> IO [Integer] +fsStats path = do + stats <- getFileSystemStats path + case stats of + Nothing -> return [0, 0, 0] + Just f -> let tot = fsStatByteCount f + free = fsStatBytesAvailable f + used = fsStatBytesUsed f + in return [tot, free, used] + +runDiskU' :: DiskUOpts -> String -> String -> Monitor String +runDiskU' opts tmp path = do + setConfigValue tmp template + [total, free, diff] <- io (handle ign $ fsStats path) + let strs = map sizeToStr [free, diff] + freep = if total > 0 then free * 100 `div` total else 0 + fr = fromIntegral freep / 100 + s <- zipWithM showWithColors' strs [freep, 100 - freep] + sp <- showPercentsWithColors [fr, 1 - fr] + fb <- showPercentBar (fromIntegral freep) fr + fvb <- showVerticalBar (fromIntegral freep) fr + fipat <- showIconPattern (freeIconPattern opts) fr + ub <- showPercentBar (fromIntegral $ 100 - freep) (1 - fr) + uvb <- showVerticalBar (fromIntegral $ 100 - freep) (1 - fr) + uipat <- showIconPattern (usedIconPattern opts) (1 - fr) + parseTemplate $ [sizeToStr total] ++ s ++ sp ++ [fb,fvb,fipat,ub,uvb,uipat] + where ign = const (return [0, 0, 0]) :: SomeException -> IO [Integer] + + +runDiskU :: [(String, String)] -> [String] -> Monitor String +runDiskU disks argv = do + devs <- io $ mountedDevices (map fst disks) + opts <- io $ parseDiskUOpts argv + strs <- mapM (\(d, p) -> runDiskU' opts (findTempl d p disks) p) devs + return $ unwords strs diff --git a/src/Xmobar/Plugins/Monitors/MPD.hs b/src/Xmobar/Plugins/Monitors/MPD.hs new file mode 100644 index 0000000..9525254 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/MPD.hs @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where + +import Data.List +import Data.Maybe (fromMaybe) +import Xmobar.Plugins.Monitors.Common +import System.Console.GetOpt +import qualified Network.MPD as M +import Control.Concurrent (threadDelay) + +mpdConfig :: IO MConfig +mpdConfig = mkMConfig "MPD: <state>" + [ "bar", "vbar", "ipat", "state", "statei", "volume", "length" + , "lapsed", "remaining", "plength", "ppos", "flags", "file" + , "name", "artist", "composer", "performer" + , "album", "title", "track", "genre", "date" + ] + +data MOpts = MOpts + { mPlaying :: String + , mStopped :: String + , mPaused :: String + , mLapsedIconPattern :: Maybe IconPattern + } + +defaultOpts :: MOpts +defaultOpts = MOpts + { mPlaying = ">>" + , mStopped = "><" + , mPaused = "||" + , mLapsedIconPattern = Nothing + } + +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 "" ["lapsed-icon-pattern"] (ReqArg (\x o -> + o { mLapsedIconPattern = Just $ parseIconPattern x }) "") "" + ] + +runMPD :: [String] -> Monitor String +runMPD args = do + opts <- io $ mopts args + status <- io $ M.withMPD M.status + song <- io $ M.withMPD M.currentSong + s <- parseMPD status song opts + parseTemplate s + +mpdWait :: IO () +mpdWait = do + status <- M.withMPD $ M.idle [M.PlayerS, M.MixerS, M.OptionsS] + case status of + Left _ -> threadDelay 10000000 + _ -> return () + +mpdReady :: [String] -> Monitor Bool +mpdReady _ = do + response <- io $ M.withMPD M.ping + case response of + Right _ -> return True + -- Only cases where MPD isn't responding is an issue; bogus information at + -- least won't hold xmobar up. + Left M.NoMPD -> return False + Left (M.ConnectionError _) -> return False + Left _ -> return True + +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:replicate 19 "" +parseMPD (Right st) song opts = do + songData <- parseSong song + bar <- showPercentBar (100 * b) b + vbar <- showVerticalBar (100 * b) b + ipat <- showIconPattern (mLapsedIconPattern opts) b + return $ [bar, vbar, ipat, ss, si, vol, len, lap, remain, plen, ppos, flags] ++ songData + where s = M.stState st + ss = show s + si = stateGlyph s opts + vol = int2str $ fromMaybe 0 (M.stVolume st) + (p, t) = fromMaybe (0, 0) (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 + flags = playbackMode st + +stateGlyph :: M.State -> MOpts -> String +stateGlyph s o = + case s of + M.Playing -> mPlaying o + M.Paused -> mPaused o + M.Stopped -> mStopped o + +playbackMode :: M.Status -> String +playbackMode s = + concat [if p s then f else "-" | + (p,f) <- [(M.stRepeat,"r"), + (M.stRandom,"z"), + (M.stSingle,"s"), + (M.stConsume,"c")]] + +parseSong :: M.Response (Maybe M.Song) -> Monitor [String] +parseSong (Left _) = return $ repeat "" +parseSong (Right Nothing) = return $ repeat "" +parseSong (Right (Just s)) = + let str sel = maybe "" (intercalate ", " . map M.toString) (M.sgGetTag sel s) + sels = [ M.Name, M.Artist, M.Composer, M.Performer + , M.Album, M.Title, M.Track, M.Genre, M.Date ] + fields = M.toString (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 :: (Show a, Num a, Ord a) => a -> String +int2str x = if x < 10 then '0':sx else sx where sx = show x diff --git a/src/Xmobar/Plugins/Monitors/Mem.hs b/src/Xmobar/Plugins/Monitors/Mem.hs new file mode 100644 index 0000000..d69921b --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Mem.hs @@ -0,0 +1,96 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where + +import Xmobar.Plugins.Monitors.Common +import qualified Data.Map as M +import System.Console.GetOpt + +data MemOpts = MemOpts + { usedIconPattern :: Maybe IconPattern + , freeIconPattern :: Maybe IconPattern + , availableIconPattern :: Maybe IconPattern + } + +defaultOpts :: MemOpts +defaultOpts = MemOpts + { usedIconPattern = Nothing + , freeIconPattern = Nothing + , availableIconPattern = Nothing + } + +options :: [OptDescr (MemOpts -> MemOpts)] +options = + [ Option "" ["used-icon-pattern"] (ReqArg (\x o -> + o { usedIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["free-icon-pattern"] (ReqArg (\x o -> + o { freeIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["available-icon-pattern"] (ReqArg (\x o -> + o { availableIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO MemOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +memConfig :: IO MConfig +memConfig = mkMConfig + "Mem: <usedratio>% (<cache>M)" -- template + ["usedbar", "usedvbar", "usedipat", "freebar", "freevbar", "freeipat", + "availablebar", "availablevbar", "availableipat", + "usedratio", "freeratio", "availableratio", + "total", "free", "buffer", "cache", "available", "used"] -- available replacements + +fileMEM :: IO String +fileMEM = readFile "/proc/meminfo" + +parseMEM :: IO [Float] +parseMEM = + do file <- fileMEM + let content = map words $ take 8 $ lines file + info = M.fromList $ map (\line -> (head line, (read $ line !! 1 :: Float) / 1024)) content + [total, free, buffer, cache] = map (info M.!) ["MemTotal:", "MemFree:", "Buffers:", "Cached:"] + available = M.findWithDefault (free + buffer + cache) "MemAvailable:" info + used = total - available + usedratio = used / total + freeratio = free / total + availableratio = available / total + return [usedratio, freeratio, availableratio, total, free, buffer, cache, available, used] + +totalMem :: IO Float +totalMem = fmap ((*1024) . (!!1)) parseMEM + +usedMem :: IO Float +usedMem = fmap ((*1024) . (!!6)) parseMEM + +formatMem :: MemOpts -> [Float] -> Monitor [String] +formatMem opts (r:fr:ar:xs) = + do let f = showDigits 0 + mon i x = [showPercentBar (100 * x) x, showVerticalBar (100 * x) x, showIconPattern i x] + sequence $ mon (usedIconPattern opts) r + ++ mon (freeIconPattern opts) fr + ++ mon (availableIconPattern opts) ar + ++ map showPercentWithColors [r, fr, ar] + ++ map (showWithColors f) xs +formatMem _ _ = replicate 10 `fmap` getConfigValue naString + +runMem :: [String] -> Monitor String +runMem argv = + do m <- io parseMEM + opts <- io $ parseOpts argv + l <- formatMem opts m + parseTemplate l diff --git a/src/Xmobar/Plugins/Monitors/Mpris.hs b/src/Xmobar/Plugins/Monitors/Mpris.hs new file mode 100644 index 0000000..3556649 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Mpris.hs @@ -0,0 +1,148 @@ +{-# LANGUAGE OverloadedStrings #-} + +---------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Mpris +-- Copyright : (c) Artem Tarasov +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Artem Tarasov <lomereiter@gmail.com> +-- Stability : unstable +-- Portability : unportable +-- +-- MPRIS song info +-- +---------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where + +-- TODO: listen to signals + +import Xmobar.Plugins.Monitors.Common + +import Text.Printf (printf) + +import DBus +import qualified DBus.Client as DC + +import Control.Arrow ((***)) +import Data.Maybe ( fromJust ) +import Data.Int ( Int32, Int64 ) +import System.IO.Unsafe (unsafePerformIO) + +import Control.Exception (try) + +class MprisVersion a where + getMethodCall :: a -> String -> MethodCall + getMetadataReply :: a -> DC.Client -> String -> IO [Variant] + getMetadataReply mv c p = fmap methodReturnBody (DC.call_ c $ getMethodCall mv p) + fieldsList :: a -> [String] + +data MprisVersion1 = MprisVersion1 +instance MprisVersion MprisVersion1 where + getMethodCall MprisVersion1 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + } + where + busName = busName_ $ "org.mpris." ++ p + objectPath = objectPath_ "/Player" + interfaceName = interfaceName_ "org.freedesktop.MediaPlayer" + memberName = memberName_ "GetMetadata" + + fieldsList MprisVersion1 = [ "album", "artist", "arturl", "mtime", "title" + , "tracknumber" ] + +data MprisVersion2 = MprisVersion2 +instance MprisVersion MprisVersion2 where + getMethodCall MprisVersion2 p = (methodCall objectPath interfaceName memberName) + { methodCallDestination = Just busName + , methodCallBody = arguments + } + where + busName = busName_ $ "org.mpris.MediaPlayer2." ++ p + objectPath = objectPath_ "/org/mpris/MediaPlayer2" + interfaceName = interfaceName_ "org.freedesktop.DBus.Properties" + memberName = memberName_ "Get" + arguments = map (toVariant::String -> Variant) + ["org.mpris.MediaPlayer2.Player", "Metadata"] + + fieldsList MprisVersion2 = [ "xesam:album", "xesam:artist", "mpris:artUrl" + , "mpris:length", "xesam:title", + "xesam:trackNumber", "xesam:composer", + "xesam:genre" + ] + +mprisConfig :: IO MConfig +mprisConfig = mkMConfig "<artist> - <title>" + [ "album", "artist", "arturl", "length" + , "title", "tracknumber" , "composer", "genre" + ] + +{-# NOINLINE dbusClient #-} +dbusClient :: DC.Client +dbusClient = unsafePerformIO DC.connectSession + +runMPRIS :: (MprisVersion a) => a -> String -> [String] -> Monitor String +runMPRIS version playerName _ = do + metadata <- io $ getMetadata version dbusClient playerName + if [] == metadata then + getConfigValue naString + else mapM showWithPadding (makeList version metadata) >>= parseTemplate + +runMPRIS1 :: String -> [String] -> Monitor String +runMPRIS1 = runMPRIS MprisVersion1 + +runMPRIS2 :: String -> [String] -> Monitor String +runMPRIS2 = runMPRIS MprisVersion2 + +--------------------------------------------------------------------------- + +fromVar :: (IsVariant a) => Variant -> a +fromVar = fromJust . fromVariant + +unpackMetadata :: [Variant] -> [(String, Variant)] +unpackMetadata [] = [] +unpackMetadata xs = + (map (fromVar *** fromVar) . unpack . head) xs where + unpack v = case variantType v of + TypeDictionary _ _ -> dictionaryItems $ fromVar v + TypeVariant -> unpack $ fromVar v + TypeStructure _ -> + let x = structureItems (fromVar v) in + if null x then [] else unpack (head x) + _ -> [] + +getMetadata :: (MprisVersion a) => a -> DC.Client -> String -> IO [(String, Variant)] +getMetadata version client player = do + reply <- try (getMetadataReply version client player) :: + IO (Either DC.ClientError [Variant]) + return $ case reply of + Right metadata -> unpackMetadata metadata; + Left _ -> [] + +makeList :: (MprisVersion a) => a -> [(String, Variant)] -> [String] +makeList version md = map getStr (fieldsList version) where + formatTime n = (if hh == 0 then printf "%02d:%02d" + else printf "%d:%02d:%02d" hh) mm ss + where hh = (n `div` 60) `div` 60 + mm = (n `div` 60) `mod` 60 + ss = n `mod` 60 + getStr str = case lookup str md of + Nothing -> "" + Just v -> case variantType v of + TypeString -> fromVar v + TypeInt32 -> let num = fromVar v in + case str of + "mtime" -> formatTime (num `div` 1000) + "tracknumber" -> printf "%02d" num + "mpris:length" -> formatTime (num `div` 1000000) + "xesam:trackNumber" -> printf "%02d" num + _ -> (show::Int32 -> String) num + TypeInt64 -> let num = fromVar v in + case str of + "mpris:length" -> formatTime (num `div` 1000000) + _ -> (show::Int64 -> String) num + TypeArray TypeString -> + let x = arrayItems (fromVar v) in + if null x then "" else fromVar (head x) + _ -> "" diff --git a/src/Xmobar/Plugins/Monitors/MultiCpu.hs b/src/Xmobar/Plugins/Monitors/MultiCpu.hs new file mode 100644 index 0000000..3db3b5f --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/MultiCpu.hs @@ -0,0 +1,128 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.MultiCpu (startMultiCpu) where + +import Xmobar.Plugins.Monitors.Common +import Control.Applicative ((<$>)) +import qualified Data.ByteString.Lazy.Char8 as B +import Data.List (isPrefixOf, transpose, unfoldr) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import System.Console.GetOpt + +data MultiCpuOpts = MultiCpuOpts + { loadIconPatterns :: [IconPattern] + , loadIconPattern :: Maybe IconPattern + , fallbackIconPattern :: Maybe IconPattern + } + +defaultOpts :: MultiCpuOpts +defaultOpts = MultiCpuOpts + { loadIconPatterns = [] + , loadIconPattern = Nothing + , fallbackIconPattern = Nothing + } + +options :: [OptDescr (MultiCpuOpts -> MultiCpuOpts)] +options = + [ Option "" ["load-icon-pattern"] (ReqArg (\x o -> + o { loadIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["load-icon-patterns"] (ReqArg (\x o -> + o { loadIconPatterns = parseIconPattern x : loadIconPatterns o }) "") "" + , Option "" ["fallback-icon-pattern"] (ReqArg (\x o -> + o { fallbackIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO MultiCpuOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +variables :: [String] +variables = ["bar", "vbar","ipat","total","user","nice","system","idle"] +vNum :: Int +vNum = length variables + +multiCpuConfig :: IO MConfig +multiCpuConfig = + mkMConfig "Cpu: <total>%" $ + ["auto" ++ k | k <- variables] ++ + [ k ++ n | n <- "" : map show [0 :: Int ..] + , k <- variables] + +type CpuDataRef = IORef [[Int]] + +cpuData :: IO [[Int]] +cpuData = parse `fmap` B.readFile "/proc/stat" + where parse = map parseList . cpuLists + cpuLists = takeWhile isCpu . map B.words . B.lines + isCpu (w:_) = "cpu" `isPrefixOf` B.unpack w + isCpu _ = False + parseList = map (parseInt . B.unpack) . tail + +parseCpuData :: CpuDataRef -> IO [[Float]] +parseCpuData cref = + do as <- readIORef cref + bs <- cpuData + writeIORef cref bs + let p0 = zipWith percent bs as + return p0 + +percent :: [Int] -> [Int] -> [Float] +percent b a = if tot > 0 then map (/ tot) $ take 4 dif else [0, 0, 0, 0] + where dif = map fromIntegral $ zipWith (-) b a + tot = sum dif + +formatMultiCpus :: MultiCpuOpts -> [[Float]] -> Monitor [String] +formatMultiCpus _ [] = return [] +formatMultiCpus opts xs = concat <$> mapM (\(i, x) -> formatCpu opts i x) (zip [0..] xs) + +formatCpu :: MultiCpuOpts -> Int -> [Float] -> Monitor [String] +formatCpu opts i xs + | length xs < 4 = showPercentsWithColors $ replicate vNum 0.0 + | otherwise = let t = sum $ take 3 xs + in do b <- showPercentBar (100 * t) t + h <- showVerticalBar (100 * t) t + d <- showIconPattern tryString t + ps <- showPercentsWithColors (t:xs) + return (b:h:d:ps) + where tryString + | i == 0 = loadIconPattern opts + | i <= length (loadIconPatterns opts) = Just $ loadIconPatterns opts !! (i - 1) + | otherwise = fallbackIconPattern opts + +splitEvery :: Int -> [a] -> [[a]] +splitEvery n = unfoldr (\x -> if null x then Nothing else Just $ splitAt n x) + +groupData :: [String] -> [[String]] +groupData = transpose . tail . splitEvery vNum + +formatAutoCpus :: [String] -> Monitor [String] +formatAutoCpus [] = return $ replicate vNum "" +formatAutoCpus xs = return $ map unwords (groupData xs) + +runMultiCpu :: CpuDataRef -> [String] -> Monitor String +runMultiCpu cref argv = + do c <- io $ parseCpuData cref + opts <- io $ parseOpts argv + l <- formatMultiCpus opts c + a <- formatAutoCpus l + parseTemplate $ a ++ l + +startMultiCpu :: [String] -> Int -> (String -> IO ()) -> IO () +startMultiCpu a r cb = do + cref <- newIORef [[]] + _ <- parseCpuData cref + runM a multiCpuConfig (runMultiCpu cref) r cb diff --git a/src/Xmobar/Plugins/Monitors/Net.hs b/src/Xmobar/Plugins/Monitors/Net.hs new file mode 100644 index 0000000..81a5f6b --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Net.hs @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Net +-- Copyright : (c) 2011, 2012, 2013, 2014, 2017 Jose Antonio Ortega Ruiz +-- (c) 2007-2010 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 Xmobar.Plugins.Monitors.Net ( + startNet + , startDynNet + ) where + +import Xmobar.Plugins.Monitors.Common + +import Data.Word (Word64) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) +import Control.Monad (forM, filterM) +import System.Directory (getDirectoryContents, doesFileExist) +import System.FilePath ((</>)) +import System.Console.GetOpt +import System.IO.Error (catchIOError) + +import qualified Data.ByteString.Lazy.Char8 as B + +data NetOpts = NetOpts + { rxIconPattern :: Maybe IconPattern + , txIconPattern :: Maybe IconPattern + } + +defaultOpts :: NetOpts +defaultOpts = NetOpts + { rxIconPattern = Nothing + , txIconPattern = Nothing + } + +options :: [OptDescr (NetOpts -> NetOpts)] +options = + [ Option "" ["rx-icon-pattern"] (ReqArg (\x o -> + o { rxIconPattern = Just $ parseIconPattern x }) "") "" + , Option "" ["tx-icon-pattern"] (ReqArg (\x o -> + o { txIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO NetOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +data UnitPerSec = Bs | KBs | MBs | GBs deriving (Eq,Enum,Ord) +data NetValue = NetValue Float UnitPerSec deriving (Eq,Show) + +instance Show UnitPerSec where + show Bs = "B/s" + show KBs = "KB/s" + show MBs = "MB/s" + show GBs = "GB/s" + +data NetDev num + = NA + | NI String + | ND String num num deriving (Eq,Show,Read) + +type NetDevRawTotal = NetDev Word64 +type NetDevRate = NetDev Float + +type NetDevRef = IORef (NetDevRawTotal, UTCTime) + +-- The more information available, the better. +-- Note that names don't matter. Therefore, if only the names differ, +-- a compare evaluates to EQ while (==) evaluates to False. +instance Ord num => Ord (NetDev num) where + compare NA NA = EQ + compare NA _ = LT + compare _ NA = GT + compare (NI _) (NI _) = EQ + compare (NI _) ND {} = LT + compare ND {} (NI _) = GT + compare (ND _ x1 y1) (ND _ x2 y2) = + if downcmp /= EQ + then downcmp + else y1 `compare` y2 + where downcmp = x1 `compare` x2 + +netConfig :: IO MConfig +netConfig = mkMConfig + "<dev>: <rx>KB|<tx>KB" -- template + ["dev", "rx", "tx", "rxbar", "rxvbar", "rxipat", "txbar", "txvbar", "txipat"] -- available replacements + +operstateDir :: String -> FilePath +operstateDir d = "/sys/class/net" </> d </> "operstate" + +existingDevs :: IO [String] +existingDevs = getDirectoryContents "/sys/class/net" >>= filterM isDev + where isDev d | d `elem` excludes = return False + | otherwise = doesFileExist (operstateDir d) + excludes = [".", "..", "lo"] + +isUp :: String -> IO Bool +isUp d = flip catchIOError (const $ return False) $ do + operstate <- B.readFile (operstateDir d) + return $! (B.unpack . head . B.lines) operstate `elem` ["up", "unknown"] + +readNetDev :: [String] -> IO NetDevRawTotal +readNetDev (d:x:y:_) = do + up <- isUp d + return (if up then ND d (r x) (r y) else NI d) + where r s | s == "" = 0 + | otherwise = read s + +readNetDev _ = return NA + +netParser :: B.ByteString -> IO [NetDevRawTotal] +netParser = mapM (readNetDev . splitDevLine) . readDevLines + where readDevLines = drop 2 . B.lines + splitDevLine = selectCols . wordsBy (`elem` " :") . B.unpack + selectCols cols = map (cols!!) [0,1,9] + wordsBy f s = case dropWhile f s of + [] -> [] + s' -> w : wordsBy f s'' where (w, s'') = break f s' + +findNetDev :: String -> IO NetDevRawTotal +findNetDev dev = do + nds <- B.readFile "/proc/net/dev" >>= netParser + case filter isDev nds of + x:_ -> return x + _ -> return NA + where isDev (ND d _ _) = d == dev + isDev (NI d) = d == dev + isDev NA = False + +formatNet :: Maybe IconPattern -> Float -> Monitor (String, String, String, String) +formatNet mipat d = do + s <- getConfigValue useSuffix + dd <- getConfigValue decDigits + let str True v = showDigits dd d' ++ show u + where (NetValue d' u) = byteNetVal v + str False v = showDigits dd $ v / 1024 + b <- showLogBar 0.9 d + vb <- showLogVBar 0.9 d + ipat <- showLogIconPattern mipat 0.9 d + x <- showWithColors (str s) d + return (x, b, vb, ipat) + +printNet :: NetOpts -> NetDevRate -> Monitor String +printNet opts nd = + case nd of + ND d r t -> do + (rx, rb, rvb, ripat) <- formatNet (rxIconPattern opts) r + (tx, tb, tvb, tipat) <- formatNet (txIconPattern opts) t + parseTemplate [d,rx,tx,rb,rvb,ripat,tb,tvb,tipat] + NI _ -> return "" + NA -> getConfigValue naString + +parseNet :: NetDevRef -> String -> IO NetDevRate +parseNet nref nd = do + (n0, t0) <- readIORef nref + n1 <- findNetDev nd + t1 <- getCurrentTime + writeIORef nref (n1, t1) + let scx = realToFrac (diffUTCTime t1 t0) + scx' = if scx > 0 then scx else 1 + rate da db = takeDigits 2 $ fromIntegral (db - da) / scx' + diffRate (ND d ra ta) (ND _ rb tb) = ND d (rate ra rb) (rate ta tb) + diffRate (NI d) _ = NI d + diffRate _ (NI d) = NI d + diffRate _ _ = NA + return $ diffRate n0 n1 + +runNet :: NetDevRef -> String -> [String] -> Monitor String +runNet nref i argv = do + dev <- io $ parseNet nref i + opts <- io $ parseOpts argv + printNet opts dev + +parseNets :: [(NetDevRef, String)] -> IO [NetDevRate] +parseNets = mapM $ uncurry parseNet + +runNets :: [(NetDevRef, String)] -> [String] -> Monitor String +runNets refs argv = do + dev <- io $ parseActive refs + opts <- io $ parseOpts argv + printNet opts dev + where parseActive refs' = fmap selectActive (parseNets refs') + selectActive = maximum + +startNet :: String -> [String] -> Int -> (String -> IO ()) -> IO () +startNet i a r cb = do + t0 <- getCurrentTime + nref <- newIORef (NA, t0) + _ <- parseNet nref i + runM a netConfig (runNet nref i) r cb + +startDynNet :: [String] -> Int -> (String -> IO ()) -> IO () +startDynNet a r cb = do + devs <- existingDevs + refs <- forM devs $ \d -> do + t <- getCurrentTime + nref <- newIORef (NA, t) + _ <- parseNet nref d + return (nref, d) + runM a netConfig (runNets refs) r cb + +byteNetVal :: Float -> NetValue +byteNetVal v + | v < 1024**1 = NetValue v Bs + | v < 1024**2 = NetValue (v/1024**1) KBs + | v < 1024**3 = NetValue (v/1024**2) MBs + | otherwise = NetValue (v/1024**3) GBs diff --git a/src/Xmobar/Plugins/Monitors/Swap.hs b/src/Xmobar/Plugins/Monitors/Swap.hs new file mode 100644 index 0000000..fcaab84 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Swap.hs @@ -0,0 +1,56 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Swap where + +import Xmobar.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 + | null 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 + d <- getConfigValue decDigits + other <- mapM (showWithColors (showDigits d)) 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/Xmobar/Plugins/Monitors/Thermal.hs b/src/Xmobar/Plugins/Monitors/Thermal.hs new file mode 100644 index 0000000..320ae17 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Thermal.hs @@ -0,0 +1,39 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Thermal where + +import qualified Data.ByteString.Lazy.Char8 as B +import Xmobar.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 + if exists + then do number <- io $ fmap ((read :: String -> Int) . stringParser (1, 0)) (B.readFile file) + thermal <- showWithColors show number + parseTemplate [ thermal ] + else return $ "Thermal (" ++ zone ++ "): N/A" diff --git a/src/Xmobar/Plugins/Monitors/ThermalZone.hs b/src/Xmobar/Plugins/Monitors/ThermalZone.hs new file mode 100644 index 0000000..bc46b59 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/ThermalZone.hs @@ -0,0 +1,49 @@ +------------------------------------------------------------------------------ +-- | +-- Module : Plugins.Monitors.ThermalZone +-- Copyright : (c) 2011, 2013 Jose Antonio Ortega Ruiz +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : jao@gnu.org +-- Stability : unstable +-- Portability : portable +-- Created : Fri Feb 25, 2011 03:18 +-- +-- +-- A thermal zone plugin based on the sysfs linux interface. +-- See http://kernel.org/doc/Documentation/thermal/sysfs-api.txt +-- +------------------------------------------------------------------------------ + +module Xmobar.Plugins.Monitors.ThermalZone (thermalZoneConfig, runThermalZone) where + +import Xmobar.Plugins.Monitors.Common + +import System.Posix.Files (fileExist) +import Control.Exception (IOException, catch) +import qualified Data.ByteString.Char8 as B + +-- | Default thermal configuration. +thermalZoneConfig :: IO MConfig +thermalZoneConfig = mkMConfig "<temp>C" ["temp"] + +-- | Retrieves thermal information. Argument is name of thermal +-- directory in \/sys\/clas\/thermal. Returns the monitor string +-- parsed according to template (either default or user specified). +runThermalZone :: [String] -> Monitor String +runThermalZone args = do + let zone = head args + file = "/sys/class/thermal/thermal_zone" ++ zone ++ "/temp" + handleIOError :: IOException -> IO (Maybe B.ByteString) + handleIOError _ = return Nothing + parse = return . (read :: String -> Int) . B.unpack + exists <- io $ fileExist file + if exists + then do contents <- io $ catch (fmap Just $ B.readFile file) handleIOError + case contents of + Just d -> do + mdegrees <- parse d + temp <- showWithColors show (mdegrees `quot` 1000) + parseTemplate [ temp ] + Nothing -> getConfigValue naString + else getConfigValue naString diff --git a/src/Xmobar/Plugins/Monitors/Top.hs b/src/Xmobar/Plugins/Monitors/Top.hs new file mode 100644 index 0000000..d6df249 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Top.hs @@ -0,0 +1,195 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Top +-- Copyright : (c) 2010, 2011, 2012, 2013, 2014, 2018 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 #-} +{-# LANGUAGE BangPatterns #-} + +module Xmobar.Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where + +import Xmobar.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 + +statWords :: [String] -> [String] +statWords line@(x:pn:ppn:xs) = + if last pn == ')' then line else statWords (x:(pn ++ " " ++ ppn):xs) +statWords _ = replicate 52 "0" + +getProcessData :: FilePath -> IO [String] +getProcessData pidf = + handle ign $ withFile ("/proc" </> pidf </> "stat") ReadMode readWords + where readWords = fmap (statWords . words) . hGetLine + ign = const (return []) :: SomeException -> IO [String] + +memPages :: [String] -> String +memPages fs = fs!!23 + +ppid :: [String] -> String +ppid fs = fs!!3 + +skip :: [String] -> Bool +skip fs = length fs < 24 || memPages fs == "0" || ppid fs == "0" + +handleProcesses :: ([String] -> a) -> IO [a] +handleProcesses f = + fmap (foldl' (\a p -> if skip p 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 3 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) = + getConfigValue decDigits >>= \d -> showInfo n (showDigits d 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/Xmobar/Plugins/Monitors/UVMeter.hs b/src/Xmobar/Plugins/Monitors/UVMeter.hs new file mode 100644 index 0000000..079177f --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/UVMeter.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.UVMeter +-- Copyright : (c) Róman Joost +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Róman Joost +-- Stability : unstable +-- Portability : unportable +-- +-- An australian uv monitor for Xmobar +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.UVMeter where + +import Xmobar.Plugins.Monitors.Common + +import qualified Control.Exception as CE +import Network.HTTP.Conduit + (parseRequest, newManager, tlsManagerSettings, httpLbs, + responseBody) +import Data.ByteString.Lazy.Char8 as B +import Text.Read (readMaybe) +import Text.Parsec +import Text.Parsec.String +import Control.Monad (void) + + +uvConfig :: IO MConfig +uvConfig = mkMConfig + "<station>" -- template + ["station" -- available replacements + ] + +newtype UvInfo = UV { index :: String } + deriving (Show) + +uvURL :: String +uvURL = "https://uvdata.arpansa.gov.au/xml/uvvalues.xml" + +getData :: IO String +getData = + CE.catch (do request <- parseRequest uvURL + manager <- newManager tlsManagerSettings + res <- httpLbs request manager + return $ B.unpack $ responseBody res) + errHandler + where errHandler + :: CE.SomeException -> IO String + errHandler _ = return "<Could not retrieve data>" + +textToXMLDocument :: String -> Either ParseError [XML] +textToXMLDocument = parse document "" + +formatUVRating :: Maybe Float -> Monitor String +formatUVRating Nothing = getConfigValue naString +formatUVRating (Just x) = do + uv <- showWithColors show x + parseTemplate [uv] + +getUVRating :: String -> [XML] -> Maybe Float +getUVRating locID (Element "stations" _ y:_) = getUVRating locID y +getUVRating locID (Element "location" [Attribute attr] ys:xs) + | locID == snd attr = getUVRating locID ys + | otherwise = getUVRating locID xs +getUVRating _ (Element "index" [] [Body rate]:_) = readMaybe rate +getUVRating locID (_:xs) = getUVRating locID xs +getUVRating _ [] = Nothing + + +runUVMeter :: [String] -> Monitor String +runUVMeter [] = return "N.A." +runUVMeter (s:_) = do + resp <- io getData + case textToXMLDocument resp of + Right doc -> formatUVRating (getUVRating s doc) + Left _ -> getConfigValue naString + +-- | XML Parsing code comes here. +-- This is a very simple XML parser to just deal with the uvvalues.xml +-- provided by ARPANSA. If you work on a new plugin which needs an XML +-- parser perhaps consider using a real XML parser and refactor this +-- plug-in to us it as well. +-- +-- Note: This parser can not deal with short tags. +-- +-- Kudos to: Charlie Harvey for his article about writing an XML Parser +-- with Parsec. +-- + +type AttrName = String +type AttrValue = String + +newtype Attribute = Attribute (AttrName, AttrValue) + deriving (Show) + +data XML = Element String [Attribute] [XML] + | Decl String + | Body String + deriving (Show) + +-- | parse the document +-- +document :: Parser [XML] +document = do + spaces + y <- try xmlDecl <|> tag + spaces + x <- many tag + spaces + return (y : x) + +-- | parse any tags +-- +tag :: Parser XML +tag = do + char '<' + spaces + name <- many (letter <|> digit) + spaces + attr <- many attribute + spaces + string ">" + eBody <- many elementBody + endTag name + spaces + return (Element name attr eBody) + +xmlDecl :: Parser XML +xmlDecl = do + void $ manyTill anyToken (string "<?xml") -- ignore the byte order mark + decl <- many (noneOf "?>") + string "?>" + return (Decl decl) + +elementBody :: Parser XML +elementBody = spaces *> try tag <|> text + +endTag :: String -> Parser String +endTag str = string "</" *> string str <* char '>' + +text :: Parser XML +text = Body <$> many1 (noneOf "><") + +attribute :: Parser Attribute +attribute = do + name <- many (noneOf "= />") + spaces + char '=' + spaces + char '"' + value <- many (noneOf "\"") + char '"' + spaces + return (Attribute (name, value)) diff --git a/src/Xmobar/Plugins/Monitors/Uptime.hs b/src/Xmobar/Plugins/Monitors/Uptime.hs new file mode 100644 index 0000000..235fc85 --- /dev/null +++ b/src/Xmobar/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 Xmobar.Plugins.Monitors.Uptime (uptimeConfig, runUptime) where + +import Xmobar.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/Xmobar/Plugins/Monitors/Volume.hs b/src/Xmobar/Plugins/Monitors/Volume.hs new file mode 100644 index 0000000..1d3281c --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Volume.hs @@ -0,0 +1,196 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Plugins.Monitors.Volume +-- Copyright : (c) 2011, 2013, 2015, 2018 Thomas Tuegel +-- License : BSD-style (see LICENSE) +-- +-- Maintainer : Jose A. Ortega Ruiz <jao@gnu.org> +-- Stability : unstable +-- Portability : unportable +-- +-- A monitor for ALSA soundcards +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.Monitors.Volume + ( runVolume + , runVolumeWith + , volumeConfig + , options + , defaultOpts + , VolumeOpts + ) where + +import Control.Applicative ((<$>)) +import Control.Monad ( liftM2, liftM3, mplus ) +import Data.Traversable (sequenceA) +import Xmobar.Plugins.Monitors.Common +import Sound.ALSA.Mixer +import qualified Sound.ALSA.Exception as AE +import System.Console.GetOpt + +volumeConfig :: IO MConfig +volumeConfig = mkMConfig "Vol: <volume>% <status>" + ["volume", "volumebar", "volumevbar", "dB","status", "volumeipat"] + + +data VolumeOpts = VolumeOpts + { onString :: String + , offString :: String + , onColor :: Maybe String + , offColor :: Maybe String + , highDbThresh :: Float + , lowDbThresh :: Float + , volumeIconPattern :: Maybe IconPattern + } + +defaultOpts :: VolumeOpts +defaultOpts = VolumeOpts + { onString = "[on] " + , offString = "[off]" + , onColor = Just "green" + , offColor = Just "red" + , highDbThresh = -5.0 + , lowDbThresh = -30.0 + , volumeIconPattern = Nothing + } + +options :: [OptDescr (VolumeOpts -> VolumeOpts)] +options = + [ Option "O" ["on"] (ReqArg (\x o -> o { onString = x }) "") "" + , Option "o" ["off"] (ReqArg (\x o -> o { offString = x }) "") "" + , Option "" ["lowd"] (ReqArg (\x o -> o { lowDbThresh = read x }) "") "" + , Option "" ["highd"] (ReqArg (\x o -> o { highDbThresh = read x }) "") "" + , Option "C" ["onc"] (ReqArg (\x o -> o { onColor = Just x }) "") "" + , Option "c" ["offc"] (ReqArg (\x o -> o { offColor = Just x }) "") "" + , Option "" ["volume-icon-pattern"] (ReqArg (\x o -> + o { volumeIconPattern = Just $ parseIconPattern x }) "") "" + ] + +parseOpts :: [String] -> IO VolumeOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +percent :: Integer -> Integer -> Integer -> Float +percent v' lo' hi' = (v - lo) / (hi - lo) + where v = fromIntegral v' + lo = fromIntegral lo' + hi = fromIntegral hi' + +formatVol :: Integer -> Integer -> Integer -> Monitor String +formatVol lo hi v = + showPercentWithColors $ percent v lo hi + +formatVolBar :: Integer -> Integer -> Integer -> Monitor String +formatVolBar lo hi v = + showPercentBar (100 * x) x where x = percent v lo hi + +formatVolVBar :: Integer -> Integer -> Integer -> Monitor String +formatVolVBar lo hi v = + showVerticalBar (100 * x) x where x = percent v lo hi + +formatVolDStr :: Maybe IconPattern -> Integer -> Integer -> Integer -> Monitor String +formatVolDStr ipat lo hi v = + showIconPattern ipat $ percent v lo hi + +switchHelper :: VolumeOpts + -> (VolumeOpts -> Maybe String) + -> (VolumeOpts -> String) + -> Monitor String +switchHelper opts cHelp strHelp = return $ + colorHelper (cHelp opts) + ++ strHelp opts + ++ maybe "" (const "</fc>") (cHelp opts) + +formatSwitch :: VolumeOpts -> Bool -> Monitor String +formatSwitch opts True = switchHelper opts onColor onString +formatSwitch opts False = switchHelper opts offColor offString + +colorHelper :: Maybe String -> String +colorHelper = maybe "" (\c -> "<fc=" ++ c ++ ">") + +formatDb :: VolumeOpts -> Integer -> Monitor String +formatDb opts dbi = do + h <- getConfigValue highColor + m <- getConfigValue normalColor + l <- getConfigValue lowColor + d <- getConfigValue decDigits + let db = fromIntegral dbi / 100.0 + digits = showDigits d db + startColor | db >= highDbThresh opts = colorHelper h + | db < lowDbThresh opts = colorHelper l + | otherwise = colorHelper m + stopColor | null startColor = "" + | otherwise = "</fc>" + return $ startColor ++ digits ++ stopColor + +runVolume :: String -> String -> [String] -> Monitor String +runVolume mixerName controlName argv = do + opts <- io $ parseOpts argv + runVolumeWith opts mixerName controlName + +runVolumeWith :: VolumeOpts -> String -> String -> Monitor String +runVolumeWith opts mixerName controlName = do + (lo, hi, val, db, sw) <- io readMixer + p <- liftMonitor $ liftM3 formatVol lo hi val + b <- liftMonitor $ liftM3 formatVolBar lo hi val + v <- liftMonitor $ liftM3 formatVolVBar lo hi val + d <- getFormatDB opts db + s <- getFormatSwitch opts sw + ipat <- liftMonitor $ liftM3 (formatVolDStr $ volumeIconPattern opts) lo hi val + parseTemplate [p, b, v, d, s, ipat] + + where + + readMixer = + AE.catch (withMixer mixerName $ \mixer -> do + control <- getControlByName mixer controlName + (lo, hi) <- liftMaybe $ getRange <$> volumeControl control + val <- getVal $ volumeControl control + db <- getDB $ volumeControl control + sw <- getSw $ switchControl control + return (lo, hi, val, db, sw)) + (const $ return (Nothing, Nothing, Nothing, Nothing, Nothing)) + + volumeControl :: Maybe Control -> Maybe Volume + volumeControl c = (playback . volume =<< c) + `mplus` (capture . volume =<< c) + `mplus` (common . volume =<< c) + + switchControl :: Maybe Control -> Maybe Switch + switchControl c = (playback . switch =<< c) + `mplus` (capture . switch =<< c) + `mplus` (common . switch =<< c) + + liftMaybe :: Maybe (IO (a,b)) -> IO (Maybe a, Maybe b) + liftMaybe = fmap (liftM2 (,) (fmap fst) (fmap snd)) . sequenceA + + liftMonitor :: Maybe (Monitor String) -> Monitor String + liftMonitor Nothing = unavailable + liftMonitor (Just m) = m + + channel v r = AE.catch (getChannel FrontLeft v) (const $ return $ Just r) + + getDB :: Maybe Volume -> IO (Maybe Integer) + getDB Nothing = return Nothing + getDB (Just v) = channel (dB v) 0 + + getVal :: Maybe Volume -> IO (Maybe Integer) + getVal Nothing = return Nothing + getVal (Just v) = channel (value v) 0 + + getSw :: Maybe Switch -> IO (Maybe Bool) + getSw Nothing = return Nothing + getSw (Just s) = channel s False + + getFormatDB :: VolumeOpts -> Maybe Integer -> Monitor String + getFormatDB _ Nothing = unavailable + getFormatDB opts' (Just d) = formatDb opts' d + + getFormatSwitch :: VolumeOpts -> Maybe Bool -> Monitor String + getFormatSwitch _ Nothing = unavailable + getFormatSwitch opts' (Just sw) = formatSwitch opts' sw + + unavailable = getConfigValue naString diff --git a/src/Xmobar/Plugins/Monitors/Weather.hs b/src/Xmobar/Plugins/Monitors/Weather.hs new file mode 100644 index 0000000..cb5bf07 --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Weather.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Weather where + +import Xmobar.Plugins.Monitors.Common + +import qualified Control.Exception as CE + +#ifdef HTTP_CONDUIT +import Network.HTTP.Conduit +import Network.HTTP.Types.Status +import Network.HTTP.Types.Method +import qualified Data.ByteString.Lazy.Char8 as B +#else +import Network.HTTP +#endif + +import Text.ParserCombinators.Parsec + +weatherConfig :: IO MConfig +weatherConfig = mkMConfig + "<station>: <tempC>C, rh <rh>% (<hour>)" -- template + ["station" -- available replacements + , "stationState" + , "year" + , "month" + , "day" + , "hour" + , "windCardinal" + , "windAzimuth" + , "windMph" + , "windKnots" + , "windKmh" + , "windMs" + , "visibility" + , "skyCondition" + , "tempC" + , "tempF" + , "dewPointC" + , "dewPointF" + , "rh" + , "pressure" + ] + +data WindInfo = + WindInfo { + windCardinal :: String -- cardinal direction + , windAzimuth :: String -- azimuth direction + , windMph :: String -- speed (MPH) + , windKnots :: String -- speed (knot) + , windKmh :: String -- speed (km/h) + , windMs :: String -- speed (m/s) + } deriving (Show) + +data WeatherInfo = + WI { stationPlace :: String + , stationState :: String + , year :: String + , month :: String + , day :: String + , hour :: String + , windInfo :: WindInfo + , visibility :: String + , skyCondition :: String + , tempC :: Int + , tempF :: Int + , dewPointC :: Int + , dewPointF :: Int + , 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) + +noWind :: WindInfo +noWind = WindInfo "μ" "μ" "0" "0" "0" "0" + +pWind :: Parser WindInfo +pWind = + let tospace = manyTill anyChar (char ' ') + toKmh knots = knots $* 1.852 + toMs knots = knots $* 0.514 + ($*) :: String -> Double -> String + op1 $* op2 = show (round ((read op1::Double) * op2)::Integer) + + -- Occasionally there is no wind and a METAR report gives simply, "Wind: Calm:0" + wind0 = do manyTill skipRestOfLine (string "Wind: Calm:0") + return noWind + windVar = do manyTill skipRestOfLine (string "Wind: Variable at ") + mph <- tospace + string "MPH (" + knot <- tospace + manyTill anyChar newline + return $ WindInfo "μ" "μ" mph knot (toKmh knot) (toMs knot) + wind = do manyTill skipRestOfLine (string "Wind: from the ") + cardinal <- tospace + char '(' + azimuth <- tospace + string "degrees) at " + mph <- tospace + string "MPH (" + knot <- tospace + manyTill anyChar newline + return $ WindInfo cardinal azimuth mph knot (toKmh knot) (toMs knot) + in try wind0 <|> try windVar <|> try wind <|> return noWind + +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 + +{- + example of 'http://weather.noaa.gov/pub/data/observations/metar/decoded/VTUD.TXT': + Station name not available + Aug 11, 2013 - 10:00 AM EDT / 2013.08.11 1400 UTC + Wind: from the N (350 degrees) at 1 MPH (1 KT):0 + Visibility: 4 mile(s):0 + Sky conditions: mostly clear + Temperature: 77 F (25 C) + Dew Point: 73 F (23 C) + Relative Humidity: 88% + Pressure (altimeter): 29.77 in. Hg (1008 hPa) + ob: VTUD 111400Z 35001KT 8000 FEW030 25/23 Q1008 A2977 INFO R RWY30 + cycle: 14 +-} +parseData :: Parser [WeatherInfo] +parseData = + do (st, ss) <- try (string "Station name not available" >> return ("??", "??")) <|> + (do st <- getAllBut "," + space + ss <- getAllBut "(" + return (st, ss) + ) + skipRestOfLine >> getAllBut "/" + (y,m,d,h) <- pTime + w <- pWind + v <- getAfterString "Visibility: " + sk <- getAfterString "Sky conditions: " + skipTillString "Temperature: " + (tC,tF) <- pTemp + skipTillString "Dew Point: " + (dC, dF) <- pTemp + 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 dC dF rh p] + +defUrl :: String +-- "http://weather.noaa.gov/pub/data/observations/metar/decoded/" +defUrl = "http://tgftp.nws.noaa.gov/data/observations/metar/decoded/" + +stationUrl :: String -> String +stationUrl station = defUrl ++ station ++ ".TXT" + +getData :: String -> IO String +#ifdef HTTP_CONDUIT +getData station = CE.catch (do + manager <- newManager tlsManagerSettings + request <- parseUrl $ stationUrl station + res <- httpLbs request manager + return $ B.unpack $ responseBody res + ) errHandler + where errHandler :: CE.SomeException -> IO String + errHandler _ = return "<Could not retrieve data>" +#else +getData station = do + let request = getRequest (stationUrl station) + CE.catch (simpleHTTP request >>= getResponseBody) errHandler + where errHandler :: CE.IOException -> IO String + errHandler _ = return "<Could not retrieve data>" +#endif + +formatWeather :: [WeatherInfo] -> Monitor String +formatWeather [WI st ss y m d h (WindInfo wc wa wm wk wkh wms) v sk tC tF dC dF r p] = + do cel <- showWithColors show tC + far <- showWithColors show tF + parseTemplate [st, ss, y, m, d, h, wc, wa, wm, wk, wkh, wms, v, sk, cel, far, show dC, show dF, show r , show p ] +formatWeather _ = getConfigValue naString + +runWeather :: [String] -> Monitor String +runWeather str = + do d <- io $ getData $ head str + i <- io $ runP parseData d + formatWeather i + +weatherReady :: [String] -> Monitor Bool +#ifdef HTTP_CONDUIT +weatherReady str = do + initRequest <- parseUrl $ stationUrl $ head str + let request = initRequest{method = methodHead} + io $ CE.catch ( do + manager <- newManager tlsManagerSettings + res <- httpLbs request manager + return $ checkResult $responseStatus res ) errHandler + where errHandler :: CE.SomeException -> IO Bool + errHandler _ = return False + checkResult status + | statusIsServerError status = False + | statusIsClientError status = False + | otherwise = True +#else +weatherReady str = do + let station = head str + request = headRequest (stationUrl station) + io $ CE.catch (simpleHTTP request >>= checkResult) errHandler + where errHandler :: CE.IOException -> IO Bool + errHandler _ = return False + checkResult result = + case result of + Left _ -> return False + Right response -> + case rspCode response of + -- Permission or network errors are failures; anything + -- else is recoverable. + (4, _, _) -> return False + (5, _, _) -> return False + (_, _, _) -> return True +#endif diff --git a/src/Xmobar/Plugins/Monitors/Wireless.hs b/src/Xmobar/Plugins/Monitors/Wireless.hs new file mode 100644 index 0000000..545f6bc --- /dev/null +++ b/src/Xmobar/Plugins/Monitors/Wireless.hs @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.Monitors.Wireless (wirelessConfig, runWireless) where + +import System.Console.GetOpt + +import Xmobar.Plugins.Monitors.Common +import Network.IWlib + +newtype WirelessOpts = WirelessOpts + { qualityIconPattern :: Maybe IconPattern + } + +defaultOpts :: WirelessOpts +defaultOpts = WirelessOpts + { qualityIconPattern = Nothing + } + +options :: [OptDescr (WirelessOpts -> WirelessOpts)] +options = + [ Option "" ["quality-icon-pattern"] (ReqArg (\d opts -> + opts { qualityIconPattern = Just $ parseIconPattern d }) "") "" + ] + +parseOpts :: [String] -> IO WirelessOpts +parseOpts argv = + case getOpt Permute options argv of + (o, _, []) -> return $ foldr id defaultOpts o + (_, _, errs) -> ioError . userError $ concat errs + +wirelessConfig :: IO MConfig +wirelessConfig = + mkMConfig "<essid> <quality>" + ["essid", "quality", "qualitybar", "qualityvbar", "qualityipat"] + +runWireless :: String -> [String] -> Monitor String +runWireless iface args = do + opts <- io $ parseOpts args + iface' <- if "" == iface then io findInterface else return iface + wi <- io $ getWirelessInfo iface' + na <- getConfigValue naString + let essid = wiEssid wi + qlty = fromIntegral $ wiQuality wi + e = if essid == "" then na else essid + ep <- showWithPadding e + q <- if qlty >= 0 + then showPercentWithColors (qlty / 100) + else showWithPadding "" + qb <- showPercentBar qlty (qlty / 100) + qvb <- showVerticalBar qlty (qlty / 100) + qipat <- showIconPattern (qualityIconPattern opts) (qlty / 100) + parseTemplate [ep, q, qb, qvb, qipat] + +findInterface :: IO String +findInterface = do + c <- readFile "/proc/net/wireless" + let nds = lines c + return $ if length nds > 2 then takeWhile (/= 'c') (nds!!2) else [] diff --git a/src/Xmobar/Plugins/PipeReader.hs b/src/Xmobar/Plugins/PipeReader.hs new file mode 100644 index 0000000..f18b9cb --- /dev/null +++ b/src/Xmobar/Plugins/PipeReader.hs @@ -0,0 +1,48 @@ +----------------------------------------------------------------------------- +-- | +-- 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 Xmobar.Plugins.PipeReader(PipeReader(..)) where + +import System.IO +import Xmobar.Utils(hGetLineSafe) +import Xmobar.Run.Commands(Exec(..)) +import Xmobar.System.Environment(expandEnv) +import System.Posix.Files +import Control.Concurrent(threadDelay) +import Control.Exception +import Control.Monad(forever, unless) +import Control.Applicative ((<$>)) + +data PipeReader = PipeReader String String + deriving (Read, Show) + +instance Exec PipeReader where + alias (PipeReader _ a) = a + start (PipeReader p _) cb = do + (def, pipe) <- split ':' <$> expandEnv p + unless (null def) (cb def) + checkPipe pipe + h <- openFile pipe ReadWriteMode + forever (hGetLineSafe h >>= cb) + where + split c xs | c `elem` xs = let (pre, post) = span (c /=) xs + in (pre, dropWhile (c ==) post) + | otherwise = ([], xs) + +checkPipe :: FilePath -> IO () +checkPipe file = + handle (\(SomeException _) -> waitForPipe) $ do + status <- getFileStatus file + unless (isNamedPipe status) waitForPipe + where waitForPipe = threadDelay 1000000 >> checkPipe file diff --git a/src/Xmobar/Plugins/StdinReader.hs b/src/Xmobar/Plugins/StdinReader.hs new file mode 100644 index 0000000..bed7f5c --- /dev/null +++ b/src/Xmobar/Plugins/StdinReader.hs @@ -0,0 +1,45 @@ +----------------------------------------------------------------------------- +-- | +-- 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`. +-- +-- Exports: +-- - `StdinReader` to safely display stdin content (striping actions). +-- - `UnsafeStdinReader` to display stdin content as-is. +-- +----------------------------------------------------------------------------- + +module Xmobar.Plugins.StdinReader (StdinReader(..)) where + +import Prelude +import System.Posix.Process +import System.Exit +import System.IO +import Control.Exception (SomeException(..), handle) +import Xmobar.Actions (stripActions) +import Xmobar.Utils (hGetLineSafe) +import Xmobar.Run.Commands + +data StdinReader = StdinReader | UnsafeStdinReader + deriving (Read, Show) + +instance Exec StdinReader where + start stdinReader cb = do + s <- handle (\(SomeException e) -> do hPrint stderr e; return "") + (hGetLineSafe stdin) + cb $ escape stdinReader s + eof <- isEOF + if eof + then exitImmediately ExitSuccess + else start stdinReader cb + +escape :: StdinReader -> String -> String +escape StdinReader = stripActions +escape UnsafeStdinReader = id diff --git a/src/Xmobar/Plugins/XMonadLog.hs b/src/Xmobar/Plugins/XMonadLog.hs new file mode 100644 index 0000000..a4f17bb --- /dev/null +++ b/src/Xmobar/Plugins/XMonadLog.hs @@ -0,0 +1,91 @@ +{-# 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 Xmobar.Plugins.XMonadLog (XMonadLog(..)) where + +import Control.Monad +import Graphics.X11 +import Graphics.X11.Xlib.Extras +import Xmobar.Run.Commands +#ifdef UTF8 +#undef UTF8 +import Codec.Binary.UTF8.String as UTF8 +#define UTF8 +#endif +import Foreign.C (CChar) +import Xmobar.Utils (nextEvent') +import Xmobar.Actions (stripActions) + +data XMonadLog = XMonadLog + | UnsafeXMonadLog + | XPropertyLog String + | UnsafeXPropertyLog String + | NamedXPropertyLog String String + | UnsafeNamedXPropertyLog String String + deriving (Read, Show) + +instance Exec XMonadLog where + alias XMonadLog = "XMonadLog" + alias UnsafeXMonadLog = "UnsafeXMonadLog" + alias (XPropertyLog atom) = atom + alias (NamedXPropertyLog _ name) = name + alias (UnsafeXPropertyLog atom) = atom + alias (UnsafeNamedXPropertyLog _ name) = name + + start x cb = do + let atom = case x of + XMonadLog -> "_XMONAD_LOG" + UnsafeXMonadLog -> "_XMONAD_LOG" + XPropertyLog a -> a + UnsafeXPropertyLog a -> a + NamedXPropertyLog a _ -> a + UnsafeNamedXPropertyLog a _ -> a + sanitize = case x of + UnsafeXMonadLog -> id + UnsafeXPropertyLog _ -> id + UnsafeNamedXPropertyLog _ _ -> id + _ -> stripActions + + 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 . sanitize . 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 |