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_ Nothing Nothing evalConfig
+  XTest -> hRunXIO False stderr $ withDBus_ evalConfig
   XRun -> runXIO "xmobar.log" run
 
 run :: XIO ()
@@ -75,8 +75,8 @@ 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
-  -- TODO do these dbus things really need to remain connected?
+  withDBus_ $ \db -> do
-  c <- withDBus Nothing Nothing evalConfig
+    c <- evalConfig db
     liftIO $ xmobar c
 
 evalConfig :: DBusState -> XIO Config
@@ -88,7 +88,7 @@ evalConfig db = do
   return $ config bf ifs ios cs d
 
 printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db ->
+printDeps = withDBus_ $ \db ->
   mapM_ logInfo $
     fmap showFulfillment $
       sort $
@@ -218,7 +218,7 @@ getWireless =
     xpfWireless
     [Subfeature (IORoot wirelessCmd $ Only readWireless) "sysfs path"]
 
-getEthernet :: Maybe NamedSysConnection -> BarFeature
+getEthernet :: Maybe SysClient -> 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 NamedSysConnection -> BarFeature
+getVPN :: Maybe SysClient -> BarFeature
 getVPN cl = iconDBus_ "VPN status indicator" xpfVPN root (Only_ devDep)
   where
     root useIcon tree = DBusRoot_ (const $ vpnCmd useIcon) tree cl
 
-getBt :: Maybe NamedSysConnection -> BarFeature
+getBt :: Maybe SysClient -> BarFeature
 getBt = xmobarDBus "bluetooth status indicator" xpfBluetooth btDep btCmd
 
 getAlsa :: BarFeature
@@ -250,7 +250,7 @@ getAlsa =
   where
     root useIcon = IORoot_ (alsaCmd useIcon)
 
-getBl :: Maybe NamedSesConnection -> BarFeature
+getBl :: Maybe SesClient -> BarFeature
 getBl =
   xmobarDBus
     "Intel backlight indicator"
@@ -258,7 +258,7 @@ getBl =
     intelBacklightSignalDep
     blCmd
 
-getCk :: Maybe NamedSesConnection -> BarFeature
+getCk :: Maybe SesClient -> BarFeature
 getCk =
   xmobarDBus
     "Clevo keyboard indicator"
@@ -266,7 +266,7 @@ getCk =
     clevoKeyboardSignalDep
     ckCmd
 
-getSs :: Maybe NamedSesConnection -> BarFeature
+getSs :: Maybe SesClient -> BarFeature
 getSs = xmobarDBus "screensaver indicator" (const True) ssSignalDep ssCmd
 
 getLock :: Always CmdSpec
@@ -283,7 +283,7 @@ xmobarDBus
   -> XPQuery
   -> DBusDependency_ c
   -> (Fontifier -> CmdSpec)
