Use BarIO in block Producers

src/QBar/Blocks.hs

@@ -12,8 +12,8 @@ import Pipes
 
 dateBlock :: PushBlock
 dateBlock = do
-  yield =<< lift dateBlockOutput
-  lift $ sleepUntil =<< nextMinute
+  yield =<< liftIO dateBlockOutput
+  liftIO $ sleepUntil =<< nextMinute
   dateBlock
 
 dateBlockOutput :: IO BlockOutput

src/QBar/ControlSocket.hs

@@ -4,6 +4,7 @@
 module QBar.ControlSocket where
 
 import QBar.Cli (MainOptions(..))
+import QBar.Core
 -- TODO: remove dependency?
 import QBar.Filter
 
@@ -13,9 +14,11 @@ import Control.Concurrent (forkFinally)
 import Control.Concurrent.Async
 import Control.Concurrent.STM.TChan (TChan, writeTChan)
 import Data.Aeson.TH
+import Data.ByteString (ByteString)
 import Data.Either (either)
 import Data.Text.Lazy (Text, pack)
 import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
 import Network.Socket
 import Pipes
 import Pipes.Parse
@@ -30,6 +33,7 @@ import System.IO
 type CommandChan = TChan Command
 
 data Command = SetFilter Filter
+  | Block
   deriving Show
 
 data SocketResponse = Success | Error Text
