packages feed

hi3status (empty) → 0.1.0.0

raw patch · 21 files changed

+1248/−0 lines, 21 filesdep +aesondep +basedep +binarysetup-changed

Dependencies added: aeson, base, binary, bytestring, dbus, dyre, hi3status, network, prefix-units, process, regex-pcre-builtin, text, time, transformers, vector

Files

+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Josh Kirklin++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ ctl-src/Main.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}++import DBus+import DBus.Client+import Data.String++import System.Console.GetOpt+import System.Environment++import System.Process+import GHC.IO.Handle++data CtlOption = BlockName String deriving Show++data CtlAction = UpdateAll | Update String++connectHi3status :: IO Client+connectHi3status = do+    pid <- read <$> readProcess "pidof" ["-s","i3"] "" :: IO Int+    addrStr <- (head . lines) <$> readProcess "grep" ["-ozP","(?<=DBUS_SESSION_BUS_ADDRESS=).*","/proc/"++show pid++"/environ"] ""+    let maddr = parseAddress addrStr+    case maddr of +        Nothing -> fail "couldn't get hi3status dbus address"+        Just addr -> do+            putStrLn "Connecting"+            cl <- connect addr+            return cl++callMethod :: String -> String -> IO ()+callMethod o m = do+    cl <- connectHi3status+    let c = (methodCall (fromString o) "org.i3wm.hi3status" (fromString m)) { methodCallDestination = Just "org.i3wm.hi3status" }+    callNoReply cl c+    return ()++act :: CtlAction -> IO ()+act UpdateAll = callMethod "/" "UpdateAll"+act (Update name) = callMethod ("/" ++ name) "Update"++modifyAction :: CtlOption -> CtlAction -> CtlAction+modifyAction (BlockName name) UpdateAll = Update name+modifyAction (BlockName name) (Update _) = Update name++blockNameOption = +    Option ['n'] ["name"]+        (OptArg (\ms -> case ms of+            Nothing -> BlockName ""+            Just s -> BlockName s) "STRING") "Name of block"++main = do+    args <- getArgs+    let (opts,_,err) = getOpt RequireOrder [blockNameOption] args+    case err of+        [] -> do+            let modifications = map modifyAction opts+                action = foldl (flip ($)) UpdateAll modifications+            act action+        _ -> do+            putStr $ usageInfo "hi3status-ctl" [blockNameOption]+            mapM_ putStrLn err+
+ hi3status.cabal view
@@ -0,0 +1,53 @@+name:                hi3status+version:             0.1.0.0+synopsis:            Status line for i3bar.+description:         Hi3status is a compact, lightweight, responsive and highly configurable status line for i3bar.+license:             MIT+license-file:        LICENSE+author:              Josh Kirklin+maintainer:          tekn04321@gmail.com+-- copyright:           +category:            System+build-type:          Simple+-- extra-source-files:  +cabal-version:       >=1.10++source-repository head+  type:                git+  location:            git://github.com/ScrambledEggsOnToast/hi3status.git++library+  exposed-modules:     Hi3Status+                       Hi3Status.Block+                       Hi3Status.Block.Util+                       Hi3Status.Blocks.Backlight+                       Hi3Status.Blocks.Battery+                       Hi3Status.Blocks.Clock+                       Hi3Status.Blocks.StaticText+                       Hi3Status.Blocks.Volume+                       Hi3Status.Blocks.Wifi+                       Hi3Status.Blocks.Ethernet+                       Hi3Status.Blocks.Network+                       Hi3Status.Blocks.Window+                       Hi3Status.Blocks.Weather+                       Hi3Status.Blocks.Music+  other-modules:       Hi3Status.Block.Internal+                       Hi3Status.StatusLine+  build-depends:       base >=4.8 && <4.9, vector, text, aeson, dbus, transformers, bytestring, process, time, regex-pcre-builtin, dyre, prefix-units, network, binary+  hs-source-dirs:      lib-src+  default-language:    Haskell2010++executable hi3status+  main-is:             Main.hs+  build-depends:       base >=4.8 && <4.9, hi3status+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -threaded++executable hi3status-ctl+  main-is:             Main.hs+  -- other-modules:       +  -- other-extensions:    +  build-depends:       base >=4.8 && <4.9, dbus, process+  hs-source-dirs:      ctl-src+  default-language:    Haskell2010
+ lib-src/Hi3Status.hs view
@@ -0,0 +1,97 @@+{-|+Module      : Hi3Status+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental++Hi3status is a compact, lightweight, responsive and highly configurable status line for i3bar. ++The hi3status package comes in three parts:++    * @hi3status@ the library contains all of the code necessary for running a status line, as well as some basic components (or blocks) that can be used to make up a status line.+    * @hi3status@ the program is responsible for actually running the status line.+    * @hi3status-ctl@ is a small program which can be used to trigger updates to the status line.++= hi3status configuration++The hi3status configuration file is written in Haskell and is located at @~\/.config\/hi3status\/hi3status.hs@. A brief example of this file is given below:++@+{-# LANGUAGE OverloadedStrings #-}+import Hi3Status+import Hi3Status.Blocks.StaticText+import Hi3Status.Blocks.Clock++myBlocks = +  [ "message" %% StaticTextBlock "Welcome to hi3status" Nothing+  , "time"    %% ClockBlock "%H:%M:%S %d\/%m\/%Y"+  ]++main = hi3status myBlocks+@++The main structural element of a hi3status status line are its blocks, which are defined to be values of types which are instances of the 'Block' class. For example in the above, 'Hi3Status.Blocks.StaticText.StaticTextBlock' is a block that displays a piece of unchanging text with an optional given color, and 'Hi3Status.Blocks.Clock.ClockBlock' is a block that displays a clock with the given formatting.++Each block provided to hi3status must have a unique name associated with it. To do this we form a 'BlocksEntry' using the '%%' operator: ++@+aBlockEntry = "aUniqueName" %% aBlock+@++Finally we combine these 'BlocksEntry's into a single value of the type 'Blocks', which is just a type synonym for @[BlocksEntry]@. We then wire up the @main@ function of the configuration file to this value using 'hi3status':++@+main = hi3status myBlocks+@++= i3bar configuration++In order to use hi3status as the status line for i3bar, make sure the following is present in your @.i3\/config@:++@+bar {+    status_command hi3status+    ...+}+@++= hi3status-ctl++The hi3status-ctl program is used to trigger updates to hi3status. For example, suppose we have a block which displays the current volume of the speakers. It would be desireable to have hi3status update this block when the volume changes. We would thus take the appropriate action such that the following is run every time the volume changes:++@+hi3status-ctl --name=volume+@++Note that the name specified above is the unique name given in the 'BlocksEntry' for the appropriate block.++-}+module Hi3Status (+  -- * Main entry point+    hi3status,+    startStatusLine,+  -- * Blocks+    Blocks (..),+    BlocksEntry,+    (%%)+    ) where++import Hi3Status.StatusLine+import Hi3Status.Block+import Hi3Status.Blocks.StaticText++import qualified Config.Dyre as Dyre+import Data.String++showError :: Blocks -> String -> Blocks+showError bs e = "error" %% StaticTextBlock (fromString (head . lines $ e)) Nothing : bs++realMain bs = startStatusLine bs++-- | Run hi3status. Usually this will be used in the configuration file as follows: @main = hi3status myBlocks@.+hi3status = Dyre.wrapMain $ Dyre.defaultParams+    { Dyre.projectName = "hi3status"+    , Dyre.realMain = realMain+    , Dyre.showError = showError+    }+
+ lib-src/Hi3Status/Block.hs view
@@ -0,0 +1,60 @@+{-|+Module      : Hi3Status.Block+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental++Blocks are the main components of a status line. A block is any instance of the+'Block' class.++-}++module Hi3Status.Block (+    -- * Class+    Block (..),+    -- * Monad+    BlockM (),+    pushBlockDescription,+    waitForUpdateSignal,+    getUpdater,+    -- * Descriptions+    BlockDescription (..),+    emptyBlockDescription+    ) where++import Hi3Status.Block.Internal ++import Control.Concurrent.Chan+import Control.Concurrent.MVar++-- | Push a new block description to the status line.+pushBlockDescription :: BlockDescription -> BlockM ()+pushBlockDescription bd = BlockM $ \p _ c -> writeChan c . BlockUpdate p $ bd++-- | Wait until an update is required.+waitForUpdateSignal :: BlockM ()+waitForUpdateSignal = BlockM $ \_ u _ -> takeMVar u >> return ()++-- | Return the updater for this block, i.e. a value of the type @IO ()@ that+-- when run will request that the block be updated. This is useful when, for+-- example, we desire to set an update timer internal to the block itself:+-- +-- @+-- updateInFiveSeconds :: BlockM ()+-- updateInFiveSeconds = do+--     updater <- getUpdater+--     liftIO $ forkIO $ do+--         threadDelay 5000000+--         updater+-- @+getUpdater :: BlockM (IO ())+getUpdater = BlockM $ \_ u _ -> return $ update u+++class Block a where+    -- | This function takes in a block, and returns a value of type +    -- @BlockM ()@, which is executed in its own thread when the status line+    -- begins.+    runBlock :: a -> BlockM ()++
+ lib-src/Hi3Status/Block/Internal.hs view
@@ -0,0 +1,107 @@+{-|+Module      : Hi3Status.Block.Internal+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+{-# LANGUAGE OverloadedStrings #-}+module Hi3Status.Block.Internal where++import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.MVar++import Control.Monad.IO.Class++import qualified Data.Text as T+import Data.String+import qualified Data.Aeson as A+import Data.Aeson ((.=))++data BlockUpdate = BlockUpdate +  { blockUpdatePosition :: Int+  , blockUpdateDescription :: BlockDescription+  }++data UpdateSignal = UpdateSignal++-- | 'BlockM' is a monad responsible for controlling the operation of a block. Each block has two lines of communication with the main status line:+-- +-- * The status line can tell the block that it needs updating.+-- * The block can push updates in the form of 'BlockDescription's to the status line, which will then be processed and submitted to i3bar.+data BlockM a = BlockM +  { runBlockM :: Int -> MVar UpdateSignal -> Chan BlockUpdate -> IO a }++instance Functor BlockM where+    fmap f blockm = BlockM $ \p u c -> fmap f $ runBlockM blockm p u c++instance Applicative BlockM where+    pure a = BlockM $ \_ _ _ -> return a+    (BlockM f) <*> (BlockM a) = BlockM $ \p u c -> (f p u c) <*> (a p u c)++instance Monad BlockM where+    BlockM a >>= m = BlockM $ \p u c -> do+        a' <- a p u c+        runBlockM (m a') p u c+    return = pure+    fail e = BlockM $ \_ _ _ -> fail e++instance MonadIO BlockM where+    liftIO io = BlockM $ \_ _ _ -> io++update u = tryPutMVar u UpdateSignal >> return ()++data BlockAlign = AlignLeft | AlignCenter | AlignRight ++instance A.ToJSON BlockAlign where+    toJSON AlignLeft = A.String "left"+    toJSON AlignCenter = A.String "center"+    toJSON AlignRight = A.String "right"++-- | A 'BlockDescription' contains everything needed by i3bar to properly render a block. This includes things like the text of a block, and the color of the text. For more information about each field, see the i3bar protocol at <http://i3wm.org/docs/i3bar-protocol.html>.+data BlockDescription = BlockDescription+  { full_text :: T.Text+  , short_text :: Maybe T.Text+  , color :: Maybe T.Text+  , min_width :: Maybe Int+  , align :: Maybe BlockAlign+  , name :: Maybe T.Text+  , instanc :: Maybe T.Text+  , urgent :: Maybe Bool+  , separator :: Maybe Bool+  , separator_block_width :: Maybe Int+  , markup :: Maybe T.Text+  }++instance A.ToJSON BlockDescription where+    toJSON d = A.object . filter ((/= A.Null) . snd) $+      [ "full_text" .= full_text d+      , "short_text" .= short_text d+      , "color" .= color d+      , "min_width" .= min_width d+      , "align" .= align d+      , "name" .= name d+      , "instance" .= instanc d+      , "urgent" .= urgent d+      , "separator" .= separator d+      , "separator_block_width" .= separator_block_width d+      , "markup" .= markup d+      ]++instance IsString BlockDescription where+    fromString str = emptyBlockDescription { full_text = fromString str }++-- | An empty block description, i.e. one with @full_text = ""@, and everything else equal to @Nothing@.+emptyBlockDescription =+    BlockDescription +        ""+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing+        Nothing
+ lib-src/Hi3Status/Block/Util.hs view
@@ -0,0 +1,77 @@+{-|+Module      : Hi3Status.Block.Util+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental++This module contains a number of common functions that are useful for writing +blocks.++-}++{-# LANGUAGE OverloadedStrings #-}++module Hi3Status.Block.Util (+    -- * BlockM+    onUpdate,+    periodic,+    periodic_,+    -- * Text formatting+    formatText,+    maxLengthText+    ) where++import Hi3Status.Block++import Control.Concurrent++import Control.Monad.IO.Class++import qualified Data.Text as T++-- | Perform a given 'BlockM' when an update is required.+onUpdate :: BlockM () -> BlockM ()+onUpdate blockm = do+    waitForUpdateSignal+    blockm+    onUpdate blockm++-- | Perform a given 'BlockM' every given number of microseconds, or whenever+-- an update is requested.+periodic :: Int -> BlockM () -> BlockM ()+periodic t blockm = do+    u <- getUpdater+    liftIO $ forkIO $ timer u+    go+  where+    go = do+        blockm+        waitForUpdateSignal+        go+    timer u = do+        threadDelay t+        u+        timer u++-- | Perform a given 'BlockM' every given number of microseconds.+periodic_ :: Int -> BlockM () -> BlockM ()+periodic_ t blockm = do+    blockm+    liftIO $ threadDelay t+    periodic_ t blockm++-- | Format a string using the given substitutions and return it as a+-- 'Data.Text.Text'.+--+-- >>> formatText [("status","Ready"),("percentage","85")] "{status}: {percentage}%" = "Ready: 85%"+formatText :: [(String, String)] -> String -> T.Text+formatText subs format = foldl (flip ($)) (T.pack format) +                            $ map makeFormatter subs+  where +    makeFormatter (t,s) = T.replace (T.concat ["{",T.pack t,"}"]) (T.pack s)++maxLengthText :: String -> Maybe Int -> String+maxLengthText t ml = case ml of+    Nothing -> t+    Just n -> (take n t) ++ (if n < length t then "..." else "")+
+ lib-src/Hi3Status/Blocks/Backlight.hs view
@@ -0,0 +1,35 @@+{-|+Module      : Hi3Status.Blocks.Backlight+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}++module Hi3Status.Blocks.Backlight +  ( BacklightBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Control.Monad.IO.Class+import System.Process++-- | A backlight percentage brightness indicator. Uses @xbacklight@ as a backend.+data BacklightBlock = BacklightBlock { +    -- | The format of the display text. +    --+    -- * @{perc}@ = backlight brightness percentage.+    format :: String +    }++instance Block BacklightBlock where+    runBlock b = onUpdate $ do+        perc <- xbacklight+        let s = formatText [("perc", show $ round perc)] $ format b+        pushBlockDescription $ emptyBlockDescription { full_text = s }++xbacklight :: BlockM Float+xbacklight = read <$> (liftIO $ readProcess "xbacklight" [] "")
+ lib-src/Hi3Status/Blocks/Battery.hs view
@@ -0,0 +1,71 @@+{-|+Module      : Hi3Status.Blocks.Battery+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Battery +  ( BatteryBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Control.Monad.IO.Class+import System.Process++import Text.Regex.PCRE+import Text.Read+import Data.Maybe++-- | A battery indicator. Uses @acpi@ as a backend.+data BatteryBlock = BatteryBlock {+    -- | The format of the display text.+    --+    -- * @{icon}@ = Icon+    -- * @{perc}@ = Percentage charge+    -- * @{time}@ = Time remaining+    format :: String,+    -- | A list of icons for the battery in order of increasing charge.+    batteryIcons :: [String],+    -- | An icon to display when the battery is charging.+    chargingIcon :: String,+    -- | The color to use when the battery has plenty of charge.+    goodColor :: Maybe String,+    -- | The color to use when the battery is low on charge.+    lowColor :: Maybe String,+    -- | The color to use when the battery is charging.+    chargingColor :: Maybe String,+    -- | For percentages below this threshold, 'lowColor' is used; for +    -- percentages above, 'goodColor' is used.+    lowThreshold :: Int +    }++instance Block BatteryBlock where+    runBlock b = periodic 5000000 $ do+        (charging, perc, time) <- acpi+        let i = chooseIcon (batteryIcons b) perc ++ if charging then chargingIcon b else ""+            text = formatText [("icon", i),("perc", show perc),("time",time)] $ format b+            c = if charging then chargingColor b+                  else if perc <= lowThreshold b then lowColor b+                      else goodColor b+        pushBlockDescription $ emptyBlockDescription { full_text = text, color = T.pack <$> c }++chooseIcon :: [String] -> Int -> String+chooseIcon [] _ = ""+chooseIcon icons perc = icons !! (round $ (realToFrac $ (length icons - 1) * perc) / 100)++acpi :: BlockM (Bool, Int, String)+acpi = do+    s <- liftIO $ readProcess "acpi" [] ""+    let charging = s =~ "Charging" :: Bool+        perc = read $ s =~ "[0-9]*(?=%)" :: Int+        mh = readMaybe $ s =~ "[0-9][0-9](?=:)" :: Maybe Int+        mm = readMaybe $ s =~ "(?<=:)[0-9][0-9](?=:)" :: Maybe Int+        time = fromMaybe "full" $ do+            h <- mh+            m <- mm+            return $ show h ++ "h" ++ show m ++ "m"+    return (charging, perc, time)
+ lib-src/Hi3Status/Blocks/Clock.hs view
@@ -0,0 +1,32 @@+{-|+Module      : Hi3Status.Blocks.Clock+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Clock+  ( ClockBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Data.Time.Clock+import Data.Time.Format+import Control.Monad.IO.Class++-- | A clock.+data ClockBlock = ClockBlock {+    -- | The format of the clock. Conventions for substitution are those used+    -- by @strftime@.+    format :: String+    }++instance Block ClockBlock where+    runBlock (ClockBlock format) = periodic_ 1000000 $ do+        t <- liftIO getCurrentTime+        let s = formatTime defaultTimeLocale format t+        pushBlockDescription $ emptyBlockDescription { full_text = T.pack s }+
+ lib-src/Hi3Status/Blocks/Ethernet.hs view
@@ -0,0 +1,45 @@+{-|+Module      : Hi3Status.Blocks.Ethernet+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Ethernet+  ( EthernetBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Control.Monad.IO.Class+import System.Process++-- | An ethernet status indicator. Uses files at @/sys/class/net/@.+data EthernetBlock = EthernetBlock { +    -- | The format of the displayed text when connected to a network.+    connectedFormat :: String, +    -- | The format of the displayed text when not connected to a network.+    disconnectedFormat :: String, +    -- | The color of the text when connected to a network.+    connectedColor :: Maybe String, +    -- | The color of the text when not connected to a network.+    disconnectedColor :: Maybe String, +    -- | The device to query, e.g. "eth0".+    device :: String +    }++instance Block EthernetBlock where+    runBlock b = periodic 5000000 $ do+        os <- operstate (device b)+        let (c,text) = +                if os +                    then (connectedColor b, formatText [] (connectedFormat b))+                    else (disconnectedColor b, formatText [] (disconnectedFormat b))+        pushBlockDescription $ emptyBlockDescription { full_text = text, color = T.pack <$> c}++operstate :: String -> BlockM Bool+operstate dev = do+    os <- liftIO $ filter (/='\n') <$> readProcess "cat" ["/sys/class/net/"++dev++"/operstate"] ""+    return (os == "up")
+ lib-src/Hi3Status/Blocks/Music.hs view
@@ -0,0 +1,68 @@+{-|+Module      : Hi3Status.Blocks.Music+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Music+  ( MusicBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T+import Data.List (isInfixOf)+import Data.Maybe (fromJust)++import Control.Monad.IO.Class+import System.Process+import System.Exit++-- | Currently playing music. Uses @playerctl@.+data MusicBlock = MusicBlock {+    -- | The format of the displayed text.+    --+    -- *@{playpause}@ = Play/pause icon.+    -- *@{artist}@ = Artist.+    -- *@{track}@ = Track.+    -- *@{album}@ = Album.+    format :: String,+    -- | The maximum length of the displayed text.+    maxLength :: Maybe Int,+    -- | The icon to display when playing.+    playIcon :: String,+    -- | The icon to display when paused.+    pauseIcon :: String+    }++instance Block MusicBlock where+    runBlock b = periodic 1000000 $ do+        p <- liftIO playing+        if p == Nothing +            then pushBlockDescription $ emptyBlockDescription+            else do+                (artist, track, album) <- liftIO metadata+                pushBlockDescription $ emptyBlockDescription +                    { full_text = T.pack . (flip maxLengthText (maxLength b)) . T.unpack $ formatText +                        [ ("artist", artist)+                        , ("track", track)+                        , ("album", album)+                        , ("playpause", if fromJust p then playIcon b else pauseIcon b)+                        ] (format b)+                    }++playing :: IO (Maybe Bool)+playing = do+    (e,p,_) <- readProcessWithExitCode "playerctl" ["status"] ""+    if e == ExitFailure 1 then return Nothing+        else if "laying" `isInfixOf` p then return (Just True)+            else if "ause" `isInfixOf` p then return (Just False)+                else return Nothing++metadata :: IO (String, String, String)+metadata = do+    artist <- filter (/='\n') <$> readProcess "playerctl" ["metadata","artist"] ""+    track <- filter (/='\n') <$> readProcess "playerctl" ["metadata","title"] ""+    album <- filter (/='\n') <$> readProcess "playerctl" ["metadata","album"] ""+    return (artist, track, album)
+ lib-src/Hi3Status/Blocks/Network.hs view
@@ -0,0 +1,64 @@+{-|+Module      : Hi3Status.Blocks.Network+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Network+  ( NetworkBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Data.Prefix.Units++import Control.Monad.IO.Class+import Control.Concurrent+import System.Process++-- | A network transfer rate indicator. Uses files at @/sys/class/net/@.+data NetworkBlock = NetworkBlock { +    -- | The format of the displayed text.+    --+    -- * @{rx}@ = Download rate.+    -- * @{tx}@ = Upload rate.+    format :: String, +    -- | The device to query, e.g. "eth0".+    device :: String,+    -- | How often to check the rates (in microseconds).+    checkPeriod :: Int+    }++instance Block NetworkBlock where+  {-  runBlock b = do+        (rx,tx) <- rxtx (device b)+        rxRef <- liftIO $ newIORef rx+        txRef <- liftIO $ newIORef tx+        periodic (checkPeriod b) $ do+            (rx',tx') <- rxtx (device b)+            liftIO $ writeIORef rx +-}+    runBlock b = do+        (rx,tx) <- rxtx (device b)+        go rx tx+      where+        go rx tx = do+            (rx',tx') <- rxtx (device b)+            let rr = 1000000 * (realToFrac $ rx'-rx) / (realToFrac $ checkPeriod b) :: Double+                tr = 1000000 * (realToFrac $ tx'-tx) / (realToFrac $ checkPeriod b) :: Double+                rs = showValue FormatSiKMGT (round rr :: Int)+                ts = showValue FormatSiKMGT (round tr :: Int)++            pushBlockDescription $ emptyBlockDescription { full_text = formatText [("rx",rs),("tx",ts)] (format b) }+            +            liftIO $ threadDelay (checkPeriod b)+            go rx' tx'++rxtx :: String -> BlockM (Int, Int)+rxtx dev = do+    rx <- liftIO $ filter (/='\n') <$> readProcess "cat" ["/sys/class/net/"++dev++"/statistics/rx_bytes"] ""+    tx <- liftIO $ filter (/='\n') <$> readProcess "cat" ["/sys/class/net/"++dev++"/statistics/tx_bytes"] ""+    return (read rx, read tx)
+ lib-src/Hi3Status/Blocks/StaticText.hs view
@@ -0,0 +1,25 @@+{-|+Module      : Hi3Status.Blocks.StaticText+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.StaticText (+    StaticTextBlock (..)+    ) where++import Hi3Status.Block++import qualified Data.Text as T++-- | A simple block that displays a piece of static text.+data StaticTextBlock = StaticTextBlock {+    -- | The text to display.+    text :: String, +    -- | The color of the text.+    textColor :: (Maybe String) +    }++instance Block StaticTextBlock where+    runBlock b = do+        pushBlockDescription $ emptyBlockDescription { full_text = T.pack $ text b, color = T.pack <$> textColor b }
+ lib-src/Hi3Status/Blocks/Volume.hs view
@@ -0,0 +1,55 @@+{-|+Module      : Hi3Status.Blocks.Volume+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Volume +  ( VolumeBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Control.Monad.IO.Class+import System.Process++import Text.Regex.PCRE++-- | A block to indicate the status of the system volume. Uses @amixer@ as a backend.+data VolumeBlock = VolumeBlock {+    -- | The format of the displayed text when not muted.+    --+    -- * @{icon}@ = Icon+    -- * @{perc}@ = Percentage+    format :: String,+    -- | The format of the displayed text when muted.+    muteFormat :: String,+    -- | The icon to display when not muted and volume is normal.+    normalIcon :: String,+    -- | The icon to display when not muted and volume is low.+    lowIcon :: String,+    -- | The icon to dipslay when muted.+    muteIcon :: String,+    -- | The device to query.+    device :: String,+    -- | The control to query.+    control :: String+    }++instance Block VolumeBlock where+    runBlock b = onUpdate $ do+        (perc, muted) <- amixer (device b) (control b)+        let i = if muted then muteIcon b else (if perc <= 30 then lowIcon b else normalIcon b)+            str = formatText [("icon",i),("perc",show perc)] $ if muted then muteFormat b else format b+        pushBlockDescription $ emptyBlockDescription { full_text = str }++amixer :: String -> String -> BlockM (Int, Bool)+amixer d c = do+    str <- liftIO $ readProcess "amixer" ["-D",d,"sget",c] ""+    let perc = read $ str =~ "(?<=\\[)[0-9]*(?=%\\])"+        muted = "off" == str =~ "(?<=\\[)(on|off)(?=\\])"+    return (perc, muted)+
+ lib-src/Hi3Status/Blocks/Weather.hs view
@@ -0,0 +1,67 @@+{-|+Module      : Hi3Status.Blocks.Weather+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Weather (+    WeatherBlock (..)+    ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import System.Process+import System.Exit+import Data.List+import qualified Data.Text as T+import Control.Monad.IO.Class++data Conditions = ClearDay | ClearNight | Rain | Cloudy++-- | A simple block that displays a piece of static text. Requires @weather@ and @sunwait@.+data WeatherBlock = WeatherBlock  {+    -- | The weather format.+    --+    -- *@{icon}@ = An icon specifying conditions.+    -- *@{temp}@ = The temperature.+    format :: String, +    -- | @{icon}@ when it's clear in the day.+    clearDayText :: String, +    -- | @{icon}@ when it's clear at night.+    clearNightText :: String, +    -- | @{icon}@ when it's raining.+    rainText :: String, +    -- | @{icon}@ when it's cloudy.+    cloudyText :: String, +    -- | True for Celsius, False for Farenheit.+    celsius :: Bool,+    -- | Location code.+    location :: String,+    -- | Latitude.+    latitude :: String,+    -- | Longitude.+    longitude :: String+    }++weather :: String -> Bool -> String -> String -> IO (Conditions, Int)+weather loc celsius long lat = do+    w <- readProcess "weather" (if celsius then ["-m",loc] else [loc]) ""+    temp <- readProcess "grep" ["emperature"] w >>= readProcess "awk" ["{print $2}"]+    con <- if "cloud" `isInfixOf` w then return Cloudy else if "rain" `isInfixOf` w then return Rain+        else do+            (daynight,_,_) <- readProcessWithExitCode "sunwait" ["poll", long, lat] ""+            case daynight of+                ExitFailure 3 -> return ClearNight+                otherwise -> return ClearDay+    return (con,read temp)++instance Block WeatherBlock where+    runBlock b = periodic_ 1000000000 $ do+        (c,t) <- liftIO $ weather (location b) (celsius b) (longitude b) (latitude b)+        let icon = case c of+                ClearDay -> clearDayText b+                ClearNight -> clearNightText b+                Rain -> rainText b+                Cloudy -> cloudyText b+        pushBlockDescription $ emptyBlockDescription { full_text = formatText [("icon",icon),("temp", show t)] (format b) }
+ lib-src/Hi3Status/Blocks/Wifi.hs view
@@ -0,0 +1,49 @@+{-|+Module      : Hi3Status.Blocks.Wifi+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+module Hi3Status.Blocks.Wifi+  ( WifiBlock (..)+  ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import qualified Data.Text as T++import Control.Monad.IO.Class+import System.Process++-- | A wifi status indicator. Uses @iwgetid@ as a backend.+data WifiBlock = WifiBlock { +    -- | The format of the displayed text when connected to a network.+    --+    -- * @{ssid}@ = The SSID of the network.+    connectedFormat :: String, +    -- | The format of the displayed text when not connected to a network.+    disconnectedFormat :: String, +    -- | The color of the text when connected to a network.+    connectedColor :: Maybe String, +    -- | The color of the text when not connected to a network.+    disconnectedColor :: Maybe String, +    -- | The device to query, e.g. "wlan0".+    device :: String +    }++instance Block WifiBlock where+    runBlock b = periodic 5000000 $ do+        ms <- iwconfig (device b)+        let text = case ms of+                Nothing -> formatText [] $ disconnectedFormat b+                Just s -> formatText [("ssid",s)] $ connectedFormat b+            c = case ms of+                Nothing -> disconnectedColor b+                Just _ -> connectedColor b+        pushBlockDescription $ emptyBlockDescription { full_text = text, color = T.pack <$> c}++iwconfig :: String -> BlockM (Maybe String)+iwconfig dev = do+    ssid <- liftIO $ filter (/='\n') <$> readProcess "iwgetid" ["-r",dev] ""+    return $ if ssid == "" then Nothing else Just ssid
+ lib-src/Hi3Status/Blocks/Window.hs view
@@ -0,0 +1,122 @@+{-|+Module      : Hi3Status.Blocks.Window+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+{-# LANGUAGE OverloadedStrings #-}++module Hi3Status.Blocks.Window (+    WindowBlock (..)+    ) where++import Hi3Status.Block+import Hi3Status.Block.Util++import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString.Lazy+import System.Process+import qualified Data.ByteString.Lazy as BS+import Data.Binary+import Data.Binary.Put+import Data.Binary.Get+import Data.Int (Int64)+import qualified Data.Aeson as A+import qualified Data.Aeson.Types as AT+import Data.Aeson.Types ((.:))+import Data.String+import qualified Data.Text as T+import Data.Bits (clearBit, testBit)+import Control.Monad.IO.Class+import Control.Monad (when)++-- | This block displays the title of the currently focused window.+data WindowBlock = WindowBlock {+    -- | The format of the displayed text.+    --+    -- * @{title}@ = Window title.+    format :: String,+    -- | The maximum length of the displayed title.+    maxLength :: (Maybe Int) +    }++instance Block WindowBlock where+    runBlock b = do+        soc <- liftIO $ socket AF_UNIX Stream 0+        addr <- liftIO socketAddr+        liftIO $ connect soc addr+        liftIO $ sendMessage soc Subscribe "[\"window\",\"workspace\"]"+        go soc+        liftIO $ sClose soc+      where+        go soc = do+            Just (t,p) <- liftIO $ recieveReply soc+            when (t == Event Window || t == Event Workspace) $ do+                let titleResult = case t of+                        Event Window -> AT.parse windowParser p+                        Event Workspace -> AT.parse workspaceParser p+                case titleResult of+                    AT.Error _ -> return ()+                    AT.Success (Just title) -> do+                        let t = maxLengthText (T.unpack title) (maxLength b)+                        pushBlockDescription $ emptyBlockDescription { full_text = formatText [("title", t)] (format b) }+                    otherwise -> pushBlockDescription emptyBlockDescription { full_text = "" }+            go soc++data MessageType = Command | Workspaces | Subscribe | Outputs | Tree | Marks | BarConfig | Version deriving (Enum, Show, Eq)+data EventType = Workspace | Output | Mode | Window | BarconfigUpdate | Binding deriving (Enum, Show, Eq)+data ReplyType = Message MessageType | Event EventType deriving (Show, Eq)++sendMessage :: Socket -> MessageType -> BS.ByteString -> IO Int64+sendMessage soc messagetype payload = send soc msg+  where+    msg = runPut $ do+        putByteString "i3-ipc"+        putWord32host $ fromIntegral (BS.length payload)+        putWord32host $ fromIntegral (fromEnum messagetype)+        putLazyByteString payload++recieveReply :: Socket -> IO (Maybe (ReplyType, A.Value))+recieveReply soc = do+    magic <- recv soc 6+    if magic == "i3-ipc" +        then do+            length <- fromIntegral . decode32 <$> recv soc 4+            replyTypeB <- fromIntegral . decode32 <$> recv soc 4+            payload <- recv soc length+            let replyType = if testBit replyTypeB 31 then Event (toEnum (replyTypeB `clearBit` 31)) else Message (toEnum replyTypeB)+            return $ do +                payloadValue <- A.decode payload+                return (replyType, payloadValue)+        else return Nothing+  where+    decode32 = runGet getWord32host ++socketAddr :: IO SockAddr+socketAddr = do+    s <- readProcess "i3" ["--get-socketpath"] ""+    return $ SockAddrUnix $ filter (/='\n') s++windowParser :: A.Value -> AT.Parser (Maybe T.Text)+windowParser = AT.withObject "Window event object" $ \o -> do+    AT.String t <- o .: "change"+    if t == "close" then return Nothing+        else if (t == "focus" || t == "title")+            then do+                AT.Object c <- o .: "container" +                AT.Object pr <- c .: "window_properties"+                AT.String title <- pr .: "title"+                return (Just title)+            else AT.typeMismatch "Window event focus change" (AT.Object o)++workspaceParser :: A.Value -> AT.Parser (Maybe T.Text)+workspaceParser = AT.withObject "Workspace event object" $ \o -> do+    AT.String t <- o .: "change"+    if t == "empty" then return Nothing+        else if t == "focus"+            then do+                AT.Object curr <- o .: "current"+                n <- curr .: "nodes"+                fn <- curr .: "floating_nodes"+                if (n == AT.emptyArray && fn == AT.emptyArray) then return Nothing else AT.typeMismatch "Workspace empty" (AT.Object o)+            else AT.typeMismatch "Workspace event focus change" (AT.Object o)
+ lib-src/Hi3Status/StatusLine.hs view
@@ -0,0 +1,93 @@+{-|+Module      : Hi3Status.StatusLine+License     : MIT+Maintainer  : Josh Kirklin (jjvk2@cam.ac.uk)+Stability   : experimental+-}+{-# LANGUAGE GADTs, OverloadedStrings #-}+module Hi3Status.StatusLine (+    startStatusLine,+    Blocks,+    BlocksEntry (),+    (%%)+    ) where++import Hi3Status.Block+import Hi3Status.Block.Internal++import System.IO++import Control.Concurrent+import Control.Concurrent.Chan+import Control.Concurrent.MVar++import qualified Data.Vector as V+import qualified Data.Vector.Mutable as MV++import qualified Data.ByteString.Lazy.Char8 as B+import Data.String++import DBus+import DBus.Client++import qualified Data.Aeson as A++-- | A unique name attached to a block.+data BlocksEntry where+    BlocksEntry :: Block a => String -> a -> BlocksEntry++-- | Construct a 'BlocksEntry' from a unique name and a block.+(%%) :: Block a => String -> a -> BlocksEntry+(%%) = BlocksEntry+infixl 7 %%++-- | A list of 'BlocksEntry's.+type Blocks = [BlocksEntry]++runBlocks :: Blocks -> Chan BlockUpdate -> IO [(String, MVar UpdateSignal)]+runBlocks bs c = mapM (\(n, BlocksEntry i b) -> do+    u <- newMVar UpdateSignal+    forkIO $ runBlockM (runBlock b) n u c+    return (i,u)) . zip [0..] $ bs++receiveUpdates :: Chan BlockUpdate -> MV.IOVector BlockDescription -> IO ()+receiveUpdates c ds = do+    BlockUpdate n d <- readChan c+    MV.write ds n d+    fds <- V.freeze ds+    let jds = A.toJSON fds+        out = A.encode jds+    B.putStr out+    putStr ","+    receiveUpdates c ds++updateAll us = mapM_ (\(_,u) -> update u) us++startStatusLine :: Blocks -> IO ()+startStatusLine blocks = do+    hSetBuffering stdout LineBuffering -- set buffering correctly++    putStr "{\"version\": 1, \"click_events\": true}[" -- i3bar protocol header++    -- The channel for block updates+    updateChan <- newChan :: IO (Chan BlockUpdate)++    -- Initiate the blockdescriptions with empty blocks+    blockDescriptions <- MV.replicate (length blocks) emptyBlockDescription :: IO (MV.IOVector BlockDescription)++    -- Start the blocks, and obtain their names/updaters+    namesUpdaters <- runBlocks blocks updateChan++    -- Connect to d-bus+    client <- connectSession +    requestName client "org.i3wm.hi3status" [nameAllowReplacement, nameReplaceExisting]++    -- Set up d-bus methods+    export client "/" [autoMethod "org.i3wm.hi3status" "UpdateAll" $ updateAll namesUpdaters]+    mapM_ (\(name,updater) -> do+        export client (fromString $ "/"++name) [autoMethod "org.i3wm.hi3status" "Update" $ update updater]+        return ()) namesUpdaters+        ++    -- Start receiving and handling updates - do this last    +    receiveUpdates updateChan blockDescriptions
+ src/Main.hs view
@@ -0,0 +1,45 @@+import System.Environment+import System.Console.GetOpt++import Hi3Status+import Hi3Status.Blocks.Clock+import Hi3Status.Blocks.Volume+import Hi3Status.Blocks.Window++data Configuration = Configuration { preset :: Bool, fontawesome :: Bool }+defaultConfiguration = Configuration False False++options :: [OptDescr (Configuration -> Configuration)]+options =+    [ Option ['p'] ["preset"] (NoArg preset') "use preset configuration (window title, volume, time, date)"+    , Option ['f'] ["fontawesome"] (NoArg fontawesome') "use FontAwesome icons in preset configuration"+    ]++preset' :: Configuration -> Configuration+preset' c = c { preset = True }++fontawesome' :: Configuration -> Configuration+fontawesome' c = c { fontawesome = True }++main = do+    args <- getArgs+    case getOpt Permute options args of+        (cfs, _, []) -> do+            let c = foldr ($) defaultConfiguration cfs+            if preset c then startStatusLine (presetBlocks (fontawesome c)) else hi3status []+        _ -> putStrLn (usageInfo "hi3status - Haskell status line for i3bar." options)++presetBlocks :: Bool -> Blocks+presetBlocks True = +  [ "window"  %% WindowBlock "\61474 {title}" (Just 100)+  , "volume"  %% VolumeBlock "{icon} {perc}%" "{icon}" "\61480" "\61479" "\61478" "default" "Master"+  , "time"    %% ClockBlock "\61463 %H:%M:%S"+  , "date"    %% ClockBlock "\61555 %m/%d/%Y"+  ]+presetBlocks False = +  [ "window"  %% WindowBlock "{title}" (Just 100)+  , "volume"  %% VolumeBlock "{perc}%" "mute" "" "" "" "default" "Master"+  , "time"    %% ClockBlock "%H:%M:%S"+  , "date"    %% ClockBlock "%m/%d/%Y"+  ]+