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 = pullBlock' (everyNSeconds 60) $ forever $ do
+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
-  sendBlockUpdate $ 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

qbar/src/QBar/Blocks/NetworkManager.hs

+module QBar.Blocks.NetworkManager (
+  getDBusProperty,
+  networkManagerBlock,
+  runExceptT_,
+) where
+
+import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
+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)
+
+fromJust :: MonadError () m => Maybe a -> m a
+fromJust (Just a) = return a
+fromJust Nothing = throwError ()
+
+runExceptT_ :: Monad m => ExceptT () m a -> m (Maybe a)
+runExceptT_ a = either (const Nothing) Just <$> runExceptT a
+
+getDBusProperty :: (MonadError () m, MonadIO m, DBus.IsVariant a) => DBus.Client -> DBus.BusName -> DBus.ObjectPath -> DBus.InterfaceName -> DBus.MemberName -> m a
+getDBusProperty client busName objectPath interfaceName memberName = do
+  result' <- tryMaybe' $ do
+    let methodCall = ((DBus.methodCall objectPath interfaceName memberName) {DBus.methodCallDestination = Just busName})
+    result <- either (const Nothing) Just <$> DBus.getProperty client methodCall
+    return $ DBus.fromVariant =<< result
+  fromJust result'
+
+getConnectionInfo :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m ConnectionInfo
+getConnectionInfo client connectionObjectPath = do
+  connectionType <- getActiveConnectionType client connectionObjectPath
+  connectionName <- getActiveConnectionName client connectionObjectPath
+  case connectionType of
+    "802-11-wireless" -> do
+      devices <- getActiveConnectionDevice client connectionObjectPath
+      device <- fromJust $ listToMaybe devices
+      accessPoint <- getDeviceAccessPoint client device
+      signalStrength <- fromIntegral <$> getAccessPointSignalStrength client accessPoint
+      return $ WifiConnection connectionName signalStrength
+    "gsm" -> do
+      devices <- getActiveConnectionDevice client connectionObjectPath
+      device <- fromJust $ listToMaybe devices
+      udi <- getDeviceUdi client device
+      signalQuality <- getModemSignalQuality client $ DBus.objectPath_ udi
+      return $ WwanConnection connectionName . fromIntegral . fst $ signalQuality
+    "802-3-ethernet" -> return $ EthernetConnection connectionName
+    _ -> throwError ()
+
+networkManagerBlock :: Block
+networkManagerBlock = runSignalBlockConfiguration $ SignalBlockConfiguration {
+  aquire,
+  release,
+  signalThread = Nothing,
+  signalBlock = networkManagerBlock',
+  interval = Just defaultInterval
+}
+  where
+    aquire :: (() -> IO ()) -> BarIO DBus.Client
+    aquire trigger = liftIO $ do
+      client <- DBus.connectSystem
+      let matchRule = DBus.matchAny {
+        DBus.matchPath = Just "/org/freedesktop/NetworkManager",
+        DBus.matchInterface = Just "org.freedesktop.DBus.Properties"
+      }
+      void . DBus.addMatch client matchRule $ dbusSignalHandler trigger
+      return client
+    release :: DBus.Client -> BarIO ()
+    release = liftIO . DBus.disconnect
+
+    networkManagerBlock' :: DBus.Client -> SignalBlock ()
+    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
+      primaryConnectionInfo <- case primaryConnection of
+        Just primaryConnection' -> runExceptT_ $ getConnectionInfo client primaryConnection'
+        Nothing -> return Nothing
+      return . mkBlockOutput $ fullText' primaryConnectionInfo
+    fullText' :: Maybe ConnectionInfo -> BlockText
+    fullText' connectionInfo = fullText'' connectionInfo
+      where
+        importanceLevel :: Importance
+        importanceLevel = case connectionInfo of
+          Nothing -> errorImportant
+          (Just (WifiConnection _ strength)) -> toImportance (0, 85 ,100, 100, 100) . (100 -) $ strength
+          (Just (WwanConnection _ strength)) -> toImportance (0, 85 ,100, 100, 100) . (100 -) $ strength
+          (Just (EthernetConnection _)) -> normalImportant
+        fullText'' :: Maybe ConnectionInfo -> BlockText
+        fullText'' Nothing = importantText importanceLevel "❌\xFE0E No Connection"
+        fullText'' (Just (WifiConnection name strength)) = importantText importanceLevel $ "📡\xFE0E " <> name <> " " <> formatPercent strength
+        fullText'' (Just (WwanConnection _ signalQuality)) = importantText importanceLevel $ "📶\xFE0E " <> formatPercent signalQuality
+        fullText'' (Just (EthernetConnection _)) = importantText importanceLevel "🔌\xFE0E Ethernet"
+    dbusSignalHandler :: (() -> IO ()) -> DBus.Signal -> IO ()
+    dbusSignalHandler trigger signal = when (primaryConnectionHasChanged signal) $ trigger ()
+    primaryConnectionHasChanged :: DBus.Signal -> Bool
+    primaryConnectionHasChanged = any (maybe False (containsKey "PrimaryConnection") . DBus.fromVariant) . DBus.signalBody
+    containsKey :: String -> Map.Map String DBus.Variant -> Bool
+    containsKey = Map.member
+
+formatPercent :: Int -> Text
+formatPercent a = T.justifyRight 3 ' ' $ (T.pack . show . max 0 . min 100) a <> "%"
+
+getPrimaryConnectionPath :: (MonadError () m, MonadIO m) => DBus.Client -> m DBus.ObjectPath
+getPrimaryConnectionPath client =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    "/org/freedesktop/NetworkManager"
+    "org.freedesktop.NetworkManager"
+    "PrimaryConnection"
+
+getActiveConnectionType :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Text
+getActiveConnectionType client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.Connection.Active"
+    "Type"
+
+getActiveConnectionName :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Text
+getActiveConnectionName client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.Connection.Active"
+    "Id"
+
+getActiveConnectionDevice :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m [DBus.ObjectPath]
+getActiveConnectionDevice client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.Connection.Active"
+    "Devices"
+
+getDeviceAccessPoint :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m DBus.ObjectPath
+getDeviceAccessPoint client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.Device.Wireless"
+    "ActiveAccessPoint"
+
+getDeviceUdi :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m String
+getDeviceUdi client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.Device"
+    "Udi"
+
+getAccessPointSignalStrength :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m Word8
+getAccessPointSignalStrength client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.NetworkManager"
+    objectPath
+    "org.freedesktop.NetworkManager.AccessPoint"
+    "Strength"
+
+getModemSignalQuality :: (MonadError () m, MonadIO m) => DBus.Client -> DBus.ObjectPath -> m (Word32, Bool)
+getModemSignalQuality client objectPath =
+  getDBusProperty
+    client
+    "org.freedesktop.ModemManager1"
+    objectPath
+    "org.freedesktop.ModemManager1.Modem"
+    "SignalQuality"

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 where
-
-import Control.Exception (IOException, catch)
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.IO as TIO
+module QBar.Blocks.Utils (
+  ensure,
+  formatFloatN,
+  parseFile,
+  tryMaybe',
+  tryMaybe,
+) where
+
+import QBar.Prelude
+
+import Control.Exception (SomeException, catch)
+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
@@ -19,13 +25,13 @@ ensure f a
   | f a = Just a
   | otherwise = Nothing
 
