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

 {-# LANGUAGE TemplateHaskell #-}
 
-module QBar.Blocks.CpuUsage where
+module QBar.Blocks.CpuUsage (
+  cpuUsageBlock,
+) where
 
-import Control.Applicative ((<|>))
-import Control.Lens
-import Control.Monad.State
-import qualified Data.Attoparsec.Text.Lazy as AT
-import qualified Data.Text.Lazy as T
+import QBar.BlockHelper
 import QBar.BlockOutput
 import QBar.Blocks.Utils
 import QBar.Core
+import QBar.Prelude
+
+import Control.Applicative ((<|>))
+import Control.Lens
+import Control.Monad.State (StateT, evalStateT, lift)
+import Data.Attoparsec.Text.Lazy qualified as AT
+import Data.Text.Lazy qualified as T
 
 {-
   For time accounting the guest fields need to be ignored according to the kernel source code
@@ -17,18 +22,16 @@ import QBar.Core
   the accounting also counts the guest time to user or nice respectively so applications
   that are not aware of the new fields do not loose time.
 -}
-data CpuStat
-  = CpuStat
-      { userTime :: Int,
-        niceTime :: Int,
-        systemTime :: Int,
-        idleTime :: Int,
-        iowaitTime :: Int,
-        irqTime :: Int,
-        softirqTime :: Int,
-        stealTime :: Int
-      }
-  deriving (Show)
+data CpuStat = CpuStat {
+  userTime :: Int,
+  niceTime :: Int,
+  systemTime :: Int,
+  idleTime :: Int,
+  iowaitTime :: Int,
+  irqTime :: Int,
+  softirqTime :: Int,
+  stealTime :: Int
+} deriving (Show)
 
 getCpuStat :: IO (Maybe CpuStat)
 getCpuStat = parseFile "/proc/stat" cpuStat
@@ -47,53 +50,48 @@ getCpuStat = parseFile "/proc/stat" cpuStat
       irqTime' <- AT.skipSpace *> AT.decimal
       softirqTime' <- AT.skipSpace *> AT.decimal
       stealTime' <- AT.skipSpace *> AT.decimal
-      return $
-        CpuStat
-          { userTime = userTime',
-            niceTime = niceTime',
-            systemTime = systemTime',
-            idleTime = idleTime',
-            iowaitTime = iowaitTime',
-            irqTime = irqTime',
-            softirqTime = softirqTime',
-            stealTime = stealTime'
-          }
+      return $ CpuStat {
+        userTime = userTime',
+        niceTime = niceTime',
+        systemTime = systemTime',
+        idleTime = idleTime',
+        iowaitTime = iowaitTime',
+        irqTime = irqTime',
+        softirqTime = softirqTime',
+        stealTime = stealTime'
+      }
 
 differenceCpuStat :: CpuStat -> CpuStat -> CpuStat
-differenceCpuStat a b =
-  CpuStat
-    { userTime = userTime a - userTime b,
-      niceTime = niceTime a - niceTime b,
-      systemTime = systemTime a - systemTime b,
-      idleTime = idleTime a - idleTime b,
-      iowaitTime = iowaitTime a - iowaitTime b,
-      irqTime = irqTime a - irqTime b,
-      softirqTime = softirqTime a - softirqTime b,
-      stealTime = stealTime a - stealTime b
-    }
+differenceCpuStat a b = CpuStat {
+    userTime = userTime a - userTime b,
+    niceTime = niceTime a - niceTime b,
+    systemTime = systemTime a - systemTime b,
+    idleTime = idleTime a - idleTime b,
+    iowaitTime = iowaitTime a - iowaitTime b,
+    irqTime = irqTime a - irqTime b,
+    softirqTime = softirqTime a - softirqTime b,
+    stealTime = stealTime a - stealTime b
+  }
 
 cpuTotalTime :: Num a => CpuStat -> a
 cpuTotalTime
-  CpuStat
-    { userTime,
-      niceTime,
-      systemTime,
-      idleTime,
-      iowaitTime,
-      irqTime,
-      softirqTime,
-      stealTime
-    } =
-    fromIntegral . sum $
-      [ userTime,
-        niceTime,
-        systemTime,
-        idleTime,
-        iowaitTime,
-        irqTime,
-        softirqTime,
-        stealTime
-      ]
+  CpuStat { userTime,
+    niceTime,
+    systemTime,
+    idleTime,
+    iowaitTime,
+    irqTime,
+    softirqTime,
+    stealTime
+  } = fromIntegral . sum $ [ userTime,
+    niceTime,
+    systemTime,
+    idleTime,
+    iowaitTime,
+    irqTime,
+    softirqTime,
+    stealTime
+  ]
 
 cpuUsage :: CpuStat -> Float
 cpuUsage stat@CpuStat {idleTime, iowaitTime} = 1 - (totalIdleTime / totalTime)
@@ -103,32 +101,29 @@ cpuUsage stat@CpuStat {idleTime, iowaitTime} = 1 - (totalIdleTime / totalTime)
     totalIdleTime :: Num a => a
     totalIdleTime = fromIntegral $ idleTime + iowaitTime
 
-data CpuBlockState
-  = CpuBlockState
-      { _lastCpuStat :: CpuStat,
-        _lastCpuUsage :: Float
-      }
-  deriving (Show)
+data CpuBlockState = CpuBlockState {
+  _lastCpuStat :: CpuStat,
+  _lastCpuUsage :: Float
+} deriving (Show)
 
 makeLenses ''CpuBlockState
 
-cpuUsageBlock :: Int -> PullBlock
-cpuUsageBlock decimalPlaces = evalStateT cpuUsageBlock' createState
+cpuUsageBlock :: Int -> Block
+cpuUsageBlock decimalPlaces = runPollBlock $ evalStateT cpuUsageBlock' createState
   where
-    cpuUsageBlock' :: StateT CpuBlockState Block PullMode
-    cpuUsageBlock' = do
+    cpuUsageBlock' :: StateT CpuBlockState PollBlock' ExitBlock
+    cpuUsageBlock' = forever $ do
       updateState
       importance <- cpuUsageImportance
-      updateBlock . mkBlockOutput . importantText importance =<< cpuUsageText
-      cpuUsageBlock'
+      text <- ("💻\xFE0E " <>) <$> cpuUsageText
+      lift $ yieldBlockUpdate $ mkBlockOutput $ importantText importance text
     createState :: CpuBlockState
-    createState =
-      CpuBlockState
-        { _lastCpuStat = CpuStat 0 0 0 0 0 0 0 0,
-          _lastCpuUsage = 0
-        }
+    createState = CpuBlockState {
+      _lastCpuStat = CpuStat 0 0 0 0 0 0 0 0,
+      _lastCpuUsage = 0
+    }
     cpuUsageImportance :: Monad m => StateT CpuBlockState m Importance
-    cpuUsageImportance = toImportance (100, 90, 80, 60, 50, 0) <$> use lastCpuUsage
+    cpuUsageImportance = toImportance (0, 60, 80, 90, 100) <$> use lastCpuUsage
     cpuUsageTextWidth :: Num a => a
     cpuUsageTextWidth
       | decimalPlaces == 0 = 3

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 Pipes
-import Control.Lens
+import Data.Text.Lazy qualified as T
 
 
-dateBlock :: PushBlock
-dateBlock = do
-  updateBlock =<< liftIO dateBlockOutput
-  liftIO $ sleepUntil =<< nextMinute
-  dateBlock
-
-
-dateBlockOutput :: IO BlockOutput
-dateBlockOutput = do
-  zonedTime <- getZonedTime
+dateBlock :: Block
+dateBlock = runPollBlock' (everyNSeconds 60) $ forever $ do
+  zonedTime <- liftIO getZonedTime
+  let logo :: Text = "📅\xFE0E "
   let date = T.pack (formatTime defaultTimeLocale "%a %F" zonedTime)
   let time = T.pack (formatTime defaultTimeLocale "%R" zonedTime)
-  let text = normalText ("📅\xFE0E " <> date <> " ") <> activeText time
-  return $ blockName ?~ "date" $ 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"

qbar/src/QBar/Blocks/Pipe.hs

+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 Data.ByteString.Lazy.Char8 qualified as BSC
+import Data.Text.Lazy qualified as T
+import Pipes
+import Pipes.Concurrent
+import Pipes.Prelude qualified as PP
+import System.IO
+
+runPipeClient :: Bool -> MainOptions -> IO ()
+runPipeClient enableEvents mainOptions = do
+  (output, input) <- spawn unbounded
+  hostTask <- async $ sendBlockStream (addBlock $ pipeBlock $ fromInput input) mainOptions
+  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.
+    pipeBlock :: Producer String BarIO () -> Block
+    pipeBlock source = ExitBlock <$ source >-> pack
+      where
+        pack :: Pipe String BlockUpdate BarIO ()
+        pack = forever $ do
+          value <- await
+          let output = parseTags' . T.pack $ value
+          if enableEvents
+            then pushBlockUpdate' handler output
+            else pushBlockUpdate output
+
+        handler :: BlockEventHandler
+        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

qbar/src/QBar/Cli.hs

+{-# LANGUAGE TemplateHaskell #-}
+
+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 Data.Maybe (fromMaybe)
+import Data.Text.Lazy qualified as T
+import Development.GitRev
+import Options.Applicative
+
+-- |Entry point.
+runQBar :: IO ()
+runQBar = join parseMain
+
+parseMain :: IO (IO ())
+parseMain = customExecParser parserPrefs parser
+  where
+    parser :: ParserInfo (IO ())
+    parser = info (mainParser <**> helper)
+      (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
+
+    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 "qubes" (info qubesCommandParser (progDesc "Display information about Qubes."))
+  )
+
+serverCommandParser :: Parser (MainOptions -> IO ())
+serverCommandParser = hsubparser (
+    command "swaybar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server. Should be called by swaybar.")) <>
+    command "i3bar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server. Should be called by i3bar.")) <>
+    command "send" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server.")) <>
+    command "send-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))
+
+pipeClientParser :: Parser (MainOptions -> IO ())
+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
+
+blockParser :: Parser (BarIO ())
+blockParser =
+  subparser (
+    commandGroup "Available presets:" <>
+    metavar "CONFIG..." <>
+    command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks."))
+  )
+  <|>
+  subparser (
+    commandGroup "Available blocks:" <>
+    hidden <>
+    command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
+    command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block.")) <>
+    command "battery" (info (pure $ addBlock batteryBlock) (progDesc "Load the battery block.")) <>
+    command "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
+  poll <- switch $ long "poll" <> short 'p' <> help "Run script in poll mode (at regular intervals)"
+  -- HACK optparse-applicative does not support options of style --poll[=INTERVAL],
+  -- so we add a second option to specify the interval explicitly instead
+  -- https://github.com/pcapriotti/optparse-applicative/issues/243
+  pollInterval <- fromMaybe defaultInterval <$> optional (IntervalSeconds <$> option auto (
+    long "interval" <>
+    short 'i' <>
+    metavar "SECONDS" <>
+    help ("Interval to use for --poll mode (default: " <> humanReadableInterval defaultInterval <> ")")
+    ))
+  clickEvents <- switch $ long "events" <> short 'e' <> help "Send click events to stdin of the script"
+  script <- strArgument (metavar "SCRIPT" <> help "The script that will be executed with a shell.")
+  return $ (if poll then addBlock . pollScriptBlock 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."))
+  )

qbar/src/QBar/Color.hs

+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.Colour.RGBSpace
+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 :: 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
+
+hexColorText :: Color -> Text
+hexColorText = hexColor'
+  where
+    hexColor' :: Color -> Text
+    hexColor' (ColorRGB rgb) = pangoRGB rgb
+    hexColor' (ColorRGBA rgb a) = pangoRGB rgb <> hexColorComponent a
+
+    pangoRGB :: RGB Double -> Text
+    pangoRGB (RGB r g b) =
+      let r' = hexColorComponent r
+          g' = hexColorComponent g
+          b' = hexColorComponent b
+      in "#" <> r' <> g' <> b'
+    hexColorComponent :: Double -> Text
+    hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 (truncate (val * 255) :: Int)) ""
+    paddedHexComponent :: Text -> Text
+    paddedHexComponent hex =
+      let len = 2 - T.length hex
+          padding :: Text = if len == 1 then "0" else ""
+      in padding <> hex
+
+
+colorParser :: A.Parser Color
+colorParser = do
+  void $ char '#'
+  rgb <- RGB <$> doubleFromHex2 <*> doubleFromHex2 <*> doubleFromHex2
+  option (ColorRGB rgb) (ColorRGBA rgb <$> doubleFromHex2)
+  where
+    doubleFromHex2 :: A.Parser Double
+    doubleFromHex2 = (/ 256) . fromIntegral <$> hexadecimal'' 2
+
+    -- 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 :: 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.Cli (MainOptions(..))
 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.Monad (forever, void, when)
 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 Data.ByteString (ByteString)
