qbar/src/QBar/Time.hs

+{-# LANGUAGE OverloadedLists #-}
+
+module QBar.Time (
+  HasSleepScheduler(..),
+  Interval(..),
+  SleepScheduler,
+  createSleepScheduler,
+  everyMinute,
+  everyNSeconds,
+  humanReadableInterval,
+  nextIntervalTime,
+  sleepUntil',
+  sleepUntil,
+  sleepUntilInterval',
+  sleepUntilInterval,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.MVar
+import Data.Ord (comparing)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
+
+newtype Interval = IntervalSeconds Integer
+  deriving (Read, Show)
+
+-- |Describes an interval that is run every "n" seconds after midnight.
+everyNSeconds :: Integer -> Interval
+everyNSeconds = IntervalSeconds
+
+-- |Describes an interval that is run every minute.
+everyMinute :: Interval
+everyMinute = IntervalSeconds 60
+
+nextIntervalTime :: MonadIO m => Interval -> m UTCTime
+nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
+  now <- getCurrentTime
+  let dayTime = utctDayTime now
+  let daySeconds :: Integer = floor dayTime
+  let intervalId = daySeconds `div` intervalSeconds
+  return now {
+    utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
+  }
+
+humanReadableInterval :: Interval -> String
+humanReadableInterval (IntervalSeconds i) = show i <> "s"
+
+data SleepScheduler = SleepScheduler (MVar (SortedList ScheduledEvent, [ScheduledEvent])) Event.Event
+data ScheduledEvent = ScheduledEvent {
+  time :: UTCTime,
+  event :: Event.Event,
+  fireOnNegativeTimeJump :: Bool
+} deriving Eq
+instance Ord ScheduledEvent where
+  compare = comparing time
+
+class HasSleepScheduler m where
+  askSleepScheduler :: m SleepScheduler
+
+createSleepScheduler :: MonadIO m => m SleepScheduler
+createSleepScheduler = liftIO $ do
+  scheduler <- SleepScheduler <$> newMVar ([], []) <*> Event.new
+  link =<< async (schedulerThread scheduler)
+  return scheduler
+  where
+    schedulerThread :: SleepScheduler -> IO ()
+    schedulerThread (SleepScheduler eventsMVar trigger) = schedulerThread' =<< getCurrentTime
+      where
+        schedulerThread' :: UTCTime -> IO ()
+        schedulerThread' lastTime = do
+          start <- getCurrentTime
+
+          -- Check for a negative time step (threshold is between 5 and 65 seconds, depending on loop activity)
+          when (start < addUTCTime (fromInteger (-5)) lastTime) $ fireEvents fireOnNegativeTimeJump
+
+          (sortedEvents, _) <- readMVar eventsMVar
+          waitResult <- case fromSortedList sortedEvents of
+            [] -> True <$ Event.wait trigger
+            (ScheduledEvent{time} : _) -> waitForEvent time
+
+          when waitResult $ do
+            now <- getCurrentTime
+            fireEvents (checkEvent now)
+
+          schedulerThread' start
+
+        -- Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
+        waitForEvent :: UTCTime -> IO Bool
+        waitForEvent eventTime = do
+          now <- getCurrentTime
+          let timeUntil = diffUTCTime eventTime now
+          if
+            | timeUntil <= 0 -> return True
+            | timeUntil < 60 -> True <$ Event.waitTimeout trigger (ceiling $ toRational timeUntil * 1000000)
+            -- False indicates a timeout, in which case no events need to be fired
+            | otherwise -> Event.waitTimeout trigger (60 * 1000000)
+
+
+        fireEvents :: (ScheduledEvent -> Bool) -> IO ()
+        fireEvents predicate =
+          modifyMVar_ eventsMVar $ \(hots, colds) -> do
+            let allEvents = hots <> toSortedList colds
+            let (activeEvents, futureEvents) = partition predicate allEvents
+            mapM_ (Event.set . event) activeEvents
+            -- Sleep scheduler thread 'Event' is cleared during 'modifyMVar_' to prevent race conditions.
+            Event.clear trigger
+            return (futureEvents, [])
+
+        -- Predicate to check if an event should be fired.
+        checkEvent :: UTCTime -> ScheduledEvent -> Bool
+        checkEvent now ScheduledEvent{time} = now >= time
+
+
+queueScheduledEvent :: MonadIO m => SleepScheduler -> ScheduledEvent -> m ()
+queueScheduledEvent (SleepScheduler eventsMVar trigger) event@ScheduledEvent{time=eventTime} = liftIO $
+  modifyMVar_ eventsMVar $ \(sorted, unsorted) ->
+    -- Sleep scheduler thread 'Event' is set during 'modifyMVar_' to prevent race conditions.
+    case fromSortedList sorted of
+      [] -> (singleton event, unsorted) <$ Event.set trigger
+      (first : _) ->
+        if eventTime < time first
+          -- Event happens before the first event, so it is inserted at the front of the sorted list and the scheduler thread is notified
+          then (insert event sorted, unsorted) <$ Event.set trigger
+          -- Otherwise it is added to the unsorted pool and will be handled later.
+          else return (sorted, event:unsorted)
+
+
+-- |Suspends the thread until the given time is reached.
+sleepUntil :: (HasSleepScheduler m, MonadIO m) => UTCTime -> m ()
+sleepUntil time = do
+  scheduler <- askSleepScheduler
+  sleepUntil' scheduler time
+
+sleepUntil' :: MonadIO m => SleepScheduler -> UTCTime -> m ()
+sleepUntil' scheduler time = liftIO $ do
+  event <- Event.new
+  queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=False})
+  Event.wait event
+
+-- |Suspends the thread until the next time boundary described by 'Interval' is reached. Also returns when the system time jumps backwards.
+sleepUntilInterval :: (HasSleepScheduler m, MonadIO m) => Interval -> m ()
+sleepUntilInterval interval = do
+  scheduler <- askSleepScheduler
+  sleepUntilInterval' scheduler interval
+
+sleepUntilInterval' :: MonadIO m => SleepScheduler -> Interval -> m ()
+sleepUntilInterval' scheduler interval = liftIO $ do
+  event <- Event.new
+  time <- nextIntervalTime interval
+  queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=True})
+  Event.wait event