@@ -45,6 +49,8 @@ ipcSocketAddress MainOptions{socketLocation} = maybe defaultSocketPath (return .
     defaultSocketPath = do
       xdgRuntimeDir <- getEnv "XDG_RUNTIME_DIR"
       waylandDisplay <- getEnv "WAYLAND_DISPLAY"
+      -- TODO: fallback to I3_SOCKET_PATH if WAYLAND_DISPLAY is not set.
+      -- If both are not set it might be useful to fall back to XDG_RUNTIME_DIR/qbar, so qbar can run headless (eg. for tests)
       return $ xdgRuntimeDir </> waylandDisplay <> "-qbar"
 
 sendIpc :: MainOptions -> Command -> IO ()
@@ -83,14 +89,28 @@ listenUnixSocket options commandChan = do
     void $ forkFinally (socketHandler conn) (\_ -> close conn)
   where
     socketHandler :: Socket -> IO ()
-    socketHandler sock = do
-      decodeResult <- evalStateT decode $ fromSocket sock 4096
-      response <- maybe (errorResponse "Empty stream") (either (errorResponse . pack . show) commandHandler) decodeResult
-      let consumer = toSocket sock
+    socketHandler sock = streamHandler (fromSocket sock 4096) (toSocket sock)
+    streamHandler :: Producer ByteString IO () -> Consumer ByteString IO () -> IO ()
+    streamHandler producer consumer = do
+      (decodeResult, leftovers) <- runStateT decode producer
+      response <- maybe (errorResponse "Empty stream") (either handleError (handleCommand leftovers)) decodeResult
       runEffect (encode response >-> consumer)
-    commandHandler :: Command -> IO SocketResponse
-    commandHandler command = do
+    handleCommand :: Producer ByteString IO () -> Command -> IO SocketResponse
+    handleCommand _ Block = error "TODO" -- addBlock $ handleBlockStream leftovers
+    handleCommand _ command = do
       atomically $ writeTChan commandChan command
       return Success
+    handleError :: DecodingError -> IO SocketResponse
+    handleError = return . Error . pack . show
     errorResponse :: Text -> IO SocketResponse
-    errorResponse message = return $ Error message
\ No newline at end of file
+    errorResponse message = return $ Error message
+
+handleBlockStream :: Producer ByteString IO () -> PushBlock
+handleBlockStream producer = do
+  (decodeResult, leftovers) <- liftIO $ runStateT decode producer
+  maybe exitBlock (either (\_ -> exitBlock) (handleParsedBlock leftovers)) decodeResult
+  where
+    handleParsedBlock :: Producer ByteString IO () -> String -> PushBlock
+    handleParsedBlock leftovers update = do
+      yield $ createBlock $ TL.pack update
+      handleBlockStream leftovers
\ No newline at end of file

src/QBar/Core.hs

@@ -48,23 +48,25 @@ data PushMode = PushMode
 data PullMode = PullMode
 data CachedMode = CachedMode
 
+type Block a = Producer BlockOutput BarIO a
+
 
 -- |Block that 'yield's an update whenever the block should be changed
-type PushBlock = Producer BlockOutput IO PushMode
+type PushBlock = Block PushMode
 -- |Block that generates an update on 'yield'. Should only be pulled when an update is required.
-type PullBlock = Producer BlockOutput IO PullMode
+type PullBlock = Block PullMode
 -- |Cached block. Always 'yield's the latest update, so it should only be pulled when the bar is rendered.
-type CachedBlock = Producer BlockOutput IO CachedMode
+type CachedBlock = Block CachedMode
 
 class IsBlock a where
-  toCachedBlock :: Bar -> a -> CachedBlock
+  toCachedBlock :: a -> CachedBlock
 instance IsBlock PushBlock where
   toCachedBlock = cachePushBlock
 instance IsBlock CachedBlock where
-  toCachedBlock _ = id
+  toCachedBlock = id
 
 class IsBlockMode a where
-  exitBlock :: Producer BlockOutput IO a
+  exitBlock :: Block a
 instance IsBlockMode PushMode where
   exitBlock = return PushMode
 instance IsBlockMode PullMode where
@@ -73,7 +75,7 @@ instance IsBlockMode CachedMode where
   exitBlock = return CachedMode
 
 
-type BarIO a = ReaderT Bar IO a
+type BarIO = ReaderT Bar IO
 
 data Bar = Bar {
   requestBarUpdate :: IO (),
@@ -167,13 +169,13 @@ removePango block
         Left _ -> text
         Right parsed -> removeFormatting parsed
 
-modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput IO r
+modify :: (BlockOutput -> BlockOutput) -> Pipe BlockOutput BlockOutput BarIO r
 modify = PP.map
 
-autoPadding :: Pipe BlockOutput BlockOutput IO r
+autoPadding :: Pipe BlockOutput BlockOutput BarIO r
 autoPadding = autoPadding' 0 0
   where
-    autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput IO r
+    autoPadding' :: Int64 -> Int64 -> Pipe BlockOutput BlockOutput BarIO r
     autoPadding' fullLength shortLength = do
       block <- await
       let values' = (values block)
@@ -197,67 +199,69 @@ sharedInterval seconds = do
     liftIO $ threadDelay $ seconds * 1000000
     -- Updates all client blocks
     -- If send returns 'False' the clients mailbox has been closed, so it is removed
-    liftIO $ modifyMVar_ clientsMVar (fmap catMaybes . mapConcurrently runAndFilterClient)
+    bar <- ask
+    liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (\r -> runReaderT (runAndFilterClient r) bar)
     -- Then update the bar
     updateBar
 
   return (addClient clientsMVar, task)
-    where
-      runAndFilterClient :: (MVar PullBlock, Output BlockOutput) -> IO (Maybe (MVar PullBlock, Output BlockOutput))
-      runAndFilterClient client = do
-        result <- runClient client
-        return $ if result then Just client else Nothing
-      runClient :: (MVar PullBlock, Output BlockOutput) -> IO Bool
-      runClient (blockProducerMVar, output) =
-        modifyMVar blockProducerMVar $ \blockProducer -> do
-          result <- next blockProducer
-          case result of
-            Left _ -> return (exitBlock, False)
-            Right (blockOutput, blockProducer') -> do
-              success <- atomically $ send output blockOutput {
-                clickAction = Just (updateClickHandler blockOutput)
-              }
-              if success
-                -- Store new BlockProducer back into MVar
-                then return (blockProducer', True)
-                -- Mailbox is sealed, stop running producer
-                else return (exitBlock, False)
-        where
-          updateClickHandler :: BlockOutput -> Click -> BarIO ()
-          updateClickHandler block _ = do
-            -- Give user feedback that the block is updating
-            let outdatedBlock = setColor updatingColor $ removePango block
-            lift $ void $ atomically $ send output $ outdatedBlock
-            -- Notify bar about changed block state to display the feedback
-            updateBar
-            -- Run a normal block update to update the block to the new value
-            lift $ void $ runClient (blockProducerMVar, output)
-            -- Notify bar about changed block state, this is usually done by the shared interval handler
-            updateBar
-      addClient :: MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock
-      addClient clientsMVar blockProducer = do
-        -- Spawn the mailbox that preserves the latest block
-        (output, input) <- lift $ spawn $ latest emptyBlock
-
-        blockProducerMVar <- lift $ newMVar blockProducer
-
-        -- Generate initial block and send it to the mailbox
-        lift $ void $ runClient (blockProducerMVar, output)
-
-        -- Register the client for regular updates
-        lift $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
-
-        -- Return a block producer from the mailbox
-        cacheFromInput input
+  where
+    runAndFilterClient :: (MVar PullBlock, Output BlockOutput) -> BarIO (Maybe (MVar PullBlock, Output BlockOutput))
+    runAndFilterClient client = do
+      result <- runClient client
+      return $ if result then Just client else Nothing
+    runClient :: (MVar PullBlock, Output BlockOutput) -> BarIO Bool
+    runClient (blockProducerMVar, output) = do
+      bar <- ask
+      liftIO $ modifyMVar blockProducerMVar $ \blockProducer -> do
+        result <- runReaderT (next blockProducer) bar
+        case result of
+          Left _ -> return (exitBlock, False)
+          Right (blockOutput, blockProducer') -> do
+            success <- atomically $ send output blockOutput {
+              clickAction = Just (updateClickHandler blockOutput)
+            }
+            if success
+              -- Store new BlockProducer back into MVar
+              then return (blockProducer', True)
+              -- Mailbox is sealed, stop running producer
+              else return (exitBlock, False)
+      where
+        updateClickHandler :: BlockOutput -> Click -> BarIO ()
+        updateClickHandler block _ = do
+          -- Give user feedback that the block is updating
+          let outdatedBlock = setColor updatingColor $ removePango block
+          liftIO $ void $ atomically $ send output $ outdatedBlock
+          -- 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 (blockProducerMVar, output)
+          -- Notify bar about changed block state, this is usually done by the shared interval handler
+          updateBar
+    addClient :: MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock
+    addClient clientsMVar blockProducer = do
+      -- Spawn the mailbox that preserves the latest block
+      (output, input) <- liftIO $ spawn $ latest emptyBlock
+
+      blockProducerMVar <- liftIO $ newMVar blockProducer
+
+      -- Generate initial block and send it to the mailbox
+      lift $ void $ runClient (blockProducerMVar, output)
+
+      -- Register the client for regular updates
+      liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
+
+      -- Return a block producer from the mailbox
+      cacheFromInput input
 
 blockScript :: FilePath -> PullBlock
 blockScript path = forever $ yield =<< (lift $ blockScriptAction)
   where
-    blockScriptAction :: IO BlockOutput
+    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) <- readProcessStdout $ shell path
+      (exitCode, output) <- liftIO $ readProcessStdout $ shell path
       case exitCode of
         ExitSuccess -> return $ case map E.decodeUtf8 (C8.lines output) of
           (text:short:color:_) -> setColor color $ shortText short $ createScriptBlock text
@@ -268,15 +272,15 @@ blockScript path = forever $ yield =<< (lift $ blockScriptAction)
     createScriptBlock :: T.Text -> BlockOutput
     createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
 
-startPersistentBlockScript :: FilePath -> BarIO CachedBlock
+startPersistentBlockScript :: FilePath -> CachedBlock
 -- This is only using 'CachedBlock' because the code was already written and tested
 -- This could probably be massively simplified by using the new 'pushBlock'
 startPersistentBlockScript path = do
-  bar <- ask
-  return $ do
-    (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
-    initialDataEvent <- lift $ Event.new
-    task <- lift $ async $ do
+  bar <- lift $ ask
+  do
+    (output, input, seal) <- liftIO $ spawn' $ latest $ emptyBlock
+    initialDataEvent <- liftIO $ Event.new
+    task <- liftIO $ async $ do
       let processConfig = setStdin closed $ setStdout createPipe $ shell path
       finally (
         catch (
@@ -290,8 +294,8 @@ startPersistentBlockScript path = do
           )
         )
         (atomically seal)
-    lift $ link task
-    lift $ Event.wait initialDataEvent
+    liftIO $ link task
+    liftIO $ Event.wait initialDataEvent
     cacheFromInput input
   where
     signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO ()
@@ -325,8 +329,7 @@ pangoColor (RGB r g b) =
 addBlock :: IsBlock a => a -> BarIO ()
 addBlock block = do
   newBlockChan' <- asks newBlockChan
-  cachedBlock <- asks toCachedBlock <*> return block
-  liftIO $ atomically $ writeTChan newBlockChan' cachedBlock
+  liftIO $ atomically $ writeTChan newBlockChan' $ toCachedBlock block
 
 updateBar :: BarIO ()
 updateBar = liftIO =<< asks requestBarUpdate
@@ -342,29 +345,29 @@ barAsync action = do
   bar <- ask
   lift $ async $ runReaderT action bar
 
-cachePushBlock :: Bar -> PushBlock -> CachedBlock
-cachePushBlock bar pushBlock =
-  lift (next pushBlock) >>= either (\_ -> exitBlock) withInitialBlock
+cachePushBlock :: PushBlock -> CachedBlock
+cachePushBlock pushBlock = lift (next pushBlock) >>= either (const exitBlock) withInitialBlock
   where
     withInitialBlock :: (BlockOutput, PushBlock) -> CachedBlock
     withInitialBlock (initialBlockOutput, pushBlock') = do
-      (output, input, seal) <- lift $ spawn' $ latest $ Just initialBlockOutput
+      (output, input, seal) <- liftIO $ spawn' $ latest $ Just initialBlockOutput
       -- The async could be used to stop the block later, but for now we are just linking it to catch exceptions
-      lift $ link =<< async (sendProducerToMailbox output seal pushBlock')
+      task <- lift $ barAsync (sendProducerToMailbox output seal pushBlock')
+      liftIO $ link task
       terminateOnMaybe $ fromInput input
-    sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> PushBlock -> IO ()
+    sendProducerToMailbox :: Output (Maybe BlockOutput) -> STM () -> PushBlock -> BarIO ()
     sendProducerToMailbox output seal pushBlock' = do
       void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
-      atomically $ void $ send output Nothing
-      updateBar'' bar
-      atomically seal
-    sendOutputToMailbox :: Output (Maybe BlockOutput) -> BlockOutput -> Effect IO ()
-    sendOutputToMailbox output blockOutput = lift $ do
+      liftIO $ atomically $ void $ send output Nothing
+      updateBar
+      liftIO $ atomically seal
+    sendOutputToMailbox :: Output (Maybe BlockOutput) -> BlockOutput -> 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
-      atomically $ void $ send output $ Just blockOutput
-      updateBar'' bar
-    terminateOnMaybe :: Producer (Maybe BlockOutput) IO () -> Producer BlockOutput IO CachedMode
+      liftIO $ atomically $ void $ send output $ Just blockOutput
+      lift $ updateBar
+    terminateOnMaybe :: Producer (Maybe BlockOutput) BarIO () -> Producer BlockOutput BarIO CachedMode
     terminateOnMaybe p = do
       eitherMaybeValue <- lift $ next p
       case eitherMaybeValue of

src/QBar/DefaultConfig.hs

@@ -20,7 +20,7 @@ generateDefaultBarConfig = do
   let cpu = (systemInfoInterval $ blockScript $ blockLocation "cpu_usage") >-> modify (setBlockName "cpu" . addIcon "💻") >-> autoPadding
   let ram = (systemInfoInterval $ blockScript $ blockLocation "memory") >-> modify (addIcon "🐏") >-> autoPadding
   let temperature = (systemInfoInterval $ blockScript $ blockLocation "temperature") >-> autoPadding
-  volumeBlock <- startPersistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
+  let volumeBlock = startPersistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
   let battery = (systemInfoInterval $ blockScript $ blockLocation "battery2")
 
   addBlock dateBlock

src/QBar/Server.hs

@@ -37,44 +37,44 @@ renderIndicator :: CachedBlock
 -- Using 'cachedBlock' is a hack to actually get the block to update on every bar update (by doing this it will not get a cache later in the pipeline).
 renderIndicator = forever $ each $ map createBlock ["/", "-", "\\", "|"]
 
-runBlock :: CachedBlock -> IO (Maybe (BlockOutput, CachedBlock))
+runBlock :: CachedBlock -> BarIO (Maybe (BlockOutput, CachedBlock))
 runBlock producer = do
   next' <- next producer
   return $ case next' of
     Left _ -> Nothing
     Right (block, newProducer) -> Just (block, newProducer)
 
-runBlocks :: [CachedBlock] -> IO ([BlockOutput], [CachedBlock])
+runBlocks :: [CachedBlock] -> BarIO ([BlockOutput], [CachedBlock])
 runBlocks block = unzip . catMaybes <$> mapM runBlock block
 
-renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> IO ()
+renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> BarIO ()
 renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
   where
-    addNewBlocks :: [CachedBlock] -> IO [CachedBlock]
+    addNewBlocks :: [CachedBlock] -> BarIO [CachedBlock]
     addNewBlocks blocks = do
-      maybeNewBlock <- atomically $ tryReadTChan newBlockChan
+      maybeNewBlock <- liftIO $ atomically $ tryReadTChan newBlockChan
       case maybeNewBlock of
         Nothing -> return blocks
         Just newBlock -> addNewBlocks (newBlock:blocks)
-    renderLoop' :: BS.ByteString -> [CachedBlock] -> IO ()
+    renderLoop' :: BS.ByteString -> [CachedBlock] -> BarIO ()
     renderLoop' previousBarOutput' blocks = do
-      blockFilter <- readIORef handleActiveFilter
+      blockFilter <- liftIO $ readIORef handleActiveFilter
 
       -- Wait for an event (unless the filter is animated)
-      unless (isAnimatedFilter blockFilter) $ Event.wait barUpdateEvent
+      unless (isAnimatedFilter blockFilter) $ liftIO $ Event.wait barUpdateEvent
 
       -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
-      threadDelay 10000
-      Event.clear barUpdateEvent
+      liftIO $ threadDelay 10000
+      liftIO $ Event.clear barUpdateEvent
 
       blocks' <- addNewBlocks blocks
 
       (blockOutputs, blocks'') <- runBlocks blocks'
 
-      currentBarOutput <- renderLine options handle blockFilter blockOutputs previousBarOutput'
+      currentBarOutput <- liftIO $ renderLine options handle blockFilter blockOutputs previousBarOutput'
 
       -- Wait for 100ms after rendering a line to limit cpu load of rapid events
-      threadDelay 100000
+      liftIO $ threadDelay 100000
 
       renderLoop' currentBarOutput blocks''
 
@@ -209,11 +209,11 @@ runBarConfiguration generateBarConfig options = do
     command <- atomically $ readTChan commandChan
     case command of
       SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
-    updateBar barUpdateChannel
+      Block -> error "TODO"
     updateBar' barUpdateChannel
   link socketUpdateAsync
 
-  renderLoop options handle barUpdateEvent initialOutput newBlockChan
+  runReaderT (renderLoop options handle barUpdateEvent initialOutput newBlockChan) bar
   where
     loadBlocks :: BarIO ()
     loadBlocks = do