-import qualified Data.ByteString.Char8 as BSC
-import System.FilePath ((</>))
-import System.IO
-import Data.Either (either)
-import Data.Maybe (maybe)
-import Data.Text.Lazy (Text, pack)
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
+import Data.ByteString qualified as BS
+import Data.ByteString.Char8 qualified as BSC
+import Data.Text.Lazy (pack)
+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
 
@@ -49,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)
+    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
@@ -70,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
@@ -99,23 +144,34 @@ 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, updateC, seal) <- newCache'
+    (cache, updateCacheC, sealCache) <- newCache'
     (eventOutput, eventInput, eventSeal) <- liftIO $ spawn' unbounded
     bar <- askBar
-    addBlock cache
+    addBlockCache cache
     prefix <- liftIO $ (<> "_") <$> randomIdentifier
-    return (updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateC, fromInput eventInput, seal >> atomically eventSeal)
+    let blockConsumer = updateBarP bar >-> attachHandlerP eventOutput prefix >-> updateCacheC
+    let eventProducer = fromInput eventInput
+    let seal = sealCache >> atomically eventSeal >> updateBarDefault' bar
+    return (blockConsumer, eventProducer, seal)
     where
       attachHandlerP :: Output BlockEvent -> Text -> Pipe [BlockOutput] [BlockState] IO ()
       attachHandlerP eventOutput prefix = attachHandlerP'