-  -> Maybe (NamedConnection c)
+  -> Maybe 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 NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  , fsDBusExporters :: [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   , fsPowerMon :: SometimesIO
-  , fsRemovableMon :: Maybe NamedSysConnection -> SometimesIO
+  , fsRemovableMon :: Maybe SysClient -> 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 NamedSysConnection -> FeatureSet
+features :: Maybe SysClient -> FeatureSet
 features cl =
   FeatureSet
     { fsKeys = externalBindings
@@ -251,7 +251,7 @@ stopChildDaemons = mapM_ stop
       liftIO $ killNoWait p
 
 printDeps :: XIO ()
-printDeps = withDBus_ Nothing Nothing $ \db -> do
+printDeps = withDBus_ $ \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
-  disconnectDBus db
+  disconnectDBusX 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,13 +5,9 @@ module Data.Internal.DBus
   ( SafeClient (..)
   , SysClient (..)
   , SesClient (..)
-  , NamedConnection (..)
-  , NamedSesConnection
-  , NamedSysConnection
   , DBusEnv (..)
   , DIO
   , HasClient (..)
-  , releaseBusName
   , withDIO
   , addMatchCallback
   , addMatchCallbackSignal
@@ -59,129 +55,48 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client
 
-data NamedConnection c = NamedConnection
-  { ncClient :: !Client
-  , ncHumanName :: !(Maybe BusName)
-  --, 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)
-    => Maybe BusName
+    => m (Maybe c)
-    -> m (Maybe (NamedConnection c))
 
-  disconnectDBusClient
+  disconnectDBusClient :: MonadUnliftIO m => c -> m ()
-    :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  disconnectDBusClient = liftIO . disconnect . toClient
-    => NamedConnection c
-    -> m ()
-  disconnectDBusClient c = do
-    releaseBusName c
-    liftIO $ disconnect $ ncClient c
 
   withDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> m a)
-    -> (NamedConnection c -> m a)
     -> m (Maybe a)
-  withDBusClient n f =
+  withDBusClient f =
-    bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
+    bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
 
   withDBusClient_
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> m ())
-    -> (NamedConnection c -> m ())
     -> m ()
-  withDBusClient_ n = void . withDBusClient n
+  withDBusClient_ = void . withDBusClient
 
   fromDBusClient
     :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-    => Maybe BusName
+    => (c -> a)
-    -> (NamedConnection c -> a)
     -> m (Maybe a)
-  fromDBusClient n f = withDBusClient n (return . f)
+  fromDBusClient f = withDBusClient (return . f)
 
-data SysClient = SysClient
+newtype SysClient = SysClient Client
 
 instance SafeClient SysClient where
-  getDBusClient = connectToDBusWithName True SysClient
+  toClient (SysClient cl) = cl
 
-data SesClient = SesClient
+  getDBusClient = fmap SysClient <$> getDBusClient' True
+
+newtype SesClient = SesClient Client
 
 instance SafeClient SesClient where
-  -- TODO wet
+  toClient (SesClient cl) = cl
-  getDBusClient = connectToDBusWithName False SesClient
 
-connectToDBusWithName
+  getDBusClient = fmap SesClient <$> getDBusClient' False
-  :: (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)
@@ -195,16 +110,7 @@ getDBusClient' sys = do
       return Nothing
     Right c -> return $ Just c
 
---callHello :: Client -> IO (Maybe BusName)
+data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
---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)
 
@@ -216,7 +122,7 @@ instance HasLogFunc (DBusEnv SimpleApp c) where
 
 withDIO
   :: (MonadUnliftIO m, MonadReader env m)
-  => NamedConnection c
+  => c
   -> DIO env c a
   -> m a
 withDIO cl x = do
@@ -224,7 +130,7 @@ withDIO cl x = do
   runRIO (DBusEnv cl env) x
 
 class HasClient env where
-  clientL :: SafeClient c => Lens' (env c) (NamedConnection c)
+  clientL :: SafeClient c => Lens' (env c) c
 
 --------------------------------------------------------------------------------
 -- Methods
@@ -236,7 +142,7 @@ callMethod'
   => MethodCall
   -> m MethodBody
 callMethod' mc = do
-  cl <- ncClient <$> view clientL
+  cl <- toClient <$> view clientL
   liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
 
 callMethod
@@ -308,7 +214,7 @@ addMatchCallbackSignal
   -> (Signal -> m ())
   -> m SignalHandler
 addMatchCallbackSignal rule cb = do
-  cl <- ncClient <$> view clientL
+  cl <- toClient <$> view clientL
   withRunInIO $ \run -> addMatch cl rule $ run . cb
 
 addMatchCallback
@@ -389,7 +295,7 @@ callPropertyGet
   -> MemberName
   -> m [Variant]
 callPropertyGet bus path iface property = do
-  cl <- ncClient <$> view clientL
+  cl <- toClient <$> view clientL
   res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
   case res of
     Left err -> do
@@ -541,14 +447,14 @@ addInterfaceRemovedListener bus =
 -- Interface export/unexport
 
 exportPair
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
   => ObjectPath
   -> (Client -> m Interface)
-  -> NamedConnection c
+  -> c
   -> (m (), m ())
 exportPair path toIface cl = (up, down)
   where
-    cl_ = ncClient cl
+    cl_ = toClient cl
     up = do
       logInfo $ "adding interface: " <> path_
       i <- toIface cl_

