diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs new file mode 100644 index 0000000000000000000000000000000000000000..dfb8f58b477befd8a95773fdaece839366a2cfdd --- /dev/null +++ b/src/QBar/Host.hs @@ -0,0 +1,18 @@ +module QBar.Host where + +import QBar.Core + +import Control.Concurrent.Event as Event +import Control.Concurrent.STM.TChan (TChan, newTChanIO) + +runBarHost :: (TChan CachedBlock -> BarUpdateEvent -> BarIO ()) -> IO () +runBarHost host = do + -- Create an event used to signal bar updates + barUpdateEvent <- Event.newSet + let requestBarUpdate = Event.set barUpdateEvent + + -- Create channel to send new block producers to render loop + newBlockChan <- newTChanIO + + let bar = Bar { requestBarUpdate, newBlockChan } + runBarIO bar (host newBlockChan barUpdateEvent) diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs index c105ce2e53eb62563d24a607f849479c6563b532..ad918d4b806415cb0e6c072b69bcfb7735c2f5e9 100644 --- a/src/QBar/Server.hs +++ b/src/QBar/Server.hs @@ -1,11 +1,12 @@ module QBar.Server where import QBar.Blocks +import QBar.BlockText import QBar.Core import QBar.Cli import QBar.ControlSocket import QBar.Filter -import QBar.BlockText +import QBar.Host import QBar.Themes import Control.Monad (forever, when, unless) @@ -189,62 +190,59 @@ renderInitialBlocks options handle blockFilter = do runBarServer :: BarIO () -> MainOptions -> IO () runBarServer defaultBarConfig options = do - putStrLn "{\"version\":1,\"click_events\":true}" putStrLn "[" - (requestBarUpdate, barUpdateEvent) <- createBarUpdateChannel + runBarHost (\newBlockChan barUpdateEvent -> do - -- Create channel to send new block producers to render loop - newBlockChan <- newTChanIO - let bar = Bar { requestBarUpdate, newBlockChan } + -- Create IORef to contain the active filter + let initialBlockFilter = StaticFilter None + activeFilter <- liftIO $ newIORef initialBlockFilter - -- Create IORef to contain the active filter - let initialBlockFilter = StaticFilter None - activeFilter <- newIORef initialBlockFilter + -- Create IORef for event handlers + eventHandlerListIORef <- liftIO $ newIORef [] - -- Create IORef for event handlers - eventHandlerListIORef <- newIORef [] + let handle = Handle { + handleActionList = eventHandlerListIORef, + handleActiveFilter = activeFilter + } - let handle = Handle { - handleActionList = eventHandlerListIORef, - handleActiveFilter = activeFilter - } + initialOutput <- liftIO $ renderInitialBlocks options handle initialBlockFilter - initialOutput <- renderInitialBlocks options handle initialBlockFilter + bar <- askBar + -- Fork stdin handler + liftIO $ void $ forkFinally (runBarIO bar (handleStdin options eventHandlerListIORef)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result) - -- Fork stdin handler - void $ forkFinally (runBarIO bar (handleStdin options eventHandlerListIORef)) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result) + loadBlocks + -- Install signal handler for SIGCONT + installSignalHandlers - runBarIO bar loadBlocks + -- Create control socket + commandChan <- liftIO createCommandChan + controlSocketAsync <- liftIO $ listenUnixSocketAsync options commandChan + liftIO $ link controlSocketAsync - -- Install signal handler for SIGCONT - runBarIO bar installSignalHandlers - - -- Create control socket - commandChan <- createCommandChan - controlSocketAsync <- listenUnixSocketAsync options commandChan - 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 - -- Update bar on control socket messages - socketUpdateAsync <- async $ forever $ do - command <- atomically $ readTChan commandChan - case command of - SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter - Block -> error "TODO" - updateBar' bar - link socketUpdateAsync + renderLoop options handle barUpdateEvent initialOutput newBlockChan + ) + where + loadBlocks :: BarIO () + loadBlocks = do + when (indicator options) $ addBlock renderIndicator - runBarIO bar (renderLoop options handle barUpdateEvent initialOutput newBlockChan) - where - loadBlocks :: BarIO () - loadBlocks = do - when (indicator options) $ addBlock renderIndicator + defaultBarConfig - defaultBarConfig createCommandChan :: IO CommandChan