@@ -136,20 +192,34 @@ instance IsStream BlockStream where
               prefixedName = prefix <> blockName'
 
       updateBarP :: Bar -> Pipe a a IO ()
-      updateBarP bar = do
-        v <- await
-        yield v
-        liftIO $ updateBar' bar
-        updateBarP bar
+      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 TL.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
@@ -158,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)
@@ -183,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
+  result <- sendIpc' command options
+  case result of
+    Left err -> T.hPutStrLn stderr err
+    Right () -> when verbose $ hPutStrLn stderr "Success"
 
-sendIpc :: MainOptions -> Command -> IO ()
-sendIpc options@MainOptions{verbose} command = do
-  let request = Command command
-  sock <- connectIpcSocket options
-  runEffect $ encode request >-> toSocket sock
+sendIpc' :: Command -> MainOptions -> IO (Either Text ())
+sendIpc' command options = catch sendCommand handleException
+  where
+    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 blockStreamClient loadBlocks
+  where
+    blockStreamClient :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
+    blockStreamClient = reconnectClient (ReconnectSendLatest []) $ streamClient BlockStream options
 
-  decodeResult <- evalStateT decode $ fromSocket sock 4096
-  maybe exitEmptyStream (either exitInvalidResult showResponse) decodeResult
+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
-    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
+    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)
 
