From e85043c6412b1745c5734bf0eac044b27472f140 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Sun, 1 Dec 2019 04:43:39 +0100
Subject: [PATCH] Refactor: Introduce BarIO monad that can add blocks and
update the bar
---
src/QBar/Core.hs | 129 +++++++++++++++++++++++---------------
src/QBar/DefaultConfig.hs | 13 ++--
src/QBar/Server.hs | 113 ++++++++++++++++++---------------
3 files changed, 146 insertions(+), 109 deletions(-)
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 2e76522..b8eb7b1 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -7,10 +7,12 @@ import QBar.Pango
import Control.Exception (catch, finally, IOException)
import Control.Monad (forever)
+import Control.Monad.Reader (ReaderT, runReaderT, ask, asks)
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.Event as Event
import Control.Concurrent.MVar
+import Control.Concurrent.STM.TChan (TChan, writeTChan)
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as C8
import qualified Data.HashMap.Lazy as HM
@@ -29,19 +31,19 @@ import System.Process.Typed (shell, withProcessWait, setStdin, setStdout, getStd
import Data.Colour.RGBSpace
-data BlockOutput = BlockOutput {
- values :: HM.HashMap T.Text T.Text,
- clickAction :: Maybe (Click -> IO ())
-}
-instance Show BlockOutput where
- show BlockOutput{values} = show values
-
data Click = Click {
name :: T.Text,
button :: Int
} deriving Show
$(deriveJSON defaultOptions ''Click)
+data BlockOutput = BlockOutput {
+ values :: HM.HashMap T.Text T.Text,
+ clickAction :: Maybe (Click -> BarIO ())
+}
+instance Show BlockOutput where
+ show BlockOutput{values} = show values
+
data PushMode = PushMode
data PullMode = PullMode
data CachedMode = CachedMode
@@ -55,7 +57,7 @@ type PullBlock = Producer BlockOutput IO PullMode
type CachedBlock = Producer BlockOutput IO CachedMode
class IsBlock a where
- toCachedBlock :: BarUpdateChannel -> a -> CachedBlock
+ toCachedBlock :: Bar -> a -> CachedBlock
instance IsBlock PushBlock where
toCachedBlock = cachePushBlock
instance IsBlock CachedBlock where
@@ -71,11 +73,18 @@ instance IsBlockMode CachedMode where
exitBlock = return CachedMode
+type BarIO a = ReaderT Bar IO a
+
+data Bar = Bar {
+ requestBarUpdate :: IO (),
+ newBlockChan :: TChan CachedBlock
+}
+
data BarUpdateChannel = BarUpdateChannel (IO ())
type BarUpdateEvent = Event.Event
-type BarConfiguration = BarUpdateChannel -> Producer CachedBlock IO ()
+type BarConfiguration = BarIO ()
defaultColor :: T.Text
@@ -180,17 +189,17 @@ cacheFromInput input = fmap (\_ -> CachedMode) $ fromInput input
-- | Create a shared interval. Takes a BarUpdateChannel to signal bar updates and an interval (in seconds).Data.Maybe
-- Returns an IO action that can be used to attach blocks to the shared interval and an async that contains a reference to the scheduler thread.
-sharedInterval :: BarUpdateChannel -> Int -> IO (PullBlock -> CachedBlock, Async ())
-sharedInterval barUpdateChannel seconds = do
- clientsMVar <- newMVar ([] :: [(MVar PullBlock, Output BlockOutput)])
+sharedInterval :: Int -> BarIO (PullBlock -> CachedBlock, Async ())
+sharedInterval seconds = do
+ clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output BlockOutput)])
- task <- async $ forever $ do
- threadDelay $ seconds * 1000000
+ task <- barAsync $ forever $ do
+ liftIO $ threadDelay $ seconds * 1000000
-- Updates all client blocks
-- If send returns 'False' the clients mailbox has been closed, so it is removed
- modifyMVar_ clientsMVar (fmap catMaybes . mapConcurrently runAndFilterClient)
+ liftIO $ modifyMVar_ clientsMVar (fmap catMaybes . mapConcurrently runAndFilterClient)
-- Then update the bar
- updateBar barUpdateChannel
+ updateBar
return (addClient clientsMVar, task)
where
@@ -214,17 +223,17 @@ sharedInterval barUpdateChannel seconds = do
-- Mailbox is sealed, stop running producer
else return (exitBlock, False)
where
- updateClickHandler :: BlockOutput -> Click -> IO ()
+ updateClickHandler :: BlockOutput -> Click -> BarIO ()
updateClickHandler block _ = do
-- Give user feedback that the block is updating
let outdatedBlock = setColor updatingColor $ removePango block
- void $ atomically $ send output $ outdatedBlock
+ lift $ void $ atomically $ send output $ outdatedBlock
-- Notify bar about changed block state to display the feedback
- updateBar barUpdateChannel
+ updateBar
-- Run a normal block update to update the block to the new value
- void $ runClient (blockProducerMVar, output)
+ lift $ void $ runClient (blockProducerMVar, output)
-- Notify bar about changed block state, this is usually done by the shared interval handler
- updateBar barUpdateChannel
+ updateBar
addClient :: MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock
addClient clientsMVar blockProducer = do
-- Spawn the mailbox that preserves the latest block
@@ -259,29 +268,31 @@ blockScript path = forever $ yield =<< (lift $ blockScriptAction)
createScriptBlock :: T.Text -> BlockOutput
createScriptBlock text = pangoMarkup $ setBlockName (T.pack path) $ createBlock text
-startPersistentBlockScript :: BarUpdateChannel -> FilePath -> CachedBlock
+startPersistentBlockScript :: FilePath -> BarIO 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 barUpdateChannel path = do
- (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
- initialDataEvent <- lift $ Event.new
- task <- lift $ async $ do
- let processConfig = setStdin closed $ setStdout createPipe $ shell path
- finally (
- catch (
- withProcessWait processConfig $ \ process -> do
- let handle = getStdout process
- runEffect $ (fromHandle handle) >-> signalFirstBlock initialDataEvent >-> toOutput output
- )
- ( \ e ->
- -- output error
- runEffect $ (yield $ createErrorBlock $ "[" <> (T.pack $ show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
+startPersistentBlockScript path = do
+ bar <- ask
+ return $ do
+ (output, input, seal) <- lift $ spawn' $ latest $ emptyBlock
+ initialDataEvent <- lift $ Event.new
+ task <- lift $ async $ do
+ let processConfig = setStdin closed $ setStdout createPipe $ shell path
+ finally (
+ catch (
+ withProcessWait processConfig $ \ process -> do
+ let handle = getStdout process
+ runEffect $ (fromHandle bar handle) >-> signalFirstBlock initialDataEvent >-> toOutput output
+ )
+ ( \ e ->
+ -- output error
+ runEffect $ (yield $ createErrorBlock $ "[" <> (T.pack $ show (e :: IOException)) <> "]") >-> signalFirstBlock initialDataEvent >-> toOutput output
+ )
)
- )
- (atomically seal)
- lift $ link task
- lift $ Event.wait initialDataEvent
- cacheFromInput input
+ (atomically seal)
+ lift $ link task
+ lift $ Event.wait initialDataEvent
+ cacheFromInput input
where
signalFirstBlock :: Event.Event -> Pipe BlockOutput BlockOutput IO ()
signalFirstBlock event = do
@@ -290,11 +301,11 @@ startPersistentBlockScript barUpdateChannel path = do
lift $ Event.set event
-- Replace with cat
cat
- fromHandle :: Handle -> Producer BlockOutput IO ()
- fromHandle handle = forever $ do
+ fromHandle :: Bar -> Handle -> Producer BlockOutput IO ()
+ fromHandle bar handle = forever $ do
line <- lift $ TIO.hGetLine handle
yield $ pangoMarkup $ createBlock line
- lift $ updateBar barUpdateChannel
+ lift $ updateBar'' bar
pangoColor :: RGB Double -> T.Text
pangoColor (RGB r g b) =
@@ -310,11 +321,29 @@ pangoColor (RGB r g b) =
padding = if len == 1 then "0" else ""
in padding <> hex
-updateBar :: BarUpdateChannel -> IO ()
-updateBar (BarUpdateChannel updateAction) = updateAction
-cachePushBlock :: BarUpdateChannel -> PushBlock -> CachedBlock
-cachePushBlock barUpdateChannel pushBlock =
+addBlock :: IsBlock a => a -> BarIO ()
+addBlock block = do
+ newBlockChan' <- asks newBlockChan
+ cachedBlock <- asks toCachedBlock <*> return block
+ liftIO $ atomically $ writeTChan newBlockChan' cachedBlock
+
+updateBar :: BarIO ()
+updateBar = liftIO =<< asks requestBarUpdate
+
+updateBar' :: BarUpdateChannel -> IO ()
+updateBar' (BarUpdateChannel updateAction) = updateAction
+
+updateBar'' :: Bar -> IO ()
+updateBar'' = updateBar' . BarUpdateChannel . requestBarUpdate
+
+barAsync :: BarIO a -> BarIO (Async a)
+barAsync action = do
+ bar <- ask
+ lift $ async $ runReaderT action bar
+
+cachePushBlock :: Bar -> PushBlock -> CachedBlock
+cachePushBlock bar pushBlock =
lift (next pushBlock) >>= either (\_ -> exitBlock) withInitialBlock
where
withInitialBlock :: (BlockOutput, PushBlock) -> CachedBlock
@@ -327,14 +356,14 @@ cachePushBlock barUpdateChannel pushBlock =
sendProducerToMailbox output seal pushBlock' = do
void $ runEffect $ for pushBlock' (sendOutputToMailbox output)
atomically $ void $ send output Nothing
- updateBar barUpdateChannel
+ updateBar'' bar
atomically seal
sendOutputToMailbox :: Output (Maybe BlockOutput) -> BlockOutput -> Effect IO ()
sendOutputToMailbox output blockOutput = lift $ 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 barUpdateChannel
+ updateBar'' bar
terminateOnMaybe :: Producer (Maybe BlockOutput) IO () -> Producer BlockOutput IO CachedMode
terminateOnMaybe p = do
eitherMaybeValue <- lift $ next p
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index 39b8e27..6776b04 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -9,9 +9,9 @@ import Pipes
blockLocation :: String -> FilePath
blockLocation name = "~/.config/qbar/blocks/" <> name
-generateDefaultBarConfig :: BarUpdateChannel -> Producer CachedBlock IO ()
-generateDefaultBarConfig barUpdateChannel = do
- (systemInfoInterval, systemInfoIntervalTask) <- lift $ sharedInterval barUpdateChannel 10
+generateDefaultBarConfig :: BarIO ()
+generateDefaultBarConfig = do
+ (systemInfoInterval, systemInfoIntervalTask) <- sharedInterval 10
lift $ link systemInfoIntervalTask
let todo = (systemInfoInterval $ blockScript $ blockLocation "todo")
@@ -20,7 +20,7 @@ generateDefaultBarConfig barUpdateChannel = 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
- let volumeBlock = startPersistentBlockScript barUpdateChannel $ blockLocation "volume-pulseaudio -S -F3"
+ volumeBlock <- startPersistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
let battery = (systemInfoInterval $ blockScript $ blockLocation "battery2")
addBlock dateBlock
@@ -31,7 +31,4 @@ generateDefaultBarConfig barUpdateChannel = do
addBlock cpu
addBlock networkEnvironment
addBlock wifi
- addBlock todo
- where
- addBlock :: IsBlock a => a -> Producer CachedBlock IO ()
- addBlock block = yield $ toCachedBlock barUpdateChannel block
\ No newline at end of file
+ addBlock todo
\ No newline at end of file
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index faf6460..c1e83c1 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -8,28 +8,28 @@ import QBar.Cli
import QBar.ControlSocket
import QBar.Filter
-import Control.Monad (forever, when, unless, forM_)
+import Control.Monad (forever, when, unless)
+import Control.Monad.Reader (runReaderT, ask)
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, writeTChan, tryReadTChan)
+import Control.Concurrent.STM.TChan (TChan, newTChanIO, readTChan, tryReadTChan)
import Data.Aeson (encode, decode)
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 (isJust, fromJust, fromMaybe, catMaybes, mapMaybe)
+import Data.Maybe (isJust, fromJust, catMaybes, mapMaybe)
import qualified Data.Text.Lazy as T
import Data.Time.Clock.POSIX
import Pipes
-import Pipes.Prelude (toListM)
import System.IO (stdin, stdout, stderr, hFlush, hPutStrLn)
import System.Posix.Signals
data Handle = Handle {
- handleActionList :: IORef [(T.Text, Click -> IO ())],
+ handleActionList :: IORef [(T.Text, Click -> BarIO ())],
handleActiveFilter :: IORef Filter
}
@@ -101,9 +101,9 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks prev
return encodedOutput
where
- clickActionList :: [(T.Text, Click -> IO ())]
+ clickActionList :: [(T.Text, Click -> BarIO ())]
clickActionList = mapMaybe getClickAction blocks
- getClickAction :: BlockOutput -> Maybe (T.Text, Click -> IO ())
+ getClickAction :: BlockOutput -> Maybe (T.Text, Click -> BarIO ())
getClickAction block = if hasBlockName && hasClickAction then Just (fromJust maybeBlockName, fromJust maybeClickAction) else Nothing
where
maybeBlockName = getBlockName block
@@ -111,31 +111,35 @@ renderLine MainOptions{verbose} Handle{handleActionList} blockFilter blocks prev
maybeClickAction = clickAction block
hasClickAction = isJust maybeClickAction
-createBarUpdateChannel :: IO (BarUpdateChannel, BarUpdateEvent)
+createBarUpdateChannel :: IO (IO (), BarUpdateEvent)
createBarUpdateChannel = do
event <- Event.newSet
- return (BarUpdateChannel $ Event.set event, event)
-
-handleStdin :: MainOptions -> IORef [(T.Text, Click -> IO ())] -> IO ()
-handleStdin options actionListIORef = forever $ do
- line <- BSSC8.hGetLine stdin
-
- unless (line == "[") $ do
- -- Echo input to stderr when verbose flag is set
- when (verbose options) $ do
- BSSC8.hPutStrLn stderr line
- hFlush stderr
-
- let maybeClick = decode $ removeComma $ BS.fromStrict line
- case maybeClick of
- Just click -> do
- clickActionList <- readIORef actionListIORef
- let clickAction' = getClickAction clickActionList click
- async ((fromMaybe discard clickAction') click) >>= link
- Nothing -> return ()
+ return (Event.set event, event)
+
+handleStdin :: MainOptions -> IORef [(T.Text, Click -> BarIO ())] -> BarIO ()
+handleStdin options actionListIORef = do
+ bar <- ask
+ liftIO $ forever $ do
+ line <- BSSC8.hGetLine stdin
+
+ unless (line == "[") $ do
+ -- Echo input to stderr when verbose flag is set
+ when (verbose options) $ do
+ BSSC8.hPutStrLn stderr line
+ hFlush stderr
+
+ let maybeClick = decode $ removeComma $ BS.fromStrict line
+ case maybeClick of
+ Just click -> do
+ clickActionList <- readIORef actionListIORef
+ let maybeClickAction = getClickAction clickActionList click
+ case maybeClickAction of
+ Just clickAction' -> async (runReaderT (clickAction' click) bar) >>= link
+ Nothing -> return ()
+ Nothing -> return ()
where
- getClickAction :: [(T.Text, Click -> IO ())] -> Click -> Maybe (Click -> IO ())
+ getClickAction :: [(T.Text, Click -> BarIO ())] -> Click -> Maybe (Click -> BarIO ())
getClickAction clickActionList click = lookup (name click) clickActionList
removeComma :: C8.ByteString -> C8.ByteString
removeComma line
@@ -149,24 +153,14 @@ installSignalHandlers barUpdateChannel = void $ installHandler sigCONT (Catch si
sigContAction :: IO ()
sigContAction = do
hPutStrLn stderr "SIGCONT received"
- updateBar barUpdateChannel
+ updateBar' barUpdateChannel
-runBarConfiguration :: (BarUpdateChannel -> Producer CachedBlock IO ()) -> MainOptions -> IO ()
+runBarConfiguration :: BarConfiguration -> MainOptions -> IO ()
runBarConfiguration generateBarConfig options = do
- -- Create IORef for mouse click callbacks
- actionList <- newIORef []
- --link =<< async (handleStdin options actionList)
- void $ forkFinally (handleStdin options actionList) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
-
-- Create IORef to contain the active filter
let initialBlockFilter = StaticFilter None
activeFilter <- newIORef initialBlockFilter
- let handle = Handle {
- handleActionList = actionList,
- handleActiveFilter = activeFilter
- }
-
putStrLn "{\"version\":1,\"click_events\":true}"
putStrLn "["
@@ -176,21 +170,31 @@ runBarConfiguration generateBarConfig options = do
-- Attach spinner indicator when verbose flag is set
let initialBlocks' = if indicator options then initialBlocks <> [createBlock "*"] else initialBlocks
+ (requestBarUpdate, barUpdateEvent) <- createBarUpdateChannel
+ -- TODO: should be removed
+ let barUpdateChannel = BarUpdateChannel requestBarUpdate
+
+ -- Create channel to send new block producers to render loop
+ newBlockChan <- newTChanIO
+
+ let bar = Bar { requestBarUpdate, newBlockChan }
+
+ -- Create IORef for mouse click callbacks
+ actionList <- newIORef []
+ let handle = Handle {
+ handleActionList = actionList,
+ handleActiveFilter = activeFilter
+ }
+
+
-- Render initial time block so the bar is not empty after startup
initialOutput <- renderLine options handle initialBlockFilter initialBlocks' ""
- -- Create and initialzie blocks
- (barUpdateChannel, barUpdateEvent) <- createBarUpdateChannel
- blocks <- toListM $ generateBarConfig barUpdateChannel
+ -- Fork stdin handler
+ void $ forkFinally (runReaderT (handleStdin options actionList) bar) (\result -> hPutStrLn stderr $ "handleStdin failed: " <> show result)
- -- Attach spinner indicator when verbose flag is set
- let blocks' = if indicator options then (renderIndicator:blocks) else blocks
- -- Create channel to send new block producers to render loop
- newBlocks <- newTChanIO
-
- -- Send initial block producers to render loop
- forM_ blocks' $ \ bp -> atomically $ writeTChan newBlocks bp
+ runReaderT loadBlocks bar
-- Install signal handler for SIGCONT
installSignalHandlers barUpdateChannel
@@ -206,9 +210,16 @@ runBarConfiguration generateBarConfig options = do
case command of
SetFilter blockFilter -> atomicWriteIORef activeFilter blockFilter
updateBar barUpdateChannel
+ updateBar' barUpdateChannel
link socketUpdateAsync
- renderLoop options handle barUpdateEvent initialOutput newBlocks
+ renderLoop options handle barUpdateEvent initialOutput newBlockChan
+ where
+ loadBlocks :: BarIO ()
+ loadBlocks = do
+ when (indicator options) $ addBlock renderIndicator
+ -- Evaluate config
+ generateBarConfig
createCommandChan :: IO CommandChan
createCommandChan = newTChanIO
--
GitLab