-tryMaybe :: IO a -> IO (Maybe a)
+tryMaybe :: MonadIO m => IO a -> m (Maybe a)
 tryMaybe a = tryMaybe' (Just <$> a)
 
-tryMaybe' :: IO (Maybe a) -> IO (Maybe a)
-tryMaybe' a = catch a (\(_ :: IOException) -> return Nothing)
+tryMaybe' :: MonadIO m => IO (Maybe a) -> m (Maybe a)
+tryMaybe' a = liftIO . catch a $ \(_ :: SomeException) -> return Nothing
 
-parseFile :: FilePath -> AT.Parser a -> IO (Maybe a)
+parseFile :: MonadIO m => FilePath -> AT.Parser a -> m (Maybe a)
 parseFile path parser = tryMaybe' $ do
   fileContents <- TIO.readFile path
   return . AT.maybeResult $ AT.parse parser fileContents

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,27 +35,49 @@ 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 ())
 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 for swaybar. Should be called by swaybar.")) <>
-    command "i3bar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server for i3bar. Should be called by i3bar.")) <>
-    command "send" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server."))
+    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-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 ())
+    barConfigurationParser = sequence_ <$> some blockParser
+
+mirrorCommandParser :: Parser (MainOptions -> IO ())
+mirrorCommandParser = hsubparser (
+    command "swaybar" (info (runBarServerMirror <$> barConfigurationParser) (progDesc "Mirror the output of another server. Should be called by swaybar.")) <>
+    command "i3bar" (info (runBarServerMirror <$> barConfigurationParser) (progDesc "Mirror the output of another server. Should be called by i3bar."))
   )
+  where
+    barConfigurationParser :: Parser (BarIO ())
+    barConfigurationParser = sequence_ <$> many blockParser
+
 
 themeCommandParser :: Parser (MainOptions -> IO ())
 themeCommandParser = sendIpc . SetTheme <$> strArgument (metavar "THEME" <> completeWith (map T.unpack themeNames))
@@ -58,18 +87,12 @@ pipeClientParser = do
   events <- switch $ long "events" <> short 'e' <> help "Also encode events to stdout. Every event will be a JSON-encoded line."
   pure $ runPipeClient events
 