-sendBlockStream :: MainOptions -> BarIO () -> IO ()
-sendBlockStream = runBarHost . streamClient BlockStream
 
 
 listenUnixSocketAsync :: MainOptions -> Bar -> CommandHandler -> IO (Async ())
@@ -216,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
-  setCloseOnExecIfNeeded $ fdSocket sock
-  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
@@ -253,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 ()
@@ -264,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

qbar/src/QBar/Core.hs

+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.Utils
+
+import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.MVar
+import Control.Concurrent.STM.TChan
+import Control.Lens
+import Control.Monad.Reader (ReaderT, runReaderT, ask)
+import Control.Monad.State (StateT)
+import Control.Monad.Writer (WriterT)
+import Data.Aeson
+import Data.Int (Int64)
+import Data.Maybe (fromMaybe)
+import Data.Text.Lazy qualified as T
+import GHC.Generics
+import Pipes
+import Pipes.Concurrent
+import Pipes.Prelude qualified as PP
+import Pipes.Safe (SafeT, runSafeT)
+
+data MainOptions = MainOptions {
+  verbose :: Bool,
+  indicator :: Bool,
+  socketLocation :: Maybe T.Text
+}
+
+data BlockEvent = Click {
+  name :: T.Text,
+  button :: Int
+} deriving (Eq, Show, Generic)
+
+instance FromJSON BlockEvent
+instance ToJSON BlockEvent
+
+data ExitBlock = ExitBlock
+
+type BlockEventHandler = BlockEvent -> BarIO ()
+
+type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler)
+data BlockUpdateReason = DefaultUpdate | PollUpdate | 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
+
+-- |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
+
+class IsCachable a where
+  toCachedBlock :: a -> BlockCache
+
+instance IsCachable Block where
+  toCachedBlock = cacheBlock
+instance IsCachable BlockCache where
+  toCachedBlock = id
+
+exitBlock :: Functor m => Proxy a' a b' b m ExitBlock
+exitBlock = return ExitBlock
+
+exitCache :: BlockCache
+exitCache = return ExitBlock
+
+
+type BarIO = SafeT (ReaderT Bar IO)
+
+data Bar = Bar {
+  requestBarUpdate :: BlockUpdateReason -> IO (),
+  newBlockChan :: TChan BlockCache,
+  barSleepScheduler :: SleepScheduler,
+  attachBarOutputInternal :: (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO ()
+}
+instance HasSleepScheduler BarIO where
+  askSleepScheduler = barSleepScheduler <$> askBar
+instance HasSleepScheduler (Proxy a' a b' b BarIO) where
+  askSleepScheduler = lift askSleepScheduler
+
+
+newtype BarUpdateChannel = BarUpdateChannel (IO ())
+type BarUpdateEvent = Event.Event
+
+
+class (MonadIO m) => MonadBarIO m where
+  liftBarIO :: BarIO a -> m a
+instance MonadBarIO BarIO where
+  liftBarIO = id
+instance (MonadBarIO m) => MonadBarIO (Proxy a' a b' b m) where
+  liftBarIO = lift . liftBarIO
+instance (MonadBarIO m) => MonadBarIO (StateT a m) where
+  liftBarIO = lift . liftBarIO
+instance (MonadBarIO m) => MonadBarIO (ReaderT a m) where
+  liftBarIO = lift . liftBarIO
+instance (MonadBarIO m, Monoid a) => MonadBarIO (WriterT a m) where
+  liftBarIO = lift . liftBarIO
+
+askBar :: MonadBarIO m => m Bar
+askBar = liftBarIO $ lift ask
+
+
+pushBlockUpdate :: BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate blockOutput = yield (Just (blockOutput, Nothing), DefaultUpdate)
+
+pushBlockUpdate' :: BlockEventHandler -> BlockOutput -> Producer' BlockUpdate BarIO ()
+pushBlockUpdate' blockEventHandler blockOutput = yield (Just (blockOutput, Just blockEventHandler), DefaultUpdate)
+
+-- |Update a block by removing the current output
+pushEmptyBlockUpdate :: Producer' BlockUpdate BarIO ()
+pushEmptyBlockUpdate = yield (Nothing, DefaultUpdate)
+
+
+mkBlockState :: BlockOutput -> BlockState
+mkBlockState blockOutput = Just (blockOutput, Nothing)
+
+mkBlockState' :: Text -> BlockEventHandler -> BlockOutput -> BlockState
+mkBlockState' newBlockName blockEventHandler blockOutput = Just (blockOutput {_blockName = Just newBlockName}, Just blockEventHandler)
+
+updateEventHandler :: BlockEventHandler -> BlockState -> BlockState
+updateEventHandler _ Nothing = Nothing
+updateEventHandler eventHandler (Just (blockOutput, _)) = Just (blockOutput, Just eventHandler)
+
+hasEventHandler :: BlockState -> Bool
+hasEventHandler (Just (_, Just _)) = True
+hasEventHandler _ = False
+
+invalidateBlockState :: BlockState -> BlockState
+invalidateBlockState = ((_Just . _2) .~ Nothing) . ((_Just . _1) %~ invalidateBlock)
+
+
+runBarIO :: MonadIO m => Bar -> BarIO r -> m r
+runBarIO bar action = liftIO $ runReaderT (runSafeT action) bar
+
+
+defaultInterval :: Interval
+defaultInterval = everyNSeconds 10
+
+
+-- |Creates a new cache from a producer that automatically seals itself when the producer terminates.
+newCache :: Producer [BlockState] BarIO () -> BlockCache
+newCache input = newCacheInternal =<< newCache''
+  where
+    newCacheInternal :: (BlockCache, [BlockState] -> IO Bool, IO ()) -> BlockCache
+    newCacheInternal (cache, update, seal) = do
+      task <- barAsync updateTask
+      liftIO $ link task
+      cache
+      where
+        updateTask :: BarIO ()
+        updateTask = do
+          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
+  (cache, update, seal) <- newCache''
+  return (cache, cacheUpdateConsumer update, seal)
+  where
+    cacheUpdateConsumer :: MonadIO m2 => ([BlockState] -> IO Bool) -> Consumer [BlockState] m2 ()
+    cacheUpdateConsumer update = do
+      v <- await
+      result <- liftIO $ update v
+      when result $ cacheUpdateConsumer update
+
+-- |Low-level function to create a new cache. The result is a tuple of the cache, an action can be used to update the cache (it returns 'False'
+-- |if the cache is sealed) and an action that seals the cache.
+newCache'' :: (MonadIO m, MonadIO m2, MonadIO m3) => m (BlockCache, [BlockState] -> m2 Bool, m3 ())
+newCache'' = do
+  store <- liftIO $ newMVar (Just [])
+  newCacheInternal store
+  where
+    newCacheInternal :: (MonadIO m, MonadIO m2, MonadIO m3) => MVar (Maybe [BlockState]) -> m (BlockCache, [BlockState] -> m2 Bool, m3 ())
+    newCacheInternal store = return (cache, update, seal)
+      where
+        update :: MonadIO m => [BlockState] -> m Bool
+        update value = liftIO $ modifyMVar store $ \old ->
+          return $ case old of
+            Nothing -> (Nothing, False)
+            Just _ -> (Just value, True)
+        seal :: MonadIO m => m ()
+        seal = liftIO . void . swapMVar store $ Nothing
+        cache :: BlockCache
+        cache = do
+          v <- liftIO (readMVar store)
+          case v of
+            Nothing -> exitCache
+            Just value -> yield value >> cache
+
+-- |Creates a cache from a block.
+cacheBlock :: Block -> BlockCache
+-- 'Block's 'yield' an update whenever they want to update the cache.
+cacheBlock pushBlock = newCache $ void $ pushBlock >-> updateBarP >-> addBlockName >-> PP.map (: [])
+  where
+    updateBarP :: Pipe BlockUpdate BlockState BarIO r
+    updateBarP = forever $ do
+      (state, reason) <- await
+      yield state
+      updateBar reason
+
+    -- 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
+      forever $ do
+        state <- await
+        yield $ (_Just . _1 . blockName) %~ (Just . fromMaybe defaultBlockName) $ state
+
+
+modify :: (BlockOutput -> BlockOutput) -> Pipe BlockUpdate BlockUpdate BarIO r
+modify x = PP.map (over (_1 . _Just . _1) x)
+
+autoPadding :: Pipe BlockUpdate BlockUpdate BarIO r
+autoPadding = autoPadding' 0 0
+  where
+    autoPadding' :: Int64 -> Int64 -> Pipe BlockUpdate BlockUpdate BarIO r
+    autoPadding' fullLength shortLength = do
+      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)
+          autoPadding' fullLength' shortLength'
+        (Nothing, reason) -> do
+          yield (Nothing, reason)
+          autoPadding' 0 0
+    padString :: Int64 -> BlockText
+    padString len = normalText . T.take len . T.repeat $ ' '
+    padFullText :: Int64 -> BlockOutput -> BlockOutput
+    padFullText len = over fullText $ \s -> padString (len - printedLength s) <> s
+    padShortText :: Int64 -> BlockOutput -> BlockOutput
+    padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s
+
+addBlock :: Block -> BarIO ()
+addBlock block = do
+  newBlockChan' <- newBlockChan <$> askBar
+  liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block
+
+addBlockCache :: BlockCache -> BarIO ()
+addBlockCache cache = do
+  newBlockChan' <- newBlockChan <$> askBar
+  liftIO $ atomically $ writeTChan newBlockChan' cache
+
+updateBar :: MonadBarIO m => BlockUpdateReason -> m ()
+updateBar reason = liftIO =<< requestBarUpdate <$> askBar <*> return reason
+
+updateBar' :: MonadIO m => Bar -> BlockUpdateReason -> m ()
+updateBar' bar reason = runBarIO bar $ updateBar reason
+
+updateBarDefault :: MonadBarIO m => m ()
+updateBarDefault = updateBar DefaultUpdate
+
+updateBarDefault' :: MonadIO m => Bar -> m ()
+updateBarDefault' bar = updateBar' bar DefaultUpdate
+
+barAsync :: MonadBarIO m => BarIO a -> m (Async a)
+barAsync action = do
+  bar <- askBar
+  liftIO $ async $ runBarIO bar action

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.Event as Event
-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 (when)
 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
