diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs index 204a47311bbefe932df9fe73f9611b968e4ad271..35f4f0cead1ba78b714fc4f6f99e6829db3f7a16 100644 --- a/src/QBar/Cli.hs +++ b/src/QBar/Cli.hs @@ -50,7 +50,8 @@ 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" (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 ()) diff --git a/src/QBar/ControlSocket.hs b/src/QBar/ControlSocket.hs index 1554dca2050a9864edd0e19aef3682e8270b862f..67cd966f882b43de74a0213878664fa5409941a2 100644 --- a/src/QBar/ControlSocket.hs +++ b/src/QBar/ControlSocket.hs @@ -18,9 +18,10 @@ import QBar.Utils import Control.Concurrent (forkFinally) import Control.Concurrent.Async -import Control.Exception (SomeException, IOException, handle) +import Control.Exception (SomeException, IOException, handle, onException) import Data.Aeson (FromJSON, ToJSON) import Data.Aeson.TH +import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as BSC import Data.Text.Lazy (pack) import Data.Time.Clock (getCurrentTime, addUTCTime) @@ -37,6 +38,7 @@ import Pipes.Aeson.Unchecked (encode) import Pipes.Network.TCP (fromSocket, toSocket) import System.Directory (removeFile, doesFileExist) import System.Environment (getEnv) +import System.Exit (exitSuccess) import System.FilePath ((</>)) import System.IO @@ -50,11 +52,15 @@ class (ToJSON (Up s), FromJSON (Up s), ToJSON (Down s), FromJSON (Down s)) => Is toStreamType :: s -> StreamType streamClient :: s -> MainOptions -> BarIO (Consumer (Up s) IO (), Producer (Down s) IO ()) - streamClient s options@MainOptions{verbose} = liftIO $ do - sock <- connectIpcSocket options - runEffect (encode (StartStream $ toStreamType s) >-> toSocket sock) - let up = forever (await >>= encode) >-> verbosePrintP >-> toSocket sock - let down = decodeStreamSafe options (fromSocket sock 4096 >-> verbosePrintP) + streamClient s options = do + sock <- liftIO $ connectIpcSocket options + 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 () @@ -269,6 +275,25 @@ sendBlockStream loadBlocks options = runBarHost blockStreamClient loadBlocks blockStreamClient :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) blockStreamClient = reconnectClient (ReconnectSendLatest []) $ streamClient BlockStream options +sendBlockStreamStdio :: BarIO () -> MainOptions -> IO () +sendBlockStreamStdio loadBlocks options = runBarHost blockStreamClient loadBlocks + where + blockStreamClient :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) + blockStreamClient = streamClient' BlockStream options sink source + sink :: Consumer ByteString IO () + sink = forever $ do + value <- await + -- Close when connection to upstream qbar is lost + liftIO $ (BS.hPut stdout value >> hFlush stdout) `onException` (hPutStrLn stderr "Stdout closed" >> exitSuccess) + source :: Producer ByteString IO () + source = forever $ do + value <- liftIO (BS.hGetSome stdin 4096) + -- Close when connection to upstream qbar is lost + when (BS.null value) $ liftIO $ do + hPutStrLn stderr "Stdin closed" + exitSuccess + yield value + addServerMirrorStream :: MainOptions -> BarIO () addServerMirrorStream options = do (blockEventConsumer, blockOutputProducer) <- reconnectClient ReconnectNoResend $ streamClient MirrorStream options diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs index 40a98abc68800b865409f0b34f64ebd8a355d19c..c2caaa8e5effd9380ea5bc3fb1395dc6a85aa6bc 100644 --- a/src/QBar/Host.hs +++ b/src/QBar/Host.hs @@ -9,11 +9,11 @@ import QBar.Time import QBar.Utils import Control.Concurrent (forkIO, forkFinally, threadDelay) -import Control.Concurrent.Async (async, wait, waitBoth) +import Control.Concurrent.Async (async, wait, waitAny) import qualified Control.Concurrent.Event as Event -import Control.Concurrent.MVar (MVar, newMVar, modifyMVar_, swapMVar) +import Control.Concurrent.MVar import Control.Concurrent.STM.TChan -import Control.Exception (SomeException, catch) +import Control.Exception (SomeException, catch, fromException) import Control.Lens hiding (each, (.=)) import Control.Monad.STM (atomically) import Data.IORef (IORef, newIORef, readIORef, writeIORef) @@ -21,6 +21,7 @@ import Data.Maybe (catMaybes, mapMaybe) import qualified Data.Text.Lazy as T import Pipes import Pipes.Concurrent (spawn, unbounded, toOutput, fromInput) +import System.Exit (ExitCode, exitWith) import System.IO (stderr, hPutStrLn) import System.Posix.Signals (Handler(..), sigCONT, installHandler) @@ -164,8 +165,8 @@ requestBarUpdateHandler HostHandle{barUpdateEvent, barUpdatedEvent, followupEven attachBarOutput :: (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO () attachBarOutput (blockOutputConsumer, blockEventProducer) = do - bar <- askBar - liftIO $ attachBarOutputInternal bar (blockOutputConsumer, blockEventProducer) + Bar{attachBarOutputInternal} <- askBar + liftIO $ attachBarOutputInternal (blockOutputConsumer, blockEventProducer) runBarHost :: BarIO (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> BarIO () -> IO () @@ -188,6 +189,8 @@ runBarHost' initializeBarAction = do -- Create IORef for event handlers eventHandlerListIORef <- newIORef [] + exitCodeMVar <- newEmptyMVar + let hostHandle = HostHandle { barUpdateEvent, barUpdatedEvent, @@ -202,7 +205,7 @@ runBarHost' initializeBarAction = do (cacheConsumer, cacheProducer) <- mkBroadcastCacheP [] -- Important: both monads (output producer / event consumer) will be forked whenever a new output connects! - let attachBarOutputInternal = attachBarOutputImpl cacheProducer (toOutput eventOutput) + let attachBarOutputInternal = attachBarOutputImpl exitCodeMVar cacheProducer (toOutput eventOutput) let requestBarUpdate = requestBarUpdateHandler hostHandle @@ -220,15 +223,28 @@ runBarHost' initializeBarAction = do -- Dispatch incoming events to blocks eventTask <- async $ runEffect $ fromInput eventInput >-> eventDispatcher bar eventHandlerListIORef + exitTask <- async $ takeMVar exitCodeMVar >>= exitWith + - void $ waitBoth blockTask eventTask + void $ waitAny [blockTask, eventTask, exitTask] where - attachBarOutputImpl :: Producer [BlockOutput] IO () -> Consumer BlockEvent IO () -> (Consumer [BlockOutput] IO (), Producer BlockEvent IO ()) -> IO () - attachBarOutputImpl blockOutputProducer eventConsumer (barOutputConsumer, barEventProducer) = do + 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 = liftIO $ runEffect $ barEventProducer >-> eventConsumer - liftIO $ void $ forkFinally handleBarEventInput (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result) + liftIO $ void $ forkFinally handleBarEventInput $ handleOnExitCodeException (\result -> hPutStrLn stderr $ "An event input handler failed: " <> show result) let handleBarOutput = liftIO $ runEffect $ blockOutputProducer >-> filterDuplicates >-> barOutputConsumer - liftIO $ void $ forkFinally handleBarOutput (\result -> hPutStrLn stderr $ "A bar output handler failed: " <> show result) + 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