Implement pipe block

src/QBar/Blocks/Pipe.hs

+module QBar.Blocks.Pipe where
+
+import QBar.BlockOutput
+import QBar.Core
+
+import Data.Aeson (encode)
+import qualified Data.ByteString.Lazy.Char8 as BSC
+import qualified Data.Text.Lazy as T
+import Pipes
+import qualified Pipes.Prelude as PP
+import System.IO
+
+-- |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 :: Bool -> PushBlock
+pipeBlock enableEvents = PushMode <$ PP.stdinLn >-> PP.map stringToState
+  where
+    stringToState :: String -> BlockState
+    stringToState = attachHandler . mkBlockOutput . normalText . T.pack
+    attachHandler :: BlockOutput -> BlockState
+    attachHandler = if enableEvents then mkBlockState' pipeBlockName handler else mkBlockState
+    handler :: BlockEventHandler
+    handler event = liftIO $ BSC.hPutStrLn stderr $ encode event
+    pipeBlockName :: Text
+    pipeBlockName = "pipe"

src/QBar/Cli.hs

@@ -2,6 +2,7 @@
 
 module QBar.Cli where
 
+import QBar.Blocks.Pipe
 import QBar.ControlSocket
 import QBar.Core
 import QBar.DefaultConfig
@@ -38,6 +39,7 @@ barCommandParser :: Parser (MainOptions -> IO ())
 barCommandParser = hsubparser (
     command "server" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
     command "connect" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
+    command "pipe" (info (sendBlockStream <$> pipeBlockParser) (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 "default" (info (pure $ sendIpc . SetTheme $ "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
     command "rainbow" (info (pure $ sendIpc . SetTheme $ "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
@@ -46,6 +48,11 @@ barCommandParser = hsubparser (
 themeCommandParser :: Parser (MainOptions -> IO ())
 themeCommandParser = sendIpc . SetTheme <$> strArgument (metavar "THEME" <> completeWith (map T.unpack themeNames))
 
+pipeBlockParser :: Parser (BarIO ())
+pipeBlockParser = do
+  events <- switch $ long "events" <> short 'e' <> help "Also encode events to stdout. Every event will be a JSON-encoded line."
+  pure $ addBlock $ pipeBlock events
+
 barConfigurationParser :: Parser (BarIO ())
 barConfigurationParser = do
   blocks <- many $ hsubparser (

src/QBar/Core.hs

@@ -134,6 +134,9 @@ updateBlock' blockEventHandler blockOutput = liftBlock . yield $ Just (blockOutp
 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)