From 901767b8e475f28fbd6844c73cb25e49561d174e Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Fri, 31 Jan 2020 19:44:27 +0100
Subject: [PATCH] Split 'Server' into generic 'Host' and sway/i3-bar specific
'Server'
---
src/QBar/Host.hs | 149 ++++++++++++++++++++++++-
src/QBar/Server.hs | 271 +++++++++++++--------------------------------
2 files changed, 224 insertions(+), 196 deletions(-)
diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs
index dfb8f58..5cc2fe8 100644
--- a/src/QBar/Host.hs
+++ b/src/QBar/Host.hs
@@ -1,12 +1,134 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
module QBar.Host where
+import QBar.BlockOutput
import QBar.Core
+import Control.Concurrent (forkIO, forkFinally, threadDelay)
import Control.Concurrent.Event as Event
-import Control.Concurrent.STM.TChan (TChan, newTChanIO)
+import Control.Concurrent.STM.TChan (TChan, newTChanIO, tryReadTChan)
+import Control.Exception (SomeException, catch)
+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 Pipes
+import System.IO (stderr, hPutStrLn)
+import System.Posix.Signals
+
+data HostHandle = HostHandle {
+ barUpdateEvent :: BarUpdateEvent,
+ newBlockChan :: TChan CachedBlock,
+ eventHandlerListIORef :: IORef [(T.Text, BlockEventHandler)]
+}
+
+installSignalHandlers :: Bar -> IO ()
+installSignalHandlers bar = void $ installHandler sigCONT (Catch sigContAction) Nothing
+ where
+ sigContAction :: IO ()
+ sigContAction = do
+ hPutStrLn stderr "SIGCONT received"
+ updateBar' bar
+
+eventDispatcher :: IORef [(T.Text, BlockEventHandler)] -> Consumer BlockEvent BarIO ()
+eventDispatcher eventHandlerListIORef = eventDispatcher'
+ where
+ eventDispatcher' :: Consumer BlockEvent BarIO ()
+ eventDispatcher' = do
+ blockEvent <- await
+ bar <- askBar
+ eventHandlerList <- liftIO $ readIORef eventHandlerListIORef
+ let maybeEventHandler = getEventHandler eventHandlerList blockEvent
+ case maybeEventHandler of
+ Just eventHandler -> liftIO . void . forkIO $ catch (runBarIO bar $ eventHandler blockEvent) (\(e :: SomeException) -> hPutStrLn stderr $ "event handler failed: " <> show e)
+ Nothing -> return ()
+ eventDispatcher'
+ getEventHandler :: [(T.Text, BlockEventHandler)] -> BlockEvent -> Maybe BlockEventHandler
+ getEventHandler eventHandlerList blockEvent = lookup (name blockEvent) eventHandlerList
+
+
+runBlocks :: HostHandle -> Producer [BlockOutput] BarIO ()
+runBlocks HostHandle{barUpdateEvent, newBlockChan, eventHandlerListIORef} = runBlocks' []
+ where
+ runBlocks' :: [CachedBlock] -> Producer [BlockOutput] BarIO ()
+ runBlocks' blocks = do
+ liftIO $ do
+ -- Wait for an update request
+ Event.wait barUpdateEvent
+
+ -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
+ threadDelay 10000
+ Event.clear barUpdateEvent
+
+ blocks' <- lift $ addNewBlocks blocks
+
+ (blockStates, blocks'') <- lift $ getBlockStates blocks'
+
+ -- Pass blocks to output
+ yield $ map fst $ catMaybes blockStates
+
+ -- 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
+
+ -- Loop
+ runBlocks' blocks''
+
+ addNewBlocks :: [CachedBlock] -> BarIO [CachedBlock]
+ addNewBlocks blocks = do
+ maybeNewBlock <- liftIO $ atomically $ tryReadTChan newBlockChan
+ case maybeNewBlock of
+ Nothing -> return blocks
+ Just newBlock -> addNewBlocks (newBlock:blocks)
-runBarHost :: (TChan CachedBlock -> BarUpdateEvent -> BarIO ()) -> IO ()
-runBarHost host = do
+ getBlockStates :: [CachedBlock] -> BarIO ([BlockState], [CachedBlock])
+ getBlockStates blocks = unzip . catMaybes <$> mapM getBlockState blocks
+
+ getBlockState :: CachedBlock -> BarIO (Maybe (BlockState, CachedBlock))
+ getBlockState producer = do
+ next' <- next producer
+ return $ case next' of
+ Left _ -> Nothing
+ Right (blockState, newProducer) -> Just (blockState, newProducer)
+
+ updateEventHandlers :: [BlockState] -> IO ()
+ updateEventHandlers blockStates =
+ writeIORef eventHandlerListIORef eventHandlerList
+ where
+ eventHandlerList :: [(T.Text, BlockEventHandler)]
+ 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
+ return (blockName', eventHandler)
+
+
+filterDuplicates :: (Monad m, Eq a) => Pipe a a m r
+filterDuplicates = do
+ value <- await
+ yield value
+ filterDuplicates' value
+ where
+ filterDuplicates' :: (Monad m, Eq a) => a -> Pipe a a m r
+ filterDuplicates' lastValue = do
+ value <- await
+ when (lastValue /= value) $ yield value
+ filterDuplicates' value
+
+
+runBarHost :: Consumer [BlockOutput] BarIO ()
+ -> Producer BlockEvent BarIO ()
+ -> IO ()
+runBarHost host barEventProducer = do
-- Create an event used to signal bar updates
barUpdateEvent <- Event.newSet
let requestBarUpdate = Event.set barUpdateEvent
@@ -15,4 +137,23 @@ runBarHost host = do
newBlockChan <- newTChanIO
let bar = Bar { requestBarUpdate, newBlockChan }
- runBarIO bar (host newBlockChan barUpdateEvent)
+
+ -- Install signal handler for SIGCONT
+ installSignalHandlers bar
+
+ -- Create IORef for event handlers
+ eventHandlerListIORef <- newIORef []
+
+ let hostHandle = HostHandle {
+ barUpdateEvent,
+ newBlockChan,
+ eventHandlerListIORef
+ }
+
+ let handleStdin = runEffect $ barEventProducer >-> eventDispatcher eventHandlerListIORef
+ -- Fork stdin handler
+ void $ forkFinally (runBarIO bar handleStdin) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
+
+ -- Run bar host
+ runBarIO bar $ runEffect $ runBlocks hostHandle >-> filterDuplicates >-> host
+
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index f466972..24729d1 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -1,6 +1,7 @@
+{-# LANGUAGE DuplicateRecordFields #-}
+
module QBar.Server where
-import QBar.Blocks
import QBar.BlockOutput
import QBar.BlockText
import QBar.Core
@@ -10,45 +11,26 @@ import QBar.Filter
import QBar.Host
import QBar.Themes
-import Control.Monad (forever, when, unless)
+import Control.Monad (forever, when, unless, forM_)
import Control.Monad.STM (atomically)
-import Control.Concurrent (threadDelay, forkFinally)
import Control.Concurrent.Async
-import Control.Concurrent.Event as Event
-import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, tryReadTChan)
+import Control.Concurrent.STM.TChan (newTChanIO, readTChan)
import Data.Aeson (encode, decode, ToJSON, toJSON, object, (.=))
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.IORef
-import Data.Maybe (catMaybes, mapMaybe, fromMaybe)
+import Data.Maybe (fromMaybe)
import qualified Data.Text.Lazy as T
-import Data.Time.Clock.POSIX
import Pipes
-import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
-import System.Posix.Signals
+import System.IO (stdin, stdout, stderr, hFlush)
import Control.Lens hiding (each, (.=))
-data Handle = Handle {
- handleActionList :: IORef [(T.Text, BlockEventHandler)],
- handleActiveFilter :: IORef Filter
-}
-
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 (mkBlockState . mkBlockOutput . normalText) ["/", "-", "\\", "|"]
-runBlock :: CachedBlock -> BarIO (Maybe (BlockState, CachedBlock))
-runBlock producer = do
- next' <- next producer
- return $ case next' of
- Left _ -> Nothing
- Right (blockState, newProducer) -> Just (blockState, newProducer)
-
-runBlocks :: [CachedBlock] -> BarIO ([BlockState], [CachedBlock])
-runBlocks blocks = unzip . catMaybes <$> mapM runBlock blocks
-
data RenderBlock = RenderBlock T.Text (Maybe T.Text) (Maybe T.Text)
deriving(Show)
instance ToJSON RenderBlock where
@@ -56,195 +38,100 @@ instance ToJSON RenderBlock where
fullText'' <> shortText'' <> blockName'' <> pango''
where
fullText'' = [ "full_text" .= fullText' ]
- shortText'' = fromMaybe (\s -> ["short_text".=s]) mempty shortText'
- blockName'' = fromMaybe (\s -> ["name".=s]) mempty blockName'
+ shortText'' = fromMaybe (\s -> ["short_text" .= s]) mempty shortText'
+ blockName'' = fromMaybe (\s -> ["name" .= s]) mempty blockName'
pango'' = [ "markup" .= ("pango" :: T.Text) ]
+-- |A consumer that accepts lists of 'BlockOutput' and renders them to stdout using the {sway,i3}bar-protocol.
+swayBarOutput :: MainOptions -> Consumer [BlockOutput] BarIO ()
+swayBarOutput MainOptions{verbose} = do
+ -- Output header
+ liftIO $ do
+ putStrLn "{\"version\":1,\"click_events\":true}"
+ putStrLn "["
-renderLoop :: MainOptions -> Handle -> BarUpdateEvent -> BS.ByteString -> TChan CachedBlock -> BarIO ()
-renderLoop options handle@Handle{handleActiveFilter} barUpdateEvent previousBarOutput newBlockChan = renderLoop' previousBarOutput []
+ swayBarOutput'
where
- addNewBlocks :: [CachedBlock] -> BarIO [CachedBlock]
- addNewBlocks blocks = do
- maybeNewBlock <- liftIO $ atomically $ tryReadTChan newBlockChan
- case maybeNewBlock of
- Nothing -> return blocks
- Just newBlock -> addNewBlocks (newBlock:blocks)
- renderLoop' :: BS.ByteString -> [CachedBlock] -> BarIO ()
- renderLoop' previousBarOutput' blocks = do
- blockFilter <- liftIO $ readIORef handleActiveFilter
-
- -- Wait for an event (unless the filter is animated)
- unless (isAnimatedFilter blockFilter) $ liftIO $ Event.wait barUpdateEvent
-
- -- Wait for 10ms after first events to catch (almost-)simultaneous event updates
- liftIO $ threadDelay 10000
- liftIO $ Event.clear barUpdateEvent
-
- blocks' <- addNewBlocks blocks
-
- (blockStates, blocks'') <- runBlocks blocks'
-
- currentBarOutput <- liftIO $ renderLine options handle blockFilter blockStates previousBarOutput'
-
- -- Wait for 100ms after rendering a line to limit cpu load of rapid events
- liftIO $ threadDelay 100000
-
- renderLoop' currentBarOutput blocks''
-
-renderLine :: MainOptions -> Handle -> Filter -> [BlockState] -> BS.ByteString -> IO BS.ByteString
-renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blockStates previousEncodedOutput = do
- time <- fromRational . toRational <$> getPOSIXTime
- let blockOutputs = map fst $ catMaybes blockStates
- let filteredBlocks = applyFilter blockFilter time blockOutputs
- -- let encodedOutput = encode $ map values filteredBlocks
- let encodedOutput = encodeOutput filteredBlocks
- let changed = previousEncodedOutput /= encodedOutput
- when changed $ do
- hPut stdout encodedOutput
- putStrLn ","
- hFlush stdout
- -- Echo output to stderr when verbose flag is set
- when verbose $ do
- hPut stderr encodedOutput
- hPut stderr "\n"
- hFlush stderr
-
- when verbose $ unless changed $ hPutStrLn stderr "Output unchanged"
-
- -- Register all event handlers regardless of bar changes, because we cannot easily check if any handler has changed
- writeIORef handleActionList eventHandlerList
-
- return encodedOutput
- where
- theme :: Theme
- theme = defaultTheme
+ swayBarOutput' :: Consumer [BlockOutput] BarIO ()
+ swayBarOutput' = do
+ blocks <- await
+
+ let encodedOutput = encodeOutput blocks
+
+ liftIO $ do
+ hPut stdout encodedOutput
+ putStrLn ","
+ hFlush stdout
+ -- Echo output to stderr when verbose flag is set
+ when verbose $ do
+ hPut stderr encodedOutput
+ hPut stderr "\n"
+ hFlush stderr
+
+ swayBarOutput'
encodeOutput :: [BlockOutput] -> BS.ByteString
- encodeOutput bs = encode $ zipWith encodeBlock bs $ theme bs
+ encodeOutput bs = encode $ zipWith encodeBlock bs $ defaultTheme bs
encodeBlock :: BlockOutput -> (T.Text, Maybe T.Text) -> RenderBlock
encodeBlock b (fullText', shortText') = RenderBlock fullText' shortText' (b^.blockName)
- eventHandlerList :: [(T.Text, BlockEventHandler)]
- 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
- return (blockName', eventHandler)
-createBarUpdateChannel :: IO (IO (), BarUpdateEvent)
-createBarUpdateChannel = do
- event <- Event.newSet
- return (Event.set event, event)
+-- |A producer that reads swaybar/i3bar-input events from stdin and emits them as 'BlockEvent's.
+swayBarInput :: MainOptions -> Producer BlockEvent BarIO ()
+swayBarInput MainOptions{verbose} = swayBarInput'
+ where
+ swayBarInput' :: Producer BlockEvent BarIO ()
+ swayBarInput' = do
+ line <- liftIO $ BSSC8.hGetLine stdin
-handleStdin :: MainOptions -> IORef [(T.Text, BlockEventHandler)] -> BarIO ()
-handleStdin options eventHandlerListIORef = do
- bar <- askBar
- liftIO $ forever $ do
- line <- BSSC8.hGetLine stdin
+ unless (line == "[") $ do
+ -- Echo input to stderr when verbose flag is set
+ when verbose $ liftIO $ do
+ liftIO $ BSSC8.hPutStrLn stderr line
+ hFlush stderr
- unless (line == "[") $ do
- -- Echo input to stderr when verbose flag is set
- when (verbose options) $ do
- BSSC8.hPutStrLn stderr line
- hFlush stderr
+ let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
+ forM_ maybeBlockEvent yield
- let maybeBlockEvent = decode $ removeComma $ BS.fromStrict line
- case maybeBlockEvent of
- Just blockEvent -> do
- eventHandlerList <- readIORef eventHandlerListIORef
- let maybeEventHandler = getEventHandler eventHandlerList blockEvent
- case maybeEventHandler of
- Just eventHandler -> async (runBarIO bar (eventHandler blockEvent)) >>= link
- Nothing -> return ()
- Nothing -> return ()
+ swayBarInput'
- where
- getEventHandler :: [(T.Text, BlockEventHandler)] -> BlockEvent -> Maybe BlockEventHandler
- getEventHandler eventHandlerList blockEvent = lookup (name blockEvent) eventHandlerList
removeComma :: C8.ByteString -> C8.ByteString
removeComma line
| C8.head line == ',' = C8.tail line
| C8.last line == ',' = C8.init line
| otherwise = line
-installSignalHandlers :: BarIO ()
-installSignalHandlers = do
- bar <- askBar
- liftIO $ void $ installHandler sigCONT (Catch (sigContAction bar)) Nothing
- where
- sigContAction :: Bar -> IO ()
- sigContAction bar = do
- hPutStrLn stderr "SIGCONT received"
- updateBar' bar
-
-renderInitialBlocks :: MainOptions -> Handle -> Filter -> IO C8.ByteString
-renderInitialBlocks options handle blockFilter = do
- date <- dateBlockOutput
- let initialBlocks = [mkBlockState date]
- -- Attach spinner indicator when verbose flag is set
- let initialBlocks' = if indicator options then initialBlocks <> [mkBlockState $ mkBlockOutput . normalText $ "*"] else initialBlocks
- -- Render initial time block so the bar is not empty after startup
- renderLine options handle blockFilter initialBlocks' ""
-
runBarServer :: BarIO () -> MainOptions -> IO ()
-runBarServer defaultBarConfig options = do
- putStrLn "{\"version\":1,\"click_events\":true}"
- putStrLn "["
-
- runBarHost (\newBlockChan barUpdateEvent -> do
-
-
- -- Create IORef to contain the active filter
- let initialBlockFilter = StaticFilter None
- activeFilter <- liftIO $ newIORef initialBlockFilter
-
- -- Create IORef for event handlers
- eventHandlerListIORef <- liftIO $ newIORef []
-
- let handle = Handle {
- handleActionList = eventHandlerListIORef,
- handleActiveFilter = activeFilter
- }
-
- initialOutput <- liftIO $ renderInitialBlocks options handle initialBlockFilter
-
- bar <- askBar
- -- Fork stdin handler
- liftIO $ void $ forkFinally (runBarIO bar (handleStdin options eventHandlerListIORef)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
-
-
- loadBlocks
-
- -- Install signal handler for SIGCONT
- installSignalHandlers
-
- -- Create control socket
- commandChan <- liftIO createCommandChan
- controlSocketAsync <- liftIO $ listenUnixSocketAsync options commandChan
- liftIO $ link controlSocketAsync
-
- -- Update bar on control socket messages
- socketUpdateAsync <- liftIO $ async $ forever $ do
- command <- atomically $ readTChan commandChan
- case command of
- SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
- Block -> error "TODO"
- updateBar' bar
- liftIO $ link socketUpdateAsync
-
- renderLoop options handle barUpdateEvent initialOutput newBlockChan
- )
- where
- loadBlocks :: BarIO ()
- loadBlocks = do
- when (indicator options) $ addBlock renderIndicator
-
- defaultBarConfig
-
-
+runBarServer defaultBarConfig options = runBarHost barServer (swayBarInput options)
+ where
+ barServer :: Consumer [BlockOutput] BarIO ()
+ barServer = do
+ -- Create IORef to contain the active filter
+ let initialBlockFilter = StaticFilter None
+ activeFilter <- liftIO $ newIORef initialBlockFilter
+
+ -- Load blocks
+ lift $ do
+ when (indicator options) $ addBlock renderIndicator
+ defaultBarConfig
+
+ -- Create control socket
+ commandChan <- liftIO createCommandChan
+ controlSocketAsync <- liftIO $ listenUnixSocketAsync options commandChan
+ liftIO $ link controlSocketAsync
+
+ bar <- askBar
+
+ -- Update bar on control socket messages
+ socketUpdateAsync <- liftIO $ async $ forever $ do
+ command <- atomically $ readTChan commandChan
+ case command of
+ SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
+ Block -> error "TODO"
+ updateBar' bar
+ liftIO $ link socketUpdateAsync
+
+ swayBarOutput options
createCommandChan :: IO CommandChan
createCommandChan = newTChanIO
--
GitLab