-barConfigurationParser :: Parser (BarIO ())
-barConfigurationParser = do
-  blocks <- some blockParser
-  pure $ sequence_ blocks
-
 blockParser :: Parser (BarIO ())
 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 (
@@ -77,11 +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 "script" (info scriptBlockParser (progDesc "Display the output of an external script as a 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 "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
-  persistent <- switch $ long "persistent" <> short 'p' <> help "Run script in persistent 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 persistent then addBlock . persistentScriptBlock 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 OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
 
-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.Exception (SomeException, handle)
 import Control.Concurrent (forkFinally)
 import Control.Concurrent.Async
+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 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', unbounded, 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
 
@@ -43,16 +55,21 @@ class (ToJSON (Up s), FromJSON (Up s), ToJSON (Down s), FromJSON (Down s)) => Is
   streamHandler :: s -> BarIO (Consumer (Up s) IO (), Producer (Down s) IO (), IO ())
   toStreamType :: s -> StreamType
 
-  streamClient :: (MonadIO m) => s -> MainOptions -> m (Consumer (Up s) IO (), Producer (Down s) IO ())
-  streamClient s options@MainOptions{verbose} = do
+  streamClient :: s -> MainOptions -> BarIO (Consumer (Up s) IO (), Producer (Down s) IO ())
+  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
+      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
@@ -64,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
@@ -93,16 +144,24 @@ decodeStreamSafe MainOptions{verbose} inputStream = decodeStream inputStream >->
             Right v -> yield v >> failOnDecodingError'
 
 
-data StreamType = BlockStreamType BlockStream
+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
   toStreamType = BlockStreamType
+  streamHandler :: BlockStream -> BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO (), IO ())
   streamHandler _ = do
     (cache, updateCacheC, sealCache) <- newCache'
     (eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded
@@ -136,13 +195,31 @@ instance IsStream BlockStream where
       updateBarP bar = forever $ await >>= yield >> liftIO (updateBarDefault' bar)
 
 
+data MirrorStream = MirrorStream
+  deriving Generic
+
+instance IsStream MirrorStream where
+  type Up MirrorStream = BlockEvent
+  type Down MirrorStream = [BlockOutput]
+  toStreamType = MirrorStreamType
+  streamHandler :: MirrorStream -> BarIO (Consumer BlockEvent IO (), Producer [BlockOutput] IO (), IO ())
+  streamHandler _ = do
+    (eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded
+    (blockOutput, blockInput, blockSeal) <- liftIO $ spawn' $ newest 1
+    let seal = atomically $ eventSeal >> blockSeal
+
+    attachBarOutput (toOutput blockOutput, fromInput eventInput)
+    return (toOutput eventOutput, fromInput blockInput, seal)
+
+
 data Request = Command Command | StartStream StreamType
+  deriving Generic
 
-data Command = SetTheme T.Text
-  deriving Show
+data Command = SetTheme T.Text | CheckServer
+  deriving (Show, Generic)
 
 data CommandResult = Success | Error Text
-  deriving Show
+  deriving (Show, Generic)
 
 
 ipcSocketAddress :: MainOptions -> IO FilePath
@@ -151,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)
@@ -176,31 +249,93 @@ connectIpcSocket options = do
   connect sock $ SockAddrUnix socketPath
   return sock
 
-$(deriveJSON defaultOptions ''Request)
-$(deriveJSON defaultOptions ''Command)
-$(deriveJSON defaultOptions ''CommandResult)
-$(deriveJSON defaultOptions ''StreamType)
-$(deriveJSON defaultOptions ''BlockStream)
-
 sendIpc :: Command -> MainOptions -> IO ()
 sendIpc command options@MainOptions{verbose} = do
-  let request = Command command
-  sock <- connectIpcSocket options
-  runEffect $ encode request >-> toSocket sock
+  result <- sendIpc' command options
+  case result of
+    Left err -> T.hPutStrLn stderr err
+    Right () -> when verbose $ hPutStrLn stderr "Success"
 
-  decodeResult <- evalStateT decode $ fromSocket sock 4096
-  maybe exitEmptyStream (either exitInvalidResult showResponse) decodeResult
+sendIpc' :: Command -> MainOptions -> IO (Either Text ())
+sendIpc' command options = catch sendCommand handleException
   where
-    exitEmptyStream :: IO ()
-    exitEmptyStream = hPutStrLn stderr "Empty stream"
-    exitInvalidResult :: DecodingError -> IO ()
-    exitInvalidResult = hPrint stderr
-    showResponse :: CommandResult -> IO ()
-    showResponse Success = when verbose $ hPutStrLn stderr "Success"
-    showResponse (Error message) = hPrint stderr message
+    sendCommand :: IO (Either Text ())
+    sendCommand = do
+      sock <- connectIpcSocket options
+      runEffect $ encode (Command command) >-> toSocket sock
+
+      decodeResult <- evalStateT decode $ fromSocket sock 4096
+      return $ maybe onEmptyStream (either onInvalidResult showResponse) decodeResult
+
+    handleException :: SomeException -> IO (Either Text ())
+    handleException = return . Left . T.pack . show
+    onEmptyStream :: Either Text ()
+    onEmptyStream = Left "Empty stream"
+    onInvalidResult :: DecodingError -> Either Text ()
+    onInvalidResult = Left . T.pack . show
+    showResponse :: CommandResult -> Either Text ()
+    showResponse Success = Right ()
+    showResponse (Error message) = Left message
+
 
 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) <- reconnectClient ReconnectNoResend $ streamClient MirrorStream options
+
+  (eventOutput, eventInput) <- liftIO $ spawn unbounded
+  bar <- askBar
+
+  task <- liftIO $ async $ runEffect $ fromInput eventInput >-> blockEventConsumer
+  liftIO $ link task
+  prefix <- liftIO $ (<> "_") <$> randomIdentifier
+  addBlockCache $ newCacheIO (blockOutputProducer >-> updateBarP bar >-> attachHandlerP eventOutput prefix)
+  where
+    attachHandlerP :: Output BlockEvent -> Text -> Pipe [BlockOutput] [BlockState] IO ()
+    attachHandlerP eventOutput prefix = attachHandlerP'
+      where
+        attachHandlerP' :: Pipe [BlockOutput] [BlockState] IO ()
+        attachHandlerP' = do
+          outputs <- await
+          yield $ map (\o -> maybe (noHandler o) (attachHandler o) (_blockName o)) outputs
+          attachHandlerP'
+        noHandler :: BlockOutput -> BlockState
+        noHandler output = Just (output, Nothing)
+        attachHandler :: BlockOutput -> Text -> BlockState
+        attachHandler output blockName' = Just (output {_blockName = Just prefixedName}, Just patchedEvent)
+          where
+            patchedEvent :: BlockEventHandler
+            patchedEvent event = liftIO . atomically . void $ PC.send eventOutput $ event {name = blockName'}
+            prefixedName :: Text
+            prefixedName = prefix <> blockName'
+
+    updateBarP :: Bar -> Pipe a a IO ()
+    updateBarP bar = forever $ await >>= yield >> liftIO (updateBarDefault' bar)
+
 
 
 listenUnixSocketAsync :: MainOptions -> Bar -> CommandHandler -> IO (Async ())
@@ -209,17 +344,33 @@ listenUnixSocketAsync options bar commandHandler = async $ listenUnixSocket opti
 listenUnixSocket :: MainOptions -> Bar -> CommandHandler -> IO ()
 listenUnixSocket options@MainOptions{verbose} bar commandHandler = do
   socketPath <- ipcSocketAddress options
-  hPutStrLn stderr $ "Creating control socket at " <> socketPath
   socketExists <- doesFileExist socketPath
-  when socketExists $ removeFile socketPath
-  sock <- socket AF_UNIX Stream defaultProtocol
-  withFdSocket sock setCloseOnExecIfNeeded
-  bind sock (SockAddrUnix socketPath)
-  listen sock 5
-  forever $ do
-    (conn, _) <- accept sock
-    void $ forkFinally (socketHandler conn) (handleSocketResult conn)
+  if socketExists
+    then do
+      socketTestResult <- sendIpc' CheckServer options
+      case socketTestResult of
+        Right _ -> hPutStrLn stderr $ "Could not create control socket at " <> socketPath <> ": another server is already running"
+        Left _ -> do
+          removeFile socketPath
+          listenUnixSocket' socketPath
+    else
+      listenUnixSocket' socketPath
   where
+    listenUnixSocket' :: FilePath -> IO b
+    listenUnixSocket' socketPath = do
+      hPutStrLn stderr $ "Creating control socket at " <> socketPath
+      sock <- socket AF_UNIX Stream defaultProtocol
+#if MIN_VERSION_network(3,0,0)
+      withFdSocket sock setCloseOnExecIfNeeded
+#else
+      setCloseOnExecIfNeeded $ fdSocket sock
+#endif
+      bind sock (SockAddrUnix socketPath)
+      listen sock 5
+      forever $ do
+        (conn, _) <- accept sock
+        void $ forkFinally (socketHandler conn) (handleSocketResult conn)
+
     handleSocketResult :: Socket -> Either SomeException () -> IO ()
     handleSocketResult conn (Left err) = do
       when verbose $ hPutStrLn stderr $ "Ipc connection closed with error " <> show err
@@ -246,7 +397,6 @@ listenUnixSocket options@MainOptions{verbose} bar commandHandler = do
 
     handleRequest :: Producer ByteString IO () -> Consumer ByteString IO () -> Request -> BarIO ()
     handleRequest _leftovers responseConsumer (Command command) = liftIO $ runEffect (handleCommand command >-> responseConsumer)
-    --handleRequest leftovers responseConsumer StartBlockStream = blockStreamHandler options leftovers responseConsumer
     handleRequest leftovers responseConsumer (StartStream streamType) = mapStreamType streamType $ \s -> handleByteStream s options leftovers responseConsumer
 
     handleCommand :: Command -> Producer ByteString IO ()
@@ -257,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 #-}
-
-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 Control.Concurrent.Event as Event
+import Control.Concurrent.Event qualified as Event
 import Control.Concurrent.MVar
-import Control.Concurrent.STM.TChan (TChan, writeTChan)
+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.Either (isRight)
+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.Core
 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,
@@ -35,27 +73,23 @@ data MainOptions = MainOptions {
 data BlockEvent = Click {
   name :: T.Text,
   button :: Int
-} deriving 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 | PullUpdate | UserUpdate
+data BlockUpdateReason = DefaultUpdate | PollUpdate | EventUpdate
 type BlockUpdate = (BlockState, BlockUpdateReason)
 
 -- |Block that 'yield's an update whenever the block should be changed
 type Block' = Producer BlockUpdate BarIO
 type Block = Producer BlockUpdate BarIO ExitBlock
 
--- |Block that 'respond's with an update whenever it receives a 'PullSignal'.
-type PullBlock' = Server PullSignal BlockUpdate BarIO
-type PullBlock = Server PullSignal BlockUpdate BarIO ExitBlock
-data PullSignal = PullSignal
-
 -- |Cache that holds multiple BlockStates. When iterated it always immediately 'yield's the latest update, so it should only be pulled when a bar update has been requested.
 type BlockCache = Producer [BlockState] BarIO ExitBlock
 
@@ -64,17 +98,11 @@ class IsCachable a where
 
 instance IsCachable Block where
   toCachedBlock = cacheBlock
-instance IsCachable PullBlock where
-  toCachedBlock = cacheBlock . pullBlock
 instance IsCachable BlockCache where
   toCachedBlock = id
 
-class IsBlock a where
-  exitBlock :: a
-instance IsBlock Block where
-  exitBlock = return ExitBlock
-instance IsBlock PullBlock where
-  exitBlock = return ExitBlock
+exitBlock :: Functor m => Proxy a' a b' b m ExitBlock
+exitBlock = return ExitBlock
 
 exitCache :: BlockCache
 exitCache = return ExitBlock
@@ -85,7 +113,8 @@ type BarIO = SafeT (ReaderT Bar IO)
 data Bar = Bar {
   requestBarUpdate :: BlockUpdateReason -> IO (),
   newBlockChan :: TChan BlockCache,
-  barSleepScheduler :: SleepScheduler
+  barSleepScheduler :: SleepScheduler,
+  attachBarOutputInternal :: (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
 }
 instance HasSleepScheduler BarIO where
   askSleepScheduler = barSleepScheduler <$> askBar
@@ -114,27 +143,15 @@ askBar :: MonadBarIO m => m Bar
 askBar = liftBarIO $ lift ask
 
 
-sendBlockUpdate :: BlockOutput -> Proxy a' a PullSignal BlockUpdate BarIO ()
-sendBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), PullUpdate)
+pushBlockUpdate :: BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate blockOutput = yield (Just (blockOutput, Nothing), DefaultUpdate)
 
-sendBlockUpdate' :: BlockEventHandler -> BlockOutput -> Proxy a' a PullSignal BlockUpdate BarIO ()
-sendBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), PullUpdate)
+pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate' blockEventHandler blockOutput = yield (Just (blockOutput, Just blockEventHandler), DefaultUpdate)
 
 -- |Update a block by removing the current output
-sendEmptyBlockUpdate :: Proxy a' a PullSignal BlockUpdate BarIO ()
-sendEmptyBlockUpdate = void . respond $ (Nothing, PullUpdate)
-
-
-pushBlockUpdate :: BlockOutput -> Proxy a' a () BlockUpdate BarIO ()
-pushBlockUpdate blockOutput = void . respond $ (Just (blockOutput, Nothing), DefaultUpdate)
-
-pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Proxy a' a () BlockUpdate BarIO ()
-pushBlockUpdate' blockEventHandler blockOutput = void . respond $ (Just (blockOutput, Just blockEventHandler), DefaultUpdate)
-
--- |Update a block by removing the current output
-pushEmptyBlockUpdate :: Proxy a' a () BlockUpdate BarIO ()
-pushEmptyBlockUpdate = void . respond $ (Nothing, DefaultUpdate)
-
+pushEmptyBlockUpdate :: Producer' BlockUpdate BarIO ()
+pushEmptyBlockUpdate = yield (Nothing, DefaultUpdate)
 
 
 mkBlockState :: BlockOutput -> BlockState
@@ -152,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
@@ -162,43 +179,6 @@ runBarIO bar action = liftIO $ runReaderT (runSafeT action) bar
 defaultInterval :: Interval
 defaultInterval = everyNSeconds 10
 
--- |Converts a 'PullBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
-pullBlock :: PullBlock -> Block
-pullBlock = pullBlock' defaultInterval
-
--- |Converts a 'PullBlock' to a 'Block' by running it whenever the 'defaultInterval' is triggered.
-pullBlock' :: Interval -> PullBlock -> Block
-pullBlock' interval pb = pb >>~ addPullSignal >-> sleepToNextInterval
-  where
-    addPullSignal :: BlockUpdate -> Proxy PullSignal BlockUpdate () BlockUpdate BarIO ExitBlock
-    addPullSignal = respond >=> const (request PullSignal) >=> addPullSignal
-
-    sleepToNextInterval :: Pipe BlockUpdate BlockUpdate BarIO ExitBlock
-    sleepToNextInterval = do
-      event <- liftIO Event.new
-      forever $ do
-        (state, reason) <- await
-        if hasEventHandler state
-          then do
-            -- If state already has an event handler, we do not attach another one
-            yield (state, reason)
-            sleepUntilInterval interval
-          else do
-            -- Attach a click handler that will trigger a block update
-            yield (updateEventHandler (triggerOnClick event) state, reason)
-
-            scheduler <- askSleepScheduler
-            result <- liftIO $ do
-              timerTask <- async $ sleepUntilInterval' scheduler defaultInterval
-              eventTask <- async $ Event.wait event
-              waitEitherCancel timerTask eventTask
-
-            when (isRight result) $ do
-              liftIO $ Event.clear event
-              yield (invalidateBlockState state, UserUpdate)
-
-    triggerOnClick :: Event -> BlockEvent -> BarIO ()
-    triggerOnClick event _ = liftIO $ Event.set event
 
 -- |Creates a new cache from a producer that automatically seals itself when the producer terminates.
 newCache :: Producer [BlockState] BarIO () -> BlockCache
@@ -215,6 +195,20 @@ newCache input = newCacheInternal =<< newCache''
           runEffect (input >-> forever (await >>= liftIO . update))
           liftIO seal
 
+-- |Creates a new cache from a producer (over the IO monad) that automatically seals itself when the producer terminates.
+newCacheIO :: Producer [BlockState] IO () -> BlockCache
+newCacheIO input = newCacheInternal =<< newCache''
+  where
+    newCacheInternal :: (BlockCache, [BlockState] -> IO Bool, IO ()) -> BlockCache
+    newCacheInternal (cache, update, seal) = do
+      liftIO $ link =<< async updateTask
+      cache
+      where
+        updateTask :: IO ()
+        updateTask = do
+          runEffect (input >-> forever (await >>= liftIO . update))
+          liftIO seal
+
 -- |Create a new cache. The result is a tuple of the cache, a consumer that can be used to update the cache and an action that seals the cache.
 newCache' :: (MonadIO m, MonadIO m2, MonadIO m3) => m (BlockCache, Consumer [BlockState] m2 (), m3 ())
 newCache' = do
@@ -254,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
@@ -262,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
@@ -282,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)

qbar/src/QBar/DefaultConfig.hs

+module QBar.DefaultConfig (
+  defaultBarConfig
+) where
+
+import QBar.Blocks
+import QBar.Core
+import QBar.Prelude
+
+defaultBarConfig :: BarIO ()
+defaultBarConfig = do
+  -- TODO: commented-out blocks should be added as soon as they are implemented in qbar
+  addBlock dateBlock
+  addBlock batteryBlock
+  --addBlock volumeBlock
+  addBlock $ cpuUsageBlock 1
+  --addBlock ramUsageBlock
+  --addBlock freeDiskSpaceBlock
+  --addBlock cpuTemperatureBlock
+  addBlock networkManagerBlock

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)
-import qualified Control.Concurrent.Event as Event
-import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, swapMVar)
-import Control.Concurrent.STM.TChan (TChan, newTChanIO, tryReadTChan)
-import Control.Exception (SomeException, catch)
+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.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)
 
