ENH use names for dbus connections

bin/xmobar.hs

@@ -63,7 +63,7 @@ parseTest =
 xio :: XOpts -> IO ()
 xio o = case o of
   XDeps -> hRunXIO False stderr printDeps
-  XTest -> hRunXIO False stderr $ withDBus_ evalConfig
+  XTest -> hRunXIO False stderr $ withDBus_ Nothing Nothing evalConfig
   XRun -> runXIO "xmobar.log" run
 
 run :: XIO ()
@@ -75,9 +75,9 @@ run = do
   -- linebuffering it usually only prints the first few characters (even then
   -- it only prints 10-20% of the time)
   liftIO $ hSetBuffering stderr LineBuffering
-  withDBus_ $ \db -> do
+  -- TODO do these dbus things really need to remain connected?
-    c <- evalConfig db
+  c <- withDBus Nothing Nothing evalConfig
-    liftIO $ xmobar c
+  liftIO $ xmobar c
 
 evalConfig :: DBusState -> XIO Config
 evalConfig db = do
@@ -88,7 +88,7 @@ evalConfig db = do
   return $ config bf ifs ios cs d
 
 printDeps :: XIO ()
-printDeps = withDBus_ $ \db ->
+printDeps = withDBus_ Nothing Nothing $ \db ->
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
@@ -218,7 +218,7 @@ getWireless =
     xpfWireless
     [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe SysClient -> BarFeature
+getEthernet :: Maybe NamedSysConnection -> BarFeature
 getEthernet cl = iconDBus_ "ethernet status indicator" xpfEthernet root (Only_ devDep)
   where
     root useIcon tree' =
@@ -234,12 +234,12 @@ getBattery = iconIO_ "battery level indicator" xpfBattery root tree
           io $
             fmap (Msg LevelError) <$> hasBattery
 
-getVPN :: Maybe SysClient -> BarFeature
+getVPN :: Maybe NamedSysConnection -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
 
-getBt :: Maybe SysClient -> BarFeature
+getBt :: Maybe NamedSysConnection -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
@@ -250,7 +250,7 @@ getAlsa =
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe SesClient -> BarFeature
+getBl :: Maybe NamedSesConnection -> BarFeature
 getBl =
   xmobarDBus
     "Intel backlight indicator"
@@ -258,7 +258,7 @@ getBl =
     intelBacklightSignalDep
     blCmd
 
-getCk :: Maybe SesClient -> BarFeature
+getCk :: Maybe NamedSesConnection -> BarFeature
 getCk =
   xmobarDBus
     "Clevo keyboard indicator"
@@ -266,7 +266,7 @@ getCk =
     clevoKeyboardSignalDep
     ckCmd
 
-getSs :: Maybe SesClient -> BarFeature
+getSs :: Maybe NamedSesConnection -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -283,7 +283,7 @@ xmobarDBus
   -> XPQuery
   -> DBusDependency_ c
   -> (Fontifier -> CmdSpec)
-  -> Maybe c
+  -> Maybe (NamedConnection c)
   -> BarFeature
 xmobarDBus n q dep cmd cl = iconDBus_ n q root (Only_ dep)
   where

bin/xmonad.hs

@@ -166,9 +166,9 @@ getCreateDirectories = do
 
 data FeatureSet = FeatureSet
   { fsKeys :: (XIO () -> IO ()) -> X () -> DBusState -> [KeyGroup FeatureX]
-  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
+  , fsDBusExporters :: [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe SysClient -> SometimesIO
+  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
   , fsDaemons :: [Sometimes (XIO (Process () () ()))]
   , fsACPIHandler :: Always (String -> X ())
   , fsTabbedTheme :: Always Theme
@@ -183,7 +183,7 @@ tabbedFeature = Always "theme for tabbed windows" $ Option sf fallback
     niceTheme = IORoot XT.tabbedTheme $ fontTree XT.defFontFamily defFontPkgs
     fallback = Always_ $ FallbackAlone $ XT.tabbedTheme XT.fallbackFont
 
-features :: Maybe SysClient -> FeatureSet
+features :: Maybe NamedSysConnection -> FeatureSet
 features cl =
   FeatureSet
     { fsKeys = externalBindings
@@ -251,7 +251,7 @@ stopChildDaemons = mapM_ stop
       liftIO $ killNoWait p
 
 printDeps :: XIO ()
-printDeps = withDBus_ $ \db -> do
+printDeps = withDBus_ Nothing Nothing $ \db -> do
   runIO <- askRunInIO
   let mockCleanup = runCleanup runIO mockClean db
   let bfs =
@@ -292,7 +292,7 @@ runCleanup runIO ts db = liftIO $ runIO $ do
   mapM_ stopXmobar $ clXmobar ts
   stopChildDaemons $ clChildren ts
   sequence_ $ clDBusUnexporters ts
-  disconnectDBusX db
+  disconnectDBus db
 
 -- | Kill a process (group) after xmonad has already started
 -- This is necessary (as opposed to 'stopProcess' from rio) because a) xmonad

lib/Data/Internal/DBus.hs

@@ -5,9 +5,13 @@ module Data.Internal.DBus
   ( SafeClient (..)
   , SysClient (..)
   , SesClient (..)
+  , NamedConnection (..)
+  , NamedSesConnection
+  , NamedSysConnection
   , DBusEnv (..)
   , DIO
   , HasClient (..)
+  , releaseBusName
   , withDIO
   , addMatchCallback
   , addMatchCallbackSignal
@@ -55,54 +59,129 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client
 
--- data NamedConnection c = NamedConnection
+data NamedConnection c = NamedConnection
---   { ncClient :: Client
+  { ncClient :: !Client
---   , ncName :: Maybe BusName
+  , ncHumanName :: !(Maybe BusName)
---   , ncType :: c
+  --, ncUniqueName :: !BusName
---   }
+  , ncType :: !c
+  }
+
+type NamedSesConnection = NamedConnection SesClient
+
+type NamedSysConnection = NamedConnection SysClient
 
 class SafeClient c where
-  toClient :: c -> Client
-
   getDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => m (Maybe c)
+    => Maybe BusName
+    -> m (Maybe (NamedConnection c))
 
-  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
+  disconnectDBusClient
-  disconnectDBusClient = liftIO . disconnect . toClient
+    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+    => NamedConnection c
+    -> m ()
+  disconnectDBusClient c = do
+    releaseBusName c
+    liftIO $ disconnect $ ncClient c
 
   withDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> m a)
+    => Maybe BusName
+    -> (NamedConnection c -> m a)
     -> m (Maybe a)
-  withDBusClient f =
+  withDBusClient n f =
-    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
+    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
 
   withDBusClient_
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> m ())
+    => Maybe BusName
+    -> (NamedConnection c -> m ())
     -> m ()
-  withDBusClient_ = void . withDBusClient
+  withDBusClient_ n = void . withDBusClient n
 
   fromDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => (c -> a)
+    => Maybe BusName
+    -> (NamedConnection c -> a)
     -> m (Maybe a)
-  fromDBusClient f = withDBusClient (return . f)
+  fromDBusClient n f = withDBusClient n (return . f)
 
-newtype SysClient = SysClient Client
+data SysClient = SysClient
 
 instance SafeClient SysClient where
-  toClient (SysClient cl) = cl
+  getDBusClient = connectToDBusWithName True SysClient
 
-  getDBusClient = fmap SysClient <$> getDBusClient' True
+data SesClient = SesClient
-
-newtype SesClient = SesClient Client
 
 instance SafeClient SesClient where
-  toClient (SesClient cl) = cl
+  -- TODO wet
+  getDBusClient = connectToDBusWithName False SesClient
 
-  getDBusClient = fmap SesClient <$> getDBusClient' False
+connectToDBusWithName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => Bool
+  -> c
+  -> Maybe BusName
+  -> m (Maybe (NamedConnection c))
+connectToDBusWithName sys t n = do
+  clRes <- getDBusClient' sys
+  case clRes of
+    Nothing -> do
+      logError "could not get client"
+      return Nothing
+    Just cl -> do
+      --helloRes <- liftIO $ callHello cl
+      --case helloRes of
+      --  Nothing -> do
+      --    logError "count not get unique name"
+      --    return Nothing
+      --  Just unique -> do
+          n' <- maybe (return Nothing) (`requestBusName` cl) n
+          return $
+            Just $
+              NamedConnection
+                { ncClient = cl
+                , ncHumanName = n'
+      --          , ncUniqueName = unique
+                , ncType = t
+                }
+
+releaseBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => NamedConnection c
+  -> m ()
+releaseBusName NamedConnection {ncClient, ncHumanName} = do
+  -- TODO this might error?
+  case ncHumanName of
+    Just n -> do
+      liftIO $ void $ releaseName ncClient n
+      logInfo $ "released bus name: " <> displayBusName n
+    Nothing -> return ()
+
+requestBusName
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => BusName
+  -> Client
+  -> m (Maybe BusName)
+requestBusName n cl = do
+  res <- try $ liftIO $ requestName cl n []
+  case res of
+    Left e -> do
+      logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+      return Nothing
+    Right r -> do
+      let msg
+            | r == NamePrimaryOwner = "registering name"
+            | r == NameAlreadyOwner = "this process already owns name"
+            | r == NameInQueue
+                || r == NameExists =
+                "another process owns name"
+            -- this should never happen
+            | otherwise = "unknown error when requesting name"
+      logInfo $ msg <> ": " <> displayBusName n
+      case r of
+        NamePrimaryOwner -> return $ Just n
+        _ -> return Nothing
 
 getDBusClient'
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@@ -116,7 +195,16 @@ getDBusClient' sys = do
       return Nothing
     Right c -> return $ Just c
 
-data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
+--callHello :: Client -> IO (Maybe BusName)
+--callHello cl = do
+--  reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
+--  case methodReturnBody reply of
+--    [name] | Just nameStr <- fromVariant name -> do
+--      busName <- parseBusName nameStr
+--      return $ Just busName
+--    _ -> return Nothing
+--
+data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection c), dEnv :: !env}
 
 type DIO env c = RIO (DBusEnv env c)
 
