ENH use busname when matching signal

lib/DBus/Internal.hs

@@ -4,10 +4,11 @@
 module DBus.Internal
   ( addMatchCallback
   , getDBusClient
+  , fromDBusClient
   , withDBusClient
   , withDBusClient_
   , matchProperty
-  , matchProperty'
+  , matchPropertyFull
   , matchPropertyChanged
   , SignalMatch(..)
   , SignalCallback
@@ -16,12 +17,15 @@ module DBus.Internal
   , callPropertyGet
   , callMethod
   , callMethod'
+  , methodCallBus
   , callGetManagedObjects
   , ObjectTree
   , getManagedObjects
   , omInterface
   , addInterfaceAddedListener
   , addInterfaceRemovedListener
+  , fromSingletonVariant
+  , bodyToMaybe
   ) where
 
 import           Control.Exception
@@ -44,9 +48,33 @@ callMethod' cl = fmap (bimap methodErrorMessage methodReturnBody) . call cl
 
 callMethod :: Client -> BusName -> ObjectPath -> InterfaceName -> MemberName
   -> IO MethodBody
-callMethod client bus path iface mem =
+callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
-  callMethod' client (methodCall path iface mem)
+
-  { methodCallDestination = Just bus }
+methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
+methodCallBus b p i m = (methodCall p i m)
+    { methodCallDestination = Just b }
+
+--------------------------------------------------------------------------------
+-- | Bus names
+
+dbusInterface :: InterfaceName
+dbusInterface = interfaceName_ "org.freedesktop.DBus"
+
+callGetNameOwner :: Client -> BusName -> IO (Maybe BusName)
+callGetNameOwner client name = bodyToMaybe <$> callMethod' client mc
+  where
+    mc = (methodCallBus dbusName dbusPath dbusInterface mem)
+      { methodCallBody = [toVariant name] }
+    mem = memberName_ "GetNameOwner"
+
+--------------------------------------------------------------------------------
+-- | Variant parsing
+
+fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
+fromSingletonVariant = fromVariant <=< listToMaybe
+
+bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
+bodyToMaybe = either (const Nothing) fromSingletonVariant
 
 --------------------------------------------------------------------------------
 -- | Signals
@@ -56,6 +84,20 @@ type SignalCallback = [Variant] -> IO ()
 addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
 addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
 
+matchSignal :: Maybe BusName -> Maybe ObjectPath -> Maybe InterfaceName
+  -> Maybe MemberName -> MatchRule
+matchSignal b p i m = matchAny
+  { matchPath = p
+  , matchSender = b
+  , matchInterface = i
+  , matchMember = m
+  }
+
+matchSignalFull :: Client -> BusName -> Maybe ObjectPath -> Maybe InterfaceName
+  -> Maybe MemberName -> IO (Maybe MatchRule)
+matchSignalFull client b p i m =
+  fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
+
 --------------------------------------------------------------------------------
 -- | Properties
 
@@ -65,26 +107,18 @@ propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
-callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> String -> Client
+callPropertyGet :: BusName -> ObjectPath -> InterfaceName -> MemberName -> Client
   -> IO [Variant]
-callPropertyGet bus path iface property client = either (const []) (:[])
+callPropertyGet bus path iface property client = fmap (either (const []) (:[]))
-  <$> getProperty client (methodCall path iface $ memberName_ property)
+  $ getProperty client $ methodCallBus bus path iface property
-    { methodCallDestination = Just bus }
 
--- TODO actually get the real busname when using this (will involve IO)
+matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
-matchProperty' :: Maybe ObjectPath -> MatchRule
+matchProperty b p =
-matchProperty' p = matchAny
+  matchSignal b p (Just propertyInterface) (Just propertySignal)
-  -- 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
+matchPropertyFull :: Client -> BusName -> Maybe ObjectPath -> IO (Maybe MatchRule)
-matchProperty = matchProperty' . Just
+matchPropertyFull client b p =
+  matchSignalFull client b p (Just propertyInterface) (Just propertySignal)
 
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
@@ -117,18 +151,19 @@ getDBusClient sys = do
     Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
     Right c -> return $ Just c
 
-withDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
+withDBusClient :: Bool -> (Client -> IO a) -> IO (Maybe a)
 withDBusClient sys f = do
   client <- getDBusClient sys
-  let r = f <$> client
+  forM client $ \c -> do
-  mapM_ disconnect client
+    r <- f c
-  return r
+    disconnect c
+    return r
 
 withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
-withDBusClient_ sys f = do
+withDBusClient_ sys = void . withDBusClient sys
-  client <- getDBusClient sys
+
-  mapM_ f client
+fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
-  mapM_ disconnect client
+fromDBusClient sys f = withDBusClient sys (return . f)
 
 --------------------------------------------------------------------------------
 -- | Object Manager
@@ -141,30 +176,29 @@ 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)
+callGetManagedObjects :: Client -> BusName -> ObjectPath -> IO ObjectTree
-addInterfaceChangedListener :: MemberName -> ObjectPath -> SignalCallback
+callGetManagedObjects client bus path =
-  -> Client -> IO ()
+  either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
-addInterfaceChangedListener prop path = fmap void . addMatchCallback rule
+  <$> callMethod client bus path omInterface getManagedObjects
-  where
-    rule = matchAny
-      { matchPath = Just path
-      , matchInterface = Just omInterface
-      , matchMember = Just prop
-      }
 
-addInterfaceAddedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
+addInterfaceChangedListener :: BusName -> MemberName -> ObjectPath
-addInterfaceAddedListener = addInterfaceChangedListener omInterfacesAdded
+  -> SignalCallback -> Client -> IO (Maybe SignalHandler)
+addInterfaceChangedListener bus prop path sc client = do
+  rule <- matchSignalFull client bus (Just path) (Just omInterface) (Just prop)
+  forM rule $ \r -> addMatchCallback r sc client
 
-addInterfaceRemovedListener :: ObjectPath -> SignalCallback -> Client -> IO ()
+addInterfaceAddedListener :: BusName -> ObjectPath -> SignalCallback -> Client
-addInterfaceRemovedListener = addInterfaceChangedListener omInterfacesRemoved
+  -> IO (Maybe SignalHandler)
+addInterfaceAddedListener bus =
+  addInterfaceChangedListener bus omInterfacesAdded
+
+addInterfaceRemovedListener :: BusName -> ObjectPath -> SignalCallback -> Client
+  -> IO (Maybe SignalHandler)
+addInterfaceRemovedListener bus =
+  addInterfaceChangedListener bus omInterfacesRemoved

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

@@ -62,11 +62,10 @@ brightnessControls bc client =
   where
     cb = callBacklight client bc
 
--- TODO not dry
 callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
-callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client = do
+callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
-  reply <- callMethod client xmonadBusName p i memGet
+  either (const Nothing) bodyGetBrightness
-  return $ either (const Nothing) bodyGetBrightness reply
+  <$> callMethod client xmonadBusName p i memGet
 
 signalDep :: BrightnessConfig a b -> DBusDep
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
@@ -76,6 +75,7 @@ matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client ->
 matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
   void . addMatchCallback brMatcher (cb . bodyGetBrightness)
   where