lib/Data/Internal/XIO.hs

@@ -288,18 +288,8 @@ type SubfeatureRoot a = Subfeature (Root a)
 data Root a
   = forall p. IORoot (p -> a) (IOTree p)
   | IORoot_ a IOTree_
-  | forall c p.
+  | forall c p. SafeClient c => DBusRoot (p -> c -> a) (DBusTree c p) (Maybe c)
-    SafeClient c =>
+  | forall c. SafeClient c => DBusRoot_ (c -> a) (DBusTree_ c) (Maybe 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
@@ -886,10 +876,10 @@ introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
 introspectMethod :: MemberName
 introspectMethod = memberName_ "Introspect"
 
-testDBusDep_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO MResult_
+testDBusDep_ :: SafeClient c => c -> DBusDependency_ c -> XIO MResult_
 testDBusDep_ c d = memoizeMVar $ testDBusDepNoCache_ c d
 
-testDBusDepNoCache_ :: SafeClient c => NamedConnection c -> DBusDependency_ c -> XIO Result_
+testDBusDepNoCache_ :: SafeClient c => c -> DBusDependency_ c -> XIO Result_
 testDBusDepNoCache_ cl (Bus _ bus) = do
   ret <- withDIO cl $ callMethod queryBus queryPath queryIface queryMem
   return $ case ret of
@@ -1020,11 +1010,11 @@ sometimesExeArgs fn n ful sys path args =
 
 sometimesDBus
   :: SafeClient c
-  => Maybe (NamedConnection c)
+  => Maybe c
   -> T.Text
   -> T.Text
   -> Tree_ (DBusDependency_ c)
-  -> (NamedConnection c -> a)
+  -> (c -> a)
   -> Sometimes a
 sometimesDBus c fn n t x = sometimes1 fn n $ DBusRoot_ x t c
 
@@ -1038,7 +1028,7 @@ sometimesEndpoint
   -> ObjectPath
   -> InterfaceName
   -> MemberName
-  -> Maybe (NamedConnection c)
+  -> Maybe 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 NamedSysConnection -> Sometimes (m ())
+runNetMenu :: MonadUnliftIO m => Maybe SysClient -> 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 NamedSesConnection -> Sometimes (m ())
+runBwMenu :: MonadUnliftIO m => Maybe SesClient -> 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 NamedSesConnection
+  -> Maybe SesClient
   -> 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 NamedSesConnection -> Sometimes (m ())
+runNotificationClose :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationClose = runNotificationCmd "close notification" "close"
 
-runNotificationCloseAll :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationCloseAll :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationCloseAll =
   runNotificationCmd "close all notifications" "close-all"
 
-runNotificationHistory :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationHistory :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runNotificationHistory =
   runNotificationCmd "see notification history" "history-pop"
 
-runNotificationContext :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runNotificationContext :: MonadUnliftIO m => Maybe SesClient -> 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 NamedSysConnection -> Sometimes (XIO (P.Process () () ()))
+runNetAppDaemon :: Maybe SysClient -> 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 NamedSysConnection -> Sometimes (m ())
+runToggleBluetooth :: MonadUnliftIO m => Maybe SysClient -> Sometimes (m ())
 runToggleBluetooth cl =
   Sometimes
     "bluetooth toggle"
@@ -366,7 +366,7 @@ runFlameshot
   :: MonadUnliftIO m
   => T.Text
   -> T.Text
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> 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 NamedSesConnection -> Sometimes (m ())
+runAreaCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runAreaCapture = runFlameshot "screen area capture" "gui"
 
 -- myWindowCap = "screencap -w" --external script
 
-runDesktopCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runDesktopCapture :: MonadUnliftIO m => Maybe SesClient -> Sometimes (m ())
 runDesktopCapture = runFlameshot "fullscreen capture" "full"
 
-runScreenCapture :: MonadUnliftIO m => Maybe NamedSesConnection -> Sometimes (m ())
+runScreenCapture :: MonadUnliftIO m => Maybe SesClient -> 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 NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m (), m ())
 exportClevoKeyboard =
   brightnessExporter
