ENH make bluetooth module display connection status

bin/xmobar.hs

@@ -63,9 +63,9 @@ main = do
 config :: BarRegions -> String -> Config
 config br confDir = defaultConfig
   { font = barFont
-  , additionalFonts = [iconFont, iconFontLarge, iconFontXLarge]
+  , additionalFonts = [iconFont, iconFontLarge, iconFontXLarge, iconFontXXLarge]
   , textOffset = 16
-  , textOffsets = [16, 17, 18]
+  , textOffsets = [16, 17, 17, 18]
   , bgColor = T.bgColor
   , fgColor = T.fgColor
   , position = BottomSize C 100 24
@@ -161,7 +161,8 @@ btCmd :: CmdSpec
 btCmd = CmdSpec
   { csAlias = btAlias
   , csRunnable = Run
-    $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor)
+    -- $ Bluetooth ("<fn=2>\xf293</fn>", T.fgColor, T.backdropFgColor)
+    $ Bluetooth ("<fn=3>\xf5b0</fn>", "<fn=3>\xf5ae</fn>") (T.fgColor, T.backdropFgColor)
   }
 
 alsaCmd :: CmdSpec
@@ -202,10 +203,10 @@ lockCmd = CmdSpec
   { csAlias = "locks"
   , csRunnable = Run
     $ Locks
-    [ "-N", "<fn=3>\xf8a5</fn>"
+    [ "-N", "<fn=4>\xf8a5</fn>"
-    , "-n", xmobarColor T.backdropFgColor "" "<fn=3>\xf8a5</fn>"
+    , "-n", xmobarColor T.backdropFgColor "" "<fn=4>\xf8a5</fn>"
     , "-C", "<fn=3>\xf657</fn>"
-    , "-c", xmobarColor T.backdropFgColor "" "<fn=3>\xf657</fn>"
+    , "-c", xmobarColor T.backdropFgColor "" "<fn=4>\xf657</fn>"
     , "-s", ""
     , "-S", ""
     , "-d", " "
@@ -405,4 +406,7 @@ iconFontLarge :: String
 iconFontLarge = nerdFont 15
 
 iconFontXLarge :: String
-iconFontXLarge = nerdFont 20
+iconFontXLarge = nerdFont 18
+
+iconFontXXLarge :: String
+iconFontXXLarge = nerdFont 20

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

@@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Brightness.Common
   , signalDep
   ) where
 
--- import           Control.Monad               (void)
+import           Control.Monad               (void)
 
 import           Data.Int                    (Int32)
 
@@ -73,7 +73,7 @@ signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
 
 matchSignal :: Num c => BrightnessConfig a b -> (Maybe c -> IO ()) -> Client -> IO ()
 matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
-  addMatchCallback brMatcher (cb . bodyGetBrightness)
+  void . addMatchCallback brMatcher (cb . bodyGetBrightness)
   where
     brMatcher = matchAny
       { matchPath = Just p

lib/XMonad/Internal/DBus/Common.hs

@@ -6,16 +6,17 @@ module XMonad.Internal.DBus.Common
   , getDBusClient
   , withDBusClient
   , withDBusClient_
-  , withDBusClientConnection_
   , matchProperty
+  , matchProperty'
   , xmonadBusName
   , matchPropertyChanged
   , SignalMatch(..)
+  , SignalCallback
+  , withSignalMatch
   , callPropertyGet
   ) where
 
 import           Control.Exception
-import           Control.Monad
 
 import qualified Data.Map.Strict   as M
 
@@ -25,9 +26,11 @@ import           DBus.Client
 xmonadBusName :: BusName
 xmonadBusName = busName_ "org.xmonad"
 
+type SignalCallback = [Variant] -> IO ()
+
 -- | Bind a callback to a signal match rule
-addMatchCallback :: MatchRule -> ([Variant] -> IO ()) -> Client -> IO ()
+addMatchCallback :: MatchRule -> SignalCallback -> Client -> IO SignalHandler
-addMatchCallback rule cb client = void $ addMatch client rule $ cb . signalBody
+addMatchCallback rule cb client = addMatch client rule $ cb . signalBody
 
 getDBusClient :: Bool -> IO (Maybe Client)
 getDBusClient sys = do
@@ -49,46 +52,50 @@ withDBusClient_ sys f = do
   mapM_ f client
   mapM_ disconnect client
 
-withDBusClientConnection_ :: Bool -> (Client -> IO ()) -> IO ()
-withDBusClientConnection_ sys f = do
-  client <- getDBusClient sys
-  mapM_ f client
-
 propertyInterface :: InterfaceName
 propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
 
 propertySignal :: MemberName
 propertySignal = memberName_ "PropertiesChanged"
 
-matchProperty :: ObjectPath -> MatchRule
+matchProperty' :: Maybe ObjectPath -> MatchRule
-matchProperty p = matchAny
+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 = Just p
+  { matchPath = p
   , matchInterface = Just propertyInterface
   , matchMember = Just propertySignal
   }
 
+matchProperty :: ObjectPath -> MatchRule
+matchProperty = matchProperty' . Just
+
 data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
 
-matchPropertyChanged :: InterfaceName -> String -> (Variant -> Maybe a)
+withSignalMatch :: (Maybe a -> IO ()) -> SignalMatch a -> IO ()
-  -> [Variant] -> SignalMatch a
+withSignalMatch f (Match x) = f (Just x)
-matchPropertyChanged iface property f [i, body, _] =
+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 $ f =<< M.lookup property b'
+        maybe NoMatch Match $ fromVariant =<< M.lookup property b'
         else NoMatch
       _                   -> Failure
   where
     toMap v = fromVariant v :: Maybe (M.Map String Variant)
-matchPropertyChanged _ _ _ _ = Failure
+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/Screensaver.hs

@@ -130,7 +130,8 @@ callQuery client = do
   return $ either (const Nothing) bodyGetCurrentState reply
 
 matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
-matchSignal cb = addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
+matchSignal cb =
+  fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
 
 ssSignalDep :: DBusDep
 ssSignalDep = Endpoint xmonadBusName ssPath interface $ Signal_ memState

lib/XMonad/Internal/Dependency.hs

@@ -36,6 +36,12 @@ module XMonad.Internal.Dependency
   , executeFeatureWith_
   , callMethod
   , callMethod'
+  , callGetManagedObjects
+  , ObjectTree
+  , getManagedObjects
+  , omInterface
+  , addInterfaceAddedListener
+  , addInterfaceRemovedListener
   ) where
 
 import           Control.Monad.IO.Class
@@ -43,17 +49,23 @@ 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 qualified DBus.Introspection          as I
 
-import           System.Directory        (findExecutable, readable, writable)
+import           System.Directory
+    ( 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
@@ -376,3 +388,42 @@ dbusDepSatisfied client (Endpoint busname objpath iface mem) = do
       , "on bus"
       , 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/BacklightCommon.hs

@@ -8,13 +8,12 @@ module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
 import           DBus.Client
 
-import           XMonad.Internal.DBus.Common
 import           Xmobar.Plugins.Common
 
 startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
   -> (Client -> IO (Maybe a)) -> String -> (String -> IO ()) -> IO ()
 startBacklight matchSignal callGetBrightness icon cb = do
-    withDBusClientConnection_ False $ \c -> do
+    withDBusClientConnection False cb $ \c -> do
       matchSignal (cb . formatBrightness) c
       cb . formatBrightness =<< callGetBrightness c
     where

lib/Xmobar/Plugins/Bluetooth.hs

@@ -2,6 +2,33 @@
 -- | Bluetooth plugin
 --
 -- Use the bluez interface on DBus to check status
+--
+-- org.bluez dynamically updates its DBus interfaces using the standard Object
+-- Manager. The adapter is located at path "/org/bluez/hci<X>" where X is
+-- usually 0, and each device is "/org/bluez/hci<X>/<MAC_ADDRESS>".
+--
+-- This plugin will reflect if the adapter is powered and if any device is
+-- connected to it. The rough outline for this procedure:
+-- 1) get the adapter from the object manager
+-- 2) get all devices associated with the adapter using the object interface
+-- 3) determine if the adapter is powered
+-- 4) determine if any devices are connected
+-- 5) format the icon; powered vs not powered controls the color and connected
+--    vs not connected controls the icon (connected bluetooth symbol has two
+--    dots flanking it)
+--
+-- Step 3 can be accomplished using the "org.bluez.Adapter1" interface and
+-- querying the "Powered" property. Step 4 can be done using the
+-- "org.bluez.Device1" interface and the "Connected" property for each device
+-- path. Since these are properties, we can asynchronously read changes to them
+-- via the "PropertiesChanged" signal.
+--
+-- If any devices are added/removed, steps 2-4 will need to be redone and any
+-- listeners will need to be updated. (TODO not sure which signals to use in
+-- determining if a device is added)
+--
+-- TODO also not sure if I need to care about multiple adapters and/or the
+-- adapter changing.
 
 module Xmobar.Plugins.Bluetooth
   ( Bluetooth(..)
@@ -9,6 +36,14 @@ module Xmobar.Plugins.Bluetooth
   , btDep
   ) where
 