+    -- TODO add busname to this
     brMatcher = matchAny
       { matchPath = Just p
       , matchInterface = Just i
@@ -128,7 +128,8 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
   where
     sig = signal p i memCur
 
-callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName -> FeatureIO
+callBacklight :: Maybe Client -> BrightnessConfig a b -> String -> MemberName
+  -> FeatureIO
 callBacklight client BrightnessConfig { bcPath = p
                                       , bcInterface = i
                                       , bcName = n } controlName m =

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -11,11 +11,11 @@ import           DBus.Client
 import           Xmobar.Plugins.Common
 
 startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
-  -> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
+  -> (Client -> IO (Maybe a)) -> String -> Callback -> IO ()
 startBacklight matchSignal callGetBrightness icon cb = do
     withDBusClientConnection False cb $ \c -> do
-      matchSignal (cb . formatBrightness) c
+      matchSignal display c
-      cb . formatBrightness =<< callGetBrightness c
+      display =<< callGetBrightness c
     where
-      formatBrightness = maybe na $
+      formatBrightness b = return $ icon ++ show (round b :: Integer) ++ "%"
-        \b -> icon ++ show (round b :: Integer) ++ "%"
+      display = displayMaybe cb formatBrightness

lib/Xmobar/Plugins/Bluetooth.hs

@@ -56,7 +56,7 @@ btAlias :: String
 btAlias = "bluetooth"
 
 btDep :: DBusDep
-btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects
+btDep = Endpoint btBus btOMPath omInterface $ Method_ getManagedObjects
 
 data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 
@@ -73,7 +73,8 @@ startAdapter is cs cb cl = do
   forM_ (findAdapter ot) $ \adapter -> do
     -- set up adapter
     initAdapter state adapter cl
-    addAdaptorListener state display adapter cl
+    -- TODO this step could fail; at least warn the user...
+    void $ addAdaptorListener state display adapter cl
     -- set up devices on the adapter (and listeners for adding/removing devices)
     let devices = findDevices adapter ot
     addDeviceAddedListener state display adapter cl
@@ -157,24 +158,27 @@ splitPath :: ObjectPath -> [String]
 splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
 
 getBtObjectTree :: Client -> IO ObjectTree
-getBtObjectTree client = callGetManagedObjects client btBus btOmPath
+getBtObjectTree client = callGetManagedObjects client btBus btOMPath
 
 btBus :: BusName
 btBus = busName_ "org.bluez"
 
-btOmPath :: ObjectPath
+btOMPath :: ObjectPath
-btOmPath = objectPath_ "/"
+btOMPath = objectPath_ "/"
+
+addBtOMListener :: SignalCallback -> Client -> IO ()
+addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
 
 addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
 addDeviceAddedListener state display adapter client =
-  addInterfaceAddedListener btOmPath addDevice client
+  addBtOMListener addDevice client
   where
     addDevice = pathCallback adapter display $ \d ->
       addAndInitDevice state display d client
 
 addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
 addDeviceRemovedListener state display adapter client =
-  addInterfaceRemovedListener btOmPath remDevice client
+  addBtOMListener remDevice client
   where
     remDevice = pathCallback adapter display $ \d -> do
       old <- removeDevice state d
@@ -193,16 +197,20 @@ initAdapter state adapter client = do
   reply <- callGetPowered adapter client
   putPowered state $ fromSingletonVariant reply
 
-addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+matchBTProperty :: Client -> ObjectPath -> IO (Maybe MatchRule)
-addAdaptorListener state display adaptor =
+matchBTProperty client p = matchPropertyFull client btBus (Just p)
-  void . addMatchCallback rule (procMatch . matchPowered)
+
+addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client
+  -> IO (Maybe SignalHandler)
+addAdaptorListener state display adaptor client = do
+  rule <- matchBTProperty client adaptor
+  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) client
   where
-    rule = matchProperty adaptor
     procMatch = withSignalMatch $ \b -> putPowered state b >> display
 
 callGetPowered :: ObjectPath -> Client -> IO [Variant]
 callGetPowered adapter =
-  callPropertyGet btBus adapter adapterInterface adaptorPowered
+  callPropertyGet btBus adapter adapterInterface $ memberName_ adaptorPowered
 
 matchPowered :: [Variant] -> SignalMatch Bool
 matchPowered = matchPropertyChanged adapterInterface adaptorPowered
@@ -225,7 +233,8 @@ adaptorPowered = "Powered"
 addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
 addAndInitDevice state display device client = do
   sh <- addDeviceListener state display device client
