taffybar 7.3.1 → 7.4.0

raw patch · 22 files changed

+752/−186 lines, 22 filesdep ~dbus-menudep ~haskell-gi-basedep ~xdg-desktop-entryPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: dbus-menu, haskell-gi-base, xdg-desktop-entry

API changes (from Hackage documentation)

Files

• CHANGELOG.md +46/−0
• doc/custom.md +16/−0
• src/System/Taffybar/Context.hs +46/−16
• src/System/Taffybar/Information/DiskUsage.hs +27/−11
• src/System/Taffybar/Information/Notifications.hs +76/−0
• src/System/Taffybar/Information/Privacy.hs +40/−27
• src/System/Taffybar/Information/SafeX11.hs +30/−34
• src/System/Taffybar/Widget/FreedesktopNotifications.hs +14/−62
• src/System/Taffybar/Widget/NetworkGraph.hs +13/−7
• src/System/Taffybar/Widget/Privacy.hs +16/−4
• src/System/Taffybar/Widget/Workspaces.hs +17/−2
• taffybar.cabal +11/−3
• test/data/appearance-test.css +1/−1
• test/unit/DBusMenuSpec.hs +37/−16
• test/unit/System/Taffybar/ContextSpec.hs +13/−0
• test/unit/System/Taffybar/ContextStateSpec.hs +83/−0
• test/unit/System/Taffybar/Information/NotificationsSpec.hs +41/−0
• test/unit/System/Taffybar/Information/PrivacySpec.hs +27/−0
• test/unit/System/Taffybar/Information/SafeX11Spec.hs +25/−0
• test/unit/System/Taffybar/Widget/NetworkGraphSpec.hs +21/−0
• test/unit/System/Taffybar/Widget/Workspaces/LayoutSpec.hs +140/−0
• test/unit/unit-tests.hs +12/−3

@@ -1,3 +1,49 @@+# 7.4.0++## Compatibility++* `PrivacyInfo` gains a `PrivacyUnavailable` constructor. Custom exhaustive+  pattern matches should handle unavailable monitoring; `privacyInfoError`+  provides a total accessor for the error. Existing `activeNodes` accessors+  continue to work.++## Fixes++* Restore workspace labels before window icons in the default widget layout+  (#696). The bottom-left overlay remains available by setting+  `widgetBuilder = labelOverlayWidgetBuilder`.+* Initialize shared context state outside the registry lock, preventing+  deadlocks when an initializer accesses another state type. Concurrent+  callers share the result, and failed or cancelled initialization can be+  retried (#695).+* Keep the X11 request worker running after a synchronous request fails, while+  preserving cancellation. Property buffers now stay inside the worker's+  lifetime, and temporary error handlers are restored and released (#695).+* Show a warning when privacy monitoring fails instead of implying that no+  streams are active. Keep the last known activity visible and include the+  collection error in the tooltip (#695).+* Parse and safely quote desktop-entry command arguments, preserving quoted+  arguments, field-code expansion, and literal percent signs without+  interpreting arguments as shell expressions (#695).+* Prevent an expired notification from removing its replacement. Each+  notification generation has its own expiry, and formatted notification+  markup is preserved instead of being truncated mid-tag (#695).+* Apply the network graph's interface filter to its tooltip as well as its+  samples, so both report traffic for the same interfaces (#695).+* Share disk-usage polling by canonical path and polling interval, allowing+  multiple filesystems and cadences without reusing the first widget's+  settings (#695).+* Keep open tray menus synchronized with layout and property updates, fixing+  stale Wi-Fi lists and rejected clicks in nm-applet. Preserve hovered items+  and open submenus when services renumber menu item IDs.++## Packaging++* Require `xdg-desktop-entry >= 0.1.1.7` and `dbus-menu >= 0.1.4.0` so Hackage+  builds include the command-expansion and live-menu fixes.+* Propagate Nix build and check failures in CI instead of reporting a successful+  workflow after a failed build (#695).+ # 7.3.1  ## Fixes

@@ -28,6 +28,22 @@ Appearance of Taffybar widgets can be controlled with CSS rules. These are by default loaded from `$XDG_CONFIG_HOME/taffybar/taffybar.css`. +### Workspace labels and icons++`workspacesNew defaultWorkspacesConfig` places the workspace label before its+window icons. To overlay the label in the bottom-left corner of the icons,+select the overlay builder:++```haskell+workspacesNew defaultWorkspacesConfig+  { widgetBuilder = labelOverlayWidgetBuilder }+```++Both builders are exported by `System.Taffybar.Widget.Workspaces`. CSS controls+spacing and appearance through `.workspace-label`, `.window-icon-container`,+and `.contents`. The overlay builder also exposes `.overlay-box` for styling+the label's container.+ ### GTK Documentation  CSS styling is a feature of GTK. It uses a limited version of CSS, so