-
 data HostHandle = HostHandle {
   barUpdateEvent :: BarUpdateEvent,
   barUpdatedEvent :: Event.Event,
@@ -113,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)
 
 
@@ -138,12 +148,12 @@ filterDuplicates = do
 
 followupEventWaitTime :: BlockUpdateReason -> Int
 followupEventWaitTime DefaultUpdate = 10000
-followupEventWaitTime PullUpdate = 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 PollUpdate = 50000
+-- '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 PullUpdate
+followupEventWaitTimeDefault = followupEventWaitTime PollUpdate
 
 requestBarUpdateHandler :: HostHandle -> BlockUpdateReason -> IO ()
 requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeMVar} blockUpdateReason = do
@@ -152,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
@@ -161,8 +171,18 @@ requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEven
     signalHost _ = Event.set barUpdateEvent
 
 
+attachBarOutput :: (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO ()
+attachBarOutput (blockOutputConsumer, blockEventProducer) = do
+  Bar{attachBarOutputInternal} <- askBar
+  liftIO $ attachBarOutputInternal (blockOutputConsumer, blockEventProducer)
+
+
 runBarHost :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO () -> IO ()
-runBarHost createHost loadBlocks = do
+runBarHost createHost loadBlocks = runBarHost' $ loadBlocks >> createHost >>= attachBarOutput
+
+
+runBarHost' :: BarIO () -> IO ()
+runBarHost' initializeBarAction = do
   -- Create an event used request bar updates
   barUpdateEvent <- Event.newSet
   -- Create an event that is signaled after bar updates
@@ -177,6 +197,8 @@ runBarHost createHost loadBlocks = do
   -- Create IORef for event handlers
   eventHandlerListIORef <- newIORef []
 
+  exitCodeMVar <- newEmptyMVar
+
   let hostHandle = HostHandle {
     barUpdateEvent,
     barUpdatedEvent,
@@ -185,20 +207,55 @@ runBarHost createHost loadBlocks = do
     eventHandlerListIORef
   }
 
+  (eventOutput, eventInput) <- spawn unbounded
+
+  -- Create cache for block outputs
+  (cacheConsumer, cacheProducer) <- mkBroadcastCacheP []
+
+  -- Important: both monads (output producer / event consumer) will be forked whenever a new output connects!
+  let attachBarOutputInternal = attachBarOutputImpl exitCodeMVar cacheProducer (toOutput eventOutput)
+
+
   let requestBarUpdate = requestBarUpdateHandler hostHandle
 
-  let bar = Bar {requestBarUpdate, newBlockChan, barSleepScheduler}
+  let bar = Bar {requestBarUpdate, newBlockChan, barSleepScheduler, attachBarOutputInternal}
 
   -- Install signal handler for SIGCONT
   installSignalHandlers bar
 
-  runBarIO bar loadBlocks
+  -- Load blocks and initialize output handlers
+  runBarIO bar initializeBarAction
+
+  -- Run blocks and send filtered output to connected clients
+  blockTask <- async $ runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> cacheConsumer
+  -- Dispatch incoming events to blocks
+  eventTask <- async $ runEffect $ fromInput eventInput >-> eventDispatcher bar eventHandlerListIORef
 
-  (host, barEventProducer) <- runBarIO bar createHost
+  exitTask <- async $ takeMVar exitCodeMVar >>= exitWith
 
-  let handleStdin = liftIO $ runEffect $ barEventProducer >-> eventDispatcher bar eventHandlerListIORef
-  -- Fork stdin handler
-  void $ forkFinally (runBarIO bar handleStdin) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
 
-  -- Run bar host
-  runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> host
+  void $ waitAny [blockTask, eventTask, exitTask]
+
+  where
+    attachBarOutputImpl :: MVar ExitCode -> Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
+    attachBarOutputImpl exitMVar 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
+        handleBarOutput :: IO ()
+        handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer
+      liftIO $ void $ forkFinally handleBarOutput $ handleOnExitCodeException (\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 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
 
-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,
-    undefined
-  )
-where
-
-import BasePrelude hiding
+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
@@ -83,7 +83,19 @@ traceM = Trace.traceM
 traceShowM :: (Show a, Applicative m) => a -> m ()
 traceShowM = Trace.traceShowM
 
+{-# DEPRECATED traceIO "Partitial Function." #-}
+traceIO :: Control.Monad.IO.Class.MonadIO m => String -> m ()
+traceIO = Control.Monad.IO.Class.liftIO . Trace.traceIO
+
+{-# DEPRECATED traceShowIO "Partitial Function." #-}
+traceShowIO :: (Control.Monad.IO.Class.MonadIO m, Show a) => a -> m ()
+traceShowIO = traceIO . show
+
+{-# DEPRECATED traceShowIdIO "Partitial Function." #-}
+traceShowIdIO :: (Control.Monad.IO.Class.MonadIO m, Show a) => a -> m a
+traceShowIdIO a = traceShowIO a >> return a
+
 intercalate :: Monoid a => a -> [a] -> a
 intercalate _ [] = mempty
 intercalate _ [x] = x
-intercalate inter (x:xs) = x <> inter <> intercalate inter xs
+intercalate inter (x : xs) = x <> inter <> intercalate inter xs

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)
 
 renderIndicators :: [Text]
@@ -40,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) ]
 
 
@@ -60,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'
@@ -108,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,
@@ -116,38 +127,67 @@ swayBarOutput options@MainOptions{indicator} = do
       pangoBlockName = _blockName
     }
 
