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 @@ -31,7 +31,6 @@ import Text.Printf import qualified StatusNotifier.Item.Client as I -import qualified StatusNotifier.Item.Constants as I import StatusNotifier.Util import qualified StatusNotifier.Watcher.Client as W import qualified StatusNotifier.Watcher.Constants as W @@ -106,6 +105,7 @@ { itemInfoMap :: IO (Map.Map BusName ItemInfo) , addUpdateHandler :: UpdateHandler -> IO Unique , removeUpdateHandler :: Unique -> IO () + , forceUpdate :: BusName -> IO () } deriving Typeable build :: Params -> IO (Maybe Host) @@ -184,7 +184,7 @@ clientSignalRegister signalRegisterFn handler = signalRegisterFn client matchAny handler logUnableToCallSignal - handleItemAdded _ serviceName = + handleItemAdded serviceName = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> buildItemInfo serviceName >>= either (logErrorAndThen $ return itemInfoMap) @@ -196,13 +196,13 @@ maybe I.defaultPath itemServicePath . Map.lookup name <$> readMVar itemInfoMapVar - handleItemRemoved _ serviceName = let busName = busName_ serviceName in + handleItemRemoved serviceName = let busName = busName_ serviceName in modifyMVar_ itemInfoMapVar (return . Map.delete busName ) >> doUpdate ItemRemoved defaultItemInfo { itemServiceName = busName } watcherRegistrationPairs = - [ (W.registerForStatusNotifierItemRegistered, handleItemAdded) - , (W.registerForStatusNotifierItemUnregistered, handleItemRemoved) + [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded) + , (W.registerForStatusNotifierItemUnregistered, const handleItemRemoved) ] getSender fn s@M.Signal { M.signalSender = Just sender} = @@ -289,9 +289,9 @@ { itemInfoMap = readMVar itemInfoMapVar , addUpdateHandler = addHandler , removeUpdateHandler = removeHandler + , forceUpdate = handleItemAdded . coerce } else Nothing else do logErrorWithMessage "Failed to obtain desired service name" nameRequestResult return Nothing - diff --git a/src/StatusNotifier/Item/Client.hs b/src/StatusNotifier/Item/Client.hs --- a/src/StatusNotifier/Item/Client.hs +++ b/src/StatusNotifier/Item/Client.hs @@ -1,17 +1,17 @@ {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module StatusNotifier.Item.Client where import DBus.Generation -import StatusNotifier.Item.Constants as C -import Language.Haskell.TH - -generateClient C.generationParams C.introspectionInterface -generateSignalsFromInterface C.generationParams C.introspectionInterface +import DBus.Internal.Types +import StatusNotifier.Util +import System.FilePath -printItemClient = - runQ (generateClient C.generationParams C.introspectionInterface) >>= - putStrLn . pprint +generateClientFromFile + defaultGenerationParams + { genTakeSignalErrorHandler = True } + False + ("xml" "StatusNotifierItem.xml") -printItemSignals = - runQ (generateSignalsFromInterface C.generationParams C.introspectionInterface) >>= - putStrLn . pprint +defaultPath :: ObjectPath +defaultPath = "/StatusNotifierItem" diff --git a/src/StatusNotifier/Item/Constants.hs b/src/StatusNotifier/Item/Constants.hs deleted file mode 100644 --- a/src/StatusNotifier/Item/Constants.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module StatusNotifier.Item.Constants where - -import DBus.Generation -import DBus.Introspection -import DBus.Internal.Types -import Data.Maybe -import Language.Haskell.TH -import System.IO.Unsafe - -import StatusNotifier.Util - -{-# NOINLINE introspectionObject #-} -introspectionObject = unsafePerformIO $ - head . maybeToList . parseXML "/" <$> - readFile "xml/StatusNotifierItem.xml" - -introspectionInterface = - head $ objectInterfaces introspectionObject - -defaultPath :: ObjectPath -defaultPath = objectPath introspectionObject - -generationParams = - defaultGenerationParams - { genTakeSignalErrorHandler = True } diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs --- a/src/StatusNotifier/Util.hs +++ b/src/StatusNotifier/Util.hs @@ -7,26 +7,40 @@ import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I +import qualified DBus.Generation as G import qualified Data.ByteString as BS +import Data.Maybe import qualified Data.Vector.Storable as VS import Data.Vector.Storable.ByteString import Language.Haskell.TH import Network.Socket (ntohl) -import Paths_status_notifier_item ( getDataDir ) import StatusNotifier.TH -import System.FilePath import System.IO import System.IO.Unsafe import System.Log.Handler.Simple import System.Log.Logger -getXMLDataFile :: String -> IO FilePath -getXMLDataFile filename = ( filename) . ( "xml") <$> getDataDir +getIntrospectionObjectFromFile :: FilePath -> T.ObjectPath -> Q I.Object +getIntrospectionObjectFromFile filepath nodePath = runIO $ + head . maybeToList . I.parseXML nodePath <$> readFile filepath +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 + realParams = + if useObjectPath + 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 cond whenTrue whenFalse = cond >>= (\bool -> if bool then whenTrue else whenFalse) +makeLensesWithLSuffix :: Name -> DecsQ makeLensesWithLSuffix = makeLensesWith $ lensRules & lensField .~ \_ _ name -> @@ -45,15 +59,6 @@ makeErrorReply :: ErrorName -> String -> Reply makeErrorReply e message = ReplyError e [T.toVariant message] -{-# NOINLINE defaultHandler #-} -defaultHandler :: GenericHandler Handle -defaultHandler = unsafePerformIO $ streamHandler stdout INFO - -{-# NOINLINE makeDefaultLogger #-} -makeDefaultLogger :: String -> Logger -makeDefaultLogger name = - unsafePerformIO $ getLogger name - logErrorWithDefault :: Show a => Logger -> b -> String -> Either a b -> IO b logErrorWithDefault logger def message = @@ -97,5 +102,10 @@ (>>=/) :: 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 bus path = right (I.parseXML "/") <$> introspect client bus path 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 @@ -27,7 +27,6 @@ data WatcherParams = WatcherParams { watcherNamespace :: String , watcherPath :: String - , watcherLogger :: Logger , watcherStop :: IO () , watcherDBusClient :: Maybe Client } @@ -36,7 +35,6 @@ defaultWatcherParams = WatcherParams { watcherNamespace = "org.kde" - , watcherLogger = makeDefaultLogger "StatusNotifier.Watcher.Service" , watcherStop = return () , watcherPath = "/StatusNotifierWatcher" , watcherDBusClient = Nothing diff --git a/src/StatusNotifier/Watcher/Service.hs b/src/StatusNotifier/Watcher/Service.hs --- a/src/StatusNotifier/Watcher/Service.hs +++ b/src/StatusNotifier/Watcher/Service.hs @@ -20,6 +20,7 @@ import Data.Maybe import Data.Monoid import Data.String +import qualified StatusNotifier.Item.Client as Item import StatusNotifier.Util import StatusNotifier.Watcher.Constants import StatusNotifier.Watcher.Signals @@ -29,14 +30,14 @@ buildWatcher WatcherParams { watcherNamespace = interfaceNamespace - , watcherLogger = logger , watcherStop = stopWatcher , watcherPath = path , watcherDBusClient = mclient } = do let watcherInterfaceName = getWatcherInterfaceName interfaceNamespace - log = logL logger INFO - logError = logL logger ERROR + logNamespace = "StatusNotifier.Watcher.Service" + log = logM logNamespace INFO + logError = logM logNamespace ERROR mkLogCb cb msg = lift (log (show msg)) >> cb msg mkLogMethod method = method { methodHandler = mkLogCb $ methodHandler method } mkLogProperty name fn = @@ -50,13 +51,15 @@ let itemIsRegistered item items = isJust $ find (== item) items - registerStatusNotifierItem MethodCall { methodCallSender = sender } name = runExceptT $ do + registerStatusNotifierItem MethodCall + { methodCallSender = sender } + name = runExceptT $ do let maybeBusName = getFirst $ mconcat $ map First [T.parseBusName name, sender] parseServiceError = makeErrorReply errorInvalidParameters $ printf "the provided service %s could not be parsed \ \as a bus name or an object path." name - path = fromMaybe "/StatusNotifierItem" $ T.parseObjectPath name + path = fromMaybe Item.defaultPath $ T.parseObjectPath name remapErrorName = left $ (`makeErrorReply` "Failed to verify ownership.") . M.methodErrorName @@ -64,7 +67,8 @@ let item = ItemEntry { serviceName = busName , servicePath = path } - hasOwner <- ExceptT $ remapErrorName <$> DBusTH.nameHasOwner client (coerce busName) + hasOwner <- ExceptT $ remapErrorName <$> + DBusTH.nameHasOwner client (coerce busName) lift $ modifyMVar_ notifierItems $ \currentItems -> if itemIsRegistered item currentItems then @@ -125,17 +129,25 @@ return () watcherMethods = map mkLogMethod - [ autoMethodWithMsg "RegisterStatusNotifierItem" registerStatusNotifierItem - , autoMethod "RegisterStatusNotifierHost" registerStatusNotifierHost - , autoMethod "StopWatcher" stopWatcher - , autoMethod "GetObjectPathForItemName" objectPathForItem + [ 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 + [ mkLogProperty "RegisteredStatusNotifierItems" + registeredStatusNotifierItems + , mkLogProperty "RegisteredSNIEntries" + registeredSNIEntries + , mkLogProperty "IsStatusNotifierHostRegistered" + isStatusNotifierHostRegistered + , mkLogProperty "ProtocolVersion" + protocolVersion ] watcherInterface = @@ -151,7 +163,8 @@ case nameRequestResult of NamePrimaryOwner -> do - _ <- DBusTH.registerForNameOwnerChanged client matchAny handleNameOwnerChanged + _ <- DBusTH.registerForNameOwnerChanged client + matchAny handleNameOwnerChanged export client (fromString path) watcherInterface _ -> stopWatcher return nameRequestResult @@ -163,5 +176,6 @@ -- IO isn't needed to build watcher {-# NOINLINE watcherInterface #-} watcherInterface = buildIntrospectionInterface clientInterface - where (clientInterface, _) = unsafePerformIO $ buildWatcher - defaultWatcherParams { watcherDBusClient = Just undefined } + where (clientInterface, _) = + unsafePerformIO $ buildWatcher + defaultWatcherParams { watcherDBusClient = Just undefined } diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: feda98a88b3e5480785430699b26288a4655a16b299f61f763431c4193ea54b4 +-- hash: fab14775734399bef953c7eccd528496b0abd4ae265b3f999bf78e2ee151b2b4 name: status-notifier-item -version: 0.2.1.0 +version: 0.2.2.0 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop @@ -31,7 +31,6 @@ exposed-modules: StatusNotifier.Host.Service StatusNotifier.Item.Client - StatusNotifier.Item.Constants StatusNotifier.TH StatusNotifier.Util StatusNotifier.Watcher.Client @@ -80,6 +79,7 @@ build-depends: base >=4.7 && <5 , dbus >=1.0.0 && <2.0.0 + , dbus-hslogger >=0.1.0.1 && <0.2.0.0 , hslogger , optparse-applicative , status-notifier-item diff --git a/watcher/Main.hs b/watcher/Main.hs --- a/watcher/Main.hs +++ b/watcher/Main.hs @@ -1,39 +1,68 @@ module Main where import Control.Concurrent.MVar +import Control.Monad +import DBus.Client import Data.Semigroup ((<>)) +import Data.Version (showVersion) import Options.Applicative import StatusNotifier.Watcher.Constants import StatusNotifier.Watcher.Service +import System.Log.DBus.Server import System.Log.Logger +import Text.Printf -setWatcherParams namespace path = - defaultWatcherParams - { watcherNamespace = namespace - , watcherPath = path - } +import Paths_status_notifier_item (version) -watcherParamsParser :: Parser WatcherParams -watcherParamsParser = setWatcherParams +getWatcherParams :: String -> String -> Priority -> IO WatcherParams +getWatcherParams namespace path priority = do + logger <- getLogger "StatusNotifier" + saveGlobalLogger $ setLevel priority logger + client <- connectSession + startLogServer client + return $ + defaultWatcherParams + { watcherNamespace = namespace + , watcherPath = path + , watcherDBusClient = Just client + } + +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 + <> 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." ) + <> help "The path at which to run the watcher." + ) <*> option auto + ( long "log-level" + <> short 'l' + <> help "Set the log level" + <> metavar "LEVEL" + <> value WARNING + ) +versionOption :: Parser (a -> a) +versionOption = infoOption + (printf "status-notifier-watcher %s" $ showVersion version) + ( long "version" + <> help "Show the version number of gtk-sni-tray" + ) + +main :: IO () main = do - watcherParams <- execParser $ - info (watcherParamsParser <**> helper) + watcherParams <- join $ execParser $ + info (helper <*> versionOption <*> watcherParamsParser) ( fullDesc <> progDesc "Run a StatusNotifierWatcher") stop <- newEmptyMVar (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () } - startWatcher + _ <- startWatcher takeMVar stop diff --git a/xml/StatusNotifierItem.xml b/xml/StatusNotifierItem.xml --- a/xml/StatusNotifierItem.xml +++ b/xml/StatusNotifierItem.xml @@ -1,68 +1,68 @@ - - - - - - - + + + + + + + - - - - + + + + - - - + + + - - - + + + - - + + - - + + - - - + + + - - - - - - - - - - - - - + + + + + + + + + + + + + - - - - - - - - - - - - + + + + + + + + + + + + - - - - - - - - + + + + + + + +