status-notifier-item 0.3.2.1 → 0.3.2.2

raw patch · 8 files changed

+573/−11 lines, 8 filesdep +directorydep +hspecdep +processdep ~dbusPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: directory, hspec, process, unix

Dependency ranges changed: dbus

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• src/StatusNotifier/Watcher/Service.hs +33/−10
• status-notifier-item.cabal +24/−1
• test/HostSpec.hs +136/−0
• test/Main.hs +13/−0
• test/TestSupport.hs +141/−0
• test/UtilSpec.hs +83/−0
• test/WatcherSpec.hs +135/−0

@@ -1,5 +1,13 @@ # Changelog for status-notifier-item +## 0.3.2.2 - 2026-02-11+- Fix watcher registration ownership checks by requiring explicit service-name+  registrations to be initiated by the current owner.+- Fix watcher duplicate handling by coalescing path-first and name-first+  registrations from the same sender/path pair.+- Add an isolated DBus integration test suite covering watcher/host behavior+  and regression tests for registration ownership and deduplication.+ ## 0.3.2.1 - 2026-02-09 - Add name-owner resolution fallback for signal sender identification, fixing   noisy errors when items register under well-known bus names.

@@ -63,27 +63,50 @@       registerStatusNotifierItem MethodCall                                    { methodCallSender = sender }                                  name = runExceptT $ do-        let maybeBusName = getFirst $ mconcat $-                           map First [T.parseBusName name, sender]+        let parsedBusName = T.parseBusName name             parseServiceError = makeErrorReply errorInvalidParameters $               printf "the provided service %s could not be parsed \                      \as a bus name or an object path." name+            senderMissingError = makeErrorReply errorInvalidParameters $+              "Unable to identify sender for registration."             path = fromMaybe Item.defaultPath $ T.parseObjectPath name             remapErrorName =               left $ (`makeErrorReply` "Failed to verify ownership.") .                    M.methodErrorName-        busName <- ExceptT $ return $ maybeToEither parseServiceError maybeBusName+            resolveOwner bus+              | ":" `isPrefixOf` (coerce bus :: String) = return (Just bus)+              | otherwise = do+                  result <- DBusTH.getNameOwner client (coerce bus)+                  return $ busName_ <$> either (const Nothing) Just result+        when (isNothing parsedBusName && isNothing (T.parseObjectPath name)) $+          throwE parseServiceError+        senderName <- ExceptT $ return $ maybeToEither senderMissingError sender+        busName <-+          case parsedBusName of+            Just providedBusName -> do+              owner <- ExceptT $ remapErrorName <$>+                       DBusTH.getNameOwner client (coerce providedBusName)+              unless (owner == coerce senderName) $+                throwE $ makeErrorReply errorInvalidParameters $+                  printf "Sender %s does not own service %s."+                    (coerce senderName :: String)+                    name+              return providedBusName+            Nothing -> return senderName         let item = ItemEntry { serviceName = busName                              , servicePath = path                              }-        hasOwner <- ExceptT $ remapErrorName <$>-                    DBusTH.nameHasOwner client (coerce busName)         lift $ modifyMVar_ notifierItems $ \currentItems ->-          if itemIsRegistered item currentItems-          then-            return currentItems-          else-            do+          do+            ownerPathMatches <- filterM (\existingItem ->+              if servicePath existingItem == path+              then do+                existingOwner <- resolveOwner (serviceName existingItem)+                return $ existingOwner == Just senderName+              else return False) currentItems+            if itemIsRegistered item currentItems || not (null ownerPathMatches)+            then return currentItems+            else do               emitStatusNotifierItemRegistered client $ renderServiceName item               return $ item : currentItems 

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           status-notifier-item-version:        0.3.2.1+version:        0.3.2.2 synopsis:       A wrapper over the StatusNotifierItem/libappindicator dbus specification description:    Please see the README on Github at <https://github.com/IvanMalison/status-notifier-item#readme> category:       Desktop@@ -95,4 +95,27 @@     , hslogger     , optparse-applicative     , status-notifier-item+  default-language: Haskell2010++test-suite status-notifier-item-test+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      HostSpec+      TestSupport+      UtilSpec+      WatcherSpec+      Paths_status_notifier_item+  hs-source-dirs:+      test+  build-depends:+      base >=4.7 && <5+    , containers+    , dbus >=1.2.1 && <2.0.0+    , directory+    , hslogger+    , hspec+    , process+    , status-notifier-item+    , unix   default-language: Haskell2010