+import System.Posix.Signals (Handler(..), sigCONT, installHandler)
 
 data HostHandle = HostHandle {
   barUpdateEvent :: BarUpdateEvent,
+  barUpdatedEvent :: Event.Event,
+  followupEventWaitTimeMVar :: MVar Int,
   newBlockChan :: TChan BlockCache,
   eventHandlerListIORef :: IORef [(T.Text, BlockEventHandler)]
 }
@@ -32,7 +47,8 @@ installSignalHandlers bar = void $ installHandler sigCONT (Catch sigContAction)
     sigContAction :: IO ()
     sigContAction = do
       hPutStrLn stderr "SIGCONT received"
-      updateBar' bar
+      updateBarDefault' bar
+
 
 eventDispatcher :: Bar -> IORef [(T.Text, BlockEventHandler)] -> Consumer BlockEvent IO ()
 eventDispatcher bar eventHandlerListIORef = eventDispatcher'
@@ -51,19 +67,21 @@ eventDispatcher bar eventHandlerListIORef = eventDispatcher'
 
 
 runBlocks :: Bar -> HostHandle -> Producer [BlockOutput] IO ()
-runBlocks bar HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} = runBlocks' []
+runBlocks bar HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeMVar, newBlockChan, eventHandlerListIORef} = runBlocks' []
   where
     runBlocks' :: [BlockCache] -> Producer [BlockOutput] IO ()
     runBlocks' blocks = do