@@ -128,7 +216,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where
 
 withDIO
   :: (MonadUnliftIO m, MonadReader env m)
-  => c
+  => NamedConnection c
   -> DIO env c a
   -> m a
 withDIO cl x = do
@@ -136,7 +224,7 @@ withDIO cl x = do
   runRIO (DBusEnv cl env) x
 
 class HasClient env where
-  clientL :: SafeClient c => Lens' (env c) c
+  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
 
 --------------------------------------------------------------------------------
 -- Methods
@@ -148,7 +236,7 @@ callMethod'
   => MethodCall
   -> m MethodBody
 callMethod' mc = do
-  cl <- toClient <$> view clientL
+  cl <- ncClient <$> view clientL
   liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
 callMethod
@@ -220,7 +308,7 @@ addMatchCallbackSignal
   -> (Signal -> m ())
   -> m SignalHandler
 addMatchCallbackSignal rule cb = do
-  cl <- toClient <$> view clientL
+  cl <- ncClient <$> view clientL
   withRunInIO $ \run -> addMatch cl rule $ run . cb
 
 addMatchCallback
@@ -301,7 +389,7 @@ callPropertyGet
   -> MemberName
   -> m [Variant]
 callPropertyGet bus path iface property = do
-  cl <- toClient <$> view clientL
+  cl <- ncClient <$> view clientL
   res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
   case res of
     Left err -> do
