status-notifier-item 0.3.2.13 → 0.3.2.14
raw patch · 21 files changed
+863/−750 lines, 21 filessetup-changedPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
API changes (from Hackage documentation)
- StatusNotifier.Host.Service: callFromInfo :: (BusName -> ObjectPath -> t) -> ItemInfo -> t
+ StatusNotifier.Host.Service: callFromInfo :: (BusName -> ObjectPath -> result) -> ItemInfo -> result
Files
- ChangeLog.md +6/−0
- Setup.hs +1/−0
- item/Main.hs +39/−34
- src/StatusNotifier/Host/Service.hs +54/−58
- src/StatusNotifier/Item/Client.hs +5/−2
- src/StatusNotifier/Item/Service.hs +34/−33
- src/StatusNotifier/TH.hs +3/−2
- src/StatusNotifier/Util.hs +56/−44
- src/StatusNotifier/Watcher/Client.hs +4/−3
- src/StatusNotifier/Watcher/Constants.hs +54/−41
- src/StatusNotifier/Watcher/Service.hs +391/−343
- src/StatusNotifier/Watcher/Signals.hs +14/−6
- src/StatusNotifier/Watcher/StateCache.hs +52/−47
- status-notifier-item.cabal +1/−1
- test/HostSpec.hs +3/−3
- test/Main.hs +1/−2
- test/TestSupport.hs +58/−55
- test/UtilSpec.hs +5/−5
- test/WatcherSpec.hs +28/−24
- tool/Main.hs +2/−3
- watcher/Main.hs +52/−44
ChangeLog.md view
@@ -2,6 +2,12 @@ ## Unreleased +## 0.3.2.14 - 2026-05-13+- Clean up generated DBus client, service, and watcher code for newer compiler+ warning compatibility.+- Keep watcher startup behavior unchanged after reverting an experimental+ synchronous startup path.+ ## 0.3.2.13 - 2026-03-30 - Host: suppress no-op property update notifications when a signal arrives but the refreshed item value is unchanged, avoiding redundant tray updates.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
item/Main.hs view
@@ -1,48 +1,53 @@ module Main where -import Control.Concurrent.MVar import Control.Monad-import Data.Semigroup ((<>)) import Data.Version (showVersion) import Options.Applicative import Paths_status_notifier_item (version) import StatusNotifier.Item.Service import Text.Printf -itemsParamsParser = ItemParams- <$> strOption- ( long "icon-name"- <> short 'n'- <> metavar "NAME"- <> value "emacs"- <> help "The icon the item will display."- ) <*> strOption- ( long "overlay-name"- <> short 'o'- <> metavar "NAME"- <> value "steam"- <> help "The icon that will be used for the overlay."- ) <*> strOption- ( long "dbus-name"- <> short 'd'- <> metavar "NAME"- <> value "org.SampleSNI"- <> help "The dbus name used for this sample item."- )+itemsParamsParser :: Parser ItemParams+itemsParamsParser =+ ItemParams+ <$> strOption+ ( long "icon-name"+ <> short 'n'+ <> metavar "NAME"+ <> value "emacs"+ <> help "The icon the item will display."+ )+ <*> strOption+ ( long "overlay-name"+ <> short 'o'+ <> metavar "NAME"+ <> value "steam"+ <> help "The icon that will be used for the overlay."+ )+ <*> strOption+ ( long "dbus-name"+ <> short 'd'+ <> metavar "NAME"+ <> value "org.SampleSNI"+ <> help "The dbus name used for this sample item."+ ) versionOption :: Parser (a -> a)-versionOption = infoOption- (printf "status-notifier-item %s" $ showVersion version)- ( long "version"- <> help "Show the version number of gtk-sni-tray"- )+versionOption =+ infoOption+ (printf "status-notifier-item %s" $ showVersion version)+ ( long "version"+ <> help "Show the version number of gtk-sni-tray"+ ) main :: IO () main = do- itemParams <- execParser $ info (helper <*> versionOption <*> itemsParamsParser)- ( fullDesc- <> progDesc "Run a static StatusNotifierItem"- )- buildItem itemParams- void $ getChar-+ itemParams <-+ execParser $+ info+ (helper <*> versionOption <*> itemsParamsParser)+ ( fullDesc+ <> progDesc "Run a static StatusNotifierItem"+ )+ _ <- buildItem itemParams+ void getChar
src/StatusNotifier/Host/Service.hs view
@@ -8,9 +8,7 @@ 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@@ -30,7 +28,6 @@ import Data.String import Data.Typeable import Data.Unique-import Data.Word import qualified StatusNotifier.Item.Client as I import StatusNotifier.Util import qualified StatusNotifier.Watcher.Client as W@@ -67,8 +64,10 @@ matchSenderWhenNameOwnersUnmatched :: Bool } +hostLogger :: Priority -> String -> IO () hostLogger = logM "StatusNotifier.Host.Service" +defaultParams :: Params defaultParams = Params { dbusClient = Nothing,@@ -120,6 +119,7 @@ } deriving (Eq, Show) +supressPixelData :: ItemInfo -> ItemInfo supressPixelData info = info { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info,@@ -166,6 +166,7 @@ [(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)] convertPixmapsToHostByteOrder = map $ over _3 networkToSystemByteOrder +callFromInfo :: (BusName -> ObjectPath -> result) -> ItemInfo -> result callFromInfo fn ItemInfo@@ -196,7 +197,7 @@ let busName = getBusName namespaceString uniqueID logError = hostLogger ERROR- logErrorWithMessage message error = logError message >> logError (show error)+ logErrorWithMessage message err = logError message >> logError (show err) logInfo = hostLogger INFO logDebug = hostLogger DEBUG@@ -216,7 +217,7 @@ doUpdate utype uinfo = readMVar updateHandlersVar >>= mapM_ (doUpdateForHandler utype uinfo) - addHandler handler = do+ addUpdateHandler_ handler = do unique <- newUnique modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do logInfo $@@ -233,7 +234,7 @@ return itemInfoMap return unique - removeHandler unique =+ removeUpdateHandler_ unique = modifyMVar_ updateHandlersVar $ \handlers -> do let newHandlers = filter ((/= unique) . fst) handlers logInfo $@@ -253,16 +254,15 @@ in (busName_ bus, objectPath_ <$> maybePath) buildItemInfo name = runExceptT $ do- let (busName, maybePath) = parseServiceName name- path <- case maybePath of+ let (itemBusName, maybePath) = parseServiceName name+ itemPath <- case maybePath of Just parsedPath -> return parsedPath Nothing -> objectPath_ <$> ExceptT- (W.getObjectPathForItemName client (coerce busName))+ (W.getObjectPathForItemName client (coerce itemBusName)) let doGetDef def fn =- ExceptT $ exemptAll def <$> fn client busName path- doGet fn = ExceptT $ fn client busName path+ ExceptT $ exemptAll def <$> fn client itemBusName itemPath pixmaps <- doGetDef [] $ getPixmaps I.getIconPixmap iName <- doGetDef name I.getIconName overlayPixmap <- doGetDef [] $ getPixmaps I.getOverlayIconPixmap@@ -277,11 +277,11 @@ itemIsMenu <- doGetDef True I.getItemIsMenu return ItemInfo- { itemServiceName = busName,+ { itemServiceName = itemBusName, itemId = idString, itemStatus = status, itemCategory = category,- itemServicePath = path,+ itemServicePath = itemPath, itemToolTip = tooltip, iconPixmaps = pixmaps, iconThemePath = themePath,@@ -302,10 +302,10 @@ registerWithPairs = mapM (uncurry clientSignalRegister) where- logUnableToCallSignal signal =+ logUnableToCallSignal dbusSignal = hostLogger ERROR $ printf "Unable to call handler with %s" $- show signal+ show dbusSignal clientSignalRegister signalRegisterFn handler = signalRegisterFn client matchAny handler logUnableToCallSignal @@ -327,18 +327,18 @@ (addItemInfo itemInfoMap) where addItemInfo- map+ currentMap itemInfo@ItemInfo { itemServiceName = newName, itemServicePath = newPath } =- if Map.member newName map+ if Map.member newName currentMap then do logDebug $ printf "Ignoring duplicate ItemAdded for %s because the exact service is already tracked." (coerce newName :: String)- return map+ return currentMap else do -- When the watcher restarts, some items may re-register -- under a different bus name (e.g. switching between@@ -358,7 +358,7 @@ && logicalDuplicateKey existingInfo == logicalDuplicateKey itemInfo addFresh = do doUpdate ItemAdded itemInfo- pure (Map.insert newName itemInfo map)+ pure (Map.insert newName itemInfo currentMap) replaceExisting :: BusName -> ItemInfo -> String -> IO (Map.Map BusName ItemInfo) replaceExisting existingName existingInfo reason = do logInfo $@@ -371,12 +371,12 @@ doUpdate ItemAdded itemInfo pure $ Map.insert newName itemInfo $- Map.delete existingName map+ Map.delete existingName currentMap tryLogicalDuplicateMatch = case logicalDuplicateKey itemInfo of Nothing -> addFresh Just duplicateKey -> do- existing <- findUniqueMatchM matchesLogicalDuplicate (Map.toList map)+ existing <- findUniqueMatchM matchesLogicalDuplicate (Map.toList currentMap) case existing of Just (existingName, existingInfo) -> replaceExisting@@ -387,7 +387,7 @@ case newOwner of Nothing -> tryLogicalDuplicateMatch Just _ -> do- existing <- findM matchesOwnerAndPath (Map.toList map)+ existing <- findM matchesOwnerAndPath (Map.toList currentMap) case existing of Nothing -> do logDebug $@@ -410,14 +410,14 @@ modifyMVar itemInfoMapVar doRemove >>= maybe logNonExistentRemoval (doUpdate ItemRemoved) where- busName = fst (parseServiceName serviceName)+ itemBusName = fst (parseServiceName serviceName) doRemove currentMap =- return (Map.delete busName currentMap, Map.lookup busName currentMap)+ return (Map.delete itemBusName currentMap, Map.lookup itemBusName 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+ show itemBusName watcherRegistrationPairs = [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded),@@ -428,6 +428,7 @@ synchronizeItemsWithWatcher = do let retryDelayMicros = 50000+ maxRetries :: Int maxRetries = 20 fetchWatcherItems retries = do watcherItemsResult <- W.getRegisteredStatusNotifierItems client@@ -456,20 +457,15 @@ 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- runProperty prop serviceName = getObjectPathForItemName serviceName >>= prop client serviceName - logUnknownSender updateType signal =+ logUnknownSender updateType dbusSignal = hostLogger DEBUG $ printf "Got signal for update type: %s from unknown sender: %s" (show updateType)- (show signal)+ (show dbusSignal) identifySender M.Signal@@ -529,24 +525,24 @@ a <||> b = runMaybeT $ MaybeT a <|> MaybeT b identifySender _ = return Nothing - updateItemByLensAndProp lens prop busName = runExceptT $ do- newValue <- ExceptT (runProperty prop busName)+ updateItemByLensAndProp valueLens prop itemBusName = runExceptT $ do+ newValue <- ExceptT (runProperty prop itemBusName) let modify infoMap =- case Map.lookup busName infoMap of+ case Map.lookup itemBusName infoMap of Nothing -> return (infoMap, Nothing) Just oldInfo ->- let newInfo = set lens newValue oldInfo+ let newInfo = set valueLens newValue oldInfo in if newInfo == oldInfo then return (infoMap, Just Nothing) else- let newMap = Map.insert busName newInfo infoMap+ let newMap = Map.insert itemBusName newInfo infoMap in return (newMap, Just $ Just newInfo) ExceptT $ maybeToEither (methodError (Serial 0) errorFailed) <$> modifyMVar itemInfoMapVar modify - logErrorsHandler lens updateType prop =- runUpdaters [updateItemByLensAndProp lens prop] updateType+ logErrorsHandler valueLens updateType prop =+ runUpdaters [updateItemByLensAndProp valueLens prop] updateType -- Run all the provided updaters with the expectation that at least one -- will succeed.@@ -555,17 +551,17 @@ let (failures, successes) = partitionEithers updateResults logLevel = propertyUpdateFailureLogLevel failures successes mapM_ (doUpdate updateType) $ catMaybes successes- when (not $ null failures) $+ unless (null failures) $ hostLogger logLevel $ printf "Property update failures %s" $ show failures - runUpdaters updaters updateType signal =- identifySender signal >>= maybe runForAll (runUpdateForService . itemServiceName)+ runUpdaters updaters updateType dbusSignal =+ identifySender dbusSignal >>= maybe runForAll (runUpdateForService . itemServiceName) where runUpdateForService = runUpdatersForService updaters updateType runForAll =- logUnknownSender updateType signal+ logUnknownSender updateType dbusSignal >> readMVar itemInfoMapVar >>= mapM_ runUpdateForService . Map.keys @@ -578,17 +574,17 @@ updateIconTheme = updateItemByLensAndProp iconThemePathL getThemePathDefault - updateFromIconThemeFromSignal signal =- identifySender signal >>= traverse (updateIconTheme . itemServiceName)+ updateFromIconThemeFromSignal dbusSignal =+ identifySender dbusSignal >>= traverse (updateIconTheme . itemServiceName) - handleNewIcon signal = do+ handleNewIcon dbusSignal = 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+ _ <- updateFromIconThemeFromSignal dbusSignal runUpdaters [updateIconPixmaps, updateIconName] IconUpdated- signal+ dbusSignal updateOverlayIconName = updateItemByLensAndProp overlayIconNameL $@@ -598,15 +594,15 @@ updateItemByLensAndProp overlayIconPixmapsL $ getPixmaps I.getOverlayIconPixmap - handleNewOverlayIcon signal = do- updateFromIconThemeFromSignal signal+ handleNewOverlayIcon dbusSignal = do+ _ <- updateFromIconThemeFromSignal dbusSignal runUpdaters [updateOverlayIconPixmaps, updateOverlayIconName] OverlayIconUpdated- signal+ dbusSignal - getThemePathDefault client busName objectPath =- right Just <$> I.getIconThemePath client busName objectPath+ getThemePathDefault dbusClient itemBusName objectPath =+ right Just <$> I.getIconThemePath dbusClient itemBusName objectPath handleNewTitle = logErrorsHandler iconTitleL TitleUpdated I.getTitle@@ -639,10 +635,10 @@ shutdownHost = do logInfo "Shutting down StatusNotifierHost" unregisterAll- releaseName client (fromString busName)+ _ <- releaseName client (fromString busName) return ()- logErrorAndShutdown error =- logError (show error) >> shutdownHost >> return (Map.empty, False)+ logErrorAndShutdown err =+ logError (show err) >> shutdownHost >> return (Map.empty, False) finishInitialization serviceNames = do itemInfos <- createAll serviceNames let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos@@ -673,8 +669,8 @@ Just Host { itemInfoMap = readMVar itemInfoMapVar,- addUpdateHandler = addHandler,- removeUpdateHandler = removeHandler,+ addUpdateHandler = addUpdateHandler_,+ removeUpdateHandler = removeUpdateHandler_, forceUpdate = handleItemAdded . coerce } else Nothing
src/StatusNotifier/Item/Client.hs view
@@ -1,5 +1,7 @@-{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+ module StatusNotifier.Item.Client where import DBus.Generation@@ -9,7 +11,8 @@ generateClientFromFile defaultGenerationParams- { genTakeSignalErrorHandler = True }+ { genTakeSignalErrorHandler = True+ } False ("xml" </> "StatusNotifierItem.xml")
src/StatusNotifier/Item/Service.hs view
@@ -1,41 +1,42 @@ {-# LANGUAGE OverloadedStrings #-}+ module StatusNotifier.Item.Service where -import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import DBus-import DBus.Client-import qualified DBus.TH as DBusTH+import DBus+import DBus.Client import qualified Data.ByteString as BS-import Data.Int-import Data.String+import Data.Int+import Data.String import qualified StatusNotifier.Watcher.Client as W data ItemParams = ItemParams- { iconName :: String- , iconOverlayName :: String- , itemDBusName :: String- } deriving (Eq, Show, Read)+ { iconName :: String,+ iconOverlayName :: String,+ itemDBusName :: String+ }+ deriving (Eq, Show, Read) -buildItem ItemParams- { iconName = name- , iconOverlayName = overlayName- , itemDBusName = dbusName- } = do- client <- connectSession- let- getTooltip :: IO (String, [(Int32, Int32, BS.ByteString)], String, String)- getTooltip = return ("", [], "Title", "Text")- let clientInterface =- Interface { interfaceName = "org.kde.StatusNotifierItem"- , interfaceMethods = []- , interfaceProperties =- [ readOnlyProperty "IconName" $ return name- , readOnlyProperty "OverlayIconName" $ return overlayName- , readOnlyProperty "ToolTip" $ getTooltip- ]- , interfaceSignals = []- }- export client (fromString "/StatusNotifierItem") clientInterface- requestName client (busName_ dbusName) []- W.registerStatusNotifierItem client dbusName+buildItem :: ItemParams -> IO (Either MethodError ())+buildItem+ ItemParams+ { iconName = name,+ iconOverlayName = overlayName,+ itemDBusName = itemBusName+ } = do+ client <- connectSession+ let getTooltip :: IO (String, [(Int32, Int32, BS.ByteString)], String, String)+ getTooltip = return ("", [], "Title", "Text")+ let clientInterface =+ Interface+ { interfaceName = "org.kde.StatusNotifierItem",+ interfaceMethods = [],+ interfaceProperties =+ [ readOnlyProperty "IconName" $ return name,+ readOnlyProperty "OverlayIconName" $ return overlayName,+ readOnlyProperty "ToolTip" getTooltip+ ],+ interfaceSignals = []+ }+ export client (fromString "/StatusNotifierItem") clientInterface+ _ <- requestName client (busName_ itemBusName) []+ W.registerStatusNotifierItem client itemBusName
src/StatusNotifier/TH.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE TemplateHaskell #-}+ module StatusNotifier.TH where import DBus.Client@@ -6,5 +7,5 @@ -- XXX: Move this to haskell-dbus generateClient defaultGenerationParams $- buildIntrospectionInterface $- buildIntrospectableInterface undefined+ buildIntrospectionInterface $+ buildIntrospectableInterface undefined
src/StatusNotifier/Util.hs view
@@ -1,60 +1,70 @@ {-# LANGUAGE OverloadedStrings #-}+ module StatusNotifier.Util where -import Control.Arrow-import Control.Lens-import DBus.Client+import Control.Arrow+import Control.Lens+import DBus.Client import qualified DBus.Generation as G import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I-import Data.Bits+import Data.Bits import qualified Data.ByteString as BS-import Data.Maybe-import qualified Data.Vector.Storable as VS-import Data.Vector.Storable.ByteString-import Data.Word-import Language.Haskell.TH-import StatusNotifier.TH+import Data.Maybe+import Data.Text (pack) import qualified Data.Text.IO as TIO-import Data.Text (pack)-import System.ByteOrder (fromBigEndian)-import System.Log.Logger+import qualified Data.Vector.Storable as VS+import Data.Vector.Storable.ByteString+import Data.Word+import Language.Haskell.TH+import StatusNotifier.TH+import System.ByteOrder (fromBigEndian)+import System.Log.Logger splitServiceName :: String -> (String, Maybe String) splitServiceName name =- case break (=='/') name of+ case break (== '/') name of (bus, "") -> (bus, Nothing) (bus, path) | not (null bus) -> (bus, Just path) _ -> (name, Nothing) getIntrospectionObjectFromFile :: FilePath -> T.ObjectPath -> Q I.Object-getIntrospectionObjectFromFile filepath nodePath = runIO $- head . maybeToList . I.parseXML nodePath <$> TIO.readFile filepath+getIntrospectionObjectFromFile filepath nodePath = do+ object <- runIO $ I.parseXML nodePath <$> TIO.readFile filepath+ maybe+ (fail $ "Unable to parse introspection XML from " <> filepath)+ pure+ object generateClientFromFile :: G.GenerationParams -> Bool -> FilePath -> Q [Dec] generateClientFromFile params useObjectPath filepath = do object <- getIntrospectionObjectFromFile filepath "/"- let interface = head $ I.objectInterfaces object- actualObjectPath = I.objectPath object+ interface <-+ case I.objectInterfaces object of+ interface : _ -> pure interface+ [] -> fail $ "No interfaces found in introspection XML from " <> filepath+ let actualObjectPath = I.objectPath object realParams = if useObjectPath- then params { G.genObjectPath = Just actualObjectPath }- else params- (++) <$> G.generateClient realParams interface <*>- G.generateSignalsFromInterface realParams interface+ then params {G.genObjectPath = Just actualObjectPath}+ else params+ (++)+ <$> G.generateClient realParams interface+ <*> G.generateSignalsFromInterface realParams interface -ifM :: Monad m => m Bool -> m a -> m a -> m a+ifM :: (Monad m) => m Bool -> m a -> m a -> m a ifM cond whenTrue whenFalse = cond >>= (\bool -> if bool then whenTrue else whenFalse) makeLensesWithLSuffix :: Name -> DecsQ makeLensesWithLSuffix = makeLensesWith $- lensRules & lensField .~ \_ _ name ->- [TopName (mkName $ nameBase name ++ "L")]+ lensRules+ & lensField .~ \_ _ name ->+ [TopName (mkName $ nameBase name ++ "L")] -whenJust :: Monad m => Maybe a -> (a -> m ()) -> m ()+whenJust :: (Monad m) => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe $ return () convertARGBToABGR :: Word32 -> Word32@@ -76,11 +86,11 @@ makeErrorReply e message = ReplyError e [T.toVariant message] logErrorWithDefault ::- Show a => (Priority -> String -> IO ()) -> b -> String -> Either a b -> IO b+ (Show a) => (Priority -> String -> IO ()) -> b -> String -> Either a b -> IO b logErrorWithDefault logger def message = fmap (fromMaybe def) . logEitherError logger message -logEitherError :: Show a => (Priority -> String -> IO ()) -> String -> Either a b -> IO (Maybe b)+logEitherError :: (Show a) => (Priority -> String -> IO ()) -> String -> Either a b -> IO (Maybe b) logEitherError logger message = either (\err -> logger ERROR (message ++ show err) >> return Nothing) (return . Just) @@ -89,10 +99,10 @@ exemptUnknownMethod def eitherV = case eitherV of Right _ -> eitherV- Left M.MethodError { M.methodErrorName = errorName } ->+ Left M.MethodError {M.methodErrorName = errorName} -> if errorName == errorUnknownMethod- then Right def- else eitherV+ then Right def+ else eitherV exemptAll :: b -> Either M.MethodError b -> Either M.MethodError b@@ -102,34 +112,36 @@ Left _ -> Right def infixl 4 <..>-(<..>) :: Functor f => (a -> b) -> f (f a) -> f (f b)++(<..>) :: (Functor f) => (a -> b) -> f (f a) -> f (f b) (<..>) = fmap . fmap infixl 4 <<$>>+ (<<$>>) :: (a -> IO b) -> Maybe a -> IO (Maybe b)-fn <<$>> m = sequenceA $ fn <$> m+fn <<$>> m = traverse fn m -forkM :: Monad m => (i -> m a) -> (i -> m b) -> i -> m (a, b)+forkM :: (Monad m) => (i -> m a) -> (i -> m b) -> i -> m (a, b) forkM a b i = do r1 <- a i r2 <- b i return (r1, r2) -tee :: Monad m => (i -> m a) -> (i -> m b) -> i -> m a+tee :: (Monad m) => (i -> m a) -> (i -> m b) -> i -> m a tee = (fmap . fmap . fmap) (fmap fst) forkM -(>>=/) :: Monad m => m a -> (a -> m b) -> m a+(>>=/) :: (Monad m) => m a -> (a -> m b) -> m a (>>=/) a = (a >>=) . tee return -getInterfaceAt- :: Client- -> T.BusName- -> T.ObjectPath- -> IO (Either M.MethodError (Maybe I.Object))+getInterfaceAt ::+ Client ->+ T.BusName ->+ T.ObjectPath ->+ IO (Either M.MethodError (Maybe I.Object)) getInterfaceAt client bus path = right (I.parseXML "/" . pack) <$> introspect client bus path -findM :: Monad m => (a -> m Bool) -> [a] -> m (Maybe a)-findM p [] = return Nothing-findM p (x:xs) = ifM (p x) (return $ Just x) (findM p xs)+findM :: (Monad m) => (a -> m Bool) -> [a] -> m (Maybe a)+findM p =+ foldr (\x -> ifM (p x) (return $ Just x)) (return Nothing)
src/StatusNotifier/Watcher/Client.hs view
@@ -1,14 +1,15 @@ {-# LANGUAGE TemplateHaskell #-}+ module StatusNotifier.Watcher.Client where import DBus.Generation import Language.Haskell.TH- import StatusNotifier.Watcher.Constants import StatusNotifier.Watcher.Service generateClient watcherClientGenerationParams watcherInterface +printWatcherClient :: IO () printWatcherClient =- runQ (generateClient watcherClientGenerationParams watcherInterface) >>=- putStrLn . pprint+ runQ (generateClient watcherClientGenerationParams watcherInterface)+ >>= putStrLn . pprint
src/StatusNotifier/Watcher/Constants.hs view
@@ -1,16 +1,14 @@ {-# LANGUAGE OverloadedStrings #-}+ module StatusNotifier.Watcher.Constants where -import DBus.Client-import DBus.Generation-import DBus.Internal.Types+import DBus.Client+import DBus.Generation+import DBus.Internal.Types import qualified DBus.Introspection as I-import Data.Coerce-import Data.String-import StatusNotifier.Util-import System.IO.Unsafe-import System.Log.Logger-import Text.Printf+import Data.Coerce+import Data.String+import Text.Printf statusNotifierWatcherString :: String statusNotifierWatcherString = "StatusNotifierWatcher"@@ -20,50 +18,65 @@ fromString $ printf "%s.%s" interfaceNamespace statusNotifierWatcherString data ItemEntry = ItemEntry- { serviceName :: BusName- , servicePath :: ObjectPath- } deriving (Show, Eq)+ { serviceName :: BusName,+ servicePath :: ObjectPath+ }+ deriving (Show, Eq) data WatcherParams = WatcherParams- { watcherNamespace :: String- , watcherPath :: String- , watcherStop :: IO ()- , watcherDBusClient :: Maybe Client- , watcherStateCachePath :: Maybe FilePath+ { watcherNamespace :: String,+ watcherPath :: String,+ watcherStop :: IO (),+ watcherDBusClient :: Maybe Client,+ watcherStateCachePath :: Maybe FilePath } defaultWatcherParams :: WatcherParams defaultWatcherParams = WatcherParams- { watcherNamespace = "org.kde"- , watcherStop = return ()- , watcherPath = "/StatusNotifierWatcher"- , watcherDBusClient = Nothing- , watcherStateCachePath = Nothing- }+ { watcherNamespace = "org.kde",+ watcherStop = return (),+ watcherPath = "/StatusNotifierWatcher",+ watcherDBusClient = Nothing,+ watcherStateCachePath = Nothing+ } +defaultWatcherInterfaceName :: InterfaceName defaultWatcherInterfaceName = getWatcherInterfaceName $ watcherNamespace defaultWatcherParams -serviceArg = I.SignalArg { I.signalArgName = "service"- , I.signalArgType = TypeString- }+serviceArg :: I.SignalArg+serviceArg =+ I.SignalArg+ { I.signalArgName = "service",+ I.signalArgType = TypeString+ } -watcherSignals = [ I.Signal { I.signalName = "StatusNotifierItemRegistered"- , I.signalArgs = [serviceArg]- }- , I.Signal { I.signalName = "StatusNotifierItemUnregistered"- , I.signalArgs = [serviceArg]- }- , I.Signal { I.signalName = "StatusNotifierHostRegistered"- , I.signalArgs = []- }- ]+watcherSignals :: [I.Signal]+watcherSignals =+ [ I.Signal+ { I.signalName = "StatusNotifierItemRegistered",+ I.signalArgs = [serviceArg]+ },+ I.Signal+ { I.signalName = "StatusNotifierItemUnregistered",+ I.signalArgs = [serviceArg]+ },+ I.Signal+ { I.signalName = "StatusNotifierHostRegistered",+ I.signalArgs = []+ }+ ] +watcherClientGenerationParams :: GenerationParams watcherClientGenerationParams = defaultGenerationParams- { genBusName = Just $ fromString $ coerce $ getWatcherInterfaceName- (watcherNamespace defaultWatcherParams)- , genObjectPath = Just $ fromString $ watcherPath defaultWatcherParams- , genTakeSignalErrorHandler = True- }+ { genBusName =+ Just $+ fromString $+ coerce $+ getWatcherInterfaceName+ (watcherNamespace defaultWatcherParams),+ genObjectPath = Just $ fromString $ watcherPath defaultWatcherParams,+ genTakeSignalErrorHandler = True+ }
src/StatusNotifier/Watcher/Service.hs view
@@ -1,387 +1,435 @@-{-# LANGUAGE OverloadedStrings, FlexibleContexts #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+ module StatusNotifier.Watcher.Service where -import Control.Arrow-import Control.Concurrent.MVar-import Control.Monad-import Control.Monad.Trans.Class-import Control.Monad.Trans.Except-import DBus-import DBus.Client-import DBus.Generation-import DBus.Internal.Message as M-import DBus.Internal.Types+import Control.Arrow+import Control.Concurrent.MVar+import Control.Monad+import Control.Monad.Trans.Class+import Control.Monad.Trans.Except+import DBus+import DBus.Client+import DBus.Internal.Message as M+import DBus.Internal.Types import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I import qualified DBus.TH as DBusTH-import Data.Coerce-import Data.Int-import Data.List-import Data.Maybe-import Data.Monoid-import Data.String+import Data.Coerce+import Data.Int+import Data.List+import Data.Maybe+import Data.String 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-import Text.Printf+import StatusNotifier.Util+import StatusNotifier.Watcher.Constants+import StatusNotifier.Watcher.Signals+import StatusNotifier.Watcher.StateCache+import System.IO.Unsafe+import System.Log.Logger+import Text.Printf -buildWatcher WatcherParams- { watcherNamespace = interfaceNamespace- , watcherStop = stopWatcher- , watcherPath = path- , watcherDBusClient = mclient- , watcherStateCachePath = maybeCachePath- } = do- let watcherInterfaceName = getWatcherInterfaceName interfaceNamespace- logNamespace = "StatusNotifier.Watcher.Service"- logInfo = logM logNamespace INFO- logDebug = logM logNamespace DEBUG- logError = logM logNamespace ERROR- -- 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 $ logDebug (coerce name ++ " Called") >> fn+buildWatcher :: WatcherParams -> IO (Interface, IO RequestNameReply)+buildWatcher+ WatcherParams+ { watcherNamespace = interfaceNamespace,+ watcherStop = stopWatcher,+ watcherPath = path,+ watcherDBusClient = mclient,+ watcherStateCachePath = maybeCachePath+ } = do+ let watcherInterfaceName = getWatcherInterfaceName interfaceNamespace+ logNamespace = "StatusNotifier.Watcher.Service"+ logInfo = logM logNamespace INFO+ logDebug = logM logNamespace DEBUG+ logError = logM logNamespace ERROR+ -- 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 $ logDebug (coerce name ++ " Called") >> fn - client <- maybe connectSession return mclient- cachePath <- maybe (defaultWatcherStateCachePath interfaceNamespace path)- pure- maybeCachePath+ client <- maybe connectSession return mclient+ cachePath <-+ maybe+ (defaultWatcherStateCachePath interfaceNamespace path)+ pure+ maybeCachePath - notifierItems <- newMVar []- notifierHosts <- newMVar []+ notifierItems <- newMVar []+ notifierHosts <- newMVar [] - let itemIsRegistered item items =- isJust $ find (== item) items+ 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 ())+ 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+ (logError . printf "Failed to persist watcher state to %s: %s" cachePath)+ (const $ return ()) - renderServiceName :: ItemEntry -> String- renderServiceName ItemEntry { serviceName = busName- , servicePath = path- } =- let bus = (coerce busName :: String)- objPath = (coerce path :: String)- defaultPath = (coerce Item.defaultPath :: String)- in if objPath == defaultPath- then bus- else bus ++ objPath+ renderServiceName :: ItemEntry -> String+ renderServiceName+ ItemEntry+ { serviceName = busName,+ servicePath = itemPath+ } =+ let bus = (coerce busName :: String)+ objPath = (coerce itemPath :: 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+ 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)+ 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)+ 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- }+ 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+ 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+ 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+ 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)+ 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)+ 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)+ 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)+ persistWatcherState+ return (restoredItems, restoredHosts) - registerStatusNotifierItem MethodCall- { methodCallSender = sender }- name = runExceptT $ do- let parsedBusName = T.parseBusName name- parseServiceError = makeErrorReply errorInvalidParameters $- printf "the provided service %s could not be parsed \- \as a bus name or an object path." name- senderMissingError = makeErrorReply errorInvalidParameters $- "Unable to identify sender for registration."- path = fromMaybe Item.defaultPath $ T.parseObjectPath name- remapErrorName =- left $ (`makeErrorReply` "Failed to verify ownership.") .- M.methodErrorName- when (isNothing parsedBusName && isNothing (T.parseObjectPath name)) $- throwE parseServiceError- senderName <- ExceptT $ return $ maybeToEither senderMissingError sender- busName <-- case parsedBusName of- 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- }- 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+ registerStatusNotifierItem+ MethodCall+ { methodCallSender = sender+ }+ name = runExceptT $ do+ let parsedBusName = T.parseBusName name+ parseServiceError =+ makeErrorReply errorInvalidParameters $+ printf+ "the provided service %s could not be parsed \+ \as a bus name or an object path."+ name+ senderMissingError =+ makeErrorReply+ errorInvalidParameters+ "Unable to identify sender for registration."+ itemPath = fromMaybe Item.defaultPath $ T.parseObjectPath name+ remapErrorName =+ left $+ (`makeErrorReply` "Failed to verify ownership.")+ . M.methodErrorName+ when (isNothing parsedBusName && isNothing (T.parseObjectPath name)) $+ throwE parseServiceError+ senderName <- ExceptT $ return $ maybeToEither senderMissingError sender+ busName <-+ case parsedBusName of+ 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 = itemPath+ }+ 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- 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+ registerStatusNotifierHost name =+ let item =+ ItemEntry+ { serviceName = busName_ name,+ servicePath = "/StatusNotifierHost"+ }+ in 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 =- map renderServiceName <$> readMVar notifierItems+ registeredStatusNotifierItems :: IO [String]+ registeredStatusNotifierItems =+ map renderServiceName <$> readMVar notifierItems - registeredSNIEntries :: IO [(String, String)]- registeredSNIEntries =- map getTuple <$> readMVar notifierItems- where getTuple (ItemEntry bname path) = (coerce bname, coerce path)+ registeredSNIEntries :: IO [(String, String)]+ registeredSNIEntries =+ map getTuple <$> readMVar notifierItems+ where+ getTuple (ItemEntry bname itemPath) = (coerce bname, coerce itemPath) - objectPathForItem :: String -> IO (Either Reply String)- objectPathForItem name =- case splitServiceName name of- (_, Just path) -> return $ Right path- (bus, Nothing) ->- maybeToEither notFoundError . fmap (coerce . servicePath) .- find ((== busName_ bus) . serviceName) <$>- readMVar notifierItems- where notFoundError =- makeErrorReply errorInvalidParameters $+ objectPathForItem :: String -> IO (Either Reply String)+ objectPathForItem name =+ case splitServiceName name of+ (_, Just itemPath) -> return $ Right itemPath+ (bus, Nothing) ->+ maybeToEither notFoundError+ . fmap (coerce . servicePath)+ . find ((== busName_ bus) . serviceName)+ <$> readMVar notifierItems+ where+ notFoundError =+ makeErrorReply errorInvalidParameters $ printf "Service %s is not registered." name - isStatusNotifierHostRegistered = not . null <$> readMVar notifierHosts+ isStatusNotifierHostRegistered = not . null <$> readMVar notifierHosts - protocolVersion = return 0 :: IO Int32+ protocolVersion = return 0 :: IO Int32 - filterDeadService :: String -> MVar [ItemEntry] -> IO [ItemEntry]- filterDeadService deadService mvar = modifyMVar mvar $- return . partition ((/= busName_ deadService) . serviceName)+ filterDeadService :: String -> MVar [ItemEntry] -> IO [ItemEntry]+ filterDeadService deadService mvar =+ modifyMVar mvar $+ return . partition ((/= busName_ deadService) . serviceName) - handleNameOwnerChanged _ name oldOwner newOwner =- when (newOwner == "") $ do- removedItems <- filterDeadService name notifierItems- unless (null removedItems) $ do- logInfo $ printf "Unregistering item %s because it disappeared." name- forM_ removedItems $ \item ->- emitStatusNotifierItemUnregistered client $ renderServiceName item- removedHosts <- filterDeadService name notifierHosts- unless (null removedHosts) $- logInfo $ printf "Unregistering host %s because it disappeared." name- when (not (null removedItems) || not (null removedHosts)) $- persistWatcherState- return ()+ handleNameOwnerChanged _ name _oldOwner newOwner =+ when (newOwner == "") $ do+ removedItems <- filterDeadService name notifierItems+ unless (null removedItems) $ do+ logInfo $ printf "Unregistering item %s because it disappeared." name+ forM_ removedItems $ \item ->+ emitStatusNotifierItemUnregistered client $ renderServiceName item+ removedHosts <- filterDeadService name notifierHosts+ unless (null removedHosts) $+ logInfo $+ printf "Unregistering host %s because it disappeared." name+ when+ (not (null removedItems) || not (null removedHosts))+ persistWatcherState - watcherMethods = map mkLogMethod- [ autoMethodWithMsg "RegisterStatusNotifierItem"- registerStatusNotifierItem- , autoMethod "RegisterStatusNotifierHost"- registerStatusNotifierHost- , autoMethod "StopWatcher"- stopWatcher- , autoMethod "GetObjectPathForItemName"- objectPathForItem- ]+ watcherMethods =+ map+ mkLogMethod+ [ autoMethodWithMsg+ "RegisterStatusNotifierItem"+ registerStatusNotifierItem,+ autoMethod+ "RegisterStatusNotifierHost"+ registerStatusNotifierHost,+ autoMethod+ "StopWatcher"+ stopWatcher,+ autoMethod+ "GetObjectPathForItemName"+ objectPathForItem+ ] - watcherProperties =- [ mkLogProperty "RegisteredStatusNotifierItems"- registeredStatusNotifierItems- , mkLogProperty "RegisteredSNIEntries"- registeredSNIEntries- , mkLogProperty "IsStatusNotifierHostRegistered"- isStatusNotifierHostRegistered- , mkLogProperty "ProtocolVersion"- protocolVersion- ]+ watcherProperties =+ [ mkLogProperty+ "RegisteredStatusNotifierItems"+ registeredStatusNotifierItems,+ mkLogProperty+ "RegisteredSNIEntries"+ registeredSNIEntries,+ mkLogProperty+ "IsStatusNotifierHostRegistered"+ isStatusNotifierHostRegistered,+ mkLogProperty+ "ProtocolVersion"+ protocolVersion+ ] - watcherInterface =- Interface- { interfaceName = watcherInterfaceName- , interfaceMethods = watcherMethods- , interfaceProperties = watcherProperties- , interfaceSignals = watcherSignals- }+ builtWatcherInterface =+ Interface+ { interfaceName = watcherInterfaceName,+ interfaceMethods = watcherMethods,+ interfaceProperties = watcherProperties,+ interfaceSignals = watcherSignals+ } - startWatcher = do- nameRequestResult <- requestName client (coerce watcherInterfaceName) []- case nameRequestResult of- NamePrimaryOwner ->- 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+ startWatcher = do+ nameRequestResult <- requestName client (coerce watcherInterfaceName) []+ case nameRequestResult of+ NamePrimaryOwner ->+ do+ _ <-+ DBusTH.registerForNameOwnerChanged+ client+ matchAny+ handleNameOwnerChanged+ (restoredItems, restoredHosts) <- restoreWatcherStateFromCache+ export client (fromString path) builtWatcherInterface+ 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 - return (watcherInterface, startWatcher)+ return (builtWatcherInterface, startWatcher) -- For Client generation -- TODO: get rid of unsafePerformIO here by making function that takes mvars so -- IO isn't needed to build watcher {-# NOINLINE watcherInterface #-}+watcherInterface :: I.Interface watcherInterface = buildIntrospectionInterface clientInterface- where (clientInterface, _) =- unsafePerformIO $ buildWatcher- defaultWatcherParams { watcherDBusClient = Just undefined }+ where+ (clientInterface, _) =+ unsafePerformIO $+ buildWatcher+ defaultWatcherParams {watcherDBusClient = Just undefined}
src/StatusNotifier/Watcher/Signals.hs view
@@ -1,17 +1,25 @@ {-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS_GHC -Wno-unused-matches #-}+ module StatusNotifier.Watcher.Signals where import DBus.Generation import Language.Haskell.TH- import StatusNotifier.Watcher.Constants -- The bus name is set to nothing here because sender comes through as the -- unique name of the watcher, not the special bus name that it requests.-generateSignals watcherClientGenerationParams { genBusName = Nothing }- defaultWatcherInterfaceName watcherSignals+generateSignals+ watcherClientGenerationParams {genBusName = Nothing}+ defaultWatcherInterfaceName+ watcherSignals +printWatcherSignals :: IO () printWatcherSignals =- runQ (generateSignals watcherClientGenerationParams { genBusName = Nothing }- defaultWatcherInterfaceName watcherSignals) >>=- putStrLn . pprint+ runQ+ ( generateSignals+ watcherClientGenerationParams {genBusName = Nothing}+ defaultWatcherInterfaceName+ watcherSignals+ )+ >>= putStrLn . pprint
src/StatusNotifier/Watcher/StateCache.hs view
@@ -1,45 +1,48 @@ module StatusNotifier.Watcher.StateCache- ( PersistedItemEntry (..)- , PersistedWatcherState (..)- , defaultWatcherStateCachePath- , readPersistedWatcherState- , writePersistedWatcherState- ) where+ ( 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+ ( XdgDirectory (XdgCache),+ createDirectoryIfMissing,+ doesFileExist,+ getXdgDirectory,+ renameFile, )-import System.FilePath ((</>), takeDirectory)+import System.FilePath (takeDirectory, (</>)) import Text.ParserCombinators.ReadP- ( ReadP- , char- , choice- , eof- , many- , munch- , readP_to_S- , satisfy- , sepBy- , skipSpaces+ ( ReadP,+ char,+ choice,+ eof,+ many,+ munch,+ readP_to_S,+ satisfy,+ sepBy,+ skipSpaces, ) data PersistedItemEntry = PersistedItemEntry- { persistedServiceName :: String- , persistedServicePath :: String- } deriving (Eq, Show)+ { persistedServiceName :: String,+ persistedServicePath :: String+ }+ deriving (Eq, Show) data PersistedWatcherState = PersistedWatcherState- { persistedItems :: [PersistedItemEntry]- , persistedHosts :: [PersistedItemEntry]- } deriving (Eq, Show)+ { persistedItems :: [PersistedItemEntry],+ persistedHosts :: [PersistedItemEntry]+ }+ deriving (Eq, Show) data JsonValue = JsonObject [(String, JsonValue)]@@ -90,16 +93,16 @@ encodePersistedWatcherState state = encodeJsonValue $ JsonObject- [ ("version", JsonNumber 1)- , ("items", JsonArray $ map encodeItemEntry (persistedItems state))- , ("hosts", JsonArray $ map encodeItemEntry (persistedHosts state))+ [ ("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))+ [ ("service_name", JsonString (persistedServiceName entry)),+ ("service_path", JsonString (persistedServicePath entry)) ] decodePersistedWatcherState :: String -> Either String PersistedWatcherState@@ -114,20 +117,22 @@ hostsValue <- getRequired "hosts" rootObject items <- asArray "items" itemsValue >>= mapM decodeItemEntry hosts <- asArray "hosts" hostsValue >>= mapM decodeItemEntry- Right PersistedWatcherState- { persistedItems = items- , persistedHosts = hosts- }+ 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- }+ Right+ PersistedItemEntry+ { persistedServiceName = serviceName,+ persistedServicePath = servicePath+ } encodeJsonValue :: JsonValue -> String encodeJsonValue json =@@ -218,17 +223,17 @@ parseEscaped = do _ <- char '\\' choice- [ '"' <$ char '"'- , '\\' <$ char '\\'- , '\n' <$ char 'n'- , '\r' <$ char 'r'- , '\t' <$ char 't'+ [ '"' <$ 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 == '-')+ sign <- munch (== '-') digits <- munch isDigit if null digits || length sign > 1 then fail "Invalid number"
status-notifier-item.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: status-notifier-item-version: 0.3.2.13+version: 0.3.2.14 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at <https://github.com/taffybar/status-notifier-item#readme> category: Desktop
test/HostSpec.hs view
@@ -17,7 +17,7 @@ writeChan, ) import Control.Exception (finally)-import Control.Monad (replicateM, void)+import Control.Monad (join, replicateM, void) import DBus (busName_, interfaceName_, memberName_, objectPath_, signal) import DBus.Client import qualified DBus.Internal.Message as M@@ -76,8 +76,8 @@ removeUpdateHandler host token itemClient <- connectSession- cleanup <- registerSimpleItem itemClient "org.test.HostItemC" defaultPath "help-about"- cleanup+ join $+ registerSimpleItem itemClient "org.test.HostItemC" defaultPath "help-about" noEvent <- timeout 500000 (readChan events) noEvent `shouldBe` Nothing
test/Main.hs view
@@ -1,8 +1,7 @@ module Main (main) where -import Test.Hspec- import qualified HostSpec+import Test.Hspec import qualified UtilSpec import qualified WatcherSpec
test/TestSupport.hs view
@@ -2,58 +2,59 @@ {-# LANGUAGE RecordWildCards #-} module TestSupport- ( withIsolatedSessionBus- , startWatcher- , registerSimpleItem- , connectSessionWithName- , waitFor- ) where+ ( withIsolatedSessionBus,+ startWatcher,+ registerSimpleItem,+ connectSessionWithName,+ waitFor,+ )+where import Control.Concurrent (threadDelay) import Control.Exception (SomeException, displayException, finally, try) import Control.Monad (filterM) import DBus (BusName, busName_, formatBusName, objectPath_) import DBus.Client- ( Client- , Interface (..)- , RequestNameReply (NamePrimaryOwner)- , connectSession- , connectWithName- , defaultClientOptions- , export- , readOnlyProperty- , releaseName- , requestName+ ( Client,+ Interface (..),+ RequestNameReply (NamePrimaryOwner),+ connectSession,+ connectWithName,+ defaultClientOptions,+ export,+ readOnlyProperty,+ releaseName,+ requestName, ) import DBus.Internal.Address (getSessionAddress)+import qualified StatusNotifier.Watcher.Client as WatcherClient import StatusNotifier.Watcher.Constants- ( defaultWatcherParams- , watcherDBusClient- , watcherStop+ ( defaultWatcherParams,+ watcherDBusClient,+ watcherStop, )-import qualified StatusNotifier.Watcher.Client as WatcherClient import qualified StatusNotifier.Watcher.Service as WatcherService import System.Directory- ( createDirectory- , doesFileExist- , findExecutable- , getTemporaryDirectory- , removeDirectoryRecursive- , removeFile+ ( createDirectory,+ doesFileExist,+ findExecutable,+ getTemporaryDirectory,+ removeDirectoryRecursive,+ removeFile, ) import System.Environment (lookupEnv, setEnv, unsetEnv)-import System.Exit (ExitCode, ExitCode (ExitSuccess))-import System.FilePath ((</>), takeDirectory)+import System.Exit (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+ { previousAddress :: Maybe String,+ previousPid :: Maybe String,+ previousCacheHome :: Maybe String,+ cacheHome :: FilePath,+ daemonPid :: String } findDbusSessionConfig :: IO (Maybe FilePath)@@ -64,8 +65,8 @@ Just exe -> do let prefix = takeDirectory (takeDirectory exe) candidates =- [ prefix </> "share" </> "dbus-1" </> "session.conf"- , prefix </> "etc" </> "dbus-1" </> "session.conf"+ [ prefix </> "share" </> "dbus-1" </> "session.conf",+ prefix </> "etc" </> "dbus-1" </> "session.conf" ] existing <- filterM doesFileExist candidates pure $ case existing of@@ -108,13 +109,14 @@ 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- }+ pure+ BusEnv+ { previousAddress = oldAddress,+ previousPid = oldPid,+ previousCacheHome = oldCacheHome,+ cacheHome = cachePath,+ daemonPid = pidLine+ } _ -> error $ "Failed to start test dbus-daemon: exit="@@ -138,11 +140,12 @@ restore "DBUS_SESSION_BUS_ADDRESS" previousAddress restore "DBUS_SESSION_BUS_PID" previousPid restore "XDG_CACHE_HOME" previousCacheHome- _ <- try (removeDirectoryRecursive cacheHome) ::- IO (Either SomeException ())+ _ <-+ try (removeDirectoryRecursive cacheHome) ::+ IO (Either SomeException ()) pure () where- restore key value = maybe (unsetEnv key) (setEnv key) value+ restore key = maybe (unsetEnv key) (setEnv key) startWatcher :: IO Client startWatcher = do@@ -150,8 +153,8 @@ (_, startFn) <- WatcherService.buildWatcher defaultWatcherParams- { watcherDBusClient = Just client- , watcherStop = pure ()+ { watcherDBusClient = Just client,+ watcherStop = pure () } reply <- startFn reply `shouldBe` NamePrimaryOwner@@ -166,14 +169,14 @@ registerSimpleItem client busName objectPath iconName = do let iface = Interface- { interfaceName = "org.kde.StatusNotifierItem"- , interfaceMethods = []- , interfaceProperties =- [ readOnlyProperty "IconName" (pure iconName)- , readOnlyProperty "OverlayIconName" (pure ("" :: String))- , readOnlyProperty "ItemIsMenu" (pure False)- ]- , interfaceSignals = []+ { interfaceName = "org.kde.StatusNotifierItem",+ interfaceMethods = [],+ interfaceProperties =+ [ readOnlyProperty "IconName" (pure iconName),+ readOnlyProperty "OverlayIconName" (pure ("" :: String)),+ readOnlyProperty "ItemIsMenu" (pure False)+ ],+ interfaceSignals = [] } path = objectPath_ objectPath
test/UtilSpec.hs view
@@ -69,11 +69,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 = [] } errorUnknownMethod :: ErrorName
test/WatcherSpec.hs view
@@ -1,15 +1,15 @@+{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} module WatcherSpec (spec) where import Control.Exception (finally)-import Data.Either (isLeft)-import Data.List (isPrefixOf) import DBus (BusName, busName_, formatBusName, objectPath_) import DBus.Client+import Data.Either (isLeft)+import Data.List (isPrefixOf) import qualified StatusNotifier.Watcher.Client as WatcherClient import Test.Hspec- import TestSupport spec :: Spec@@ -24,13 +24,13 @@ watcher <- startWatcher itemClient <- connectSession cleanup <- registerSimpleItem itemClient "org.test.ItemA" defaultPath "network-wireless"- (do- result <- WatcherClient.getRegisteredSNIEntries watcher- result `shouldSatisfy` \v ->- case v of+ ( do+ result <- WatcherClient.getRegisteredSNIEntries watcher+ result `shouldSatisfy` \case Right entries -> any ((== defaultPath) . snd) entries Left _ -> False- ) `finally` cleanup+ )+ `finally` cleanup it "is idempotent when the same item registers twice" $ \() -> do watcher <- startWatcher@@ -82,16 +82,17 @@ 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 = []- }+ 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@@ -142,7 +143,7 @@ itemClientB <- connectSession cleanupA <- registerSimpleItem itemClientA "org.test.ItemE" defaultPath "media-playback-start" cleanupB <- registerSimpleItem itemClientB "org.test.ItemF" defaultPath "media-playback-stop"- (do+ ( do Right before <- WatcherClient.getRegisteredSNIEntries watcher before `shouldContain` [("org.test.ItemE", "/StatusNotifierItem")] before `shouldContain` [("org.test.ItemF", "/StatusNotifierItem")]@@ -156,18 +157,20 @@ && ("org.test.ItemF", "/StatusNotifierItem") `elem` entries Left _ -> False stable `shouldBe` True- ) `finally` cleanupB+ )+ `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+ ( do _ <- releaseName watcher1 "org.kde.StatusNotifierWatcher" watcher2 <- startWatcher Right entries <- WatcherClient.getRegisteredSNIEntries watcher2 entries `shouldContain` [("org.test.RestoreLive", "/StatusNotifierItem")]- ) `finally` cleanup+ )+ `finally` cleanup it "drops cached items that no longer exist when restarting" $ \() -> do watcher1 <- startWatcher@@ -183,7 +186,7 @@ watcher1 <- startWatcher itemClient <- connectSession cleanup <- registerSimpleItem itemClient "org.test.RestoreDedup" defaultPath "folder"- (do+ ( do _ <- releaseName watcher1 "org.kde.StatusNotifierWatcher" watcher2 <- startWatcher WatcherClient.registerStatusNotifierItem itemClient "org.test.RestoreDedup"@@ -191,7 +194,8 @@ Right entries <- WatcherClient.getRegisteredSNIEntries watcher2 let matches = filter (== ("org.test.RestoreDedup", "/StatusNotifierItem")) entries length matches `shouldBe` 1- ) `finally` cleanup+ )+ `finally` cleanup defaultPath :: String defaultPath = "/StatusNotifierItem"
tool/Main.hs view
@@ -1,13 +1,12 @@ module Main where -import StatusNotifier.Watcher.Client import DBus.Client-import Data.String+import StatusNotifier.Watcher.Client +main :: IO () main = do client <- connectSession registeredItems <- getRegisteredSNIEntries client print registeredItems- return ()
watcher/Main.hs view
@@ -3,17 +3,15 @@ import Control.Concurrent.MVar import Control.Monad import DBus.Client-import Data.Semigroup ((<>)) import Data.Version (showVersion) import Options.Applicative+import Paths_status_notifier_item (version) import StatusNotifier.Watcher.Constants import StatusNotifier.Watcher.Service import System.Log.DBus.Server import System.Log.Logger import Text.Printf -import Paths_status_notifier_item (version)- getWatcherParams :: String -> String -> Priority -> Maybe FilePath -> IO WatcherParams getWatcherParams namespace path priority stateCachePath = do logger <- getLogger "StatusNotifier"@@ -22,54 +20,64 @@ startLogServer client return $ defaultWatcherParams- { watcherNamespace = namespace- , watcherPath = path- , watcherDBusClient = Just client- , watcherStateCachePath = stateCachePath- }+ { watcherNamespace = namespace,+ watcherPath = path,+ watcherDBusClient = Just client,+ watcherStateCachePath = stateCachePath+ } watcherParamsParser :: Parser (IO WatcherParams)-watcherParamsParser = getWatcherParams- <$> strOption- ( long "namespace"- <> short 'n'- <> metavar "NAMESPACE"- <> value "org.kde"- <> help "The namespace the watcher should register at."- ) <*> strOption- ( long "path"- <> short 'p'- <> metavar "DBUS-PATH"- <> value "/StatusNotifierWatcher"- <> help "The path at which to run the watcher."- ) <*> option auto- ( long "log-level"- <> short 'l'- <> help "Set the log level"- <> metavar "LEVEL"- <> value INFO- ) <*> optional (strOption- ( long "state-cache-path"- <> metavar "FILEPATH"- <> help "Override the watcher state cache file path."- )- )+watcherParamsParser =+ getWatcherParams+ <$> strOption+ ( long "namespace"+ <> short 'n'+ <> metavar "NAMESPACE"+ <> value "org.kde"+ <> help "The namespace the watcher should register at."+ )+ <*> strOption+ ( long "path"+ <> short 'p'+ <> metavar "DBUS-PATH"+ <> value "/StatusNotifierWatcher"+ <> help "The path at which to run the watcher."+ )+ <*> option+ auto+ ( long "log-level"+ <> short 'l'+ <> help "Set the log level"+ <> metavar "LEVEL"+ <> 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 status-notifier-watcher"- )+versionOption =+ infoOption+ (printf "status-notifier-watcher %s" $ showVersion version)+ ( long "version"+ <> help "Show the version number of status-notifier-watcher"+ ) main :: IO () main = do- watcherParams <- join $ execParser $- info (helper <*> versionOption <*> watcherParamsParser)- ( fullDesc- <> progDesc "Run a StatusNotifierWatcher"- )+ watcherParams <-+ join $+ execParser $+ info+ (helper <*> versionOption <*> watcherParamsParser)+ ( fullDesc+ <> progDesc "Run a StatusNotifierWatcher"+ ) stop <- newEmptyMVar- (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () }+ (_, startWatcher) <- buildWatcher watcherParams {watcherStop = putMVar stop ()} _ <- startWatcher takeMVar stop