@@ -128,7 +128,7 @@ exportClevoKeyboard =
 
 clevoKeyboardControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> 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 NamedSesConnection
+  -> Maybe SesClient
   -> 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 xmonadSesBusName p i memGet
+    <$> callMethod xmonadBusName p i memGet
 
-signalDep :: BrightnessConfig m a b -> DBusDependency_ c
+signalDep :: BrightnessConfig m a b -> DBusDependency_ SesClient
 signalDep BrightnessConfig {bcPath = p, bcInterface = i} =
-  Endpoint [] xmonadSesBusName p i $ Signal_ memCur
+  Endpoint [] xmonadBusName p i $ Signal_ memCur
 
 matchSignal
   :: ( HasClient env
@@ -112,18 +112,18 @@ brightnessExporter
   -> [Fulfillment]
   -> [IODependency_]
   -> BrightnessConfig m a b
-  -> Maybe NamedSesConnection
+  -> Maybe SesClient
   -> 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 xmonadSesBusName) $ fmap DBusIO deps
+    tree = listToAnds (Bus ful xmonadBusName) $ fmap DBusIO deps
 
 exportBrightnessControlsInner
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, RealFrac b)
   => BrightnessConfig m a b
-  -> NamedSesConnection
+  -> SesClient
   -> (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 NamedSesConnection
+  -> Maybe SesClient
   -> 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 [] xmonadSesBusName p i $ Method_ m) cl
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadBusName p i $ Method_ m) cl
-    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m
+    cmd c = void $ withDIO c $ callMethod xmonadBusName 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 NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m (), m ())
 exportIntelBacklight =
   brightnessExporter
@@ -114,7 +114,7 @@ exportIntelBacklight =
 
 intelBacklightControls
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> BrightnessControls m
 intelBacklightControls = brightnessControls xpfIntelBacklight intelBacklightConfig
 

lib/XMonad/Internal/DBus/Common.hs

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

lib/XMonad/Internal/DBus/Control.hs

@@ -10,8 +10,9 @@ module XMonad.Internal.DBus.Control
   , withDBus
   , withDBus_
   , connectDBus
+  , connectDBusX
   , disconnectDBus
-  -- , disconnectDBusX
+  , disconnectDBusX
   , getDBusClient
   , withDBusClient
   , withDBusClient_
@@ -25,6 +26,7 @@ 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
@@ -32,8 +34,8 @@ import XMonad.Internal.DBus.Screensaver
 
 -- | Current connections to the DBus (session and system buses)
 data DBusState = DBusState
