REF move all 'common' DBus code to seperate shared module

bin/xmobar.hs

@@ -18,6 +18,7 @@ import           Data.List
 import           Data.Maybe
 
 import           DBus.Client
+import           DBus.Internal
 
 import           System.Directory
 import           System.Exit
@@ -42,7 +43,6 @@ import           XMonad.Hooks.DynamicLog
 import           XMonad.Internal.Command.Power                  (hasBattery)
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver               (ssSignalDep)
 import           XMonad.Internal.Dependency
 import           XMonad.Internal.Shell

lib/DBus/Internal.hs

@@ -0,0 +1,170 @@
+--------------------------------------------------------------------------------
+-- | Common internal DBus functions
+
+module DBus.Internal
+  ( addMatchCallback
+  , getDBusClient
+  , withDBusClient
+  , withDBusClient_
+  , matchProperty
+  , matchProperty'
+  , matchPropertyChanged
+  , SignalMatch(..)
+  , SignalCallback
+  , MethodBody
+  , withSignalMatch
+  , callPropertyGet
+  , callMethod
+  , callMethod'
+  , callGetManagedObjects
+  , ObjectTree
+  , getManagedObjects
+  , omInterface
+  , addInterfaceAddedListener
+  , addInterfaceRemovedListener
+  ) where
+
+import           Control.Exception
+import           Control.Monad
+
+import           Data.Bifunctor
+import qualified Data.Map.Strict   as M
+import           Data.Maybe
+
+import           DBus
+import           DBus.Client
+
+--------------------------------------------------------------------------------
+-- | Methods
+
+type MethodBody = Either String [Variant]
+
+callMethod' :: Client -> MethodCall -> IO MethodBody
+callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
+
+callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
+  -> IO MethodBody
+callMethod client bus path iface mem =
+  callMethod' client (methodCall path iface mem)
+  { methodCallDestination = Just bus }
+
+--------------------------------------------------------------------------------
+-- | Signals
+
+type SignalCallback = [Variant] -> IO ()
+
+addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
+addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
+
+--------------------------------------------------------------------------------
+-- | Properties
+
+propertyInterface :: InterfaceName
+propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
+
+propertySignal :: MemberName
+propertySignal = memberName_ "PropertiesChanged"
+
+callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
+  -> IO [Variant]
+callPropertyGet bus path iface property client = either (const []) (:[])
+  <$> getProperty client (methodCall path iface $ memberName_ property)
+    { methodCallDestination = Just bus }
+
+-- TODO actually get the real busname when using this (will involve IO)
+matchProperty' :: Maybe ObjectPath -> MatchRule
+matchProperty' p = matchAny
+  -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the
+  -- requested name (eg "org.something.understandable"). If sender is included
+  -- here, likely nothing will match. Solution is to somehow get the unique
+  -- name, which I could do, but probably won't
+  { matchPath = p
+  , matchInterface = Just propertyInterface
+  , matchMember = Just propertySignal
+  }
+
+matchProperty :: ObjectPath -> MatchRule
+matchProperty = matchProperty' . Just
+
+data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
+
+withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
+withSignalMatch f (Match x) = f (Just x)
+withSignalMatch f Failure   = f Nothing
+withSignalMatch _ NoMatch   = return ()
+
+matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant]
+  -> SignalMatch a
+matchPropertyChanged iface property [i, body, _] =
+  let i' = (fromVariant i :: Maybe String)
+      b = toMap body in
+    case (i', b) of
+      (Just i'', Just b') -> if i'' == formatInterfaceName iface then
+        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
+        else NoMatch
+      _                   -> Failure
+  where
+    toMap v = fromVariant v :: Maybe (M.Map String Variant)
+matchPropertyChanged _ _ _ = Failure
+
+--------------------------------------------------------------------------------
+-- | Client requests
+
+getDBusClient :: Bool -> IO (Maybe Client)
+getDBusClient sys = do
+  res <- try $ if sys then connectSystem else connectSession
+  case res of
+    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
+    Right c -> return $ Just c
+
+withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
+withDBusClient sys f = do
+  client <- getDBusClient sys
+  let r = f <$> client
+  mapM_ disconnect client
+  return r
+
+withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
+withDBusClient_ sys f = do
+  client <- getDBusClient sys
+  mapM_ f client
+  mapM_ disconnect client
+
+--------------------------------------------------------------------------------
+-- | Object Manager
+
+type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
+
+omInterface :: InterfaceName
+omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
+
+getManagedObjects :: MemberName
+getManagedObjects = memberName_ "GetManagedObjects"
+
+callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
+callGetManagedObjects client bus path =
+  either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe))
+  <$> callMethod client bus path omInterface getManagedObjects
+
+omInterfacesAdded :: MemberName
+omInterfacesAdded = memberName_ "InterfacesAdded"
+
+omInterfacesRemoved :: MemberName
+omInterfacesRemoved = memberName_ "InterfacesRemoved"
+
+-- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus)
+addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback
+  -> Client -> IO ()
+addInterfaceChangedListener prop path = fmap void . addMatchCallback rule
+  where
+    rule = matchAny
+      { matchPath = Just path
+      , matchInterface = Just omInterface
+      , matchMember = Just prop
+      }
+
+addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
+addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded
+
+addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
+addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved

lib/XMonad/Internal/DBus/Brightness/Common.hs

@@ -17,6 +17,7 @@ import           Data.Int                    (Int32)
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 import qualified DBus.Introspection          as I
 
 import           XMonad.Internal.DBus.Common

lib/XMonad/Internal/DBus/Common.hs

@@ -1,101 +1,11 @@
 --------------------------------------------------------------------------------
--- | Common internal DBus functions
+-- | High-level interface for managing XMonad's DBus
 
 module XMonad.Internal.DBus.Common
-  ( addMatchCallback
+  ( xmonadBusName
-  , getDBusClient
-  , withDBusClient
-  , withDBusClient_
-  , matchProperty
-  , matchProperty'
-  , xmonadBusName
-  , matchPropertyChanged
-  , SignalMatch(..)
-  , SignalCallback
-  , withSignalMatch
-  , callPropertyGet
   ) where
 
-import           Control.Exception
-
-import qualified Data.Map.Strict   as M
-
 import           DBus
-import           DBus.Client
 
 xmonadBusName :: BusName
 xmonadBusName = busName_ "org.xmonad"
-
-type SignalCallback = [Variant] -> IO ()
-
--- | Bind a callback to a signal match rule
-addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
-addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
-
-getDBusClient :: Bool -> IO (Maybe Client)
-getDBusClient sys = do
-  res <- try $ if sys then connectSystem else connectSession
-  case res of
-    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
-    Right c -> return $ Just c
-
-withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
-withDBusClient sys f = do
-  client <- getDBusClient sys
-  let r = f <$> client
-  mapM_ disconnect client
-  return r
-
-withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
-withDBusClient_ sys f = do
-  client <- getDBusClient sys
-  mapM_ f client
-  mapM_ disconnect client
-
-propertyInterface :: InterfaceName
-propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
-
-propertySignal :: MemberName
-propertySignal = memberName_ "PropertiesChanged"
-
-matchProperty' :: Maybe ObjectPath -> MatchRule
-matchProperty' p = matchAny
-  -- NOTE: the sender for signals is usually the unique name (eg :X.Y) not the
-  -- requested name (eg "org.something.understandable"). If sender is included
-  -- here, likely nothing will match. Solution is to somehow get the unique
-  -- name, which I could do, but probably won't
-  { matchPath = p
-  , matchInterface = Just propertyInterface
-  , matchMember = Just propertySignal
-  }
-
-matchProperty :: ObjectPath -> MatchRule
-matchProperty = matchProperty' . Just
-
-data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
-
-withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
-withSignalMatch f (Match x) = f (Just x)
-withSignalMatch f Failure   = f Nothing
-withSignalMatch _ NoMatch   = return ()
-
-matchPropertyChanged :: IsVariant a => InterfaceName -> String -> [Variant]
-  -> SignalMatch a
-matchPropertyChanged iface property [i, body, _] =
-  let i' = (fromVariant i :: Maybe String)
-      b = toMap body in
-    case (i', b) of
-      (Just i'', Just b') -> if i'' == formatInterfaceName iface then
-        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
-        else NoMatch
-      _                   -> Failure
-  where
-    toMap v = fromVariant v :: Maybe (M.Map String Variant)
-matchPropertyChanged _ _ _ = Failure
-
-callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
-  -> IO [Variant]
-callPropertyGet bus path iface property client = either (const []) (:[])
-  <$> getProperty client (methodCall path iface $ memberName_ property)
-    { methodCallDestination = Just bus }
-

lib/XMonad/Internal/DBus/Control.hs

@@ -10,16 +10,14 @@ module XMonad.Internal.DBus.Control
   , withDBusClient
   , withDBusClient_
   , stopXMonadService
-  , pathExists
   , disconnect
   ) where
 
 import           Control.Monad                                  (forM_, void)
 
-import           Data.Either
-
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
@@ -27,12 +25,6 @@ import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver
 import           XMonad.Internal.Dependency
 
-introspectInterface :: InterfaceName
-introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
-
-introspectMethod :: MemberName
-introspectMethod = memberName_ "Introspect"
-
 startXMonadService :: IO (Maybe Client)
 startXMonadService = do
   client <- getDBusClient False
@@ -47,7 +39,6 @@ stopXMonadService client = do
   void $ releaseName client xmonadBusName
   disconnect client
 
-
 requestXMonadName :: Client -> IO ()
 requestXMonadName client = do
   res <- requestName client xmonadBusName []
@@ -60,11 +51,3 @@ requestXMonadName client = do
   forM_ msg putStrLn
   where
     xn = "'" ++ formatBusName xmonadBusName ++ "'"
-
-pathExists :: Bool -> BusName -> ObjectPath -> IO Bool
-pathExists sysbus n p = do
-  client <- if sysbus then connectSystem else connectSession
-  r <- call client (methodCall p introspectInterface introspectMethod)
-       { methodCallDestination = Just n }
-  disconnect client
-  return $ isRight r

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -13,6 +13,7 @@ import           Control.Monad               (void)
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 import qualified DBus.Introspection          as I
 
 import           Graphics.X11.XScreenSaver

lib/XMonad/Internal/Dependency.hs

@@ -34,38 +34,24 @@ module XMonad.Internal.Dependency
   , executeFeature_
   , executeFeatureWith
   , executeFeatureWith_
-  , callMethod
-  , callMethod'
-  , callGetManagedObjects
-  , ObjectTree
-  , getManagedObjects
-  , omInterface
-  , addInterfaceAddedListener
-  , addInterfaceRemovedListener
   ) where
 
 import           Control.Monad.IO.Class
 import           Control.Monad.Identity
 
-import           Data.Bifunctor              (bimap)
 import           Data.List               (find)
-import qualified Data.Map                    as M
 import           Data.Maybe              (catMaybes, fromMaybe, listToMaybe)
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 import qualified DBus.Introspection      as I
 
-import           System.Directory
+import           System.Directory        (findExecutable, readable, writable)
-    ( findExecutable
-    , readable
-    , writable
-    )
 import           System.Environment
 import           System.Exit
 
 import           XMonad.Core             (X, io)
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.IO
 import           XMonad.Internal.Process
 import           XMonad.Internal.Shell
@@ -332,16 +318,6 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
--- TODO this belongs somewhere else, IDK where tho for now
-callMethod' :: Client -> MethodCall -> IO (Either String [Variant])
-callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
-
-callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
-  -> IO (Either String [Variant])
-callMethod client bus path iface mem =
-  callMethod' client (methodCall path iface mem)
-  { methodCallDestination = Just bus }
-
 dbusDepSatisfied :: Client -> DBusDep -> IO (Maybe String)
 dbusDepSatisfied client (Bus bus) = do
   ret <- callMethod client queryBus queryPath queryIface queryMem
@@ -389,41 +365,3 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
       , formatBusName busname
       ]
 
