qbar/src/QBar/Time.hs

+{-# LANGUAGE OverloadedLists #-}
+
+module QBar.Time (
+  HasSleepScheduler(..),
+  Interval(..),
+  SleepScheduler,
+  createSleepScheduler,
+  everyMinute,
+  everyNSeconds,
+  humanReadableInterval,
+  nextIntervalTime,
+  sleepUntil',
+  sleepUntil,
+  sleepUntilInterval',
+  sleepUntilInterval,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Async
+import Control.Concurrent.Event qualified as Event
+import Control.Concurrent.MVar
+import Data.Ord (comparing)
+import Data.SortedList (SortedList, toSortedList, fromSortedList, singleton, partition, insert)
+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime, addUTCTime)
+
+newtype Interval = IntervalSeconds Integer
+  deriving (Read, Show)
+
+-- |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 :: Integer = floor dayTime
+  let intervalId = daySeconds `div` intervalSeconds
+  return now {
+    utctDayTime = fromInteger $ (intervalId + 1) * intervalSeconds
+  }
+
+humanReadableInterval :: Interval -> String
+humanReadableInterval (IntervalSeconds i) = show i <> "s"
+
+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

qbar/src/QBar/Utils.hs

+module QBar.Utils (
+  mkBroadcastCacheP,
+  mkBroadcastP,
+  randomIdentifier,
+  signalEventPipe,
+) where
+
+import QBar.Prelude
+
+import Control.Concurrent.Event as Event
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TChan
+import Control.Concurrent.STM.TVar
+import Control.Monad (replicateM)
+import Data.Text.Lazy qualified as T
+import Pipes
+import System.Random
+
+-- Pipe that signals an 'Event' after every value that passes through
+signalEventPipe :: MonadIO m => Event.Event -> Pipe a a m r
+signalEventPipe event = forever $ (yield =<< await) >> liftIO (Event.signal event)
+
+randomIdentifier :: MonadIO m => m Text
+randomIdentifier = liftIO $ T.pack <$> replicateM 8 randomCharacter
+  where
+    randomCharacter :: IO Char
+    randomCharacter = do
+      index <- randomRIO (0, T.length alphabet - 1)
+      return $ T.index alphabet index
+    alphabet :: T.Text
+    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+mkBroadcastP :: forall a. IO (Consumer a IO (), Producer a IO ())
+mkBroadcastP = do
+  chan <- newBroadcastTChanIO
+  return (sendToStore chan, recvFromStore chan)
+  where
+    sendToStore :: TChan a -> Consumer a IO ()
+    sendToStore chan = forever $ do
+      value <- await
+      liftIO . atomically $ writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: TChan a -> Producer a IO ()
+    recvFromStore chan = do
+      outputChan <- liftIO . atomically $ dupTChan chan
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)
+
+-- |Creates a pair of consumer and producer. Both can be used multiple times in parallel.
+-- |All values send to a consumer will be sent to all currently running producers.
+-- |When running a new producer it will immediateley receive the latest value that was sent to a consumer.
+mkBroadcastCacheP :: forall a. a -> IO (Consumer a IO (), Producer a IO ())
+mkBroadcastCacheP initialValue = do
+  store <- (,) <$> newTVarIO initialValue <*> newBroadcastTChanIO
+  return (sendToStore store, recvFromStore store)
+  where
+    sendToStore :: (TVar a, TChan a) -> Consumer a IO ()
+    sendToStore (var, chan) = forever $ do
+      value <- await
+      liftIO . atomically $ do
+        writeTVar var value
+        writeTChan chan value
+
+    -- Monad will be forked when new outputs connect
+    recvFromStore :: (TVar a, TChan a) -> Producer a IO ()
+    recvFromStore (var, chan) = do
+      (outputChan, value) <- liftIO . atomically $ do
+        value <- readTVar var
+        outputChan <- dupTChan chan
+        return (outputChan, value)
+
+      yield value
+
+      forever $ yield =<< (liftIO . atomically $ readTChan outputChan)

test/Spec.hs → qbar/test/Spec.hs

+import Prelude
+
 main :: IO ()
 main = putStrLn "Test suite not yet implemented"

shell.nix

