diff options
| author | Pavan Rikhi <pavan.rikhi@gmail.com> | 2018-03-17 22:48:24 -0400 | 
|---|---|---|
| committer | jao <jao@gnu.org> | 2018-11-21 21:41:35 +0000 | 
| commit | 4d1402a1a7d87767267d48a77998e4fb13395b31 (patch) | |
| tree | 17fd6160dc1fa9c8a0676a94bcf8d19b551c655c /src/Plugins/Monitors | |
| parent | 9e2a5c7daddf683d4be7c318aefed3da3ea7a89a (diff) | |
| download | xmobar-4d1402a1a7d87767267d48a77998e4fb13395b31.tar.gz xmobar-4d1402a1a7d87767267d48a77998e4fb13395b31.tar.bz2 | |
Split Modules into Library & Executable Structure
Move the Main module to a new `app` directory. All other modules have
been nested under the `Xmobar` name. Lots of module headers & imports
were updated.
Diffstat (limited to 'src/Plugins/Monitors')
| -rw-r--r-- | src/Plugins/Monitors/Batt.hs | 247 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Bright.hs | 99 | ||||
| -rw-r--r-- | src/Plugins/Monitors/CatInt.hs | 25 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Common.hs | 544 | ||||
| -rw-r--r-- | src/Plugins/Monitors/CoreCommon.hs | 138 | ||||
| -rw-r--r-- | src/Plugins/Monitors/CoreTemp.hs | 45 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Cpu.hs | 88 | ||||
| -rw-r--r-- | src/Plugins/Monitors/CpuFreq.hs | 44 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Disk.hs | 241 | ||||
| -rw-r--r-- | src/Plugins/Monitors/MPD.hs | 139 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Mem.hs | 96 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Mpris.hs | 148 | ||||
| -rw-r--r-- | src/Plugins/Monitors/MultiCpu.hs | 128 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Net.hs | 218 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Swap.hs | 56 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Thermal.hs | 39 | ||||
| -rw-r--r-- | src/Plugins/Monitors/ThermalZone.hs | 49 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Top.hs | 195 | ||||
| -rw-r--r-- | src/Plugins/Monitors/UVMeter.hs | 157 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Uptime.hs | 50 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Volume.hs | 196 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Weather.hs | 255 | ||||
| -rw-r--r-- | src/Plugins/Monitors/Wireless.hs | 70 | 
23 files changed, 0 insertions, 3267 deletions
| diff --git a/src/Plugins/Monitors/Batt.hs b/src/Plugins/Monitors/Batt.hs deleted file mode 100644 index eeeb049..0000000 --- a/src/Plugins/Monitors/Batt.hs +++ /dev/null @@ -1,247 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Batt ( battConfig, runBatt, runBatt' ) where - -import Control.Exception (SomeException, handle) -import 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/Plugins/Monitors/Bright.hs b/src/Plugins/Monitors/Bright.hs deleted file mode 100644 index cb510f6..0000000 --- a/src/Plugins/Monitors/Bright.hs +++ /dev/null @@ -1,99 +0,0 @@ ------------------------------------------------------------------------------ ----- | ----- 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 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 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/Plugins/Monitors/CatInt.hs b/src/Plugins/Monitors/CatInt.hs deleted file mode 100644 index aacbd71..0000000 --- a/src/Plugins/Monitors/CatInt.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.CatInt --- Copyright   :  (c) Nathaniel Wesley Filardo --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Nathaniel Wesley Filardo --- Stability   :  unstable --- Portability :  unportable --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CatInt where - -import Plugins.Monitors.Common -import 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/Plugins/Monitors/Common.hs b/src/Plugins/Monitors/Common.hs deleted file mode 100644 index 782a18f..0000000 --- a/src/Plugins/Monitors/Common.hs +++ /dev/null @@ -1,544 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 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 Plugins --- $monitor - -type Monitor a = ReaderT MConfig IO a - -data MConfig = -    MC { normalColor :: IORef (Maybe String) -       , low :: IORef Int -       , lowColor :: IORef (Maybe String) -       , high :: IORef Int -       , highColor :: IORef (Maybe String) -       , template :: IORef String -       , export :: IORef [String] -       , ppad :: IORef Int -       , 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/Plugins/Monitors/CoreCommon.hs b/src/Plugins/Monitors/CoreCommon.hs deleted file mode 100644 index 6298421..0000000 --- a/src/Plugins/Monitors/CoreCommon.hs +++ /dev/null @@ -1,138 +0,0 @@ -{-# 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 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 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/Plugins/Monitors/CoreTemp.hs b/src/Plugins/Monitors/CoreTemp.hs deleted file mode 100644 index e19baf0..0000000 --- a/src/Plugins/Monitors/CoreTemp.hs +++ /dev/null @@ -1,45 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.CoreTemp --- Copyright   :  (c) Juraj Hercek --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Juraj Hercek <juhe_haskell@hck.sk> --- Stability   :  unstable --- Portability :  unportable --- --- A core temperature monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CoreTemp where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - - -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/Plugins/Monitors/Cpu.hs b/src/Plugins/Monitors/Cpu.hs deleted file mode 100644 index 0dba92a..0000000 --- a/src/Plugins/Monitors/Cpu.hs +++ /dev/null @@ -1,88 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Cpu (startCpu) where - -import 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/Plugins/Monitors/CpuFreq.hs b/src/Plugins/Monitors/CpuFreq.hs deleted file mode 100644 index 34240ee..0000000 --- a/src/Plugins/Monitors/CpuFreq.hs +++ /dev/null @@ -1,44 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.CpuFreq --- Copyright   :  (c) Juraj Hercek --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Juraj Hercek <juhe_haskell@hck.sk> --- Stability   :  unstable --- Portability :  unportable --- --- A cpu frequency monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.CpuFreq where - -import Plugins.Monitors.Common -import Plugins.Monitors.CoreCommon - --- | --- Cpu frequency default configuration. Default template contains only --- one core frequency, user should specify custom template in order to --- get more cpu frequencies. -cpuFreqConfig :: IO MConfig -cpuFreqConfig = -  mkMConfig "Freq: <cpu0>" (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/Plugins/Monitors/Disk.hs b/src/Plugins/Monitors/Disk.hs deleted file mode 100644 index 0019c1a..0000000 --- a/src/Plugins/Monitors/Disk.hs +++ /dev/null @@ -1,241 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Disk --- Copyright   :  (c) 2010, 2011, 2012, 2014 Jose A Ortega Ruiz --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org> --- Stability   :  unstable --- Portability :  unportable --- ---  Disk usage and throughput monitors for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Disk (diskUConfig, runDiskU, startDiskIO) where - -import Plugins.Monitors.Common -import 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/Plugins/Monitors/MPD.hs b/src/Plugins/Monitors/MPD.hs deleted file mode 100644 index 0676e64..0000000 --- a/src/Plugins/Monitors/MPD.hs +++ /dev/null @@ -1,139 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.MPD --- Copyright   :  (c) Jose A Ortega Ruiz --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose A Ortega Ruiz <jao@gnu.org> --- Stability   :  unstable --- Portability :  unportable --- ---  MPD status and song --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.MPD ( mpdConfig, runMPD, mpdWait, mpdReady ) where - -import Data.List -import Data.Maybe (fromMaybe) -import 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/Plugins/Monitors/Mem.hs b/src/Plugins/Monitors/Mem.hs deleted file mode 100644 index 403fa43..0000000 --- a/src/Plugins/Monitors/Mem.hs +++ /dev/null @@ -1,96 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Mem --- Copyright   :  (c) Andrea Rossato --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org> --- Stability   :  unstable --- Portability :  unportable --- --- A memory monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Mem (memConfig, runMem, totalMem, usedMem) where - -import Plugins.Monitors.Common -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/Plugins/Monitors/Mpris.hs b/src/Plugins/Monitors/Mpris.hs deleted file mode 100644 index ed76dc9..0000000 --- a/src/Plugins/Monitors/Mpris.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# 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 Plugins.Monitors.Mpris ( mprisConfig, runMPRIS1, runMPRIS2 ) where - --- TODO: listen to signals - -import 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/Plugins/Monitors/MultiCpu.hs b/src/Plugins/Monitors/MultiCpu.hs deleted file mode 100644 index 1477cf6..0000000 --- a/src/Plugins/Monitors/MultiCpu.hs +++ /dev/null @@ -1,128 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.MultiCpu --- Copyright   :  (c) Jose A Ortega Ruiz --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose A Ortega <jao@gnu.org> --- Stability   :  unstable --- Portability :  unportable --- --- A multi-cpu monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.MultiCpu (startMultiCpu) where - -import 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/Plugins/Monitors/Net.hs b/src/Plugins/Monitors/Net.hs deleted file mode 100644 index 9819fe2..0000000 --- a/src/Plugins/Monitors/Net.hs +++ /dev/null @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Net ( -                        startNet -                      , startDynNet -                      ) where - -import 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/Plugins/Monitors/Swap.hs b/src/Plugins/Monitors/Swap.hs deleted file mode 100644 index b6c5019..0000000 --- a/src/Plugins/Monitors/Swap.hs +++ /dev/null @@ -1,56 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Swap --- Copyright   :  (c) Andrea Rossato --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose A. Ortega Ruiz <jao@gnu.org> --- Stability   :  unstable --- Portability :  unportable --- --- A  swap usage monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Swap where - -import Plugins.Monitors.Common - -import qualified Data.ByteString.Lazy.Char8 as B - -swapConfig :: IO MConfig -swapConfig = mkMConfig -        "Swap: <usedratio>%"                    -- template -        ["usedratio", "total", "used", "free"] -- available replacements - -fileMEM :: IO B.ByteString -fileMEM = B.readFile "/proc/meminfo" - -parseMEM :: IO [Float] -parseMEM = -    do file <- fileMEM -       let li i l -               | l /= [] = head l !! i -               | otherwise = B.empty -           fs s l -               | 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/Plugins/Monitors/Thermal.hs b/src/Plugins/Monitors/Thermal.hs deleted file mode 100644 index 5a97152..0000000 --- a/src/Plugins/Monitors/Thermal.hs +++ /dev/null @@ -1,39 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Thermal --- Copyright   :  (c) Juraj Hercek --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Juraj Hercek <juhe_haskell@hck.sk> --- Stability   :  unstable --- Portability :  unportable --- --- A thermal monitor for Xmobar --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Thermal where - -import qualified Data.ByteString.Lazy.Char8 as B -import Plugins.Monitors.Common -import System.Posix.Files (fileExist) - --- | Default thermal configuration. -thermalConfig :: IO MConfig -thermalConfig = mkMConfig -       "Thm: <temp>C" -- template -       ["temp"]       -- available replacements - --- | Retrieves thermal information. Argument is name of thermal directory in --- \/proc\/acpi\/thermal_zone. Returns the monitor string parsed according to --- template (either default or user specified). -runThermal :: [String] -> Monitor String -runThermal args = do -    let zone = head args -        file = "/proc/acpi/thermal_zone/" ++ zone ++ "/temperature" -    exists <- io $ fileExist file -    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/Plugins/Monitors/ThermalZone.hs b/src/Plugins/Monitors/ThermalZone.hs deleted file mode 100644 index a4744b4..0000000 --- a/src/Plugins/Monitors/ThermalZone.hs +++ /dev/null @@ -1,49 +0,0 @@ ------------------------------------------------------------------------------- --- | --- 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 Plugins.Monitors.ThermalZone (thermalZoneConfig, runThermalZone) where - -import 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/Plugins/Monitors/Top.hs b/src/Plugins/Monitors/Top.hs deleted file mode 100644 index 41a68b2..0000000 --- a/src/Plugins/Monitors/Top.hs +++ /dev/null @@ -1,195 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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 Plugins.Monitors.Top (startTop, topMemConfig, runTopMem) where - -import Plugins.Monitors.Common - -import Control.Exception (SomeException, handle) -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.List (sortBy, foldl') -import Data.Ord (comparing) -import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime) -import System.Directory (getDirectoryContents) -import System.FilePath ((</>)) -import System.IO (IOMode(ReadMode), hGetLine, withFile) -import System.Posix.Unistd (SysVar(ClockTick), getSysVar) - -import Foreign.C.Types - -maxEntries :: Int -maxEntries = 10 - -intStrs :: [String] -intStrs = map show [1..maxEntries] - -topMemConfig :: IO MConfig -topMemConfig = mkMConfig "<both1>" -                 [ k ++ n | n <- intStrs , k <- ["name", "mem", "both"]] - -topConfig :: IO MConfig -topConfig = mkMConfig "<both1>" -              ("no" : [ k ++ n | n <- intStrs -                               , k <- [ "name", "cpu", "both" -                                      , "mname", "mem", "mboth"]]) - -foreign import ccall "unistd.h getpagesize" -  c_getpagesize :: CInt - -pageSize :: Float -pageSize = fromIntegral c_getpagesize / 1024 - -processes :: IO [FilePath] -processes = fmap (filter isPid) (getDirectoryContents "/proc") -  where isPid = (`elem` ['0'..'9']) . head - -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/Plugins/Monitors/UVMeter.hs b/src/Plugins/Monitors/UVMeter.hs deleted file mode 100644 index 4d90846..0000000 --- a/src/Plugins/Monitors/UVMeter.hs +++ /dev/null @@ -1,157 +0,0 @@ -{-# 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 Plugins.Monitors.UVMeter where - -import 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/Plugins/Monitors/Uptime.hs b/src/Plugins/Monitors/Uptime.hs deleted file mode 100644 index 8524bcc..0000000 --- a/src/Plugins/Monitors/Uptime.hs +++ /dev/null @@ -1,50 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module      : Plugins.Monitors.Uptime --- Copyright   : (c) 2010 Jose Antonio Ortega Ruiz --- License     : BSD3-style (see LICENSE) --- --- Maintainer  : jao@gnu.org --- Stability   : unstable --- Portability : unportable --- Created: Sun Dec 12, 2010 20:26 --- --- --- Uptime --- ------------------------------------------------------------------------------- - - -module Plugins.Monitors.Uptime (uptimeConfig, runUptime) where - -import Plugins.Monitors.Common - -import qualified Data.ByteString.Lazy.Char8 as B - -uptimeConfig :: IO MConfig -uptimeConfig = mkMConfig "Up <days>d <hours>h <minutes>m" -                         ["days", "hours", "minutes", "seconds"] - -readUptime :: IO Float -readUptime = -  fmap (read . B.unpack . head . B.words) (B.readFile "/proc/uptime") - -secsPerDay :: Integer -secsPerDay = 24 * 3600 - -uptime :: Monitor [String] -uptime = do -  t <- io readUptime -  u <- getConfigValue useSuffix -  let tsecs = floor t -      secs = tsecs `mod` secsPerDay -      days = tsecs `quot` secsPerDay -      hours = secs `quot` 3600 -      mins = (secs `mod` 3600) `div` 60 -      ss = secs `mod` 60 -      str x s = if u then show x ++ s else show x -  mapM (`showWithColors'` days) -       [str days "d", str hours "h", str mins "m", str ss "s"] - -runUptime :: [String] -> Monitor String -runUptime _ = uptime >>= parseTemplate diff --git a/src/Plugins/Monitors/Volume.hs b/src/Plugins/Monitors/Volume.hs deleted file mode 100644 index 0023d41..0000000 --- a/src/Plugins/Monitors/Volume.hs +++ /dev/null @@ -1,196 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Volume --- Copyright   :  (c) 2011, 2013, 2015 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 Plugins.Monitors.Volume -  ( runVolume -  , runVolumeWith -  , volumeConfig -  , options -  , defaultOpts -  , VolumeOpts -  ) where - -import Control.Applicative ((<$>)) -import Control.Monad ( liftM2, liftM3, mplus ) -import Data.Traversable (sequenceA) -import 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/Plugins/Monitors/Weather.hs b/src/Plugins/Monitors/Weather.hs deleted file mode 100644 index cd1b4eb..0000000 --- a/src/Plugins/Monitors/Weather.hs +++ /dev/null @@ -1,255 +0,0 @@ -{-# 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 Plugins.Monitors.Weather where - -import 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/Plugins/Monitors/Wireless.hs b/src/Plugins/Monitors/Wireless.hs deleted file mode 100644 index 9397e50..0000000 --- a/src/Plugins/Monitors/Wireless.hs +++ /dev/null @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module      :  Plugins.Monitors.Wireless --- Copyright   :  (c) Jose Antonio Ortega Ruiz --- License     :  BSD-style (see LICENSE) --- --- Maintainer  :  Jose Antonio Ortega Ruiz --- Stability   :  unstable --- Portability :  unportable --- --- A monitor reporting ESSID and link quality for wireless interfaces --- ------------------------------------------------------------------------------ - -module Plugins.Monitors.Wireless (wirelessConfig, runWireless)  where - -import System.Console.GetOpt - -import 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 [] | 