qbar/src/QBar/Utils.hs

+module QBar.Utils (
+  mkBroadcastCacheP,
+  mkBroadcastP,
+  randomIdentifier,
+  signalEventPipe,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Event as Event
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad (replicateM)
+import Data.Text.Lazy qualified as T
+import Pipes
+import System.Random
+
+-- Pipe that signals an 'Event' after every value that passes through
+signalEventPipe :: MonadIO m => Event.Event -> Pipe a a m r
+signalEventPipe event = forever $ (yield =<< await) >> liftIO (Event.signal event)
+
+randomIdentifier :: MonadIO m => m Text
+randomIdentifier = liftIO $ T.pack <$> replicateM 8 randomCharacter
+  where
+    randomCharacter :: IO Char
+    randomCharacter = do
+      index <- randomRIO (0, T.length alphabet - 1)
+      return $ T.index alphabet index
+    alphabet :: T.Text
+    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+mkBroadcastP :: forall a. IO (Consumer a IO (), Producer a IO ())
+mkBroadcastP = do
+  chan <- newBroadcastTChanIO
+  return (sendToStore chan, recvFromStore chan)
+  where
+    sendToStore :: TChan a -> Consumer a IO ()
+    sendToStore chan = forever $ do
+      value <- await
+      liftIO . atomically $ writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: TChan a -> Producer a IO ()
+    recvFromStore chan = do
+      outputChan <- liftIO . atomically $ dupTChan chan
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+-- |When running a new producer it will immediateley receive the latest value that was sent to a consumer.
+mkBroadcastCacheP :: forall a. a -> IO (Consumer a IO (), Producer a IO ())
+mkBroadcastCacheP initialValue = do
+  store <- (,) <$> newTVarIO initialValue <*> newBroadcastTChanIO
+  return (sendToStore store, recvFromStore store)
+  where
+    sendToStore :: (TVar a, TChan a) -> Consumer a IO ()
+    sendToStore (var, chan) = forever $ do
+      value <- await
+      liftIO . atomically $ do
+        writeTVar var value
+        writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: (TVar a, TChan a) -> Producer a IO ()
+    recvFromStore (var, chan) = do
+      (outputChan, value) <- liftIO . atomically $ do
+        value <- readTVar var
+        outputChan <- dupTChan chan
+        return (outputChan, value)
+
+      yield value
+
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)

