status-notifier-item 0.3.2.10 → 0.3.2.11

raw patch · 7 files changed

+760/−453 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +14/−0
• src/StatusNotifier/Host/Service.hs +548/−401
• src/StatusNotifier/Watcher/Service.hs +18/−9
• status-notifier-item.cabal +5/−5
• test/HostSpec.hs +136/−37
• test/TestSupport.hs +12/−1
• test/WatcherSpec.hs +27/−0

@@ -1,10 +1,24 @@ # Changelog for status-notifier-item +## Unreleased++## 0.3.2.11 - 2026-03-29+- Watcher: accept explicit SNI registrations initiated from a separate unique+  bus name owned by the same process, fixing KDE/Qt multi-connection+  registrations.+- Host: deduplicate logical items across bus-name churn so tray hosts keep a+  single logical icon when senders change identity.+- Add regression tests for the multi-connection registration and bus-name churn+  deduplication cases.+ ## 0.3.2.10 - 2026-02-17 - Relax upper bounds to restore Stackage nightly compatibility:   `optparse-applicative < 0.20` and `template-haskell < 2.24`.  ## 0.3.2.9 - 2026-02-17+- Version bump only; no library changes beyond `0.3.2.8`.++## 0.3.2.8 - 2026-02-17 - Host: eliminate duplicate `ItemAdded` deliveries to newly-registered update   handlers by making handler registration + initial replay atomic with respect   to item map updates.