@@ -453,14 +541,14 @@ addInterfaceRemovedListener bus =
 -- Interface export/unexport
 
 exportPair
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => ObjectPath
   -> (Client -> m Interface)
-  -> c
+  -> NamedConnection c
   -> (m (), m ())
 exportPair path toIface cl = (up, down)
   where
-    cl_ = toClient cl
+    cl_ = ncClient cl
     up = do
       logInfo $ "adding interface: " <> path_
       i <- toIface cl_

lib/Data/Internal/XIO.hs

@@ -288,8 +288,18 @@ type SubfeatureRoot a = Subfeature (Root a)
 data Root a
   = forall p. IORoot (p -> a) (IOTree p)
   | IORoot_ a IOTree_
-  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
+  | forall c p.
-  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe c)
+    SafeClient c =>
+    DBusRoot
+      (p -> NamedConnection c -> a)
+      (DBusTree c p)
+      (Maybe (NamedConnection c))
+  | forall c.
+    SafeClient c =>
+    DBusRoot_
+      (NamedConnection c -> a)
+      (DBusTree_ c)
+      (Maybe (NamedConnection c))
 
 instance Functor Root where
   fmap f (IORoot a t) = IORoot (f . a) t
@@ -876,10 +886,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
+testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
+testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
 testDBusDepNoCache_ cl (Bus _ bus) = do
   ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
   return $ case ret of
@@ -1010,11 +1020,11 @@ sometimesExeArgs fn n ful sys path args =
 
 sometimesDBus
   :: SafeClient c
-  => Maybe c
+  => Maybe (NamedConnection c)
   -> T.Text
   -> T.Text
   -> Tree_ (DBusDependency_ c)
-  -> (c -> a)
+  -> (NamedConnection c -> a)
   -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
 
@@ -1028,7 +1038,7 @@ sometimesEndpoint
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> Maybe c
+  -> Maybe (NamedConnection c)
   -> Sometimes (m ())
 sometimesEndpoint fn name ful busname path iface mem cl =
   sometimesDBus cl fn name deps cmd

lib/XMonad/Internal/Command/DMenu.hs

@@ -146,7 +146,7 @@ runAppMenu = spawnDmenuCmd "app launcher" ["-show", "drun"]
 runWinMenu :: MonadUnliftIO m => Sometimes (m ())
 runWinMenu = spawnDmenuCmd "window switcher" ["-show", "window"]
 
-runNetMenu :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runNetMenu :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runNetMenu cl =
   Sometimes
     "network control menu"
@@ -171,7 +171,7 @@ runAutorandrMenu = sometimesIO_ "autorandr menu" "rofi autorandr" tree cmd
 --------------------------------------------------------------------------------
 -- Password manager
 
-runBwMenu :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runBwMenu :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runBwMenu cl = sometimesDBus cl "password manager" "rofi bitwarden" tree cmd
   where
     cmd _ =

lib/XMonad/Internal/Command/Desktop.hs

@@ -246,7 +246,7 @@ runNotificationCmd
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> Sometimes (m ())
 runNotificationCmd n arg cl =
   sometimesDBus cl (T.unwords [n, "control"]) "dunstctl" tree cmd
@@ -258,18 +258,18 @@ runNotificationCmd n arg cl =
           Method_ $
             memberName_ "NotificationAction"
 
-runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationClose :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runNotificationContext =
   runNotificationCmd "open notification context" "context"
 
@@ -277,7 +277,7 @@ runNotificationContext =
 -- System commands
 
 -- this is required for some vpn's to work properly with network-manager
-runNetAppDaemon :: Maybe SysClient -> Sometimes (XIO (P.Process () () ()))
+runNetAppDaemon :: Maybe NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
 runNetAppDaemon cl =
   Sometimes
     "network applet"
@@ -288,7 +288,7 @@ runNetAppDaemon cl =
     app = DBusIO $ sysExe [Package Official "network-manager-applet"] "nm-applet"
     cmd _ = P.proc "nm-applet" [] (P.startProcess . P.setCreateGroup True)
 
-runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
+runToggleBluetooth :: MonadUnliftIO m => Maybe NamedSysConnection -> Sometimes (m ())
 runToggleBluetooth cl =
   Sometimes
     "bluetooth toggle"
@@ -366,7 +366,7 @@ runFlameshot
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> Sometimes (m ())
 runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
   where
@@ -378,15 +378,15 @@ runFlameshot n mode cl = sometimesDBus cl n (T.pack myCapture) tree cmd
 
 -- TODO this will steal focus from the current window (and puts it
 -- in the root window?) ...need to fix
-runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runAreaCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
+runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
 runScreenCapture = runFlameshot "screen capture" "screen"
 
 runCaptureBrowser :: MonadUnliftIO m => Sometimes (m ())

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