test/Spec.hs → qbar/test/Spec.hs

+import Prelude
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"

shell.nix

-{ pkgs ? import <nixpkgs> {} }:
-
-pkgs.mkShell {
-  buildInputs = with pkgs; [
-    stack
-    zsh
-    jq
-  ];
-}

src/BasePrelude.hs

-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module BasePrelude
-  ( module Prelude,
-  )
-where
-
-import "base" Prelude

src/QBar/Blocks.hs

-module QBar.Blocks
-  ( QBar.Blocks.Battery.batteryBlock,
-    QBar.Blocks.CpuUsage.cpuUsageBlock,
-    QBar.Blocks.Date.dateBlock,
-  )
-where
-
-import qualified QBar.Blocks.Battery
-import qualified QBar.Blocks.CpuUsage
-import qualified QBar.Blocks.Date

src/QBar/Cli.hs

-{-# LANGUAGE ApplicativeDo #-}
-
-module QBar.Cli where
-
-import QBar.Blocks
-import QBar.Blocks.Pipe
-import QBar.ControlSocket
-import QBar.Core
-import QBar.DefaultConfig
-import QBar.Server
-import QBar.Theme
-
-import Control.Monad (join, sequence_)
-import qualified Data.Text.Lazy as T
-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
-
-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
-  return (barCommand MainOptions {verbose, indicator, socketLocation})
-
-barCommandParser :: Parser (MainOptions -> IO ())
-barCommandParser = hsubparser (
-    command "server" (info serverCommandParser (progDesc "Start a new 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."))
-  )
-
-serverCommandParser :: Parser (MainOptions -> IO ())
-serverCommandParser = hsubparser (
-    command "swaybar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server for swaybar. Should be called by swaybar.")) <>
-    command "i3bar" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new server for i3bar. Should be called by i3bar.")) <>
-    command "connect" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but send them to another qbar server."))
-  )
-
-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
-
-barConfigurationParser :: Parser (BarIO ())
-barConfigurationParser = do
-  blocks <- many blockParser
-  pure $ case blocks of
-    -- Load default config if no blocks are selected on the command line
-    [] -> defaultBarConfig
-    l -> sequence_ l
-
-blockParser :: Parser (BarIO ())
-blockParser = hsubparser (
-    command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks.")) <>
-    command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block."))
-  )

src/QBar/Core.hs

