diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/item/Main.hs b/item/Main.hs --- a/item/Main.hs +++ b/item/Main.hs @@ -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 diff --git a/src/StatusNotifier/Host/Service.hs b/src/StatusNotifier/Host/Service.hs --- a/src/StatusNotifier/Host/Service.hs +++ b/src/StatusNotifier/Host/Service.hs @@ -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 diff --git a/src/StatusNotifier/Item/Client.hs b/src/StatusNotifier/Item/Client.hs --- a/src/StatusNotifier/Item/Client.hs +++ b/src/StatusNotifier/Item/Client.hs @@ -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") diff --git a/src/StatusNotifier/Item/Service.hs b/src/StatusNotifier/Item/Service.hs --- a/src/StatusNotifier/Item/Service.hs +++ b/src/StatusNotifier/Item/Service.hs @@ -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 diff --git a/src/StatusNotifier/TH.hs b/src/StatusNotifier/TH.hs --- a/src/StatusNotifier/TH.hs +++ b/src/StatusNotifier/TH.hs @@ -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 diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs --- a/src/StatusNotifier/Util.hs +++ b/src/StatusNotifier/Util.hs @@ -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) diff --git a/src/StatusNotifier/Watcher/Client.hs b/src/StatusNotifier/Watcher/Client.hs --- a/src/StatusNotifier/Watcher/Client.hs +++ b/src/StatusNotifier/Watcher/Client.hs @@ -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 diff --git a/src/StatusNotifier/Watcher/Constants.hs b/src/StatusNotifier/Watcher/Constants.hs --- a/src/StatusNotifier/Watcher/Constants.hs +++ b/src/StatusNotifier/Watcher/Constants.hs @@ -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 + } diff --git a/src/StatusNotifier/Watcher/Service.hs b/src/StatusNotifier/Watcher/Service.hs --- a/src/StatusNotifier/Watcher/Service.hs +++ b/src/StatusNotifier/Watcher/Service.hs @@ -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} diff --git a/src/StatusNotifier/Watcher/Signals.hs b/src/StatusNotifier/Watcher/Signals.hs --- a/src/StatusNotifier/Watcher/Signals.hs +++ b/src/StatusNotifier/Watcher/Signals.hs @@ -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 diff --git a/src/StatusNotifier/Watcher/StateCache.hs b/src/StatusNotifier/Watcher/StateCache.hs --- a/src/StatusNotifier/Watcher/StateCache.hs +++ b/src/StatusNotifier/Watcher/StateCache.hs @@ -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" diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: status-notifier-item -version: 0.3.2.13 +version: 0.3.2.14 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop diff --git a/test/HostSpec.hs b/test/HostSpec.hs --- a/test/HostSpec.hs +++ b/test/HostSpec.hs @@ -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 diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,8 +1,7 @@ module Main (main) where -import Test.Hspec - import qualified HostSpec +import Test.Hspec import qualified UtilSpec import qualified WatcherSpec diff --git a/test/TestSupport.hs b/test/TestSupport.hs --- a/test/TestSupport.hs +++ b/test/TestSupport.hs @@ -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 diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs --- a/test/UtilSpec.hs +++ b/test/UtilSpec.hs @@ -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 diff --git a/test/WatcherSpec.hs b/test/WatcherSpec.hs --- a/test/WatcherSpec.hs +++ b/test/WatcherSpec.hs @@ -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" diff --git a/tool/Main.hs b/tool/Main.hs --- a/tool/Main.hs +++ b/tool/Main.hs @@ -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 () diff --git a/watcher/Main.hs b/watcher/Main.hs --- a/watcher/Main.hs +++ b/watcher/Main.hs @@ -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