-  { dbSesClient :: Maybe NamedSesConnection
+  { dbSesClient :: Maybe SesClient
-  , dbSysClient :: Maybe NamedSysConnection
+  , dbSysClient :: Maybe SysClient
   }
 
 withDBusX_
@@ -45,79 +47,60 @@ withDBusX_ = void . withDBusX
 withDBusX
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
   => (DBusState -> m a)
-  -> m a
+  -> m (Maybe a)
-withDBusX = withDBus (Just xmonadSesBusName) Nothing
+withDBusX f = withDBus $ \db -> do
+  forM (dbSesClient db) $ \ses -> do
+    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
 
 withDBus_
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => (DBusState -> m a)
-  -> Maybe BusName
-  -> (DBusState -> m a)
   -> m ()
-withDBus_ sesname sysname = void . withDBus sesname sysname
+withDBus_ = void . withDBus
 
 withDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => (DBusState -> m a)
-  -> Maybe BusName
-  -> (DBusState -> m a)
   -> m a
-withDBus sesname sysname = bracket (connectDBus sesname sysname) disconnectDBus
+withDBus = bracket connectDBus disconnectDBus
 
 -- | Connect to the DBus
 connectDBus
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => Maybe BusName
+  => m DBusState
-  -> Maybe BusName
+connectDBus = do
-  -> m DBusState
+  ses <- getDBusClient
-connectDBus sesname sysname = do
+  sys <- getDBusClient
-  ses <- getDBusClient sesname
-  sys <- getDBusClient sysname
   return DBusState {dbSesClient = ses, dbSysClient = sys}
 
 -- | Disconnect from the DBus
-disconnectDBus
+disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
+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 ()
-disconnectDBus db = disc dbSesClient >> disc dbSysClient
+disconnectDBusX db = do
-  where
+  forM_ (dbSesClient db) releaseXMonadName
-    disc
+  disconnectDBus db
-      :: (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 NamedSesConnection -> Sometimes (XIO (), XIO ())]
+  -> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
   -> ([XIO ()] -> XIO a)
   -> XIO a
 withDBusInterfaces db interfaces = bracket up sequence
@@ -130,59 +113,35 @@ withDBusInterfaces db interfaces = bracket up sequence
 -- | All exporter features to be assigned to the DBus
 dbusExporters
   :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => [Maybe NamedSesConnection -> Sometimes (m (), m ())]
+  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
 
--- releaseXMonadName
+releaseXMonadName
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
---   => c
+  => SesClient
---   -> m ()
+  -> m ()
--- releaseXMonadName cl = do
+releaseXMonadName ses = do
---   -- TODO this might error?
+  -- TODO this might error?
---   liftIO $ void $ releaseName (toClient cl) xmonadBusName
+  liftIO $ void $ releaseName (toClient ses) xmonadBusName
---   logInfo "released xmonad name"
+  logInfo "released xmonad name"
 
--- releaseBusName
+requestXMonadName
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
---   => BusName
+  => SesClient
---   -> c
+  -> m ()
---   -> m ()
+requestXMonadName ses = do
--- releaseBusName n cl = do
+  res <- liftIO $ requestName (toClient ses) xmonadBusName []
---   -- TODO this might error?
+  let msg
---   liftIO $ void $ releaseName (toClient cl) n
+        | res == NamePrimaryOwner = "registering name"
---   logInfo $ "released bus name: " <> displayBusName n
+        | res == NameAlreadyOwner = "this process already owns name"
-
+        | res == NameInQueue
--- requestBusName
+            || res == NameExists =
---   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+            "another process owns name"
---   => BusName
+        | otherwise = "unknown error when requesting name"
---   -> c
+  logInfo $ msg <> ": " <> xn
---   -> m ()
+  where
--- requestBusName n cl = do
+    xn =
---   res <- try $ liftIO $ requestName (toClient cl) n []
+      Utf8Builder $
---   case res of
+        encodeUtf8Builder $
---     Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+          T.pack $
---     Right r -> do
+            formatBusName xmonadBusName
---       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
      )
-  => NamedSysConnection
+  => SysClient
   -> m ()
 listenDevices cl = do
   addMatch' memAdded driveInsertedSound addedHasDrive
@@ -98,7 +98,7 @@ runRemovableMon
      , MonadReader env m
      , MonadUnliftIO m
      )
-  => Maybe NamedSysConnection
+  => Maybe SysClient
   -> 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 NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m (), m ())
 exportScreensaver ses =
   sometimesDBus ses "screensaver toggle" "xset" (toAnd_ bus ssx) cmd
@@ -119,19 +119,19 @@ exportScreensaver ses =
                 }
             ]
         }
-    bus = Bus [] xmonadSesBusName
+    bus = Bus [] xmonadBusName
     ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable
 
 callToggle
   :: (HasClient (DBusEnv env), MonadReader env m, MonadUnliftIO m)
-  => Maybe NamedSesConnection
+  => Maybe SesClient
   -> Sometimes (m ())
 callToggle =
   sometimesEndpoint
     "screensaver toggle"
     "dbus switch"
     []
-    xmonadSesBusName
+    xmonadBusName
     ssPath
     interface
     memToggle
@@ -140,7 +140,7 @@ callQuery
   :: (HasClient env, MonadReader (env SesClient) m, MonadUnliftIO m)
   => m (Maybe SSState)
 callQuery = do
-  reply <- callMethod xmonadSesBusName ssPath interface memQuery
+  reply <- callMethod xmonadBusName ssPath interface memQuery
   return $ either (const Nothing) bodyGetCurrentState reply
 
 matchSignal
