Merge branch 'fix_dbus'

bin/xmobar.hs

@@ -11,12 +11,12 @@ module Main (main) where
 
 import Data.Internal.DBus
 import Data.Internal.XIO
+import GHC.Enum (enumFrom)
 import Options.Applicative
 import RIO hiding (hFlush)
 import RIO.List
 import qualified RIO.NonEmpty as NE
 import qualified RIO.Text as T
-import XMonad.Config.Prime (enumFrom)
 import XMonad.Core hiding (config)
 import XMonad.Internal.Command.Power
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
@@ -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,48 +59,129 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client
 
-class SafeClient c where
+data NamedConnection c = NamedConnection
-  toClient :: c -> Client
+  { ncClient :: !Client
+  , ncHumanName :: !(Maybe BusName)
+  --, ncUniqueName :: !BusName
+  , ncType :: !c
+  }
 
+type NamedSesConnection = NamedConnection SesClient
+
+type NamedSysConnection = NamedConnection SysClient
+
+class SafeClient c where
   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)
@@ -110,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)
 
@@ -122,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
@@ -130,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
@@ -142,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
@@ -214,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
@@ -295,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
@@ -447,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
@@ -76,11 +76,11 @@ callGetBrightness
   -> m (Maybe n)
 callGetBrightness BrightnessConfig {bcPath = p, bcInterface = i} =
   either (const Nothing) bodyGetBrightness
-    <$> callMethod xmonadBusName p i memGet
+    <$> 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 [] xmonadBusName p i $ Signal_ memCur
+  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
 
 matchSignal
   :: ( HasClient env
@@ -112,18 +112,18 @@ 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"]
   where
     root = DBusRoot_ (exportBrightnessControlsInner bc) tree cl
-    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
+    tree = listToAnds (Bus ful xmonadSesBusName) $ fmap DBusIO deps
 
 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
@@ -180,8 +180,8 @@ callBacklight
 callBacklight q cl BrightnessConfig {bcPath = p, bcInterface = i, bcName = n} controlName m =
   Sometimes (T.unwords [n, controlName]) q [Subfeature root "method call"]
   where
-    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
-    cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
+    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
 
 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)

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

@@ -2,7 +2,8 @@
 -- High-level interface for managing XMonad's DBus
 
 module XMonad.Internal.DBus.Common
