diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for status-notifier-item + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Ivan Malison (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Ivan Malison nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# status-notifier-item diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/StatusNotifier/Host/Service.hs b/src/StatusNotifier/Host/Service.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Host/Service.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} + +module StatusNotifier.Host.Service where + +import Control.Arrow +import Control.Concurrent +import Control.Concurrent.MVar +import Control.Lens +import Control.Lens.Tuple +import Control.Monad +import Control.Monad.Except +import DBus +import DBus.Client +import qualified DBus.Internal.Message as M +import qualified Data.ByteString as BS +import Data.Either +import Data.Int +import qualified Data.Map.Strict as Map +import Data.Maybe +import Data.String +import Data.Word +import System.Log.Logger +import Text.Printf + +import qualified StatusNotifier.Item.Constants as I +import qualified StatusNotifier.Item.Client as I +import StatusNotifier.Util +import qualified StatusNotifier.Watcher.Client as W +import qualified StatusNotifier.Watcher.Signals as W + +statusNotifierHostString :: String +statusNotifierHostString = "StatusNotifierHost" + +getBusName :: String -> String -> String +getBusName namespace = + printf "%s.%s-%s" namespace statusNotifierHostString + +data UpdateType + = ItemAdded + | ItemRemoved + | IconUpdated + | IconNameUpdated + | TitleUpdated + | TooltipUpdated deriving (Eq, Show) + +data Params = Params + { dbusClient :: Maybe Client + , uniqueIdentifier :: String + , namespace :: String + , handleUpdate :: UpdateType -> ItemInfo -> IO () + , hostLogger :: Logger + } + +defaultParams = Params + { dbusClient = Nothing + , uniqueIdentifier = "" + , namespace = "org.kde" + , handleUpdate = \_ _ -> return () + , hostLogger = makeDefaultLogger "StatusNotifier.Watcher.Service" + } + +data ItemInfo = ItemInfo + { itemServiceName :: BusName + , itemServicePath :: ObjectPath + , iconTitle :: String + , iconName :: String + , iconThemePath :: Maybe String + , iconPixmaps :: [(Int32, Int32, BS.ByteString)] + , menuPath :: Maybe ObjectPath + } deriving (Eq, Show) + +defaultItemInfo = + ItemInfo + { itemServiceName = "a.b" + , itemServicePath = "/" + , iconThemePath = Nothing + , iconName = "" + , iconTitle = "" + , iconPixmaps = [] + , menuPath = Nothing + } + +makeLensesWithLSuffix ''ItemInfo + +convertPixmapsToHostByteOrder :: + [(Int32, Int32, BS.ByteString)] -> [(Int32, Int32, BS.ByteString)] +convertPixmapsToHostByteOrder = map $ over _3 networkToSystemByteOrder + +callFromInfo fn ItemInfo { itemServiceName = name + , itemServicePath = path + } = fn name path + +build :: Params -> IO (IO RequestNameReply) +build Params { dbusClient = mclient + , namespace = namespaceString + , uniqueIdentifier = uniqueID + , handleUpdate = updateHandler + , hostLogger = logger + } = do + client <- maybe connectSession return mclient + itemInfoMapVar <- newMVar Map.empty + let busName = getBusName namespaceString uniqueID + + logError = logL logger ERROR + logErrorWithMessage message error = logError message >> logError (show error) + logInfo = logL logger INFO + logErrorAndThen andThen e = logError (show e) >> andThen + + doUpdate utype uinfo = + logInfo (printf "Sending update (iconPixmaps suppressed): %s %s" + (show utype) + (show $ uinfo { iconPixmaps = [] })) >> + void (forkIO (updateHandler utype uinfo)) + + getPixmaps a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$> + I.getIconPixmap a1 a2 a3 + + buildItemInfo name = runExceptT $ do + pathString <- ExceptT $ W.getObjectPathForItemName client name + let busName = fromString name + path = objectPath_ pathString + getMaybe fn a b c = right Just <$> fn a b c + doGetDef def fn = + ExceptT $ exemptAll def <$> fn client busName path + doGet fn = ExceptT $ fn client busName path + pixmaps <- doGetDef [] getPixmaps + iName <- doGetDef name I.getIconName + themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath + menu <- doGetDef Nothing $ getMaybe I.getMenu + title <- doGetDef "" I.getTitle + return ItemInfo + { itemServiceName = busName_ name + , itemServicePath = path + , iconPixmaps = pixmaps + , iconThemePath = themePath + , iconName = iName + , iconTitle = title + , menuPath = menu + } + + createAll serviceNames = do + (errors, itemInfos) <- + partitionEithers <$> mapM buildItemInfo serviceNames + mapM_ (logErrorWithMessage "Error in item building at startup:") errors + return itemInfos + + registerWithPairs = + mapM (uncurry clientSignalRegister) + where logUnableToCallSignal signal = + logL logger ERROR $ printf "Unable to call handler with %s" $ + show signal + clientSignalRegister signalRegisterFn handler = + signalRegisterFn client matchAny handler logUnableToCallSignal + + handleItemAdded _ serviceName = + modifyMVar_ itemInfoMapVar $ \itemInfoMap -> + buildItemInfo serviceName >>= + either (logErrorAndThen $ return itemInfoMap) + (addItemInfo itemInfoMap) + where addItemInfo map itemInfo = doUpdate ItemAdded itemInfo >> + return (Map.insert (itemServiceName itemInfo) itemInfo map) + + getObjectPathForItemName name = + maybe I.defaultPath itemServicePath . Map.lookup name <$> + readMVar itemInfoMapVar + + 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) + ] + + getSender fn s@M.Signal { M.signalSender = Just sender} = + logInfo (show s) >> fn sender + getSender _ s = logError $ "Received signal with no sender: " ++ show s + + logPropError = logErrorWithMessage "Error updating property: " + + makeUpdaterFromProp = makeUpdaterFromProp' logPropError + + makeUpdaterFromProp' onError lens updateType prop = getSender run + where run sender = + getObjectPathForItemName sender >>= + prop client sender >>= + either onError (runUpdate lens updateType sender) + + runUpdate lens updateType sender newValue = + modifyMVar itemInfoMapVar modify >>= callUpdate + where modify infoMap = + let newMap = set (at sender . non defaultItemInfo . lens) + newValue infoMap + in return (newMap, Map.lookup sender newMap) + callUpdate = flip whenJust (doUpdate updateType) + + updatePixmaps = + makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps + handleNewIcon signal = + makeUpdaterFromProp' + (const $ updatePixmaps signal) + iconNameL IconNameUpdated I.getIconName signal + handleNewTitle = + makeUpdaterFromProp iconTitleL TitleUpdated I.getTitle + + clientRegistrationPairs = + [ (I.registerForNewIcon, handleNewIcon) + , (I.registerForNewTitle, handleNewTitle) + ] + + initializeItemInfoMap = modifyMVar_ itemInfoMapVar $ \itemInfoMap -> do + -- All initialization is done inside this modifyMvar to avoid race + -- conditions with the itemInfoMapVar. + clientSignalHandlers <- registerWithPairs clientRegistrationPairs + watcherSignalHandlers <- registerWithPairs watcherRegistrationPairs + let unregisterAll = + mapM_ (removeMatch client) $ + clientSignalHandlers ++ watcherSignalHandlers + shutdownHost = do + logInfo "Shutting down StatusNotifierHost" + unregisterAll + releaseName client (fromString busName) + return () + logErrorAndShutdown error = + logError (show error) >> shutdownHost >> return Map.empty + finishInitialization serviceNames = do + itemInfos <- createAll serviceNames + mapM_ (doUpdate ItemAdded) itemInfos + let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos + -- Extra paranoia about the map + resultMap = if Map.null itemInfoMap + then newMap + else Map.union itemInfoMap newMap + W.registerStatusNotifierHost client busName >>= + either logErrorAndShutdown (const $ return resultMap) + W.getRegisteredStatusNotifierItems client >>= + either logErrorAndShutdown finishInitialization + + startup = + do + nameRequestResult <- requestName client (fromString busName) [] + when (nameRequestResult == NamePrimaryOwner) initializeItemInfoMap + return nameRequestResult + return startup diff --git a/src/StatusNotifier/Item/Client.hs b/src/StatusNotifier/Item/Client.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Client.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} +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 + +printItemClient = + runQ (generateClient C.generationParams C.introspectionInterface) >>= + putStrLn . pprint + +printItemSignals = + runQ (generateSignalsFromInterface C.generationParams C.introspectionInterface) >>= + putStrLn . pprint diff --git a/src/StatusNotifier/Item/Constants.hs b/src/StatusNotifier/Item/Constants.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Constants.hs @@ -0,0 +1,26 @@ +{-# 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/TH.hs b/src/StatusNotifier/TH.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/TH.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TemplateHaskell #-} +module StatusNotifier.TH where + +import DBus.Client +import DBus.Generation + +-- XXX: Move this to haskell-dbus +generateClient defaultGenerationParams $ + buildIntrospectionInterface $ + buildIntrospectableInterface undefined diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Util.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE OverloadedStrings #-} +module StatusNotifier.Util where + +import Control.Arrow +import Control.Lens +import DBus.Client +import qualified DBus.Internal.Message as M +import qualified DBus.Internal.Types as T +import qualified DBus.Introspection as I +import qualified Data.ByteString as BS +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 + +ifM :: Monad m => m Bool -> m a -> m a -> m a +ifM cond whenTrue whenFalse = + cond >>= (\bool -> if bool then whenTrue else whenFalse) + +makeLensesWithLSuffix = + makeLensesWith $ + lensRules & lensField .~ \_ _ name -> + [TopName (mkName $ nameBase name ++ "L")] + +whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () +whenJust = flip $ maybe $ return () + +networkToSystemByteOrder :: BS.ByteString -> BS.ByteString +networkToSystemByteOrder original = + vectorToByteString $ VS.map ntohl $ byteStringToVector original + +maybeToEither :: b -> Maybe a -> Either b a +maybeToEither = flip maybe Right . Left + +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 = + setLevel INFO $ unsafePerformIO $ getLogger name + +logErrorWithDefault :: + Show a => Logger -> b -> String -> Either a b -> IO b +logErrorWithDefault logger def message = + either (\err -> logL logger ERROR (message ++ show err) >> return def) return + +exemptUnknownMethod :: + b -> Either M.MethodError b -> Either M.MethodError b +exemptUnknownMethod def eitherV = + case eitherV of + Right _ -> eitherV + Left M.MethodError { M.methodErrorName = errorName } -> + if errorName == errorUnknownMethod + then Right def + else eitherV + +exemptAll :: + b -> Either M.MethodError b -> Either M.MethodError b +exemptAll def eitherV = + case eitherV of + Right _ -> eitherV + Left _ -> Right def + +infixl 4 <..> +(<..>) :: 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 + +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 = (fmap . fmap . fmap) (fmap fst) forkM + +(>>=/) :: Monad m => m a -> (a -> m b) -> m a +(>>=/) a = (a >>=) . tee return + +getInterfaceAt client bus path = + right (I.parseXML "/") <$> introspect client bus path diff --git a/src/StatusNotifier/Watcher/Client.hs b/src/StatusNotifier/Watcher/Client.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Watcher/Client.hs @@ -0,0 +1,14 @@ +{-# 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 = + runQ (generateClient watcherClientGenerationParams watcherInterface) >>= + putStrLn . pprint diff --git a/src/StatusNotifier/Watcher/Constants.hs b/src/StatusNotifier/Watcher/Constants.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Watcher/Constants.hs @@ -0,0 +1,69 @@ +{-# LANGUAGE OverloadedStrings #-} +module StatusNotifier.Watcher.Constants where + +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 + +statusNotifierWatcherString :: String +statusNotifierWatcherString = "StatusNotifierWatcher" + +getWatcherInterfaceName :: String -> InterfaceName +getWatcherInterfaceName interfaceNamespace = + fromString $ printf "%s.%s" interfaceNamespace statusNotifierWatcherString + +data ItemEntry = ItemEntry + { serviceName :: BusName + , servicePath :: ObjectPath + } deriving (Show, Eq) + +data WatcherParams = WatcherParams + { watcherNamespace :: String + , watcherPath :: String + , watcherLogger :: Logger + , watcherStop :: IO () + , watcherDBusClient :: Maybe Client + } + +defaultWatcherParams :: WatcherParams +defaultWatcherParams = + WatcherParams + { watcherNamespace = "org.kde" + , watcherLogger = makeDefaultLogger "StatusNotifier.Watcher.Service" + , watcherStop = return () + , watcherPath = "/StatusNotifierWatcher" + , watcherDBusClient = Nothing + } + +defaultWatcherInterfaceName = + getWatcherInterfaceName $ watcherNamespace defaultWatcherParams + +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 = [] + } + ] + +watcherClientGenerationParams = + defaultGenerationParams + { 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 new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Watcher/Service.hs @@ -0,0 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +module StatusNotifier.Watcher.Service where + +import Control.Arrow +import Control.Concurrent.MVar +import Control.Monad +import Control.Monad.Trans +import Control.Monad.Trans.Except +import DBus +import DBus.Client +import DBus.Generation +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 StatusNotifier.Util +import StatusNotifier.Watcher.Constants +import StatusNotifier.Watcher.Signals +import System.IO.Unsafe +import System.Log.Logger +import Text.Printf + + +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 + mkLogCb cb msg = lift (log (show msg)) >> cb msg + mkLogMethod method = method { methodHandler = mkLogCb $ methodHandler method } + mkLogProperty name fn = + readOnlyProperty name $ log (coerce name ++ " Called") >> fn + + client <- maybe connectSession return mclient + + notifierItems <- newMVar [] + notifierHosts <- newMVar [] + + let itemIsRegistered item items = + isJust $ find (== item) items + + 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 + remapErrorName = + left $ (`makeErrorReply` "Failed to verify ownership.") . + M.methodErrorName + busName <- ExceptT $ return $ maybeToEither parseServiceError maybeBusName + let item = ItemEntry { serviceName = busName + , servicePath = path + } + hasOwner <- ExceptT $ remapErrorName <$> DBusTH.nameHasOwner client (coerce busName) + lift $ modifyMVar_ notifierItems $ \currentItems -> + if itemIsRegistered item currentItems + then + return currentItems + else + do + emitStatusNotifierItemRegistered client $ coerce busName + return $ item : currentItems + + registerStatusNotifierHost name = + let item = ItemEntry { serviceName = busName_ name + , servicePath = "/StatusNotifierHost" + } in + modifyMVar_ notifierHosts $ \currentHosts -> + if itemIsRegistered item currentHosts + then + return currentHosts + else + do + emitStatusNotifierHostRegistered client + return $ item : currentHosts + + registeredStatusNotifierItems :: IO [String] + registeredStatusNotifierItems = + map (coerce . serviceName) <$> readMVar notifierItems + + registeredSNIEntries :: IO [(String, String)] + registeredSNIEntries = + map getTuple <$> readMVar notifierItems + where getTuple (ItemEntry bname path) = (coerce bname, coerce path) + + objectPathForItem :: String -> IO (Either Reply String) + objectPathForItem name = + maybeToEither notFoundError . fmap (coerce . servicePath) . + find ((== busName_ name) . serviceName) <$> + readMVar notifierItems + where notFoundError = + makeErrorReply errorInvalidParameters $ + printf "Service %s is not registered." name + + isStatusNotifierHostRegistered = not . null <$> readMVar notifierHosts + + protocolVersion = return 1 :: IO Int32 + + 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 + log $ printf "Unregistering item %s because it disappeared." name + emitStatusNotifierItemUnregistered client name + removedHosts <- filterDeadService name notifierHosts + unless (null removedHosts) $ + log $ printf "Unregistering host %s because it disappeared." name + return () + + 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 + ] + + watcherInterface = + 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 + export client (fromString path) watcherInterface + _ -> stopWatcher + return nameRequestResult + + return (watcherInterface, 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 = buildIntrospectionInterface clientInterface + where (clientInterface, _) = unsafePerformIO $ buildWatcher + defaultWatcherParams { watcherDBusClient = Just undefined } diff --git a/src/StatusNotifier/Watcher/Signals.hs b/src/StatusNotifier/Watcher/Signals.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Watcher/Signals.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE TemplateHaskell #-} +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 + +printWatcherSignals = + runQ (generateSignals watcherClientGenerationParams { genBusName = Nothing } + defaultWatcherInterfaceName watcherSignals) >>= + putStrLn . pprint diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal new file mode 100644 --- /dev/null +++ b/status-notifier-item.cabal @@ -0,0 +1,87 @@ +-- This file has been generated from package.yaml by hpack version 0.27.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 5031b8852f36b00720f0e3a9da94253f14e1732c28f671b766c2a75be1926610 + +name: status-notifier-item +version: 0.1.0.0 +synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification +description: Please see the README on Github at +category: Desktop +homepage: https://github.com/IvanMalison/status-notifier-item#readme +bug-reports: https://github.com/IvanMalison/status-notifier-item/issues +author: Ivan Malison +maintainer: IvanMalison@gmail.com +copyright: 2018 Ivan Malison +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 + +extra-source-files: + ChangeLog.md + README.md + xml/StatusNotifierItem.xml + +source-repository head + type: git + location: https://github.com/IvanMalison/status-notifier-item + +library + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , bytestring + , containers + , dbus >=1.0.0 && <2.0.0 + , filepath + , hslogger + , lens + , mtl + , network + , spool >=0.1 && <1.0 + , template-haskell + , transformers + , vector + exposed-modules: + StatusNotifier.Host.Service + StatusNotifier.Item.Client + StatusNotifier.Item.Constants + StatusNotifier.TH + StatusNotifier.Util + StatusNotifier.Watcher.Client + StatusNotifier.Watcher.Constants + StatusNotifier.Watcher.Service + StatusNotifier.Watcher.Signals + other-modules: + Paths_status_notifier_item + default-language: Haskell2010 + +executable sni-cl-tool + main-is: Main.hs + hs-source-dirs: + ./tool + build-depends: + base >=4.7 && <5 + , dbus >1.0 + , optparse-applicative + , status-notifier-item + other-modules: + Paths_status_notifier_item + default-language: Haskell2010 + +executable status-notifier-watcher + main-is: Main.hs + hs-source-dirs: + ./watcher + build-depends: + base >=4.7 && <5 + , dbus >=1.0.0 && <2.0.0 + , hslogger + , optparse-applicative + , status-notifier-item + other-modules: + Paths_status_notifier_item + default-language: Haskell2010 diff --git a/tool/Main.hs b/tool/Main.hs new file mode 100644 --- /dev/null +++ b/tool/Main.hs @@ -0,0 +1,13 @@ +module Main where + +import StatusNotifier.Watcher.Client +import DBus.Client +import Data.String + +main = do + client <- connectSession + registeredItems <- + getRegisteredSNIEntries + client + print registeredItems + return () diff --git a/watcher/Main.hs b/watcher/Main.hs new file mode 100644 --- /dev/null +++ b/watcher/Main.hs @@ -0,0 +1,39 @@ +module Main where + +import Control.Concurrent.MVar +import Data.Semigroup ((<>)) +import Options.Applicative +import StatusNotifier.Watcher.Constants +import StatusNotifier.Watcher.Service +import System.Log.Logger + +setWatcherParams namespace path = + defaultWatcherParams + { watcherNamespace = namespace + , watcherPath = path + } + +watcherParamsParser :: Parser WatcherParams +watcherParamsParser = setWatcherParams + <$> 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." ) + +main = do + watcherParams <- execParser $ + info (watcherParamsParser <**> helper) + ( fullDesc + <> progDesc "Run a StatusNotifierWatcher") + stop <- newEmptyMVar + (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () } + startWatcher + takeMVar stop diff --git a/xml/StatusNotifierItem.xml b/xml/StatusNotifierItem.xml new file mode 100644 --- /dev/null +++ b/xml/StatusNotifierItem.xml @@ -0,0 +1,68 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +