ENH use typesafe dbus client

bin/xmobar.hs

@@ -14,8 +14,6 @@ module Main (main) where
 import           Data.List
 import           Data.Maybe
 
-import           DBus.Client
-
 import           System.Exit
 import           System.IO
 import           System.IO.Error
@@ -183,7 +181,7 @@ getWireless :: BarFeature
 getWireless = Sometimes "wireless status indicator" xpfWireless
   [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe Client -> BarFeature
+getEthernet :: Maybe SysClient -> BarFeature
 getEthernet cl = iconDBus "ethernet status indicator" (const True) root tree
   where
     root useIcon tree' = DBusRoot (const . ethernetCmd useIcon) tree' cl
@@ -196,14 +194,14 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
     tree = Only_ $ IOTest_ "Test if battery is present" []
       $ fmap (Msg Error) <$> hasBattery
 
-getVPN :: Maybe Client -> BarFeature
+getVPN :: Maybe SysClient -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root $ toAnd_ vpnDep test
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
     test = DBusIO $ IOTest_ "Use nmcli to test if VPN is present"
       networkManagerPkgs vpnPresent
 
-getBt :: Maybe Client -> BarFeature
+getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
@@ -212,15 +210,15 @@ getAlsa = iconIO_ "volume level indicator" (const True) root
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe Client -> BarFeature
+getBl :: Maybe SesClient -> BarFeature
 getBl = xmobarDBus "Intel backlight indicator" xpfIntelBacklight
   intelBacklightSignalDep blCmd
 
-getCk :: Maybe Client -> BarFeature
+getCk :: Maybe SesClient -> BarFeature
 getCk = xmobarDBus "Clevo keyboard indicator" xpfClevoBacklight
   clevoKeyboardSignalDep ckCmd
 
-getSs :: Maybe Client -> BarFeature
+getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -231,8 +229,8 @@ getLock = always1 "lock indicator" "icon indicator" root $ lockCmd fontifyAlt
 --------------------------------------------------------------------------------
 -- | bar feature constructors
 
-xmobarDBus :: String -> XPQuery -> DBusDependency_ -> (Fontifier -> CmdSpec)
+xmobarDBus :: SafeClient c => String -> XPQuery -> DBusDependency_ c
-  -> Maybe Client -> BarFeature
+  -> (Fontifier -> CmdSpec) -> Maybe c -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
   where
     root useIcon tree = DBusRoot_ (const $ cmd useIcon) tree cl
@@ -241,12 +239,12 @@ iconIO_ :: String -> XPQuery -> (Fontifier -> IOTree_ -> Root CmdSpec)
   -> IOTree_ -> BarFeature
 iconIO_ = iconSometimes' And_ Only_
 
-iconDBus :: String -> XPQuery -> (Fontifier -> DBusTree p -> Root CmdSpec)
+iconDBus :: SafeClient c => String -> XPQuery
-  -> DBusTree p -> BarFeature
+  -> (Fontifier -> DBusTree c p -> Root CmdSpec) -> DBusTree c p -> BarFeature
 iconDBus = iconSometimes' And1 $ Only_ . DBusIO
 
-iconDBus_ :: String -> XPQuery -> (Fontifier -> DBusTree_ -> Root CmdSpec)
+iconDBus_ :: SafeClient c => String -> XPQuery
-  -> DBusTree_ -> BarFeature
+  -> (Fontifier -> DBusTree_ c -> Root CmdSpec) -> DBusTree_ c -> BarFeature
 iconDBus_ = iconSometimes' And_ $ Only_ . DBusIO
 
 iconSometimes' :: (t -> t_ -> t) -> (IODependency_ -> t_) -> String -> XPQuery

bin/xmonad.hs

@@ -90,9 +90,9 @@ run = do
 
 data FeatureSet = FeatureSet
   { fsKeys          :: ThreadState -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe Client -> SometimesIO]
+  , fsDBusExporters :: [Maybe SesClient -> SometimesIO]
   , fsPowerMon      :: SometimesIO
-  , fsRemovableMon  :: Maybe Client -> SometimesIO
+  , fsRemovableMon  :: Maybe SysClient -> SometimesIO
   , fsDaemons       :: [Sometimes (IO ProcessHandle)]
   , fsACPIHandler   :: Always (String -> X ())
   , fsTabbedTheme   :: Always Theme
@@ -107,7 +107,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
     niceTheme = IORoot T.tabbedTheme $ fontTree T.defFontFamily defFontPkgs
     fallback = Always_ $ FallbackAlone $ T.tabbedTheme T.fallbackFont
 
-features :: Maybe Client -> FeatureSet
+features :: Maybe SysClient -> FeatureSet
 features cl = FeatureSet
   { fsKeys = externalBindings
   , fsDBusExporters = dbusExporters

lib/DBus/Internal.hs

@@ -3,10 +3,10 @@
 
 module DBus.Internal
   ( addMatchCallback
-  , getDBusClient
+  -- , getDBusClient
-  , fromDBusClient
+  -- , fromDBusClient
-  , withDBusClient
+  -- , withDBusClient
-  , withDBusClient_
+  -- , withDBusClient_
   , matchProperty
   , matchPropertyFull
   , matchPropertyChanged
@@ -28,7 +28,7 @@ module DBus.Internal
   , bodyToMaybe
   ) where
 
-import           Control.Exception
+-- import           Control.Exception
 import           Control.Monad
 
 import           Data.Bifunctor
@@ -144,26 +144,26 @@ matchPropertyChanged _ _ _ = Failure
 --------------------------------------------------------------------------------
 -- | Client requests
 
-getDBusClient :: Bool -> IO (Maybe Client)
+-- getDBusClient :: Bool -> IO (Maybe Client)
-getDBusClient sys = do
+-- getDBusClient sys = do
-  res <- try $ if sys then connectSystem else connectSession
+--   res <- try $ if sys then connectSystem else connectSession
-  case res of
+--   case res of
-    Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
+--     Left e  -> putStrLn (clientErrorMessage e) >> return Nothing
-    Right c -> return $ Just c
+--     Right c -> return $ Just c
 
-withDBusClient :: Bool -> (Client -> IO a) -> IO (Maybe a)
+-- withDBusClient :: Bool -> (c -> IO a) -> IO (Maybe a)
-withDBusClient sys f = do
+-- withDBusClient sys f = do
-  client <- getDBusClient sys
+--   client <- getDBusClient sys
-  forM client $ \c -> do
+--   forM client $ \c -> do
-    r <- f c
+--     r <- f c
-    disconnect c
+--     disconnect c
-    return r
+--     return r
 
-withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
+-- withDBusClient_ :: Bool -> (Client -> IO ()) -> IO ()
-withDBusClient_ sys = void . withDBusClient sys
+-- withDBusClient_ sys = void . withDBusClient sys
 
-fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
+-- fromDBusClient :: Bool -> (Client -> a) -> IO (Maybe a)
-fromDBusClient sys f = withDBusClient sys (return . f)
+-- fromDBusClient sys f = withDBusClient sys (return . f)
 
 --------------------------------------------------------------------------------
 -- | Object Manager

lib/XMonad/Internal/Command/DMenu.hs

@@ -18,7 +18,6 @@ module XMonad.Internal.Command.DMenu
 import           Control.Monad.Reader
 
 import           DBus
-import           DBus.Client
 
 import           Graphics.X11.Types
 
@@ -137,7 +136,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: SometimesX
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: Maybe Client -> SometimesX
+runNetMenu :: Maybe SysClient -> SometimesX
 runNetMenu cl =
   sometimesDBus cl "network control menu" "rofi NetworkManager" tree cmd
   where
@@ -155,7 +154,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- | Password manager
 
-runBwMenu :: Maybe Client -> SometimesX
+runBwMenu :: Maybe SesClient -> SometimesX
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
     cmd _ = spawnCmd myDmenuPasswords

lib/XMonad/Internal/Command/Desktop.hs

@@ -43,7 +43,6 @@ import           Control.Monad               (void)
 import           Control.Monad.IO.Class
 
 import           DBus
-import           DBus.Client
 
 import           System.Directory
 import           System.Environment
@@ -215,7 +214,7 @@ runVolumeMute = featureSound "mute" volumeChangeSound (void toggleMute) $ return
 --------------------------------------------------------------------------------
 -- | Notification control
 
-runNotificationCmd :: String -> FilePath -> Maybe Client -> SometimesX
+runNotificationCmd :: String -> FilePath -> Maybe SesClient -> SometimesX
 runNotificationCmd n arg cl =
   sometimesDBus cl (n ++ " control") "dunstctl" tree cmd
   where
@@ -224,18 +223,18 @@ runNotificationCmd n arg cl =
       $ Endpoint [] notifyBus notifyPath (interfaceName_ "org.dunstproject.cmd0")
       $ Method_ $ memberName_ "NotificationAction"
 
-runNotificationClose :: Maybe Client -> SometimesX
+runNotificationClose :: Maybe SesClient -> SometimesX
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: Maybe Client -> SometimesX
+runNotificationCloseAll :: Maybe SesClient -> SometimesX
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: Maybe Client -> SometimesX
+runNotificationHistory :: Maybe SesClient -> SometimesX
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: Maybe Client -> SometimesX
+runNotificationContext :: Maybe SesClient -> SometimesX
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
@@ -243,7 +242,7 @@ runNotificationContext =
 -- | System commands
 
 -- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe Client -> Sometimes (IO ProcessHandle)
+runNetAppDaemon :: Maybe SysClient -> Sometimes (IO ProcessHandle)
 runNetAppDaemon cl = Sometimes "network applet" xpfVPN
   [Subfeature (DBusRoot_ cmd tree cl) "NM-applet"]
   where
@@ -251,7 +250,7 @@ runNetAppDaemon cl = Sometimes "network applet" xpfVPN
     app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
     cmd _ = snd <$> spawnPipe "nm-applet"
 
-runToggleBluetooth :: Maybe Client -> SometimesX
+runToggleBluetooth :: Maybe SysClient -> SometimesX
 runToggleBluetooth cl = Sometimes "bluetooth toggle" xpfBluetooth
   [Subfeature (DBusRoot_ cmd tree cl) "bluetoothctl"]
   where
@@ -306,7 +305,7 @@ getCaptureDir = do
   where
     fallback = (</> ".local/share") <$> getHomeDirectory
 
-runFlameshot :: String -> String -> Maybe Client -> SometimesX
+runFlameshot :: String -> String -> Maybe SesClient -> SometimesX
 runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
   where
     cmd _ = spawnCmd myCapture [mode]
@@ -315,15 +314,15 @@ runFlameshot n mode cl = sometimesDBus cl n myCapture tree cmd
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: Maybe Client -> SometimesX
+runAreaCapture :: Maybe SesClient -> SometimesX
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: Maybe Client -> SometimesX
+runDesktopCapture :: Maybe SesClient -> SometimesX
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: Maybe Client -> SometimesX
+runScreenCapture :: Maybe SesClient -> SometimesX
 runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: SometimesX

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

@@ -15,7 +15,6 @@ import           Control.Monad                          (when)
 import           Data.Int                               (Int32)
 
 import           DBus
-import           DBus.Client
 
 import           System.FilePath.Posix
 
@@ -113,18 +112,18 @@ stateFileDep = pathRW stateFile [Package AUR "tuxedo-keyboard"]
 brightnessFileDep :: IODependency_
 brightnessFileDep = pathR brightnessFile [Package AUR "tuxedo-keyboard"]
 
-clevoKeyboardSignalDep :: DBusDependency_
+clevoKeyboardSignalDep :: DBusDependency_ SesClient
 clevoKeyboardSignalDep = signalDep clevoKeyboardConfig
 
-exportClevoKeyboard :: Maybe Client -> SometimesIO
+exportClevoKeyboard :: Maybe SesClient -> SometimesIO
 exportClevoKeyboard = brightnessExporter xpfClevoBacklight []
   [stateFileDep, brightnessFileDep] clevoKeyboardConfig
 
-clevoKeyboardControls :: Maybe Client -> BrightnessControls
+clevoKeyboardControls :: Maybe SesClient -> BrightnessControls
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 
-callGetBrightnessCK :: Client -> IO (Maybe Brightness)
+callGetBrightnessCK :: SesClient -> IO (Maybe Brightness)
-callGetBrightnessCK = callGetBrightness clevoKeyboardConfig
+callGetBrightnessCK = callGetBrightness clevoKeyboardConfig . toClient
 
-matchSignalCK :: (Maybe Brightness -> IO ()) -> Client -> IO ()
+matchSignalCK :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
-matchSignalCK = matchSignal clevoKeyboardConfig
+matchSignalCK cb = matchSignal clevoKeyboardConfig cb . toClient

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

@@ -52,9 +52,9 @@ data BrightnessControls = BrightnessControls
   , bctlDec :: SometimesIO
   }
 
-brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe Client
+brightnessControls :: XPQuery -> BrightnessConfig a b -> Maybe SesClient
   -> BrightnessControls
-brightnessControls q bc client =
+brightnessControls q bc cl =
   BrightnessControls
   { bctlMax = cb "max brightness" memMax
   , bctlMin = cb "min brightness" memMin
@@ -62,14 +62,14 @@ brightnessControls q bc client =
   , bctlDec = cb "decrease brightness" memDec
   }
   where
-    cb = callBacklight q client bc
+    cb = callBacklight q cl bc
 
 callGetBrightness :: Num c => BrightnessConfig a b -> Client -> IO (Maybe c)
 callGetBrightness BrightnessConfig { bcPath = p, bcInterface = i } client =
   either (const Nothing) bodyGetBrightness
   <$> callMethod client xmonadBusName p i memGet
 
-signalDep :: BrightnessConfig a b -> DBusDependency_
+signalDep :: BrightnessConfig a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig { bcPath = p, bcInterface = i } =
   Endpoint [] xmonadBusName p i $ Signal_ memCur
 
@@ -88,20 +88,21 @@ matchSignal BrightnessConfig { bcPath = p, bcInterface = i } cb =
 -- | Internal DBus Crap
 
 brightnessExporter :: RealFrac b => XPQuery -> [Fulfillment] -> [IODependency_]
-  -> BrightnessConfig a b -> Maybe Client -> SometimesIO
+  -> BrightnessConfig a b -> Maybe SesClient -> SometimesIO
 brightnessExporter q ful deps bc@BrightnessConfig { bcName = n } cl =
   Sometimes (n ++ " DBus Interface") q [Subfeature root "exporter"]
   where
     root = DBusRoot_ (exportBrightnessControls' bc) tree cl
     tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
-exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> Client -> IO ()
+exportBrightnessControls' :: RealFrac b => BrightnessConfig a b -> SesClient -> IO ()
-exportBrightnessControls' bc client = do
+exportBrightnessControls' bc cl = do
+  let ses = toClient cl
   maxval <- bcGetMax bc -- assume the max value will never change
   let bounds = (bcMinRaw bc, maxval)
-  let autoMethod' m f = autoMethod m $ emitBrightness bc client =<< f bc bounds
+  let autoMethod' m f = autoMethod m $ emitBrightness bc ses =<< f bc bounds
   let funget = bcGet bc
-  export client (bcPath bc) defaultInterface
+  export ses (bcPath bc) defaultInterface
     { interfaceName = bcInterface bc
     , interfaceMethods =
       [ autoMethod' memMax bcMax
@@ -130,7 +131,7 @@ emitBrightness BrightnessConfig{ bcPath = p, bcInterface = i } client cur =
   where
     sig = signal p i memCur
 
-callBacklight :: XPQuery -> Maybe Client -> BrightnessConfig a b -> String
+callBacklight :: XPQuery -> Maybe SesClient -> BrightnessConfig a b -> String
   -> MemberName -> SometimesIO
 callBacklight q cl BrightnessConfig { bcPath = p
                                     , bcInterface = i
@@ -138,7 +139,7 @@ callBacklight q cl BrightnessConfig { bcPath = p
   Sometimes (unwords [n, controlName]) q [Subfeature root "method call"]
   where
     root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
-    cmd c = io $ void $ callMethod c xmonadBusName p i m
+    cmd c = io $ void $ callMethod (toClient c) xmonadBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -13,7 +13,6 @@ module XMonad.Internal.DBus.Brightness.IntelBacklight
 import           Data.Int                               (Int32)
 
 import           DBus
-import           DBus.Client
 
 import           System.FilePath.Posix
 
@@ -95,18 +94,18 @@ curFileDep = pathRW curFile []
 maxFileDep :: IODependency_
 maxFileDep = pathR maxFile []
 
-intelBacklightSignalDep :: DBusDependency_
+intelBacklightSignalDep :: DBusDependency_ SesClient
 intelBacklightSignalDep = signalDep intelBacklightConfig
 
-exportIntelBacklight :: Maybe Client -> SometimesIO
+exportIntelBacklight :: Maybe SesClient -> SometimesIO
 exportIntelBacklight = brightnessExporter xpfIntelBacklight []
   [curFileDep, maxFileDep] intelBacklightConfig
 
-intelBacklightControls :: Maybe Client -> BrightnessControls
+intelBacklightControls :: Maybe SesClient -> BrightnessControls
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 
-callGetBrightnessIB :: Client -> IO (Maybe Brightness)
+callGetBrightnessIB :: SesClient -> IO (Maybe Brightness)
-callGetBrightnessIB = callGetBrightness intelBacklightConfig
+callGetBrightnessIB = callGetBrightness intelBacklightConfig . toClient
 
-matchSignalIB :: (Maybe Brightness -> IO ()) -> Client -> IO ()
+matchSignalIB :: (Maybe Brightness -> IO ()) -> SesClient -> IO ()
-matchSignalIB = matchSignal intelBacklightConfig
+matchSignalIB cb = matchSignal intelBacklightConfig cb . toClient

lib/XMonad/Internal/DBus/Control.hs

@@ -21,7 +21,6 @@ import           Control.Monad
 
 import           DBus
 import           DBus.Client
-import           DBus.Internal
 
 import           XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import           XMonad.Internal.DBus.Brightness.IntelBacklight
@@ -31,36 +30,37 @@ import           XMonad.Internal.Dependency
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-    { dbSesClient :: Maybe Client
+    { dbSesClient :: Maybe SesClient
-    , dbSysClient :: Maybe Client
+    , dbSysClient :: Maybe SysClient
     }
 
 -- | Connect to the DBus
 connectDBus :: IO DBusState
 connectDBus = do
-  ses <- getDBusClient False
+  ses <- getDBusClient
-  sys <- getDBusClient True
+  sys <- getDBusClient
   return DBusState { dbSesClient = ses, dbSysClient = sys }
 
+-- TODO why is this only the session client?
 -- | Disconnect from the DBus
 disconnectDBus :: DBusState -> IO ()
-disconnectDBus db = forM_ (dbSysClient db) disconnect
+disconnectDBus db = forM_ (toClient <$> dbSysClient db) disconnect
 
 -- | Connect to the DBus and request the XMonad name
 connectDBusX :: IO DBusState
 connectDBusX = do
   db <- connectDBus
-  forM_ (dbSesClient db) requestXMonadName
+  forM_ (toClient <$> dbSesClient db) requestXMonadName
   return db
 
 -- | Disconnect from DBus and release the XMonad name
 disconnectDBusX :: DBusState -> IO ()
 disconnectDBusX db = do
-  forM_ (dbSesClient db) releaseXMonadName
+  forM_ (toClient <$> dbSesClient db) releaseXMonadName
   disconnectDBus db
 
 -- | All exporter features to be assigned to the DBus
-dbusExporters :: [Maybe Client -> SometimesIO]
+dbusExporters :: [Maybe SesClient -> SometimesIO]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 releaseXMonadName :: Client -> IO ()

lib/XMonad/Internal/DBus/Removable.hs

@@ -32,13 +32,13 @@ memAdded = memberName_ "InterfacesAdded"
 memRemoved :: MemberName
 memRemoved = memberName_ "InterfacesRemoved"
 
-dbusDep :: MemberName -> DBusDependency_
+dbusDep :: MemberName -> DBusDependency_ SysClient
 dbusDep m = Endpoint [Package Official "udisks2"] bus path interface $ Signal_ m
 
-addedDep :: DBusDependency_
+addedDep :: DBusDependency_ SysClient
 addedDep = dbusDep memAdded
 
-removedDep :: DBusDependency_
+removedDep :: DBusDependency_ SysClient
 removedDep = dbusDep memRemoved
 
 driveInsertedSound :: FilePath
@@ -73,15 +73,15 @@ playSoundMaybe p b = when b $ io $ playSound p
 -- If it not already, we won't see any signals from the dbus until it is
 -- started (it will work after it is started however). It seems safe to simply
 -- enable the udisks2 service at boot; however this is not default behavior.
-listenDevices :: Client -> IO ()
+listenDevices :: SysClient -> IO ()
-listenDevices client = do
+listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
   addMatch' memRemoved driveRemovedSound removedHasDrive
   where
-    addMatch' m p f = void $ addMatch client ruleUdisks { matchMember = Just m }
+    addMatch' m p f = void $ addMatch (toClient cl) ruleUdisks { matchMember = Just m }
       $ playSoundMaybe p . f . signalBody
 
-runRemovableMon :: Maybe Client -> SometimesIO
+runRemovableMon :: Maybe SysClient -> SometimesIO
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices
   where

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -94,14 +94,15 @@ bodyGetCurrentState _   = Nothing
 --------------------------------------------------------------------------------
 -- | Exported haskell API
 
-exportScreensaver :: Maybe Client -> SometimesIO
+exportScreensaver :: Maybe SesClient -> SometimesIO
-exportScreensaver client =
+exportScreensaver ses =
-  sometimesDBus client "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
+  sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
   where
-    cmd cl = export cl ssPath defaultInterface
+    cmd cl = let cl' = toClient cl in
+      export cl' ssPath defaultInterface
       { interfaceName = interface
       , interfaceMethods =
-        [ autoMethod memToggle $ emitState cl =<< toggle
+        [ autoMethod memToggle $ emitState cl' =<< toggle
         , autoMethod memQuery query
         ]
       , interfaceSignals = [sig]
@@ -119,7 +120,7 @@ exportScreensaver client =
     bus = Bus [] xmonadBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
-callToggle :: Maybe Client -> SometimesIO
+callToggle :: Maybe SesClient -> SometimesIO
 callToggle = sometimesEndpoint "screensaver toggle" "dbus switch" []
   xmonadBusName ssPath interface memToggle
 
@@ -128,9 +129,9 @@ callQuery client = do
   reply <- callMethod client xmonadBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
-matchSignal :: (Maybe SSState -> IO ()) -> Client -> IO ()
+matchSignal :: (Maybe SSState -> IO ()) -> SesClient -> IO ()
-matchSignal cb =
+matchSignal cb ses = void $ addMatchCallback ruleCurrentState
-  fmap void . addMatchCallback ruleCurrentState $ cb . bodyGetCurrentState
+  (cb . bodyGetCurrentState) $ toClient ses
 
-ssSignalDep :: DBusDependency_
+ssSignalDep :: DBusDependency_ SesClient
 ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState

lib/XMonad/Internal/Dependency.hs

@@ -40,6 +40,9 @@ module XMonad.Internal.Dependency
   , IOTree_
   , DBusTree
   , DBusTree_
+  , SafeClient(..)
+  , SysClient(..)
+  , SesClient(..)
   , IODependency(..)
   , IODependency_(..)
   , SystemDependency(..)
@@ -109,6 +112,7 @@ module XMonad.Internal.Dependency
   , shellTest
   ) where
 
+import           Control.Exception       hiding (bracket)
 import           Control.Monad.IO.Class
 import           Control.Monad.Identity
 import           Control.Monad.Reader
@@ -293,8 +297,49 @@ type SubfeatureRoot a = Subfeature (Root a)
 -- needed
 data Root a = forall p. IORoot (p -> a) (IOTree p)
   | IORoot_ a IOTree_
-  | forall p. DBusRoot (p -> Client -> a) (DBusTree p) (Maybe Client)
+  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
-  | DBusRoot_ (Client -> a) DBusTree_ (Maybe Client)
+  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
+
+class SafeClient c where
+  toClient :: c -> Client
+
+  getDBusClient :: IO (Maybe c)
+
+  withDBusClient :: (c -> IO a) -> IO (Maybe a)
+  withDBusClient f = do
+    client <- getDBusClient
+    forM client $ \c -> do
+      r <- f c
+      disconnect (toClient c)
+      return r
+
+  withDBusClient_ :: (c -> IO ()) -> IO ()
+  withDBusClient_ = void . withDBusClient
+
+  fromDBusClient :: (c -> a) -> IO (Maybe a)
+  fromDBusClient f = withDBusClient (return . f)
+
+newtype SysClient = SysClient Client
+
+instance SafeClient SysClient where
+  toClient (SysClient cl) = cl
+
+  getDBusClient = fmap SysClient <$> getDBusClient' True
+
+newtype SesClient = SesClient Client
+
+instance SafeClient SesClient where
+  toClient (SesClient cl) = cl
+
+  getDBusClient = fmap SesClient <$> getDBusClient' False
+
+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
+
 
 -- | The dependency tree with rule to merge results when needed
 data Tree d d_ p =
@@ -309,9 +354,9 @@ data Tree_ d = And_ (Tree_ d) (Tree_ d) | Or_ (Tree_ d) (Tree_ d) | Only_ d
 
 -- | Shorthand tree types for lazy typers
 type IOTree p = Tree IODependency IODependency_ p
-type DBusTree p = Tree IODependency DBusDependency_ p
+type DBusTree c p = Tree IODependency (DBusDependency_ c) p
 type IOTree_ = Tree_ IODependency_
-type DBusTree_ = Tree_ DBusDependency_
+type DBusTree_ c = Tree_ (DBusDependency_ c)
 
 -- | A dependency that only requires IO to evaluate (with payload)
 data IODependency p =
@@ -325,12 +370,12 @@ data IODependency p =
   | forall a. IOSometimes (Sometimes a) (a -> p)
 
 -- | A dependency pertaining to the DBus
-data DBusDependency_ = Bus [Fulfillment] BusName
+data DBusDependency_ c = Bus [Fulfillment] BusName
   | Endpoint [Fulfillment] BusName ObjectPath InterfaceName DBusMember
   | DBusIO IODependency_
   deriving (Eq, Generic)
 
-instance Hashable DBusDependency_ where
+instance Hashable (DBusDependency_ c) where
   hashWithSalt s (Bus f b)            = s `hashWithSalt` f
                                         `hashWithSalt` formatBusName b
   hashWithSalt s (Endpoint f b o i m) = s `hashWithSalt` f
@@ -445,7 +490,8 @@ data PostFail = PostFail [Msg] | PostMissing Msg
 -- that the results will always be the same.
 
 emptyCache :: Cache
-emptyCache = Cache H.empty H.empty H.empty
+-- emptyCache = Cache H.empty H.empty H.empty
+emptyCache = Cache H.empty H.empty
 
 memoizeIO_ :: (IODependency_ -> FIO Result_) -> IODependency_ -> FIO Result_
 memoizeIO_ f d = do
@@ -458,16 +504,17 @@ memoizeIO_ f d = do
       modify (\s -> s { cIO_ = H.insert d r (cIO_ s) })
       return r
 
-memoizeDBus_ :: (DBusDependency_ -> FIO Result_) -> DBusDependency_ -> FIO Result_
+-- memoizeDBus_ :: SafeClient c => (DBusDependency_ c -> FIO Result_)
-memoizeDBus_ f d = do
+--   -> DBusDependency_ c -> FIO Result_
-  m <- gets cDBus_
+-- memoizeDBus_ get f d = do
-  case H.lookup d m of
+--   m <- gets cDBus_
-    (Just r) -> return r
+--   case H.lookup d m of
-    Nothing  -> do
+--     (Just r) -> return r
-      -- io $ putStrLn $ "not using cache for " ++ show d
+--     Nothing  -> do
-      r <- f d
+--       -- io $ putStrLn $ "not using cache for " ++ show d
-      modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
+--       r <- f d
-      return r
+--       modify (\s -> s { cDBus_ = H.insert d r (cDBus_ s) })
+--       return r
 
 memoizeFont :: (String -> IO (Result FontBuilder)) -> String -> FIO (Result FontBuilder)
 memoizeFont f d = do
@@ -549,7 +596,7 @@ type XPQuery = XPFeatures -> Bool
 data Cache = Cache
   { --cIO    :: forall p. Memoizable p => H.HashMap (IODependency p) (Result p)
     cIO_  :: H.HashMap IODependency_ Result_
-  , cDBus_ :: H.HashMap DBusDependency_ Result_
+  -- , cDBus_ :: forall c. H.HashMap (DBusDependency_ c) Result_
   , cFont :: H.HashMap String (Result FontBuilder)
   }
 
@@ -884,12 +931,13 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDependency_ :: Client -> DBusDependency_ -> FIO Result_
+testDBusDependency_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
-testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
+-- testDBusDependency_ cl = memoizeDBus_ (testDBusDependency'_ cl)
+testDBusDependency_ = testDBusDependency'_
 
-testDBusDependency'_ :: Client -> DBusDependency_ -> FIO Result_
+testDBusDependency'_ :: SafeClient c => c -> DBusDependency_ c -> FIO Result_
 testDBusDependency'_ cl (Bus _ bus) = io $ do
-  ret <- callMethod cl queryBus queryPath queryIface queryMem
+  ret <- callMethod (toClient cl) queryBus queryPath queryIface queryMem
   return $ case ret of
         Left e    -> Left [Msg Error e]
         Right b -> let ns = bodyGetNames b in
@@ -907,7 +955,7 @@ testDBusDependency'_ cl (Bus _ bus) = io $ do
     bodyGetNames _   = []
 
 testDBusDependency'_ cl (Endpoint _ busname objpath iface mem) = io $ do
-  ret <- callMethod cl busname objpath introspectInterface introspectMethod
+  ret <- callMethod (toClient cl) busname objpath introspectInterface introspectMethod
   return $ case ret of
         Left e     -> Left [Msg Error e]
         Right body -> procBody body
@@ -996,18 +1044,18 @@ sometimesExeArgs :: MonadIO m => String -> String -> [Fulfillment] -> Bool
 sometimesExeArgs fn n ful sys path args =
   sometimesIO_ fn n (Only_ (IOSystem_ ful $ Executable sys path)) $ spawnCmd path args
 
-sometimesDBus :: Maybe Client -> String -> String -> Tree_ DBusDependency_
+sometimesDBus :: SafeClient c => Maybe c -> String -> String
-  -> (Client -> a) -> Sometimes a
+  -> Tree_ (DBusDependency_ c) -> (c -> a) -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
 
-sometimesEndpoint :: MonadIO m => String -> String -> [Fulfillment]
+sometimesEndpoint :: (SafeClient c, MonadIO m) => String -> String
-  -> BusName -> ObjectPath -> InterfaceName -> MemberName -> Maybe Client
+  -> [Fulfillment] -> BusName -> ObjectPath -> InterfaceName -> MemberName
-  -> Sometimes (m ())
+  -> Maybe c -> Sometimes (m ())
 sometimesEndpoint fn name ful busname path iface mem cl =
   sometimesDBus cl fn name deps cmd
   where
     deps = Only_ $ Endpoint ful busname path iface $ Method_ mem
-    cmd c = io $ void $ callMethod c busname path iface mem
+    cmd c = io $ void $ callMethod (toClient c) busname path iface mem
 
 --------------------------------------------------------------------------------
 -- | Dependency Tree Constructors
@@ -1207,7 +1255,7 @@ dataSysDependency f d = first Q $
     f' = ("fulfilment", JSON_UQ $ dataFulfillments f)
 
 
-dataDBusDependency :: DBusDependency_ -> DependencyData
+dataDBusDependency :: DBusDependency_ c -> DependencyData
 dataDBusDependency d =
   case d of
     (DBusIO i)         -> dataIODependency_ i

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -6,14 +6,13 @@
 
 module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
-import           DBus.Client
+import           XMonad.Internal.Dependency
-
 import           Xmobar.Plugins.Common
 
-startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> Client -> IO ())
+startBacklight :: RealFrac a => ((Maybe a -> IO ()) -> SesClient -> IO ())
-  -> (Client -> IO (Maybe a)) -> String -> Callback -> IO ()
+  -> (SesClient -> IO (Maybe a)) -> String -> Callback -> IO ()
 startBacklight matchSignal callGetBrightness icon cb = do
-    withDBusClientConnection False cb $ \c -> do
+    withDBusClientConnection cb $ \c -> do
       matchSignal display c
       display =<< callGetBrightness c
     where

lib/Xmobar/Plugins/Bluetooth.hs

@@ -56,7 +56,7 @@ import           Xmobar.Plugins.Common
 btAlias :: String
 btAlias = "bluetooth"
 
-btDep :: DBusDependency_
+btDep :: DBusDependency_ SysClient
 btDep = Endpoint [Package Official "bluez"] btBus btOMPath omInterface
   $ Method_ getManagedObjects
 
@@ -65,9 +65,9 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
   alias (Bluetooth _ _) = btAlias
   start (Bluetooth icons colors) cb =
-    withDBusClientConnection True cb $ startAdapter icons colors cb
+    withDBusClientConnection cb $ startAdapter icons colors cb
 
-startAdapter :: Icons -> Colors -> Callback -> Client -> IO ()
+startAdapter :: Icons -> Colors -> Callback -> SysClient -> IO ()
 startAdapter is cs cb cl = do
   ot <- getBtObjectTree cl
   state <- newMVar emptyState
@@ -157,29 +157,29 @@ adaptorHasDevice adaptor device = case splitPath device of
 splitPath :: ObjectPath -> [String]
 splitPath = splitOn "/" . dropWhile (=='/') . formatObjectPath
 
-getBtObjectTree :: Client -> IO ObjectTree
+getBtObjectTree :: SysClient -> IO ObjectTree
-getBtObjectTree client = callGetManagedObjects client btBus btOMPath
+getBtObjectTree sys = callGetManagedObjects (toClient sys) btBus btOMPath
 
 btOMPath :: ObjectPath
 btOMPath = objectPath_ "/"
 
-addBtOMListener :: SignalCallback -> Client -> IO ()
+addBtOMListener :: SignalCallback -> SysClient -> IO ()
-addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc
+addBtOMListener sc = void . addInterfaceAddedListener btBus btOMPath sc . toClient
 
-addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addDeviceAddedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
 addDeviceAddedListener state display adapter client =
   addBtOMListener addDevice client
   where
     addDevice = pathCallback adapter display $ \d ->
       addAndInitDevice state display d client
 
-addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addDeviceRemovedListener :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
-addDeviceRemovedListener state display adapter client =
+addDeviceRemovedListener state display adapter sys =
-  addBtOMListener remDevice client
+  addBtOMListener remDevice sys
   where
     remDevice = pathCallback adapter display $ \d -> do
       old <- removeDevice state d
-      forM_ old $ removeMatch client . btDevSigHandler
+      forM_ old $ removeMatch (toClient sys) . btDevSigHandler
 
 pathCallback :: ObjectPath -> IO () -> (ObjectPath -> IO ()) -> SignalCallback
 pathCallback adapter display f [device, _] = forM_ (fromVariant device) $ \d ->
@@ -189,25 +189,25 @@ pathCallback _ _ _ _ = return ()
 --------------------------------------------------------------------------------
 -- | Adapter
 
-initAdapter :: MutableBtState -> ObjectPath -> Client -> IO ()
+initAdapter :: MutableBtState -> ObjectPath -> SysClient -> IO ()
 initAdapter state adapter client = do
   reply <- callGetPowered adapter client
   putPowered state $ fromSingletonVariant reply
 
-matchBTProperty :: Client -> ObjectPath -> IO (Maybe MatchRule)
+matchBTProperty :: SysClient -> ObjectPath -> IO (Maybe MatchRule)
-matchBTProperty client p = matchPropertyFull client btBus (Just p)
+matchBTProperty client p = matchPropertyFull (toClient client) btBus (Just p)
 
-addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> Client
+addAdaptorListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
   -> IO (Maybe SignalHandler)
-addAdaptorListener state display adaptor client = do
+addAdaptorListener state display adaptor sys = do
-  rule <- matchBTProperty client adaptor
+  rule <- matchBTProperty sys adaptor
-  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) client
+  forM rule $ \r -> addMatchCallback r (procMatch . matchPowered) (toClient sys)
   where
     procMatch = withSignalMatch $ \b -> putPowered state b >> display
 
-callGetPowered :: ObjectPath -> Client -> IO [Variant]
+callGetPowered :: ObjectPath -> SysClient -> IO [Variant]
-callGetPowered adapter =
+callGetPowered adapter sys =
-  callPropertyGet btBus adapter adapterInterface $ memberName_ adaptorPowered
+  callPropertyGet btBus adapter adapterInterface (memberName_ adaptorPowered) $ toClient sys
 
 matchPowered :: [Variant] -> SignalMatch Bool
 matchPowered = matchPropertyChanged adapterInterface adaptorPowered
@@ -227,25 +227,25 @@ adaptorPowered = "Powered"
 --------------------------------------------------------------------------------
 -- | Devices
 
-addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> Client -> IO ()
+addAndInitDevice :: MutableBtState -> IO () -> ObjectPath -> SysClient -> IO ()
 addAndInitDevice state display device client = do
   sh <- addDeviceListener state display device client
   -- TODO add some intelligent error messages here
   forM_ sh $ \s -> initDevice state s device client
 
-initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> Client -> IO ()
+initDevice :: MutableBtState -> SignalHandler -> ObjectPath -> SysClient -> IO ()
 initDevice state sh device client = do
-  reply <- callGetConnected device client
+  reply <- callGetConnected device (toClient client)
   void $ insertDevice state device $
     BTDevice { btDevConnected = fromVariant =<< listToMaybe reply
              , btDevSigHandler = sh
              }
 
-addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> Client
+addDeviceListener :: MutableBtState -> IO () -> ObjectPath -> SysClient
   -> IO (Maybe SignalHandler)
 addDeviceListener state display device client = do
   rule <- matchBTProperty client device
-  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) client
+  forM rule $ \r -> addMatchCallback r (procMatch . matchConnected) (toClient client)
   where
     procMatch = withSignalMatch $ \c -> updateDevice state device c >> display
 

lib/Xmobar/Plugins/Common.hs

@@ -21,6 +21,7 @@ import           DBus.Client
 import           DBus.Internal
 
 import           XMonad.Hooks.DynamicLog    (xmobarColor)
+import           XMonad.Internal.Dependency
 
 type Callback = String -> IO ()
 
@@ -59,5 +60,5 @@ 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 :: SafeClient c => Callback -> (c -> IO ()) -> IO ()
-withDBusClientConnection sys cb f = displayMaybe' cb f =<< getDBusClient sys
+withDBusClientConnection cb f = displayMaybe' cb f =<< getDBusClient

lib/Xmobar/Plugins/Device.hs

@@ -1,14 +1,14 @@
+--------------------------------------------------------------------------------
+-- | Device plugin
+--
+-- Display different text depending on whether or not the interface has
+-- connectivity
+
 module Xmobar.Plugins.Device
   ( Device(..)
   , devDep
   ) where
 
---------------------------------------------------------------------------------
--- | Devince plugin
---
--- Display different text depending on whether or not the interface has
--- connectivity
-
 import           Control.Monad
 
 import           Data.Word
@@ -18,15 +18,13 @@ import           DBus.Client
 import           DBus.Internal
 
 import           XMonad.Internal.Command.Desktop
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common
 
 newtype Device = Device (String, String, Colors) deriving (Read, Show)
 
-nmBus :: BusName
-nmBus = busName_ "org.freedesktop.NetworkManager"
-
 nmPath :: ObjectPath
 nmPath = objectPath_ "/org/freedesktop/NetworkManager"
 
@@ -42,18 +40,19 @@ getByIP = memberName_ "GetDeviceByIpIface"
 devSignal :: String
 devSignal = "Ip4Connectivity"
 
-devDep :: DBusDependency_
+devDep :: DBusDependency_ SysClient
-devDep = Endpoint networkManagerPkgs nmBus nmPath nmInterface $ Method_ getByIP
+devDep = Endpoint networkManagerPkgs networkManagerBus nmPath nmInterface
+  $ Method_ getByIP
 
-getDevice :: Client -> String -> IO (Maybe ObjectPath)
+getDevice :: SysClient -> String -> IO (Maybe ObjectPath)
-getDevice client iface = bodyToMaybe <$> callMethod' client mc
+getDevice cl iface = bodyToMaybe <$> callMethod' (toClient cl) mc
   where
-    mc = (methodCallBus nmBus nmPath nmInterface getByIP)
+    mc = (methodCallBus networkManagerBus nmPath nmInterface getByIP)
       { methodCallBody = [toVariant iface]
       }
 
 getDeviceConnected :: ObjectPath -> Client -> IO [Variant]
-getDeviceConnected path = callPropertyGet nmBus path nmDeviceInterface
+getDeviceConnected path = callPropertyGet networkManagerBus path nmDeviceInterface
   $ memberName_ devSignal
 
 matchStatus :: [Variant] -> SignalMatch Word32
@@ -62,13 +61,13 @@ matchStatus = matchPropertyChanged nmDeviceInterface devSignal
 instance Exec Device where
   alias (Device (iface, _, _)) = iface
   start (Device (iface, text, colors)) cb = do
-    withDBusClientConnection True cb $ \client -> do
+    withDBusClientConnection cb $ \client -> do
       path <- getDevice client iface
       displayMaybe' cb (listener client) path
     where
       listener client path = do
-        rule <- matchPropertyFull client nmBus (Just path)
+        rule <- matchPropertyFull (toClient client) networkManagerBus (Just path)
         -- TODO warn the user here rather than silently drop the listener
         forM_ rule $ \r ->
-          startListener r (getDeviceConnected path) matchStatus chooseColor' cb client
+          startListener r (getDeviceConnected path) matchStatus chooseColor' cb (toClient client)
       chooseColor' = return . (\s -> colorText colors s text) . (> 1)

lib/Xmobar/Plugins/Screensaver.hs

@@ -12,6 +12,7 @@ module Xmobar.Plugins.Screensaver
 import           Xmobar
 
 import           XMonad.Internal.DBus.Screensaver
+import           XMonad.Internal.Dependency
 import           Xmobar.Plugins.Common
 
 newtype Screensaver = Screensaver (String, Colors) deriving (Read, Show)
@@ -22,9 +23,9 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
   alias (Screensaver _) = ssAlias
   start (Screensaver (text, colors)) cb = do
-    withDBusClientConnection False cb $ \c -> do
+    withDBusClientConnection cb $ \c -> do
       matchSignal display c
-      display =<< callQuery c
+      display =<< callQuery (toClient c)
     where
       display = displayMaybe cb $ return . (\s -> colorText colors s text)
 

lib/Xmobar/Plugins/VPN.hs

@@ -19,10 +19,10 @@ import           Data.Maybe
 import qualified Data.Set                        as S
 
 import           DBus
-import           DBus.Client
 import           DBus.Internal
 
 import           XMonad.Internal.Command.Desktop
+import           XMonad.Internal.DBus.Common
 import           XMonad.Internal.Dependency
 import           Xmobar
 import           Xmobar.Plugins.Common
@@ -32,7 +32,7 @@ newtype VPN = VPN (String, Colors) deriving (Read, Show)
 instance Exec VPN where
   alias (VPN _) = vpnAlias
   start (VPN (text, colors)) cb =
-    withDBusClientConnection True cb $ \c -> do
+    withDBusClientConnection cb $ \c -> do
     state <- initState c
     let display = displayMaybe cb iconFormatter . Just =<< readState state
     let signalCallback' f = f state display
@@ -53,7 +53,7 @@ type VPNState = S.Set ObjectPath
 
 type MutableVPNState = MVar VPNState
 
-initState :: Client -> IO MutableVPNState
+initState :: SysClient -> IO MutableVPNState
 initState client = do
   ot <- getVPNObjectTree client
   newMVar $ findTunnels ot
@@ -69,17 +69,17 @@ updateState f state op = modifyMVar_ state $ return . f op
 -- | Tunnel Device Detection
 --
 
-getVPNObjectTree :: Client -> IO ObjectTree
+getVPNObjectTree :: SysClient -> IO ObjectTree
-getVPNObjectTree client = callGetManagedObjects client vpnBus vpnPath
+getVPNObjectTree client = callGetManagedObjects (toClient client) vpnBus vpnPath
 
 findTunnels :: ObjectTree -> VPNState
 findTunnels = S.fromList . M.keys . M.filter (elem vpnDeviceTun . M.keys)
 
-vpnAddedListener :: SignalCallback -> Client -> IO ()
+vpnAddedListener :: SignalCallback -> SysClient -> IO ()
-vpnAddedListener = fmap void . addInterfaceAddedListener vpnBus vpnPath
+vpnAddedListener cb = void . addInterfaceAddedListener vpnBus vpnPath cb . toClient
 
-vpnRemovedListener :: SignalCallback -> Client -> IO ()
+vpnRemovedListener :: SignalCallback -> SysClient -> IO ()
-vpnRemovedListener = fmap void . addInterfaceRemovedListener vpnBus vpnPath
+vpnRemovedListener cb = void . addInterfaceRemovedListener vpnBus vpnPath cb . toClient
 
 addedCallback :: MutableVPNState -> IO () -> SignalCallback
 addedCallback state display [device, added] = update >> display
@@ -119,6 +119,6 @@ vpnDeviceTun = "org.freedesktop.NetworkManager.Device.Tun"
 vpnAlias :: String
 vpnAlias = "vpn"
 
-vpnDep :: DBusDependency_
+vpnDep :: DBusDependency_ SysClient
-vpnDep = Endpoint networkManagerPkgs vpnBus vpnPath omInterface
+vpnDep = Endpoint networkManagerPkgs networkManagerBus vpnPath omInterface
   $ Method_ getManagedObjects