status-notifier-item (empty) → 0.1.0.0
raw patch · 17 files changed
+911/−0 lines, 17 filesdep +basedep +bytestringdep +containerssetup-changed
Dependencies added: base, bytestring, containers, dbus, filepath, hslogger, lens, mtl, network, optparse-applicative, spool, status-notifier-item, template-haskell, transformers, vector
Files
- ChangeLog.md +3/−0
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- src/StatusNotifier/Host/Service.hs +246/−0
- src/StatusNotifier/Item/Client.hs +17/−0
- src/StatusNotifier/Item/Constants.hs +26/−0
- src/StatusNotifier/TH.hs +10/−0
- src/StatusNotifier/Util.hs +101/−0
- src/StatusNotifier/Watcher/Client.hs +14/−0
- src/StatusNotifier/Watcher/Constants.hs +69/−0
- src/StatusNotifier/Watcher/Service.hs +168/−0
- src/StatusNotifier/Watcher/Signals.hs +17/−0
- status-notifier-item.cabal +87/−0
- tool/Main.hs +13/−0
- watcher/Main.hs +39/−0
- xml/StatusNotifierItem.xml +68/−0
+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for status-notifier-item++## Unreleased changes
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# status-notifier-item
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/StatusNotifier/Host/Service.hs view
@@ -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
+ src/StatusNotifier/Item/Client.hs view
@@ -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
+ src/StatusNotifier/Item/Constants.hs view
@@ -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 }
+ src/StatusNotifier/TH.hs view
@@ -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
+ src/StatusNotifier/Util.hs view
@@ -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
+ src/StatusNotifier/Watcher/Client.hs view
@@ -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
+ src/StatusNotifier/Watcher/Constants.hs view
@@ -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+ }
+ src/StatusNotifier/Watcher/Service.hs view
@@ -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 }
+ src/StatusNotifier/Watcher/Signals.hs view
@@ -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
+ status-notifier-item.cabal view
@@ -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 <https://github.com/IvanMalison/status-notifier-item#readme>+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
+ tool/Main.hs view
@@ -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 ()
+ watcher/Main.hs view
@@ -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
+ xml/StatusNotifierItem.xml view
@@ -0,0 +1,68 @@+<node name="/StatusNotifierItem">+ <interface name="org.kde.StatusNotifierItem">+ <property name="Category" type="s" access="read"/>+ <property name="Id" type="s" access="read"/>+ <property name="Title" type="s" access="read"/>+ <property name="Status" type="s" access="read"/>+ <property name="WindowId" type="i" access="read"/>+ <property name="Menu" type="o" access="read" />++ <!-- main icon -->+ <!-- names are preferred over pixmaps -->+ <property name="IconName" type="s" access="read" />+ <property name="IconThemePath" type="s" access="read" />++ <!-- struct containing width, height and image data-->+ <!-- implementation has been dropped as of now -->+ <property name="IconPixmap" type="a(iiay)" access="read" />++ <!-- not used in ayatana code, no test case so far -->+ <property name="OverlayIconName" type="s" access="read"/>+ <property name="OverlayIconPixmap" type="a(iiay)" access="read" />++ <!-- Requesting attention icon -->+ <property name="AttentionIconName" type="s" access="read"/>++ <!--same definition as image-->+ <property name="AttentionIconPixmap" type="a(iiay)" access="read" />++ <!-- tooltip data -->+ <!--(iiay) is an image-->+ <property name="ToolTip" type="(sa(iiay)ss)" access="read" />++ <!-- interaction: actually, we do not use them. -->+ <method name="Activate">+ <arg name="x" type="i" direction="in"/>+ <arg name="y" type="i" direction="in"/>+ </method>+ <method name="SecondaryActivate">+ <arg name="x" type="i" direction="in"/>+ <arg name="y" type="i" direction="in"/>+ </method>+ <method name="Scroll">+ <arg name="delta" type="i" direction="in"/>+ <arg name="dir" type="s" direction="in"/>+ </method>++ <!-- Signals: the client wants to change something in the status-->+ <signal name="NewTitle"></signal>+ <signal name="NewIcon"></signal>+ <signal name="NewIconThemePath">+ <arg type="s" name="icon_theme_path" direction="out" />+ </signal>+ <signal name="NewAttentionIcon"></signal>+ <signal name="NewOverlayIcon"></signal>+ <signal name="NewToolTip"></signal>+ <signal name="NewStatus">+ <arg name="status" type="s" />+ </signal>++ <!-- ayatana labels -->+ <signal name="XAyatanaNewLabel">+ <arg type="s" name="label" direction="out" />+ <arg type="s" name="guide" direction="out" />+ </signal>+ <property name="XAyatanaLabel" type="s" access="read" />+ <property name="XAyatanaLabelGuide" type="s" access="read" />+ </interface>+</node>