diff --git a/package.yaml b/package.yaml
index d656997f871e419cf9965b63f939614f053fb816..f261c960de2cb9483b1fee6c3cc92cec63a92f69 100644
--- a/package.yaml
+++ b/package.yaml
@@ -40,6 +40,7 @@ dependencies:
- pipes-parse
- pipes-safe
- random
+- sorted-list
- stm
- text
- time
diff --git a/src/QBar/Cli.hs b/src/QBar/Cli.hs
index 63840065d720cda90165185845ff37621e1a9433..958fd951392200cd6b4f90556fa8b6da5ff1d2a3 100644
--- a/src/QBar/Cli.hs
+++ b/src/QBar/Cli.hs
@@ -69,7 +69,8 @@ barConfigurationParser = do
blockParser :: Parser (BarIO ())
blockParser = subparser (
commandGroup "Available blocks:" <>
- command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block."))
+ command "date" (info (pure $ addBlock dateBlock) (progDesc "Load the date and time block.")) <>
+ command "cpu" (info (pure $ addBlock $ cpuUsageBlock 1) (progDesc "Load the cpu usage block."))
)
<|>
subparser (
diff --git a/src/QBar/Core.hs b/src/QBar/Core.hs
index 276299afe7f9588dd2d876e8f80c265890b130bd..d318a7fb0d2280efbfd256bb32362b46be543f56 100644
--- a/src/QBar/Core.hs
+++ b/src/QBar/Core.hs
@@ -5,8 +5,8 @@ module QBar.Core where
import QBar.BlockOutput
import QBar.TagParser
+import QBar.Time
-import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Concurrent.Event as Event
import Control.Concurrent.MVar
@@ -18,8 +18,8 @@ import Control.Monad.State (StateT)
import Control.Monad.Writer (WriterT)
import Data.Aeson.TH
import qualified Data.ByteString.Lazy.Char8 as C8
+import Data.Either (isRight)
import Data.Int (Int64)
-import Data.Maybe (catMaybes)
import qualified Data.Text.Lazy as T
import qualified Data.Text.Lazy.Encoding as E
import qualified Data.Text.Lazy.IO as TIO
@@ -71,6 +71,8 @@ class IsCachable a where
instance IsCachable PushBlock where
toCachedBlock = cachePushBlock
+instance IsCachable PullBlock where
+ toCachedBlock = toCachedBlock . schedulePullBlock
instance IsCachable BlockCache where
toCachedBlock = id
@@ -89,8 +91,13 @@ type BarIO = SafeT (ReaderT Bar IO)
data Bar = Bar {
requestBarUpdate :: IO (),
- newBlockChan :: TChan BlockCache
+ newBlockChan :: TChan BlockCache,
+ barSleepScheduler :: SleepScheduler
}
+instance HasSleepScheduler BarIO where
+ askSleepScheduler = barSleepScheduler <$> askBar
+instance HasSleepScheduler (Proxy a' a b' b BarIO) where
+ askSleepScheduler = lift askSleepScheduler
newtype BarUpdateChannel = BarUpdateChannel (IO ())
@@ -142,11 +149,50 @@ updateEventHandler :: BlockEventHandler -> BlockState -> BlockState
updateEventHandler _ Nothing = Nothing
updateEventHandler eventHandler (Just (blockOutput, _)) = Just (blockOutput, Just eventHandler)
+hasEventHandler :: BlockState -> Bool
+hasEventHandler (Just (_, Just _)) = True
+hasEventHandler _ = False
+
+invalidateBlockState :: BlockState -> BlockState
+invalidateBlockState Nothing = Nothing
+invalidateBlockState (Just (output, eventHandler)) = Just (invalidateBlock output, eventHandler)
+
runBarIO :: Bar -> BarIO r -> IO r
runBarIO bar action = runReaderT (runSafeT action) bar
+defaultInterval :: Interval
+defaultInterval = everyNSeconds 10
+
+schedulePullBlock :: PullBlock -> PushBlock
+schedulePullBlock pullBlock = PushMode <$ pullBlock >-> sleepToNextInterval
+ where
+ sleepToNextInterval :: Pipe BlockState BlockState BarIO PullMode
+ sleepToNextInterval = do
+ event <- liftIO Event.new
+ forever $ do
+ state <- await
+ if hasEventHandler state
+ then do
+ -- If state already has an event handler, we do not attach another one
+ yield state
+ sleepUntilInterval defaultInterval
+ else do
+ -- Attach a click handler that will trigger a block update
+ yield $ updateEventHandler (triggerOnClick event) state
+
+ scheduler <- askSleepScheduler
+ result <- liftIO $ do
+ timerTask <- async $ sleepUntilInterval' scheduler defaultInterval
+ eventTask <- async $ Event.wait event
+ waitEitherCancel timerTask eventTask
+
+ when (isRight result) $ yield $ invalidateBlockState state
+
+ triggerOnClick :: Event -> BlockEvent -> BarIO ()
+ triggerOnClick event _ = liftIO $ Event.signal event
+
newCache :: Producer [BlockState] IO () -> BlockCache
newCache input = newCacheInternal =<< newCache''
where
@@ -228,81 +274,6 @@ autoPadding = autoPadding' 0 0
padShortText len = over (shortText._Just) $ \s -> padString (len - printedLength s) <> s
--- | 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 -> BlockCache)
-sharedInterval seconds = do
- clientsMVar <- liftIO $ newMVar ([] :: [(MVar PullBlock, Output BlockState)])
-
- 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 <- askBar
- liftIO $ modifyMVar_ clientsMVar $ fmap catMaybes . mapConcurrently (runBarIO bar . runAndFilterClient)
- -- Then update the bar
- updateBar
-
- liftIO $ link task
-
- return (addClient startEvent clientsMVar)
- where
- runAndFilterClient :: (MVar PullBlock, Output BlockState) -> BarIO (Maybe (MVar PullBlock, Output BlockState))
- runAndFilterClient client = do
- result <- runClient client
- return $ if result then Just client else Nothing
- runClient :: (MVar PullBlock, Output BlockState) -> BarIO Bool
- runClient (blockMVar, output) = do
- bar <- askBar
- liftIO $ modifyMVar blockMVar $ \blockProducer -> do
- result <- runReaderT (runSafeT $ next blockProducer) bar
- case result of
- Left _ -> return (exitBlock, False)
- Right (blockState, blockProducer') -> do
- success <- atomically $ send output $ updateEventHandler (updateClickHandler blockState) blockState
- if success
- -- Store new BlockProducer back into MVar
- then return (blockProducer', True)
- -- Mailbox is sealed, stop running producer
- else return (exitBlock, False)
- where
- updateClickHandler :: BlockState -> BlockEvent -> BarIO ()
- updateClickHandler Nothing _ = return ()
- updateClickHandler (Just (block, _)) _ = do
- -- Give user feedback that the block is updating
- let outdatedBlock = invalidateBlock block
- -- The invalidated block output has no event handler
- liftIO $ void $ atomically $ send output . Just $ (outdatedBlock, Nothing)
- -- Notify bar about changed block state to display the feedback
- updateBar
- -- Run a normal block update to update the block to the new value
- void $ runClient (blockMVar, output)
- -- Notify bar about changed block state, this is usually done by the shared interval handler
- updateBar
- addClient :: Event.Event -> MVar [(MVar PullBlock, Output BlockState)] -> PullBlock -> BlockCache
- addClient startEvent clientsMVar blockProducer = do
- -- Spawn the mailbox that preserves the latest block
- (output, input) <- liftIO $ spawn $ latest Nothing
-
- blockMVar <- liftIO $ newMVar blockProducer
-
- -- Generate initial block and send it to the mailbox
- lift $ void $ runClient (blockMVar, output)
-
- -- Register the client for regular updates
- liftIO $ modifyMVar_ clientsMVar $ \ clients -> return ((blockMVar, output):clients)
-
- -- Start update thread (if not already started)
- liftIO $ Event.set startEvent
-
- -- Return a block producer from the mailbox
- cacheFromInput input
-
blockScript :: FilePath -> PullBlock
blockScript path = forever $ updateBlock =<< (lift blockScriptAction)
where
diff --git a/src/QBar/DefaultConfig.hs b/src/QBar/DefaultConfig.hs
index 7fc58cd76e6292628aaff71f7812decb8f83605f..ac5ad0849ab304fbefe491505ccfe4b2b8a34b97 100644
--- a/src/QBar/DefaultConfig.hs
+++ b/src/QBar/DefaultConfig.hs
@@ -10,10 +10,8 @@ import Control.Lens
defaultBarConfig :: BarIO ()
defaultBarConfig = do
- systemInfoInterval <- sharedInterval 10
-
- let battery = systemInfoInterval $ batteryBlock >-> modify (blockName ?~ "battery")
- let cpuUsage = systemInfoInterval $ cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
+ let battery = batteryBlock >-> modify (blockName ?~ "battery")
+ let cpuUsage = cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
-- TODO: commented-out blocks should be added as soon as they are implemented in qbar
addBlock dateBlock
@@ -26,16 +24,14 @@ defaultBarConfig = do
legacyBarConfig :: BarIO ()
legacyBarConfig = do
- systemInfoInterval <- sharedInterval 10
-
- let todo = systemInfoInterval (blockScript $ blockLocation "todo")
- let wifi = systemInfoInterval $ (blockScript $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
- let networkEnvironment = systemInfoInterval (blockScript $ blockLocation "network-environment")
- let ram = systemInfoInterval $ (blockScript $ blockLocation "memory") >-> modify (addIcon "ðŸ\xFE0E") >-> autoPadding
- let temperature = systemInfoInterval $ (blockScript $ blockLocation "temperature") >-> autoPadding
+ let todo = blockScript $ blockLocation "todo"
+ let wifi = (blockScript $ blockLocation "wifi2") >-> modify (addIcon "📡\xFE0E")
+ let networkEnvironment = blockScript $ blockLocation "network-environment"
+ let ram = (blockScript $ blockLocation "memory") >-> modify (addIcon "ðŸ\xFE0E") >-> autoPadding
+ let temperature = (blockScript $ blockLocation "temperature") >-> autoPadding
let volumeBlock = persistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
- let battery = systemInfoInterval $ batteryBlock >-> modify (blockName ?~ "battery")
- let cpuUsage = systemInfoInterval $ cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
+ let battery = batteryBlock >-> modify (blockName ?~ "battery")
+ let cpuUsage = cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
addBlock dateBlock
addBlock battery
diff --git a/src/QBar/Host.hs b/src/QBar/Host.hs
index e191194a2eacd1463c156bb4e2d1add4bb930032..5934ceccf6c8b849cb7f7fb832e44a62862e3c4f 100644
--- a/src/QBar/Host.hs
+++ b/src/QBar/Host.hs
@@ -5,6 +5,7 @@ module QBar.Host where
import QBar.BlockOutput
import QBar.Core
+import QBar.Time
import Control.Concurrent (forkIO, forkFinally, threadDelay)
import Control.Concurrent.Event as Event
@@ -134,7 +135,9 @@ runBarHost createHost loadBlocks = do
-- Create channel to send new block producers to render loop
newBlockChan <- newTChanIO
- let bar = Bar { requestBarUpdate, newBlockChan }
+ barSleepScheduler <- createSleepScheduler
+
+ let bar = Bar { requestBarUpdate, newBlockChan, barSleepScheduler }
-- Install signal handler for SIGCONT
installSignalHandlers bar
diff --git a/src/QBar/Time.hs b/src/QBar/Time.hs
index fa205f22f91d0e2ebb76ec51ecbd40e515417eae..9add2437994cbdfeb397851e887e162b16ab02c9 100644
--- a/src/QBar/Time.hs
+++ b/src/QBar/Time.hs
@@ -1,23 +1,136 @@
-module QBar.Time (sleepUntil, nextMinute) where
+{-# LANGUAGE OverloadedLists #-}
-import Control.Concurrent (threadDelay)
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime)
+module QBar.Time (SleepScheduler, HasSleepScheduler(..), Interval, createSleepScheduler, sleepUntil, sleepUntil', sleepUntilInterval, sleepUntilInterval', everyMinute, everyNSeconds, nextIntervalTime) where
-sleepUntil :: UTCTime -> IO ()
-sleepUntil time = do
- now <- getCurrentTime
- let timeUntil = diffUTCTime time now
- when (timeUntil > 0) $
- if timeUntil > 1
- then threadDelay 1000000 >> sleepUntil time
- else threadDelay $ ceiling $ toRational timeUntil * 1000000
-
-nextMinute :: IO UTCTime
-nextMinute = do
+import Control.Concurrent.Async
+import Control.Concurrent.MVar
+import qualified Control.Concurrent.Event as Event
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Ord (comparing)
+
+newtype Interval = IntervalSeconds Integer
+
+-- |Describes an interval that is run every "n" seconds after midnight.
+everyNSeconds :: Integer -> Interval
+everyNSeconds = IntervalSeconds
+
+-- |Describes an interval that is run every minute.
+everyMinute :: Interval
+everyMinute = IntervalSeconds 60
+
+nextIntervalTime :: MonadIO m => Interval -> m UTCTime
+nextIntervalTime (IntervalSeconds intervalSeconds) = liftIO $ do
now <- getCurrentTime
let dayTime = utctDayTime now
let daySeconds = floor dayTime
- let dayMinute = daySeconds `div` 60
+ let intervalId = daySeconds `div` intervalSeconds
return now {
- utctDayTime = fromInteger $ (dayMinute + 1) * 60
- }
\ No newline at end of file
+ utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
+ }
+
+
+data SleepScheduler = SleepScheduler (MVar (SortedList ScheduledEvent, [ScheduledEvent])) Event.Event
+data ScheduledEvent = ScheduledEvent {
+ time :: UTCTime,
+ event :: Event.Event,
+ fireOnNegativeTimeJump :: Bool
+} deriving Eq
+instance Ord ScheduledEvent where
+ compare = comparing time
+
+class HasSleepScheduler m where
+ askSleepScheduler :: m SleepScheduler
+
+createSleepScheduler :: MonadIO m => m SleepScheduler
+createSleepScheduler = liftIO $ do
+ scheduler <- SleepScheduler <$> newMVar ([], []) <*> Event.new
+ link =<< (async $ schedulerThread scheduler)
+ return scheduler
+ where
+ schedulerThread :: SleepScheduler -> IO ()
+ schedulerThread (SleepScheduler eventsMVar trigger) = schedulerThread' =<< getCurrentTime
+ where
+ schedulerThread' :: UTCTime -> IO ()
+ schedulerThread' lastTime = do
+ start <- getCurrentTime
+
+ -- Check for a negative time step (threshold is between 5 and 65 seconds, depending on loop activity)
+ when (start < addUTCTime (fromInteger (-5)) lastTime) $ fireEvents fireOnNegativeTimeJump
+
+ (sortedEvents, _) <- readMVar eventsMVar
+ waitResult <- case fromSortedList sortedEvents of
+ [] -> True <$ Event.wait trigger
+ (ScheduledEvent{time} : _) -> waitForEvent time
+
+ when waitResult $ do
+ now <- getCurrentTime
+ fireEvents (checkEvent now)
+
+ schedulerThread' start
+
+ -- |Waits for the next event, with a timeout. A return value of 'False' indicates a timeout occured.
+ waitForEvent :: UTCTime -> IO Bool
+ waitForEvent eventTime = do
+ now <- getCurrentTime
+ let timeUntil = diffUTCTime eventTime now
+ if
+ | timeUntil <= 0 -> return True
+ | timeUntil < 60 -> True <$ Event.waitTimeout trigger (ceiling $ toRational timeUntil * 1000000)
+ -- False indicates a timeout, in which case no events need to be fired
+ | otherwise -> Event.waitTimeout trigger (60 * 1000000)
+
+
+ fireEvents :: (ScheduledEvent -> Bool) -> IO ()
+ fireEvents predicate =
+ modifyMVar_ eventsMVar $ \(hots, colds) -> do
+ let allEvents = hots <> toSortedList colds
+ let (activeEvents, futureEvents) = partition predicate allEvents
+ mapM_ (Event.set . event) activeEvents
+ -- Sleep scheduler thread 'Event' is cleared during 'modifyMVar_' to prevent race conditions.
+ Event.clear trigger
+ return (futureEvents, [])
+
+ -- |Predicate to check if an event should be fired.
+ checkEvent :: UTCTime -> ScheduledEvent -> Bool
+ checkEvent now ScheduledEvent{time} = now >= time
+
+
+queueScheduledEvent :: MonadIO m => SleepScheduler -> ScheduledEvent -> m ()
+queueScheduledEvent (SleepScheduler eventsMVar trigger) event@ScheduledEvent{time=eventTime} = liftIO $
+ modifyMVar_ eventsMVar $ \(sorted, unsorted) ->
+ -- Sleep scheduler thread 'Event' is set during 'modifyMVar_' to prevent race conditions.
+ case fromSortedList sorted of
+ [] -> (singleton event, unsorted) <$ Event.set trigger
+ (first : _) ->
+ if eventTime < time first
+ -- Event happens before the first event, so it is inserted at the front of the sorted list and the scheduler thread is notified
+ then (insert event sorted, unsorted) <$ Event.set trigger
+ -- Otherwise it is added to the unsorted pool and will be handled later.
+ else return (sorted, event:unsorted)
+
+
+-- |Suspends the thread until the given time is reached.
+sleepUntil :: (HasSleepScheduler m, MonadIO m) => UTCTime -> m ()
+sleepUntil time = do
+ scheduler <- askSleepScheduler
+ sleepUntil' scheduler time
+
+sleepUntil' :: MonadIO m => SleepScheduler -> UTCTime -> m ()
+sleepUntil' scheduler time = liftIO $ do
+ event <- Event.new
+ queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=False})
+ Event.wait event
+
+-- |Suspends the thread until the next time boundary described by 'Interval' is reached. Also returns when the system time jumps backwards.
+sleepUntilInterval :: (HasSleepScheduler m, MonadIO m) => Interval -> m ()
+sleepUntilInterval interval = do
+ scheduler <- askSleepScheduler
+ sleepUntilInterval' scheduler interval
+
+sleepUntilInterval' :: MonadIO m => SleepScheduler -> Interval -> m ()
+sleepUntilInterval' scheduler interval = liftIO $ do
+ event <- Event.new
+ time <- nextIntervalTime interval
+ queueScheduledEvent scheduler (ScheduledEvent {time, event, fireOnNegativeTimeJump=True})
+ Event.wait event