@@ -0,0 +1,136 @@+{-# LANGUAGE OverloadedStrings #-}++module HostSpec (spec) where++import Control.Concurrent (newChan, readChan, writeChan)+import Control.Exception (finally)+import Control.Monad (replicateM)+import Data.List (sort)+import qualified Data.Map.Strict as Map+import DBus (busName_)+import DBus.Client+import StatusNotifier.Host.Service hiding (startWatcher)+import System.Timeout (timeout)+import Test.Hspec++import TestSupport++spec :: Spec+spec = around withIsolatedSessionBus $ do+  describe "StatusNotifier.Host.Service integration" $ do+    it "receives ItemAdded then ItemRemoved for a registered item" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-a"}+      events <- newChan+      _ <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))++      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.HostItemA" defaultPath "folder"++      added <- timeout 1500000 (readChan events)+      added `shouldBe` Just (ItemAdded, busName_ "org.test.HostItemA")++      cleanup++      removed <- timeout 1500000 (readChan events)+      removed `shouldBe` Just (ItemRemoved, busName_ "org.test.HostItemA")++    it "replays existing items to newly-added handlers" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.HostItemB" defaultPath "browser"++      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-b"}+      events <- newChan+      _ <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))++      replayed <- timeout 1500000 (readChan events)+      replayed `shouldBe` Just (ItemAdded, busName_ "org.test.HostItemB")++      cleanup++    it "stops dispatching updates after removeUpdateHandler" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-c"}+      events <- newChan+      token <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))+      removeUpdateHandler host token++      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.HostItemC" defaultPath "help-about"+      cleanup++      noEvent <- timeout 500000 (readChan events)+      noEvent `shouldBe` Nothing++    it "keeps itemInfoMap in sync across add/remove transitions" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-d"}+      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.HostItemD" defaultPath "mail-send"++      addedMapReady <-+        waitFor 1500000 $ do+          current <- itemInfoMap host+          pure $ busName_ "org.test.HostItemD" `elem` Map.keys current+      addedMapReady `shouldBe` True++      cleanup++      removedMapReady <-+        waitFor 1500000 $ do+          current <- itemInfoMap host+          pure $ busName_ "org.test.HostItemD" `notElem` Map.keys current+      removedMapReady `shouldBe` True++    it "loads item icon names into itemInfoMap" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-e"}+      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.HostItemE" defaultPath "drive-harddisk"+      (do+          populated <-+            waitFor 1500000 $ do+              current <- itemInfoMap host+              pure $ case Map.lookup (busName_ "org.test.HostItemE") current of+                Just info -> iconName info == "drive-harddisk"+                Nothing -> False+          populated `shouldBe` True+        ) `finally` cleanup++    it "replays all pre-existing items to newly-added handlers" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      itemClientA <- connectSession+      itemClientB <- connectSession+      cleanupA <- registerSimpleItem itemClientA "org.test.HostItemF" defaultPath "audio-volume-high"+      cleanupB <- registerSimpleItem itemClientB "org.test.HostItemG" defaultPath "audio-volume-low"+      (do+          Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-f"}+          events <- newChan+          _ <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))+          replayed <- replicateM 2 (timeout 1500000 (readChan events))+          let addedNames = sort [name | Just (ItemAdded, name) <- replayed]+          addedNames+            `shouldBe` sort [busName_ "org.test.HostItemF", busName_ "org.test.HostItemG"]+        ) `finally` (cleanupA >> cleanupB)++    it "does not emit updates for forceUpdate on unknown services" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-g"}+      events <- newChan+      _ <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))+      forceUpdate host (busName_ "org.test.DoesNotExist")+      noEvent <- timeout 500000 (readChan events)+      noEvent `shouldBe` Nothing+      current <- itemInfoMap host+      Map.null current `shouldBe` True++defaultPath :: String+defaultPath = "/StatusNotifierItem"

@@ -0,0 +1,13 @@+module Main (main) where++import Test.Hspec++import qualified HostSpec+import qualified UtilSpec+import qualified WatcherSpec++main :: IO ()+main = hspec $ do+  UtilSpec.spec+  WatcherSpec.spec+  HostSpec.spec

@@ -0,0 +1,141 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module TestSupport+  ( withIsolatedSessionBus+  , startWatcher+  , registerSimpleItem+  , waitFor+  ) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, bracket, try)+import DBus (busName_, objectPath_)+import DBus.Client+  ( Client+  , Interface (..)+  , RequestNameReply (NamePrimaryOwner)+  , connectSession+  , export+  , readOnlyProperty+  , releaseName+  , requestName+  )+import StatusNotifier.Watcher.Constants+  ( defaultWatcherParams+  , watcherDBusClient+  , watcherStop+  )+import qualified StatusNotifier.Watcher.Client as WatcherClient+import qualified StatusNotifier.Watcher.Service as WatcherService+import System.Environment (lookupEnv, setEnv, unsetEnv)+import System.Exit (ExitCode, ExitCode (ExitSuccess))+import System.Process (readProcessWithExitCode)+import Test.Hspec++data BusEnv = BusEnv+  { previousAddress :: Maybe String+  , previousPid :: Maybe String+  , daemonPid :: String+  }++withIsolatedSessionBus :: ActionWith () -> IO ()+withIsolatedSessionBus action =+  bracket setup teardown (const $ action ())++setup :: IO BusEnv+setup = do+  oldAddress <- lookupEnv "DBUS_SESSION_BUS_ADDRESS"+  oldPid <- lookupEnv "DBUS_SESSION_BUS_PID"+  (code, out, err) <-+    readProcessWithExitCode+      "dbus-daemon"+      ["--session", "--fork", "--print-address=1", "--print-pid=1"]+      ""+  case (code, lines out) of+    (ExitSuccess, address : pidLine : _) -> do+      setEnv "DBUS_SESSION_BUS_ADDRESS" address+      setEnv "DBUS_SESSION_BUS_PID" pidLine+      pure BusEnv+        { previousAddress = oldAddress+        , previousPid = oldPid+        , daemonPid = pidLine+        }+    _ ->+      error $+        "Failed to start test dbus-daemon: exit="+          <> show code+          <> " stdout="+          <> show out+          <> " stderr="+          <> show err++teardown :: BusEnv -> IO ()+teardown BusEnv {..} = do+  -- Terminate bus daemon. If it is already gone, ignore the error.+  _ <-+    ( try $+        readProcessWithExitCode+          "kill"+          ["-TERM", daemonPid]+          ""+    ) ::+      IO (Either SomeException (ExitCode, String, String))+  restore "DBUS_SESSION_BUS_ADDRESS" previousAddress+  restore "DBUS_SESSION_BUS_PID" previousPid+  where+    restore key value = maybe (unsetEnv key) (setEnv key) value++startWatcher :: IO Client+startWatcher = do+  client <- connectSession+  (_, startFn) <-+    WatcherService.buildWatcher+      defaultWatcherParams+        { watcherDBusClient = Just client+        , watcherStop = pure ()+        }+  reply <- startFn+  reply `shouldBe` NamePrimaryOwner+  pure client++registerSimpleItem ::+  Client ->+  String ->+  String ->+  String ->+  IO (IO ())+registerSimpleItem client busName objectPath iconName = do+  let iface =+        Interface+          { interfaceName = "org.kde.StatusNotifierItem"+          , interfaceMethods = []+          , interfaceProperties =+              [ readOnlyProperty "IconName" (pure iconName)+              , readOnlyProperty "OverlayIconName" (pure ("" :: String))+              , readOnlyProperty "ItemIsMenu" (pure False)+              ]+          , interfaceSignals = []+          }+      path = objectPath_ objectPath++  export client path iface+  _ <- requestName client (busName_ busName) []+  registerResult <- WatcherClient.registerStatusNotifierItem client busName+  registerResult `shouldBe` Right ()+  pure $ do+    _ <- releaseName client (busName_ busName)+    pure ()++waitFor :: Int -> IO Bool -> IO Bool+waitFor timeoutMicros predicate =+  go 0+  where+    step = 20000+    go elapsed+      | elapsed >= timeoutMicros = predicate+      | otherwise = do+          ok <- predicate+          if ok+            then pure True+            else threadDelay step >> go (elapsed + step)

