status-notifier-item 0.2.1.0 → 0.2.2.0

raw patch · 9 files changed

+173/−148 lines, 9 filesdep +dbus-hsloggerPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: dbus-hslogger

API changes (from Hackage documentation)

Files

• src/StatusNotifier/Host/Service.hs +6/−6
• src/StatusNotifier/Item/Client.hs +11/−11
• src/StatusNotifier/Item/Constants.hs +0/−26
• src/StatusNotifier/Util.hs +23/−13
• src/StatusNotifier/Watcher/Constants.hs +0/−2
• src/StatusNotifier/Watcher/Service.hs +31/−17
• status-notifier-item.cabal +3/−3
• watcher/Main.hs +42/−13
• xml/StatusNotifierItem.xml +57/−57

@@ -31,7 +31,6 @@ import           Text.Printf  import qualified StatusNotifier.Item.Client as I-import qualified StatusNotifier.Item.Constants as I import           StatusNotifier.Util import qualified StatusNotifier.Watcher.Client as W import qualified StatusNotifier.Watcher.Constants as W@@ -106,6 +105,7 @@   { itemInfoMap :: IO (Map.Map BusName ItemInfo)   , addUpdateHandler :: UpdateHandler -> IO Unique   , removeUpdateHandler :: Unique -> IO ()+  , forceUpdate :: BusName -> IO ()   } deriving Typeable  build :: Params -> IO (Maybe Host)@@ -184,7 +184,7 @@               clientSignalRegister signalRegisterFn handler =                 signalRegisterFn client matchAny handler logUnableToCallSignal -      handleItemAdded _ serviceName =+      handleItemAdded serviceName =         modifyMVar_ itemInfoMapVar $ \itemInfoMap ->           buildItemInfo serviceName >>=                         either (logErrorAndThen $ return itemInfoMap)@@ -196,13 +196,13 @@         maybe I.defaultPath itemServicePath . Map.lookup name <$>         readMVar itemInfoMapVar -      handleItemRemoved _ serviceName = let busName = busName_ serviceName in+      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)+        [ (W.registerForStatusNotifierItemRegistered, const handleItemAdded)+        , (W.registerForStatusNotifierItemUnregistered, const handleItemRemoved)         ]        getSender fn s@M.Signal { M.signalSender = Just sender} =@@ -289,9 +289,9 @@       { itemInfoMap = readMVar itemInfoMapVar       , addUpdateHandler = addHandler       , removeUpdateHandler = removeHandler+      , forceUpdate = handleItemAdded . coerce       }     else Nothing   else do     logErrorWithMessage "Failed to obtain desired service name" nameRequestResult     return Nothing-

@@ -1,17 +1,17 @@ {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-} 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+import DBus.Internal.Types+import StatusNotifier.Util+import System.FilePath -printItemClient =-  runQ (generateClient C.generationParams C.introspectionInterface) >>=-       putStrLn . pprint+generateClientFromFile+  defaultGenerationParams+  { genTakeSignalErrorHandler = True }+  False+  ("xml" </> "StatusNotifierItem.xml") -printItemSignals =-  runQ (generateSignalsFromInterface C.generationParams C.introspectionInterface) >>=-       putStrLn . pprint+defaultPath :: ObjectPath+defaultPath = "/StatusNotifierItem"

@@ -1,26 +0,0 @@-{-# 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 }

@@ -7,26 +7,40 @@ import qualified DBus.Internal.Message as M import qualified DBus.Internal.Types as T import qualified DBus.Introspection as I+import qualified DBus.Generation as G import qualified Data.ByteString as BS+import           Data.Maybe 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+getIntrospectionObjectFromFile :: FilePath -> T.ObjectPath -> Q I.Object+getIntrospectionObjectFromFile filepath nodePath = runIO $+  head . maybeToList . I.parseXML nodePath <$> 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 ->@@ -45,15 +59,6 @@ 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 =-  unsafePerformIO $ getLogger name- logErrorWithDefault ::   Show a => Logger -> b -> String -> Either a b -> IO b logErrorWithDefault logger def message =@@ -97,5 +102,10 @@ (>>=/) :: 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 "/") <$> introspect client bus path