-  initDevice state sh device client
+  -- TODO add some intelligent error messages here
+  forM_ sh $ \s -> initDevice state s device client
 
 initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO ()
 initDevice state sh device client = do
@@ -235,18 +244,19 @@ initDevice state sh device client = do
              , btDevSigHandler = sh
              }
 
-addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO SignalHandler
+addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client
-addDeviceListener state display device =
+  -> IO (Maybe SignalHandler)
-  addMatchCallback rule (procMatch . matchConnected)
+addDeviceListener state display device client = do
+  rule <- matchBTProperty client device
+  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) client
   where
-    rule = matchProperty device
     procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
 
 matchConnected :: [Variant] -> SignalMatch Bool
 matchConnected = matchPropertyChanged devInterface devConnected
 
 callGetConnected :: ObjectPath -> Client -> IO [Variant]
-callGetConnected p = callPropertyGet btBus p devInterface devConnected
+callGetConnected p = callPropertyGet btBus p devInterface $ memberName_ devConnected
 
 insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
 insertDevice m device dev = modifyMVar m $ \s -> do

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -22,5 +22,5 @@ ckAlias = "clevokeyboard"
 
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = ckAlias
-  start (ClevoKeyboard icon) cb = do
+  start (ClevoKeyboard icon) =
-     startBacklight matchSignalCK callGetBrightnessCK icon cb
+     startBacklight matchSignalCK callGetBrightnessCK icon

lib/Xmobar/Plugins/Common.hs

@@ -7,6 +7,8 @@ module Xmobar.Plugins.Common
   , fromSingletonVariant
   , withDBusClientConnection
   , Callback
+  , displayMaybe
+  , displayMaybe'
   )
   where
 
@@ -16,8 +18,6 @@ import           DBus
 import           DBus.Client
 import           DBus.Internal
 
-import           Data.Maybe
-
 import           XMonad.Hooks.DynamicLog (xmobarColor)
 
 type Callback = String -> IO ()
@@ -27,15 +27,13 @@ startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
   -> Client -> IO ()
 startListener rule getProp fromSignal toColor cb client = do
   reply <- getProp client
-  procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
+  displayMaybe cb toColor $ fromSingletonVariant reply
   void $ addMatchCallback rule (procMatch . fromSignal) client
   where
     procMatch = procSignalMatch cb toColor
 
-procSignalMatch :: (String -> IO ()) -> (a -> IO String) -> SignalMatch a -> IO ()
+procSignalMatch :: Callback -> (a -> IO String) -> SignalMatch a -> IO ()
-procSignalMatch callback formatter (Match x) = callback =<< formatter x
+procSignalMatch cb f = withSignalMatch (displayMaybe cb f)
-procSignalMatch callback _ Failure           = callback na
-procSignalMatch _ _ NoMatch                  = return ()
 
 chooseColor :: String -> String -> String -> Bool -> String
 chooseColor text colorOn colorOff state =
@@ -44,8 +42,11 @@ chooseColor text colorOn colorOff state =
 na :: String
 na = "N/A"
 
-fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
+displayMaybe :: Callback -> (a -> IO String) -> Maybe a -> IO ()
-fromSingletonVariant = fromVariant <=< listToMaybe
+displayMaybe cb f = cb <=< maybe (return na) f
+
+displayMaybe' :: Callback -> (a -> IO ()) -> Maybe a -> IO ()
+displayMaybe' cb = maybe (cb na)
 
 withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO ()
-withDBusClientConnection sys cb f = maybe (cb na) f =<< getDBusClient sys
+withDBusClientConnection sys cb f = displayMaybe' cb f =<< getDBusClient sys

lib/Xmobar/Plugins/Device.hs

@@ -11,7 +11,6 @@ module Xmobar.Plugins.Device
 
 import           Control.Monad
 
-import           Data.Maybe
 import           Data.Word
 
 import           DBus