+runBarServerMirror :: BarIO () -> MainOptions -> IO ()
+runBarServerMirror loadBlocks options = do
+  -- 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
+    loadBlocks
+
+
 runBarServer :: BarIO () -> MainOptions -> IO ()
-runBarServer loadBlocks options = runBarHost barServer loadBlocks
-  where
-    barServer :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
-    barServer = do
-      -- Event to render the bar (fired when block output or theme is changed)
-      renderEvent <- liftIO Event.new
+runBarServer loadBlocks options = runBarHost' $ do
+  barServer <- barServerWithSocket options
+  loadBlocks
+  attachBarOutput barServer
+
 
-      -- Mailbox to store the latest 'BlockOutput's
-      (output, input) <- liftIO $ spawn $ latest []
+barServerWithSocket :: MainOptions -> BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
+barServerWithSocket options = do
+  (blockConsumer, eventProducer, setTheme') <- themingBarServer options
+
+  bar <- askBar
+
+  -- Create control socket
+  controlSocketAsync <- liftIO $ listenUnixSocketAsync options bar (commandHandler setTheme')
+  liftIO $ link controlSocketAsync
+
+  return (blockConsumer, eventProducer)
+  where
+    commandHandler :: (Theme -> IO ()) -> Command -> IO CommandResult
+    commandHandler _ CheckServer = return Success
+    commandHandler setTheme' (SetTheme name) =
+      case findTheme name of
+        Left err -> return $ Error err
+        Right theme -> do
+          setTheme' theme
+          return Success
 
-      -- MVar that holds the current theme, linked to the input from the above mailbox
-      (themedBlockProducerMVar :: MVar (Producer [ThemedBlockOutput] IO (), Bool)) <- liftIO $ newMVar $ throw $ userError "Unexpected behavior: Default theme not set"
 
-      let setTheme' = setTheme renderEvent input themedBlockProducerMVar
+themingBarServer :: MonadIO m => MainOptions -> m (Consumer [BlockOutput] IO (), Producer BlockEvent IO (), Theme -> IO ())
+themingBarServer options = do
+  -- Event to render the bar (fired when block output or theme is changed)
+  renderEvent <- liftIO Event.new
 
-      -- Set default theme
-      liftIO $ setTheme' defaultTheme
+  -- Mailbox to store the latest 'BlockOutput's
+  (output, input) <- liftIO $ spawn $ latest []
 
-      bar <- askBar
+  -- MVar that holds the current theme, linked to the input from the above mailbox
+  (themedBlockProducerMVar :: MVar (Producer [ThemedBlockOutput] IO (), Bool)) <- liftIO $ newMVar $ throw $ userError "Unexpected behavior: Default theme not set"
 
-      -- Create control socket
-      controlSocketAsync <- liftIO $ listenUnixSocketAsync options bar (commandHandler setTheme')
-      liftIO $ link controlSocketAsync
+  let setTheme' = setTheme renderEvent input themedBlockProducerMVar
 
+  -- Set default theme
+  liftIO $ setTheme' defaultTheme
 
-      -- Run render loop
-      liftIO $ link =<< async (renderLoop renderEvent themedBlockProducerMVar)
+  -- Run render loop
+  liftIO $ link =<< async (renderLoop renderEvent themedBlockProducerMVar)
 
-      -- Return a consumer that accepts BlockOutputs from the bar host, moves them to the mailbox and signals the renderer to update the bar.
-      return (signalPipe renderEvent >-> toOutput output, swayBarInput options)
+  -- Return a consumer that accepts BlockOutputs from the bar host, moves them to the mailbox and signals the renderer to update the bar.
+  return (signalEventPipe renderEvent >-> toOutput output, swayBarInput options, setTheme')
 
+  where
     renderLoop :: Event.Event -> MVar (Producer [ThemedBlockOutput] IO (), Bool) -> IO ()
     renderLoop renderEvent themedBlockProducerMVar = runEffect $
       themeAnimator renderEvent themedBlockProducerMVar >-> filterDuplicates >-> swayBarOutput options
@@ -160,7 +200,7 @@ runBarServer loadBlocks options = runBarHost barServer loadBlocks
           (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'))
@@ -168,7 +208,6 @@ runBarServer loadBlocks options = runBarHost barServer loadBlocks
           yield themedBlocks
           liftIO $ if isAnimated''
             -- Limit to 10 FPS because swaybar rendering is surprisingly expensive
-            -- TODO: make FPS configurable
             then void $ Event.waitTimeout renderEvent 100000
             else Event.wait renderEvent
           themeAnimator'
@@ -181,11 +220,3 @@ runBarServer loadBlocks options = runBarHost barServer loadBlocks
         mkThemedBlockProducer :: Theme -> (Producer [ThemedBlockOutput] IO (), Bool)
         mkThemedBlockProducer (StaticTheme themeFn) = (fromInput blockOutputInput >-> PP.map themeFn, False)
         mkThemedBlockProducer (AnimatedTheme themePipe) = (fromInput blockOutputInput >-> themePipe, True)
-
-    commandHandler :: (Theme -> IO ()) -> Command -> IO CommandResult
-    commandHandler setTheme' (SetTheme name) =
-      case findTheme name of
-        Left err -> return $ Error err
-        Right theme -> do
-          setTheme' theme
-          return Success

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,12 +60,12 @@ 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 '>'
       content <- T.fromStrict <$> A.takeWhile1 (notInClass "<>")
-      void $ string $ "</span>"
+      void $ string "</span>"
       return $ mkStyledText color background content
       where
         colorAttributeParser :: Text -> Parser Color
@@ -65,11 +75,8 @@ tagParser = parser (False, normalImportant)
           skipSpace
           void $ char '='
           skipSpace
-          value <- (
-              char '\'' *> colorParser <* char '\''
-              <|> char '"' *> colorParser <* char '"'
-            )
-          return value
+          char '\'' *> colorParser <* char '\'' <|>
+            char '"' *> colorParser <* char '"'
 
         colorAttribute :: Parser (Maybe Color, Maybe Color)
         colorAttribute = do
@@ -83,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