@@ -157,4 +157,4 @@ matchSignal cb =
       (cb . bodyGetCurrentState)
 
 ssSignalDep :: DBusDependency_ SesClient
-ssSignalDep = Endpoint [] xmonadSesBusName ssPath interface $ Signal_ memState
+ssSignalDep = Endpoint [] xmonadBusName 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 Nothing (Just "ethernet.log") $ \c -> do
+    withDBusClientConnection cb (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 Nothing (Just "ethernet-cb.log") $ \c' ->
+                withDBusClientConnection cb (Just "ethernet-cb.log") $ \c' ->
                   mapEnv c' $
                     testActiveType contypes sig
 

lib/Xmobar/Plugins/BacklightCommon.hs

@@ -4,7 +4,6 @@
 -- 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
@@ -12,15 +11,14 @@ import Xmobar.Plugins.Common
 
 startBacklight
   :: (MonadUnliftIO m, RealFrac a)
-  => Maybe BusName
+  => Maybe FilePath
-  -> Maybe FilePath
   -> ((Maybe a -> DIO SimpleApp SesClient ()) -> DIO SimpleApp SesClient ())
   -> DIO SimpleApp SesClient (Maybe a)
   -> T.Text
   -> Callback
   -> m ()
-startBacklight n name matchSignal callGetBrightness icon cb = do
+startBacklight name matchSignal callGetBrightness icon cb = do
-  withDBusClientConnection cb n name $ \c -> withDIO c $ do
+  withDBusClientConnection cb name $ \c -> withDIO c $ do
     matchSignal dpy
     dpy =<< callGetBrightness
   where

lib/Xmobar/Plugins/Bluetooth.hs

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

lib/Xmobar/Plugins/ClevoKeyboard.hs

@@ -24,9 +24,4 @@ ckAlias = "clevokeyboard"
 instance Exec ClevoKeyboard where
   alias (ClevoKeyboard _) = T.unpack ckAlias
   start (ClevoKeyboard icon) =
-    startBacklight
+    startBacklight (Just "clevo_kbd.log") matchSignalCK callGetBrightnessCK icon
-      (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 :: !(NamedConnection c)
+  { plugClient :: !c
   , plugState :: !(MVar s)
   , plugDisplay :: !(Callback -> PluginIO s c ())
   , plugCallback :: !Callback
@@ -99,20 +99,17 @@ displayMaybe' cb = maybe (liftIO $ cb $ T.unpack na)
 withDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c)
   => Callback
-  -> Maybe BusName
   -> Maybe FilePath
-  -> (NamedConnection c -> RIO SimpleApp ())
+  -> (c -> RIO SimpleApp ())
   -> m ()
-withDBusClientConnection cb n logfile f =
+withDBusClientConnection cb 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 $
+        runRIO env $ displayMaybe' cb f =<< getDBusClient
-          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
@@ -120,12 +117,11 @@ withDBusClientConnection cb n logfile f =
 -- DBus connection and closed its logfile.
 withNestedDBusClientConnection
   :: (MonadUnliftIO m, SafeClient c, MonadReader (PluginEnv s c) m)
-  => Maybe BusName
+  => Maybe FilePath
-  -> Maybe FilePath
   -> PluginIO s c ()
   -> m ()
-withNestedDBusClientConnection n logfile f = do
+withNestedDBusClientConnection logfile f = do
   dpy <- asks plugDisplay
   s <- asks plugState
   cb <- asks plugCallback
-  withDBusClientConnection cb n logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f
+  withDBusClientConnection cb logfile $ \c -> mapRIO (PluginEnv c s dpy cb) f

lib/Xmobar/Plugins/IntelBacklight.hs

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

lib/Xmobar/Plugins/Screensaver.hs

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

stack.yaml

@@ -17,8 +17,8 @@
 #
 # resolver: ./custom-snapshot.yaml
 # resolver: https://example.com/snapshots/2018-01-01.yaml
-resolver: lts-19.33
+#resolver: lts-17.4
-#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.