diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,41 @@ # Changelog for status-notifier-item +## 0.3.2.7 - 2026-02-13 +- Watcher: default `--log-level` is now INFO. +- Watcher: log item/host registrations at INFO; keep per-request method/property + tracing at DEBUG to avoid spamming. +- Host: downgrade noisy INFO/WARNING logs (signal dumps, handler updates, and + expected removal/mismatch cases) to DEBUG. + +## 0.3.2.6 - 2026-02-13 +- Watcher: persist item/host registrations to an XDG cache JSON file and + restore on startup with validation (bus owner + object/interface checks). +- Watcher: keep persisted state in sync across registrations/unregistrations and + deduplicate/replace owner-equivalent path registrations. +- Host: reconcile item state when watcher ownership changes so stale items are + removed after watcher restarts. +- Add integration tests for cache restore, stale-cache pruning, post-restore + deduplication, and host watcher-owner-change reconciliation. + +## 0.3.2.5 - 2026-02-12 +- Test suite: start an isolated `dbus-daemon` using a session config shipped + alongside the `dbus-daemon` executable when available (fixes Nix sandbox + builds where `/etc/dbus-1/session.conf` is absent). + +## 0.3.2.4 - 2026-02-12 +- Host: deduplicate items that re-register under a different bus name after a + watcher restart (e.g. unique name vs well-known name), preventing duplicate + tray icons. +- Add a regression test for watcher-restart re-registration deduplication. + +## 0.3.2.3 - 2026-02-11 +- Downgrade unknown-sender update logs from WARNING to DEBUG to avoid noisy + false alarms for routine tray signals. +- Treat UnknownMethod property refresh failures as expected optional-property + misses (same as InvalidArgs), logging them at DEBUG unless no updater + succeeded. +- Add host tests for property update failure log-level classification. + ## 0.3.2.2 - 2026-02-11 - Fix watcher registration ownership checks by requiring explicit service-name registrations to be initiated by the current owner. 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 @@ -78,6 +78,17 @@ 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" + +propertyUpdateFailureLogLevel :: [M.MethodError] -> [a] -> Priority +propertyUpdateFailureLogLevel failures updates + | not (null updates) = DEBUG + | all isExpectedPropertyUpdateFailure failures = DEBUG + | otherwise = ERROR + data ItemInfo = ItemInfo { itemServiceName :: BusName , itemServicePath :: ObjectPath @@ -131,10 +142,12 @@ logErrorWithMessage message error = logError message >> logError (show error) logInfo = hostLogger INFO + logDebug = hostLogger DEBUG logErrorAndThen andThen e = logError (show e) >> andThen doUpdateForHandler utype uinfo (unique, handler) = do - logInfo (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s" + -- 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)) @@ -214,16 +227,54 @@ 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) + handleItemAdded serviceName = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> buildItemInfo serviceName >>= either (logErrorAndThen $ return itemInfoMap) (addItemInfo itemInfoMap) - where addItemInfo map itemInfo@ItemInfo{..} = - if Map.member itemServiceName map + where addItemInfo map itemInfo@ItemInfo{ itemServiceName = newName + , itemServicePath = newPath + } = + if Map.member newName map then return map - else doUpdate ItemAdded itemInfo >> - return (Map.insert itemServiceName itemInfo map) + else do + -- When the watcher restarts, some items may re-register + -- under a different bus name (e.g. switching between + -- unique name and a well-known name). Detect that by + -- matching on the item's unique name owner, and replace + -- the existing entry rather than creating a duplicate. + newOwner <- resolveOwner newName + let matchesOwnerAndPath (existingName, existingInfo) = do + existingOwner <- resolveOwner existingName + pure $ + existingName /= newName + && existingOwner == newOwner + && itemServicePath existingInfo == newPath + addFresh = do + doUpdate ItemAdded itemInfo + pure (Map.insert newName itemInfo map) + case newOwner of + Nothing -> addFresh + 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 getObjectPathForItemName name = maybe I.defaultPath itemServicePath . Map.lookup name <$> @@ -237,7 +288,8 @@ doRemove currentMap = return (Map.delete busName currentMap, Map.lookup busName currentMap) logNonExistentRemoval = - hostLogger WARNING $ printf "Attempt to remove unknown item %s" $ + -- This can happen due to watcher/host races (e.g. watcher restart). + hostLogger DEBUG $ printf "Attempt to remove unknown item %s" $ show busName watcherRegistrationPairs = @@ -245,15 +297,47 @@ , (W.registerForStatusNotifierItemUnregistered, const handleItemRemoved) ] + 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 + + 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} = - logInfo (show s) >> fn 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 logUnknownSender updateType signal = - hostLogger WARNING $ + hostLogger DEBUG $ printf "Got signal for update type: %s from unknown sender: %s" (show updateType) (show signal) @@ -296,7 +380,7 @@ (show senderNameOwner) (show infoNameOwner) when (senderNameOwner /= infoNameOwner) $ - hostLogger WARNING warningText + hostLogger DEBUG warningText return doMatchUnmatchedSender else return False lift $ findM matchesSender (Map.elems infoMap) @@ -321,12 +405,7 @@ runUpdatersForService updaters updateType serviceName = do updateResults <- mapM ($ serviceName) updaters let (failures, updates) = partitionEithers updateResults - isInvalidArgs M.MethodError { M.methodErrorName = errName } = - errName == errorName_ "org.freedesktop.DBus.Error.InvalidArgs" - logLevel - | not (null updates) = DEBUG - | all isInvalidArgs failures = DEBUG - | otherwise = ERROR + logLevel = propertyUpdateFailureLogLevel failures updates mapM_ (doUpdate updateType) updates when (not $ null failures) $ hostLogger logLevel $ printf "Property update failures %s" $ @@ -397,9 +476,11 @@ -- conditions with the itemInfoMapVar. clientSignalHandlers <- registerWithPairs clientRegistrationPairs watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs + watcherOwnerChangedHandler <- + DTH.registerForNameOwnerChanged client matchAny handleWatcherNameOwnerChanged let unregisterAll = mapM_ (removeMatch client) $ - clientSignalHandlers ++ watcherSignalHandlers + watcherOwnerChangedHandler : clientSignalHandlers ++ watcherSignalHandlers shutdownHost = do logInfo "Shutting down StatusNotifierHost" unregisterAll diff --git a/src/StatusNotifier/Watcher/Constants.hs b/src/StatusNotifier/Watcher/Constants.hs --- a/src/StatusNotifier/Watcher/Constants.hs +++ b/src/StatusNotifier/Watcher/Constants.hs @@ -29,6 +29,7 @@ , watcherPath :: String , watcherStop :: IO () , watcherDBusClient :: Maybe Client + , watcherStateCachePath :: Maybe FilePath } defaultWatcherParams :: WatcherParams @@ -38,6 +39,7 @@ , watcherStop = return () , watcherPath = "/StatusNotifierWatcher" , watcherDBusClient = Nothing + , watcherStateCachePath = Nothing } defaultWatcherInterfaceName = 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 @@ -23,6 +23,7 @@ import qualified StatusNotifier.Item.Client as Item import StatusNotifier.Util import StatusNotifier.Watcher.Constants +import StatusNotifier.Watcher.StateCache import StatusNotifier.Watcher.Signals import System.IO.Unsafe import System.Log.Logger @@ -33,33 +34,193 @@ , watcherStop = stopWatcher , watcherPath = path , watcherDBusClient = mclient + , watcherStateCachePath = maybeCachePath } = do let watcherInterfaceName = getWatcherInterfaceName interfaceNamespace logNamespace = "StatusNotifier.Watcher.Service" - log = logM logNamespace INFO + logInfo = logM logNamespace INFO + logDebug = logM logNamespace DEBUG logError = logM logNamespace ERROR - mkLogCb cb msg = lift (log (show msg)) >> cb msg + -- Default level is now INFO (watcher/Main.hs). Keep generic per-request + -- logging at DEBUG to avoid spamming INFO for frequent property reads. + mkLogCb cb msg = lift (logDebug (show msg)) >> cb msg mkLogMethod method = method { methodHandler = mkLogCb $ methodHandler method } mkLogProperty name fn = - readOnlyProperty name $ log (coerce name ++ " Called") >> fn + readOnlyProperty name $ logDebug (coerce name ++ " Called") >> fn client <- maybe connectSession return mclient + cachePath <- maybe (defaultWatcherStateCachePath interfaceNamespace path) + pure + maybeCachePath notifierItems <- newMVar [] notifierHosts <- newMVar [] let itemIsRegistered item items = isJust $ find (== item) items + + persistWatcherState = do + currentItems <- readMVar notifierItems + currentHosts <- readMVar notifierHosts + let toPersisted entry = + PersistedItemEntry + { persistedServiceName = coerce (serviceName entry) + , persistedServicePath = coerce (servicePath entry) + } + persistedState = + PersistedWatcherState + { persistedItems = map toPersisted currentItems + , persistedHosts = map toPersisted currentHosts + } + writePersistedWatcherState cachePath persistedState >>= + either + (\err -> + logError $ + printf "Failed to persist watcher state to %s: %s" cachePath err + ) + (const $ return ()) + + renderServiceName :: ItemEntry -> String renderServiceName ItemEntry { serviceName = busName , servicePath = path } = - let bus = coerce busName - objPath = coerce path - defaultPath = coerce Item.defaultPath + let bus = (coerce busName :: String) + objPath = (coerce path :: String) + defaultPath = (coerce Item.defaultPath :: String) in if objPath == defaultPath then bus else bus ++ objPath + resolveOwner bus + | ":" `isPrefixOf` (coerce bus :: String) = return (Just bus) + | otherwise = do + result <- DBusTH.getNameOwner client (coerce bus) + return $ busName_ <$> either (const Nothing) Just result + + insertItemNoSignal owner item currentItems = do + ownerPathMatches <- + case owner of + Nothing -> return [] + Just itemOwner -> + filterM + (\existingItem -> + if servicePath existingItem == servicePath item + then do + existingOwner <- resolveOwner (serviceName existingItem) + return $ existingOwner == Just itemOwner + else return False + ) + currentItems + if itemIsRegistered item currentItems + then return (currentItems, False) + else + if null ownerPathMatches + then return (item : currentItems, True) + else + let removeMatches = + foldl' (flip delete) currentItems ownerPathMatches + in return (item : removeMatches, True) + + insertHostNoSignal host currentHosts = + if itemIsRegistered host currentHosts + then (currentHosts, False) + else (host : currentHosts, True) + + parsePersistedItemEntry persistedEntry = do + parsedBusName <- T.parseBusName (persistedServiceName persistedEntry) + parsedPath <- T.parseObjectPath (persistedServicePath persistedEntry) + return ItemEntry + { serviceName = parsedBusName + , servicePath = parsedPath + } + + statusNotifierItemInterfaceName = fromString "org.kde.StatusNotifierItem" + hasStatusNotifierItemInterface objectInfo = + any ((== statusNotifierItemInterfaceName) . I.interfaceName) $ + I.objectInterfaces objectInfo + + validatePersistedItem persistedEntry = + case parsePersistedItemEntry persistedEntry of + Nothing -> do + logError $ printf "Dropping unparsable cached item entry: %s" $ + show persistedEntry + return Nothing + Just item -> do + owner <- resolveOwner (serviceName item) + case owner of + Nothing -> do + logInfo $ + printf "Dropping cached item %s because the bus name is no longer owned." + (renderServiceName item) + return Nothing + Just validOwner -> do + objectResult <- + getInterfaceAt client (serviceName item) (servicePath item) + case objectResult of + Right (Just objectInfo) + | hasStatusNotifierItemInterface objectInfo -> + return $ Just (item, validOwner) + _ -> do + logInfo $ + printf "Dropping cached item %s because it no longer exposes org.kde.StatusNotifierItem." + (renderServiceName item) + return Nothing + + validatePersistedHost persistedEntry = + case parsePersistedItemEntry persistedEntry of + Nothing -> do + logError $ printf "Dropping unparsable cached host entry: %s" $ + show persistedEntry + return Nothing + Just host -> do + owner <- resolveOwner (serviceName host) + if isNothing owner + then do + logInfo $ + printf "Dropping cached host %s because the bus name is no longer owned." + (coerce (serviceName host) :: String) + return Nothing + else return $ Just host + + restoreWatcherStateFromCache = do + stateResult <- readPersistedWatcherState cachePath + case stateResult of + Left err -> do + logError $ + printf "Failed to read watcher cache state from %s: %s" cachePath err + return ([], []) + Right Nothing -> return ([], []) + Right (Just persistedState) -> do + validItems <- catMaybes <$> mapM validatePersistedItem (persistedItems persistedState) + validHosts <- catMaybes <$> mapM validatePersistedHost (persistedHosts persistedState) + + restoredItems <- + modifyMVar notifierItems $ \currentItems -> do + (newItems, insertedItemsRev) <- + foldM + (\(accItems, accInserted) (item, itemOwner) -> do + (nextItems, inserted) <- insertItemNoSignal (Just itemOwner) item accItems + if inserted + then return (nextItems, item : accInserted) + else return (nextItems, accInserted) + ) + (currentItems, []) + validItems + return (newItems, reverse insertedItemsRev) + + restoredHosts <- + modifyMVar notifierHosts $ \currentHosts -> do + let insertHost (accHosts, accInserted) host = + let (nextHosts, inserted) = insertHostNoSignal host accHosts + in if inserted + then (nextHosts, host : accInserted) + else (nextHosts, accInserted) + (newHosts, insertedHostsRev) = foldl' insertHost (currentHosts, []) validHosts + return (newHosts, reverse insertedHostsRev) + + persistWatcherState + return (restoredItems, restoredHosts) + registerStatusNotifierItem MethodCall { methodCallSender = sender } name = runExceptT $ do @@ -73,11 +234,6 @@ remapErrorName = left $ (`makeErrorReply` "Failed to verify ownership.") . M.methodErrorName - resolveOwner bus - | ":" `isPrefixOf` (coerce bus :: String) = return (Just bus) - | otherwise = do - result <- DBusTH.getNameOwner client (coerce bus) - return $ busName_ <$> either (const Nothing) Just result when (isNothing parsedBusName && isNothing (T.parseObjectPath name)) $ throwE parseServiceError senderName <- ExceptT $ return $ maybeToEither senderMissingError sender @@ -96,32 +252,27 @@ let item = ItemEntry { serviceName = busName , servicePath = path } - lift $ modifyMVar_ notifierItems $ \currentItems -> - do - ownerPathMatches <- filterM (\existingItem -> - if servicePath existingItem == path - then do - existingOwner <- resolveOwner (serviceName existingItem) - return $ existingOwner == Just senderName - else return False) currentItems - if itemIsRegistered item currentItems || not (null ownerPathMatches) - then return currentItems - else do - emitStatusNotifierItemRegistered client $ renderServiceName item - return $ item : currentItems + changed <- lift $ modifyMVar notifierItems $ \currentItems -> do + (newItems, inserted) <- insertItemNoSignal (Just senderName) item currentItems + return (newItems, inserted) + lift $ + when changed $ do + logInfo $ printf "Registered item %s." (renderServiceName item) + emitStatusNotifierItemRegistered client $ renderServiceName item + persistWatcherState registerStatusNotifierHost name = let item = ItemEntry { serviceName = busName_ name , servicePath = "/StatusNotifierHost" } in - modifyMVar_ notifierHosts $ \currentHosts -> - if itemIsRegistered item currentHosts - then - return currentHosts - else - do - emitStatusNotifierHostRegistered client - return $ item : currentHosts + do + changed <- modifyMVar notifierHosts $ \currentHosts -> + let (newHosts, inserted) = insertHostNoSignal item currentHosts + in return (newHosts, inserted) + when changed $ do + logInfo $ printf "Registered host %s." name + emitStatusNotifierHostRegistered client + persistWatcherState registeredStatusNotifierItems :: IO [String] registeredStatusNotifierItems = @@ -156,12 +307,14 @@ when (newOwner == "") $ do removedItems <- filterDeadService name notifierItems unless (null removedItems) $ do - log $ printf "Unregistering item %s because it disappeared." name + logInfo $ printf "Unregistering item %s because it disappeared." name forM_ removedItems $ \item -> emitStatusNotifierItemUnregistered client $ renderServiceName item removedHosts <- filterDeadService name notifierHosts unless (null removedHosts) $ - log $ printf "Unregistering host %s because it disappeared." name + logInfo $ printf "Unregistering host %s because it disappeared." name + when (not (null removedItems) || not (null removedHosts)) $ + persistWatcherState return () watcherMethods = map mkLogMethod @@ -201,7 +354,15 @@ do _ <- DBusTH.registerForNameOwnerChanged client matchAny handleNameOwnerChanged + (restoredItems, restoredHosts) <- restoreWatcherStateFromCache export client (fromString path) watcherInterface + logInfo $ + printf "Restored %d cached items and %d cached hosts." + (length restoredItems) + (length restoredHosts) + mapM_ (emitStatusNotifierItemRegistered client . renderServiceName) + restoredItems + mapM_ (const $ emitStatusNotifierHostRegistered client) restoredHosts _ -> stopWatcher return nameRequestResult diff --git a/src/StatusNotifier/Watcher/StateCache.hs b/src/StatusNotifier/Watcher/StateCache.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Watcher/StateCache.hs @@ -0,0 +1,275 @@ +module StatusNotifier.Watcher.StateCache + ( PersistedItemEntry (..) + , PersistedWatcherState (..) + , defaultWatcherStateCachePath + , readPersistedWatcherState + , writePersistedWatcherState + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (IOException, try) +import Data.Char (isAlphaNum, isDigit) +import Data.List (intercalate) +import System.Directory + ( XdgDirectory (XdgCache) + , createDirectoryIfMissing + , doesFileExist + , getXdgDirectory + , renameFile + ) +import System.FilePath ((), takeDirectory) +import Text.ParserCombinators.ReadP + ( ReadP + , char + , choice + , eof + , many + , munch + , readP_to_S + , satisfy + , sepBy + , skipSpaces + ) + +data PersistedItemEntry = PersistedItemEntry + { persistedServiceName :: String + , persistedServicePath :: String + } deriving (Eq, Show) + +data PersistedWatcherState = PersistedWatcherState + { persistedItems :: [PersistedItemEntry] + , persistedHosts :: [PersistedItemEntry] + } deriving (Eq, Show) + +data JsonValue + = JsonObject [(String, JsonValue)] + | JsonArray [JsonValue] + | JsonString String + | JsonNumber Int + deriving (Eq, Show) + +defaultWatcherStateCachePath :: String -> String -> IO FilePath +defaultWatcherStateCachePath interfaceNamespace path = do + xdgCachePath <- getXdgDirectory XdgCache "status-notifier-item" + let sanitize = map (\c -> if isAlphaNum c then c else '_') + filename = + "watcher-state-" + ++ sanitize interfaceNamespace + ++ "-" + ++ sanitize path + ++ ".json" + pure $ xdgCachePath filename + +writePersistedWatcherState :: FilePath -> PersistedWatcherState -> IO (Either String ()) +writePersistedWatcherState cachePath state = do + let tempPath = cachePath ++ ".tmp" + encodedState = encodePersistedWatcherState state + writeResult <- + try $ do + createDirectoryIfMissing True (takeDirectory cachePath) + writeFile tempPath encodedState + renameFile tempPath cachePath + pure $ + case writeResult of + Left err -> Left (show (err :: IOException)) + Right _ -> Right () + +readPersistedWatcherState :: FilePath -> IO (Either String (Maybe PersistedWatcherState)) +readPersistedWatcherState cachePath = do + exists <- doesFileExist cachePath + if not exists + then pure $ Right Nothing + else do + readResult <- try (readFile cachePath) :: IO (Either IOException String) + pure $ + case readResult of + Left err -> Left (show err) + Right contents -> Just <$> decodePersistedWatcherState contents + +encodePersistedWatcherState :: PersistedWatcherState -> String +encodePersistedWatcherState state = + encodeJsonValue $ + JsonObject + [ ("version", JsonNumber 1) + , ("items", JsonArray $ map encodeItemEntry (persistedItems state)) + , ("hosts", JsonArray $ map encodeItemEntry (persistedHosts state)) + ] + +encodeItemEntry :: PersistedItemEntry -> JsonValue +encodeItemEntry entry = + JsonObject + [ ("service_name", JsonString (persistedServiceName entry)) + , ("service_path", JsonString (persistedServicePath entry)) + ] + +decodePersistedWatcherState :: String -> Either String PersistedWatcherState +decodePersistedWatcherState raw = do + root <- parseJson raw + rootObject <- asObject "root" root + version <- getRequiredNumber "version" rootObject + if version /= 1 + then Left "Unsupported watcher cache version." + else do + itemsValue <- getRequired "items" rootObject + hostsValue <- getRequired "hosts" rootObject + items <- asArray "items" itemsValue >>= mapM decodeItemEntry + hosts <- asArray "hosts" hostsValue >>= mapM decodeItemEntry + Right PersistedWatcherState + { persistedItems = items + , persistedHosts = hosts + } + +decodeItemEntry :: JsonValue -> Either String PersistedItemEntry +decodeItemEntry value = do + obj <- asObject "entry" value + serviceName <- getRequiredString "service_name" obj + servicePath <- getRequiredString "service_path" obj + Right PersistedItemEntry + { persistedServiceName = serviceName + , persistedServicePath = servicePath + } + +encodeJsonValue :: JsonValue -> String +encodeJsonValue json = + case json of + JsonObject fields -> + "{" + ++ intercalate "," (map encodeField fields) + ++ "}" + where + encodeField (name, value) = + encodeJsonString name ++ ":" ++ encodeJsonValue value + JsonArray values -> + "[" ++ intercalate "," (map encodeJsonValue values) ++ "]" + JsonString value -> + encodeJsonString value + JsonNumber number -> + show number + +encodeJsonString :: String -> String +encodeJsonString value = + "\"" ++ concatMap encodeChar value ++ "\"" + where + encodeChar '"' = "\\\"" + encodeChar '\\' = "\\\\" + encodeChar '\n' = "\\n" + encodeChar '\r' = "\\r" + encodeChar '\t' = "\\t" + encodeChar c = [c] + +parseJson :: String -> Either String JsonValue +parseJson input = + case [value | (value, rest) <- readP_to_S parseJsonDocument input, null rest] of + [value] -> Right value + [] -> Left "Failed to parse watcher cache JSON." + _ -> Left "Watcher cache JSON is ambiguous." + +parseJsonDocument :: ReadP JsonValue +parseJsonDocument = do + skipSpaces + value <- parseJsonValue + skipSpaces + eof + return value + +parseJsonValue :: ReadP JsonValue +parseJsonValue = do + skipSpaces + choice [parseJsonObject, parseJsonArray, JsonString <$> parseJsonString, parseJsonNumber] + +parseJsonObject :: ReadP JsonValue +parseJsonObject = do + _ <- char '{' + skipSpaces + fields <- sepBy parseJsonField (skipSpaces >> char ',' >> skipSpaces) + skipSpaces + _ <- char '}' + return $ JsonObject fields + +parseJsonField :: ReadP (String, JsonValue) +parseJsonField = do + key <- parseJsonString + skipSpaces + _ <- char ':' + skipSpaces + value <- parseJsonValue + return (key, value) + +parseJsonArray :: ReadP JsonValue +parseJsonArray = do + _ <- char '[' + skipSpaces + values <- sepBy parseJsonValue (skipSpaces >> char ',' >> skipSpaces) + skipSpaces + _ <- char ']' + return $ JsonArray values + +parseJsonString :: ReadP String +parseJsonString = do + _ <- char '"' + chars <- many parseJsonStringChar + _ <- char '"' + return chars + +parseJsonStringChar :: ReadP Char +parseJsonStringChar = + parseEscaped <|> parseUnescaped + where + parseEscaped = do + _ <- char '\\' + choice + [ '"' <$ char '"' + , '\\' <$ char '\\' + , '\n' <$ char 'n' + , '\r' <$ char 'r' + , '\t' <$ char 't' + ] + parseUnescaped = satisfy (\c -> c /= '"' && c /= '\\') + +parseJsonNumber :: ReadP JsonValue +parseJsonNumber = do + sign <- munch (\c -> c == '-') + digits <- munch isDigit + if null digits || length sign > 1 + then fail "Invalid number" + else return $ JsonNumber (read (sign ++ digits)) + +getRequired :: String -> [(String, JsonValue)] -> Either String JsonValue +getRequired key objectFields = + case lookup key objectFields of + Nothing -> Left $ "Missing key: " ++ key + Just value -> Right value + +getRequiredString :: String -> [(String, JsonValue)] -> Either String String +getRequiredString key fields = do + value <- getRequired key fields + asString key value + +getRequiredNumber :: String -> [(String, JsonValue)] -> Either String Int +getRequiredNumber key fields = do + value <- getRequired key fields + asNumber key value + +asObject :: String -> JsonValue -> Either String [(String, JsonValue)] +asObject label value = + case value of + JsonObject fields -> Right fields + _ -> Left $ "Expected object for " ++ label + +asArray :: String -> JsonValue -> Either String [JsonValue] +asArray label value = + case value of + JsonArray values -> Right values + _ -> Left $ "Expected array for " ++ label + +asString :: String -> JsonValue -> Either String String +asString label value = + case value of + JsonString str -> Right str + _ -> Left $ "Expected string for " ++ label + +asNumber :: String -> JsonValue -> Either String Int +asNumber label value = + case value of + JsonNumber number -> Right number + _ -> Left $ "Expected number for " ++ label diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: status-notifier-item -version: 0.3.2.2 +version: 0.3.2.7 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop @@ -37,24 +37,26 @@ StatusNotifier.Watcher.Constants StatusNotifier.Watcher.Service StatusNotifier.Watcher.Signals + StatusNotifier.Watcher.StateCache other-modules: Paths_status_notifier_item hs-source-dirs: src build-depends: base >=4.7 && <5 - , byte-order - , bytestring - , bytestring-to-vector - , containers - , dbus >=1.2.1 && <2.0.0 - , filepath - , hslogger - , lens - , template-haskell - , text - , transformers - , vector + , byte-order <0.2 + , bytestring <0.13 + , bytestring-to-vector <0.4 + , containers <0.8 + , dbus >=1.2.1 && <2 + , directory <1.4 + , filepath <1.6 + , hslogger <1.4 + , lens <5.4 + , template-haskell <2.23 + , text <2.2 + , transformers <0.7 + , vector <0.14 default-language: Haskell2010 executable sni-cl-tool @@ -65,8 +67,8 @@ ./tool build-depends: base >=4.7 && <5 - , dbus >1.0 - , optparse-applicative + , dbus >=1.2.1 && <2 + , optparse-applicative <0.19 , status-notifier-item default-language: Haskell2010 @@ -78,7 +80,7 @@ ./item build-depends: base >=4.7 && <5 - , optparse-applicative + , optparse-applicative <0.19 , status-notifier-item default-language: Haskell2010 @@ -90,10 +92,10 @@ ./watcher build-depends: base >=4.7 && <5 - , dbus >=1.0.0 && <2.0.0 - , dbus-hslogger >=0.1.0.1 && <0.2.0.0 - , hslogger - , optparse-applicative + , dbus >=1.2.1 && <2 + , dbus-hslogger >=0.1.0.1 && <0.2 + , hslogger <1.4 + , optparse-applicative <0.19 , status-notifier-item default-language: Haskell2010 @@ -110,12 +112,13 @@ test build-depends: base >=4.7 && <5 - , containers - , dbus >=1.2.1 && <2.0.0 - , directory - , hslogger - , hspec - , process + , containers <0.8 + , dbus >=1.2.1 && <2 + , directory <1.4 + , filepath <1.6 + , hslogger <1.4 + , hspec <3 + , process <1.7 , status-notifier-item - , unix + , unix <2.9 default-language: Haskell2010 diff --git a/test/HostSpec.hs b/test/HostSpec.hs --- a/test/HostSpec.hs +++ b/test/HostSpec.hs @@ -7,9 +7,13 @@ import Control.Monad (replicateM) import Data.List (sort) import qualified Data.Map.Strict as Map -import DBus (busName_) +import DBus (busName_, objectPath_) import DBus.Client +import qualified DBus.Internal.Message as M +import DBus.Internal.Types (ErrorName, Serial (..), errorName_) 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 @@ -132,5 +136,122 @@ current <- itemInfoMap host Map.null current `shouldBe` True + it "deduplicates an item that re-registers under a different bus name after watcher restart" $ \() -> do + watcher1 <- startWatcher + + 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 = [] + } + defaultPath = "/StatusNotifierItem" + export itemClient (objectPath_ defaultPath) iface + _ <- requestName itemClient (busName_ "org.test.RestartRereg") [] + + -- First register by path only; watcher will store the sender unique name. + WatcherClient.registerStatusNotifierItem itemClient defaultPath + `shouldReturn` Right () + + hostClient <- connectSession + Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-h"} + + initialReady <- + waitFor 1500000 $ do + current <- itemInfoMap host + pure $ Map.size current == 1 + initialReady `shouldBe` True + initialMap <- itemInfoMap host + let initialKeys = Map.keys initialMap + length initialKeys `shouldBe` 1 + initialKey <- + case initialKeys of + [k] -> pure k + _ -> expectationFailure "Expected exactly one initial item key" >> error "unreachable" + + -- Simulate watcher restart (lose all state). + _ <- releaseName watcher1 (busName_ "org.kde.StatusNotifierWatcher") + _watcher2 <- startWatcher + + -- Item re-registers, this time using its well-known name. + WatcherClient.registerStatusNotifierItem itemClient "org.test.RestartRereg" + `shouldReturn` Right () + + -- Host should not keep both the old unique-name entry and the new + -- well-known entry. + deduped <- + waitFor 1500000 $ do + current <- itemInfoMap host + pure $ + Map.size current == 1 + && Map.member (busName_ "org.test.RestartRereg") current + && not (Map.member initialKey current) + deduped `shouldBe` True + + it "removes stale items when watcher ownership changes and replacement watcher has no item" $ \() -> do + watcher1 <- startWatcher + + hostClient <- connectSession + Just host <- build defaultParams {dbusClient = Just hostClient, uniqueIdentifier = "host-i"} + + itemClient <- connectSession + cleanup <- registerSimpleItem itemClient "org.test.HostWatcherOwnerChange" defaultPath "folder" + + added <- + waitFor 1500000 $ do + current <- itemInfoMap host + pure $ Map.member (busName_ "org.test.HostWatcherOwnerChange") current + added `shouldBe` True + + _ <- releaseName watcher1 (busName_ "org.kde.StatusNotifierWatcher") + cleanup + _watcher2 <- startWatcher + + removed <- + waitFor 1500000 $ do + current <- itemInfoMap host + pure $ not $ Map.member (busName_ "org.test.HostWatcherOwnerChange") current + removed `shouldBe` True + + describe "propertyUpdateFailureLogLevel" $ do + it "returns DEBUG when there are successful updates" $ do + let failures = [mkMethodError DBus.Client.errorFailed] + propertyUpdateFailureLogLevel failures [()] + `shouldBe` DEBUG + + it "returns DEBUG when all failures are UnknownMethod" $ do + let failures = [mkMethodError DBus.Client.errorUnknownMethod] + propertyUpdateFailureLogLevel failures ([] :: [()]) + `shouldBe` DEBUG + + it "returns DEBUG when all failures are InvalidArgs" $ do + let failures = [mkMethodError errorInvalidArgs] + propertyUpdateFailureLogLevel failures ([] :: [()]) + `shouldBe` DEBUG + + it "returns ERROR for unexpected failures with no successful updates" $ do + let failures = [mkMethodError DBus.Client.errorFailed] + propertyUpdateFailureLogLevel failures ([] :: [()]) + `shouldBe` ERROR + defaultPath :: String defaultPath = "/StatusNotifierItem" + +mkMethodError :: ErrorName -> M.MethodError +mkMethodError errName = + M.MethodError + { M.methodErrorName = errName + , M.methodErrorSerial = Serial 0 + , M.methodErrorSender = Nothing + , M.methodErrorDestination = Nothing + , M.methodErrorBody = [] + } + +errorInvalidArgs :: ErrorName +errorInvalidArgs = errorName_ "org.freedesktop.DBus.Error.InvalidArgs" diff --git a/test/TestSupport.hs b/test/TestSupport.hs --- a/test/TestSupport.hs +++ b/test/TestSupport.hs @@ -9,7 +9,8 @@ ) where import Control.Concurrent (threadDelay) -import Control.Exception (SomeException, bracket, try) +import Control.Exception (SomeException, displayException, finally, try) +import Control.Monad (filterM) import DBus (busName_, objectPath_) import DBus.Client ( Client @@ -28,37 +29,86 @@ ) import qualified StatusNotifier.Watcher.Client as WatcherClient import qualified StatusNotifier.Watcher.Service as WatcherService +import System.Directory + ( createDirectory + , doesFileExist + , findExecutable + , getTemporaryDirectory + , removeDirectoryRecursive + , removeFile + ) import System.Environment (lookupEnv, setEnv, unsetEnv) import System.Exit (ExitCode, ExitCode (ExitSuccess)) +import System.FilePath ((), takeDirectory) +import System.IO (hClose, openTempFile) import System.Process (readProcessWithExitCode) import Test.Hspec data BusEnv = BusEnv { previousAddress :: Maybe String , previousPid :: Maybe String + , previousCacheHome :: Maybe String + , cacheHome :: FilePath , daemonPid :: String } +findDbusSessionConfig :: IO (Maybe FilePath) +findDbusSessionConfig = do + mExe <- findExecutable "dbus-daemon" + case mExe of + Nothing -> pure Nothing + Just exe -> do + let prefix = takeDirectory (takeDirectory exe) + candidates = + [ prefix "share" "dbus-1" "session.conf" + , prefix "etc" "dbus-1" "session.conf" + ] + existing <- filterM doesFileExist candidates + pure $ case existing of + c : _ -> Just c + _ -> Nothing + withIsolatedSessionBus :: ActionWith () -> IO () -withIsolatedSessionBus action = - bracket setup teardown (const $ action ()) +withIsolatedSessionBus action = do + setupResult <- (try setup :: IO (Either SomeException BusEnv)) + case setupResult of + Right env -> action () `finally` teardown env + Left e -> + pendingWith $ + "Skipping D-Bus integration test: " + <> displayException e setup :: IO BusEnv setup = do oldAddress <- lookupEnv "DBUS_SESSION_BUS_ADDRESS" oldPid <- lookupEnv "DBUS_SESSION_BUS_PID" + oldCacheHome <- lookupEnv "XDG_CACHE_HOME" + tempDir <- getTemporaryDirectory + (cachePath, cacheHandle) <- openTempFile tempDir "status-notifier-item-test-cache" + hClose cacheHandle + removeFile cachePath + createDirectory cachePath + mConfig <- findDbusSessionConfig + let baseArgs = ["--fork", "--print-address=1", "--print-pid=1"] + args = + case mConfig of + Just configPath -> ["--config-file=" <> configPath] <> baseArgs + Nothing -> ["--session"] <> baseArgs (code, out, err) <- readProcessWithExitCode "dbus-daemon" - ["--session", "--fork", "--print-address=1", "--print-pid=1"] + args "" case (code, lines out) of (ExitSuccess, address : pidLine : _) -> do setEnv "DBUS_SESSION_BUS_ADDRESS" address setEnv "DBUS_SESSION_BUS_PID" pidLine + setEnv "XDG_CACHE_HOME" cachePath pure BusEnv { previousAddress = oldAddress , previousPid = oldPid + , previousCacheHome = oldCacheHome + , cacheHome = cachePath , daemonPid = pidLine } _ -> @@ -83,6 +133,10 @@ IO (Either SomeException (ExitCode, String, String)) restore "DBUS_SESSION_BUS_ADDRESS" previousAddress restore "DBUS_SESSION_BUS_PID" previousPid + restore "XDG_CACHE_HOME" previousCacheHome + _ <- try (removeDirectoryRecursive cacheHome) :: + IO (Either SomeException ()) + pure () where restore key value = maybe (unsetEnv key) (setEnv key) value diff --git a/test/WatcherSpec.hs b/test/WatcherSpec.hs --- a/test/WatcherSpec.hs +++ b/test/WatcherSpec.hs @@ -131,5 +131,40 @@ stable `shouldBe` True ) `finally` cleanupB + it "restores live items from cache when the watcher restarts" $ \() -> do + watcher1 <- startWatcher + itemClient <- connectSession + cleanup <- registerSimpleItem itemClient "org.test.RestoreLive" defaultPath "network-wireless" + (do + _ <- releaseName watcher1 "org.kde.StatusNotifierWatcher" + watcher2 <- startWatcher + Right entries <- WatcherClient.getRegisteredSNIEntries watcher2 + entries `shouldContain` [("org.test.RestoreLive", "/StatusNotifierItem")] + ) `finally` cleanup + + it "drops cached items that no longer exist when restarting" $ \() -> do + watcher1 <- startWatcher + itemClient <- connectSession + cleanup <- registerSimpleItem itemClient "org.test.RestoreMissing" defaultPath "network-offline" + _ <- releaseName watcher1 "org.kde.StatusNotifierWatcher" + cleanup + watcher2 <- startWatcher + Right entries <- WatcherClient.getRegisteredSNIEntries watcher2 + entries `shouldNotContain` [("org.test.RestoreMissing", "/StatusNotifierItem")] + + it "deduplicates re-registration after restoring an item from cache" $ \() -> do + watcher1 <- startWatcher + itemClient <- connectSession + cleanup <- registerSimpleItem itemClient "org.test.RestoreDedup" defaultPath "folder" + (do + _ <- releaseName watcher1 "org.kde.StatusNotifierWatcher" + watcher2 <- startWatcher + WatcherClient.registerStatusNotifierItem itemClient "org.test.RestoreDedup" + `shouldReturn` Right () + Right entries <- WatcherClient.getRegisteredSNIEntries watcher2 + let matches = filter (== ("org.test.RestoreDedup", "/StatusNotifierItem")) entries + length matches `shouldBe` 1 + ) `finally` cleanup + defaultPath :: String defaultPath = "/StatusNotifierItem" diff --git a/watcher/Main.hs b/watcher/Main.hs --- a/watcher/Main.hs +++ b/watcher/Main.hs @@ -14,8 +14,8 @@ import Paths_status_notifier_item (version) -getWatcherParams :: String -> String -> Priority -> IO WatcherParams -getWatcherParams namespace path priority = do +getWatcherParams :: String -> String -> Priority -> Maybe FilePath -> IO WatcherParams +getWatcherParams namespace path priority stateCachePath = do logger <- getLogger "StatusNotifier" saveGlobalLogger $ setLevel priority logger client <- connectSession @@ -25,6 +25,7 @@ { watcherNamespace = namespace , watcherPath = path , watcherDBusClient = Just client + , watcherStateCachePath = stateCachePath } watcherParamsParser :: Parser (IO WatcherParams) @@ -46,14 +47,19 @@ <> short 'l' <> help "Set the log level" <> metavar "LEVEL" - <> value WARNING + <> value INFO + ) <*> optional (strOption + ( long "state-cache-path" + <> metavar "FILEPATH" + <> help "Override the watcher state cache file path." ) + ) versionOption :: Parser (a -> a) versionOption = infoOption (printf "status-notifier-watcher %s" $ showVersion version) ( long "version" - <> help "Show the version number of gtk-sni-tray" + <> help "Show the version number of status-notifier-watcher" ) main :: IO ()