@@ -117,7 +117,7 @@ clevoKeyboardSignalDep =
 
 exportClevoKeyboard
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
@@ -128,7 +128,7 @@ exportClevoKeyboard =
 
 clevoKeyboardControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> BrightnessControls m
 clevoKeyboardControls = brightnessControls xpfClevoBacklight clevoKeyboardConfig
 

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

@@ -53,7 +53,7 @@ brightnessControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
   => XPQuery
   -> BrightnessConfig m a b
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> BrightnessControls m
 brightnessControls q bc cl =
   BrightnessControls
@@ -78,7 +78,7 @@ callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
     <$> callMethod xmonadSesBusName p i memGet
 
-signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
+signalDep :: BrightnessConfig m a b -> DBusDependency_ c
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
   Endpoint [] xmonadSesBusName p i $ Signal_ memCur
 
@@ -112,7 +112,7 @@ brightnessExporter
   -> [Fulfillment]
   -> [IODependency_]
   -> BrightnessConfig m a b
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
   Sometimes (T.append n " DBus Interface") q [Subfeature root "exporter"]
@@ -123,7 +123,7 @@ brightnessExporter q ful deps bc@BrightnessConfig {bcName = n} cl =
 exportBrightnessControlsInner
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
   => BrightnessConfig m a b
-  -> SesClient
+  -> NamedSesConnection
   -> (m (), m ())
 exportBrightnessControlsInner bc = cmd
   where
@@ -172,7 +172,7 @@ emitBrightness BrightnessConfig {bcPath = p, bcInterface = i} client cur =
 callBacklight
   :: (MonadReader env m, HasClient (DBusEnv env), MonadUnliftIO m)
   => XPQuery
-  -> Maybe SesClient
+  -> Maybe NamedSesConnection
   -> BrightnessConfig m a b
   -> T.Text
   -> MemberName

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

@@ -103,7 +103,7 @@ intelBacklightSignalDep =
 
 exportIntelBacklight
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
@@ -114,7 +114,7 @@ exportIntelBacklight =
 
 intelBacklightControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 

lib/XMonad/Internal/DBus/Common.hs

@@ -14,10 +14,10 @@ where
 import DBus
 
 xmonadSesBusName :: BusName
-xmonadSesBusName = busName_ "org.xmonad.Session"
+xmonadSesBusName = busName_ "org.xmonad.session"
 
 xmonadSysBusName :: BusName
-xmonadSysBusName = busName_ "org.xmonad.System"
+xmonadSysBusName = busName_ "org.xmonad.system"
 
 btBus :: BusName
 btBus = busName_ "org.bluez"

lib/XMonad/Internal/DBus/Control.hs

@@ -11,7 +11,7 @@ module XMonad.Internal.DBus.Control
   , withDBus_
   , connectDBus
   , disconnectDBus
-  , disconnectDBusX
+  -- , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -22,7 +22,6 @@ where
 
 import DBus
 import DBus.Client
-import qualified Data.ByteString.Char8 as BC
 import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