@@ -75,10 +75,10 @@ where  import Control.Arrow ((&&&), (***))-import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (ThreadId, forkIO, myThreadId, threadDelay) import qualified Control.Concurrent.MVar as MV import Control.Concurrent.STM.TChan (TChan, readTChan)-import Control.Exception (SomeException, catch, try)+import Control.Exception (SomeException, catch, mask, throwIO, try, uninterruptibleMask_) import Control.Exception.Enclosed (catchAny) import Control.Monad import Control.Monad.IO.Class@@ -167,11 +167,21 @@  type SubscriptionList = [(Unique, Listener)] -data Value = forall t. (Typeable t) => Value t+data Value+  = forall t. (Typeable t) => Value t+  | Initializing ThreadId (MV.MVar (Either SomeException Value))  fromValue :: forall t. (Typeable t) => Value -> Maybe t fromValue (Value v) = cast v+fromValue (Initializing _ _) = Nothing +awaitValue :: Value -> IO Value+awaitValue value@(Value _) = pure value+awaitValue (Initializing owner result) = do+  current <- myThreadId+  when (current == owner) $ fail "Recursive context state initialization"+  MV.readMVar result >>= either throwIO pure+ -- | 'BarConfig' specifies the configuration for a single taffybar window. data BarLevelConfig = BarLevelConfig   { -- | Constructors for widgets that should be placed at the beginning of the level.@@ -989,10 +999,10 @@ getState = do   stateMap <- asksContextVar contextState   let maybeValue = M.lookup (typeRep (Proxy :: Proxy t)) stateMap-  return $ maybeValue >>= fromValue+  resolved <- liftIO $ traverse awaitValue maybeValue+  return $ resolved >>= fromValue --- | Like "putState", but avoids aquiring a lock if the value is already in the--- map.+-- | Return existing state, initializing it once when absent. getStateDefault :: (Typeable t) => Taffy IO t -> Taffy IO t getStateDefault defaultGetter =   getState >>= maybe (putState defaultGetter) return@@ -1000,20 +1010,37 @@ -- | Get a value of the type returned by the provided action from the the -- current taffybar state, unless the state does not exist, in which case the -- action will be called to populate the state map.+-- Initializers run outside the registry lock and may access other state types.+-- Concurrent callers share the result; a failed initializer may be retried. putState :: forall t. (Typeable t) => Taffy IO t -> Taffy IO t putState getValue = do   contextVar <- asks contextState   ctx <- ask-  lift $ MV.modifyMVar contextVar $ \contextStateMap ->+  liftIO $ mask $ \restore -> do+    owner <- myThreadId+    result <- MV.newEmptyMVar     let theType = typeRep (Proxy :: Proxy t)-        currentValue = M.lookup theType contextStateMap-        insertAndReturn value =-          (M.insert theType (Value value) contextStateMap, value)-     in flip runReaderT ctx $-          maybe-            (insertAndReturn <$> getValue)-            (return . (contextStateMap,))-            (currentValue >>= fromValue)+        initializing = Initializing owner result+        unpack value = maybe (fail "Invalid context state type") pure (fromValue value)+    existing <- MV.modifyMVar contextVar $ \values ->+      case M.lookup theType values of+        Just value -> pure (values, Just value)+        Nothing -> pure (M.insert theType initializing values, Nothing)+    case existing of+      Just value -> restore (awaitValue value) >>= unpack+      Nothing -> do+        outcome <- try $ restore $ Value <$> runReaderT getValue ctx+        -- Publishing must finish even if cancellation arrives while taking the lock.+        uninterruptibleMask_ $ MV.modifyMVar_ contextVar $ \values -> do+          void $ MV.tryPutMVar result outcome+          pure $ case M.lookup theType values of+            Just (Initializing _ current)+              | current == result ->+                  either (const $ M.delete theType values) (\value -> M.insert theType value values) outcome+            _ -> values+        case outcome of+          Left err -> throwIO (err :: SomeException)+          Right _ -> MV.readMVar result >>= either throwIO unpack  -- | Overwrite a state value by type in the 'contextState' field of 'Context'. -- 'putState'/'getStateDefault' are intentionally "set-once" helpers; widgets@@ -1022,7 +1049,10 @@ setState value = do   contextVar <- asks contextState   let theType = typeRep (Proxy :: Proxy t)-  lift $ MV.modifyMVar_ contextVar $ \contextStateMap ->+  lift $ MV.modifyMVar_ contextVar $ \contextStateMap -> do+    case M.lookup theType contextStateMap of+      Just (Initializing _ result) -> void $ MV.tryPutMVar result (Right $ Value value)+      _ -> pure ()     return $ M.insert theType (Value value) contextStateMap   return value 

@@ -15,13 +15,8 @@ -- @disk-free-space@ package). -- -- The shared-channel API ('getDiskUsageInfoChan', 'getDiskUsageInfoState')--- uses a single polling thread per process (via 'getStateDefault') so that--- multiple bar instances do not each spawn their own poller.------ Because the channel is keyed by the 'DiskUsageChanVar' newtype, only one--- monitored path is supported through the shared API.  If you need to--- monitor several mount points independently, call 'getDiskUsageInfo'--- directly with 'pollingLabelNew'.+-- shares polling threads by canonical path and interval, so multiple bar+-- instances can reuse a poller while monitoring different filesystems. module System.Taffybar.Information.DiskUsage   ( DiskUsageInfo (..),     forceDiskUsageRefresh,@@ -38,10 +33,14 @@ import Control.Monad (forever, void) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically, orElse)+import Control.Monad.Trans.Reader (ask, runReaderT)+import qualified Data.Map.Strict as Map+import Data.Word (Word64)+import System.Directory (canonicalizePath) import System.DiskSpace (diskAvail, diskFree, diskTotal, getDiskUsage) import System.Log.Logger (Priority (..)) import System.Taffybar.Context (TaffyIO, getStateDefault)-import System.Taffybar.Information.Wakeup (getWakeupChannelForDelay)+import System.Taffybar.Information.Wakeup (getWakeupChannelNanoseconds, intervalSecondsToNanoseconds) import System.Taffybar.Util (logPrintF)  -- | Disk usage statistics for a single filesystem.@@ -97,8 +96,11 @@         TChan ()       ) +newtype DiskUsageSources+  = DiskUsageSources (MVar (Map.Map (FilePath, Word64) DiskUsageChanVar))+ -- | Get a broadcast channel that is updated by a shared polling thread.--- The first call starts the poller; subsequent calls return the same channel.+-- Calls with the same path and interval reuse the same poller. getDiskUsageInfoChan :: Double -> FilePath -> TaffyIO (TChan DiskUsageInfo) getDiskUsageInfoChan interval path = do   DiskUsageChanVar (chan, _, _) <- setupDiskUsageChanVar interval path@@ -117,12 +119,26 @@   liftIO $ atomically $ writeTChan refreshChan ()  setupDiskUsageChanVar :: Double -> FilePath -> TaffyIO DiskUsageChanVar-setupDiskUsageChanVar interval path = getStateDefault $ do+setupDiskUsageChanVar interval path = do+  intervalNs <- either fail pure $ intervalSecondsToNanoseconds interval+  canonicalPath <- liftIO $ canonicalizePath path+  DiskUsageSources sources <- getStateDefault $ liftIO $ DiskUsageSources <$> newMVar Map.empty+  context <- ask+  liftIO $ modifyMVar sources $ \current -> do+    let key = (canonicalPath, intervalNs)+    case Map.lookup key current of+      Just source -> pure (current, source)+      Nothing -> do+        source <- runReaderT (buildDiskUsageSource intervalNs canonicalPath) context+        pure (Map.insert key source current, source)++buildDiskUsageSource :: Word64 -> FilePath -> TaffyIO DiskUsageChanVar+buildDiskUsageSource intervalNs path = do   chan <- liftIO newBroadcastTChanIO   refreshChan <- liftIO newTChanIO   info <- liftIO $ getDiskUsageInfo path   var <- liftIO $ newMVar info-  wakeupChan <- getWakeupChannelForDelay interval+  wakeupChan <- getWakeupChannelNanoseconds intervalNs   ourWakeupChan <- liftIO $ atomically $ dupTChan wakeupChan   void $     liftIO $

@@ -0,0 +1,76 @@+-- | Notification storage with replacement-aware expiration.+module System.Taffybar.Information.Notifications+  ( Notification (..),+    NotificationQueue,+    newNotificationQueue,+    notificationUpdates,+    readNotifications,+    enqueueNotification,+    removeNotification,+    nextNotification,+  )+where++import Control.Concurrent (forkIO)+import Control.Concurrent.STM+import Control.Exception (mask_)+import Control.Monad (forM_, void, when)+import Data.Foldable (toList)+import Data.Int (Int32)+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Text (Text)+import Data.Unique (Unique, newUnique)+import Data.Word (Word32)++data Notification = Notification+  { noteAppName :: Text,+    noteReplaceId :: Word32,+    noteSummary :: Text,+    noteBody :: Text,+    noteExpireTimeout :: Maybe Int32,+    noteId :: Word32+  }+  deriving (Show, Eq)++data NotificationQueue = NotificationQueue+  { queuedNotifications :: TVar (Seq (Unique, Notification)),+    notificationUpdates :: TChan ()+  }++newNotificationQueue :: IO NotificationQueue+newNotificationQueue =+  NotificationQueue <$> newTVarIO Seq.empty <*> newBroadcastTChanIO++readNotifications :: NotificationQueue -> IO [Notification]+readNotifications queue = map snd . toList <$> readTVarIO (queuedNotifications queue)++enqueueNotification :: NotificationQueue -> Notification -> IO ()+enqueueNotification queue notification = mask_ $ do+  generation <- newUnique+  atomically $ do+    current <- readTVar $ queuedNotifications queue+    let entry = (generation, notification)+        updated = case Seq.findIndexL ((== noteId notification) . noteId . snd) current of+          Nothing -> current Seq.|> entry+          Just index -> Seq.update index entry current+    writeTVar (queuedNotifications queue) updated+    writeTChan (notificationUpdates queue) ()+  forM_ (noteExpireTimeout notification) $ \milliseconds -> void $ forkIO $ do+    elapsed <- registerDelay (max 0 (fromIntegral milliseconds) * 1000)+    atomically $ do+      current <- readTVar $ queuedNotifications queue+      when (any ((== generation) . fst) current) $ do+        readTVar elapsed >>= check+        writeTVar (queuedNotifications queue) $ Seq.filter ((/= generation) . fst) current+        writeTChan (notificationUpdates queue) ()++removeNotification :: NotificationQueue -> Word32 -> IO ()+removeNotification queue identifier = atomically $ do+  modifyTVar' (queuedNotifications queue) $ Seq.filter ((/= identifier) . noteId . snd)+  writeTChan (notificationUpdates queue) ()++nextNotification :: NotificationQueue -> IO ()+nextNotification queue = atomically $ do+  modifyTVar' (queuedNotifications queue) (Seq.drop 1)+  writeTChan (notificationUpdates queue) ()

