status-notifier-item 0.3.2.2 → 0.3.2.7

raw patch · 10 files changed

+860/−86 lines, 10 filesdep ~byte-orderdep ~bytestringdep ~bytestring-to-vectorPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: byte-order, bytestring, bytestring-to-vector, containers, dbus, dbus-hslogger, directory, filepath, hslogger, hspec, lens, optparse-applicative, process, template-haskell, text, transformers, unix, vector

API changes (from Hackage documentation)

Files

• ChangeLog.md +36/−0
• src/StatusNotifier/Host/Service.hs +97/−16
• src/StatusNotifier/Watcher/Constants.hs +2/−0
• src/StatusNotifier/Watcher/Service.hs +195/−34
• src/StatusNotifier/Watcher/StateCache.hs +275/−0
• status-notifier-item.cabal +30/−27
• test/HostSpec.hs +122/−1
• test/TestSupport.hs +58/−4
• test/WatcherSpec.hs +35/−0
• watcher/Main.hs +10/−4

@@ -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.

@@ -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

@@ -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 =

@@ -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 

@@ -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

@@ -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 <https://github.com/IvanMalison/status-notifier-item#readme> 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

@@ -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"

@@ -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 

@@ -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"

@@ -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 ()