src/QBar/Blocks/Date.hs → qbar/src/QBar/Blocks/Date.hs

-module QBar.Blocks.Date where
+module QBar.Blocks.Date (
+  dateBlock,
+) where
 
 import QBar.BlockHelper
 import QBar.BlockOutput
 import QBar.Core
+import QBar.Prelude
 import QBar.Time
 
-import qualified Data.Text.Lazy as T
 import Data.Time.Format
 import Data.Time.LocalTime
+import Data.Text.Lazy qualified as T
 
 
 dateBlock :: Block
 dateBlock = runPollBlock' (everyNSeconds 60) $ forever $ do
   zonedTime <- liftIO getZonedTime
+  let logo :: Text = "📅\xFE0E "
   let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
   let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
-  let text = normalText ("📅\xFE0E " <> date <> " ") <> activeText time
-  yieldBlockUpdate $ mkBlockOutput text
+  let text = normalText (logo <> date <> " ") <> activeText time
+  let short = normalText logo <> activeText time
+  yieldBlockUpdate $ (mkBlockOutput text) { _shortText = Just short }

qbar/src/QBar/Blocks/DiskUsage.hs

+module QBar.Blocks.DiskUsage (
+  diskUsageBlock,
+) where
+
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Core
+import QBar.Prelude
+
+import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding qualified as T
+import System.Exit
+import System.Process.Typed (shell, readProcessStdout)
+
+diskIcon :: T.Text
+diskIcon = "💾\xFE0E"
+
+diskUsageBlock :: Text -> Block
+diskUsageBlock path = runPollBlock $ forever $ do
+  output <- liftBarIO action
+  yieldBlockUpdate $ addIcon diskIcon output
+  where
+    action :: BarIO BlockOutput
+    action = do
+      (exitCode, output) <- liftIO $ readProcessStdout $ shell $ "df --human-readable --local --output=avail " <> T.unpack path
+      return $ case exitCode of
+        ExitSuccess -> createBlockOutput output
+        (ExitFailure nr) -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
+    createBlockOutput :: C8.ByteString -> BlockOutput
+    createBlockOutput output = case map T.decodeUtf8 (C8.lines output) of
+      [] -> mkErrorOutput "no output"
+      [_header] -> mkErrorOutput "invalid output"
+      (_header:values) -> mkBlockOutput $ normalText $ T.intercalate " " $ map T.strip values

src/QBar/Blocks/NetworkManager.hs → qbar/src/QBar/Blocks/NetworkManager.hs

-{-# LANGUAGE FlexibleContexts #-}
-
-module QBar.Blocks.NetworkManager where
+module QBar.Blocks.NetworkManager (
+  getDBusProperty,
+  networkManagerBlock,
+  runExceptT_,
+) where
 
 import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
-import qualified DBus
-import qualified DBus.Client as DBus
-import qualified Data.Map as Map
-import qualified Data.Text.Lazy as T
+import DBus qualified
+import DBus.Client qualified as DBus
+import Data.Map qualified as Map
+import Data.Text.Lazy qualified as T
 import Data.Word (Word32, Word8)
 import QBar.BlockHelper
 import QBar.BlockOutput
 import QBar.Blocks.Utils
 import QBar.Core
+import QBar.Prelude
 
 data ConnectionInfo = WifiConnection Text Int | WwanConnection Text Int | EthernetConnection Text
   deriving (Show)
@@ -53,15 +56,15 @@ getConnectionInfo client connectionObjectPath = do
 
 networkManagerBlock :: Block
 networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
-  initialize = initialize',
-  finalize = finalize',
+  aquire,
+  release,
   signalThread = Nothing,
   signalBlock = networkManagerBlock',
   interval = Just defaultInterval
 }
   where
-    initialize' :: (() -> IO ()) -> BarIO DBus.Client
-    initialize' trigger = liftIO $ do
+    aquire :: (() -> IO ()) -> BarIO DBus.Client
+    aquire trigger = liftIO $ do
       client <- DBus.connectSystem
       let matchRule = DBus.matchAny {
         DBus.matchPath = Just "/org/freedesktop/NetworkManager",
@@ -69,10 +72,15 @@ networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
       }
       void . DBus.addMatch client matchRule $ dbusSignalHandler trigger
       return client
-    finalize' :: DBus.Client -> BarIO ()
-    finalize' = liftIO . DBus.disconnect
+    release :: DBus.Client -> BarIO ()
+    release = liftIO . DBus.disconnect
+
     networkManagerBlock' :: DBus.Client -> SignalBlock ()
-    networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respondBlockUpdate >=> networkManagerBlock' client
+    networkManagerBlock' client
+      = (liftBarIO . networkManagerBlock'' client)
+      >=> (\x -> respondBlockUpdate x) -- why doesn't this type check without \->?
+      >=> networkManagerBlock' client
+
     networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO BlockOutput
     networkManagerBlock'' client _ = do
       primaryConnection <- runExceptT_ $ getPrimaryConnectionPath client

src/QBar/Blocks/Pipe.hs → qbar/src/QBar/Blocks/Pipe.hs

-module QBar.Blocks.Pipe where
+module QBar.Blocks.Pipe (
+  runPipeClient,
+) where
 
 import QBar.ControlSocket
 import QBar.Core
+import QBar.Prelude
 import QBar.TagParser
 
 import Control.Concurrent.Async
 import Data.Aeson (encode)
-import qualified Data.ByteString.Lazy.Char8 as BSC
-import qualified Data.Text.Lazy as T
+import Data.ByteString.Lazy.Char8 qualified as BSC
+import Data.Text.Lazy qualified as T
 import Pipes
 import Pipes.Concurrent
-import qualified Pipes.Prelude as PP
+import Pipes.Prelude qualified as PP
 import System.IO
 
 runPipeClient :: Bool -> MainOptions -> IO ()
@@ -20,7 +23,7 @@ runPipeClient enableEvents mainOptions = do
   inputTask <- async $ runEffect $ PP.stdinLn >-> toOutput output
   void $ waitEitherCancel hostTask inputTask
   where
-    -- |Special block that reads the processes stdin line-by-line and shows the latest line in the block. Must never be used in a 'server' process or when stdin/stdout is used in another way.
+    -- Special block that reads the processes stdin line-by-line and shows the latest line in the block. Must never be used in a 'server' process or when stdin/stdout is used in another way.
     pipeBlock :: Producer String BarIO () -> Block
     pipeBlock source = ExitBlock <$ source >-> pack
       where
@@ -33,4 +36,4 @@ runPipeClient enableEvents mainOptions = do
             else pushBlockUpdate output
 
         handler :: BlockEventHandler
-        handler event = liftIO $ BSC.hPutStrLn stderr $ encode event
+        handler event = liftIO $ BSC.hPutStrLn stdout $ encode event

qbar/src/QBar/Blocks/Qubes.hs

+module QBar.Blocks.Qubes (
+  diskUsageQubesBlock,
+  qubesMonitorPropertyBlock,
+  qubesVMCountBlock,
+) where
+
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Core
+import QBar.Prelude
+import QBar.Qubes.AdminAPI (
+  QubesPropertyInfo(..),
+  QubesVMState(..),
+  QubesVMInfo(..),
+  qubesEvents,
+  qubesGetProperty,
+  qubesListVMs,
+  qubesListVMsP,
+  qubesMonitorProperty,
+  qubesUsageOfDefaultPool,
+  vmState,
+  )
+
+import Data.ByteString.Lazy qualified as BL
+import Data.Map qualified as M
+import Data.Text.Encoding.Error (lenientDecode)
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding (decodeUtf8With)
+import Pipes as P
+import Pipes.Core as P
+
+diskIcon :: T.Text
+diskIcon = "💾\xFE0E"
+
+diskUsageQubesBlock :: Block
+diskUsageQubesBlock = runPollBlock $ forever $ do
+  output <- liftBarIO action
+  yieldBlockUpdate $ addIcon diskIcon output
+  where
+    action :: BarIO BlockOutput
+    action = liftIO qubesUsageOfDefaultPool >>= \case
+      (Just usage, Just size) -> return $ createBlockOutput $ size - usage
+      _ -> return $ mkErrorOutput "unknown"
+
+    createBlockOutput :: Int -> BlockOutput
+    createBlockOutput free =
+      mkBlockOutput $ chooseColor free $ formatSize free
+
+    chooseColor :: Int -> Text -> BlockText
+    chooseColor free = if free < 40 * 1024*1024*1024
+      then activeText
+      else normalText
+
+    sizeUnits :: [(Text, Int)]
+    sizeUnits = [
+        ("T", 1024*1024*1024*1024),
+        ("G", 1024*1024*1024),
+        ("M", 1024*1024),
+        ("k", 1024),
+        (" bytes", 1)
+      ]
+    formatSize size = case filter ((< size) . snd) sizeUnits of
+      ((unit, factor) : _) -> T.pack (show $ size `div` factor) <> unit
+      _ -> T.pack (show size) <> " bytes"
+
+pipeBlockWithEvents :: forall a. Producer a BarIO () -> (Either BlockEvent a -> BarIO (Maybe BlockOutput)) -> Block
+pipeBlockWithEvents prod block = runSignalBlock Nothing (Just produce) sblock
+  where
+    produce :: (a -> IO ()) -> BarIO ()
+    produce yield' = runEffect $ prod >-> forever (await >>= liftIO . yield')
+
+    sblock :: Signal a -> P.Server (Signal a) (Maybe BlockOutput) BarIO ExitBlock
+    sblock = lift . sblock' >=> respond >=> sblock
+
+    sblock' :: Signal a -> BarIO (Maybe BlockOutput)
+    sblock' RegularSignal = return Nothing  -- ignore timer
+    sblock' (UserSignal x) = block $ Right x
+    sblock' (EventSignal x) = block $ Left x
+
+qubesMonitorPropertyBlock :: BL.ByteString -> Block
+qubesMonitorPropertyBlock name = pipeBlockWithEvents (qubesMonitorProperty qubesEvents name) handle
+  where
+    handle :: Either a QubesPropertyInfo -> BarIO (Maybe BlockOutput)
+    handle = fmap handle' . either (const $ liftIO $ qubesGetProperty name) return
+
+    handle' QubesPropertyInfo {propValue, propIsDefault} = Just $ mkBlockOutput $ normalText $ decode propValue <> (if propIsDefault then " (D)" else "")
+    decode = decodeUtf8With lenientDecode
+
+qubesVMCountBlock :: Block
+qubesVMCountBlock = pipeBlockWithEvents qubesListVMsP $ fmap countVMs . either (const $ liftIO qubesListVMs) return
+  where
+    countVMs :: M.Map BL.ByteString  QubesVMInfo -> Maybe BlockOutput
+    countVMs = Just . format . M.size . M.filterWithKey isRunningVM
+
+    isRunningVM :: BL.ByteString -> QubesVMInfo -> Bool
+    isRunningVM name x = vmState x == VMRunning && name /= "dom0"
+
+    format :: Int -> BlockOutput
+    format n = mkBlockOutput $ normalText $ T.pack (show n) <> " Qube" <> (if n /= 1 then "s" else "")

qbar/src/QBar/Blocks/Script.hs

+module QBar.Blocks.Script (
+  pollScriptBlock,
+  scriptBlock,
+) where
+
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Core
+import QBar.Prelude
+import QBar.TagParser
+import QBar.Time
+
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
+import Control.Exception (IOException, handle)
+import Data.Aeson (encode)
+import Data.ByteString.Lazy.Char8 qualified as C8
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.Encoding qualified as E
+import Data.Text.Lazy.IO qualified as TIO
+import Pipes
+import Pipes.Safe (catchP)
+import System.Exit
+import System.IO hiding (stdin, stdout)
+import System.IO.Error (isEOFError)
+import System.Process.Typed (
+  Process,
+  ProcessConfig,
+  closed,
+  createPipe,
+  getExitCode,
+  getStdin,
+  getStdout,
+  readProcessStdout,
+  setStdin,
+  setStdout,
+  shell,
+  startProcess,
+  stopProcess,
+  )
+
+
+pollScriptBlock :: Interval -> FilePath -> Block
+pollScriptBlock interval path = runPollBlock' interval $ forever $ do
+  -- Why doesn't this typecheck when using >>= instead?
+  x <- lift blockScriptAction
+  yieldBlockUpdate x
+
+  where
+    blockScriptAction :: BarIO BlockOutput
+    blockScriptAction = do
+      -- The exit code is used for i3blocks signaling but ignored here (=not implemented)
+      -- I am trying to replace i3blocks scripts with native haskell blocks, so I do not need it
+      (exitCode, output) <- liftIO $ readProcessStdout $ shell path
+      return $ case exitCode of
+        ExitSuccess -> createScriptBlockOutput output
+        (ExitFailure nr) -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
+    createScriptBlockOutput :: C8.ByteString -> BlockOutput
+    createScriptBlockOutput output = case map E.decodeUtf8 (C8.lines output) of
+      (text:short:_) -> parseTags'' text short
+      (text:_) -> parseTags' text
+      [] -> emptyBlock
+
+scriptBlock :: Bool -> FilePath -> Block
+-- The outer catchP only catches errors that occur during process creation
+scriptBlock clickEvents path = startScriptProcess
+  where
+    handleError :: Maybe ExitCode -> IOException -> Block
+    handleError exitCode exc = case result of
+      Left msg -> do
+        signal <- liftIO newEmptyMVar
+        pushBlockUpdate' (const $ liftIO $ putMVar signal ()) $
+              mkErrorOutput msg
+        liftIO $ takeMVar signal
+        startScriptProcess
+      Right x  -> x
+      where
+        result :: Either Text Block
+        result = case (isEOFError exc, exitCode) of
+          (True, Just ExitSuccess)      -> Right exitBlock
+          (True, Just (ExitFailure nr)) ->
+            Left $ "exit code " <> T.pack (show nr)
+          (True, Nothing) ->
+            -- This will happen if we hit the race condition (see below)
+            -- or the process closes its stdout without exiting.
+            Left "exit code unavailable"
+          _ -> Left $ T.pack (show exc)
+    ignoreIOException :: a -> IO a -> IO a
+    ignoreIOException errValue = handle $ \(_ :: IOException) -> return errValue
+    handleErrorWithProcess :: Process i o e -> IOException -> Block
+    handleErrorWithProcess process exc = do
+      -- We want to know whether the process has already exited or we are
+      -- killing it because of some other error. stopProcess determines
+      -- that but it doesn't tell us. getExitCode is unreliable before
+      -- stopProcess because it will return Nothing while the waiter threat
+      -- hasn't noticed that the process is dead.
+      -- Furthermore, stopProcess may fail in waitForProcess if the process
+      -- has died really quickly.
+      -- I don't think there is anything we can do about this. We do try
+      -- to make the races less likely by waiting a bit.
+      exitCode <- liftIO $ do
+        threadDelay 100000
+        ignoreIOException Nothing (getExitCode process)
+          <* ignoreIOException () (stopProcess process)
+      handleError exitCode exc
+    startScriptProcess :: Block
+    startScriptProcess = flip catchP (handleError Nothing) $
+      if clickEvents
+        then startScriptProcessWithEvents
+        else startScriptProcessNoEvents
+    startScriptProcessNoEvents :: Block
+    startScriptProcessNoEvents = do
+      let
+        processConfig :: ProcessConfig () Handle ()
+        processConfig = setStdin closed $ setStdout createPipe $ shell path
+      process <- startProcess processConfig
+      -- The inner catchP catches errors that happen after the process has been created
+      -- This handler will also make sure the process is stopped
+      catchP (blockFromHandle Nothing $ getStdout process) (handleErrorWithProcess process)
+    startScriptProcessWithEvents :: Block
+    startScriptProcessWithEvents = do
+      let processConfig = setStdin createPipe $ setStdout createPipe $ shell path
+      process <- startProcess processConfig
+      -- The inner catchP catches errors that happen after the process has been created
+      -- This handler will also make sure the process is stopped
+      blockFromHandle (Just $ getStdin process) (getStdout process)
+          `catchP` handleErrorWithProcess process
+    blockFromHandle :: Maybe Handle -> Handle -> Block
+    blockFromHandle stdin stdout = forever $ do
+      line <- liftIO $ TIO.hGetLine stdout
+      let blockOutput = parseTags' line
+      case stdin of
+        Nothing -> pushBlockUpdate blockOutput
+        Just h  -> pushBlockUpdate' (handleClick h) blockOutput
+    handleClick :: Handle -> BlockEventHandler
+    handleClick stdin ev = liftIO $ do
+      C8.hPutStrLn stdin $ encode ev
+      hFlush stdin

qbar/src/QBar/Blocks/Squeekboard.hs

+module QBar.Blocks.Squeekboard (
+  squeekboardBlock,
+) where
+
+import QBar.BlockHelper
+import QBar.BlockOutput
+import QBar.Blocks.NetworkManager (getDBusProperty, runExceptT_)
+import QBar.Core
+import QBar.Prelude
+
+import Control.Monad.Except (MonadError)
+import DBus qualified
+import DBus.Client qualified as DBus
+import DBus.Internal.Message (signalBody)
+import Data.Either (isRight)
+import Pipes.Core
+
+squeekboardBlock :: Bool -> Block
+squeekboardBlock autoHide = runSignalBlockConfiguration $ SignalBlockConfiguration {
+  aquire,
+  release,
+  signalThread = Nothing,
+  signalBlock = networkManagerBlock',
+  interval = Nothing
+}
+  where
+    aquire :: (() -> IO ()) -> BarIO DBus.Client
+    aquire trigger = liftIO $ do
+      client <- DBus.connectSession
+      let matchRule = DBus.matchAny {
+        DBus.matchPath = Just "/sm/puri/OSK0",
+        DBus.matchInterface = Just "org.freedesktop.DBus.Properties",
+        DBus.matchMember = Just "PropertiesChanged"
+      }
+      void . DBus.addMatch client matchRule $ dbusSignalHandler trigger
+      let matchRule2 = DBus.matchAny {
+        DBus.matchSender = Just "org.freedesktop.DBus",
+        DBus.matchPath = Just "/org/freedesktop/DBus",
+        DBus.matchInterface = Just "org.freedesktop.DBus",
+        DBus.matchMember = Just "NameOwnerChanged"
+      }
+      void . DBus.addMatch client matchRule2 $ \signal -> when (nameOwnerChangedIsPuriOSK0 (signalBody signal)) $ dbusSignalHandler trigger signal
+      return client
+    nameOwnerChangedIsPuriOSK0 :: [DBus.Variant] -> Bool
+    nameOwnerChangedIsPuriOSK0 (path:_) = path == DBus.toVariant ("sm.puri.OSK0" :: String)
+    nameOwnerChangedIsPuriOSK0 _ = False
+    release :: DBus.Client -> BarIO ()
+    release = liftIO . DBus.disconnect
+    networkManagerBlock' :: DBus.Client -> SignalBlock ()
+    networkManagerBlock' client = (liftBarIO . networkManagerBlock'' client) >=> respond >=> networkManagerBlock' client
+    networkManagerBlock'' :: DBus.Client -> Signal () -> BarIO (Maybe BlockOutput)
+    networkManagerBlock'' client (EventSignal Click{button=1}) = do
+      mCurrent <- runExceptT_ (getVisible client)
+      case mCurrent of
+        (Just current) -> void $ setVisible client (not current)
+        Nothing -> return ()
+      networkManagerBlock''' client
+    networkManagerBlock'' client _ = networkManagerBlock''' client
+    networkManagerBlock''' :: DBus.Client -> BarIO (Maybe BlockOutput)
+    networkManagerBlock''' client = blockOutput <$> runExceptT_ (getVisible client)
+    blockOutput :: Maybe Bool -> Maybe BlockOutput
+    blockOutput (Just isEnabled) = Just (mkBlockOutput (mkText isEnabled normalImportant "⌨\xFE0E osk"))
+    blockOutput Nothing = if autoHide then Nothing else Just (mkBlockOutput $ mkText False errorImportant "⌨\xFE0E n/a")
+    dbusSignalHandler :: (() -> IO ()) -> DBus.Signal -> IO ()
+    dbusSignalHandler trigger _signal = trigger ()
+
+getVisible :: (MonadError () m, MonadIO m) => DBus.Client -> m Bool
+getVisible client = do
+  getDBusProperty
+    client
+    "sm.puri.OSK0"
+    "/sm/puri/OSK0"
+    "sm.puri.OSK0"
+    "Visible"
+
+setVisible :: (MonadIO m) => DBus.Client -> Bool -> m Bool
+setVisible client value = do
+  let methodCall = ((DBus.methodCall "/sm/puri/OSK0" "sm.puri.OSK0" "SetVisible") {DBus.methodCallDestination = Just "sm.puri.OSK0", DBus.methodCallBody = [DBus.toVariant value]})
+  isRight <$> liftIO (DBus.call client methodCall)

src/QBar/Blocks/Utils.hs → qbar/src/QBar/Blocks/Utils.hs

-{-# LANGUAGE ScopedTypeVariables #-}
+module QBar.Blocks.Utils (
+  ensure,
+  formatFloatN,
+  parseFile,
+  tryMaybe',
+  tryMaybe,
+) where
 
-module QBar.Blocks.Utils where
+import QBar.Prelude
 
 import Control.Exception (SomeException, catch)
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as TIO
+import Data.Attoparsec.Text.Lazy qualified as AT
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as TIO
 import Numeric (showFFloat)
 
 formatFloatN :: RealFloat a => Int -> a -> T.Text

src/QBar/Cli.hs → qbar/src/QBar/Cli.hs

-{-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE TemplateHaskell #-}
 
-module QBar.Cli where
+module QBar.Cli (
+  runQBar,
+) where
 
 import QBar.Blocks
 import QBar.Blocks.Pipe
 import QBar.ControlSocket
 import QBar.Core
 import QBar.DefaultConfig
+import QBar.Prelude
+import QBar.Qubes.AdminAPI (printEvents, qubesVMStats, qubesEvents)
 import QBar.Server
 import QBar.Theme
+import QBar.Time
 
 import Control.Monad (join)
-import qualified Data.Text.Lazy as T
+import Data.Maybe (fromMaybe)
+import Data.Text.Lazy qualified as T
+import Development.GitRev
 import Options.Applicative
 
 -- |Entry point.
@@ -28,12 +35,18 @@ parseMain = customExecParser parserPrefs parser
     parserPrefs :: ParserPrefs
     parserPrefs = prefs showHelpOnEmpty
 
+versionInformation :: String
+versionInformation = "Branch: " <> $gitBranch <> "\n"
+  <> "Commit: " <> $gitHash <> (if $gitDirty then " (dirty)" else "") <> "\n"
+  <> "Commit date: " <> $gitCommitDate
+
 mainParser :: Parser (IO ())
 mainParser = do
   verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
   indicator <- switch $ long "indicator" <> short 'i' <> help "Show render indicator."
   socketLocation <- optional $ strOption $ long "socket" <> short 's' <> metavar "SOCKET" <> help "Control socket location. By default determined by WAYLAND_SOCKET location."
   barCommand <- barCommandParser
+  infoOption versionInformation $ long "version" <> help "Shows version information about the executable."
   return (barCommand MainOptions {verbose, indicator, socketLocation})
 
 barCommandParser :: Parser (MainOptions -> IO ())
@@ -41,14 +54,16 @@ barCommandParser = hsubparser (
     command "server" (info serverCommandParser (progDesc "Start a new server.")) <>
     command "mirror" (info mirrorCommandParser (progDesc "Mirror the output of a running server.")) <>
     command "pipe" (info pipeClientParser (progDesc "Redirects the stdin of this process to a running bar.")) <>
-    command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server."))
+    command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
+    command "qubes" (info qubesCommandParser (progDesc "Display information about Qubes."))
   )
 
 serverCommandParser :: Parser (MainOptions -> IO ())
 serverCommandParser = hsubparser (
     command "swaybar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server. Should be called by swaybar.")) <>
     command "i3bar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server. Should be called by i3bar.")) <>