-      liftIO $ do
         -- Wait for an update request
-        Event.wait barUpdateEvent
+      liftIO $ Event.wait barUpdateEvent
+
+      -- Get current value and reset to default value
+      followupEventWaitTime' <- liftIO $ swapMVar followupEventWaitTimeMVar followupEventWaitTimeDefault
 
-        -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
-        threadDelay 10000
-        Event.clear barUpdateEvent
+      -- Wait for a moment (determined by block update reason) after the first event to catch (almost-)simultaneous block updates
+      when (followupEventWaitTime' > 0) $ liftIO $ threadDelay followupEventWaitTime'
+      liftIO $ Event.clear barUpdateEvent
 
-      blocks' <- lift $ runBarIO bar $ addNewBlocks blocks
+      blocks' <- runBarIO bar $ addNewBlocks blocks
 
       (blockStates, blocks'') <- lift $ runBarIO bar $ getBlockStates blocks'
 
@@ -73,8 +91,10 @@ runBlocks bar HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} =
       -- Register new event handlers immediately after rendering
       liftIO $ updateEventHandlers blockStates
 
-      -- Wait for 90ms after rendering a line to limit cpu load of rapid events
-      liftIO $ threadDelay 90000
+      liftIO $ Event.signal barUpdatedEvent
+
+      -- Wait for 20ms after rendering a line to limit cpu load of rapid events
+      liftIO $ threadDelay 20000
 
       -- Loop
       runBlocks' blocks''
@@ -103,13 +123,13 @@ runBlocks bar HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} =
       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)
 
 
@@ -126,36 +146,116 @@ filterDuplicates = do
       filterDuplicates' value
 
 
+followupEventWaitTime :: BlockUpdateReason -> Int
+followupEventWaitTime DefaultUpdate = 10000
+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 PollUpdate
+
+requestBarUpdateHandler :: HostHandle -> BlockUpdateReason -> IO ()
+requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEventWaitTimeMVar} blockUpdateReason = do
+  -- Configure followup event wait time
+  modifyMVar_ followupEventWaitTimeMVar $ \current -> return $ min current $ followupEventWaitTime blockUpdateReason
+  signalHost blockUpdateReason
+  where
+    signalHost :: BlockUpdateReason -> IO ()
+    signalHost EventUpdate = do
+      -- Start waiting before triggering the event cannot be missed
+      task <- async $ Event.wait barUpdatedEvent
+      Event.set barUpdateEvent
+      -- Wait until the bar is updated. This happens almost immediately, but this ensures the block won't immediately override user feedback.
+      wait task
+    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
-  -- Create an event used to signal bar updates
+runBarHost createHost loadBlocks = runBarHost' $ loadBlocks >> createHost >>= attachBarOutput
+
+
+runBarHost' :: BarIO () -> IO ()
+runBarHost' initializeBarAction = do
+  -- Create an event used request bar updates
   barUpdateEvent <- Event.newSet
