From 25b32f0f2ff01fd6928b363d7457ab9464c2c705 Mon Sep 17 00:00:00 2001
From: Jens Nolte <jens@nightmarestudio.de>
Date: Mon, 2 Dec 2019 04:06:06 +0100
Subject: [PATCH] Implement types for configuration file
---
src/QBar/Configuration.hs | 73 +++++++++++++++++++++++++++++++++++++++
src/QBar/Core.hs | 38 ++++++++++++--------
src/QBar/DefaultConfig.hs | 4 +--
src/QBar/Server.hs | 4 +--
4 files changed, 99 insertions(+), 20 deletions(-)
create mode 100644 src/QBar/Configuration.hs
diff --git a/src/QBar/Configuration.hs b/src/QBar/Configuration.hs
new file mode 100644
index 0000000..db02a5b
--- /dev/null
+++ b/src/QBar/Configuration.hs
@@ -0,0 +1,73 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+module QBar.Configuration where
+
+import QBar.Blocks
+import QBar.Core
+
+import Data.Aeson.TH
+import Data.Maybe (fromMaybe)
+import qualified Data.Text.Lazy as T
+import Control.Monad.Reader
+import Pipes
+
+data BarConfiguration = BarConfiguration {
+ intervalSeconds :: Maybe Int,
+ blocks :: [BlockConfiguration]
+}
+
+data BlockConfiguration = Modify ModifyConfiguration
+ | Date
+ | ExternalCommand ExternalCommandConfiguration
+
+data ModifyConfiguration = ModifyConfiguration {
+ block :: BlockConfiguration,
+ enableAutoPadding :: Maybe Bool,
+ icon :: Maybe T.Text
+}
+
+data ExternalCommandConfiguration = ExternalCommandConfiguration {
+ command :: FilePath,
+ persistent :: Maybe Bool
+}
+
+$(deriveJSON defaultOptions ''BarConfiguration)
+$(deriveJSON defaultOptions ''BlockConfiguration)
+$(deriveJSON defaultOptions ''ModifyConfiguration)
+$(deriveJSON defaultOptions ''ExternalCommandConfiguration)
+
+
+type ConfigurationM = Reader (PullBlock -> CachedBlock)
+
+cachePullBlock :: PullBlock -> ConfigurationM CachedBlock
+cachePullBlock pullBlock = ask <*> return pullBlock
+
+
+
+applyBarConfiguration :: BarConfiguration -> BarIO ()
+applyBarConfiguration barConfiguration@BarConfiguration{ intervalSeconds } = do
+ cachePullBlock' <- sharedInterval $ fromMaybe 10 intervalSeconds
+ let blocks' = runReader (evaluateBarConfiguration barConfiguration) cachePullBlock'
+ mapM_ addBlock blocks'
+
+evaluateBarConfiguration :: BarConfiguration -> ConfigurationM [CachedBlock]
+evaluateBarConfiguration BarConfiguration { blocks } = mapM evaluateBlockConfiguration blocks
+
+
+evaluateBlockConfiguration :: BlockConfiguration -> ConfigurationM CachedBlock
+
+evaluateBlockConfiguration (Modify ModifyConfiguration { enableAutoPadding, icon, block }) = do
+ block' <- evaluateBlockConfiguration block
+ let block'' = case icon of
+ Just icon' -> block' >-> modify (addIcon icon')
+ Nothing -> block'
+ let block''' = if enableAutoPadding == Just True
+ then block'' >-> autoPadding
+ else block''
+ return block'''
+
+evaluateBlockConfiguration Date = return $ toCachedBlock dateBlock
+
+evaluateBlockConfiguration (ExternalCommand ExternalCommandConfiguration { command, persistent }) = if fromMaybe False persistent
+ then return $ startPersistentBlockScript command
+ else cachePullBlock $ blockScript command
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 0e90b35..a280586 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -86,8 +86,6 @@ data BarUpdateChannel = BarUpdateChannel (IO ())
type BarUpdateEvent = Event.Event
-type BarConfiguration = BarIO ()
-
defaultColor :: T.Text
defaultColor = "#969896"
@@ -187,24 +185,31 @@ autoPadding = autoPadding' 0 0
autoPadding' (max fullLength fullLength') (max shortLength shortLength')
cacheFromInput :: Input BlockOutput -> CachedBlock
-cacheFromInput input = fmap (\_ -> CachedMode) $ fromInput input
+cacheFromInput input = const 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 :: Int -> BarIO (PullBlock -> CachedBlock, Async ())
+sharedInterval :: Int -> BarIO (PullBlock -> CachedBlock)
sharedInterval seconds = do
clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output BlockOutput)])
- 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
- bar <- ask
- liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (\r -> runReaderT (runAndFilterClient r) bar)
- -- Then update the bar
- updateBar
+ startEvent <- liftIO Event.new
+
+ task <- barAsync $ do
+ -- Wait for at least one subscribed client
+ liftIO $ Event.wait startEvent
+ forever $ do
+ liftIO $ threadDelay $ seconds * 1000000
+ -- Updates all client blocks
+ -- If send returns 'False' the clients mailbox has been closed, so it is removed
+ bar <- ask
+ liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (\r -> runReaderT (runAndFilterClient r) bar)
+ -- Then update the bar
+ updateBar
+
+ liftIO $ link task
- return (addClient clientsMVar, task)
+ return (addClient startEvent clientsMVar)
where
runAndFilterClient :: (MVar PullBlock, Output BlockOutput) -> BarIO (Maybe (MVar PullBlock, Output BlockOutput))
runAndFilterClient client = do
@@ -238,8 +243,8 @@ sharedInterval seconds = do
void $ runClient (blockProducerMVar, output)
-- Notify bar about changed block state, this is usually done by the shared interval handler
updateBar
- addClient :: MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock
- addClient clientsMVar blockProducer = do
+ addClient :: Event.Event -> MVar [(MVar PullBlock, Output BlockOutput)] -> PullBlock -> CachedBlock
+ addClient startEvent clientsMVar blockProducer = do
-- Spawn the mailbox that preserves the latest block
(output, input) <- liftIO $ spawn $ latest emptyBlock
@@ -251,6 +256,9 @@ sharedInterval seconds = do
-- Register the client for regular updates
liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockProducerMVar, output):clients)
+ -- Start update thread (if not already started)
+ liftIO $ Event.set startEvent
+
-- Return a block producer from the mailbox
cacheFromInput input
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index 1d43b5d..aeaee53 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -3,7 +3,6 @@ module QBar.DefaultConfig where
import QBar.Blocks
import QBar.Core
-import Control.Concurrent.Async
import Pipes
blockLocation :: String -> FilePath
@@ -11,8 +10,7 @@ blockLocation name = "~/.config/qbar/blocks/" <> name
generateDefaultBarConfig :: BarIO ()
generateDefaultBarConfig = do
- (systemInfoInterval, systemInfoIntervalTask) <- sharedInterval 10
- lift $ link systemInfoIntervalTask
+ systemInfoInterval <- sharedInterval 10
let todo = systemInfoInterval (blockScript $ blockLocation "todo")
let wifi = systemInfoInterval (blockScript $ blockLocation "wifi2 wlan") >-> modify (addIcon "📡")
diff --git a/src/QBar/Server.hs b/src/QBar/Server.hs
index d2bd71e..f5f2aca 100644
--- a/src/QBar/Server.hs
+++ b/src/QBar/Server.hs
@@ -155,7 +155,7 @@ installSignalHandlers barUpdateChannel = void $ installHandler sigCONT (Catch si
hPutStrLn stderr "SIGCONT received"
updateBar' barUpdateChannel
-runBarConfiguration :: BarConfiguration -> MainOptions -> IO ()
+runBarConfiguration :: BarIO () -> MainOptions -> IO ()
runBarConfiguration generateBarConfig options = do
-- Create IORef to contain the active filter
let initialBlockFilter = StaticFilter None
@@ -225,7 +225,7 @@ createCommandChan :: IO CommandChan
createCommandChan = newTChanIO
-- |Entry point.
-runQBar :: BarConfiguration -> MainOptions -> IO ()
+runQBar :: BarIO () -> MainOptions -> IO ()
runQBar barConfiguration options@MainOptions{barCommand} = runCommand barCommand
where
runCommand BarServer = runBarConfiguration barConfiguration options
--
GitLab