+import           Control.Concurrent.MVar
+import           Control.Monad
+
+import           Data.List
+import           Data.List.Split
+import qualified Data.Map                    as M
+import           Data.Maybe
+
 import           DBus
 import           DBus.Client
 
@@ -17,42 +52,225 @@ import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common
 
-newtype Bluetooth = Bluetooth (String, String, String) deriving (Read, Show)
-
-
-btInterface :: InterfaceName
-btInterface = interfaceName_ "org.bluez.Adapter1"
-
--- weird that this is a string when introspecting but a member name when calling
--- a method, not sure if it is supposed to work like that
-btPowered :: String
-btPowered = "Powered"
-
-btBus :: BusName
-btBus = busName_ "org.bluez"
-
--- TODO this feels like something that shouldn't be hardcoded
-btPath :: ObjectPath
-btPath = objectPath_ "/org/bluez/hci0"
-
 btAlias :: String
 btAlias = "bluetooth"
 
 btDep :: DBusDep
-btDep = Endpoint btBus btPath btInterface $ Property_ btPowered
+btDep = Endpoint btBus btOmPath omInterface $ Method_ getManagedObjects
 
-matchPowered :: [Variant] -> SignalMatch Bool
+data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
-matchPowered = matchPropertyChanged btInterface btPowered fromVariant
-
-callGetPowered :: Client -> IO [Variant]
-callGetPowered = callPropertyGet btBus btPath btInterface btPowered
 
 instance Exec Bluetooth where