@@ -0,0 +1,83 @@+{-# LANGUAGE OverloadedStrings #-}++module UtilSpec (spec) where++import qualified DBus.Internal.Message as M+import DBus.Internal.Types (ErrorName, Serial (..), errorName_)+import StatusNotifier.Util+import Test.Hspec++spec :: Spec+spec = do+  describe "splitServiceName" $ do+    it "splits a bus name with no path" $+      splitServiceName "org.example.Service"+        `shouldBe` ("org.example.Service", Nothing)++    it "splits a bus name with an object path suffix" $+      splitServiceName "org.example.Service/StatusNotifierItem"+        `shouldBe` ("org.example.Service", Just "/StatusNotifierItem")++    it "splits a bus name with a nested object path suffix" $+      splitServiceName "org.example.Service/StatusNotifierItem/Submenu"+        `shouldBe` ("org.example.Service", Just "/StatusNotifierItem/Submenu")++    it "keeps path-only values intact when no bus name is present" $+      splitServiceName "/StatusNotifierItem"+        `shouldBe` ("/StatusNotifierItem", Nothing)++    it "returns an empty bus component for empty input" $+      splitServiceName ""+        `shouldBe` ("", Nothing)++  describe "convertARGBToABGR" $ do+    it "swaps red and blue channels while preserving alpha/green" $+      convertARGBToABGR 0x11223344 `shouldBe` 0x11443322++    it "leaves values unchanged when red and blue channels are equal" $+      convertARGBToABGR 0xAADD33DD `shouldBe` 0xAADD33DD++  describe "maybeToEither" $ do+    it "returns Right for Just values" $+      maybeToEither "err" (Just (3 :: Int)) `shouldBe` Right 3++    it "returns Left default for Nothing" $+      maybeToEither "err" (Nothing :: Maybe Int) `shouldBe` Left ("err" :: String)++  describe "exemptUnknownMethod" $ do+    it "converts unknown-method errors to Right default" $+      exemptUnknownMethod "fallback" (Left $ mkMethodError errorUnknownMethod)+        `shouldBe` Right ("fallback" :: String)++    it "keeps non-unknown errors intact" $+      exemptUnknownMethod "fallback" (Left $ mkMethodError errorFailed)+        `shouldBe` Left (mkMethodError errorFailed)++    it "passes through successful values unchanged" $+      exemptUnknownMethod "fallback" (Right ("ok" :: String))+        `shouldBe` Right "ok"++  describe "exemptAll" $ do+    it "maps all errors to Right default" $+      exemptAll "fallback" (Left $ mkMethodError $ errorName_ "org.example.Error")+        `shouldBe` Right ("fallback" :: String)++    it "passes through successful values unchanged" $+      exemptAll "fallback" (Right ("ok" :: String))+        `shouldBe` Right "ok"++mkMethodError :: ErrorName -> M.MethodError+mkMethodError errName =+  M.MethodError+    { M.methodErrorName = errName+    , M.methodErrorSerial = Serial 0+    , M.methodErrorSender = Nothing+    , M.methodErrorDestination = Nothing+    , M.methodErrorBody = []+    }++errorUnknownMethod :: ErrorName+errorUnknownMethod = errorName_ "org.freedesktop.DBus.Error.UnknownMethod"++errorFailed :: ErrorName+errorFailed = errorName_ "org.freedesktop.DBus.Error.Failed"

@@ -0,0 +1,135 @@+{-# LANGUAGE OverloadedStrings #-}++module WatcherSpec (spec) where++import Control.Exception (finally)+import Data.Either (isLeft)+import Data.List (isPrefixOf)+import DBus.Client+import qualified StatusNotifier.Watcher.Client as WatcherClient+import Test.Hspec++import TestSupport++spec :: Spec+spec = around withIsolatedSessionBus $ do+  describe "StatusNotifier.Watcher.Service integration" $ do+    it "starts with no registered items" $ \() -> do+      watcher <- startWatcher+      entries <- WatcherClient.getRegisteredSNIEntries watcher+      entries `shouldBe` Right []++    it "registers an item and exposes it via RegisteredSNIEntries" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.ItemA" defaultPath "network-wireless"+      (do+        result <- WatcherClient.getRegisteredSNIEntries watcher+        result `shouldSatisfy` \v ->+          case v of+            Right entries -> any ((== defaultPath) . snd) entries+            Left _ -> False+        ) `finally` cleanup++    it "is idempotent when the same item registers twice" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      _ <- requestName itemClient "org.test.ItemB" []+      WatcherClient.registerStatusNotifierItem itemClient "org.test.ItemB"+        `shouldReturn` Right ()+      WatcherClient.registerStatusNotifierItem itemClient "org.test.ItemB"+        `shouldReturn` Right ()+      Right entries <- WatcherClient.getRegisteredSNIEntries watcher+      let matches = filter (== ("org.test.ItemB", "/StatusNotifierItem")) entries+      length matches `shouldBe` 1++    it "returns the object path for a registered name with no explicit path" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      _ <- requestName itemClient "org.test.ItemC" []+      WatcherClient.registerStatusNotifierItem itemClient "org.test.ItemC"+        `shouldReturn` Right ()+      WatcherClient.getObjectPathForItemName watcher "org.test.ItemC"+        `shouldReturn` Right "/StatusNotifierItem"++    it "accepts path-only registration and stores the sender unique name" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      WatcherClient.registerStatusNotifierItem itemClient "/CustomPath"+        `shouldReturn` Right ()+      Right entries <- WatcherClient.getRegisteredSNIEntries watcher+      let customEntries = filter ((== "/CustomPath") . snd) entries+      length customEntries `shouldBe` 1+      case customEntries of+        (serviceName, _) : _ -> serviceName `shouldSatisfy` (":" `isPrefixOf`)+        _ -> expectationFailure "Expected exactly one custom entry"++    it "returns direct paths from service/path lookups without registration" $ \() -> do+      watcher <- startWatcher+      WatcherClient.getObjectPathForItemName watcher "org.test.Missing/CustomPath"+        `shouldReturn` Right "/CustomPath"++    it "returns an error for unknown services without explicit paths" $ \() -> do+      watcher <- startWatcher+      result <- WatcherClient.getObjectPathForItemName watcher "org.test.Missing"+      result `shouldSatisfy` isLeft++    it "rejects registration for unowned well-known names" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      result <- WatcherClient.registerStatusNotifierItem itemClient "org.test.Unowned"+      result `shouldSatisfy` isLeft+      Right entries <- WatcherClient.getRegisteredSNIEntries watcher+      entries `shouldNotContain` [("org.test.Unowned", "/StatusNotifierItem")]++    it "deduplicates a client that registers by path and then by service name" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      WatcherClient.registerStatusNotifierItem itemClient "/StatusNotifierItem"+        `shouldReturn` Right ()+      _ <- requestName itemClient "org.test.PathThenName" []+      WatcherClient.registerStatusNotifierItem itemClient "org.test.PathThenName"+        `shouldReturn` Right ()+      Right entries <- WatcherClient.getRegisteredSNIEntries watcher+      let matching = filter ((== "/StatusNotifierItem") . snd) entries+      length matching `shouldBe` 1++    it "unregisters items when their bus name disappears" $ \() -> do+      watcher <- startWatcher+      itemClient <- connectSession+      cleanup <- registerSimpleItem itemClient "org.test.ItemD" defaultPath "utilities-terminal"+      Right before <- WatcherClient.getRegisteredSNIEntries watcher+      before `shouldContain` [("org.test.ItemD", "/StatusNotifierItem")]+      cleanup+      removed <-+        waitFor 1500000 $ do+          result <- WatcherClient.getRegisteredSNIEntries watcher+          pure $ case result of+            Right entries -> ("org.test.ItemD", "/StatusNotifierItem") `notElem` entries+            Left _ -> False+      removed `shouldBe` True++    it "only unregisters the disconnected item when multiple are present" $ \() -> do+      watcher <- startWatcher+      itemClientA <- connectSession+      itemClientB <- connectSession+      cleanupA <- registerSimpleItem itemClientA "org.test.ItemE" defaultPath "media-playback-start"+      cleanupB <- registerSimpleItem itemClientB "org.test.ItemF" defaultPath "media-playback-stop"+      (do+          Right before <- WatcherClient.getRegisteredSNIEntries watcher+          before `shouldContain` [("org.test.ItemE", "/StatusNotifierItem")]+          before `shouldContain` [("org.test.ItemF", "/StatusNotifierItem")]+          cleanupA+          stable <-+            waitFor 1500000 $ do+              result <- WatcherClient.getRegisteredSNIEntries watcher+              pure $ case result of+                Right entries ->+                  ("org.test.ItemE", "/StatusNotifierItem") `notElem` entries+                    && ("org.test.ItemF", "/StatusNotifierItem") `elem` entries+                Left _ -> False+          stable `shouldBe` True+        ) `finally` cleanupB++defaultPath :: String+defaultPath = "/StatusNotifierItem"