diff --git a/item/Main.hs b/item/Main.hs new file mode 100644 --- /dev/null +++ b/item/Main.hs @@ -0,0 +1,48 @@ +module Main where + +import Control.Concurrent.MVar +import Control.Monad +import Data.Semigroup ((<>)) +import Data.Version (showVersion) +import Options.Applicative +import Paths_status_notifier_item (version) +import StatusNotifier.Item.Service +import Text.Printf + +itemsParamsParser = ItemParams + <$> strOption + ( long "icon-name" + <> short 'n' + <> metavar "NAME" + <> value "emacs" + <> help "The icon the item will display." + ) <*> strOption + ( long "overlay-name" + <> short 'o' + <> metavar "NAME" + <> value "steam" + <> help "The icon that will be used for the overlay." + ) <*> strOption + ( long "dbus-name" + <> short 'd' + <> metavar "NAME" + <> value "org.SampleSNI" + <> help "The dbus name used for this sample item." + ) + +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 + diff --git a/src/StatusNotifier/Host/Service.hs b/src/StatusNotifier/Host/Service.hs --- a/src/StatusNotifier/Host/Service.hs +++ b/src/StatusNotifier/Host/Service.hs @@ -4,13 +4,16 @@ 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.Except +import Control.Monad.Trans.Class +import Control.Monad.Trans.Except +import Control.Monad.Trans.Maybe import DBus import DBus.Client import DBus.Generation @@ -48,9 +51,10 @@ = ItemAdded | ItemRemoved | IconUpdated - | IconNameUpdated + | OverlayIconUpdated + | StatusUpdated | TitleUpdated - | TooltipUpdated deriving (Eq, Show) + | ToolTipUpdated deriving (Eq, Show) type UpdateHandler = UpdateType -> ItemInfo -> IO () @@ -59,6 +63,7 @@ , uniqueIdentifier :: String , namespace :: String , startWatcher :: Bool + , matchSenderWhenNameOwnersUnmatched :: Bool } hostLogger = logM "StatusNotifier.Host.Service" @@ -68,15 +73,24 @@ , 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 :: [(Int32, Int32, BS.ByteString)] + , iconPixmaps :: ImageInfo + , overlayIconPixmaps :: ImageInfo , menuPath :: Maybe ObjectPath } deriving (Eq, Show) @@ -105,6 +119,7 @@ , namespace = namespaceString , uniqueIdentifier = uniqueID , startWatcher = shouldStartWatcher + , matchSenderWhenNameOwnersUnmatched = doMatchUnmatchedSender } = do client <- maybe connectSession return mclient itemInfoMapVar <- newMVar Map.empty @@ -113,6 +128,7 @@ logError = hostLogger ERROR logErrorWithMessage message error = logError message >> logError (show error) + logInfo = hostLogger INFO logErrorAndThen andThen e = logError (show e) >> andThen @@ -136,30 +152,43 @@ removeHandler unique = modifyMVar_ updateHandlersVar (return . filter ((/= unique) . fst)) - getPixmaps a1 a2 a3 = fmap convertPixmapsToHostByteOrder <$> - I.getIconPixmap a1 a2 a3 + 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 - 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 + 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 @@ -190,12 +219,12 @@ handleItemRemoved serviceName = modifyMVar itemInfoMapVar doRemove >>= - maybe logNonExistantRemoval (doUpdate ItemRemoved) + maybe logNonExistentRemoval (doUpdate ItemRemoved) where busName = busName_ serviceName doRemove currentMap = return (Map.delete busName currentMap, Map.lookup busName currentMap) - logNonExistantRemoval = + logNonExistentRemoval = hostLogger WARNING $ printf "Attempt to remove unknown item %s" $ show busName @@ -208,8 +237,6 @@ logInfo (show s) >> fn sender getSender _ s = logError $ "Received signal with no sender: " ++ show s - logPropError = logErrorWithMessage "Error updating property: " - runProperty prop serviceName = getObjectPathForItemName serviceName >>= prop client serviceName @@ -218,67 +245,117 @@ printf "Got signal for update type: %s from unknown sender: %s" (show updateType) (show signal) - logErrorsUpdater lens updateType prop signal = - makeUpdaterFromProp lens updateType prop signal >>= - either logPropError ((flip when logSenderErrorAndUpdateAll) . isNothing) - where - logSenderErrorAndUpdateAll = do - logUnknownSender updateType signal - void $ updatePropertyForAllItemInfos lens updateType prop + 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 - makeUpdaterFromProp lens updateType prop - signal@M.Signal { M.signalSender = Just sender} = - runExceptT $ - ExceptT (runProperty prop sender) >>= - lift . runUpdateOfProperty lens updateType sender - makeUpdaterFromProp _ _ _ _ = return $ Right 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 - runUpdateOfProperty lens updateType serviceName newValue = do - maybeServiceInfo <- modifyMVar itemInfoMapVar modify - whenJust maybeServiceInfo (doUpdate updateType) - return maybeServiceInfo - where - modify infoMap = - let newMap = set (at serviceName . _Just . lens) newValue infoMap - in return (newMap, Map.lookup serviceName newMap) + logErrorsHandler lens updateType prop = + runUpdaters [updateItemByLensAndProp lens prop] updateType - updatePropertyForAllItemInfos lens updateType prop = do - readMVar itemInfoMapVar >>= mapM (runUpdateForService . itemServiceName) - where runUpdateForService serviceName = - runProperty prop serviceName >>= - either (const $ return ()) - (void . runUpdateOfProperty lens updateType serviceName) + -- 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 - updateAllIcons = - updatePropertyForAllItemInfos iconPixmapsL IconUpdated getPixmaps >> - updatePropertyForAllItemInfos iconNameL IconNameUpdated I.getIconName + 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 - handleNewPixmaps = - makeUpdaterFromProp iconPixmapsL IconUpdated getPixmaps - handleNewIconName = - makeUpdaterFromProp iconNameL IconNameUpdated I.getIconName + 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 - newNameResult <- handleNewIconName signal - newPixmapsResult <- handleNewPixmaps signal - let remPD = right (fmap supressPixelData) - result = (remPD newNameResult, remPD newPixmapsResult) - debugLog = hostLogger DEBUG $ printf "Icon update results %s" (show result) - updateAll = logUnknownSender IconUpdated signal >> void updateAllIcons - gotProp = rights [newNameResult, newPixmapsResult] - fullSuccess = catMaybes gotProp - if null fullSuccess - then if null gotProp - then hostLogger WARNING $ printf - "Failed to load new icon with either method %s" - (show result) - else updateAll - else debugLog + -- 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 = - logErrorsUpdater iconTitleL TitleUpdated I.getTitle + 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 diff --git a/src/StatusNotifier/Item/Service.hs b/src/StatusNotifier/Item/Service.hs new file mode 100644 --- /dev/null +++ b/src/StatusNotifier/Item/Service.hs @@ -0,0 +1,41 @@ +{-# 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 diff --git a/src/StatusNotifier/Util.hs b/src/StatusNotifier/Util.hs --- a/src/StatusNotifier/Util.hs +++ b/src/StatusNotifier/Util.hs @@ -70,10 +70,14 @@ makeErrorReply e message = ReplyError e [T.toVariant message] logErrorWithDefault :: - Show a => Logger -> b -> String -> Either a b -> IO b + Show a => (Priority -> String -> IO ()) -> b -> String -> Either a b -> IO b logErrorWithDefault logger def message = - either (\err -> logL logger ERROR (message ++ show err) >> return def) return + 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 = @@ -119,3 +123,7 @@ -> IO (Either M.MethodError (Maybe I.Object)) getInterfaceAt client bus path = right (I.parseXML "/") <$> 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) diff --git a/src/StatusNotifier/Watcher/Service.hs b/src/StatusNotifier/Watcher/Service.hs --- a/src/StatusNotifier/Watcher/Service.hs +++ b/src/StatusNotifier/Watcher/Service.hs @@ -4,7 +4,7 @@ import Control.Arrow import Control.Concurrent.MVar import Control.Monad -import Control.Monad.Trans +import Control.Monad.Trans.Class import Control.Monad.Trans.Except import DBus import DBus.Client diff --git a/status-notifier-item.cabal b/status-notifier-item.cabal --- a/status-notifier-item.cabal +++ b/status-notifier-item.cabal @@ -1,11 +1,11 @@ --- This file has been generated from package.yaml by hpack version 0.21.2. +-- This file has been generated from package.yaml by hpack version 0.28.2. -- -- see: https://github.com/sol/hpack -- --- hash: 0c0d886a82dbaa1abe2f1122ced43a208b5f1e3444653dbbe36e8f2fc564a729 +-- hash: 692373b1ddc9b82457b214c2eb42f50e70a132306fd54dc142eb6150b72e1a63 name: status-notifier-item -version: 0.2.2.1 +version: 0.3.0.0 synopsis: A wrapper over the StatusNotifierItem/libappindicator dbus specification description: Please see the README on Github at category: Desktop @@ -18,7 +18,6 @@ license-file: LICENSE build-type: Simple cabal-version: >= 1.10 - extra-source-files: ChangeLog.md README.md @@ -32,6 +31,7 @@ exposed-modules: StatusNotifier.Host.Service StatusNotifier.Item.Client + StatusNotifier.Item.Service StatusNotifier.TH StatusNotifier.Util StatusNotifier.Watcher.Client @@ -50,7 +50,6 @@ , filepath , hslogger , lens - , mtl , network , spool >=0.1 && <1.0 , template-haskell @@ -67,6 +66,18 @@ 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 diff --git a/watcher/Main.hs b/watcher/Main.hs --- a/watcher/Main.hs +++ b/watcher/Main.hs @@ -61,7 +61,8 @@ watcherParams <- join $ execParser $ info (helper <*> versionOption <*> watcherParamsParser) ( fullDesc - <> progDesc "Run a StatusNotifierWatcher") + <> progDesc "Run a StatusNotifierWatcher" + ) stop <- newEmptyMVar (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () } _ <- startWatcher diff --git a/xml/StatusNotifierItem.xml b/xml/StatusNotifierItem.xml --- a/xml/StatusNotifierItem.xml +++ b/xml/StatusNotifierItem.xml @@ -30,7 +30,6 @@ - @@ -44,18 +43,13 @@ - - - - + - - - +