@@ -27,7 +27,6 @@ data WatcherParams = WatcherParams   { watcherNamespace :: String   , watcherPath :: String-  , watcherLogger :: Logger   , watcherStop :: IO ()   , watcherDBusClient :: Maybe Client   }@@ -36,7 +35,6 @@ defaultWatcherParams =   WatcherParams   { watcherNamespace = "org.kde"-  , watcherLogger = makeDefaultLogger "StatusNotifier.Watcher.Service"   , watcherStop = return ()   , watcherPath = "/StatusNotifierWatcher"   , watcherDBusClient = Nothing

@@ -20,6 +20,7 @@ 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@@ -29,14 +30,14 @@  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+      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 =@@ -50,13 +51,15 @@   let itemIsRegistered item items =         isJust $ find (== item) items -      registerStatusNotifierItem MethodCall { methodCallSender = sender } name = runExceptT $ do+      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+            path = fromMaybe Item.defaultPath $ T.parseObjectPath name             remapErrorName =               left $ (`makeErrorReply` "Failed to verify ownership.") .                    M.methodErrorName@@ -64,7 +67,8 @@         let item = ItemEntry { serviceName = busName                              , servicePath = path                              }-        hasOwner <- ExceptT $ remapErrorName <$> DBusTH.nameHasOwner client (coerce busName)+        hasOwner <- ExceptT $ remapErrorName <$>+                    DBusTH.nameHasOwner client (coerce busName)         lift $ modifyMVar_ notifierItems $ \currentItems ->           if itemIsRegistered item currentItems           then@@ -125,17 +129,25 @@           return ()        watcherMethods = map mkLogMethod-        [ autoMethodWithMsg "RegisterStatusNotifierItem" registerStatusNotifierItem-        , autoMethod "RegisterStatusNotifierHost" registerStatusNotifierHost-        , autoMethod "StopWatcher" stopWatcher-        , autoMethod "GetObjectPathForItemName" objectPathForItem+        [ 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+        [ mkLogProperty "RegisteredStatusNotifierItems"+          registeredStatusNotifierItems+        , mkLogProperty "RegisteredSNIEntries"+          registeredSNIEntries+        , mkLogProperty "IsStatusNotifierHostRegistered"+          isStatusNotifierHostRegistered+        , mkLogProperty "ProtocolVersion"+          protocolVersion         ]        watcherInterface =@@ -151,7 +163,8 @@         case nameRequestResult of           NamePrimaryOwner ->             do-              _ <- DBusTH.registerForNameOwnerChanged client matchAny handleNameOwnerChanged+              _ <- DBusTH.registerForNameOwnerChanged client+                   matchAny handleNameOwnerChanged               export client (fromString path) watcherInterface           _ -> stopWatcher         return nameRequestResult@@ -163,5 +176,6 @@ -- IO isn't needed to build watcher {-# NOINLINE watcherInterface #-} watcherInterface = buildIntrospectionInterface clientInterface-  where (clientInterface, _) = unsafePerformIO $ buildWatcher-                               defaultWatcherParams { watcherDBusClient = Just undefined }+  where (clientInterface, _) =+          unsafePerformIO $ buildWatcher+          defaultWatcherParams { watcherDBusClient = Just undefined }

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: feda98a88b3e5480785430699b26288a4655a16b299f61f763431c4193ea54b4+-- hash: fab14775734399bef953c7eccd528496b0abd4ae265b3f999bf78e2ee151b2b4  name:           status-notifier-item-version:        0.2.1.0+version:        0.2.2.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@@ -31,7 +31,6 @@   exposed-modules:       StatusNotifier.Host.Service       StatusNotifier.Item.Client-      StatusNotifier.Item.Constants       StatusNotifier.TH       StatusNotifier.Util       StatusNotifier.Watcher.Client@@ -80,6 +79,7 @@   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

@@ -1,39 +1,68 @@ module 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 -setWatcherParams namespace path =-  defaultWatcherParams-  { watcherNamespace = namespace-  , watcherPath = path-  }+import Paths_status_notifier_item (version) -watcherParamsParser :: Parser WatcherParams-watcherParamsParser = setWatcherParams+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+  <> 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." )+  <> 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 <- execParser $-                   info (watcherParamsParser <**> helper)+  watcherParams <- join $ execParser $+                   info (helper <*> versionOption <*> watcherParamsParser)                    (  fullDesc                    <> progDesc "Run a StatusNotifierWatcher")   stop <- newEmptyMVar   (_, startWatcher) <- buildWatcher watcherParams { watcherStop = putMVar stop () }-  startWatcher+  _ <- startWatcher   takeMVar stop

@@ -1,68 +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" />+  <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" />+    <!-- 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" />+    <!-- 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" />+    <!-- 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"/>+    <!-- Requesting attention icon -->+    <property name="AttentionIconName" type="s" access="read"/> -        <!--same definition as image-->-        <property name="AttentionIconPixmap" type="a(iiay)" 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" />+    <!-- 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>+    <!-- 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>+    <!-- 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>+    <!-- 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>