-    command "send" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server."))
+    command "send" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server.")) <>
+    command "send-stdio" (info (sendBlockStreamStdio <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server using stdin and stdout."))
   )
   where
     barConfigurationParser :: Parser (BarIO ())
@@ -77,8 +92,7 @@ blockParser =
   subparser (
     commandGroup "Available presets:" <>
     metavar "CONFIG..." <>
-    command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks.")) <>
-    command "legacy" (info (pure legacyBarConfig) (progDesc "Load the legacy configuration. Requires some custom block scripts."))
+    command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks."))
   )
   <|>
   subparser (
@@ -86,13 +100,49 @@ blockParser =
     hidden <>
     command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
     command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block.")) <>
-    command "battery" (info (pure $ addBlock $ batteryBlock) (progDesc "Load the battery block.")) <>
+    command "battery" (info (pure $ addBlock batteryBlock) (progDesc "Load the battery block.")) <>
+    command "disk" (info diskUsageBlockParser (progDesc "Load the disk usage block.")) <>
     command "networkmanager" (info (pure $ addBlock networkManagerBlock) (progDesc "Load the network-manager block.")) <>
-    command "script" (info scriptBlockParser (progDesc "Display the output of an external script as a block."))
+    command "script" (info scriptBlockParser (progDesc "Display the output of an external script as a block.")) <>
+    command "squeekboard" (info squeekboardParser (progDesc "Toggles the visibility of the 'squeekboard' on-screen-keyboard when clicked (squeekboard must be running).")) <>
+    command "diskQubesPool" (info (pure $ addBlock diskUsageQubesBlock) (progDesc "Load a block that shows free space in Qubes' default pool.")) <>
+    command "qubesProperty" (info qubesPropertyBlockParser (progDesc "Display the current value of a Qubes property.")) <>
+    command "qubesCount" (info (pure $ addBlock qubesVMCountBlock) (progDesc "Display the number of running Qubes (VMs)."))
   )
 
+diskUsageBlockParser :: Parser (BarIO ())
+diskUsageBlockParser = do
+  file <- strArgument (metavar "FILE" <> help "The FILE by which the file system is selected.")
+  return $ addBlock $ diskUsageBlock file
+
 scriptBlockParser :: Parser (BarIO ())
 scriptBlockParser = helper <*> do
-  poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (every line of output updates the block)."
+  poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (at regular intervals)"
+  -- HACK optparse-applicative does not support options of style --poll[=INTERVAL],
+  -- so we add a second option to specify the interval explicitly instead
+  -- https://github.com/pcapriotti/optparse-applicative/issues/243
+  pollInterval <- fromMaybe defaultInterval <$> optional (IntervalSeconds <$> option auto (
+    long "interval" <>
+    short 'i' <>
+    metavar "SECONDS" <>
+    help ("Interval to use for --poll mode (default: " <> humanReadableInterval defaultInterval <> ")")
+    ))
+  clickEvents <- switch $ long "events" <> short 'e' <> help "Send click events to stdin of the script"
   script <- strArgument (metavar "SCRIPT" <> help "The script that will be executed with a shell.")
-  return $ (if poll then addBlock . pollScriptBlock else addBlock . scriptBlock) script
+  return $ (if poll then addBlock . pollScriptBlock pollInterval else addBlock . scriptBlock clickEvents) script
+
+squeekboardParser :: Parser (BarIO ())
+squeekboardParser = do
+  autoHide <- switch $ long "auto-hide" <> short 'q' <> help "Hide the block (instead of showing an error) when squeekboard is not running."
+  return $ addBlock (squeekboardBlock autoHide)
+
+qubesPropertyBlockParser :: Parser (BarIO ())
+qubesPropertyBlockParser  = do
+  name <- strArgument (metavar "NAME" <> help "The NAME of the property.")
+  return $ addBlock $ qubesMonitorPropertyBlock name
+
+qubesCommandParser :: Parser (MainOptions -> IO ())
+qubesCommandParser = hsubparser (
+    command "stats" (info (pure $ const $ printEvents qubesVMStats) (progDesc "Subscribe to VM stats and print them to stdout.")) <>
+    command "events" (info (pure $ const $ printEvents qubesEvents) (progDesc "Subscribe to events and print them to stdout."))
+  )

src/QBar/Color.hs → qbar/src/QBar/Color.hs

-module QBar.Color where
+module QBar.Color (
+  Color(..),
+  colorParser,
+  hexColorText,
+) where
+
+import QBar.Prelude
 
 import Data.Aeson
+import Data.Aeson.Types qualified as AT
+import Data.Attoparsec.Text.Lazy as A
 import Data.Bits ((.|.), shiftL)
 import Data.Char (ord)
-import Data.Attoparsec.Text.Lazy as A
 import Data.Colour.RGBSpace
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
 import Numeric (showHex)
 
 data Color = ColorRGB (RGB Double) | ColorRGBA (RGB Double) Double
   deriving (Eq, Show)
+
 instance FromJSON Color where
-  parseJSON = withText "Color" $ either fail pure . parseOnly (colorParser <* endOfInput)
+  parseJSON :: Value -> AT.Parser Color
+  parseJSON = withText "Color" $ either fail pure . A.parseOnly (colorParser <* endOfInput) . T.fromStrict
+
 instance ToJSON Color where
   toJSON = String . T.toStrict . hexColorText
 
@@ -33,28 +43,29 @@ hexColorText = hexColor'
     paddedHexComponent :: Text -> Text
     paddedHexComponent hex =
       let len = 2 - T.length hex
-          padding = if len == 1 then "0" else ""
+          padding :: Text = if len == 1 then "0" else ""
       in padding <> hex
 
 
-colorParser :: Parser Color
+colorParser :: A.Parser Color
 colorParser = do
   void $ char '#'
   rgb <- RGB <$> doubleFromHex2 <*> doubleFromHex2 <*> doubleFromHex2
   option (ColorRGB rgb) (ColorRGBA rgb <$> doubleFromHex2)
   where
-    doubleFromHex2 :: Parser Double
+    doubleFromHex2 :: A.Parser Double
     doubleFromHex2 = (/ 256) . fromIntegral <$> hexadecimal'' 2
 
-    -- |Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
-    hexadecimal'' :: Int -> Parser Int
+    -- Variant of 'Data.Attoparsec.Text.hexadecimal' that parses a fixed amount of digits.
+    hexadecimal'' :: Int -> A.Parser Int
     hexadecimal'' digits = foldl step 0 <$> count digits (satisfy isHexDigit)
       where
         isHexDigit c = (c >= '0' && c <= '9') ||
                       (c >= 'a' && c <= 'f') ||
                       (c >= 'A' && c <= 'F')
-        step a c | w >= 48 && w <= 57  = (a `shiftL` 4) .|. fromIntegral (w - 48)
-                | w >= 97             = (a `shiftL` 4) .|. fromIntegral (w - 87)
-                | otherwise           = (a `shiftL` 4) .|. fromIntegral (w - 55)
-          where w = ord c
 
+        step :: Int -> Char -> Int
+        step a c | w >= 48 && w <= 57  = (a `shiftL` 4) .|. (w - 48)
+                | w >= 97             = (a `shiftL` 4) .|. (w - 87)
+                | otherwise           = (a `shiftL` 4) .|. (w - 55)
+          where w = ord c

src/QBar/ControlSocket.hs → qbar/src/QBar/ControlSocket.hs

 {-# LANGUAGE CPP #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE InstanceSigs #-}
 
-module QBar.ControlSocket where
+module QBar.ControlSocket (
+  Command(..),
+  CommandResult(..),
+  Down,
+  Up,
+  addServerMirrorStream,
+  listenUnixSocketAsync,
+  sendBlockStream,
+  sendBlockStreamStdio,
+  sendIpc,
+) where
 
 import QBar.BlockOutput
 import QBar.Core
 import QBar.Host
-import QBar.Util
+import QBar.Prelude
+import QBar.Time
+import QBar.Utils
 
 import Control.Concurrent (forkFinally)
 import Control.Concurrent.Async
-import Control.Exception (SomeException, handle, catch)
+import Control.Exception (SomeException, IOException, handle, onException)
 import Data.Aeson (FromJSON, ToJSON)
-import Data.Aeson.TH
-import qualified Data.ByteString.Char8 as BSC
-import System.FilePath ((</>))
-import System.IO
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BSC
 import Data.Text.Lazy (pack)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as T
+import Data.Text.Lazy qualified as T
+import Data.Text.Lazy.IO qualified as T
+import Data.Time.Clock (getCurrentTime, addUTCTime)
+import GHC.Generics
 import Network.Socket
 import Pipes
-import Pipes.Concurrent as PC (Output, spawn, spawn', unbounded, newest, toOutput, fromInput, send, atomically)
-import Pipes.Parse
-import qualified Pipes.Prelude as PP
 import Pipes.Aeson (decode, DecodingError)
 import Pipes.Aeson.Unchecked (encode)
+import Pipes.Concurrent as PC (Output, spawn, spawn', unbounded, newest, toOutput, fromInput, send, atomically)
 import Pipes.Network.TCP (fromSocket, toSocket)
+import Pipes.Parse
+import Pipes.Prelude qualified as PP
+import Pipes.Safe (catch)
 import System.Directory (removeFile, doesFileExist)
 import System.Environment (getEnv)
+import System.Exit (exitSuccess)
+import System.FilePath ((</>))
+import System.IO
 
 type CommandHandler = Command -> IO CommandResult
 
@@ -47,15 +56,20 @@ class (ToJSON (Up s), FromJSON (Up s), ToJSON (Down s), FromJSON (Down s)) => Is
   toStreamType :: s -> StreamType
 
   streamClient :: s -> MainOptions -> BarIO (Consumer (Up s) IO (), Producer (Down s) IO ())
-  streamClient s options@MainOptions{verbose} = do
+  streamClient s options = do
     sock <- liftIO $ connectIpcSocket options
-    runEffect (encode (StartStream $ toStreamType s) >-> toSocket sock)
-    let up = forever (await >>= encode) >-> verbosePrintP >-> toSocket sock
-    let down = decodeStreamSafe options (fromSocket sock 4096 >-> verbosePrintP)
+    streamClient' s options (toSocket sock) (fromSocket sock 4096)
+
+  streamClient' :: s -> MainOptions -> Consumer ByteString IO () -> Producer ByteString IO () -> BarIO (Consumer (Up s) IO (), Producer (Down s) IO ())
+  streamClient' s options@MainOptions{verbose} sink source = liftIO $ do
+    runEffect (encode (StartStream $ toStreamType s) >-> sink)
+    let up = forever (await >>= encode) >-> verbosePrintP >-> sink
+    let down = decodeStreamSafe options (source >-> verbosePrintP)
     return (up, down)
     where
       verbosePrintP :: Pipe ByteString ByteString IO ()
       verbosePrintP = if verbose then PP.chain $ BSC.hPutStrLn stderr else cat
+
   handleByteStream :: s -> MainOptions -> Producer ByteString IO () -> Consumer ByteString IO () -> BarIO ()
   handleByteStream s options up down = do
     (handleUp, handleDown, cleanup) <- streamHandler s
@@ -67,6 +81,40 @@ class (ToJSON (Up s), FromJSON (Up s), ToJSON (Down s), FromJSON (Down s)) => Is
       void $ waitEitherCancel readTask writeTask
       cleanup
 
+data ReconnectMode a = ReconnectNoResend | ReconnectSendLatest a
+
+reconnectClient :: forall up down. ReconnectMode up -> BarIO (Consumer up IO (), Producer down IO ()) -> BarIO (Consumer up IO (), Producer down IO ())
+reconnectClient reconnectMode connectClient = do
+  (upConsumer, upProducer) <- case reconnectMode of
+    ReconnectNoResend  -> liftIO mkBroadcastP
+    ReconnectSendLatest initial -> liftIO $ mkBroadcastCacheP initial
+
+  (downOutput, downInput) <- liftIO $ spawn unbounded
+  let downConsumer = toOutput downOutput
+  let downProducer = fromInput downInput
+
+  task <- barAsync $ forever $ do
+    (upStreamConsumer, downStreamProducer) <- connectRetry
+
+    liftIO $ do
+      readTask <- async $ runEffect $ downStreamProducer >-> downConsumer
+      writeTask <- async $ runEffect $ upProducer >-> upStreamConsumer
+      void $ waitEitherCancel readTask writeTask
+
+  liftIO $ link task
+
+  return (upConsumer, downProducer)
+  where
+    connectRetry :: BarIO (Consumer up IO (), Producer down IO ())
+    connectRetry = catch connectClient (\(_ :: IOException) -> liftIO (hPutStrLn stderr "Socket connection failed. Retrying...") >> reconnectDelay >> silentConnectRetry)
+    silentConnectRetry :: BarIO (Consumer up IO (), Producer down IO ())
+    silentConnectRetry = catch connectClient (\(_ :: IOException) -> reconnectDelay >> silentConnectRetry)
+    reconnectDelay :: BarIO ()
+    reconnectDelay = do
+      time <- liftIO getCurrentTime
+      let nextSecond = addUTCTime 1 time
+      sleepUntil nextSecond
+
 
 decodeStreamSafe :: FromJSON v => MainOptions -> Producer ByteString IO () -> Producer v IO ()
 decodeStreamSafe MainOptions{verbose} inputStream = decodeStream inputStream >-> failOnEmptyStream >-> failOnDecodingError
@@ -96,13 +144,19 @@ decodeStreamSafe MainOptions{verbose} inputStream = decodeStream inputStream >->
             Right v -> yield v >> failOnDecodingError'
 
 
-data StreamType = BlockStreamType BlockStream | MirrorStreamType MirrorStream
+data StreamType
+  = BlockStreamType BlockStream
+  | MirrorStreamType MirrorStream
+  deriving Generic
+
 mapStreamType :: StreamType -> (forall a. IsStream a => a -> b) -> b
 mapStreamType (BlockStreamType a) f = f a
 mapStreamType (MirrorStreamType a) f = f a
 
 
 data BlockStream = BlockStream
+  deriving Generic
+
 instance IsStream BlockStream where
   type Up BlockStream = [BlockOutput]
   type Down BlockStream = BlockEvent
@@ -142,6 +196,8 @@ instance IsStream BlockStream where
 
 
 data MirrorStream = MirrorStream
+  deriving Generic
+
 instance IsStream MirrorStream where
   type Up MirrorStream = BlockEvent
   type Down MirrorStream = [BlockOutput]
@@ -157,12 +213,13 @@ instance IsStream MirrorStream where
 
 
 data Request = Command Command | StartStream StreamType
+  deriving Generic
 
 data Command = SetTheme T.Text | CheckServer
-  deriving Show
+  deriving (Show, Generic)
 
 data CommandResult = Success | Error Text
-  deriving Show
+  deriving (Show, Generic)
 
 
 ipcSocketAddress :: MainOptions -> IO FilePath
@@ -171,19 +228,15 @@ ipcSocketAddress MainOptions{socketLocation} = maybe defaultSocketPath (return .
     defaultSocketPath :: IO FilePath
     defaultSocketPath = do
       waylandSocketPath' <- waylandSocketPath
-      maybe (maybe headlessSocketPath return =<< i3SocketPath) return waylandSocketPath'
+      maybe fallbackSocketPath return waylandSocketPath'
       where
         waylandSocketPath :: IO (Maybe FilePath)
         waylandSocketPath = handleEnvError $ do
           xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
           waylandDisplay <- getEnv "WAYLAND_DISPLAY"
           return $ xdgRuntimeDir </> waylandDisplay <> "-qbar"
-        i3SocketPath :: IO (Maybe FilePath)
-        i3SocketPath = handleEnvError $ do
-          i3SocketPath' <- getEnv "I3_SOCKET_PATH"
-          return $ i3SocketPath' <> "-qbar"
-        headlessSocketPath :: IO FilePath
-        headlessSocketPath = do
+        fallbackSocketPath :: IO FilePath
+        fallbackSocketPath = do
           xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
           return $ xdgRuntimeDir </> "qbar"
     handleEnvError :: IO FilePath -> IO (Maybe FilePath)
@@ -196,13 +249,6 @@ connectIpcSocket options = do
   connect sock $ SockAddrUnix socketPath
   return sock
 
-$(deriveJSON defaultOptions ''Request)
-$(deriveJSON defaultOptions ''Command)
-$(deriveJSON defaultOptions ''CommandResult)
-$(deriveJSON defaultOptions ''StreamType)
-$(deriveJSON defaultOptions ''BlockStream)
-$(deriveJSON defaultOptions ''MirrorStream)
-
 sendIpc :: Command -> MainOptions -> IO ()
 sendIpc command options@MainOptions{verbose} = do
   result <- sendIpc' command options
@@ -233,11 +279,33 @@ sendIpc' command options = catch sendCommand handleException
 
 
 sendBlockStream :: BarIO () -> MainOptions -> IO ()
-sendBlockStream loadBlocks options = runBarHost (streamClient BlockStream options) loadBlocks
+sendBlockStream loadBlocks options = runBarHost blockStreamClient loadBlocks
+  where
+    blockStreamClient :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
+    blockStreamClient = reconnectClient (ReconnectSendLatest []) $ streamClient BlockStream options
+
+sendBlockStreamStdio :: BarIO () -> MainOptions -> IO ()
+sendBlockStreamStdio loadBlocks options = runBarHost blockStreamClient loadBlocks
+  where
+    blockStreamClient :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
+    blockStreamClient = streamClient' BlockStream options sink source
+    sink :: Consumer ByteString IO ()
+    sink = forever $ do
+      value <- await
+      -- Close when connection to upstream qbar is lost
+      liftIO $ (BS.hPut stdout value >> hFlush stdout) `onException` (hPutStrLn stderr "Stdout closed" >> exitSuccess)
+    source :: Producer ByteString IO ()
+    source = forever $ do
+      value <- liftIO (BS.hGetSome stdin 4096)
+      -- Close when connection to upstream qbar is lost
+      when (BS.null value) $ liftIO $ do
+        hPutStrLn stderr "Stdin closed"
+        exitSuccess
+      yield value
 
 addServerMirrorStream :: MainOptions -> BarIO ()
 addServerMirrorStream options = do
-  (blockEventConsumer, blockOutputProducer) <- streamClient MirrorStream options
+  (blockEventConsumer, blockOutputProducer) <- reconnectClient ReconnectNoResend $ streamClient MirrorStream options
 
   (eventOutput, eventInput) <- liftIO $ spawn unbounded
   bar <- askBar
@@ -339,3 +407,21 @@ listenUnixSocket options@MainOptions{verbose} bar commandHandler = do
     handleError = encode . Error . pack . show
     errorResponse :: Text -> Producer ByteString IO ()
     errorResponse message = encode $ Error message
+
+instance FromJSON BlockStream
+instance ToJSON BlockStream
+
+instance FromJSON Command
+instance ToJSON Command
+
+instance FromJSON CommandResult
+instance ToJSON CommandResult
+
+instance FromJSON MirrorStream
+instance ToJSON MirrorStream
+
+instance FromJSON Request
+instance ToJSON Request
+
+instance FromJSON StreamType
+instance ToJSON StreamType

src/QBar/Core.hs → qbar/src/QBar/Core.hs

-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE RankNTypes #-}
-
-module QBar.Core where
+module QBar.Core (
+  Bar(..),
+  BarIO,
+  BarUpdateChannel(..),
+  BarUpdateEvent,
+  Block',
+  Block,
+  BlockCache,
+  BlockEvent(..),
+  BlockEventHandler,
+  BlockState,
+  BlockUpdate,
+  BlockUpdateReason(..),
+  ExitBlock(..),
+  IsCachable(..),
+  MainOptions(..),
+  MonadBarIO(..),
+  addBlock,
+  addBlockCache,
+  askBar,
+  autoPadding,
+  barAsync,
+  defaultInterval,
+  exitBlock,
+  hasEventHandler,
+  invalidateBlockState,
+  mkBlockState',
+  mkBlockState,
+  modify,
+  newCache',
+  newCache,
+  newCacheIO,
+  pushBlockUpdate',
+  pushBlockUpdate,
+  pushEmptyBlockUpdate,
+  runBarIO,
+  updateBar',
+  updateBar,
+  updateBarDefault',
+  updateBarDefault,
+  updateEventHandler,
+) where
 
 import QBar.BlockOutput
+import QBar.Prelude
 import QBar.Time
-import QBar.Util
+import QBar.Utils
 
 import Control.Concurrent.Async
-import qualified Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
 import Control.Concurrent.MVar
 import Control.Concurrent.STM.TChan
 import Control.Lens
 import Control.Monad.Reader (ReaderT, runReaderT, ask)
 import Control.Monad.State (StateT)
 import Control.Monad.Writer (WriterT)
-import Data.Aeson.TH
+import Data.Aeson
 import Data.Int (Int64)
 import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
+import GHC.Generics
 import Pipes
 import Pipes.Concurrent
+import Pipes.Prelude qualified as PP
 import Pipes.Safe (SafeT, runSafeT)
-import qualified Pipes.Prelude as PP
 
 data MainOptions = MainOptions {
   verbose :: Bool,
@@ -34,16 +73,17 @@ data MainOptions = MainOptions {
 data BlockEvent = Click {
   name :: T.Text,
   button :: Int
-} deriving (Eq, Show)
-$(deriveJSON defaultOptions ''BlockEvent)
+} deriving (Eq, Show, Generic)
 
+instance FromJSON BlockEvent
+instance ToJSON BlockEvent
 
 data ExitBlock = ExitBlock
 
 type BlockEventHandler = BlockEvent -> BarIO ()
 
 type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler)
-data BlockUpdateReason = DefaultUpdate | PollUpdate | UserUpdate
+data BlockUpdateReason = DefaultUpdate | PollUpdate | EventUpdate
 type BlockUpdate = (BlockState, BlockUpdateReason)
 
 -- |Block that 'yield's an update whenever the block should be changed
@@ -129,7 +169,7 @@ hasEventHandler (Just (_, Just _)) = True
 hasEventHandler _ = False
 
 invalidateBlockState :: BlockState -> BlockState
-invalidateBlockState = (_Just . _1) %~ invalidateBlock
+invalidateBlockState = ((_Just . _2) .~ Nothing) . ((_Just . _1) %~ invalidateBlock)
 
 
 runBarIO :: MonadIO m => Bar -> BarIO r -> m r
@@ -208,7 +248,7 @@ newCache'' = do
 -- |Creates a cache from a block.
 cacheBlock :: Block -> BlockCache
 -- 'Block's 'yield' an update whenever they want to update the cache.
-cacheBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockName >-> PP.map (\a -> [a]))
+cacheBlock pushBlock = newCache $ void $ pushBlock >-> updateBarP >-> addBlockName >-> PP.map (: [])
   where
     updateBarP :: Pipe BlockUpdate BlockState BarIO r
     updateBarP = forever $ do
@@ -216,7 +256,7 @@ cacheBlock pushBlock = newCache $ () <$ (pushBlock >-> updateBarP >-> addBlockNa
       yield state
       updateBar reason
 
-    -- |Sets 'blockName' to a random (but static) identifier if an event handler is set but the 'blockName' is not set.
+    -- Sets 'blockName' to a random (but static) identifier if an event handler is set but the 'blockName' is not set.
     addBlockName :: Pipe BlockState BlockState BarIO r
     addBlockName = do
       defaultBlockName <- randomIdentifier
@@ -236,9 +276,9 @@ autoPadding = autoPadding' 0 0
       maybeBlock <- await
       case maybeBlock of
         (Just (block, eventHandler), reason) -> do
-          let fullLength' = max fullLength . printedLength $ block^.fullText
-          let shortLength' = max shortLength . printedLength $ block^.shortText._Just
-          yield $ (Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler), reason)
+          let fullLength' = max fullLength . printedLength $ block ^. fullText
+          let shortLength' = max shortLength . printedLength $ block ^. shortText._Just
+          yield (Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler), reason)
           autoPadding' fullLength' shortLength'
         (Nothing, reason) -> do
           yield (Nothing, reason)

src/QBar/DefaultConfig.hs → qbar/src/QBar/DefaultConfig.hs

-module QBar.DefaultConfig where
+module QBar.DefaultConfig (
+  defaultBarConfig
+) where
 
 import QBar.Blocks
-import QBar.BlockOutput
 import QBar.Core
-
-import Pipes
+import QBar.Prelude
 
 defaultBarConfig :: BarIO ()
 defaultBarConfig = do
@@ -14,26 +14,6 @@ defaultBarConfig = do
   --addBlock volumeBlock
   addBlock $ cpuUsageBlock 1
   --addBlock ramUsageBlock
+  --addBlock freeDiskSpaceBlock
   --addBlock cpuTemperatureBlock
   addBlock networkManagerBlock
-
-legacyBarConfig :: BarIO ()
-legacyBarConfig = do
-  let todo = pollScriptBlock $ blockLocation "todo"
-  let networkEnvironment = pollScriptBlock $ blockLocation "network-environment"
-  let ram = pollScriptBlock (blockLocation "memory") >-> modify (addIcon "🐏\xFE0E") >-> autoPadding
-  let temperature = (pollScriptBlock $ blockLocation "temperature") >-> autoPadding
-  let volumeBlock = scriptBlock $ blockLocation "volume-pulseaudio -S -F3"
-
-  addBlock dateBlock
-  addBlock batteryBlock
-  addBlock volumeBlock
-  addBlock temperature
-  addBlock ram
-  addBlock $ cpuUsageBlock 1
-  addBlock networkEnvironment
-  addBlock networkManagerBlock
-  addBlock todo
-  where
-    blockLocation :: String -> FilePath
-    blockLocation name = "~/.config/qbar/blocks/" <> name

src/QBar/Host.hs → qbar/src/QBar/Host.hs

-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-
-module QBar.Host where
+module QBar.Host (
+  HostHandle(..),
+  attachBarOutput,
+  eventDispatcher,
+  filterDuplicates,
+  installSignalHandlers,
+  requestBarUpdateHandler,
+  runBarHost',
+  runBarHost,
+  runBlocks,
+) where
 
 import QBar.BlockOutput
 import QBar.Core
+import QBar.Prelude
 import QBar.Time
+import QBar.Utils
 
 import Control.Concurrent (forkIO, forkFinally, threadDelay)
-import Control.Concurrent.Async (async, wait, waitBoth)
-import qualified Control.Concurrent.Event as Event
-import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, swapMVar)
+import Control.Concurrent.Async (async, wait, waitAny)
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.MVar
 import Control.Concurrent.STM.TChan
-import Control.Concurrent.STM.TVar
-import Control.Exception (SomeException, catch)
+import Control.Exception (SomeException, catch, fromException)
 import Control.Lens hiding (each, (.=))
 import Control.Monad.STM (atomically)
 import Data.IORef (IORef, newIORef, readIORef, writeIORef)
 import Data.Maybe (catMaybes, mapMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
 import Pipes
 import Pipes.Concurrent (spawn, unbounded, toOutput, fromInput)
+import System.Exit (ExitCode, exitWith)
 import System.IO (stderr, hPutStrLn)
 import System.Posix.Signals (Handler(..), sigCONT, installHandler)
 
@@ -114,13 +123,13 @@ runBlocks bar HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeM
       writeIORef eventHandlerListIORef eventHandlerList
       where
         eventHandlerList :: [(T.Text, BlockEventHandler)]
-        eventHandlerList = mapMaybe getEventHandler $ blockStates
+        eventHandlerList = mapMaybe getEventHandler blockStates
 
         getEventHandler :: BlockState -> Maybe (T.Text, BlockEventHandler)
         getEventHandler Nothing = Nothing
         getEventHandler (Just (_, Nothing)) = Nothing
         getEventHandler (Just (blockOutput, Just eventHandler)) = do
-          blockName' <- blockOutput^.blockName
+          blockName' <- blockOutput ^. blockName
           return (blockName', eventHandler)
 
 
@@ -140,8 +149,8 @@ filterDuplicates = do
 followupEventWaitTime :: BlockUpdateReason -> Int
 followupEventWaitTime DefaultUpdate = 10000
 followupEventWaitTime PollUpdate = 50000
--- 'followupEventWaitTime' for 'UserUpdate' has to be zero, or blocks would be blocked blocked for this time when sending a 'UserUpdate'.
-followupEventWaitTime UserUpdate = 0
+-- 'followupEventWaitTime' for 'EventUpdate' has to be zero, or blocks would be blocked blocked for this time when sending a 'UserUpdate'.
+followupEventWaitTime EventUpdate = 0
 
 followupEventWaitTimeDefault :: Int
 followupEventWaitTimeDefault = followupEventWaitTime PollUpdate
@@ -153,7 +162,7 @@ requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEven
   signalHost blockUpdateReason
   where
     signalHost :: BlockUpdateReason -> IO ()
-    signalHost UserUpdate = do
+    signalHost EventUpdate = do
       -- Start waiting before triggering the event cannot be missed
       task <- async $ Event.wait barUpdatedEvent
       Event.set barUpdateEvent
@@ -164,8 +173,8 @@ requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEven
 
 attachBarOutput :: (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO ()
 attachBarOutput (blockOutputConsumer, blockEventProducer) = do
-  bar <- askBar
-  liftIO $ attachBarOutputInternal bar (blockOutputConsumer, blockEventProducer)
+  Bar{attachBarOutputInternal} <- askBar
+  liftIO $ attachBarOutputInternal (blockOutputConsumer, blockEventProducer)
 
 
 runBarHost :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO () -> IO ()
@@ -188,6 +197,8 @@ runBarHost' initializeBarAction = do
   -- Create IORef for event handlers
   eventHandlerListIORef <- newIORef []
 
+  exitCodeMVar <- newEmptyMVar
+
   let hostHandle = HostHandle {
     barUpdateEvent,
     barUpdatedEvent,
@@ -199,11 +210,10 @@ runBarHost' initializeBarAction = do
   (eventOutput, eventInput) <- spawn unbounded
 
   -- Create cache for block outputs
-  cache <- (,) <$> newTVarIO [] <*> newBroadcastTChanIO
-  let blockOutputProducer = blockOutputFromCache cache
+  (cacheConsumer, cacheProducer) <- mkBroadcastCacheP []
 
   -- Important: both monads (output producer / event consumer) will be forked whenever a new output connects!
-  let attachBarOutputInternal = attachBarOutputImpl blockOutputProducer (toOutput eventOutput)
+  let attachBarOutputInternal = attachBarOutputImpl exitCodeMVar cacheProducer (toOutput eventOutput)
 
 
   let requestBarUpdate = requestBarUpdateHandler hostHandle
@@ -217,38 +227,35 @@ runBarHost' initializeBarAction = do
   runBarIO bar initializeBarAction
 
   -- Run blocks and send filtered output to connected clients
-  blockTask <- async $ runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> blockOutputToCache cache
+  blockTask <- async $ runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> cacheConsumer
   -- Dispatch incoming events to blocks
   eventTask <- async $ runEffect $ fromInput eventInput >-> eventDispatcher bar eventHandlerListIORef
 
+  exitTask <- async $ takeMVar exitCodeMVar >>= exitWith
 
-  void $ waitBoth blockTask eventTask
-
-  where
-    blockOutputToCache :: (TVar [BlockOutput], TChan [BlockOutput]) -> Consumer [BlockOutput] IO ()
-    blockOutputToCache (var, chan) = forever $ do
-      value <- await
-      liftIO . atomically $ do
-        writeTVar var value
-        writeTChan chan value
-
-    -- Monad will be forked when new outputs connect
-    blockOutputFromCache :: (TVar [BlockOutput], TChan [BlockOutput]) -> Producer [BlockOutput] IO ()
-    blockOutputFromCache (var, chan) = do
-      (outputChan, value) <- liftIO . atomically $ do
-        value <- readTVar var
-        outputChan <- dupTChan chan
-        return (outputChan, value)
 
-      yield value
+  void $ waitAny [blockTask, eventTask, exitTask]
 
-      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)
+  where
+    attachBarOutputImpl :: MVar ExitCode -> Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
+    attachBarOutputImpl exitMVar blockOutputProducer eventConsumer (barOutputConsumer, barEventProducer) = do
 
-    attachBarOutputImpl :: Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
-    attachBarOutputImpl blockOutputProducer eventConsumer (barOutputConsumer, barEventProducer) = do
+      let
+        handleBarEventInput :: IO ()
+        handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
+      liftIO $ void $ forkFinally handleBarEventInput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result)
 
-      let handleBarEventInput = liftIO $ runEffect $ barEventProducer >-> eventConsumer
-      liftIO $ void $ forkFinally handleBarEventInput (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result)
+      let
+        handleBarOutput :: IO ()
+        handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
+      liftIO $ void $ forkFinally handleBarOutput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "A bar output handler failed: " <> show result)
 
-      let handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
-      liftIO $ void $ forkFinally handleBarOutput (\result -> hPutStrLn stderr $ "A bar output handler failed: " <> show result)
+      where
+        -- Calls the next handler unless the exception is an ExitCode.
+        handleOnExitCodeException :: (Either SomeException () -> IO ()) -> Either SomeException () -> IO ()
+        handleOnExitCodeException nextHandler x@(Left ex) = case fromException ex of
+          Just exitCode -> do
+            hPutStrLn stderr "Exiting"
+            putMVar exitMVar exitCode
+          Nothing -> nextHandler x
+        handleOnExitCodeException nextHandler x = nextHandler x

src/QBar/Pango.hs → qbar/src/QBar/Pango.hs

-{-# LANGUAGE DuplicateRecordFields #-}
-
-module QBar.Pango (PangoText, renderPango) where
+module QBar.Pango (
+  PangoText,
+  renderPango,
+) where
 
 import QBar.Color
+import QBar.Prelude
 import QBar.Theme
 
 type PangoText = Text

src/Prelude.hs → qbar/src/QBar/Prelude.hs

-{-# LANGUAGE NoImplicitPrelude #-}
-
-module Prelude
-  ( module BasePrelude,
-    ByteString.ByteString,
-    (>=>),
-    (<=<),
-    Control.Monad.forever,
-    Control.Monad.unless,
-    Control.Monad.void,
-    Control.Monad.when,
-    Control.Monad.IO.Class.MonadIO,
-    Control.Monad.IO.Class.liftIO,
-    Text.Text,
-    Maybe.listToMaybe,
-    error,
-    errorWithoutStackTrace,
-    head,
-    intercalate,
-    trace,
-    traceId,
-    traceShow,
-    traceShowId,
-    traceM,
-    traceShowM,
-    traceIO,
-    traceShowIO,
-    traceShowIdIO,
-    undefined,
-  )
-where
-
-import BasePrelude hiding
+module QBar.Prelude (
+  module Prelude,
+  (<=<),
+  (>=>),
+  ByteString.ByteString,
+  Control.Monad.IO.Class.MonadIO,
+  Control.Monad.IO.Class.liftIO,
+  Control.Monad.forever,
+  Control.Monad.unless,
+  Control.Monad.void,
+  Control.Monad.when,
+  Maybe.listToMaybe,
+  Text.Text,
+  error,
+  errorWithoutStackTrace,
+  head,
+  intercalate,
+  trace,
+  traceIO,
+  traceId,
+  traceM,
+  traceShow,
+  traceShowIO,
+  traceShowId,
+  traceShowIdIO,
+  traceShowM,
+  undefined,
+) where
+
+import Prelude hiding
   ( error,
     errorWithoutStackTrace,
     head,
     undefined,
   )
-import qualified BasePrelude as P
-import qualified Control.Monad
 import Control.Monad ((>=>), (<=<))
-import qualified Control.Monad.IO.Class
-import qualified Data.ByteString as ByteString
-import qualified Data.Maybe as Maybe
-import qualified Data.Text.Lazy as Text
-import qualified Debug.Trace as Trace
-import qualified GHC.Stack.Types
+import Control.Monad qualified
+import Control.Monad.IO.Class qualified
+import Data.ByteString qualified as ByteString
+import Data.Maybe qualified as Maybe
+import Data.Text.Lazy qualified as Text
+import Debug.Trace qualified as Trace
+import GHC.Stack.Types
+import Prelude qualified as P
 
 {-# DEPRECATED head "Partial Function." #-}
 head :: [a] -> a

qbar/src/QBar/Qubes/AdminAPI.hs

+{-# OPTIONS_GHC -Wno-partial-fields #-}
+
+module QBar.Qubes.AdminAPI (
+  QubesPropertyInfo(..),
+  QubesVMInfo(..),
+  QubesVMState(..),
+  printEvents,
+  qubesEvents,
+  qubesGetProperty,
+  qubesListLabelNames,
+  qubesListProperties,
+  qubesListVMs,
+  qubesListVMsP,
+  qubesMonitorProperty,
+  qubesUsageOfDefaultPool,
+  qubesVMStats,
+) where
+
+import QBar.Prelude
+
+import Control.Monad (forM_)
+import Data.Binary
+import Data.Binary.Get
+import Data.Binary.Put
+import Data.ByteString qualified as BS
+import Data.ByteString.Lazy qualified as BL
+import Data.ByteString.Lazy.Char8 qualified as BLC
+import Data.Char (isAlphaNum)
+import Data.Function ((&))
+import Data.Map qualified as Map
+import Data.Maybe (fromMaybe)
+import Network.HostName
+import Pipes
+import Pipes.Prelude qualified as P
+import Pipes.Safe qualified as P
+import System.IO (Handle, hSetBinaryMode)
+import System.Process.Typed
+import Text.Read (readMaybe)
+
+data QubesAdminReturn
+  = Ok { okContent :: BL.ByteString }
+  | Event { evSubject :: BL.ByteString, evEvent :: BL.ByteString, evProperties :: [(BL.ByteString, BL.ByteString)] }
+  | Exception { excType :: BL.ByteString, excTraceback :: BL.ByteString, excFormatString :: BL.ByteString, excFields :: [BL.ByteString] }
+  deriving (Eq, Ord, Show, Read)
+
+putLazyByteStringNul :: BL.ByteString -> Put
+putLazyByteStringNul x = do
+  when (0 `BL.elem` x) $ error "String must not contain any \\x00 bytes"
+  putLazyByteString x
+  putWord8 0x00
+
+instance Binary QubesAdminReturn where
+  put Ok {okContent} = do
+    putWord8 0x30 >> putWord8 0x00
+    putLazyByteString okContent
+  put Event {evSubject, evEvent, evProperties} = do
+    putWord8 0x31 >> putWord8 0x00
+    putLazyByteStringNul evSubject
+    putLazyByteStringNul evEvent
+    forM_ evProperties $ \(k, v) -> do
+      putLazyByteStringNul k
+      putLazyByteStringNul v
+    putWord8 0x00
+  put Exception {excType, excTraceback, excFormatString, excFields} = do
+    putWord8 0x32 >> putWord8 0x00
+    putLazyByteStringNul excType
+    putLazyByteStringNul excTraceback
+    putLazyByteStringNul excFormatString
+    forM_ excFields putLazyByteStringNul
+    putWord8 0x00
+  get = do
+    msgType <- getWord8
+    zero <- getWord8
+    case (msgType, zero) of
+      (0x30, 0x00) -> Ok <$> getRemainingLazyByteString
+      (0x31, 0x00) -> Event <$> getLazyByteStringNul <*> getLazyByteStringNul <*> getPairs
+      (0x32, 0x00) -> Exception <$> getLazyByteStringNul <*> getLazyByteStringNul <*> getLazyByteStringNul <*> getFields
+      _ -> fail $ "unsupported message type " <> show msgType <> ", " <> show zero
+    where
+      getPairs = untilZeroByte $ (,) <$> getLazyByteStringNul <*> getLazyByteStringNul
+      getFields = untilZeroByte getLazyByteStringNul
+
+      untilZeroByte :: Get a -> Get [a]
+      untilZeroByte inner = lookAhead getWord8 >>= \case
+        0x00 -> getWord8 >> return []
+        _    -> inner >>= \x -> (x:) <$> untilZeroByte inner
+
+qubesAdminConnect :: BL.ByteString -> [BL.ByteString] -> IO (Process () Handle ())
+qubesAdminConnect serviceName args = do
+  hostname <- getHostName
+  let concatArgs sep = mconcat (map (sep <>) args)
+  let cmd = if hostname == "dom0"
+      then "qubesd-query dom0 " <> serviceName <> " dom0" <> concatArgs " "
+      else "qrexec-client-vm dom0 " <> serviceName <> concatArgs "+"
+  --NOTE qubesd-query and qrexec-client-vm don't like it if their input
+  --     is closed rather than empty.
+  --     hangs: qrexec-client-vm dom0 admin.vm.List <&-
+  --     works: qrexec-client-vm dom0 admin.vm.List </dev/null
+  let processConfig = setStdin nullStream $ setStdout createPipe $ shell $ BLC.unpack cmd
+  startProcess processConfig
+
+qubesTryAdminCall :: BL.ByteString -> [BL.ByteString] -> IO QubesAdminReturn
+qubesTryAdminCall serviceName args = do
+  process <- qubesAdminConnect serviceName args
+  let stdout = getStdout process
+  hSetBinaryMode stdout True
+  reply <- decode <$> BL.hGetContents stdout
+  case reply of
+    Ok {} -> return reply
+    Exception {} -> return reply
+    Event {} -> fail "service has returned events instead of a reply"
+
+qubesAdminCall :: BL.ByteString -> [BL.ByteString] -> IO BL.ByteString
+qubesAdminCall serviceName args = qubesTryAdminCall serviceName args >>= extract where
+  extract :: QubesAdminReturn -> IO BLC.ByteString
+  extract Ok {okContent} = return okContent
+  extract x@Exception {} = fail $ "service has returned an exception: " <> show x
+  extract Event {} = fail "service has returned events instead of a reply"
+
+qubesAdminCallP :: forall m. (P.MonadSafe m, MonadFail m)
+  => BL.ByteString -> [BL.ByteString] -> Producer QubesAdminReturn m ()
+qubesAdminCallP serviceName args = do
+  process <- liftIO $ qubesAdminConnect serviceName args
+  let stdout = getStdout process
+  liftIO $ hSetBinaryMode stdout True
+  let go :: Decoder QubesAdminReturn -> Producer QubesAdminReturn m ()
+      go = \case
+        Done remainder _ value -> do
+          yield value
+          go $ pushChunk (runGetIncremental get) remainder
+        d@(Partial _) -> do
+          chunk <- liftIO $ BS.hGetSome stdout 1024
+          if not (BS.null chunk)
+            then go $ pushChunk d chunk
+            else case pushEndOfInput d of
+              Done _ _ value -> yield value
+              _              -> return ()
+        Fail _ _ msg ->
+          fail $ "decoding reply from QubesAdmin failed: " <> msg
+  go (runGetIncremental get)
+    `P.finally` stopProcess process
+
+qubesAdminEvents :: forall m. (P.MonadSafe m, MonadFail m)
+  => BL.ByteString -> [BL.ByteString] -> Producer QubesAdminReturn m ()
+qubesAdminEvents serviceName args = qubesAdminCallP serviceName args >-> onlyEvents
+  where
+    onlyEvents :: Pipe QubesAdminReturn QubesAdminReturn m ()
+    onlyEvents = forever $ await >>= \reply -> case reply of
+        Ok {} -> fail "service has returned OK instead of events"
+        Exception {} -> fail $ "service has returned an exception: " ++ show reply
+        Event {} -> yield reply
+
+qubesVMStatsRaw :: forall m. (P.MonadSafe m, MonadFail m)
+  => Producer QubesAdminReturn m ()
+qubesVMStatsRaw = qubesAdminEvents "admin.vm.Stats" []
+
+data QubesVMStats = QubesVMStats { statsVMName :: BL.ByteString, memoryKB :: Int, cpuTime :: Int, cpuUsageRaw :: Int, cpuUsage :: Int }
+  deriving (Eq, Ord, Show, Read)
+
+qubesVMStats :: forall m. (P.MonadSafe m, MonadFail m)
+  => Producer QubesVMStats m ()
+qubesVMStats = qubesVMStatsRaw >-> P.mapFoldable parse where
+  parse :: QubesAdminReturn -> Maybe QubesVMStats
+  parse Event {evSubject, evEvent, evProperties}
+    | evEvent == "connection-established" = Nothing
+    | evEvent == "vm-stats" = Just $ addProperties evProperties $ QubesVMStats evSubject absent absent absent absent
+    | otherwise = Nothing  -- shouldn't happen -> report error?
+  parse _ = Nothing  -- shouldn't happen -> report error?
+
+  absent :: Int = -1
+
+  readBL :: BLC.ByteString -> Int
+  readBL = read . BLC.unpack
+
+  addProperties :: [(BL.ByteString, BL.ByteString)] -> QubesVMStats -> QubesVMStats
+  addProperties (("memory_kb",     x) : xs) st = addProperties xs $ st { memoryKB    = readBL x }
+  addProperties (("cpu_time",      x) : xs) st = addProperties xs $ st { cpuTime     = readBL x }
+  addProperties (("cpu_usage_raw", x) : xs) st = addProperties xs $ st { cpuUsageRaw = readBL x }
+  addProperties (("cpu_usage",     x) : xs) st = addProperties xs $ st { cpuUsage    = readBL x }
+  addProperties (_ : xs) st = addProperties xs st
+  addProperties [] st = st
+
+data QubesEvent
+  = OtherEvent QubesAdminReturn
+  | DomainPreStart { domainName :: BL.ByteString, startGuid :: Maybe Bool }
+  | DomainStart { domainName :: BL.ByteString, startGuid :: Maybe Bool }
+  | DomainUnpaused { domainName :: BL.ByteString }
+  | DomainStopped { domainName :: BL.ByteString }
+  | DomainShutdown { domainName :: BL.ByteString }
+  | DomainUpdatesAvailable { domainName :: BL.ByteString, updatesAvailable :: Bool, updatesAvailableOld :: Bool }
+  | DomainStartFailed { domainName :: BL.ByteString, reason :: BL.ByteString }
+  | PropertySet { domainName :: BL.ByteString, changedProperty :: BL.ByteString, newValue :: BL.ByteString, oldValue :: BL.ByteString }
+  | PropertyDel { domainName :: BL.ByteString, changedProperty :: BL.ByteString, oldValue :: BL.ByteString } -- reset to default value
+  deriving (Eq, Ord, Show, Read)
+
+qubesEventsRaw :: forall m. (P.MonadSafe m, MonadFail m)
+  => Producer QubesAdminReturn m ()
+qubesEventsRaw = qubesAdminEvents "admin.Events" []
+
+qubesEvents :: forall m. (P.MonadSafe m, MonadFail m)
+  => Producer QubesEvent m ()
+qubesEvents = qubesEventsRaw >-> P.mapFoldable parse where
+  parse :: QubesAdminReturn -> Maybe QubesEvent
+  parse Event {evEvent="connection-established"} = Nothing
+  parse ev@(Event {evSubject, evEvent, evProperties}) =
+    Just $ case evEvent of
+      "domain-pre-start" -> DomainPreStart evSubject (boolProp "start_guid")
+      "domain-start" -> DomainStart evSubject (boolProp "start_guid")
+      "domain-unpaused" -> DomainUnpaused evSubject
+      "domain-stopped" -> DomainStopped evSubject
+      "domain-shutdown" -> DomainShutdown evSubject
+      "domain-feature-set:updates-available" ->
+        DomainUpdatesAvailable evSubject (boolPropViaInt "value") (boolPropViaInt "oldvalue")
+      "domain-start-failed" ->
+        DomainStartFailed evSubject (fromMaybe "" $ getProp "reason")
+      _ -> case BLC.break (== ':') evEvent of
+        ("property-set", _) ->
+          PropertySet evSubject (fromMaybe "" $ getProp "name") (fromMaybe "" $ getProp "newvalue") (fromMaybe "" $ getProp "oldvalue")
+        ("property-del", _) ->
+          PropertyDel evSubject (fromMaybe "" $ getProp "name") (fromMaybe "" $ getProp "oldvalue")
+        _ -> OtherEvent ev
+    where
+      getProp :: BL.ByteString -> Maybe BL.ByteString
+      getProp name = lookup name evProperties
+      readProp :: Read a => BL.ByteString -> Maybe a
+      readProp name = read . BLC.unpack <$> getProp name
+      intProp :: BL.ByteString -> Maybe Int
+      intProp = readProp
+      boolProp :: BL.ByteString -> Maybe Bool
+      boolProp = readProp
+      boolPropViaInt :: BL.ByteString -> Bool
+      boolPropViaInt = maybe False (/= 0) . intProp
+  parse _ = Nothing  -- shouldn't happen -> report error?
+
+printEvents  :: Show a => Producer a (P.SafeT IO) () -> IO ()
+printEvents prod = P.runSafeT $ runEffect $ prod >-> forever (await >>= liftIO . print)
+
+data QubesVMState = VMRunning | VMHalted | UnknownState
+  deriving (Eq, Ord, Enum)
+data QubesVMClass = AdminVM | AppVM | TemplateVM | DispVM | StandaloneVM | UnknownClass
+  deriving (Eq, Ord, Enum, Show, Read)
+data QubesVMInfo = QubesVMInfo { vmState :: QubesVMState, vmClass :: QubesVMClass }
+  deriving (Eq, Ord, Show, Read)
+
+instance Show QubesVMState where
+  show VMRunning = "Running"
+  show VMHalted = "Halted"
+  show UnknownState = "??"
+
+instance Read QubesVMState where
+  readsPrec _ s = [(value, remainder)]
+    where
+      (word, remainder) = span isAlphaNum s
+      value = case word of
+        "Running" -> VMRunning
+        "Halted" -> VMHalted
+        _ -> UnknownState
+
+qubesAdminCallLines :: BL.ByteString -> [BL.ByteString] -> IO [BL.ByteString]
+qubesAdminCallLines serviceName args = qubesAdminCall serviceName args >>= parse
+  where
+    parse :: BLC.ByteString -> IO [BLC.ByteString]
+    parse reply = BLC.split '\n' reply
+      & filter (/= "")
+      & return
+
+qubesListVMs :: IO (Map.Map BL.ByteString QubesVMInfo)
+qubesListVMs = parse <$> qubesAdminCallLines "admin.vm.List" []
+  where
+    parse :: [BLC.ByteString] -> Map.Map BLC.ByteString QubesVMInfo
+    parse = Map.fromList . map parseLine
+
+    parseLine :: BLC.ByteString -> (BLC.ByteString, QubesVMInfo)
+    parseLine line =
+      (vmName, QubesVMInfo (readPropEmpty "state") (tryReadProp "class" & fromMaybe UnknownClass))
+      where
+        (vmName : propsRaw) = BLC.split ' ' line
+        props = map (fmap BLC.tail . BLC.break (== '=')) propsRaw
+        getProp :: BL.ByteString -> Maybe BL.ByteString
+        getProp name = lookup name props
+        readPropEmpty :: Read a => BL.ByteString -> a
+        readPropEmpty name = read . BLC.unpack . fromMaybe "" $ getProp name
+        tryReadProp :: Read a => BL.ByteString -> Maybe a
+        tryReadProp name = readMaybe . BLC.unpack =<< getProp name
+
+qubesListVMsP :: forall m. (P.MonadSafe m, MonadFail m)
+  => Producer (Map.Map BL.ByteString QubesVMInfo) m ()
+qubesListVMsP = liftIO qubesListVMs >>= yield >> qubesEvents >-> P.mapM (const $ liftIO qubesListVMs)
+
+data QubesPropertyInfo = QubesPropertyInfo { propIsDefault :: Bool, propType :: BL.ByteString, propValue :: BL.ByteString }
+  deriving (Eq, Ord, Show, Read)
+
+qubesGetProperty :: BL.ByteString -> IO QubesPropertyInfo
+qubesGetProperty name = parse <$> qubesAdminCall "admin.property.Get" [name]
+  where
+    parse reply = QubesPropertyInfo (isDefault == "default=True") (BL.drop 5 typeStr) value
+      where
+        splitOn ch = fmap BLC.tail . BLC.break (== ch)
+        (isDefault, (typeStr, value)) = splitOn ' ' reply & fmap (splitOn ' ')
+
+qubesListProperties :: IO [(BL.ByteString, QubesPropertyInfo)]
+qubesListProperties = qubesListLabelNames >>= mapM (toSndM qubesGetProperty)
+  where
+    toSndM :: Applicative m => (a -> m b) -> a -> m (a, b)
+    toSndM f x = sequenceA (x, f x)
+
+qubesGetDefaultPool :: IO BL.ByteString
+qubesGetDefaultPool = propValue <$> qubesGetProperty "default_pool"
+
+qubesGetPoolInfo :: BL.ByteString -> IO [(BL.ByteString, BL.ByteString)]
+qubesGetPoolInfo name = map parseLine <$> qubesAdminCallLines "admin.pool.Info" [name]
+  where
+    parseLine = fmap BLC.tail . BLC.break (== '=')
+
+qubesUsageOfDefaultPool :: IO (Maybe Int, Maybe Int)
+qubesUsageOfDefaultPool = qubesGetDefaultPool >>= qubesGetPoolInfo >>= extract
+  where
+    extract :: [(BLC.ByteString, BLC.ByteString)] -> IO (Maybe Int, Maybe Int)
+    extract props = return (tryReadProp "usage" props, tryReadProp "size" props)
+    tryReadProp :: Read a => BL.ByteString -> [(BL.ByteString, BL.ByteString)] -> Maybe a
+    tryReadProp name props = readMaybe . BLC.unpack =<< lookup name props
+
+
+qubesListLabelNames :: IO [BL.ByteString]
+qubesListLabelNames = qubesAdminCallLines  "admin.label.List" []
+
+qubesMonitorProperty :: forall m. MonadIO m
+  => Producer QubesEvent m () -> BL.ByteString -> Producer QubesPropertyInfo m ()
+qubesMonitorProperty events name = events >-> P.filter isRelevant >-> fetchValue
+  where
+    fetchValue :: Proxy () QubesEvent () QubesPropertyInfo m b
+    fetchValue = liftIO (qubesGetProperty name) >>= go
+
+    go :: QubesPropertyInfo -> Proxy () QubesEvent () QubesPropertyInfo m b
+    go x = do
+      yield x
+      ev <- await
+      case ev of
+        PropertySet {newValue} -> go $ x { propIsDefault = False, propValue = newValue }
+        PropertyDel {} -> fetchValue
+        _ -> go x
+
+    isRelevant PropertySet {changedProperty} = name == changedProperty
+    isRelevant PropertyDel {changedProperty} = name == changedProperty
+    isRelevant _ = False

src/QBar/Server.hs → qbar/src/QBar/Server.hs

-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-
-module QBar.Server where
+module QBar.Server (
+  runBarServer,
+  runBarServerMirror,
+) where
 
 import QBar.BlockOutput
-import QBar.Core
 import QBar.ControlSocket
+import QBar.Core
 import QBar.Host
 import QBar.Pango
+import QBar.Prelude
 import QBar.Theme
-import QBar.Util
+import QBar.Utils
 
-import Control.Monad (forM_)
 import Control.Concurrent.Async (async, link)
 import Control.Concurrent.Event as Event
 import Control.Concurrent.MVar (MVar, newMVar, modifyMVar, modifyMVar_)
 import Control.Exception (throw)
+import Control.Monad (forM_)
 import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
+import Data.Aeson.Types qualified as AT
+import Data.ByteString.Char8 qualified as BSSC8
 import Data.ByteString.Lazy (hPut)
-import qualified Data.ByteString.Char8 as BSSC8
-import qualified Data.ByteString.Lazy as BS
-import qualified Data.ByteString.Lazy.Char8 as C8
+import Data.ByteString.Lazy qualified as BS
+import Data.ByteString.Lazy.Char8 qualified as C8
 import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
 import Pipes
 import Pipes.Concurrent (Input, spawn, latest, toOutput, fromInput)
-import qualified Pipes.Prelude as PP
+import Pipes.Prelude qualified as PP
 import System.IO (stdin, stdout, stderr, hFlush)
 
-data ServerMode = Host | Mirror
-data ServerOutput = Sway | Headless
-
 renderIndicators :: [Text]
 renderIndicators = ["*"] <> cycle ["/", "-", "\\", "|"]
 
@@ -43,9 +42,16 @@ instance ToJSON PangoBlock where
   toJSON PangoBlock{pangoBlockFullText, pangoBlockShortText, pangoBlockName} = object $
     fullText' <> shortText' <> blockName' <> pango'
     where
+      fullText' :: [AT.Pair]
       fullText' = [ "full_text" .= pangoBlockFullText ]
+
+      shortText' :: [AT.Pair]
       shortText' = fromMaybe (\s -> ["short_text" .= s]) mempty pangoBlockShortText
+
+      blockName' :: [AT.Pair]
       blockName' = fromMaybe (\s -> ["name" .= s]) mempty pangoBlockName
+
+      pango' :: [AT.Pair]
       pango' = [ "markup" .= ("pango" :: T.Text) ]
 
 
@@ -63,7 +69,9 @@ swayBarInput MainOptions{verbose} = swayBarInput'
           liftIO $ BSSC8.hPutStrLn stderr line
           hFlush stderr
 
-        let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
+        let
+          maybeBlockEvent :: Maybe BlockEvent
+          maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
         forM_ maybeBlockEvent yield
 
       swayBarInput'
@@ -111,7 +119,7 @@ swayBarOutput options@MainOptions{indicator} = do
           hPut stderr "\n"
           hFlush stderr
     encodeOutput :: [ThemedBlockOutput] -> BS.ByteString
-    encodeOutput blocks = encode $ map renderPangoBlock $ blocks
+    encodeOutput blocks = encode $ map renderPangoBlock blocks
     renderPangoBlock :: ThemedBlockOutput -> PangoBlock
     renderPangoBlock ThemedBlockOutput{_fullText, _shortText, _blockName} = PangoBlock {
       pangoBlockFullText = renderPango _fullText,
@@ -121,7 +129,7 @@ swayBarOutput options@MainOptions{indicator} = do
 
 runBarServerMirror :: BarIO () -> MainOptions -> IO ()
 runBarServerMirror loadBlocks options = do
-  -- TODO: apply theme from remote
+  -- It would be nice to apply the theme from the remote, but because of the current split between Host and Server some redesign is required first.
   (blockConsumer, eventProducer, _setTheme') <- themingBarServer options
   runBarHost (return (blockConsumer, eventProducer)) $ do
     addServerMirrorStream options
@@ -192,7 +200,7 @@ themingBarServer options = do
           (themedBlocks, isAnimated'') <- liftIO $ modifyMVar themedBlockProducerMVar (\(themedBlockProducer, isAnimated') -> do
             result <- next themedBlockProducer
             case result of
-              -- TODO: fix type safety on this somehow?
+              -- Maybe type safety can be improved so this pattern match is no longer needed?
               Left _ -> throw $ userError "Unexpected behavior: Themes and output cache mailbox should never return"
               Right (themedBlocks, nextThemedBlockProducer) ->
                 return ((nextThemedBlockProducer, isAnimated'), (themedBlocks, isAnimated'))

src/QBar/TagParser.hs → qbar/src/QBar/TagParser.hs

-module QBar.TagParser where
+module QBar.TagParser (
+  TagState,
+  parseTags,
+  parseTags',
+  parseTags'',
+) where
 
 import QBar.BlockOutput
 import QBar.Color
+import QBar.Prelude
 
 import Control.Applicative ((<|>))
 import Data.Attoparsec.Text.Lazy as A
 import Data.Functor (($>))
 import Data.Maybe (catMaybes)
-import qualified Data.Text as TS
-import qualified Data.Text.Lazy as T
+import Data.Text qualified as TS
+import Data.Text.Lazy qualified as T
 
 type TagState = (Bool, Importance)
 
@@ -22,7 +28,11 @@ tagParser = parser (False, normalImportant)
         singleElementParser = choice [textParser, activeTagParser, importanceTagParser, spanParser]
 
         textParser :: Parser BlockText
-        textParser = mkText active importance . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
+        textParser = mkText active importance . replaceSymbols . T.fromStrict <$> A.takeWhile1 (notInClass "<>")
+
+        replaceSymbols :: Text -> Text
+        -- replaces &amp; last to prevent the '&' from being interpreted again
+        replaceSymbols = T.replace "&amp;" "&" . T.replace "&lt;" "<" . T.replace "&gt;" ">"
 
         activeTagParser :: Parser BlockText
         activeTagParser = string "<active>" *> parser (True, importance) <* string "</active>"
@@ -50,7 +60,7 @@ tagParser = parser (False, normalImportant)
     spanParser :: Parser BlockText
     spanParser = do
       void $ string "<span"
-      (colors, backgrounds) <- unzip <$> (many' $ colorAttribute <|> backgroundAttribute)
+      (colors, backgrounds) <- unzip <$> many' (colorAttribute <|> backgroundAttribute)
       let color = listToMaybe . catMaybes $ colors
       let background = listToMaybe . catMaybes $ backgrounds
       void $ char '>'
@@ -80,7 +90,7 @@ tagParser = parser (False, normalImportant)
 
 
 parseTags :: T.Text -> Either String BlockText
-parseTags text = parseOnly (tagParser <* endOfInput) (T.toStrict text)
+parseTags = parseOnly (tagParser <* endOfInput)
 
 parseTags' :: T.Text -> BlockOutput
 parseTags' = either (mkErrorOutput . T.pack) mkBlockOutput . parseTags

src/QBar/Theme.hs → qbar/src/QBar/Theme.hs

-{-# LANGUAGE DuplicateRecordFields #-}
-{-# LANGUAGE Rank2Types #-}
-
-module QBar.Theme where
+module QBar.Theme (
+  Theme(..),
+  ThemedBlockOutput(..),
+  ThemedBlockText(..),
+  ThemedBlockTextSegment(..),
+  defaultTheme,
+  findTheme,
+  isAnimated,
+  mkTheme,
+  mkThemedBlockOutput,
+  themeNames,
+  themes,
+  whiteThemedBlockOutput,
+) where
 
 import QBar.BlockOutput
 import QBar.Color
+import QBar.Prelude
 
 import Control.Applicative ((<|>))
 import Control.Lens ((^.))
 import Control.Monad.State.Lazy (State, evalState, get, put)
 import Data.Colour.RGBSpace
 import Data.Colour.RGBSpace.HSV (hsv)
-import qualified Data.HashMap.Lazy as HM
+import Data.HashMap.Lazy qualified as HM
 import Data.Maybe (fromMaybe)
-import qualified Data.Text.Lazy as T
+import Data.Text.Lazy qualified as T
 import Data.Time.Clock.POSIX (getPOSIXTime)
 import Pipes
 
@@ -39,7 +50,6 @@ data ThemedBlockTextSegment = ThemedBlockTextSegment {
   }
   deriving (Eq, Show)
 
-
 data Theme = StaticTheme StaticTheme | AnimatedTheme AnimatedTheme
 
 type StaticTheme = [BlockOutput] -> [ThemedBlockOutput]
@@ -67,6 +77,7 @@ themes = HM.fromList themesList
 findTheme :: Text -> Either Text Theme
 findTheme themeName = maybe invalidThemeName Right $ HM.lookup themeName themes
   where
+    invalidThemeName :: Either Text Theme
     invalidThemeName = Left $ "Invalid theme: " <> themeName
 
 mkTheme :: SimplifiedTheme -> Theme
@@ -111,7 +122,6 @@ mkThemedSegment (color, backgroundColor) text = ThemedBlockTextSegment{themedSeg
 whiteThemedBlockOutput :: Text -> ThemedBlockOutput
 whiteThemedBlockOutput = mkThemedBlockOutput (ColorRGB (RGB 1 1 1), Nothing)
 
-
 invalidColor :: Color
 invalidColor = ColorRGBA (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)) (0x77 / 255)
 
@@ -131,14 +141,13 @@ defaultTheme = mkTheme defaultTheme'
     defaultTheme' True (NormalImportant _) = (ColorRGB (RGB 1 1 1), Nothing)
     defaultTheme' False (NormalImportant _) = (ColorRGB (RGB (0x96 / 255) (0x98 / 255) (0x96 / 255)), Nothing)
 
-
 rainbowTheme :: Theme
 rainbowTheme = AnimatedTheme rainbowThemePipe
   where
     rainbowThemePipe :: AnimatedTheme
     rainbowThemePipe = do
       time <- liftIO $ fromRational . toRational <$> getPOSIXTime
-      yield =<< rainbowThemePipe' time <$> await
+      yield . rainbowThemePipe' time =<< await
       rainbowThemePipe
     rainbowThemePipe' :: Double -> StaticTheme
     rainbowThemePipe' time blocks = reverse $ evalState (mapM rainbowBlock $ reverse blocks) 0
@@ -146,18 +155,18 @@ rainbowTheme = AnimatedTheme rainbowThemePipe
         rainbowBlock :: BlockOutput -> State Integer ThemedBlockOutput
         rainbowBlock block@BlockOutput{_blockName} = do
           let text = rawText $ block ^. fullText
-          let chars = T.unpack . T.reverse $ text
+          let chars = reverse . splitToChars $ text
           coloredChars <- mapM rainbowChar chars
-          let rainbowText = reverse $ coloredChars
+          let rainbowText = reverse coloredChars
           return $ ThemedBlockOutput {
             _blockName,
             _fullText = ThemedBlockText rainbowText,
             _shortText = Nothing
           }
-        rainbowChar :: Char -> State Integer ThemedBlockTextSegment
+        rainbowChar :: T.Text -> State Integer ThemedBlockTextSegment
         rainbowChar char = do
           color <- nextRainbowColor
-          return $ mkThemedSegment (color, Nothing) $ T.singleton char
+          return $ mkThemedSegment (color, Nothing) $ char
         nextRainbowColor :: State Integer Color
         -- nextRainbowColor = state $ \index -> (rainbowColor (fromInteger index), index + 1)
         nextRainbowColor = do
@@ -169,3 +178,13 @@ rainbowTheme = AnimatedTheme rainbowThemePipe
           let hue' = position * 3
               color = hsv hue' 0.8 1.0
           in ColorRGB color
+        splitToChars :: T.Text -> [T.Text]
+        splitToChars = splitStringToChars . T.unpack
+        splitStringToChars :: String -> [T.Text]
+        splitStringToChars [] = []
+        splitStringToChars ('&':xs) = splitStringToCharsAmp "&" xs
+        splitStringToChars (x:xs) = T.singleton x : splitStringToChars xs
+        splitStringToCharsAmp :: String -> String -> [T.Text]
+        splitStringToCharsAmp _ [] = []
+        splitStringToCharsAmp acc (';':xs) = T.pack (acc <> ";") : splitStringToChars xs
+        splitStringToCharsAmp acc (x:xs) = splitStringToCharsAmp (acc <> [x]) xs