@@ -33,8 +32,8 @@ import XMonad.Internal.DBus.Screensaver
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-  { dbSesClient :: Maybe SesClient
+  { dbSesClient :: Maybe NamedSesConnection
-  , dbSysClient :: Maybe SysClient
+  , dbSysClient :: Maybe NamedSysConnection
   }
 
 withDBusX_
@@ -46,50 +45,47 @@ withDBusX_ = void . withDBusX
 withDBusX
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => (DBusState -> m a)
-  -> m (Maybe a)
+  -> m a
-withDBusX f = withDBus $ \db -> do
+withDBusX = withDBus (Just xmonadSesBusName) (Just xmonadSysBusName)
-  case (dbSesClient db, dbSysClient db) of
-    (Just ses, Just sys) -> do
-      res <-
-        bracket_
-          ( do
-              requestBusName xmonadSesBusName ses
-              requestBusName xmonadSysBusName sys
-          )
-          ( do
-              releaseBusName xmonadSesBusName ses
-              releaseBusName xmonadSysBusName sys
-          )
-          $ f db
-      return $ Just res
-    _ -> return Nothing
 
 withDBus_
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (DBusState -> m a)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
   -> m ()
-withDBus_ = void . withDBus
+withDBus_ sesname sysname = void . withDBus sesname sysname
 
 withDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => (DBusState -> m a)
+  => Maybe BusName
+  -> Maybe BusName
+  -> (DBusState -> m a)
   -> m a
-withDBus = bracket connectDBus disconnectDBus
+withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
 
 -- | Connect to the DBus
 connectDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => m DBusState
+  => Maybe BusName
-connectDBus = do
+  -> Maybe BusName
-  ses <- getDBusClient
+  -> m DBusState
-  sys <- getDBusClient
+connectDBus sesname sysname = do
+  ses <- getDBusClient sesname
+  sys <- getDBusClient sysname
   return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
+disconnectDBus
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => DBusState
+  -> m ()
 disconnectDBus db = disc dbSesClient >> disc dbSysClient
   where
-    disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
+    disc
+      :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
+      => (DBusState -> Maybe (NamedConnection c))
+      -> m ()
     disc f = maybe (return ()) disconnectDBusClient $ f db
 
 -- -- | Connect to the DBus and request the XMonad name
@@ -101,15 +97,15 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
 --   requestXMonadName2 db
 --   return db
 
--- | Disconnect from DBus and release the XMonad name
+-- -- | Disconnect from DBus and release the XMonad name
-disconnectDBusX
+-- disconnectDBusX
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => DBusState
+--   => DBusState
-  -> m ()
+--   -> m ()
-disconnectDBusX db = do
+-- disconnectDBusX db = do
-  forM_ (dbSesClient db) $ releaseBusName xmonadSesBusName
+--   forM_ (dbSesClient db) releaseBusName
-  forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName
+--   forM_ (dbSysClient db) releaseBusName
-  disconnectDBus db
+--   disconnectDBus db
 
 -- requestXMonadName2
 --   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
@@ -121,7 +117,7 @@ disconnectDBusX db = do
 
 withDBusInterfaces
   :: DBusState
-  -> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
+  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   -> ([XIO ()] -> XIO a)
   -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
@@ -134,7 +130,7 @@ withDBusInterfaces db interfaces = bracket up sequence
 -- | All exporter features to be assigned to the DBus
 dbusExporters
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe SesClient -> Sometimes (m (), m ())]
+  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
 -- releaseXMonadName
@@ -146,35 +142,35 @@ dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 --   liftIO $ void $ releaseName (toClient cl) xmonadBusName
 --   logInfo "released xmonad name"
 
-releaseBusName
+-- releaseBusName
-  :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => BusName
+--   => BusName
-  -> c
+--   -> c
-  -> m ()
+--   -> m ()
-releaseBusName n cl = do
+-- releaseBusName n cl = do
-  -- TODO this might error?
+--   -- TODO this might error?
-  liftIO $ void $ releaseName (toClient cl) n
+--   liftIO $ void $ releaseName (toClient cl) n
-  logInfo $ "released bus name: " <> displayBusName n
+--   logInfo $ "released bus name: " <> displayBusName n
 
-requestBusName
+-- requestBusName
-  :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => BusName
+--   => BusName
-  -> c
+--   -> c
-  -> m ()
+--   -> m ()
-requestBusName n cl = do
+-- requestBusName n cl = do
-  res <- try $ liftIO $ requestName (toClient cl) n []
+--   res <- try $ liftIO $ requestName (toClient cl) n []
-  case res of
+--   case res of
-    Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
-    Right r -> do
+--     Right r -> do
-      let msg
+--       let msg
-            | r == NamePrimaryOwner = "registering name"
+--             | r == NamePrimaryOwner = "registering name"
-            | r == NameAlreadyOwner = "this process already owns name"
+--             | r == NameAlreadyOwner = "this process already owns name"
-            | r == NameInQueue
+--             | r == NameInQueue
-                || r == NameExists =
+--                 || r == NameExists =
-                "another process owns name"
+--                 "another process owns name"
-            -- this should never happen
+--             -- this should never happen
-            | otherwise = "unknown error when requesting name"
+--             | otherwise = "unknown error when requesting name"
-      logInfo $ msg <> ": " <> displayBusName n
+--       logInfo $ msg <> ": " <> displayBusName n
 
 -- requestXMonadName
 --   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)