@@ -46,16 +45,15 @@ devDep :: DBusDep
 devDep = Endpoint nmBus nmPath nmInterface $ Method_ getByIP
 
 getDevice :: Client -> String -> IO (Maybe ObjectPath)
-getDevice client iface = either (const Nothing) (fromVariant <=< listToMaybe)
+getDevice client iface = bodyToMaybe <$> callMethod' client mc
-  <$> callMethod' client mc
   where
-    mc = (methodCall nmPath nmInterface getByIP)
+    mc = (methodCallBus nmBus nmPath nmInterface getByIP)
       { methodCallBody = [toVariant iface]
-      , methodCallDestination = Just nmBus
       }
 
 getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
-getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
+getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface
+  $ memberName_ devSignal
 
 matchStatus :: [Variant] -> SignalMatch Word32
 matchStatus = matchPropertyChanged nmDeviceInterface devSignal
@@ -63,10 +61,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
 instance Exec Device where
   alias (Device (iface, _, _, _)) = iface
   start (Device (iface, text, colorOn, colorOff)) cb = do
-    withDBusClientConnection True cb $ \c -> do
+    withDBusClientConnection True cb $ \client -> do
-      path <- getDevice c iface
+      path <- getDevice client iface
-      maybe (cb na) (listener c) path
+      displayMaybe' cb (listener client) path
     where
-      listener client path = startListener (matchProperty path)
+      listener client path = do
-        (getDeviceConnected path) matchStatus chooseColor' cb client
+        rule <- matchPropertyFull client nmBus (Just path)
+        -- TODO warn the user here rather than silently drop the listener
+        forM_ rule $ \r ->
+          startListener r (getDeviceConnected path) matchStatus chooseColor' cb client
       chooseColor' = return . chooseColor text colorOn colorOff . (> 1)

lib/Xmobar/Plugins/IntelBacklight.hs

@@ -22,5 +22,5 @@ blAlias = "intelbacklight"
 
 instance Exec IntelBacklight where
   alias (IntelBacklight _) = blAlias
-  start (IntelBacklight icon) cb =
+  start (IntelBacklight icon) =
-     startBacklight matchSignalIB callGetBrightnessIB icon cb
+     startBacklight matchSignalIB callGetBrightnessIB icon

lib/Xmobar/Plugins/Screensaver.hs

@@ -23,8 +23,8 @@ instance Exec Screensaver where
   alias (Screensaver _) = ssAlias
   start (Screensaver (text, colorOn, colorOff)) cb = do
     withDBusClientConnection False cb $ \c -> do
-      matchSignal (cb . fmtState) c
+      matchSignal display c
-      cb . fmtState =<< callQuery c
+      display =<< callQuery c
     where
-      fmtState = maybe na $ chooseColor text colorOn colorOff
+      display = displayMaybe cb $ return . chooseColor text colorOn colorOff
 

lib/Xmobar/Plugins/VPN.hs

@@ -9,6 +9,8 @@ module Xmobar.Plugins.VPN
   , vpnDep
   ) where
 
+import           Control.Monad
+
 import           DBus
 import           DBus.Internal
 
@@ -39,10 +41,11 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
 instance Exec VPN where
   alias (VPN _) = vpnAlias
   start (VPN (text, colorOn, colorOff)) cb =
-    withDBusClientConnection True cb
+    withDBusClientConnection True cb $ \c -> do
-    $ startListener rule getProp fromSignal chooseColor' cb
+      rule <- matchPropertyFull c vpnBus (Just vpnPath)
+      -- TODO intelligently warn user
+      forM_ rule $ \r -> startListener r getProp fromSignal chooseColor' cb c
     where
-      rule = matchProperty vpnPath
+      getProp = callPropertyGet vpnBus vpnPath vpnInterface $ memberName_ vpnConnType
-      getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
       fromSignal = matchPropertyChanged vpnInterface vpnConnType
       chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==)