-  alias (Bluetooth _) = btAlias
+  alias (Bluetooth _ _) = btAlias
-  start (Bluetooth (text, colorOn, colorOff)) cb = do
+  start (Bluetooth icons colors) cb =
-    withDBusClientConnection_ True $ \c -> do
+    withDBusClientConnection True cb $ startAdapter icons colors cb
-      startListener rule callGetPowered matchPowered chooseColor' cb c
-    where
-      rule = matchProperty btPath
-      chooseColor' = chooseColor text colorOn colorOff
 
+startAdapter :: Icons -> Colors -> Callback -> Client -> IO ()
+startAdapter is cs cb cl = do
+  ot <- getBtObjectTree cl
+  state <- newMVar emptyState
+  let display = displayIcon cb (iconFormatter is cs) state
+  forM_ (findAdapter ot) $ \adapter -> do
+    -- set up adapter
+    initAdapter state adapter cl
+    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
+    addDeviceRemovedListener state display adapter cl
+    forM_ devices $ \d -> addAndInitDevice state display d cl
+    -- after setting things up, show the icon based on the initialized state
+    display
+
+--------------------------------------------------------------------------------
+-- | Icon Display
+--
+-- Color corresponds to the adaptor powered state, and the icon corresponds to
+-- if it is paired or not. If the adaptor state is undefined, display "N/A"
+
+type IconFormatter = (Maybe Bool -> Bool -> String)
+
+type Icons = (String, String)
+
+type Colors = (String, String)
+
+displayIcon :: Callback -> IconFormatter -> MutableBtState -> IO ()
+displayIcon callback formatter =
+  callback . uncurry formatter <=< readState
+
+-- TODO maybe I want this to fail when any of the device statuses are Nothing
+iconFormatter :: Icons -> Colors -> IconFormatter
+iconFormatter (iconConn, iconDisc) (colorOn, colorOff) powered connected =
+  maybe na (chooseColor icon colorOn colorOff) powered
+  where
+    icon = if connected then iconConn else iconDisc
+
+--------------------------------------------------------------------------------
+-- | Connection State
+--
+-- The signal handlers all run on separate threads, yet the icon depends on
+-- the state reflected by all these signals. The best (only?) way to do this is
+-- is to track the shared state of the bluetooth adaptor and its devices using
+-- an MVar.
+
+data BTDevice = BTDevice
+  { btDevConnected  :: Maybe Bool
+  , btDevSigHandler :: SignalHandler
+  }
+
+type ConnectedDevices = M.Map ObjectPath BTDevice
+
+data BtState = BtState
+  { btDevices :: ConnectedDevices
+  , btPowered :: Maybe Bool
+  }
+
+type MutableBtState = MVar BtState
+
+emptyState :: BtState
+emptyState = BtState
+  { btDevices = M.empty
+  , btPowered = Nothing
+  }
+
+readState :: MutableBtState -> IO (Maybe Bool, Bool)
+readState state = do
+  p <- readPowered state
+  c <- readDevices state
+  return (p, anyDevicesConnected c)
+
+--------------------------------------------------------------------------------
+-- | Object manager
+
+findAdapter :: ObjectTree -> Maybe ObjectPath
+findAdapter = find (("/org/bluez/hci" `isPrefixOf`) . formatObjectPath) . M.keys
+
+findDevices :: ObjectPath -> ObjectTree -> [ObjectPath]
+findDevices adapter = filter (adaptorHasDevice adapter) . M.keys
+
+adaptorHasDevice :: ObjectPath -> ObjectPath -> Bool
+adaptorHasDevice adaptor device = case splitPath device of
+  [org, bluez, hciX, _] -> splitPath adaptor == [org, bluez, hciX]
+  _                     -> False
+
+splitPath :: ObjectPath -> [String]
+splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
+
+getBtObjectTree :: Client -> IO ObjectTree
+getBtObjectTree client = callGetManagedObjects client btBus btOmPath
+
+btBus :: BusName
+btBus = busName_ "org.bluez"
+
+btOmPath :: ObjectPath
+btOmPath = objectPath_ "/"
+
+addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addDeviceAddedListener state display adapter client =
+  addInterfaceAddedListener btOmPath 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
+  where
+    remDevice = pathCallback adapter display $ \d -> do
+      old <- removeDevice state d
+      forM_ old $ removeMatch client . btDevSigHandler
+
+pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
+pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
+  when (adaptorHasDevice adapter d) $ f d >> display
+pathCallback _ _ _ _ = return ()
+
+--------------------------------------------------------------------------------
+-- | Adapter
+
+initAdapter :: MutableBtState -> ObjectPath -> Client -> IO ()
+initAdapter state adapter client = do
+  reply <- callGetPowered adapter client
+  putPowered state $ fromSingletonVariant reply
+
+addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addAdaptorListener state display adaptor =
+  void . addMatchCallback rule (procMatch . matchPowered)
+  where
+    rule = matchProperty adaptor
+    procMatch = withSignalMatch $ \b -> putPowered state b >> display
+
+callGetPowered :: ObjectPath -> Client -> IO [Variant]
+callGetPowered adapter =
+  callPropertyGet btBus adapter adapterInterface adaptorPowered
+
+matchPowered :: [Variant] -> SignalMatch Bool
+matchPowered = matchPropertyChanged adapterInterface adaptorPowered
+
+putPowered :: MutableBtState -> Maybe Bool -> IO ()
+putPowered m ds = modifyMVar_ m (\s -> return s { btPowered = ds })
+
+readPowered :: MutableBtState -> IO (Maybe Bool)
+readPowered = fmap btPowered . readMVar
+
+adapterInterface :: InterfaceName
+adapterInterface = interfaceName_ "org.bluez.Adapter1"
+
+adaptorPowered :: String
+adaptorPowered = "Powered"
+
+--------------------------------------------------------------------------------
+-- | Devices
+
+addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addAndInitDevice state display device client = do
+  sh <- addDeviceListener state display device client
+  initDevice state sh device client
+
+initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO ()
+initDevice state sh device client = do
+  reply <- callGetConnected device client
+  void $ insertDevice state device $
+    BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
+             , btDevSigHandler = sh
+             }
+
+addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO SignalHandler
+addDeviceListener state display device =
+  addMatchCallback rule (procMatch . matchConnected)
+  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
+
+insertDevice :: MutableBtState -> ObjectPath -> BTDevice -> IO Bool
+insertDevice m device dev = modifyMVar m $ \s -> do
+  let new = M.insert device dev $ btDevices s
+  return (s { btDevices = new }, anyDevicesConnected new)
+
+updateDevice :: MutableBtState -> ObjectPath -> Maybe Bool -> IO Bool
+updateDevice m device status = modifyMVar m $ \s -> do
+  let new = M.update (\d -> Just d { btDevConnected = status }) device $ btDevices s
+  return (s { btDevices = new }, anyDevicesConnected new)
+
+anyDevicesConnected :: ConnectedDevices -> Bool
+anyDevicesConnected = or . mapMaybe btDevConnected . M.elems
+
+removeDevice :: MutableBtState -> ObjectPath -> IO (Maybe BTDevice)
+removeDevice m device = modifyMVar m $ \s -> do
+  let devs = btDevices s
+  return (s { btDevices = M.delete device devs }, M.lookup device devs)
+
+readDevices :: MutableBtState -> IO ConnectedDevices
+readDevices = fmap btDevices . readMVar
+
+devInterface :: InterfaceName
+devInterface = interfaceName_ "org.bluez.Device1"
+
+devConnected :: String
+devConnected = "Connected"