---------------------------------------------------------------------------------
--- | Object Manager
-
-type ObjectTree = M.Map ObjectPath (M.Map String (M.Map String Variant))
-
-omInterface :: InterfaceName
-omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
-
-getManagedObjects :: MemberName
-getManagedObjects = memberName_ "GetManagedObjects"
-
-callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
-callGetManagedObjects client bus path =
-  either (const M.empty) (fromMaybe M.empty . (fromVariant <=< listToMaybe))
-  <$> callMethod client bus path omInterface getManagedObjects
-
-omInterfacesAdded :: MemberName
-omInterfacesAdded = memberName_ "InterfacesAdded"
-
-omInterfacesRemoved :: MemberName
-omInterfacesRemoved = memberName_ "InterfacesRemoved"
-
--- TODO add busname back to this (use NameGetOwner on org.freedesktop.DBus)
-addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback
-  -> Client -> IO ()
-addInterfaceChangedListener prop path = fmap void . addMatchCallback rule
-  where
-    rule = matchAny
-      { matchPath = Just path
-      , matchInterface = Just omInterface
-      , matchMember = Just prop
-      }
-
-addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
-addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded
-
-addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
-addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved

lib/Xmobar/Plugins/Bluetooth.hs

@@ -46,8 +46,8 @@ import           Data.Maybe
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common

lib/Xmobar/Plugins/Common.hs

@@ -14,11 +14,11 @@ import           Control.Monad
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 
 import           Data.Maybe
 
 import           XMonad.Hooks.DynamicLog (xmobarColor)
-import           XMonad.Internal.DBus.Common
 
 type Callback = String -> IO ()
 

lib/Xmobar/Plugins/Device.hs

@@ -16,8 +16,8 @@ import           Data.Word
 
 import           DBus
 import           DBus.Client
+import           DBus.Internal
 
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common

lib/Xmobar/Plugins/VPN.hs

@@ -10,8 +10,8 @@ module Xmobar.Plugins.VPN
   ) where
 
 import           DBus
+import           DBus.Internal
 
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common

my-xmonad.cabal

@@ -16,11 +16,11 @@ library
                    , XMonad.Internal.Command.Desktop
                    , XMonad.Internal.Command.DMenu
                    , XMonad.Internal.Command.Power
-                   , XMonad.Internal.DBus.Common
                    , XMonad.Internal.DBus.Brightness.IntelBacklight
                    , XMonad.Internal.DBus.Brightness.ClevoKeyboard
                    , XMonad.Internal.DBus.Brightness.Common
                    , XMonad.Internal.DBus.Control
+                   , XMonad.Internal.DBus.Common
                    , XMonad.Internal.DBus.Screensaver
                    , XMonad.Internal.DBus.Removable
                    , XMonad.Internal.Process
@@ -32,6 +32,7 @@ library
                    , Xmobar.Plugins.IntelBacklight
                    , Xmobar.Plugins.Screensaver
                    , Xmobar.Plugins.VPN
+                   , DBus.Internal
     build-depends: X11 >= 1.9.1
                  , base
                  , bytestring >= 0.10.8.2