@@ -1,44 +1,44 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+ module StatusNotifier.Host.Service where -import           Control.Applicative-import           Control.Arrow-import           Control.Concurrent-import           Control.Concurrent.MVar-import           Control.Lens-import           Control.Lens.Tuple-import           Control.Monad-import           Control.Monad.Trans.Class-import           Control.Monad.Trans.Except-import           Control.Monad.Trans.Maybe-import           DBus-import           DBus.Client-import           DBus.Generation+import Control.Applicative+import Control.Arrow+import Control.Concurrent+import Control.Concurrent.MVar+import Control.Lens+import Control.Lens.Tuple+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import Control.Monad.Trans.Maybe+import DBus+import DBus.Client+import DBus.Generation import qualified DBus.Internal.Message as M-import           DBus.Internal.Types+import DBus.Internal.Types import qualified DBus.TH as DTH import qualified Data.ByteString as BS-import           Data.Coerce-import           Data.Either-import           Data.Int+import Data.Coerce+import Data.Either+import Data.Int import qualified Data.Map.Strict as Map-import           Data.Maybe-import           Data.String-import           Data.Typeable-import           Data.Unique-import           Data.Word-import           System.Log.Logger-import           Text.Printf-+import Data.Maybe+import Data.String+import Data.Typeable+import Data.Unique+import Data.Word import qualified StatusNotifier.Item.Client as I-import           StatusNotifier.Util+import StatusNotifier.Util import qualified StatusNotifier.Watcher.Client as W import qualified StatusNotifier.Watcher.Constants as W-import qualified StatusNotifier.Watcher.Signals as W import qualified StatusNotifier.Watcher.Service as W+import qualified StatusNotifier.Watcher.Signals as W+import System.Log.Logger+import Text.Printf  statusNotifierHostString :: String statusNotifierHostString = "StatusNotifierHost"@@ -54,34 +54,36 @@   | OverlayIconUpdated   | StatusUpdated   | TitleUpdated-  | ToolTipUpdated deriving (Eq, Show)+  | ToolTipUpdated+  deriving (Eq, Show)  type UpdateHandler = UpdateType -> ItemInfo -> IO ()  data Params = Params-  { dbusClient :: Maybe Client-  , uniqueIdentifier :: String-  , namespace :: String-  , startWatcher :: Bool-  , matchSenderWhenNameOwnersUnmatched :: Bool+  { dbusClient :: Maybe Client,+    uniqueIdentifier :: String,+    namespace :: String,+    startWatcher :: Bool,+    matchSenderWhenNameOwnersUnmatched :: Bool   }  hostLogger = logM "StatusNotifier.Host.Service" -defaultParams = Params-  { dbusClient = Nothing-  , uniqueIdentifier = ""-  , namespace = "org.kde"-  , startWatcher = False-  , matchSenderWhenNameOwnersUnmatched = True-  }+defaultParams =+  Params+    { dbusClient = Nothing,+      uniqueIdentifier = "",+      namespace = "org.kde",+      startWatcher = False,+      matchSenderWhenNameOwnersUnmatched = True+    }  type ImageInfo = [(Int32, Int32, BS.ByteString)]  isExpectedPropertyUpdateFailure :: M.MethodError -> Bool-isExpectedPropertyUpdateFailure M.MethodError { M.methodErrorName = errName } =-  errName == errorUnknownMethod ||-  errName == errorName_ "org.freedesktop.DBus.Error.InvalidArgs"+isExpectedPropertyUpdateFailure M.MethodError {M.methodErrorName = errName} =+  errName == errorUnknownMethod+    || errName == errorName_ "org.freedesktop.DBus.Error.InvalidArgs"  propertyUpdateFailureLogLevel :: [M.MethodError] -> [a] -> Priority propertyUpdateFailureLogLevel failures updates@@ -90,167 +92,253 @@   | otherwise = ERROR  data ItemInfo = ItemInfo-  { itemServiceName :: BusName-  , itemServicePath :: ObjectPath-  , itemId :: Maybe String-  , itemStatus :: Maybe String-  , itemCategory :: Maybe String-  , itemToolTip :: Maybe (String, ImageInfo, String, String)-  , iconTitle :: String-  , iconName :: String-  , overlayIconName :: Maybe String-  , iconThemePath :: Maybe String-  , iconPixmaps :: ImageInfo-  , overlayIconPixmaps :: ImageInfo-  , menuPath :: Maybe ObjectPath-  , itemIsMenu :: Bool-  } deriving (Eq, Show)+  { itemServiceName :: BusName,+    itemServicePath :: ObjectPath,+    itemId :: Maybe String,+    itemStatus :: Maybe String,+    itemCategory :: Maybe String,+    itemToolTip :: Maybe (String, ImageInfo, String, String),+    iconTitle :: String,+    iconName :: String,+    overlayIconName :: Maybe String,+    iconThemePath :: Maybe String,+    iconPixmaps :: ImageInfo,+    overlayIconPixmaps :: ImageInfo,+    menuPath :: Maybe ObjectPath,+    itemIsMenu :: Bool+  }+  deriving (Eq, Show) +data LogicalDuplicateKey = LogicalDuplicateKey+  { duplicateItemId :: Maybe String,+    duplicateIconTitle :: Maybe String,+    duplicateIconName :: Maybe String,+    duplicateCategory :: Maybe String,+    duplicateMenuPath :: Maybe ObjectPath,+    duplicatePath :: ObjectPath,+    duplicateIsMenu :: Bool+  }+  deriving (Eq, Show)+ supressPixelData info =-  info { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info }+  info+    { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info,+      overlayIconPixmaps = map (\(w, h, _) -> (w, h, "")) $ overlayIconPixmaps info+    } +normalizeOptionalString :: String -> Maybe String+normalizeOptionalString value+  | null value = Nothing+  | otherwise = Just value++logicalDuplicateKey :: ItemInfo -> Maybe LogicalDuplicateKey+logicalDuplicateKey ItemInfo {..} =+  let key =+        LogicalDuplicateKey+          { duplicateItemId = itemId >>= normalizeOptionalString,+            duplicateIconTitle = normalizeOptionalString iconTitle,+            duplicateIconName = normalizeOptionalString iconName,+            duplicateCategory = itemCategory >>= normalizeOptionalString,+            duplicateMenuPath = menuPath,+            duplicatePath = itemServicePath,+            duplicateIsMenu = itemIsMenu+          }+      hasStableIdentity =+        isJust (duplicateItemId key)+          || isJust (duplicateIconTitle key)+          || isJust (duplicateIconName key)+   in if hasStableIdentity then Just key else Nothing++findUniqueMatchM :: (a -> IO Bool) -> [a] -> IO (Maybe a)+findUniqueMatchM predicate values = go values Nothing+  where+    go [] match = pure match+    go (value : rest) match = do+      matches <- predicate value+      case (matches, match) of+        (False, _) -> go rest match+        (True, Nothing) -> go rest (Just value)+        (True, Just _) -> pure Nothing+ makeLensesWithLSuffix ''ItemInfo  convertPixmapsToHostByteOrder ::   [(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)] convertPixmapsToHostByteOrder = map $ over _3 networkToSystemByteOrder -callFromInfo fn ItemInfo { itemServiceName = name-                         , itemServicePath = path-                         } = fn name path+callFromInfo+  fn+  ItemInfo+    { itemServiceName = name,+      itemServicePath = path+    } = fn name path  data Host = Host-  { itemInfoMap :: IO (Map.Map BusName ItemInfo)-  , addUpdateHandler :: UpdateHandler -> IO Unique-  , removeUpdateHandler :: Unique -> IO ()-  , forceUpdate :: BusName -> IO ()-  } deriving Typeable+  { itemInfoMap :: IO (Map.Map BusName ItemInfo),+    addUpdateHandler :: UpdateHandler -> IO Unique,+    removeUpdateHandler :: Unique -> IO (),+    forceUpdate :: BusName -> IO ()+  }+  deriving (Typeable)  build :: Params -> IO (Maybe Host)-build Params { dbusClient = mclient-             , namespace = namespaceString-             , uniqueIdentifier = uniqueID-             , startWatcher = shouldStartWatcher-             , matchSenderWhenNameOwnersUnmatched = doMatchUnmatchedSender-             } = do-  client <- maybe connectSession return mclient-  itemInfoMapVar <- newMVar Map.empty-  updateHandlersVar <- newMVar ([] :: [(Unique, UpdateHandler)])-  let busName = getBusName namespaceString uniqueID+build+  Params+    { dbusClient = mclient,+      namespace = namespaceString,+      uniqueIdentifier = uniqueID,+      startWatcher = shouldStartWatcher,+      matchSenderWhenNameOwnersUnmatched = doMatchUnmatchedSender+    } = do+    client <- maybe connectSession return mclient+    itemInfoMapVar <- newMVar Map.empty+    updateHandlersVar <- newMVar ([] :: [(Unique, UpdateHandler)])+    let busName = getBusName namespaceString uniqueID -      logError = hostLogger ERROR-      logErrorWithMessage message error = logError message >> logError (show error)+        logError = hostLogger ERROR+        logErrorWithMessage message error = logError message >> logError (show error) -      logInfo = hostLogger INFO-      logDebug = hostLogger DEBUG-      logErrorAndThen andThen e = logError (show e) >> andThen+        logInfo = hostLogger INFO+        logDebug = hostLogger DEBUG+        logErrorAndThen andThen e = logError (show e) >> andThen -      doUpdateForHandler utype uinfo (unique, handler) = do-        -- This is extremely chatty under normal operation; keep it at DEBUG.-        logDebug (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s"-                          (show utype)-                          (show $ supressPixelData uinfo)-                          (show $ hashUnique unique))-        forkIO $ handler utype uinfo+        doUpdateForHandler utype uinfo (unique, handler) = do+          -- This is extremely chatty under normal operation; keep it at DEBUG.+          logDebug+            ( printf+                "Sending update (iconPixmaps suppressed): %s %s, for handler %s"+                (show utype)+                (show $ supressPixelData uinfo)+                (show $ hashUnique unique)+            )+          forkIO $ handler utype uinfo -      doUpdate utype uinfo =-        readMVar updateHandlersVar >>= mapM_ (doUpdateForHandler utype uinfo)+        doUpdate utype uinfo =+          readMVar updateHandlersVar >>= mapM_ (doUpdateForHandler utype uinfo) -      addHandler handler = do-        unique <- newUnique-        modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do-          -- Register and replay under the item map lock so a concurrent add-          -- cannot be delivered both live and via replay.-          modifyMVar_ updateHandlersVar (return . ((unique, handler):))-          let doUpdateForInfo info = doUpdateForHandler ItemAdded info (unique, handler)-          mapM_ doUpdateForInfo itemInfoMap-          return itemInfoMap-        return unique+        addHandler handler = do+          unique <- newUnique+          modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do+            logInfo $+              printf+                "Registering update handler %s with %d replay items: %s"+                (show $ hashUnique unique)+                (Map.size itemInfoMap)+                (show $ Map.keys itemInfoMap)+            -- Register and replay under the item map lock so a concurrent add+            -- cannot be delivered both live and via replay.+            modifyMVar_ updateHandlersVar (return . ((unique, handler) :))+            let doUpdateForInfo info = doUpdateForHandler ItemAdded info (unique, handler)+            mapM_ doUpdateForInfo itemInfoMap+            return itemInfoMap+          return unique -      removeHandler unique =-        modifyMVar_ updateHandlersVar (return . filter ((/= unique) . fst))+        removeHandler unique =+          modifyMVar_ updateHandlersVar $ \handlers -> do+            let newHandlers = filter ((/= unique) . fst) handlers+            logInfo $+              printf+                "Removing update handler %s; remaining handlers: %d"+                (show $ hashUnique unique)+                (length newHandlers)+            return newHandlers -      getPixmaps getter a1 a2 a3 =-        fmap convertPixmapsToHostByteOrder <$> getter a1 a2 a3+        getPixmaps getter a1 a2 a3 =+          fmap convertPixmapsToHostByteOrder <$> getter a1 a2 a3 -      getMaybe fn a b c = right Just <$> fn a b c+        getMaybe fn a b c = right Just <$> fn a b c -      parseServiceName name =-        let (bus, maybePath) = splitServiceName name-        in (busName_ bus, objectPath_ <$> maybePath)+        parseServiceName name =+          let (bus, maybePath) = splitServiceName name+           in (busName_ bus, objectPath_ <$> maybePath) -      buildItemInfo name = runExceptT $ do-        let (busName, maybePath) = parseServiceName name-        path <- case maybePath of-          Just parsedPath -> return parsedPath-          Nothing -> objectPath_ <$> ExceptT-            (W.getObjectPathForItemName client (coerce busName))-        let doGetDef def fn =-              ExceptT $ exemptAll def <$> fn client busName path-            doGet fn = ExceptT $ fn client busName path-        pixmaps <- doGetDef [] $ getPixmaps I.getIconPixmap-        iName <- doGetDef name I.getIconName-        overlayPixmap <- doGetDef [] $ getPixmaps I.getOverlayIconPixmap-        overlayIName <- doGetDef Nothing $ getMaybe I.getOverlayIconName-        themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath-        menu <- doGetDef Nothing $ getMaybe I.getMenu-        title <- doGetDef "" I.getTitle-        tooltip <- doGetDef Nothing $ getMaybe I.getToolTip-        idString <- doGetDef Nothing $ getMaybe I.getId-        status <- doGetDef Nothing $ getMaybe I.getStatus-        category <- doGetDef Nothing $ getMaybe I.getCategory-        itemIsMenu <- doGetDef True I.getItemIsMenu-        return ItemInfo-                 { itemServiceName = busName-                 , itemId = idString-                 , itemStatus = status-                 , itemCategory = category-                 , itemServicePath = path-                 , itemToolTip = tooltip-                 , iconPixmaps = pixmaps-                 , iconThemePath = themePath-                 , iconName = iName-                 , iconTitle = title-                 , menuPath = menu-                 , overlayIconName = overlayIName-                 , overlayIconPixmaps = overlayPixmap-                 , itemIsMenu = itemIsMenu-                 }+        buildItemInfo name = runExceptT $ do+          let (busName, maybePath) = parseServiceName name+          path <- case maybePath of+            Just parsedPath -> return parsedPath+            Nothing ->+              objectPath_+                <$> ExceptT+                  (W.getObjectPathForItemName client (coerce busName))+          let doGetDef def fn =+                ExceptT $ exemptAll def <$> fn client busName path+              doGet fn = ExceptT $ fn client busName path+          pixmaps <- doGetDef [] $ getPixmaps I.getIconPixmap+          iName <- doGetDef name I.getIconName+          overlayPixmap <- doGetDef [] $ getPixmaps I.getOverlayIconPixmap+          overlayIName <- doGetDef Nothing $ getMaybe I.getOverlayIconName+          themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath+          menu <- doGetDef Nothing $ getMaybe I.getMenu+          title <- doGetDef "" I.getTitle+          tooltip <- doGetDef Nothing $ getMaybe I.getToolTip+          idString <- doGetDef Nothing $ getMaybe I.getId+          status <- doGetDef Nothing $ getMaybe I.getStatus+          category <- doGetDef Nothing $ getMaybe I.getCategory+          itemIsMenu <- doGetDef True I.getItemIsMenu+          return+            ItemInfo+              { itemServiceName = busName,+                itemId = idString,+                itemStatus = status,+                itemCategory = category,+                itemServicePath = path,+                itemToolTip = tooltip,+                iconPixmaps = pixmaps,+                iconThemePath = themePath,+                iconName = iName,+                iconTitle = title,+                menuPath = menu,+                overlayIconName = overlayIName,+                overlayIconPixmaps = overlayPixmap,+                itemIsMenu = itemIsMenu+              } -      createAll serviceNames = do-        (errors, itemInfos) <--          partitionEithers <$> mapM buildItemInfo serviceNames-        mapM_ (logErrorWithMessage "Error in item building at startup:") errors-        return itemInfos+        createAll serviceNames = do+          (errors, itemInfos) <-+            partitionEithers <$> mapM buildItemInfo serviceNames+          mapM_ (logErrorWithMessage "Error in item building at startup:") errors+          return itemInfos -      registerWithPairs =-        mapM (uncurry clientSignalRegister)-        where logUnableToCallSignal signal =-                hostLogger ERROR $ printf "Unable to call handler with %s" $-                     show signal-              clientSignalRegister signalRegisterFn handler =-                signalRegisterFn client matchAny handler logUnableToCallSignal+        registerWithPairs =+          mapM (uncurry clientSignalRegister)+          where+            logUnableToCallSignal signal =+              hostLogger ERROR $+                printf "Unable to call handler with %s" $+                  show signal+            clientSignalRegister signalRegisterFn handler =+              signalRegisterFn client matchAny handler logUnableToCallSignal -      -- Resolve a bus name to its unique name owner when it is well-known.-      -- For unique names (":1.42"), the owner is the name itself.-      resolveOwner :: BusName -> IO (Maybe BusName)-      resolveOwner bus =-        case (coerce bus :: String) of-          ':' : _ -> pure (Just bus)-          _ ->-            either (const Nothing) (Just . busName_) <$>-              DTH.getNameOwner client (coerce bus)+        -- Resolve a bus name to its unique name owner when it is well-known.+        -- For unique names (":1.42"), the owner is the name itself.+        resolveOwner :: BusName -> IO (Maybe BusName)+        resolveOwner bus =+          case (coerce bus :: String) of+            ':' : _ -> pure (Just bus)+            _ ->+              either (const Nothing) (Just . busName_)+                <$> DTH.getNameOwner client (coerce bus) -      handleItemAdded serviceName =-        modifyMVar_ itemInfoMapVar $ \itemInfoMap ->-          buildItemInfo serviceName >>=-          either (logErrorAndThen $ return itemInfoMap)-                 (addItemInfo itemInfoMap)-          where addItemInfo map itemInfo@ItemInfo{ itemServiceName = newName-                                                 , itemServicePath = newPath-                                                 } =-                  if Map.member newName map-                  then return map+        handleItemAdded serviceName =+          modifyMVar_ itemInfoMapVar $ \itemInfoMap ->+            buildItemInfo serviceName+              >>= either+                (logErrorAndThen $ return itemInfoMap)+                (addItemInfo itemInfoMap)+          where+            addItemInfo+              map+              itemInfo@ItemInfo+                { itemServiceName = newName,+                  itemServicePath = newPath+                } =+                if Map.member newName map+                  then do+                    logDebug $+                      printf+                        "Ignoring duplicate ItemAdded for %s because the exact service is already tracked."+                        (coerce newName :: String)+                    return map                   else do                     -- When the watcher restarts, some items may re-register                     -- under a different bus name (e.g. switching between@@ -264,267 +352,326 @@                             existingName /= newName                               && existingOwner == newOwner                               && itemServicePath existingInfo == newPath+                        matchesLogicalDuplicate (existingName, existingInfo) =+                          pure $+                            existingName /= newName+                              && logicalDuplicateKey existingInfo == logicalDuplicateKey itemInfo                         addFresh = do                           doUpdate ItemAdded itemInfo                           pure (Map.insert newName itemInfo map)+                        replaceExisting :: BusName -> ItemInfo -> String -> IO (Map.Map BusName ItemInfo)+                        replaceExisting existingName existingInfo reason = do+                          logInfo $+                            printf+                              "Replacing tracked item %s with %s for %s"+                              (coerce existingName :: String)+                              (coerce newName :: String)+                              reason+                          doUpdate ItemRemoved existingInfo+                          doUpdate ItemAdded itemInfo+                          pure $+                            Map.insert newName itemInfo $+                              Map.delete existingName map+                        tryLogicalDuplicateMatch =+                          case logicalDuplicateKey itemInfo of+                            Nothing -> addFresh+                            Just duplicateKey -> do+                              existing <- findUniqueMatchM matchesLogicalDuplicate (Map.toList map)+                              case existing of+                                Just (existingName, existingInfo) ->+                                  replaceExisting+                                    existingName+                                    existingInfo+                                    (printf "logical duplicate key %s" (show duplicateKey))+                                Nothing -> addFresh                     case newOwner of-                      Nothing -> addFresh+                      Nothing -> tryLogicalDuplicateMatch                       Just _ -> do                         existing <- findM matchesOwnerAndPath (Map.toList map)                         case existing of-                          Nothing -> addFresh-                          Just (existingName, existingInfo) -> do-                            doUpdate ItemRemoved existingInfo-                            doUpdate ItemAdded itemInfo-                            pure $-                              Map.insert newName itemInfo $-                                Map.delete existingName map+                          Nothing -> do+                            logDebug $+                              printf+                                "Tracking fresh item %s at %s"+                                (coerce newName :: String)+                                (coerce newPath :: String)+                            tryLogicalDuplicateMatch+                          Just (existingName, existingInfo) ->+                            replaceExisting+                              existingName+                              existingInfo+                              (printf "shared owner/path at %s" (coerce newPath :: String)) -      getObjectPathForItemName name =-        maybe I.defaultPath itemServicePath . Map.lookup name <$>-        readMVar itemInfoMapVar+        getObjectPathForItemName name =+          maybe I.defaultPath itemServicePath . Map.lookup name+            <$> readMVar itemInfoMapVar -      handleItemRemoved serviceName =-        modifyMVar itemInfoMapVar doRemove >>=-        maybe logNonExistentRemoval (doUpdate ItemRemoved)-        where-          busName = fst (parseServiceName serviceName)-          doRemove currentMap =-            return (Map.delete busName currentMap, Map.lookup busName currentMap)-          logNonExistentRemoval =-            -- This can happen due to watcher/host races (e.g. watcher restart).-            hostLogger DEBUG $ printf "Attempt to remove unknown item %s" $-                       show busName+        handleItemRemoved serviceName =+          modifyMVar itemInfoMapVar doRemove+            >>= maybe logNonExistentRemoval (doUpdate ItemRemoved)+          where+            busName = fst (parseServiceName serviceName)+            doRemove currentMap =+              return (Map.delete busName currentMap, Map.lookup busName currentMap)+            logNonExistentRemoval =+              -- This can happen due to watcher/host races (e.g. watcher restart).+              hostLogger DEBUG $+                printf "Attempt to remove unknown item %s" $+                  show busName -      watcherRegistrationPairs =-        [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded)-        , (W.registerForStatusNotifierItemUnregistered, const handleItemRemoved)-        ]+        watcherRegistrationPairs =+          [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded),+            (W.registerForStatusNotifierItemUnregistered, const handleItemRemoved)+          ] -      watcherServiceName = coerce $ W.getWatcherInterfaceName namespaceString+        watcherServiceName = coerce $ W.getWatcherInterfaceName namespaceString -      synchronizeItemsWithWatcher = do-        let retryDelayMicros = 50000-            maxRetries = 20-            fetchWatcherItems retries = do-              watcherItemsResult <- W.getRegisteredStatusNotifierItems client-              case watcherItemsResult of-                Right watcherItems -> return $ Right watcherItems-                Left err ->-                  if retries <= 0-                    then return $ Left err-                    else threadDelay retryDelayMicros >>-                         fetchWatcherItems (retries - 1)-        watcherItemsResult <- fetchWatcherItems maxRetries-        case watcherItemsResult of-          Left err ->-            logErrorWithMessage "Failed to synchronize host state with watcher:" err-          Right watcherServiceNames -> do-            currentMap <- readMVar itemInfoMapVar-            let watcherBusNames = map (fst . parseServiceName) watcherServiceNames-                missingFromWatcher =-                  filter (`notElem` watcherBusNames) (Map.keys currentMap)-            mapM_ (handleItemRemoved . coerce) missingFromWatcher-            mapM_ handleItemAdded watcherServiceNames+        synchronizeItemsWithWatcher = do+          let retryDelayMicros = 50000+              maxRetries = 20+              fetchWatcherItems retries = do+                watcherItemsResult <- W.getRegisteredStatusNotifierItems client+                case watcherItemsResult of+                  Right watcherItems -> return $ Right watcherItems+                  Left err ->+                    if retries <= 0+                      then return $ Left err+                      else+                        threadDelay retryDelayMicros+                          >> fetchWatcherItems (retries - 1)+          watcherItemsResult <- fetchWatcherItems maxRetries+          case watcherItemsResult of+            Left err ->+              logErrorWithMessage "Failed to synchronize host state with watcher:" err+            Right watcherServiceNames -> do+              currentMap <- readMVar itemInfoMapVar+              let watcherBusNames = map (fst . parseServiceName) watcherServiceNames+                  missingFromWatcher =+                    filter (`notElem` watcherBusNames) (Map.keys currentMap)+              mapM_ (handleItemRemoved . coerce) missingFromWatcher+              mapM_ handleItemAdded watcherServiceNames -      handleWatcherNameOwnerChanged _ name _ newOwner =-        when (name == watcherServiceName && newOwner /= "") $ do-          logInfo "Watcher owner changed; synchronizing item state."-          synchronizeItemsWithWatcher+        handleWatcherNameOwnerChanged _ name _ newOwner =+          when (name == watcherServiceName && newOwner /= "") $ do+            logInfo "Watcher owner changed; synchronizing item state."+            synchronizeItemsWithWatcher -      getSender fn s@M.Signal { M.signalSender = Just sender} =-        -- Signal dumps are too noisy at INFO.-        logDebug (show s) >> fn sender-      getSender _ s = logError $ "Received signal with no sender: " ++ show s+        getSender fn s@M.Signal {M.signalSender = Just sender} =+          -- Signal dumps are too noisy at INFO.+          logDebug (show s) >> fn sender+        getSender _ s = logError $ "Received signal with no sender: " ++ show s -      runProperty prop serviceName =-        getObjectPathForItemName serviceName >>= prop client serviceName+        runProperty prop serviceName =+          getObjectPathForItemName serviceName >>= prop client serviceName -      logUnknownSender updateType signal =-        hostLogger DEBUG $-                   printf "Got signal for update type: %s from unknown sender: %s"-                   (show updateType) (show signal)+        logUnknownSender updateType signal =+          hostLogger DEBUG $+            printf+              "Got signal for update type: %s from unknown sender: %s"+              (show updateType)+              (show signal) -      identifySender M.Signal { M.signalSender = Just sender-                              , M.signalPath = senderPath-                              } = do-        infoMap <- readMVar itemInfoMapVar-        let identifySenderBySender = return (Map.lookup sender infoMap)-            identifySenderByNameOwner =-              let matchByOwner info = do-                    ownerResult <- DTH.getNameOwner client-                                   (coerce $ itemServiceName info)-                    return $ case ownerResult of-                      Right owner -> owner == coerce sender-                      Left _ -> False-              in findM matchByOwner (Map.elems infoMap)-            identifySenderById = fmap join $-              identifySenderById_ >>= logIdentifyByIdResult-            logIdentifyByIdResult-              (Left M.MethodError { M.methodErrorName = errName })-              | errName == errorUnknownMethod =-                  hostLogger DEBUG-                    (printf "Item does not support getId: %s"-                      (show errName)) >>-                  return Nothing-            logIdentifyByIdResult result =-              logEitherError hostLogger "Failed to identify sender" result-            identifySenderById_ = runExceptT $ do-              senderId <- ExceptT $ I.getId client sender senderPath-              let matchesSender info =-                    if itemId info == Just senderId-                    then do-                      senderNameOwner <- DTH.getNameOwner client (coerce sender)-                      infoNameOwner <- DTH.getNameOwner client (coerce $ itemServiceName info)-                      let warningMsg =-                            "Matched sender id: %s, but name owners do not \-                            \ match: %s %s. Considered match: %s."-                          warningText = printf warningMsg-                                        (show senderId)-                                        (show senderNameOwner)-                                        (show infoNameOwner)-                      when (senderNameOwner /= infoNameOwner) $-                           hostLogger DEBUG warningText-                      return doMatchUnmatchedSender-                    else return False-              lift $ findM matchesSender (Map.elems infoMap)-        identifySenderBySender <||> identifySenderByNameOwner <||> identifySenderById-        where a <||> b = runMaybeT $ MaybeT a <|> MaybeT b-      identifySender _ = return Nothing+        identifySender+          M.Signal+            { M.signalSender = Just sender,+              M.signalPath = senderPath+            } = do+            infoMap <- readMVar itemInfoMapVar+            let identifySenderBySender = return (Map.lookup sender infoMap)+                identifySenderByNameOwner =+                  let matchByOwner info = do+                        ownerResult <-+                          DTH.getNameOwner+                            client+                            (coerce $ itemServiceName info)+                        return $ case ownerResult of+                          Right owner -> owner == coerce sender+                          Left _ -> False+                   in findM matchByOwner (Map.elems infoMap)+                identifySenderById =+                  fmap join $+                    identifySenderById_ >>= logIdentifyByIdResult+                logIdentifyByIdResult+                  (Left M.MethodError {M.methodErrorName = errName})+                    | errName == errorUnknownMethod =+                        hostLogger+                          DEBUG+                          ( printf+                              "Item does not support getId: %s"+                              (show errName)+                          )+                          >> return Nothing+                logIdentifyByIdResult result =+                  logEitherError hostLogger "Failed to identify sender" result+                identifySenderById_ = runExceptT $ do+                  senderId <- ExceptT $ I.getId client sender senderPath+                  let matchesSender info =+                        if itemId info == Just senderId+                          then do+                            senderNameOwner <- DTH.getNameOwner client (coerce sender)+                            infoNameOwner <- DTH.getNameOwner client (coerce $ itemServiceName info)+                            let warningMsg =+                                  "Matched sender id: %s, but name owners do not \+                                  \ match: %s %s. Considered match: %s."+                                warningText =+                                  printf+                                    warningMsg+                                    (show senderId)+                                    (show senderNameOwner)+                                    (show infoNameOwner)+                            when (senderNameOwner /= infoNameOwner) $+                              hostLogger DEBUG warningText+                            return doMatchUnmatchedSender+                          else return False+                  lift $ findM matchesSender (Map.elems infoMap)+            identifySenderBySender <||> identifySenderByNameOwner <||> identifySenderById+            where+              a <||> b = runMaybeT $ MaybeT a <|> MaybeT b+        identifySender _ = return Nothing -      updateItemByLensAndProp lens prop busName = runExceptT $ do-        newValue <- ExceptT (runProperty prop busName)-        let modify infoMap =-              -- This noops when the value is not present-              let newMap = set (at busName . _Just . lens) newValue infoMap-              in return (newMap, Map.lookup busName newMap)-        ExceptT $ maybeToEither (methodError (Serial 0) errorFailed) <$>-                modifyMVar itemInfoMapVar modify+        updateItemByLensAndProp lens prop busName = runExceptT $ do+          newValue <- ExceptT (runProperty prop busName)+          let modify infoMap =+                -- This noops when the value is not present+                let newMap = set (at busName . _Just . lens) newValue infoMap+                 in return (newMap, Map.lookup busName newMap)+          ExceptT $+            maybeToEither (methodError (Serial 0) errorFailed)+              <$> modifyMVar itemInfoMapVar modify -      logErrorsHandler lens updateType prop =-        runUpdaters [updateItemByLensAndProp lens prop] updateType+        logErrorsHandler lens updateType prop =+          runUpdaters [updateItemByLensAndProp lens prop] updateType -      -- Run all the provided updaters with the expectation that at least one-      -- will succeed.-      runUpdatersForService updaters updateType serviceName = do-        updateResults <- mapM ($ serviceName) updaters-        let (failures, updates) = partitionEithers updateResults-            logLevel = propertyUpdateFailureLogLevel failures updates-        mapM_ (doUpdate updateType) updates-        when (not $ null failures) $-             hostLogger logLevel $ printf "Property update failures %s" $-                        show failures+        -- Run all the provided updaters with the expectation that at least one+        -- will succeed.+        runUpdatersForService updaters updateType serviceName = do+          updateResults <- mapM ($ serviceName) updaters+          let (failures, updates) = partitionEithers updateResults+              logLevel = propertyUpdateFailureLogLevel failures updates+          mapM_ (doUpdate updateType) updates+          when (not $ null failures) $+            hostLogger logLevel $+              printf "Property update failures %s" $+                show failures -      runUpdaters updaters updateType signal =-        identifySender signal >>= maybe runForAll (runUpdateForService . itemServiceName)-        where runUpdateForService = runUpdatersForService updaters updateType-              runForAll = logUnknownSender updateType signal >>-                          readMVar itemInfoMapVar >>=-                          mapM_ runUpdateForService . Map.keys+        runUpdaters updaters updateType signal =+          identifySender signal >>= maybe runForAll (runUpdateForService . itemServiceName)+          where+            runUpdateForService = runUpdatersForService updaters updateType+            runForAll =+              logUnknownSender updateType signal+                >> readMVar itemInfoMapVar+                >>= mapM_ runUpdateForService . Map.keys -      updateIconPixmaps =-        updateItemByLensAndProp iconPixmapsL $ getPixmaps I.getIconPixmap+        updateIconPixmaps =+          updateItemByLensAndProp iconPixmapsL $ getPixmaps I.getIconPixmap -      updateIconName =-        updateItemByLensAndProp iconNameL I.getIconName+        updateIconName =+          updateItemByLensAndProp iconNameL I.getIconName -      updateIconTheme =-        updateItemByLensAndProp iconThemePathL getThemePathDefault+        updateIconTheme =+          updateItemByLensAndProp iconThemePathL getThemePathDefault -      updateFromIconThemeFromSignal signal =-        identifySender signal >>= traverse (updateIconTheme . itemServiceName)+        updateFromIconThemeFromSignal signal =+          identifySender signal >>= traverse (updateIconTheme . itemServiceName) -      handleNewIcon signal = do-        -- XXX: This avoids the case where the theme path is updated before the-        -- icon name is updated when both signals are sent simultaneously-        updateFromIconThemeFromSignal signal-        runUpdaters [updateIconPixmaps, updateIconName]-                    IconUpdated signal+        handleNewIcon signal = do+          -- XXX: This avoids the case where the theme path is updated before the+          -- icon name is updated when both signals are sent simultaneously+          updateFromIconThemeFromSignal signal+          runUpdaters+            [updateIconPixmaps, updateIconName]+            IconUpdated+            signal -      updateOverlayIconName =-        updateItemByLensAndProp overlayIconNameL $-                                getMaybe I.getOverlayIconName+        updateOverlayIconName =+          updateItemByLensAndProp overlayIconNameL $+            getMaybe I.getOverlayIconName -      updateOverlayIconPixmaps =-        updateItemByLensAndProp overlayIconPixmapsL $-                                getPixmaps I.getOverlayIconPixmap+        updateOverlayIconPixmaps =+          updateItemByLensAndProp overlayIconPixmapsL $+            getPixmaps I.getOverlayIconPixmap -      handleNewOverlayIcon signal = do-        updateFromIconThemeFromSignal signal-        runUpdaters [updateOverlayIconPixmaps, updateOverlayIconName]-                    OverlayIconUpdated signal+        handleNewOverlayIcon signal = do+          updateFromIconThemeFromSignal signal+          runUpdaters+            [updateOverlayIconPixmaps, updateOverlayIconName]+            OverlayIconUpdated+            signal -      getThemePathDefault client busName objectPath =-        right Just <$> I.getIconThemePath client busName objectPath+        getThemePathDefault client busName objectPath =+          right Just <$> I.getIconThemePath client busName objectPath -      handleNewTitle =-        logErrorsHandler iconTitleL TitleUpdated I.getTitle+        handleNewTitle =+          logErrorsHandler iconTitleL TitleUpdated I.getTitle -      handleNewTooltip =-        logErrorsHandler itemToolTipL ToolTipUpdated $ getMaybe I.getToolTip+        handleNewTooltip =+          logErrorsHandler itemToolTipL ToolTipUpdated $ getMaybe I.getToolTip -      handleNewStatus =-        logErrorsHandler itemStatusL StatusUpdated $ getMaybe I.getStatus+        handleNewStatus =+          logErrorsHandler itemStatusL StatusUpdated $ getMaybe I.getStatus -      clientRegistrationPairs =-        [ (I.registerForNewIcon, handleNewIcon)-        , (I.registerForNewIconThemePath, handleNewIcon)-        , (I.registerForNewOverlayIcon, handleNewOverlayIcon)-        , (I.registerForNewTitle, handleNewTitle)-        , (I.registerForNewToolTip, handleNewTooltip)-        , (I.registerForNewStatus, handleNewStatus)-        ]+        clientRegistrationPairs =+          [ (I.registerForNewIcon, handleNewIcon),+            (I.registerForNewIconThemePath, handleNewIcon),+            (I.registerForNewOverlayIcon, handleNewOverlayIcon),+            (I.registerForNewTitle, handleNewTitle),+            (I.registerForNewToolTip, handleNewTooltip),+            (I.registerForNewStatus, handleNewStatus)+          ] -      initializeItemInfoMap = modifyMVar itemInfoMapVar $ \itemInfoMap -> do-        -- All initialization is done inside this modifyMVar to avoid race-        -- conditions with the itemInfoMapVar.-        clientSignalHandlers <- registerWithPairs clientRegistrationPairs-        watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs-        watcherOwnerChangedHandler <--          DTH.registerForNameOwnerChanged client matchAny handleWatcherNameOwnerChanged-        let unregisterAll =+        initializeItemInfoMap = modifyMVar itemInfoMapVar $ \itemInfoMap -> do+          -- All initialization is done inside this modifyMVar to avoid race+          -- conditions with the itemInfoMapVar.+          clientSignalHandlers <- registerWithPairs clientRegistrationPairs+          watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs+          watcherOwnerChangedHandler <-+            DTH.registerForNameOwnerChanged client matchAny handleWatcherNameOwnerChanged+          let unregisterAll =                 mapM_ (removeMatch client) $-                    watcherOwnerChangedHandler : clientSignalHandlers ++ watcherSignalHandlers-            shutdownHost = do+                  watcherOwnerChangedHandler : clientSignalHandlers ++ watcherSignalHandlers+              shutdownHost = do                 logInfo "Shutting down StatusNotifierHost"                 unregisterAll                 releaseName client (fromString busName)                 return ()-            logErrorAndShutdown error =-              logError (show error) >> shutdownHost >> return (Map.empty, False)-            finishInitialization serviceNames = do-              itemInfos <- createAll serviceNames-              let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos-                  resultMap = Map.union itemInfoMap newMap-              W.registerStatusNotifierHost client busName >>=-               either logErrorAndShutdown (const $ return (resultMap, True))-        W.getRegisteredStatusNotifierItems client >>=-         either logErrorAndShutdown finishInitialization+              logErrorAndShutdown error =+                logError (show error) >> shutdownHost >> return (Map.empty, False)+              finishInitialization serviceNames = do+                itemInfos <- createAll serviceNames+                let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos+                    resultMap = Map.union itemInfoMap newMap+                W.registerStatusNotifierHost client busName+                  >>= either logErrorAndShutdown (const $ return (resultMap, True))+          W.getRegisteredStatusNotifierItems client+            >>= either logErrorAndShutdown finishInitialization -      startWatcherIfNeeded = do-        let watcherName = maybe "" coerce $ genBusName W.watcherClientGenerationParams-            startWatcher = do-              (_, doIt) <- W.buildWatcher W.defaultWatcherParams-              doIt-        res <- DTH.getNameOwner client watcherName-        case res of-          Right _ -> return ()-          Left _ -> void $ forkIO $ void startWatcher+        startWatcherIfNeeded = do+          let watcherName = maybe "" coerce $ genBusName W.watcherClientGenerationParams+              startWatcher = do+                (_, doIt) <- W.buildWatcher W.defaultWatcherParams+                doIt+          res <- DTH.getNameOwner client watcherName+          case res of+            Right _ -> return ()+            Left _ -> void $ forkIO $ void startWatcher -  when shouldStartWatcher startWatcherIfNeeded-  nameRequestResult <- requestName client (fromString busName) []-  if nameRequestResult == NamePrimaryOwner-  then do-    initializationSuccess <- initializeItemInfoMap-    return $ if initializationSuccess-    then-      Just Host-      { itemInfoMap = readMVar itemInfoMapVar-      , addUpdateHandler = addHandler-      , removeUpdateHandler = removeHandler-      , forceUpdate = handleItemAdded . coerce-      }-    else Nothing-  else do-    logErrorWithMessage "Failed to obtain desired service name" nameRequestResult-    return Nothing+    when shouldStartWatcher startWatcherIfNeeded+    nameRequestResult <- requestName client (fromString busName) []+    if nameRequestResult == NamePrimaryOwner+      then do+        initializationSuccess <- initializeItemInfoMap+        return $+          if initializationSuccess+            then+              Just+                Host+                  { itemInfoMap = readMVar itemInfoMapVar,+                    addUpdateHandler = addHandler,+                    removeUpdateHandler = removeHandler,+                    forceUpdate = handleItemAdded . coerce+                  }+            else Nothing+      else do+        logErrorWithMessage "Failed to obtain desired service name" nameRequestResult+        return Nothing

@@ -239,15 +239,24 @@         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+            Just providedBusName+              -- Unique bus names (starting with ':') are assigned by the D-Bus+              -- daemon and cannot be spoofed. Some applications (e.g. KDE's+              -- KStatusNotifierItem) register their SNI on a separate D-Bus+              -- connection, so the sender's unique name differs from the+              -- registered item's unique name even though they belong to the+              -- same process. Skip the ownership check for unique names.+              | ":" `isPrefixOf` (coerce providedBusName :: String) ->+                  return providedBusName+              | otherwise -> 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

@@ -5,12 +5,12 @@ -- see: https://github.com/sol/hpack  name:           status-notifier-item-version:        0.3.2.10+version:        0.3.2.11 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>+description:    Please see the README on Github at <https://github.com/taffybar/status-notifier-item#readme> category:       Desktop-homepage:       https://github.com/IvanMalison/status-notifier-item#readme-bug-reports:    https://github.com/IvanMalison/status-notifier-item/issues+homepage:       https://github.com/taffybar/status-notifier-item#readme+bug-reports:    https://github.com/taffybar/status-notifier-item/issues author:         Ivan Malison maintainer:     IvanMalison@gmail.com copyright:      2018 Ivan Malison@@ -24,7 +24,7 @@  source-repository head   type: git-  location: https://github.com/IvanMalison/status-notifier-item+  location: https://github.com/taffybar/status-notifier-item  library   exposed-modules:

@@ -3,30 +3,29 @@ module HostSpec (spec) where  import Control.Concurrent-  ( forkIO-  , newChan-  , newEmptyMVar-  , putMVar-  , readChan-  , takeMVar-  , threadDelay-  , tryPutMVar-  , writeChan+  ( forkIO,+    newChan,+    newEmptyMVar,+    putMVar,+    readChan,+    takeMVar,+    threadDelay,+    tryPutMVar,+    writeChan,   ) import Control.Exception (finally) import Control.Monad (replicateM, void)-import Data.List (sort)-import qualified Data.Map.Strict as Map import DBus (busName_, objectPath_) import DBus.Client import qualified DBus.Internal.Message as M import DBus.Internal.Types (ErrorName, Serial (..), errorName_)+import Data.List (sort)+import qualified Data.Map.Strict as Map import StatusNotifier.Host.Service hiding (startWatcher) import qualified StatusNotifier.Watcher.Client as WatcherClient import System.Log.Logger (Priority (..)) import System.Timeout (timeout) import Test.Hspec- import TestSupport  spec :: Spec@@ -107,7 +106,7 @@       Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-e"}       itemClient <- connectSession       cleanup <- registerSimpleItem itemClient "org.test.HostItemE" defaultPath "drive-harddisk"-      (do+      ( do           populated <-             waitFor 1500000 $ do               current <- itemInfoMap host@@ -115,7 +114,8 @@                 Just info -> iconName info == "drive-harddisk"                 Nothing -> False           populated `shouldBe` True-        ) `finally` cleanup+        )+        `finally` cleanup      it "replays all pre-existing items to newly-added handlers" $ \() -> do       _watcher <- startWatcher@@ -124,7 +124,7 @@       itemClientB <- connectSession       cleanupA <- registerSimpleItem itemClientA "org.test.HostItemF" defaultPath "audio-volume-high"       cleanupB <- registerSimpleItem itemClientB "org.test.HostItemG" defaultPath "audio-volume-low"-      (do+      ( do           Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-f"}           events <- newChan           _ <- addUpdateHandler host (\ut info -> writeChan events (ut, itemServiceName info))@@ -132,7 +132,8 @@           let addedNames = sort [name | Just (ItemAdded, name) <- replayed]           addedNames             `shouldBe` sort [busName_ "org.test.HostItemF", busName_ "org.test.HostItemG"]-        ) `finally` (cleanupA >> cleanupB)+        )+        `finally` (cleanupA >> cleanupB)      it "does not emit updates for forceUpdate on unknown services" $ \() -> do       _watcher <- startWatcher@@ -152,14 +153,14 @@       itemClient <- connectSession       let iface =             Interface-              { interfaceName = "org.kde.StatusNotifierItem"-              , interfaceMethods = []-              , interfaceProperties =-                  [ readOnlyProperty "IconName" (pure ("folder" :: String))-                  , readOnlyProperty "OverlayIconName" (pure ("" :: String))-                  , readOnlyProperty "ItemIsMenu" (pure False)-                  ]-              , interfaceSignals = []+              { interfaceName = "org.kde.StatusNotifierItem",+                interfaceMethods = [],+                interfaceProperties =+                  [ readOnlyProperty "IconName" (pure ("folder" :: String)),+                    readOnlyProperty "OverlayIconName" (pure ("" :: String)),+                    readOnlyProperty "ItemIsMenu" (pure False)+                  ],+                interfaceSignals = []               }           defaultPath = "/StatusNotifierItem"       export itemClient (objectPath_ defaultPath) iface@@ -204,6 +205,104 @@               && not (Map.member initialKey current)       deduped `shouldBe` True +    it "deduplicates a logically identical item that appears under a new bus name" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-h2"}++      let duplicateIface =+            Interface+              { interfaceName = "org.kde.StatusNotifierItem",+                interfaceMethods = [],+                interfaceProperties =+                  [ readOnlyProperty "Id" (pure ("dup-item" :: String)),+                    readOnlyProperty "Title" (pure ("Duplicate Item" :: String)),+                    readOnlyProperty "Category" (pure ("ApplicationStatus" :: String)),+                    readOnlyProperty "IconName" (pure ("folder" :: String)),+                    readOnlyProperty "OverlayIconName" (pure ("" :: String)),+                    readOnlyProperty "ItemIsMenu" (pure False)+                  ],+                interfaceSignals = []+              }+          itemAName = "org.test.HostLogicalDuplicateA"+          itemBName = "org.test.HostLogicalDuplicateB"+      itemClientA <- connectSession+      export itemClientA (objectPath_ defaultPath) duplicateIface+      _ <- requestName itemClientA (busName_ itemAName) []+      WatcherClient.registerStatusNotifierItem itemClientA itemAName+        `shouldReturn` Right ()++      initialReady <-+        waitFor 1500000 $ do+          current <- itemInfoMap host+          pure $ Map.size current == 1 && Map.member (busName_ itemAName) current+      initialReady `shouldBe` True++      itemClientB <- connectSession+      export itemClientB (objectPath_ defaultPath) duplicateIface+      _ <- requestName itemClientB (busName_ itemBName) []+      WatcherClient.registerStatusNotifierItem itemClientB itemBName+        `shouldReturn` Right ()++      deduped <-+        waitFor 1500000 $ do+          current <- itemInfoMap host+          pure $+            Map.size current == 1+              && Map.member (busName_ itemBName) current+              && not (Map.member (busName_ itemAName) current)+      deduped `shouldBe` True++      _ <- releaseName itemClientA (busName_ itemAName)+      _ <- releaseName itemClientB (busName_ itemBName)+      pure ()++    it "keeps distinct items when shared ids differ by title or icon" $ \() -> do+      _watcher <- startWatcher+      hostClient <- connectSession+      Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-h3"}++      let makeIface title iconName =+            Interface+              { interfaceName = "org.kde.StatusNotifierItem",+                interfaceMethods = [],+                interfaceProperties =+                  [ readOnlyProperty "Id" (pure ("git-sync-rs" :: String)),+                    readOnlyProperty "Title" (pure title),+                    readOnlyProperty "Category" (pure ("ApplicationStatus" :: String)),+                    readOnlyProperty "IconName" (pure iconName),+                    readOnlyProperty "OverlayIconName" (pure ("" :: String)),+                    readOnlyProperty "ItemIsMenu" (pure True)+                  ],+                interfaceSignals = []+              }+          itemAName = "org.test.HostDistinctSharedA"+          itemBName = "org.test.HostDistinctSharedB"+      itemClientA <- connectSession+      export itemClientA (objectPath_ defaultPath) (makeIface "git-sync-rs - org" "text-org")+      _ <- requestName itemClientA (busName_ itemAName) []+      WatcherClient.registerStatusNotifierItem itemClientA itemAName+        `shouldReturn` Right ()++      itemClientB <- connectSession+      export itemClientB (objectPath_ defaultPath) (makeIface "git-sync-rs - .password-store" "password")+      _ <- requestName itemClientB (busName_ itemBName) []+      WatcherClient.registerStatusNotifierItem itemClientB itemBName+        `shouldReturn` Right ()++      bothPresent <-+        waitFor 1500000 $ do+          current <- itemInfoMap host+          pure $+            Map.size current == 2+              && Map.member (busName_ itemAName) current+              && Map.member (busName_ itemBName) current+      bothPresent `shouldBe` True++      _ <- releaseName itemClientA (busName_ itemAName)+      _ <- releaseName itemClientB (busName_ itemBName)+      pure ()+     it "removes stale items when watcher ownership changes and replacement watcher has no item" $ \() -> do       watcher1 <- startWatcher @@ -240,17 +339,17 @@       let itemName = "org.test.HostHandlerRace"           iface =             Interface-              { interfaceName = "org.kde.StatusNotifierItem"-              , interfaceMethods = []-              , interfaceProperties =+              { interfaceName = "org.kde.StatusNotifierItem",+                interfaceMethods = [],+                interfaceProperties =                   [ readOnlyProperty "IconName" $ do                       void $ tryPutMVar buildStarted ()                       takeMVar continueBuild-                      pure ("folder" :: String)-                  , readOnlyProperty "OverlayIconName" (pure ("" :: String))-                  , readOnlyProperty "ItemIsMenu" (pure False)-                  ]-              , interfaceSignals = []+                      pure ("folder" :: String),+                    readOnlyProperty "OverlayIconName" (pure ("" :: String)),+                    readOnlyProperty "ItemIsMenu" (pure False)+                  ],+                interfaceSignals = []               }       export itemClient (objectPath_ defaultPath) iface       _ <- requestName itemClient (busName_ itemName) []@@ -301,11 +400,11 @@ mkMethodError :: ErrorName -> M.MethodError mkMethodError errName =   M.MethodError-    { M.methodErrorName = errName-    , M.methodErrorSerial = Serial 0-    , M.methodErrorSender = Nothing-    , M.methodErrorDestination = Nothing-    , M.methodErrorBody = []+    { M.methodErrorName = errName,+      M.methodErrorSerial = Serial 0,+      M.methodErrorSender = Nothing,+      M.methodErrorDestination = Nothing,+      M.methodErrorBody = []     }  errorInvalidArgs :: ErrorName

@@ -5,23 +5,27 @@   ( withIsolatedSessionBus   , startWatcher   , registerSimpleItem+  , connectSessionWithName   , waitFor   ) where  import Control.Concurrent (threadDelay) import Control.Exception (SomeException, displayException, finally, try) import Control.Monad (filterM)-import DBus (busName_, objectPath_)+import DBus (BusName, busName_, formatBusName, objectPath_) import DBus.Client   ( Client   , Interface (..)   , RequestNameReply (NamePrimaryOwner)   , connectSession+  , connectWithName+  , defaultClientOptions   , export   , readOnlyProperty   , releaseName   , requestName   )+import DBus.Internal.Address (getSessionAddress) import StatusNotifier.Watcher.Constants   ( defaultWatcherParams   , watcherDBusClient@@ -180,6 +184,13 @@   pure $ do     _ <- releaseName client (busName_ busName)     pure ()++connectSessionWithName :: IO (Client, BusName)+connectSessionWithName = do+  env <- getSessionAddress+  case env of+    Nothing -> error "connectSessionWithName: DBUS_SESSION_BUS_ADDRESS is invalid."+    Just addr -> connectWithName defaultClientOptions addr  waitFor :: Int -> IO Bool -> IO Bool waitFor timeoutMicros predicate =

@@ -5,6 +5,7 @@ import Control.Exception (finally) import Data.Either (isLeft) import Data.List (isPrefixOf)+import DBus (BusName, busName_, formatBusName, objectPath_) import DBus.Client import qualified StatusNotifier.Watcher.Client as WatcherClient import Test.Hspec@@ -73,6 +74,32 @@       watcher <- startWatcher       result <- WatcherClient.getObjectPathForItemName watcher "org.test.Missing"       result `shouldSatisfy` isLeft++    it "accepts registration from a different connection of the same process (KDE-style)" $ \() -> do+      watcher <- startWatcher+      -- Simulate KDE's KStatusNotifierItem pattern: one connection registers+      -- the SNI item, but the actual SNI interface lives on a separate connection.+      mainClient <- connectSession+      (sniClient, sniBusName) <- connectSessionWithName+      let sniPath = objectPath_ "/StatusNotifierItem"+          sniIface = Interface+            { interfaceName = "org.kde.StatusNotifierItem"+            , interfaceMethods = []+            , interfaceProperties =+                [ readOnlyProperty "IconName" (pure ("test-icon" :: String))+                , readOnlyProperty "OverlayIconName" (pure ("" :: String))+                , readOnlyProperty "ItemIsMenu" (pure False)+                ]+            , interfaceSignals = []+            }+          sniNameStr = formatBusName sniBusName+      export sniClient sniPath sniIface+      -- Register using the SNI connection's unique bus name, sent from mainClient+      result <- WatcherClient.registerStatusNotifierItem mainClient sniNameStr+      result `shouldBe` Right ()+      Right entries <- WatcherClient.getRegisteredSNIEntries watcher+      let matching = filter ((== sniNameStr) . fst) entries+      length matching `shouldBe` 1      it "rejects registration for unowned well-known names" $ \() -> do       watcher <- startWatcher