lib/Xmobar/Plugins/Common.hs

@@ -2,10 +2,16 @@
 module Xmobar.Plugins.Common
   ( chooseColor
   , startListener
+  , procSignalMatch
   , na
+  , fromSingletonVariant
+  , withDBusClientConnection
+  , Callback
   )
   where
 
+import           Control.Monad
+
 import           DBus
 import           DBus.Client
 
@@ -14,17 +20,22 @@ import           Data.Maybe
 import           XMonad.Hooks.DynamicLog     (xmobarColor)
 import           XMonad.Internal.DBus.Common
 
+type Callback = String -> IO ()
+
 startListener :: IsVariant a => MatchRule -> (Client -> IO [Variant])
-  -> ([Variant] -> SignalMatch a) -> (a -> String) -> (String -> IO ())
+  -> ([Variant] -> SignalMatch a) -> (a -> IO String) -> Callback
   -> Client -> IO ()
 startListener rule getProp fromSignal toColor cb client = do
   reply <- getProp client
   procMatch $ maybe Failure Match $ fromVariant =<< listToMaybe reply
-  addMatchCallback rule (procMatch . fromSignal) client
+  void $ addMatchCallback rule (procMatch . fromSignal) client
   where
-    procMatch (Match t) = cb $ toColor t
+    procMatch = procSignalMatch cb toColor
-    procMatch Failure   = cb na
+
-    procMatch NoMatch   = return ()
+procSignalMatch :: (String -> IO ()) -> (a -> IO String) -> SignalMatch a -> IO ()
+procSignalMatch callback formatter (Match x) = callback =<< formatter x
+procSignalMatch callback _ Failure           = callback na
+procSignalMatch _ _ NoMatch                  = return ()
 
 chooseColor :: String -> String -> String -> Bool -> String
 chooseColor text colorOn colorOff state =