-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TemplateHaskell #-}
-
-module QBar.Core where
-
-import QBar.BlockOutput
-import QBar.TagParser
-
-import Control.Concurrent (threadDelay)
-import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
-import Control.Concurrent.MVar
-import Control.Concurrent.STM.TChan (TChan, writeTChan)
-import Control.Exception (IOException)
-import Control.Lens
-import Control.Monad.Reader (ReaderT, runReaderT, ask)
-import Control.Monad.State (StateT)
-import Control.Monad.Writer (WriterT)
-import Data.Aeson.TH
-import qualified Data.ByteString.Lazy.Char8 as C8
-import Data.Int (Int64)
-import Data.Maybe (catMaybes)
-import qualified Data.Text.Lazy as T
-import qualified Data.Text.Lazy.Encoding as E
-import qualified Data.Text.Lazy.IO as TIO
-import Pipes
-import Pipes.Concurrent
-import Pipes.Safe (SafeT, catchP, runSafeT)
-import qualified Pipes.Prelude as PP
-import System.Exit
-import System.IO
-import System.Process.Typed (Process, shell, setStdin, setStdout,
-  getStdout, closed, createPipe, readProcessStdout, startProcess, stopProcess)
-
-
-data MainOptions = MainOptions {
-  verbose :: Bool,
-  indicator :: Bool,
-  socketLocation :: Maybe T.Text
-}
-
-data BlockEvent = Click {
-  name :: T.Text,
-  button :: Int
-} deriving Show
-$(deriveJSON defaultOptions ''BlockEvent)
-
-
-data PushMode = PushMode
-data PullMode = PullMode
-data CachedMode = CachedMode
-
-
-type BlockEventHandler = BlockEvent -> BarIO ()
-
-type BlockState = Maybe (BlockOutput, Maybe BlockEventHandler)
-
-type Block = Producer BlockState BarIO
-
-
--- |Block that 'yield's an update whenever the block should be changed
-type PushBlock = Block PushMode
--- |Block that generates an update on 'yield'. Should only be pulled when an update is required.
-type PullBlock = Block PullMode
-
--- |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 CachedMode
-
-class IsCachable a where
-  toCachedBlock :: a -> BlockCache
-
-instance IsCachable PushBlock where
-  toCachedBlock = cachePushBlock
-instance IsCachable BlockCache where
-  toCachedBlock = id
-
-class IsBlockMode a where
-  exitBlock :: Block a
-instance IsBlockMode PushMode where
-  exitBlock = return PushMode
-instance IsBlockMode PullMode where
-  exitBlock = return PullMode
-
-exitCache :: BlockCache
-exitCache = return CachedMode
-
-
-type BarIO = SafeT (ReaderT Bar IO)
-
-data Bar = Bar {
-  requestBarUpdate :: IO (),
-  newBlockChan :: TChan BlockCache
-}
-
-
-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
-
-
-class (MonadBarIO m) => MonadBlock m where
-  liftBlock :: Block a -> m a
-instance MonadBlock Block where
-  liftBlock = id
-instance (MonadBlock m) => MonadBlock (StateT a m) where
-  liftBlock = lift . liftBlock
-instance (MonadBlock m) => MonadBlock (ReaderT a m) where
-  liftBlock = lift . liftBlock
-instance (MonadBlock m, Monoid a) => MonadBlock (WriterT a m) where
-  liftBlock = lift . liftBlock
-
-updateBlock :: MonadBlock m => BlockOutput -> m ()
-updateBlock blockOutput = liftBlock . yield $ Just (blockOutput, Nothing)
-
-updateBlock' :: MonadBlock m => BlockEventHandler -> BlockOutput -> m ()
-updateBlock' blockEventHandler blockOutput = liftBlock . yield $ Just (blockOutput, Just blockEventHandler)
-
-
-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)
-
-
-runBarIO :: Bar -> BarIO r -> IO r
-runBarIO bar action = runReaderT (runSafeT action) bar
-
-
-newCache :: Producer [BlockState] IO () -> BlockCache
-newCache 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))
-          seal
-
-newCache' :: (MonadIO m) => m (BlockCache, Consumer [BlockState] IO (), IO ())
-newCache' = do
-  (cache, update, seal) <- newCache''
-  return (cache, cacheUpdateConsumer update, seal)
-  where
-    cacheUpdateConsumer :: ([BlockState] -> IO Bool) -> Consumer [BlockState] IO ()
-    cacheUpdateConsumer update = do
-      v <- await
-      result <- liftIO $ update v
-      when result $ cacheUpdateConsumer update
-
-newCache'' :: (MonadIO m) => m (BlockCache, [BlockState] -> IO Bool, IO ())
-newCache'' = do
-  store <- liftIO $ newMVar (Just [])
-  newCacheInternal store
-  where
-    newCacheInternal :: MonadIO m => MVar (Maybe [BlockState]) -> m (BlockCache, [BlockState] -> IO Bool, IO ())
-    newCacheInternal store = return (cache, update, seal)
-      where
-        update :: [BlockState] -> IO Bool
-        update value = modifyMVar store $ \old ->
-          return $ case old of
-            Nothing -> (Nothing, False)
-            Just _ -> (Just value, True)
-        seal :: IO ()
-        seal = void . swapMVar store $ Nothing
-        cache :: BlockCache
-        cache = do
-          v <- liftIO (readMVar store)
-          case v of
-            Nothing -> exitCache
-            Just value -> yield value >> cache
-
-
-cacheFromInput :: Input BlockState -> BlockCache
-cacheFromInput input = do
-  result <- liftIO $ atomically $ recv input
-  case result of
-    Nothing -> exitCache
-    Just value -> yield [value] >> cacheFromInput input
-
-
-modify :: (BlockOutput -> BlockOutput) -> Pipe BlockState BlockState BarIO r
-modify x = PP.map (over (_Just . _1) x)
-
-autoPadding :: Pipe BlockState BlockState BarIO r
-autoPadding = autoPadding' 0 0
-  where
-    autoPadding' :: Int64 -> Int64 -> Pipe BlockState BlockState BarIO r
-    autoPadding' fullLength shortLength = do
-      maybeBlock <- await
-      case maybeBlock of
-        Just (block, eventHandler) -> do
-          let fullLength' = max fullLength . printedLength $ block^.fullText
-          let shortLength' = max shortLength . printedLength $ block^.shortText._Just
-          yield $ Just (padFullText fullLength' . padShortText shortLength' $ block, eventHandler)
-          autoPadding' fullLength' shortLength'
-        Nothing -> do
-          yield Nothing
-          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
-
-
--- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
--- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
-sharedInterval :: Int -> BarIO (PullBlock -> BlockCache)
-sharedInterval seconds = do
-  clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output BlockState)])
-
-  startEvent <- liftIO Event.new
-
-  task <- barAsync $ do
-    -- Wait for at least one subscribed client
-    liftIO $ Event.wait startEvent
-    forever $ do
-      liftIO $ threadDelay $ seconds * 1000000
-      -- Updates all client blocks
-      -- If send returns 'False' the clients mailbox has been closed, so it is removed
-      bar <- askBar
-      liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (runBarIO bar . runAndFilterClient)
-      -- Then update the bar
-      updateBar
-
-  liftIO $ link task
-
-  return (addClient startEvent clientsMVar)
-  where
-    runAndFilterClient :: (MVar PullBlock, Output BlockState) -> BarIO (Maybe (MVar PullBlock, Output BlockState))
-    runAndFilterClient client = do
-      result <- runClient client
-      return $ if result then Just client else Nothing
-    runClient :: (MVar PullBlock, Output BlockState) -> BarIO Bool
-    runClient (blockMVar, output) = do
-      bar <- askBar
-      liftIO $ modifyMVar blockMVar $ \blockProducer -> do
-        result <- runReaderT (runSafeT $ next blockProducer) bar
-        case result of
-          Left _ -> return (exitBlock, False)
-          Right (blockState, blockProducer') -> do
-            success <- atomically $ send output $ updateEventHandler (updateClickHandler blockState) blockState
-            if success
-              -- Store new BlockProducer back into MVar
-              then return (blockProducer', True)
-              -- Mailbox is sealed, stop running producer
-              else return (exitBlock, False)
-      where
-        updateClickHandler :: BlockState -> BlockEvent -> BarIO ()
-        updateClickHandler Nothing _ = return ()
-        updateClickHandler (Just (block, _)) _ = do
-          -- Give user feedback that the block is updating
-          let outdatedBlock = invalidateBlock block
-          -- The invalidated block output has no event handler
-          liftIO $ void $ atomically $ send output . Just $ (outdatedBlock, Nothing)
-          -- Notify bar about changed block state to display the feedback
-          updateBar
-          -- Run a normal block update to update the block to the new value
-          void $ runClient (blockMVar, output)
-          -- Notify bar about changed block state, this is usually done by the shared interval handler
-          updateBar
-    addClient :: Event.Event -> MVar [(MVar PullBlock, Output BlockState)] -> PullBlock -> BlockCache
-    addClient startEvent clientsMVar blockProducer = do
-      -- Spawn the mailbox that preserves the latest block
-      (output, input) <- liftIO $ spawn $ latest Nothing
-
-      blockMVar <- liftIO $ newMVar blockProducer
-
-      -- Generate initial block and send it to the mailbox
-      lift $ void $ runClient (blockMVar, output)
-
-      -- Register the client for regular updates
-      liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockMVar, output):clients)
-
-      -- Start update thread (if not already started)
-      liftIO $ Event.set startEvent
-
-      -- Return a block producer from the mailbox
-      cacheFromInput input
-
-blockScript :: FilePath -> PullBlock
-blockScript path = forever $ updateBlock =<< (lift blockScriptAction)
-  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 -> createScriptBlock output
-        (ExitFailure nr) -> case nr of
-          _ -> mkErrorOutput $ "exit code " <> T.pack (show nr) <> ""
-    createScriptBlock :: C8.ByteString -> BlockOutput
-    createScriptBlock output = case map E.decodeUtf8 (C8.lines output) of
-      (text:short:_) -> parseTags'' text short
-      (text:_) -> parseTags' text
-      [] -> emptyBlock
-
-persistentBlockScript :: FilePath -> PushBlock
--- The outer catchP only catches errors that occur during process creation
-persistentBlockScript path = catchP startScriptProcess handleError
-  where
-    handleError :: IOException -> PushBlock
-    handleError e = do
-      updateBlock . mkErrorOutput $ T.pack (show e)
-      exitBlock
-    handleErrorWithProcess :: (Process i o e) -> IOException -> PushBlock
-    handleErrorWithProcess process e = do
-      stopProcess process
-      handleError e
-    startScriptProcess :: PushBlock
-    startScriptProcess = do
-      let 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 $ getStdout process) (handleErrorWithProcess process)
-    blockFromHandle :: Handle -> PushBlock
-    blockFromHandle handle = forever $ do
-      line <- liftIO $ TIO.hGetLine handle
-      updateBlock $ parseTags' line
-      lift updateBar
-
-addBlock :: IsCachable a => a -> BarIO ()
-addBlock block = do
-  newBlockChan' <- newBlockChan <$> askBar
-  liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block
-
-updateBar :: BarIO ()
-updateBar = liftIO =<< requestBarUpdate <$> askBar
-
-updateBar' :: Bar -> IO ()
-updateBar' bar = runBarIO bar updateBar
-
-barAsync :: BarIO a -> BarIO (Async a)
-barAsync action = do
-  bar <- askBar
-  liftIO $ async $ runBarIO bar action
-
-cachePushBlock :: PushBlock -> BlockCache
-cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitCache) withInitialBlock
-  where
-    withInitialBlock :: (BlockState, PushBlock) -> BlockCache
-    withInitialBlock (initialBlockOutput, pushBlock') = do
-      (output, input, seal) <- liftIO $ spawn' $ latest initialBlockOutput
-      -- The async could be used to stop the block later, but for now we are just linking it to catch exceptions
-      task <- lift $ barAsync (sendProducerToMailbox output seal pushBlock')
-      liftIO $ link task
-      cacheFromInput input
-    sendProducerToMailbox :: Output BlockState -> STM () -> PushBlock -> BarIO ()
-    sendProducerToMailbox output seal pushBlock' = do
-      -- Send push block output to mailbox until it terminates
-      void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
-      -- Then clear the block and seal the mailbox
-      liftIO $ atomically $ void $ send output Nothing
-      updateBar
-      -- TODO: sealing does prevent a 'latest' mailbox from being read
-      liftIO $ atomically seal
-    sendOutputToMailbox :: Output BlockState -> BlockState -> Effect BarIO ()
-    sendOutputToMailbox output blockOutput = do
-      -- The void is discarding the boolean result that indicates if the mailbox is sealed
-      -- This is ok because a cached block is never sealed from the receiving side
-      liftIO $ atomically $ void $ send output blockOutput
-      lift updateBar

src/QBar/DefaultConfig.hs

-module QBar.DefaultConfig where
-
-import QBar.Blocks
-import QBar.BlockOutput
-import QBar.Core
-
-import Pipes
-
-import Control.Lens
-
-blockLocation :: String -> FilePath
-blockLocation name = "~/.config/qbar/blocks/" <> name
-
-defaultBarConfig :: BarIO ()
-defaultBarConfig = do
-  systemInfoInterval <- sharedInterval 10
-
-  let todo = systemInfoInterval (blockScript $ blockLocation "todo")
-  let wifi = systemInfoInterval $ (blockScript $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
-  let networkEnvironment = systemInfoInterval (blockScript $ blockLocation "network-environment")
-  let ram = systemInfoInterval $ (blockScript $ blockLocation "memory") >-> modify (addIcon "🐏\xFE0E") >-> autoPadding
-  let temperature = systemInfoInterval $ (blockScript $ blockLocation "temperature") >-> autoPadding
-  let volumeBlock = persistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
-  let battery = systemInfoInterval $ batteryBlock >-> modify (blockName ?~ "battery")
-  let cpuUsage = systemInfoInterval $ cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
-
-  addBlock dateBlock
-  addBlock battery
-  addBlock volumeBlock
-  addBlock temperature
-  addBlock ram
-  addBlock cpuUsage
-  addBlock networkEnvironment
-  addBlock wifi
-  addBlock todo