status-notifier-item-0.3.0.4/0000755000000000000000000000000007346545000014141 5ustar0000000000000000status-notifier-item-0.3.0.4/ChangeLog.md0000755000000000000000000000007407346545000016316 0ustar0000000000000000# Changelog for status-notifier-item ## Unreleased changes status-notifier-item-0.3.0.4/LICENSE0000644000000000000000000000276107346545000015154 0ustar0000000000000000Copyright 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. status-notifier-item-0.3.0.4/README.md0000755000000000000000000000024607346545000015425 0ustar0000000000000000# status-notifier-item [![Build Status](https://travis-ci.org/taffybar/status-notifier-item.svg?branch=master)](https://travis-ci.org/taffybar/status-notifier-item) status-notifier-item-0.3.0.4/Setup.hs0000644000000000000000000000005607346545000015576 0ustar0000000000000000import Distribution.Simple main = defaultMain status-notifier-item-0.3.0.4/item/0000755000000000000000000000000007346545000015077 5ustar0000000000000000status-notifier-item-0.3.0.4/item/Main.hs0000644000000000000000000000234007346545000016316 0ustar0000000000000000module 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." ) versionOption :: Parser (a -> a) 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 status-notifier-item-0.3.0.4/src/StatusNotifier/Host/0000755000000000000000000000000007346545000020630 5ustar0000000000000000status-notifier-item-0.3.0.4/src/StatusNotifier/Host/Service.hs0000644000000000000000000004036007346545000022567 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RecordWildCards #-} module StatusNotifier.Host.Service where 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 import Control.Monad.Trans.Maybe import DBus import DBus.Client import DBus.Generation import qualified DBus.Internal.Message as M import DBus.Internal.Types import qualified DBus.TH as DTH import qualified Data.ByteString as BS import Data.Coerce import Data.Either import Data.Int import qualified Data.Map.Strict as Map import Data.Maybe import Data.String import Data.Typeable import Data.Unique import Data.Word import System.Log.Logger import Text.Printf import qualified StatusNotifier.Item.Client as I import StatusNotifier.Util import qualified StatusNotifier.Watcher.Client as W import qualified StatusNotifier.Watcher.Constants as W import qualified StatusNotifier.Watcher.Signals as W import qualified StatusNotifier.Watcher.Service as W statusNotifierHostString :: String statusNotifierHostString = "StatusNotifierHost" getBusName :: String -> String -> String getBusName namespace = printf "%s.%s-%s" namespace statusNotifierHostString data UpdateType = ItemAdded | ItemRemoved | IconUpdated | OverlayIconUpdated | StatusUpdated | TitleUpdated | ToolTipUpdated deriving (Eq, Show) type UpdateHandler = UpdateType -> ItemInfo -> IO () data Params = Params { dbusClient :: Maybe Client , uniqueIdentifier :: String , namespace :: String , startWatcher :: Bool , matchSenderWhenNameOwnersUnmatched :: Bool } hostLogger = logM "StatusNotifier.Host.Service" defaultParams = Params { dbusClient = Nothing , uniqueIdentifier = "" , namespace = "org.kde" , startWatcher = False , matchSenderWhenNameOwnersUnmatched = True } type ImageInfo = [(Int32, Int32, BS.ByteString)] data ItemInfo = ItemInfo { itemServiceName :: BusName , itemServicePath :: ObjectPath , itemId :: Maybe String , itemStatus :: Maybe String , itemCategory :: Maybe String , itemToolTip :: Maybe (String, ImageInfo, String, String) , iconTitle :: String , iconName :: String , overlayIconName :: Maybe String , iconThemePath :: Maybe String , iconPixmaps :: ImageInfo , overlayIconPixmaps :: ImageInfo , menuPath :: Maybe ObjectPath } deriving (Eq, Show) supressPixelData info = info { iconPixmaps = map (\(w, h, _) -> (w, h, "")) $ iconPixmaps info } 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 data Host = Host { itemInfoMap :: IO (Map.Map BusName ItemInfo) , addUpdateHandler :: UpdateHandler -> IO Unique , removeUpdateHandler :: Unique -> IO () , forceUpdate :: BusName -> IO () } deriving Typeable build :: Params -> IO (Maybe Host) build Params { dbusClient = mclient , namespace = namespaceString , uniqueIdentifier = uniqueID , startWatcher = shouldStartWatcher , matchSenderWhenNameOwnersUnmatched = doMatchUnmatchedSender } = do client <- maybe connectSession return mclient itemInfoMapVar <- newMVar Map.empty updateHandlersVar <- newMVar ([] :: [(Unique, UpdateHandler)]) let busName = getBusName namespaceString uniqueID logError = hostLogger ERROR logErrorWithMessage message error = logError message >> logError (show error) logInfo = hostLogger INFO logErrorAndThen andThen e = logError (show e) >> andThen doUpdateForHandler utype uinfo (unique, handler) = do logInfo (printf "Sending update (iconPixmaps suppressed): %s %s, for handler %s" (show utype) (show $ supressPixelData uinfo) (show $ hashUnique unique)) forkIO $ handler utype uinfo doUpdate utype uinfo = readMVar updateHandlersVar >>= mapM_ (doUpdateForHandler utype uinfo) addHandler handler = do unique <- newUnique modifyMVar_ updateHandlersVar (return . ((unique, handler):)) let doUpdateForInfo info = doUpdateForHandler ItemAdded info (unique, handler) readMVar itemInfoMapVar >>= mapM_ doUpdateForInfo return unique removeHandler unique = modifyMVar_ updateHandlersVar (return . filter ((/= unique) . fst)) getPixmaps getter a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$> getter a1 a2 a3 getMaybe fn a b c = right Just <$> fn a b c buildItemInfo name = runExceptT $ do pathString <- ExceptT $ W.getObjectPathForItemName client name let busName = fromString name path = objectPath_ pathString doGetDef def fn = ExceptT $ exemptAll def <$> fn client busName path doGet fn = ExceptT $ fn client busName path pixmaps <- doGetDef [] $ getPixmaps I.getIconPixmap iName <- doGetDef name I.getIconName overlayPixmap <- doGetDef [] $ getPixmaps I.getOverlayIconPixmap overlayIName <- doGetDef Nothing $ getMaybe I.getOverlayIconName themePath <- doGetDef Nothing $ getMaybe I.getIconThemePath menu <- doGetDef Nothing $ getMaybe I.getMenu title <- doGetDef "" I.getTitle tooltip <- doGetDef Nothing $ getMaybe I.getToolTip idString <- doGetDef Nothing $ getMaybe I.getId status <- doGetDef Nothing $ getMaybe I.getStatus category <- doGetDef Nothing $ getMaybe I.getCategory return ItemInfo { itemServiceName = busName_ name , itemId = idString , itemStatus = status , itemCategory = category , itemServicePath = path , itemToolTip = tooltip , iconPixmaps = pixmaps , iconThemePath = themePath , iconName = iName , iconTitle = title , menuPath = menu , overlayIconName = overlayIName , overlayIconPixmaps = overlayPixmap } 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 = hostLogger 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@ItemInfo{..} = if Map.member itemServiceName map then return map else doUpdate ItemAdded itemInfo >> return (Map.insert itemServiceName itemInfo map) getObjectPathForItemName name = maybe I.defaultPath itemServicePath . Map.lookup name <$> readMVar itemInfoMapVar handleItemRemoved serviceName = modifyMVar itemInfoMapVar doRemove >>= maybe logNonExistentRemoval (doUpdate ItemRemoved) where busName = busName_ serviceName doRemove currentMap = return (Map.delete busName currentMap, Map.lookup busName currentMap) logNonExistentRemoval = hostLogger WARNING $ printf "Attempt to remove unknown item %s" $ show busName watcherRegistrationPairs = [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded) , (W.registerForStatusNotifierItemUnregistered, const 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 runProperty prop serviceName = getObjectPathForItemName serviceName >>= prop client serviceName logUnknownSender updateType signal = hostLogger WARNING $ printf "Got signal for update type: %s from unknown sender: %s" (show updateType) (show signal) identifySender M.Signal { M.signalSender = Just sender , M.signalPath = senderPath } = do infoMap <- readMVar itemInfoMapVar let identifySenderBySender = return (Map.lookup sender infoMap) identifySenderById = fmap join $ identifySenderById_ >>= logEitherError hostLogger "Failed to identify sender" identifySenderById_ = runExceptT $ do senderId <- ExceptT $ I.getId client sender senderPath let matchesSender info = if itemId info == Just senderId then do senderNameOwner <- DTH.getNameOwner client (coerce sender) infoNameOwner <- DTH.getNameOwner client (coerce $ itemServiceName info) let warningMsg = "Matched sender id: %s, but name owners do not \ \ match: %s %s. Considered match: %s." warningText = printf warningMsg (show senderId) (show senderNameOwner) (show infoNameOwner) when (senderNameOwner /= infoNameOwner) $ hostLogger WARNING warningText return doMatchUnmatchedSender else return False lift $ findM matchesSender (Map.elems infoMap) identifySenderBySender <||> identifySenderById where a <||> b = runMaybeT $ MaybeT a <|> MaybeT b identifySender _ = return Nothing updateItemByLensAndProp lens prop busName = runExceptT $ do newValue <- ExceptT (runProperty prop busName) let modify infoMap = -- This noops when the value is not present let newMap = set (at busName . _Just . lens) newValue infoMap in return (newMap, Map.lookup busName newMap) ExceptT $ maybeToEither (methodError (Serial 0) errorFailed) <$> modifyMVar itemInfoMapVar modify logErrorsHandler lens updateType prop = runUpdaters [updateItemByLensAndProp lens prop] updateType -- Run all the provided updaters with the expectation that at least one -- will succeed. runUpdatersForService updaters updateType serviceName = do updateResults <- mapM ($ serviceName) updaters let (failures, updates) = partitionEithers updateResults logLevel = if null updates then ERROR else DEBUG mapM_ (doUpdate updateType) updates when (not $ null failures) $ hostLogger logLevel $ printf "Property update failures %s" $ show failures runUpdaters updaters updateType signal = identifySender signal >>= maybe runForAll (runUpdateForService . itemServiceName) where runUpdateForService = runUpdatersForService updaters updateType runForAll = logUnknownSender updateType signal >> readMVar itemInfoMapVar >>= mapM_ runUpdateForService . Map.keys updateIconPixmaps = updateItemByLensAndProp iconPixmapsL $ getPixmaps I.getIconPixmap updateIconName = updateItemByLensAndProp iconNameL I.getIconName updateIconTheme = updateItemByLensAndProp iconThemePathL getThemePathDefault updateFromIconThemeFromSignal signal = identifySender signal >>= traverse (updateIconTheme . itemServiceName) handleNewIcon signal = 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 runUpdaters [updateIconPixmaps, updateIconName] IconUpdated signal updateOverlayIconName = updateItemByLensAndProp overlayIconNameL $ getMaybe I.getOverlayIconName updateOverlayIconPixmaps = updateItemByLensAndProp overlayIconPixmapsL $ getPixmaps I.getOverlayIconPixmap handleNewOverlayIcon signal = do updateFromIconThemeFromSignal signal runUpdaters [updateOverlayIconPixmaps, updateOverlayIconName] OverlayIconUpdated signal getThemePathDefault client busName objectPath = right Just <$> I.getIconThemePath client busName objectPath handleNewTitle = logErrorsHandler iconTitleL TitleUpdated I.getTitle handleNewTooltip = logErrorsHandler itemToolTipL ToolTipUpdated $ getMaybe I.getToolTip handleNewStatus = logErrorsHandler itemStatusL StatusUpdated $ getMaybe I.getStatus clientRegistrationPairs = [ (I.registerForNewIcon, handleNewIcon) , (I.registerForNewIconThemePath, handleNewIcon) , (I.registerForNewOverlayIcon, handleNewOverlayIcon) , (I.registerForNewTitle, handleNewTitle) , (I.registerForNewToolTip, handleNewTooltip) , (I.registerForNewStatus, handleNewStatus) ] 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, False) finishInitialization serviceNames = do itemInfos <- createAll serviceNames let newMap = Map.fromList $ map (itemServiceName &&& id) itemInfos resultMap = Map.union itemInfoMap newMap W.registerStatusNotifierHost client busName >>= either logErrorAndShutdown (const $ return (resultMap, True)) W.getRegisteredStatusNotifierItems client >>= either logErrorAndShutdown finishInitialization startWatcherIfNeeded = do let watcherName = maybe "" coerce $ genBusName W.watcherClientGenerationParams startWatcher = do (_, doIt) <- W.buildWatcher W.defaultWatcherParams doIt res <- DTH.getNameOwner client watcherName case res of Right _ -> return () Left _ -> void $ forkIO $ void startWatcher when shouldStartWatcher startWatcherIfNeeded nameRequestResult <- requestName client (fromString busName) [] if nameRequestResult == NamePrimaryOwner then do initializationSuccess <- initializeItemInfoMap return $ if initializationSuccess then Just Host { itemInfoMap = readMVar itemInfoMapVar , addUpdateHandler = addHandler , removeUpdateHandler = removeHandler , forceUpdate = handleItemAdded . coerce } else Nothing else do logErrorWithMessage "Failed to obtain desired service name" nameRequestResult return Nothing status-notifier-item-0.3.0.4/src/StatusNotifier/Item/0000755000000000000000000000000007346545000020611 5ustar0000000000000000status-notifier-item-0.3.0.4/src/StatusNotifier/Item/Client.hs0000644000000000000000000000063007346545000022362 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module StatusNotifier.Item.Client where import DBus.Generation import DBus.Internal.Types import StatusNotifier.Util import System.FilePath generateClientFromFile defaultGenerationParams { genTakeSignalErrorHandler = True } False ("xml" "StatusNotifierItem.xml") defaultPath :: ObjectPath defaultPath = "/StatusNotifierItem" status-notifier-item-0.3.0.4/src/StatusNotifier/Item/Service.hs0000644000000000000000000000267607346545000022560 0ustar0000000000000000{-# 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 qualified Data.ByteString as BS 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) 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 status-notifier-item-0.3.0.4/src/StatusNotifier/0000755000000000000000000000000007346545000017713 5ustar0000000000000000status-notifier-item-0.3.0.4/src/StatusNotifier/TH.hs0000644000000000000000000000043207346545000020561 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module StatusNotifier.TH where import DBus.Client import DBus.Generation -- XXX: Move this to haskell-dbus generateClient defaultGenerationParams $ buildIntrospectionInterface $ buildIntrospectableInterface undefined status-notifier-item-0.3.0.4/src/StatusNotifier/Util.hs0000644000000000000000000001020707346545000021164 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module StatusNotifier.Util where 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 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 Network.Socket (ntohl) import StatusNotifier.TH import qualified Data.Text.IO as TIO import Data.Text (pack) import System.Log.Logger getIntrospectionObjectFromFile :: FilePath -> T.ObjectPath -> Q I.Object getIntrospectionObjectFromFile filepath nodePath = runIO $ head . maybeToList . I.parseXML nodePath <$> TIO.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 -> [TopName (mkName $ nameBase name ++ "L")] whenJust :: Monad m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe $ return () convertARGBToABGR :: Word32 -> Word32 convertARGBToABGR bits = (blue `shift` 16) .|. (red `shift` (-16)) .|. green .|. alpha where blue = bits .&. 0xFF green = bits .&. 0xFF00 red = bits .&. 0xFF0000 alpha = bits .&. 0xFF000000 networkToSystemByteOrder :: BS.ByteString -> BS.ByteString networkToSystemByteOrder original = vectorToByteString $ VS.map (convertARGBToABGR . 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] logErrorWithDefault :: 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 logger message = either (\err -> logger ERROR (message ++ show err) >> return Nothing) (return . Just) 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 -> 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) status-notifier-item-0.3.0.4/src/StatusNotifier/Watcher/0000755000000000000000000000000007346545000021310 5ustar0000000000000000status-notifier-item-0.3.0.4/src/StatusNotifier/Watcher/Client.hs0000644000000000000000000000060707346545000023065 0ustar0000000000000000{-# 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 status-notifier-item-0.3.0.4/src/StatusNotifier/Watcher/Constants.hs0000644000000000000000000000424107346545000023621 0ustar0000000000000000{-# 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 , watcherStop :: IO () , watcherDBusClient :: Maybe Client } defaultWatcherParams :: WatcherParams defaultWatcherParams = WatcherParams { watcherNamespace = "org.kde" , 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 } status-notifier-item-0.3.0.4/src/StatusNotifier/Watcher/Service.hs0000644000000000000000000001572307346545000023254 0ustar0000000000000000{-# 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 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 qualified StatusNotifier.Item.Client as Item 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 , watcherStop = stopWatcher , watcherPath = path , watcherDBusClient = mclient } = do let watcherInterfaceName = getWatcherInterfaceName interfaceNamespace 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 = 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 Item.defaultPath $ 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 } status-notifier-item-0.3.0.4/src/StatusNotifier/Watcher/Signals.hs0000644000000000000000000000120007346545000023235 0ustar0000000000000000{-# 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-0.3.0.4/status-notifier-item.cabal0000644000000000000000000000502607346545000021224 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- -- hash: 344c16f1d7d5b92177917e03471f2ee3844623f1a4127becd92cbc23effc40a2 name: status-notifier-item version: 0.3.0.4 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 extra-source-files: README.md ChangeLog.md xml/StatusNotifierItem.xml source-repository head type: git location: https://github.com/IvanMalison/status-notifier-item library exposed-modules: StatusNotifier.Host.Service StatusNotifier.Item.Client StatusNotifier.Item.Service StatusNotifier.TH StatusNotifier.Util StatusNotifier.Watcher.Client StatusNotifier.Watcher.Constants StatusNotifier.Watcher.Service StatusNotifier.Watcher.Signals other-modules: Paths_status_notifier_item hs-source-dirs: src build-depends: base >=4.7 && <5 , bytestring , bytestring-to-vector , containers , dbus >=1.2.1 && <2.0.0 , filepath , hslogger , lens , network <3.0.0.0 , template-haskell , text , transformers , vector default-language: Haskell2010 executable sni-cl-tool main-is: Main.hs other-modules: Paths_status_notifier_item hs-source-dirs: ./tool build-depends: base >=4.7 && <5 , dbus >1.0 , optparse-applicative , status-notifier-item default-language: Haskell2010 executable status-notifier-item-static main-is: Main.hs other-modules: Paths_status_notifier_item hs-source-dirs: ./item build-depends: base >=4.7 && <5 , optparse-applicative , status-notifier-item default-language: Haskell2010 executable status-notifier-watcher main-is: Main.hs other-modules: Paths_status_notifier_item hs-source-dirs: ./watcher 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 default-language: Haskell2010 status-notifier-item-0.3.0.4/tool/0000755000000000000000000000000007346545000015116 5ustar0000000000000000status-notifier-item-0.3.0.4/tool/Main.hs0000644000000000000000000000034607346545000016341 0ustar0000000000000000module Main where import StatusNotifier.Watcher.Client import DBus.Client import Data.String main = do client <- connectSession registeredItems <- getRegisteredSNIEntries client print registeredItems return () status-notifier-item-0.3.0.4/watcher/0000755000000000000000000000000007346545000015576 5ustar0000000000000000status-notifier-item-0.3.0.4/watcher/Main.hs0000644000000000000000000000364507346545000017026 0ustar0000000000000000module 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 import Paths_status_notifier_item (version) 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 ( 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 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 <- join $ execParser $ info (helper <*> versionOption <*> watcherParamsParser) ( fullDesc <> progDesc "Run a StatusNotifierWatcher" ) stop <- newEmptyMVar (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () } _ <- startWatcher takeMVar stop status-notifier-item-0.3.0.4/xml/0000755000000000000000000000000007346545000014741 5ustar0000000000000000status-notifier-item-0.3.0.4/xml/StatusNotifierItem.xml0000755000000000000000000000444407346545000021276 0ustar0000000000000000