@@ -32,3 +43,9 @@ chooseColor text colorOn colorOff state =
 
 na :: String
 na = "N/A"
+
+fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
+fromSingletonVariant = fromVariant <=< listToMaybe
+
+withDBusClientConnection :: Bool -> Callback -> (Client -> IO ()) -> IO ()
+withDBusClientConnection sys cb f = maybe (cb na) f =<< getDBusClient sys

lib/Xmobar/Plugins/Device.hs

@@ -58,15 +58,15 @@ getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
 getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface devSignal
 
 matchStatus :: [Variant] -> SignalMatch Word32
-matchStatus = matchPropertyChanged nmDeviceInterface devSignal fromVariant
+matchStatus = matchPropertyChanged nmDeviceInterface devSignal
 
 instance Exec Device where
   alias (Device (iface, _, _, _)) = iface
   start (Device (iface, text, colorOn, colorOff)) cb = do
-    withDBusClientConnection_ True $ \c -> do
+    withDBusClientConnection True cb $ \c -> do
       path <- getDevice c iface
       maybe (cb na) (listener c) path
     where
       listener client path = startListener (matchProperty path)
         (getDeviceConnected path) matchStatus chooseColor' cb client
-      chooseColor' = chooseColor text colorOn colorOff . (> 1)
+      chooseColor' = return . chooseColor text colorOn colorOff . (> 1)

