status-notifier-item 0.2.2.1 → 0.3.0.0

raw patch · 8 files changed

+259/−79 lines, 8 filesdep −mtlnew-component:exe:status-notifier-item-staticPVP ok

version bump matches the API change (PVP)

Dependencies removed: mtl

API changes (from Hackage documentation)

Files

• item/Main.hs +48/−0
• src/StatusNotifier/Host/Service.hs +139/−62
• src/StatusNotifier/Item/Service.hs +41/−0
• src/StatusNotifier/Util.hs +10/−2
• src/StatusNotifier/Watcher/Service.hs +1/−1
• status-notifier-item.cabal +16/−5
• watcher/Main.hs +2/−1
• xml/StatusNotifierItem.xml +2/−8

@@ -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+

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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 <https://github.com/IvanMalison/status-notifier-item#readme> 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

@@ -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

@@ -30,7 +30,6 @@     <!--(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"/>@@ -44,18 +43,13 @@       <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="NewIconThemePath"></signal>     <signal name="NewAttentionIcon"></signal>     <signal name="NewOverlayIcon"></signal>     <signal name="NewToolTip"></signal>-    <signal name="NewStatus">-      <arg name="status" type="s" />-    </signal>+    <signal name="NewStatus"></signal>      <!-- ayatana labels -->     <signal name="XAyatanaNewLabel">