lib/XMonad/Internal/DBus/Removable.hs

@@ -83,7 +83,7 @@ listenDevices
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => SysClient
+  => NamedSysConnection
   -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
@@ -98,7 +98,7 @@ runRemovableMon
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => Maybe SysClient
+  => Maybe NamedSysConnection
   -> Sometimes (m ())
 runRemovableMon cl =
   sometimesDBus cl "removeable device monitor" "dbus monitor" deps listenDevices

lib/XMonad/Internal/DBus/Screensaver.hs

@@ -93,7 +93,7 @@ bodyGetCurrentState _ = Nothing
 
 exportScreensaver
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m (), m ())
 exportScreensaver ses =
   sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
@@ -124,7 +124,7 @@ exportScreensaver ses =
 
 callToggle
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m ())
 callToggle =
   sometimesEndpoint

lib/Xmobar/Plugins/ActiveConnection.hs

@@ -39,7 +39,7 @@ connAlias = T.intercalate "_" . NE.toList
 instance Exec ActiveConnection where
   alias (ActiveConnection (contypes, _, _)) = T.unpack $ connAlias contypes
   start (ActiveConnection (contypes, text, colors)) cb =
-    withDBusClientConnection cb (Just "ethernet.log") $ \c -> do
+    withDBusClientConnection cb Nothing (Just "ethernet.log") $ \c -> do
       let dpy cb' = displayMaybe cb' formatter . Just =<< readState
       i <- withDIO c $ initialState contypes
       s <- newMVar i
@@ -60,7 +60,7 @@ instance Exec ActiveConnection where
             -- TODO can I recycle the client?
             void $
               addMatchCallbackSignal rule $ \sig ->
-                withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
+                withDBusClientConnection cb Nothing (Just "ethernet-cb.log") $ \c' ->
                   mapEnv c' $
                     testActiveType contypes sig
 

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -4,6 +4,7 @@
 -- to signals spawned by commands
 module Xmobar.Plugins.BacklightCommon (startBacklight) where
 
+import DBus
 import Data.Internal.DBus
 import RIO
 import qualified RIO.Text as T
@@ -11,14 +12,15 @@ import Xmobar.Plugins.Common
 
 startBacklight
   :: (MonadUnliftIO m, RealFrac a)
-  => Maybe FilePath
+  => Maybe BusName
+  -> Maybe FilePath
   -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
   -> DIO SimpleApp SesClient (Maybe a)
   -> T.Text
   -> Callback
   -> m ()
-startBacklight name matchSignal callGetBrightness icon cb = do
+startBacklight n name matchSignal callGetBrightness icon cb = do
-  withDBusClientConnection cb name $ \c -> withDIO c $ do
+  withDBusClientConnection cb n name $ \c -> withDIO c $ do
     matchSignal dpy
     dpy =<< callGetBrightness
   where

lib/Xmobar/Plugins/Bluetooth.hs

@@ -54,13 +54,17 @@ data Bluetooth = Bluetooth Icons Colors deriving (Read, Show)
 instance Exec Bluetooth where
   alias (Bluetooth _ _) = T.unpack btAlias
   start (Bluetooth icons colors) cb =
-    withDBusClientConnection cb (Just "bluetooth.log") $ startAdapter icons colors cb
+    withDBusClientConnection
+      cb
+      (Just "org.xmonad.bluetooth")
+      (Just "bluetooth.log")
+      $ startAdapter icons colors cb
 
 startAdapter
   :: Icons
   -> Colors
   -> Callback
-  -> SysClient
+  -> NamedSysConnection
   -> RIO SimpleApp ()
 startAdapter is cs cb cl = do
   state <- newMVar emptyState
@@ -201,7 +205,7 @@ startAdaptorListener adaptor = do
           <> displayObjectPath adaptor
   where
     callback sig =