lib/Xmobar/Plugins/Screensaver.hs

@@ -11,7 +11,6 @@ module Xmobar.Plugins.Screensaver
 
 import           Xmobar
 
-import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.DBus.Screensaver
 import           Xmobar.Plugins.Common
 
@@ -23,7 +22,7 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
   alias (Screensaver _) = ssAlias
   start (Screensaver (text, colorOn, colorOff)) cb = do
-    withDBusClientConnection_ False $ \c -> do
+    withDBusClientConnection False cb $ \c -> do
       matchSignal (cb . fmtState) c
       cb . fmtState =<< callQuery c
     where

lib/Xmobar/Plugins/VPN.hs

@@ -39,10 +39,10 @@ vpnDep = Endpoint vpnBus vpnPath vpnInterface $ Property_ vpnConnType
 instance Exec VPN where
   alias (VPN _) = vpnAlias
   start (VPN (text, colorOn, colorOff)) cb =
-    withDBusClientConnection_ True
+    withDBusClientConnection True cb
     $ startListener rule getProp fromSignal chooseColor' cb
     where
       rule = matchProperty vpnPath
       getProp = callPropertyGet vpnBus vpnPath vpnInterface vpnConnType
-      fromSignal = matchPropertyChanged vpnInterface vpnConnType fromVariant
+      fromSignal = matchPropertyChanged vpnInterface vpnConnType
-      chooseColor' = chooseColor text colorOn colorOff . ("vpn" ==)
+      chooseColor' = return . chooseColor text colorOn colorOff . ("vpn" ==)

my-xmonad.cabal

@@ -47,6 +47,7 @@ library
                  , directory >= 1.3.3.0
                  , process >= 1.6.5.0
                  , filepath >= 1.4.2.1
+                 , split >= 0.2.3.4
                  , xmobar
                  , xmonad-extras >= 0.15.2
                  , xmonad >= 0.13