-{ pkgs ? import <nixpkgs> {} }:
-
-pkgs.mkShell {
-  buildInputs = with pkgs; [
-    stack
-    zsh
-    jq
-  ];
-}

src/BasePrelude.hs

-{-# LANGUAGE PackageImports #-}
-{-# LANGUAGE NoImplicitPrelude #-}
-
-module BasePrelude
-  ( module Prelude,
-  )
-where
-
-import "base" Prelude

src/QBar/Blocks.hs

-module QBar.Blocks
-  ( QBar.Blocks.Battery.batteryBlock,
-    QBar.Blocks.CpuUsage.cpuUsageBlock,
-    QBar.Blocks.Date.dateBlock,
-  )
-where
-
-import qualified QBar.Blocks.Battery
-import qualified QBar.Blocks.CpuUsage
-import qualified QBar.Blocks.Date

src/QBar/Cli.hs

-{-# LANGUAGE ApplicativeDo #-}
-
-module QBar.Cli where
-
-import QBar.ControlSocket
-import QBar.Core
-import QBar.DefaultConfig
-import QBar.Server
-import QBar.Theme
-
-import Control.Monad (join, sequence_)
-import qualified Data.Text.Lazy as T
-import Options.Applicative
-
--- |Entry point.
-runQBar :: IO ()
-runQBar = join parseMain
-
-parseMain :: IO (IO ())
-parseMain = customExecParser parserPrefs parser
-  where
-    parser :: ParserInfo (IO ())
-    parser = info (mainParser <**> helper)
-      (fullDesc <> header "qbar - queezles {i3,sway}bar infrastructure")
-
-    parserPrefs :: ParserPrefs
-    parserPrefs = prefs showHelpOnEmpty
-
-mainParser :: Parser (IO ())
-mainParser = do
-  verbose <- switch $ long "verbose" <> short 'v' <> help "Print more diagnostic output to stderr (including a copy of every bar update)."
-  indicator <- switch $ long "indicator" <> short 'i' <> help "Show render indicator."
-  socketLocation <- optional $ strOption $ long "socket" <> short 's' <> metavar "SOCKET" <> help "Control socket location. By default determined by WAYLAND_SOCKET location."
-  barCommand <- barCommandParser
-  return (barCommand MainOptions {verbose, indicator, socketLocation})
-
-barCommandParser :: Parser (MainOptions -> IO ())
-barCommandParser = hsubparser (
-    command "server" (info (runBarServer <$> barConfigurationParser) (progDesc "Start a new qbar server. Should be called by swaybar, i3bar or or another i3bar-protocol compatible host process.")) <>
-    command "connect" (info (sendBlockStream <$> barConfigurationParser) (progDesc "Run blocks on this process but display them on the qbar server.")) <>
-    command "theme" (info themeCommandParser (progDesc "Change the theme of the running qbar server.")) <>
-    command "default" (info (pure $ sendIpc . SetTheme $ "default") (progDesc "Shortcut for 'qbar theme default'.")) <>
-    command "rainbow" (info (pure $ sendIpc . SetTheme $ "rainbow") (progDesc "Shortcut for 'qbar theme rainbow'."))
-  )
-
-themeCommandParser :: Parser (MainOptions -> IO ())
-themeCommandParser = sendIpc . SetTheme <$> strArgument (metavar "THEME" <> completeWith (map T.unpack themeNames))
-
-barConfigurationParser :: Parser (BarIO ())
-barConfigurationParser = do
-  blocks <- many $ hsubparser (
-      command "default" (info (pure defaultBarConfig) (progDesc "Load default set of blocks."))
-    )
-  pure $ case blocks of
-    [] -> defaultBarConfig
-    l -> sequence_ l

src/QBar/DefaultConfig.hs

-module QBar.DefaultConfig where
-
-import QBar.Blocks
-import QBar.BlockOutput
-import QBar.Core
-
-import Pipes
-
-import Control.Lens
-
-blockLocation :: String -> FilePath
-blockLocation name = "~/.config/qbar/blocks/" <> name
-
-defaultBarConfig :: BarIO ()
-defaultBarConfig = 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 volumeBlock = persistentBlockScript $ blockLocation "volume-pulseaudio -S -F3"
-  let battery = systemInfoInterval $ batteryBlock >-> modify (blockName ?~ "battery")
-  let cpuUsage = systemInfoInterval $ cpuUsageBlock 1 >-> modify ((blockName ?~ "cpuUsage") . addIcon "💻\xFE0E")
-
-  addBlock dateBlock
-  addBlock battery
-  addBlock volumeBlock
-  addBlock temperature
-  addBlock ram
-  addBlock cpuUsage
-  addBlock networkEnvironment
-  addBlock wifi
-  addBlock todo

src/QBar/Time.hs

-module QBar.Time (sleepUntil, nextMinute) where
-
-import Control.Concurrent (threadDelay)
-import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime, utctDayTime)
-
-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
-  now <- getCurrentTime
-  let dayTime = utctDayTime now
-  let daySeconds = floor dayTime
-  let dayMinute = daySeconds `div` 60
-  return now {
-    utctDayTime = fromInteger $ (dayMinute + 1) * 60
-  }
\ No newline at end of file

src/QBar/Util.hs

-module QBar.Util where
-
-import Control.Concurrent.Event as Event
-import Control.Monad (replicateM)
-import qualified Data.Text.Lazy as T
-import Pipes
-import System.Random
-
--- Pipe that signals an 'Event' after every value that passes through
-signalPipe :: MonadIO m => Event.Event -> Pipe a a m r
-signalPipe event = signalPipe'
-  where
-    signalPipe' :: MonadIO m => Pipe a a m r
-    signalPipe' = do
-      value <- await
-      yield value
-      liftIO $ Event.signal event
-      signalPipe'
-
-randomIdentifier :: IO Text
-randomIdentifier = T.pack <$> replicateM 8 randomCharacter
-  where
-    randomCharacter :: IO Char
-    randomCharacter = do
-      index <- randomRIO (0, T.length alphabet - 1)
-      return $ T.index alphabet index
-    alphabet :: T.Text
-    alphabet = T.pack $ ['A'..'Z'] ++ ['a'..'z'] ++ ['0'..'9']

stack.yaml

-# This file was automatically generated by 'stack init'
-#
-# Some commonly used options have been documented as comments in this file.
-# For advanced use and comprehensive documentation of the format, please see:
-# https://docs.haskellstack.org/en/stable/yaml_configuration/
-
-# Resolver to choose a 'specific' stackage snapshot or a compiler version.
-# A snapshot resolver dictates the compiler version and the set of packages
-# to be used for project dependencies. For example:
-#
-# resolver: lts-3.5
-# resolver: nightly-2015-09-21
-# resolver: ghc-7.10.2
-#
-# The location of a snapshot can be provided as a file or url. Stack assumes
-# a snapshot provided as a file might change, whereas a url resource does not.
-#
-# resolver: ./custom-snapshot.yaml
-# resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-14.20
-
-# User packages to be built.
-# Various formats can be used as shown in the example below.
-#
-# packages:
-# - some-directory
-# - https://example.com/foo/bar/baz-0.0.2.tar.gz
-# - location:
-#    git: https://github.com/commercialhaskell/stack.git
-#    commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a
-#  subdirs:
-#  - auto-update
-#  - wai
-packages:
-- .
-# Dependency packages to be pulled from upstream that are not in the resolver
-# using the same syntax as the packages field.
-# (e.g., acme-missiles-0.3)
-# extra-deps: []
-
-# Disable pure nix-shell environment on NixOS, because access to XDG_RUNTIME_DIR is needed for the control socket
-nix:
-  pure: false
-
-# Override default flag values for local packages and extra-deps
-# flags: {}
-
-# Extra package databases containing global packages
-# extra-package-dbs: []
-
-# Control whether we use the GHC we find on the path
-# system-ghc: true
-#
-# Require a specific version of stack, using version ranges
-# require-stack-version: -any # Default
-# require-stack-version: ">=1.9"
-#
-# Override the architecture used by stack, especially useful on Windows
-# arch: i386
-# arch: x86_64
-#
-# Extra directories used by stack for building
-# extra-include-dirs: [/path/to/dir]
-# extra-lib-dirs: [/path/to/dir]
-#
-# Allow a newer minor version of GHC than the snapshot specifies
-# compiler-check: newer-minor