-      withNestedDBusClientConnection Nothing $
+      withNestedDBusClientConnection Nothing Nothing $
         withSignalMatch procMatch $
           matchPropertyChanged adaptorInterface adaptorPowered sig
     procMatch = beforeDisplay . putPowered
@@ -249,7 +253,7 @@ startConnectedListener adaptor = do
   where
     adaptor_ = displayWrapQuote $ displayObjectPath adaptor
     callback sig =
-      withNestedDBusClientConnection Nothing $ do
+      withNestedDBusClientConnection Nothing Nothing $ do
         let devpath = signalPath sig
         when (adaptorHasDevice adaptor devpath) $
           withSignalMatch (update devpath) $

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -24,4 +24,9 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = T.unpack ckAlias
   start (ClevoKeyboard icon) =
-    startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
+    startBacklight
+      (Just "org.xmobar.clevo")
+      (Just "clevo_kbd.log")
+      matchSignalCK
+      callGetBrightnessCK
+      icon

lib/Xmobar/Plugins/Common.hs

@@ -26,7 +26,7 @@ import qualified RIO.Text as T
 import XMonad.Hooks.DynamicLog (xmobarColor)
 
 data PluginEnv s c = PluginEnv
-  { plugClient :: !c
+  { plugClient :: !(NamedConnection c)
   , plugState :: !(MVar s)
   , plugDisplay :: !(Callback -> PluginIO s c ())
   , plugCallback :: !Callback
@@ -99,17 +99,18 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
+  -> Maybe BusName
   -> Maybe FilePath
-  -> (c -> RIO SimpleApp ())
+  -> (NamedConnection c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb logfile f =
+withDBusClientConnection cb n logfile f =
   maybe (run stderr) (`withLogFile` run) logfile
   where
     run h = do
       logOpts <- setLogVerboseFormat True . setLogUseTime True <$> logOptionsHandle h False
       withLogFunc logOpts $ \lf -> do
         env <- mkSimpleApp lf Nothing
-        runRIO env $ displayMaybe' cb f =<< getDBusClient
+        runRIO env $ displayMaybe' cb f =<< getDBusClient n
 
 -- | Run a plugin action with a new DBus client and logfile path.
 -- This is necessary for DBus callbacks which run in separate threads, which
@@ -117,11 +118,12 @@ withDBusClientConnection cb logfile f =
 -- DBus connection and closed its logfile.
 withNestedDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
-  => Maybe FilePath
+  => Maybe BusName
+  -> Maybe FilePath
   -> PluginIO s c ()
   -> m ()
-withNestedDBusClientConnection logfile f = do
+withNestedDBusClientConnection n logfile f = do
   dpy <- asks plugDisplay
   s <- asks plugState
   cb <- asks plugCallback
-  withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
+  withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f

lib/Xmobar/Plugins/IntelBacklight.hs

@@ -24,4 +24,9 @@ blAlias = "intelbacklight"
 instance Exec IntelBacklight where
   alias (IntelBacklight _) = T.unpack blAlias
   start (IntelBacklight icon) =
-    startBacklight (Just "intel_backlight.log") matchSignalIB callGetBrightnessIB icon
+    startBacklight
+      (Just "org.xmobar.intelbacklight")
+      (Just "intel_backlight.log")
+      matchSignalIB
+      callGetBrightnessIB
+      icon

lib/Xmobar/Plugins/Screensaver.hs

@@ -25,8 +25,12 @@ ssAlias = "screensaver"
 instance Exec Screensaver where
   alias (Screensaver _) = T.unpack ssAlias
   start (Screensaver (text, colors)) cb =
-    withDBusClientConnection cb (Just "screensaver.log") $ \cl -> withDIO cl $ do
+    withDBusClientConnection
-      matchSignal dpy
+      cb
-      dpy =<< callQuery
+      (Just "org.xmobar.screensaver")
+      (Just "screensaver.log")
+      $ \cl -> withDIO cl $ do
+        matchSignal dpy
+        dpy =<< callQuery
     where
       dpy = displayMaybe cb $ return . (\s -> colorText colors s text)