-  let requestBarUpdate = Event.set barUpdateEvent
+  -- Create an event that is signaled after bar updates
+  barUpdatedEvent <- Event.new
+  followupEventWaitTimeMVar <- newMVar 0
 
   -- Create channel to send new block producers to render loop
   newBlockChan <- newTChanIO
 
-  let bar = Bar { requestBarUpdate, newBlockChan }
-
-  -- Install signal handler for SIGCONT
-  installSignalHandlers bar
+  barSleepScheduler <- createSleepScheduler
 
   -- Create IORef for event handlers
   eventHandlerListIORef <- newIORef []
 
+  exitCodeMVar <- newEmptyMVar
+
   let hostHandle = HostHandle {
     barUpdateEvent,
+    barUpdatedEvent,
+    followupEventWaitTimeMVar,
     newBlockChan,
     eventHandlerListIORef
   }
 
-  runBarIO bar loadBlocks
+  (eventOutput, eventInput) <- spawn unbounded
 
-  (host, barEventProducer) <- runBarIO bar createHost
+  -- Create cache for block outputs
+  (cacheConsumer, cacheProducer) <- mkBroadcastCacheP []
 
-  let handleStdin = liftIO $ runEffect $ barEventProducer >-> eventDispatcher bar eventHandlerListIORef
-  -- Fork stdin handler
-  void $ forkFinally (runBarIO bar handleStdin) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
+  -- Important: both monads (output producer / event consumer) will be forked whenever a new output connects!
+  let attachBarOutputInternal = attachBarOutputImpl exitCodeMVar cacheProducer (toOutput eventOutput)
 
-  -- Run bar host
-  runEffect $ runBlocks bar hostHandle >-> filterDuplicates >-> host
+
+  let requestBarUpdate = requestBarUpdateHandler hostHandle
+
+  let bar = Bar {requestBarUpdate, newBlockChan, barSleepScheduler, attachBarOutputInternal}
+
+  -- Install signal handler for SIGCONT
+  installSignalHandlers bar
+
+  -- 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
+
+  exitTask <- async $ takeMVar exitCodeMVar >>= exitWith
+
+
+  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

-module QBar.Pango (PangoText, renderPango) where
+module QBar.Pango (
+  PangoText,
+  renderPango,
+) where
 
+import QBar.Color
+import QBar.Prelude
 import QBar.Theme
 
-import Data.Colour.RGBSpace
-import qualified Data.Text.Lazy as T
-import Numeric (showHex)
-
 type PangoText = Text
 
 renderPango :: ThemedBlockText -> PangoText
@@ -20,22 +21,4 @@ coloredText Nothing foreground text = "<span color='" <> pangoColor foreground <
 coloredText (Just background) foreground text = "<span color='" <> pangoColor foreground <> "' background='" <> pangoColor background <> "'>" <> text <> "</span>"
 
 pangoColor :: Color -> Text
-pangoColor = pangoColor'
-  where
-    pangoColor' :: Color -> Text
-    pangoColor' (ColorRGB rgb) = pangoRGB rgb
-    pangoColor' (ColorRGBA rgb a) = pangoRGB rgb <> hexColorComponent a
-
-    pangoRGB :: RGB Double -> Text
-    pangoRGB (RGB r g b) =
-      let r' = hexColorComponent r
-          g' = hexColorComponent g
-          b' = hexColorComponent b
-      in "#" <> r' <> g' <> b'
-    hexColorComponent :: Double -> Text
-    hexColorComponent val = paddedHexComponent $ T.pack $ showHex (max 0 $ min 255 (truncate (val * 255) :: Int)) ""
-    paddedHexComponent :: Text -> Text
-    paddedHexComponent hex =
-      let len = 2 - T.length hex
-          padding = if len == 1 then "0" else ""
-      in padding <> hex
+pangoColor = hexColorText

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,
-    head,
-    error,
-    errorWithoutStackTrace,
-    undefined,
-    Text.Text,
-    ByteString.ByteString,
-    trace,
-    traceId,
-    traceShow,
-    traceShowId,
-    traceM,
-    traceShowM,
-    Maybe.listToMaybe,
-    intercalate
-  )
-where
-
-import BasePrelude hiding
+import Prelude hiding
   ( error,
     errorWithoutStackTrace,
     head,
     undefined,
   )
-import qualified BasePrelude as P
-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 ((>=>), (<=<))
+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
@@ -72,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.Cli
 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 (when, unless, 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]
@@ -41,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) ]
 
 
@@ -61,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'
@@ -109,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,
@@ -117,38 +127,67 @@ swayBarOutput options@MainOptions{indicator} = do
       pangoBlockName = _blockName
     }
 