-  ( xmonadBusName
+  ( xmonadSesBusName
+  , xmonadSysBusName
   , btBus
   , notifyBus
   , notifyPath
@@ -12,8 +13,11 @@ where
 
 import DBus
 
-xmonadBusName :: BusName
+xmonadSesBusName :: BusName
-xmonadBusName = busName_ "org.xmonad"
+xmonadSesBusName = busName_ "org.xmonad.session"
+
+xmonadSysBusName :: BusName
+xmonadSysBusName = busName_ "org.xmonad.system"
 
 btBus :: BusName
 btBus = busName_ "org.bluez"

lib/XMonad/Internal/DBus/Control.hs

@@ -10,9 +10,8 @@ module XMonad.Internal.DBus.Control
   , withDBus
   , withDBus_
   , connectDBus
-  , connectDBusX
   , disconnectDBus
-  , disconnectDBusX
+  -- , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -26,7 +25,6 @@ import DBus.Client
 import Data.Internal.DBus
 import Data.Internal.XIO
 import RIO
-import qualified RIO.Text as T
 import XMonad.Internal.DBus.Brightness.ClevoKeyboard
 import XMonad.Internal.DBus.Brightness.IntelBacklight
 import XMonad.Internal.DBus.Common
@@ -34,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_
@@ -47,60 +45,79 @@ 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) Nothing
-  forM (dbSesClient db) $ \ses -> do
-    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
 
 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
-disconnectDBus db = disc dbSesClient >> disc dbSysClient
-  where
-    disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
-    disc f = maybe (return ()) disconnectDBusClient $ f db
-
--- | Connect to the DBus and request the XMonad name
-connectDBusX
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => m DBusState
-connectDBusX = do
-  db <- connectDBus
-  forM_ (dbSesClient db) requestXMonadName
-  return db
-
--- | Disconnect from DBus and release the XMonad name
-disconnectDBusX
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => DBusState
   -> m ()
-disconnectDBusX db = do
+disconnectDBus db = disc dbSesClient >> disc dbSysClient
-  forM_ (dbSesClient db) releaseXMonadName
+  where
-  disconnectDBus db
+    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
+-- connectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => m DBusState
+-- connectDBusX = do
+--   db <- connectDBus
+--   requestXMonadName2 db
+--   return db
+
+-- -- | Disconnect from DBus and release the XMonad name
+-- disconnectDBusX
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- disconnectDBusX db = do
+--   forM_ (dbSesClient db) releaseBusName
+--   forM_ (dbSysClient db) releaseBusName
+--   disconnectDBus db
+
+-- requestXMonadName2
+--   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => DBusState
+--   -> m ()
+-- requestXMonadName2 db = do
+--   forM_ (dbSesClient db) requestXMonadName
+--   forM_ (dbSysClient db) requestXMonadName
 
 withDBusInterfaces
   :: DBusState
-  -> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
+  -> [Maybe NamedSesConnection -> Sometimes (XIO (), XIO ())]
   -> ([XIO ()] -> XIO a)
   -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
@@ -113,35 +130,59 @@ 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
+-- releaseXMonadName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
+--   => c
-  -> m ()
+--   -> m ()
-releaseXMonadName ses = do
+-- releaseXMonadName cl = do
-  -- TODO this might error?
+--   -- TODO this might error?
-  liftIO $ void $ releaseName (toClient ses) xmonadBusName
+--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
-  logInfo "released xmonad name"
+--   logInfo "released xmonad name"
 
-requestXMonadName
+-- releaseBusName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
+--   => BusName
-  -> m ()
+--   -> c
-requestXMonadName ses = do
+--   -> m ()
-  res <- liftIO $ requestName (toClient ses) xmonadBusName []
+-- releaseBusName n cl = do
-  let msg
+--   -- TODO this might error?
-        | res == NamePrimaryOwner = "registering name"
+--   liftIO $ void $ releaseName (toClient cl) n
-        | res == NameAlreadyOwner = "this process already owns name"
+--   logInfo $ "released bus name: " <> displayBusName n
-        | res == NameInQueue
+
-            || res == NameExists =
+-- requestBusName
-            "another process owns name"
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-        | otherwise = "unknown error when requesting name"
+--   => BusName
-  logInfo $ msg <> ": " <> xn
+--   -> c
-  where
+--   -> m ()
-    xn =
+-- requestBusName n cl = do
-      Utf8Builder $
+--   res <- try $ liftIO $ requestName (toClient cl) n []
-        encodeUtf8Builder $
+--   case res of
-          T.pack $
+--     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
-            formatBusName xmonadBusName
+--     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
+
+-- requestXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- requestXMonadName cl = do
+--   res <- liftIO $ requestName (toClient cl) xmonadBusName []
+--   let msg
+--         | res == NamePrimaryOwner = "registering name"
+--         | res == NameAlreadyOwner = "this process already owns name"
+--         | res == NameInQueue
+--             || res == NameExists =
+--             "another process owns name"
+--         | otherwise = "unknown error when requesting name"
+--   logInfo $ msg <> ": " <> displayBusName xmonadBusName

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
@@ -119,19 +119,19 @@ exportScreensaver ses =
                 }
             ]
         }
-    bus = Bus [] xmonadBusName
+    bus = Bus [] xmonadSesBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
 callToggle
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe SesClient
+  => Maybe NamedSesConnection
   -> Sometimes (m ())
 callToggle =
   sometimesEndpoint
     "screensaver toggle"
     "dbus switch"
     []
-    xmonadBusName
+    xmonadSesBusName
     ssPath
     interface
     memToggle
@@ -140,7 +140,7 @@ callQuery
   :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
   => m (Maybe SSState)
 callQuery = do
-  reply <- callMethod xmonadBusName ssPath interface memQuery
+  reply <- callMethod xmonadSesBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
 matchSignal
@@ -157,4 +157,4 @@ matchSignal cb =
       (cb . bodyGetCurrentState)
 
 ssSignalDep :: DBusDependency_ SesClient
-ssSignalDep = Endpoint [] xmonadBusName ssPath interface $ Signal_ memState
+ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState

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,14 @@ 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 Nothing (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 +202,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 +250,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,20 @@ 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 $
+          bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $
+            displayMaybe' cb f
 
 -- | 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 +120,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)

stack.yaml

@@ -17,8 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-#resolver: lts-17.4
+resolver: lts-19.33
-resolver: nightly-2022-03-03
+#resolver: nightly-2022-03-03
 
 # User packages to be built.
 # Various formats can be used as shown in the example below.