@@ -27,6 +27,8 @@      -- * Query functions     getPrivacyInfo,+    parsePrivacyInfo,+    privacyInfoError,      -- * Channel-based monitoring     getPrivacyInfoChan,@@ -41,7 +43,7 @@ import Control.Applicative ((<|>)) import Control.Concurrent.MVar import Control.Concurrent.STM.TChan-import Control.Exception (SomeException, catch)+import Control.Exception.Enclosed (catchAny) import Control.Monad (void) import Control.Monad.IO.Class (liftIO) import Control.Monad.STM (atomically)@@ -86,11 +88,18 @@   deriving (Eq, Show, Generic)  -- | Aggregated privacy information.-newtype PrivacyInfo = PrivacyInfo-  { activeNodes :: [PrivacyNode]-  }+data PrivacyInfo+  = PrivacyInfo {activeNodes :: [PrivacyNode]}+  | PrivacyUnavailable+      { activeNodes :: [PrivacyNode],+        privacyError :: Text+      }   deriving (Eq, Show, Generic) +privacyInfoError :: PrivacyInfo -> Maybe Text+privacyInfoError PrivacyInfo {} = Nothing+privacyInfoError PrivacyUnavailable {privacyError = err} = Just err+ -- | Configuration for the privacy monitor. data PrivacyConfig = PrivacyConfig   { -- | Polling interval in seconds@@ -174,25 +183,27 @@  -- | Get current privacy information by running pw-dump. getPrivacyInfo :: PrivacyConfig -> IO PrivacyInfo-getPrivacyInfo config = do-  result <- runCommand (privacyPwDumpPath config) []-  case result of-    Left err -> do-      privacyLogF WARNING "pw-dump failed: %s" err-      return $ PrivacyInfo []-    Right output -> do-      let parsed = Aeson.decode (BL.fromStrict $ TE.encodeUtf8 $ T.pack output) :: Maybe [PwObject]-      case parsed of-        Nothing -> do-          privacyLogF WARNING "Failed to parse pw-dump output" ("" :: String)-          return $ PrivacyInfo []-        Just objects -> do-          let nodes = mapMaybe (toPrivacyNode config) objects-              filtered = filterNodes config nodes-              -- Remove duplicates based on app name and node type-              unique = nubBy (\a b -> appName a == appName b && nodeType a == nodeType b) filtered-          return $ PrivacyInfo unique+getPrivacyInfo config =+  catchAny+    ( do+        result <- runCommand (privacyPwDumpPath config) []+        either unavailable pure $ result >>= parsePrivacyInfo config+    )+    (unavailable . show)+  where+    unavailable err = do+      privacyLogF WARNING "Privacy monitoring unavailable: %s" err+      pure $ PrivacyUnavailable [] (T.pack err) +-- | Decode a complete pw-dump snapshot, preserving errors as unknown state.+parsePrivacyInfo :: PrivacyConfig -> String -> Either String PrivacyInfo+parsePrivacyInfo config output = do+  objects <- Aeson.eitherDecode (BL.fromStrict $ TE.encodeUtf8 $ T.pack output)+  let nodes = mapMaybe (toPrivacyNode config) objects+      filtered = filterNodes config nodes+      unique = nubBy (\a b -> appName a == appName b && nodeType a == nodeType b) filtered+  pure $ PrivacyInfo unique+ -- | Convert a PipeWire object to a PrivacyNode if relevant. toPrivacyNode :: PrivacyConfig -> PwObject -> Maybe PrivacyNode toPrivacyNode _config obj = do@@ -286,7 +297,7 @@ getPrivacyInfoChanVar config =   getStateDefault $ do     chan <- liftIO newBroadcastTChanIO-    var <- liftIO $ newMVar (PrivacyInfo [])+    var <- liftIO $ newMVar (PrivacyUnavailable [] "Waiting for privacy monitoring")     let intervalSeconds :: Double         intervalSeconds = max 0.1 (privacyPollingInterval config)     liftIO $ refreshPrivacyInfo config chan var@@ -299,8 +310,10 @@   MVar PrivacyInfo ->   IO () refreshPrivacyInfo config chan var = do-  info <- catch (getPrivacyInfo config) $ \(e :: SomeException) -> do-    privacyLogF WARNING "Privacy info refresh failed: %s" e-    return $ PrivacyInfo []-  _ <- swapMVar var info+  current <- getPrivacyInfo config+  info <- modifyMVar var $ \previous -> do+    let next = case current of+          PrivacyUnavailable _ err -> PrivacyUnavailable (activeNodes previous) err+          _ -> current+    pure (next, next)   atomically $ writeTChan chan info

@@ -83,27 +83,26 @@   (Storable a) =>   Int -> Display -> Atom -> Window -> IO (Maybe (ForeignPtr a, Int)) rawGetWindowPropertyBytes bits d atom w =-  alloca $ \actual_type_return ->+  postX11RequestSyncDef Nothing $ alloca $ \actual_type_return ->     alloca $ \actual_format_return ->       alloca $ \nitems_return ->         alloca $ \bytes_after_return ->           alloca $ \prop_return -> do             ret <--              postX11RequestSync $-                safeXGetWindowProperty-                  d-                  w-                  atom-                  0-                  0xFFFFFFFF-                  False-                  anyPropertyType-                  actual_type_return-                  actual_format_return-                  nitems_return-                  bytes_after_return-                  prop_return-            if fromRight (-1) ret /= 0+              safeXGetWindowProperty+                d+                w+                atom+                0+                0xFFFFFFFF+                False+                anyPropertyType+                actual_type_return+                actual_format_return+                nitems_return+                bytes_after_return+                prop_return+            if ret /= 0               then return Nothing               else do                 prop_ptr <- peek prop_return@@ -137,11 +136,10 @@  withErrorHandler :: XErrorHandler -> IO a -> IO a withErrorHandler new_handler action = do-  handler <- mkXErrorHandler (\d e -> new_handler d e >> return 0)-  original <- _xSetErrorHandler handler-  res <- action-  _ <- _xSetErrorHandler original-  return res+  bracket+    (mkXErrorHandler (\d e -> new_handler d e >> return 0))+    freeHaskellFunPtr+    (\handler -> bracket (_xSetErrorHandler handler) _xSetErrorHandler (const action))  deriving instance Show ErrorEvent @@ -156,21 +154,19 @@           show ee  handleX11Requests :: IO ()-handleX11Requests = do+handleX11Requests = forever $ mask $ \restore -> do   IORequest {ioAction = action, ioResponse = responseChannel} <-     readChan requestQueue-  res <--    catch-      (maybe (Left SafeX11Exception) Right <$> timeout 500000 action)-      ( \e -> do-          logHere WARNING $-            printf "Handling X11 error with catch: %s" $-              show (e :: IOException)-          return $ Left SafeX11Exception-      )-  writeChan responseChannel res-  handleX11Requests-  return ()+  outcome <- try $ restore $ timeout 500000 (action >>= evaluate)+  let response = case outcome of+        Right value -> maybe (Left SafeX11Exception) Right value+        Left (_ :: SomeException) -> Left SafeX11Exception+  writeChan responseChannel response+  case outcome of+    Left err -> case fromException err :: Maybe SomeAsyncException of+      Just _ -> throwIO err+      Nothing -> logHere WARNING $ printf "X11 request failed: %s" (show err)+    Right _ -> pure ()  postX11RequestSync :: IO a -> IO (Either SafeX11Exception a) postX11RequestSync action = do

@@ -1,6 +1,5 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}  -- | This widget listens on DBus for freedesktop notifications@@ -35,72 +34,49 @@ import DBus import DBus.Client import Data.Default (Default (..))-import Data.Foldable import Data.Int (Int32) import Data.Map (Map)-import Data.Sequence (Seq, ViewL (..), viewl, (|>))-import qualified Data.Sequence as S import Data.Text (Text) import qualified Data.Text as T import Data.Word (Word32) import GI.GLib (markupEscapeText) import GI.Gtk import qualified GI.Pango as Pango+import System.Taffybar.Information.Notifications import System.Taffybar.Util import System.Taffybar.Widget.Util (widgetSetClassGI) --- | A simple structure representing a Freedesktop notification-data Notification = Notification-  { noteAppName :: Text,-    noteReplaceId :: Word32,-    noteSummary :: Text,-    noteBody :: Text,-    noteExpireTimeout :: Maybe Int32,-    noteId :: Word32-  }-  deriving (Show, Eq)- data NotifyState = NotifyState   { noteWidget :: Label,     noteContainer :: Widget,     -- | The associated configuration     noteConfig :: NotificationConfig,     -- | The queue of active notifications-    noteQueue :: TVar (Seq Notification),+    noteQueue :: NotificationQueue,     -- | A source of fresh notification ids-    noteIdSource :: TVar Word32,-    -- | Writing to this channel wakes up the display thread-    noteChan :: TChan ()+    noteIdSource :: TVar Word32   }  initialNoteState :: Widget -> Label -> NotificationConfig -> IO NotifyState initialNoteState wrapper l cfg = do   m <- newTVarIO 1-  q <- newTVarIO S.empty-  ch <- newBroadcastTChanIO+  q <- newNotificationQueue   return     NotifyState       { noteQueue = q,         noteIdSource = m,         noteWidget = l,         noteContainer = wrapper,-        noteConfig = cfg,-        noteChan = ch+        noteConfig = cfg       }  -- | Removes every notification with id 'nId' from the queue notePurge :: NotifyState -> Word32 -> IO ()-notePurge s nId =-  atomically . modifyTVar' (noteQueue s) $-    S.filter ((nId /=) . noteId)+notePurge s = removeNotification (noteQueue s)  -- | Removes the first (oldest) notification from the queue noteNext :: NotifyState -> IO ()-noteNext s = atomically $ modifyTVar' (noteQueue s) aux-  where-    aux queue = case viewl queue of-      EmptyL -> S.empty-      _ :< ns -> ns+noteNext = nextNotification . noteQueue  -- | Generates a fresh notification id noteFreshId :: NotifyState -> IO Word32@@ -152,21 +128,12 @@             noteExpireTimeout = realTimeout,             noteId = realId           }-  -- Either add the new note to the queue or replace an existing note if their ids match-  atomically $ do-    queue <- readTVar $ noteQueue s-    writeTVar (noteQueue s) $ case S.findIndexL (\n_ -> noteId n == noteId n_) queue of-      Nothing -> queue |> n-      Just index -> S.update index n queue-  startTimeoutThread s n-  wakeupDisplayThread s+  enqueueNotification (noteQueue s) n   return realId  -- | Handles user cancellation of a notification closeNotification :: NotifyState -> Word32 -> IO ()-closeNotification s nId = do-  notePurge s nId-  wakeupDisplayThread s+closeNotification = notePurge  notificationDaemon ::   (AutoMethod f1, AutoMethod f2) =>@@ -198,40 +165,26 @@         }  ---------------------------------------------------------------------------------wakeupDisplayThread :: NotifyState -> IO ()-wakeupDisplayThread s = void . atomically $ writeTChan (noteChan s) ()  -- | Refreshes the GUI displayThread :: NotifyState -> IO () displayThread s = do-  chan <- atomically . dupTChan $ noteChan s+  chan <- atomically . dupTChan $ notificationUpdates (noteQueue s)   forever $ do     _ <- atomically $ readTChan chan-    ns <- readTVarIO (noteQueue s)+    ns <- readNotifications (noteQueue s)     postGUIASync $-      if S.length ns == 0+      if null ns         then widgetHide (noteContainer s)         else do-          labelSetMarkup (noteWidget s) $ formatMessage (noteConfig s) (toList ns)+          labelSetMarkup (noteWidget s) $ notificationFormatter (noteConfig s) ns           widgetShowAll (noteContainer s)-  where-    formatMessage NotificationConfig {..} ns =-      T.take notificationMaxLength $ notificationFormatter ns  ---------------------------------------------------------------------------------startTimeoutThread :: NotifyState -> Notification -> IO ()-startTimeoutThread s Notification {..} = case noteExpireTimeout of-  Nothing -> return ()-  Just timeout -> void $ forkIO $ do-    threadDelay (fromIntegral timeout * 10 ^ (3 :: Int))-    notePurge s noteId-    wakeupDisplayThread s ---------------------------------------------------------------------------------- -- | Rendering and behavior settings for the notification widget. data NotificationConfig = NotificationConfig-  { -- | Maximum time that a notification will be displayed (in seconds).  Default: None+  { -- | Maximum time that a notification will be displayed (in milliseconds). Default: None     notificationMaxTimeout :: Maybe Int32,     -- | Maximum length displayed, in characters.  Default: 100     notificationMaxLength :: Int,@@ -324,5 +277,4 @@     -- \| Close the current note and pull up the next, if any     userCancel s _ = do       noteNext s-      wakeupDisplayThread s       return True

@@ -72,14 +72,20 @@ networkGraphNewWith :: NetworkGraphConfig -> TaffyIO GI.Gtk.Widget networkGraphNewWith config = do   NetworkInfoChan chan <- getNetworkChan-  let getUpDown = sumSpeeds . map snd . filter (interfacesFilter config . fst)-      toSample (up, down) = map (networkGraphScale config . fromRational) [up, down]-      sampleBuilder = return . toSample . getUpDown+  let toSample (up, down) = map (networkGraphScale config . fromRational) [up, down]+      sampleBuilder = return . toSample . networkGraphSpeeds config   widget <- channelGraphNew (networkGraphGraphConfig config) chan sampleBuilder   _ <- widgetSetClassGI widget (T.pack "network-graph")-  for_ (networkGraphTooltipFormat config) $ \(format, precision) ->+  for_ (networkGraphTooltipFormat config) $ \_ ->     channelWidgetNew widget chan $ \speedInfo ->-      let (up, down) = sumSpeeds $ map snd speedInfo-          tooltip = showInfo format precision (fromRational down, fromRational up)-       in postGUIASync $ widgetSetTooltipMarkup widget $ Just tooltip+      postGUIASync $ widgetSetTooltipMarkup widget $ networkGraphTooltip config speedInfo   return widget++networkGraphSpeeds :: NetworkGraphConfig -> [(String, (Rational, Rational))] -> (Rational, Rational)+networkGraphSpeeds config = sumSpeeds . map snd . filter (interfacesFilter config . fst)++networkGraphTooltip :: NetworkGraphConfig -> [(String, (Rational, Rational))] -> Maybe T.Text+networkGraphTooltip config speedInfo = do+  (format, precision) <- networkGraphTooltipFormat config+  let (up, down) = networkGraphSpeeds config speedInfo+  pure $ showInfo format precision (fromRational down, fromRational up)

@@ -16,7 +16,8 @@ -- Privacy indicator widget for taffybar. -- -- Shows icons when microphone, camera, or screen sharing is active.--- The widget is hidden when no privacy-relevant streams are active.+-- The widget is hidden when monitoring confirms that no streams are active.+-- A warning remains visible when monitoring is unavailable. -- -- Example usage: --@@ -57,7 +58,7 @@ import Data.Default (Default (..)) import Data.Int (Int32) import Data.List (intercalate)-import Data.Maybe (catMaybes)+import Data.Maybe (catMaybes, isJust) import qualified Data.Text as T import qualified GI.Gtk as Gtk import System.Taffybar.Context (TaffyIO)@@ -69,6 +70,7 @@     defaultPrivacyConfig,     getPrivacyInfoChan,     getPrivacyInfoState,+    privacyInfoError,   ) import System.Taffybar.Util (postGUIASync) import System.Taffybar.Widget.Util (manageWidgetThreads, widgetSetClassGI)@@ -124,6 +126,8 @@     audioInImage <- createIcon (audioInputIcon config) (privacyIconSize config)     audioOutImage <- createIcon (audioOutputIcon config) (privacyIconSize config)     videoInImage <- createIcon (videoInputIcon config) (privacyIconSize config)+    unavailableImage <- createIcon "dialog-warning-symbolic" (privacyIconSize config)+    _ <- widgetSetClassGI unavailableImage "privacy-unavailable"      _ <- widgetSetClassGI audioInImage "privacy-audio-input"     _ <- widgetSetClassGI audioOutImage "privacy-audio-output"@@ -133,6 +137,7 @@     Gtk.containerAdd box audioInImage     Gtk.containerAdd box audioOutImage     Gtk.containerAdd box videoInImage+    Gtk.containerAdd box unavailableImage      -- Create a revealer to control visibility with animation     revealer <- Gtk.revealerNew@@ -146,19 +151,26 @@               hasAudioIn = any ((== AudioInput) . nodeType) nodes               hasAudioOut = any ((== AudioOutput) . nodeType) nodes               hasVideoIn = any ((== VideoInput) . nodeType) nodes-              hasAny = hasAudioIn || hasAudioOut || hasVideoIn+              monitorError = privacyInfoError info+              hasAny = hasAudioIn || hasAudioOut || hasVideoIn || isJust monitorError            -- Show/hide individual icons           Gtk.widgetSetVisible audioInImage hasAudioIn           Gtk.widgetSetVisible audioOutImage hasAudioOut           Gtk.widgetSetVisible videoInImage hasVideoIn+          Gtk.widgetSetVisible unavailableImage (isJust monitorError)            -- Show/hide the whole widget           Gtk.revealerSetRevealChild revealer hasAny            -- Update tooltip           when hasAny $ do-            let tooltipText = buildTooltip nodes+            let tooltipText = case monitorError of+                  Nothing -> buildTooltip nodes+                  Just err ->+                    "Privacy monitoring unavailable: "+                      ++ T.unpack err+                      ++ if null nodes then "" else "\nLast known activity:\n" ++ buildTooltip nodes             Gtk.widgetSetTooltipText box (Just $ T.pack tooltipText)      -- Initial update

@@ -19,6 +19,7 @@     WorkspaceWidgetController (..),     ControllerConstructor,     defaultWidgetBuilder,+    labelOverlayWidgetBuilder,     WindowIconPixbufGetter,     defaultWorkspacesConfig,     defaultEWMHWorkspacesConfig,@@ -270,8 +271,22 @@ defaultEWMHWorkspacesConfig :: WorkspacesConfig defaultEWMHWorkspacesConfig = defaultWorkspacesConfig +-- | Place the workspace label before the window icons in a horizontal box. defaultWidgetBuilder :: ControllerConstructor-defaultWidgetBuilder cfg wsInfo = do+defaultWidgetBuilder = widgetBuilderWithLayout $ \iconsWidget labelWidget -> do+  contents <- liftIO $ Gtk.boxNew Gtk.OrientationHorizontal 0+  liftIO $ Gtk.containerAdd contents labelWidget+  liftIO $ Gtk.containerAdd contents iconsWidget+  Gtk.toWidget contents >>= buildContentsBox++-- | Overlay the workspace label in the bottom-left corner of the window icons.+-- Select this layout with @widgetBuilder = labelOverlayWidgetBuilder@.+labelOverlayWidgetBuilder :: ControllerConstructor+labelOverlayWidgetBuilder = widgetBuilderWithLayout buildWorkspaceIconLabelOverlay++widgetBuilderWithLayout ::+  (Gtk.Widget -> Gtk.Widget -> TaffyIO Gtk.Widget) -> ControllerConstructor+widgetBuilderWithLayout buildLayout cfg wsInfo = do   wsRef <- liftIO $ newIORef wsInfo   lastWorkspaceRef <- liftIO $ newIORef wsInfo   iconsRef <- liftIO $ newIORef []@@ -280,7 +295,7 @@   _ <- widgetSetClassGI label "workspace-label"   iconsWidget <- Gtk.toWidget iconsBox   labelWidget <- Gtk.toWidget label-  contents <- buildWorkspaceIconLabelOverlay iconsWidget labelWidget+  contents <- buildLayout iconsWidget labelWidget   let updateController forceIcons newWs = do         oldWs <- liftIO $ readIORef lastWorkspaceRef         liftIO $ writeIORef wsRef newWs

@@ -1,6 +1,6 @@ cabal-version: 3.4 name: taffybar-version: 7.3.1+version: 7.4.0 synopsis: A desktop bar similar to xmobar, but with more GUI description: Taffybar is a desktop status bar with GTK widgets for window   manager state, system information, tray icons, and custom user modules.@@ -75,7 +75,7 @@                , data-default >= 0.7 && < 0.9                , dbus >= 1.2.11 && < 2                , dbus-hslogger >= 0.1.1.1 && < 0.2-               , dbus-menu >= 0.1.3.4 && < 0.2+               , dbus-menu >= 0.1.4.0 && < 0.2                , directory >= 1.3 && < 1.4                , disk-free-space >= 0.1.0.1 && < 0.2                , dyre >= 0.9.0 && < 0.10@@ -123,7 +123,7 @@                , tuple >= 0.3.0.2 && < 0.4                , unix >= 2.7 && < 2.9                , utf8-string >= 1.0 && < 1.1-               , xdg-desktop-entry >= 0.1.1.6 && < 0.2+               , xdg-desktop-entry >= 0.1.1.7 && < 0.2                , xdg-basedir >= 0.2 && < 0.3                , xml >= 1.3 && < 1.4                , xml-helpers >= 1.0 && < 1.1@@ -168,6 +168,7 @@                  , System.Taffybar.Information.Memory                  , System.Taffybar.Information.Network                  , System.Taffybar.Information.Nvidia+                 , System.Taffybar.Information.Notifications                  , System.Taffybar.Information.Temperature                  , System.Taffybar.Information.NetworkManager                  , System.Taffybar.Information.OpenAIUsage@@ -401,12 +402,16 @@                , System.Taffybar.AuthSpec                , System.Taffybar.AppearanceSpec                , System.Taffybar.ContextSpec+               , System.Taffybar.ContextStateSpec                , System.Taffybar.Information.ASUSSpec                , System.Taffybar.Information.CPUFrequencySpec                , System.Taffybar.Information.CPUPowerSpec                , System.Taffybar.Information.CryptoSpec                , System.Taffybar.Information.LayoutSpec                , System.Taffybar.Information.NvidiaSpec+               , System.Taffybar.Information.NotificationsSpec+               , System.Taffybar.Information.PrivacySpec+               , System.Taffybar.Information.SafeX11Spec                , System.Taffybar.Information.Workspaces.EWMHSpec                , System.Taffybar.Information.Workspaces.HyprlandSpec                , System.Taffybar.Information.X11DesktopInfoSpec@@ -415,9 +420,11 @@                , System.Taffybar.WidgetPrioritySpec                , System.Taffybar.Widget.AnthropicUsageSpec                , System.Taffybar.Widget.BatterySpec+               , System.Taffybar.Widget.NetworkGraphSpec                , System.Taffybar.Widget.OpenAIUsageSpec                , System.Taffybar.Widget.SNITray.PrioritizedCollapsibleSpec                , System.Taffybar.Widget.Workspaces.ChannelSpec+               , System.Taffybar.Widget.Workspaces.LayoutSpec                , System.Taffybar.Widget.WindowsSpec   build-depends: data-default                , bytestring@@ -430,6 +437,7 @@                , text                , gi-gtk3                , gtk-strut+               , haskell-gi-base                , hspec                , hspec-core                , hspec-golden

@@ -29,7 +29,7 @@ .workspace-label {   color: #f0f0f0;   font-size: 12px;-  padding: 0px 6px 0px 0px;+  padding: 0px; }  .window-icon-container {

@@ -6,11 +6,12 @@ import DBusMenu   ( LayoutNode (..),     MenuItemShape,+    menuItemLabel,     menuItemShape,   ) import DBusMenu.Reconcile   ( ReconcileAction (..),-    planReconciliation,+    planLabeledReconciliation,   ) import Data.Int (Int32) import Data.Map.Strict qualified as Map@@ -22,33 +23,45 @@     it "reuses IDs whose GTK shape is unchanged" $ do       let original = leaf 1 "Before" True           updated = leaf 1 "After" False-          existing :: Map.Map Int32 MenuItemShape-          existing = Map.singleton 1 (menuItemShape original)-      planReconciliation existing [(1, menuItemShape updated)]+      planLabeledReconciliation (existing [original]) (desired [updated])         `shouldBe` [ReuseItem 1]      it "reuses stable IDs across additions, removals, and reordering" $ do-      let shape = menuItemShape (leaf 0 "" True)-          existing :: Map.Map Int32 MenuItemShape-          existing = Map.fromList [(1, shape), (2, shape), (3, shape)]-      planReconciliation existing [(3, shape), (2, shape), (4, shape)]+      let old = [leaf 1 "A" True, leaf 2 "B" True, leaf 3 "C" True]+          new = [leaf 3 "C" True, leaf 2 "B" True, leaf 4 "D" True]+      planLabeledReconciliation (existing old) (desired new)         `shouldBe` [ReuseItem 3, ReuseItem 2, BuildItem 4] +    it "reuses items by shape and label when the service renumbers everything" $ do+      let old = [leaf 1 "Wi-Fi" True, separator 2, submenu 3 "VPN", leaf 4 "Quit" True]+          new = [leaf 41 "Wi-Fi" False, separator 42, submenu 43 "VPN", leaf 44 "Quit" True]+      planLabeledReconciliation (existing old) (desired new)+        `shouldBe` [ReuseItem 1, ReuseItem 2, ReuseItem 3, ReuseItem 4]++    it "prefers exact ID matches over label matches" $ do+      let old = [leaf 1 "Same" True, leaf 2 "Same" True]+          new = [leaf 9 "Same" True, leaf 1 "Same" True]+      planLabeledReconciliation (existing old) (desired new)+        `shouldBe` [ReuseItem 2, ReuseItem 1]+     it "builds a replacement when an item's GTK shape changes" $ do       let original = leaf 1 "Leaf" True-          updated = submenu 1 "Submenu"-          existing :: Map.Map Int32 MenuItemShape-          existing = Map.singleton 1 (menuItemShape original)-      planReconciliation existing [(1, menuItemShape updated)]+          updated = submenu 1 "Leaf"+      planLabeledReconciliation (existing [original]) (desired [updated])         `shouldBe` [BuildItem 1]      it "does not reuse the same widget for a duplicate desired ID" $ do-      let shape = menuItemShape (leaf 1 "Leaf" True)-          existing :: Map.Map Int32 MenuItemShape-          existing = Map.singleton 1 shape-      planReconciliation existing [(1, shape), (1, shape)]+      let item = leaf 1 "Leaf" True+      planLabeledReconciliation (existing [item]) (desired [item, item])         `shouldBe` [ReuseItem 1, BuildItem 1] +existing :: [LayoutNode] -> Map.Map Int32 (MenuItemShape, String)+existing nodes =+  Map.fromList [(lnId node, (menuItemShape node, menuItemLabel node)) | node <- nodes]++desired :: [LayoutNode] -> [(Int32, MenuItemShape, String)]+desired nodes = [(lnId node, menuItemShape node, menuItemLabel node) | node <- nodes]+ leaf :: Int -> String -> Bool -> LayoutNode leaf itemId label enabled =   LayoutNode@@ -58,6 +71,14 @@           [ ("label", toVariant label),             ("enabled", toVariant enabled)           ],+      lnChildren = []+    }++separator :: Int -> LayoutNode+separator itemId =+  LayoutNode+    { lnId = fromIntegral itemId,+      lnProps = Map.singleton "type" (toVariant ("separator" :: String)),       lnChildren = []     } 

@@ -39,6 +39,7 @@ import System.FilePath ((</>)) import System.Taffybar.Context import System.Taffybar.Context.Backend (prepareBackendEnvironment)+import System.Taffybar.Information.DiskUsage (getDiskUsageInfoChan) import System.Taffybar.SimpleConfig import System.Taffybar.Test.DBusSpec (withTestDBus) import System.Taffybar.Test.UtilSpec (logSetup, withEnv, withSetEnv)@@ -258,6 +259,18 @@       unsubscribe unknown       remaining <- listenerIds       liftIO $ remaining `shouldMatchList` [hashUnique idA]++  describe "Disk usage source keys" $ do+    it "shares a source only when both path and interval match" $ runTaffyNoX11 $ do+      tmp <- liftIO getTemporaryDirectory+      root <- getDiskUsageInfoChan 3600 "/"+      rootAgain <- getDiskUsageInfoChan 3600 "/."+      temporary <- getDiskUsageInfoChan 3600 tmp+      fasterRoot <- getDiskUsageInfoChan 1800 "/"+      liftIO $ do+        (rootAgain == root) `shouldBe` True+        (temporary /= root) `shouldBe` True+        (fasterRoot /= root) `shouldBe` True    describe "Fuzz tests" $ do     prop "eval generators" prop_genSimpleConfig

@@ -0,0 +1,83 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module System.Taffybar.ContextStateSpec (spec) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar qualified as MV+import Control.Exception (throwIO)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Reader (runReaderT)+import Data.IORef+import Data.Map.Strict qualified as Map+import System.Taffybar.Context+import System.Timeout (timeout)+import Test.Hspec+import UnliftIO.Async (cancel, mapConcurrently, wait, withAsync)++newtype StateA = StateA Int deriving (Eq, Show)++newtype StateB = StateB Int deriving (Eq, Show)++stateContext :: IO Context+stateContext = do+  state <- MV.newMVar Map.empty+  pure Context {contextState = state}++spec :: Spec+spec = before stateContext $ describe "Context state initialization" $ do+  it "can initialize and write dependencies of other types" $ \ctx -> do+    let initialize = getStateDefault $ do+          StateB n <- getStateDefault (pure $ StateB 4)+          _ <- setState (StateB 5)+          pure $ StateA n+    timeout 1000000 (runReaderT initialize ctx) `shouldReturn` Just (StateA 4)+    runReaderT getState ctx `shouldReturn` Just (StateB 5)++  it "runs concurrent initializers for one type only once" $ \ctx -> do+    calls <- newIORef (0 :: Int)+    let initialize = getStateDefault $ liftIO $ do+          atomicModifyIORef' calls (\n -> (n + 1, ()))+          threadDelay 30000+          pure $ StateA 7+    results <- mapConcurrently (const $ runReaderT initialize ctx) [1 .. 16 :: Int]+    results `shouldBe` replicate 16 (StateA 7)+    readIORef calls `shouldReturn` 1++  it "allows unrelated state access while an initializer is blocked" $ \ctx -> do+    entered <- MV.newEmptyMVar+    release <- MV.newEmptyMVar+    let initialize = getStateDefault $ liftIO $ MV.putMVar entered () >> MV.readMVar release >> pure (StateA 1)+    withAsync (runReaderT initialize ctx) $ \worker -> do+      MV.takeMVar entered+      timeout 1000000 (runReaderT (getStateDefault $ pure $ StateB 2) ctx)+        `shouldReturn` Just (StateB 2)+      MV.putMVar release ()+      wait worker `shouldReturn` StateA 1++  it "retries after initialization throws" $ \ctx -> do+    runReaderT (getStateDefault $ liftIO $ throwIO $ userError "failed" :: TaffyIO StateA) ctx+      `shouldThrow` anyIOException+    runReaderT (getStateDefault $ pure $ StateA 3) ctx `shouldReturn` StateA 3++  it "releases an initialization slot when its owner is cancelled" $ \ctx -> do+    entered <- MV.newEmptyMVar+    release <- MV.newEmptyMVar+    let initialize = getStateDefault $ liftIO $ MV.putMVar entered () >> MV.readMVar release >> pure (StateA 1)+    withAsync (runReaderT initialize ctx) $ \worker -> MV.takeMVar entered >> cancel worker+    timeout 1000000 (runReaderT (getStateDefault $ pure $ StateA 2) ctx)+      `shouldReturn` Just (StateA 2)++  it "does not overwrite an explicit update made during initialization" $ \ctx -> do+    entered <- MV.newEmptyMVar+    release <- MV.newEmptyMVar+    let initialize = getStateDefault $ liftIO $ MV.putMVar entered () >> MV.readMVar release >> pure (StateA 1)+    withAsync (runReaderT initialize ctx) $ \worker -> do+      MV.takeMVar entered+      runReaderT (setState $ StateA 9) ctx `shouldReturn` StateA 9+      MV.putMVar release ()+      wait worker `shouldReturn` StateA 9+    runReaderT getState ctx `shouldReturn` Just (StateA 9)++  it "rejects recursive initialization instead of deadlocking" $ \ctx -> do+    let initialize = getStateDefault $ getStateDefault (pure $ StateA 1)+    timeout 1000000 (runReaderT initialize ctx) `shouldThrow` anyIOException

@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Taffybar.Information.NotificationsSpec (spec) where++import Control.Concurrent (threadDelay)+import System.Taffybar.Information.Notifications+import System.Timeout (timeout)+import Test.Hspec++notification :: Notification+notification = Notification "test" 0 "message" "" (Just 40) 1++spec :: Spec+spec = describe "Notification expiration" $ do+  it "does not let the original deadline remove a replacement" $ do+    queue <- newNotificationQueue+    enqueueNotification queue notification+    let replacement = notification {noteExpireTimeout = Nothing}+    enqueueNotification queue replacement+    threadDelay 100000+    readNotifications queue `shouldReturn` [replacement]++  it "expires a replacement at its own deadline" $ do+    queue <- newNotificationQueue+    enqueueNotification queue notification {noteExpireTimeout = Nothing}+    enqueueNotification queue notification+    timeout 1000000 (waitUntilEmpty queue) `shouldReturn` Just ()++  it "does not expire a reused ID after closing its original notification" $ do+    queue <- newNotificationQueue+    enqueueNotification queue notification+    removeNotification queue 1+    let replacement = notification {noteExpireTimeout = Nothing}+    enqueueNotification queue replacement+    threadDelay 100000+    readNotifications queue `shouldReturn` [replacement]++waitUntilEmpty :: NotificationQueue -> IO ()+waitUntilEmpty queue = do+  entries <- readNotifications queue+  if null entries then pure () else threadDelay 1000 >> waitUntilEmpty queue

@@ -0,0 +1,27 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Taffybar.Information.PrivacySpec (spec) where++import Data.Either (isLeft)+import Data.Maybe (isJust)+import System.Taffybar.Information.Privacy+import Test.Hspec++spec :: Spec+spec = describe "Privacy monitoring availability" $ do+  it "distinguishes a valid empty snapshot from malformed data" $ do+    parsePrivacyInfo defaultPrivacyConfig "[]" `shouldBe` Right (PrivacyInfo [])+    parsePrivacyInfo defaultPrivacyConfig "not JSON" `shouldSatisfy` isLeft++  it "reports an unavailable monitor when pw-dump fails" $ do+    info <- getPrivacyInfo defaultPrivacyConfig {privacyPwDumpPath = "false"}+    privacyInfoError info `shouldSatisfy` isJust++  it "reports an unavailable monitor when the executable is missing" $ do+    info <- getPrivacyInfo defaultPrivacyConfig {privacyPwDumpPath = "/does-not-exist/taffybar-pw-dump"}+    privacyInfoError info `shouldSatisfy` isJust++  it "continues reporting active microphone streams" $ do+    let input = "[{\"id\":1,\"type\":\"PipeWire:Interface:Node\",\"info\":{\"state\":\"running\",\"props\":{\"media.class\":\"Stream/Input/Audio\",\"application.name\":\"Recorder\"}}}]"+    fmap (map appName . activeNodes) (parsePrivacyInfo defaultPrivacyConfig input)+      `shouldBe` Right ["Recorder"]

@@ -0,0 +1,25 @@+module System.Taffybar.Information.SafeX11Spec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (ErrorCall (..), throwIO)+import System.Taffybar.Information.SafeX11 (postX11RequestSyncDef)+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = sequential $ describe "Safe X11 request isolation" $ do+  it "answers a failed request and continues serving healthy requests" $ do+    timeout 2000000 (postX11RequestSyncDef (0 :: Int) $ throwIO $ ErrorCall "failed getter")+      `shouldReturn` Just 0+    timeout 2000000 (postX11RequestSyncDef (0 :: Int) $ pure 42)+      `shouldReturn` Just 42++  it "forces a result inside the request exception boundary" $ do+    timeout 2000000 (postX11RequestSyncDef (0 :: Int) $ pure $ error "invalid result")+      `shouldReturn` Just 0++  it "continues serving requests after a request times out" $ do+    timeout 2000000 (postX11RequestSyncDef (0 :: Int) $ threadDelay 1000000 >> pure 1)+      `shouldReturn` Just 0+    timeout 2000000 (postX11RequestSyncDef (0 :: Int) $ pure 2)+      `shouldReturn` Just 2

@@ -0,0 +1,21 @@+{-# LANGUAGE OverloadedStrings #-}++module System.Taffybar.Widget.NetworkGraphSpec (spec) where++import System.Taffybar.Widget.NetworkGraph+import Test.Hspec++spec :: Spec+spec = describe "Network graph tooltip" $ do+  it "reports only the interfaces included in the graph" $ do+    let config =+          defaultNetworkGraphConfig+            { interfacesFilter = (== "eth0"),+              networkGraphTooltipFormat = Just ("$inB$/$outB$", 2)+            }+        samples = [("eth0", (1024, 2048)), ("lo", (10000, 20000))]+    networkGraphTooltip config samples `shouldBe` Just "2048.0/1024.0"++  it "omits disabled tooltips" $+    networkGraphTooltip defaultNetworkGraphConfig {networkGraphTooltipFormat = Nothing} []+      `shouldBe` Nothing

@@ -0,0 +1,140 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module System.Taffybar.Widget.Workspaces.LayoutSpec (spec, gtkSpec) where++import Control.Concurrent.MVar qualified as MV+import Control.Exception (bracket)+import Control.Monad (filterM, forM_)+import Control.Monad.Trans.Reader (runReaderT)+import Data.ByteString.Lazy.Char8 qualified as BL+import Data.GI.Base (castTo)+import Data.Map.Strict qualified as M+import Data.Text qualified as T+import GI.Gtk qualified as Gtk+import System.Environment (getExecutablePath)+import System.Exit (ExitCode (..))+import System.Process.Typed (proc, readProcess)+import System.Taffybar.Context (Backend (..), Context (..))+import System.Taffybar.Information.Workspaces.Model+import System.Taffybar.Test.UtilSpec (withSetEnv)+import System.Taffybar.Test.XvfbSpec (setDefaultDisplay_, withXvfb)+import System.Taffybar.Widget.Workspaces+import System.Taffybar.WindowIcon (pixBufFromColor)+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = aroundAll withXvfb $+  describe "workspace label layout" $+    it "reserves label space and preserves the opt-in overlay" $ \display ->+      setDefaultDisplay_ display $+        withSetEnv [("GDK_BACKEND", "x11"), ("TAFFYBAR_WORKSPACE_LAYOUT_CHILD", "1")] $ do+          executable <- getExecutablePath+          result <- timeout 20000000 $ readProcess (proc executable [])+          case result of+            Just (code, out, err) -> unlessSuccess code out err+            Nothing -> expectationFailure "Workspace layout subprocess timed out"+  where+    unlessSuccess ExitSuccess _ _ = pure ()+    unlessSuccess code out err = expectationFailure $ show code ++ "\n" ++ BL.unpack out ++ "\n" ++ BL.unpack err++gtkSpec :: Spec+gtkSpec = sequential $ describe "workspace label layout" $ do+  forM_ ["1", "a long workspace name"] $ \name ->+    it ("places " ++ T.unpack name ++ " before the icons by default") $+      withController defaultWorkspacesConfig (workspace name [window 1, window 2]) $ \_ controller ->+        assertLabelSpace (controllerWidget controller)++  it "keeps the label visible on an empty workspace and separates newly added icons" $+    withController defaultWorkspacesConfig (workspace "1" []) $ \ctx controller -> do+      let root = controllerWidget controller+      [label] <- widgetsWithClass "workspace-label" root+      (labelWidth, _) <- Gtk.widgetGetPreferredWidth label+      labelWidth `shouldSatisfy` (> 0)+      (rootWidth, _) <- Gtk.widgetGetPreferredWidth root+      rootWidth `shouldSatisfy` (>= labelWidth)+      length <$> widgetsWithClass "window-icon-container" root `shouldReturn` 0+      runReaderT (controllerUpdate controller $ workspace "longer label" [window 1]) ctx+      Gtk.widgetShowAll root+      assertLabelSpace root+      runReaderT (controllerUpdate controller $ workspace "1" []) ctx+      icons <- widgetsWithClass "window-icon-container" root+      length <$> filterM Gtk.widgetGetVisible icons `shouldReturn` 0++  it "preserves the opt-in overlay and lets input pass through the label"+    $ withController+      defaultWorkspacesConfig {widgetBuilder = labelOverlayWidgetBuilder}+      (workspace "1" [window 1])+    $ \_ controller -> do+      let root = controllerWidget controller+      Just overlay <- castTo Gtk.Overlay root+      [labelBox] <- widgetsWithClass "overlay-box" root+      Gtk.overlayGetOverlayPassThrough overlay labelBox `shouldReturn` True++withController ::+  WorkspacesConfig ->+  WorkspaceInfo ->+  (Context -> WorkspaceWidgetController -> IO ()) ->+  IO ()+withController cfg ws action = do+  state <- MV.newMVar M.empty+  let ctx = Context {contextState = state, backend = BackendX11}+      testCfg = cfg {getWindowIconPixbuf = \size _ -> Just <$> pixBufFromColor size 0xff0000ff}+  bracket+    (runReaderT (widgetBuilder testCfg testCfg ws) ctx)+    (Gtk.widgetDestroy . controllerWidget)+    $ \controller -> do+      Gtk.widgetShowAll (controllerWidget controller)+      action ctx controller++widgetsWithClass :: T.Text -> Gtk.Widget -> IO [Gtk.Widget]+widgetsWithClass cssClass root = do+  style <- Gtk.widgetGetStyleContext root+  matches <- Gtk.styleContextHasClass style cssClass+  container <- castTo Gtk.Container root+  children <- maybe (pure []) Gtk.containerGetChildren container+  descendants <- concat <$> mapM (widgetsWithClass cssClass) children+  pure $ [root | matches] ++ descendants++assertLabelSpace :: Gtk.Widget -> Expectation+assertLabelSpace root = do+  [label] <- widgetsWithClass "workspace-label" root+  icons <- widgetsWithClass "window-icon-container" root+  length icons `shouldSatisfy` (> 0)+  (labelWidth, _) <- Gtk.widgetGetPreferredWidth label+  labelWidth `shouldSatisfy` (> 0)+  iconWidths <- mapM (fmap fst . Gtk.widgetGetPreferredWidth) icons+  (rootWidth, _) <- Gtk.widgetGetPreferredWidth root+  rootWidth `shouldSatisfy` (>= labelWidth + sum iconWidths)+  Just labelParent <- Gtk.widgetGetParent label+  Just box <- castTo Gtk.Box labelParent+  children <- Gtk.containerGetChildren box+  mapM Gtk.widgetGetName (take 1 children) `shouldReturn` ["GtkLabel"]+  forM_ [root, label] $ \widget -> do+    style <- Gtk.widgetGetStyleContext widget+    Gtk.styleContextHasClass style "active" `shouldReturn` True++workspace :: T.Text -> [WindowInfo] -> WorkspaceInfo+workspace name windows =+  WorkspaceInfo+    { workspaceIdentity = WorkspaceIdentity (Just 1) name,+      workspaceUpdateRevision = 0,+      workspaceState = WorkspaceActive,+      workspaceHasUrgentWindow = False,+      workspaceIsSpecial = False,+      workspaceWindows = windows+    }++window :: Word -> WindowInfo+window wid =+  WindowInfo+    { windowIdentity = X11WindowIdentity (fromIntegral wid),+      windowUpdateRevision = 0,+      windowTitle = "test window",+      windowClassHints = [],+      windowPosition = Nothing,+      windowUrgent = False,+      windowActive = False,+      windowMinimized = False,+      windowPinned = False+    }

@@ -1,11 +1,20 @@ module Main where +import GI.Gtk qualified as Gtk+import System.Environment (lookupEnv)+import System.Taffybar.Widget.Workspaces.LayoutSpec qualified as WorkspaceLayout import Test.Hspec import Test.Hspec.Runner import TestLibSpec qualified import UnitSpec qualified  main :: IO ()-main = hspecWith defaultConfig $ do-  UnitSpec.spec-  describe "testlib Sanity Checks" TestLibSpec.spec+main = do+  workspaceLayoutChild <- lookupEnv "TAFFYBAR_WORKSPACE_LAYOUT_CHILD"+  case workspaceLayoutChild of+    Just "1" -> do+      _ <- Gtk.init Nothing+      hspecWith defaultConfig WorkspaceLayout.gtkSpec+    _ -> hspecWith defaultConfig $ do+      UnitSpec.spec+      describe "testlib Sanity Checks" TestLibSpec.spec