-runBarServer :: MainOptions -> BarIO () -> IO ()
-runBarServer options = runBarHost barServer
-  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
+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' $ do
+  barServer <- barServerWithSocket options
+  loadBlocks
+  attachBarOutput barServer
 
-      -- Mailbox to store the latest 'BlockOutput's
-      (output, input) <- liftIO $ spawn $ latest []
 
-      -- 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"
+barServerWithSocket :: MainOptions -> BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ())
+barServerWithSocket options = do
+  (blockConsumer, eventProducer, setTheme') <- themingBarServer options
 
-      let setTheme' = setTheme renderEvent input themedBlockProducerMVar
+  bar <- askBar
 
-      -- Set default theme
-      liftIO $ setTheme' defaultTheme
+  -- Create control socket
+  controlSocketAsync <- liftIO $ listenUnixSocketAsync options bar (commandHandler setTheme')
+  liftIO $ link controlSocketAsync
 
-      bar <- askBar
+  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
 
-      -- Create control socket
-      controlSocketAsync <- liftIO $ listenUnixSocketAsync options bar (commandHandler setTheme')
-      liftIO $ link controlSocketAsync
 
+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
 
-      -- Run render loop
-      liftIO $ link =<< async (renderLoop renderEvent themedBlockProducerMVar)
+  -- Mailbox to store the latest 'BlockOutput's
+  (output, input) <- liftIO $ spawn $ latest []
 
-      -- 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)
+  -- 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
+
+  -- Set default theme
+  liftIO $ setTheme' defaultTheme
+
+  -- 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 (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
@@ -161,7 +200,7 @@ runBarServer options = runBarHost barServer
           (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'))
@@ -169,7 +208,6 @@ runBarServer options = runBarHost barServer
           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'
@@ -182,20 +220,3 @@ runBarServer options = runBarHost barServer
         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
-
-
--- |Entry point.
-runQBar :: BarIO () -> MainOptions -> IO ()
-runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
-  where
-    runCommand BarServerCommand = runBarServer options barConfiguration
-    runCommand ConnectSocket = sendBlockStream options barConfiguration
-    runCommand (SetThemeCommand themeName) = sendIpc options $ SetTheme themeName

qbar/src/QBar/TagParser.hs

+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 Data.Text qualified as TS
+import Data.Text.Lazy qualified as T
+
+type TagState = (Bool, Importance)
+
+tagParser :: Parser BlockText
+tagParser = parser (False, normalImportant)
+  where
+    parser :: TagState -> Parser BlockText
+    parser (active, importance) = mconcat <$> many' singleElementParser
+      where
+        singleElementParser :: Parser BlockText
+        singleElementParser = choice [textParser, activeTagParser, importanceTagParser, spanParser]
+
+        textParser :: Parser BlockText
+        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>"
+
+        importanceTagParser :: Parser BlockText
+        importanceTagParser = do
+          (tag, importance') <- char '<' *> importanceParser <* char '>'
+          result <- parser (active, importance')
+          void $ string $ "</" <> tag <> ">"
+          return result
+
+    importanceParser :: Parser (TS.Text, Importance)
+    importanceParser = choice $ map mkParser importanceTags
+      where
+        mkParser :: (TS.Text, Importance) -> Parser (TS.Text, Importance)
+        mkParser (tag, importance) = string tag $> (tag, importance)
+        importanceTags :: [(TS.Text, Importance)]
+        importanceTags = [
+            ("normal", normalImportant),
+            ("warning", warnImportant),
+            ("error", errorImportant),
+            ("critical", criticalImportant)
+          ]
+
+    spanParser :: Parser BlockText
+    spanParser = do
+      void $ string "<span"
+      (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>"
+      return $ mkStyledText color background content
+      where
+        colorAttributeParser :: Text -> Parser Color
+        colorAttributeParser attribute = do
+          space >> skipSpace
+          void $ string $ T.toStrict attribute
+          skipSpace
+          void $ char '='
+          skipSpace
+          char '\'' *> colorParser <* char '\'' <|>
+            char '"' *> colorParser <* char '"'
+
+        colorAttribute :: Parser (Maybe Color, Maybe Color)
+        colorAttribute = do
+          color <- colorAttributeParser "color"
+          pure (Just color, Nothing)
+        backgroundAttribute :: Parser (Maybe Color, Maybe Color)
+        backgroundAttribute = do
+          background <- colorAttributeParser "background"
+          pure (Nothing, Just background)
+
+
+
+parseTags :: T.Text -> Either String BlockText
+parseTags = parseOnly (tagParser <* endOfInput)
+
+parseTags' :: T.Text -> BlockOutput
+parseTags' = either (mkErrorOutput . T.pack) mkBlockOutput . parseTags
+
+parseTags'' :: T.Text -> T.Text -> BlockOutput
+parseTags'' full short = either (mkErrorOutput . T.pack) id $ do
+  full' <- parseTags $ full
+  short' <- parseTags $ short
+  return $ mkBlockOutput' full' short'