Implement types for configuration file

src/QBar/Configuration.hs

+{-# 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

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
 

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 "📡")

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