diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/src/StatusNotifier/Host/Service.hs b/src/StatusNotifier/Host/Service.hs --- a/src/StatusNotifier/Host/Service.hs +++ b/src/StatusNotifier/Host/Service.hs @@ -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 diff --git a/src/StatusNotifier/Watcher/Service.hs b/src/StatusNotifier/Watcher/Service.hs --- a/src/StatusNotifier/Watcher/Service.hs +++ b/src/StatusNotifier/Watcher/Service.hs @@ -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 diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -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 +description: Please see the README on Github at 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: diff --git a/test/HostSpec.hs b/test/HostSpec.hs --- a/test/HostSpec.hs +++ b/test/HostSpec.hs @@ -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 diff --git a/test/TestSupport.hs b/test/TestSupport.hs --- a/test/TestSupport.hs +++ b/test/TestSupport.hs @@ -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 = diff --git a/test/WatcherSpec.hs b/test/WatcherSpec.hs --- a/test/WatcherSpec.hs +++ b/test/WatcherSpec.hs @@ -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