WIP name dbus connections

2023-10-25 20:40:15 -04:00 · 2023-10-25 20:40:15 -04:00 · 78ba3173c3
parent 58b68f298c
commit 78ba3173c3
5 changed files with 107 additions and 52 deletions
--- a/lib/Data/Internal/DBus.hs
+++ b/lib/Data/Internal/DBus.hs
@ -55,6 +55,12 @@ import qualified RIO.Text as T
 --------------------------------------------------------------------------------
 -- Type-safe client

+-- data NamedConnection c = NamedConnection
+--   { ncClient :: Client
+--   , ncName :: Maybe BusName
+--   , ncType :: c
+--   }
+
 class SafeClient c where
  toClient :: c -> Client

--- a/lib/XMonad/Internal/DBus/Brightness/Common.hs
+++ b/lib/XMonad/Internal/DBus/Brightness/Common.hs
@ -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 {bcPath = p, bcInterface = i} =
-  Endpoint [] xmonadBusName p i $ Signal_ memCur
+  Endpoint [] xmonadSesBusName p i $ Signal_ memCur

 matchSignal
  :: ( HasClient env
@ -118,7 +118,7 @@ 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)
@ -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
-    cmd c = void $ withDIO c $ callMethod xmonadBusName p i m
+    root = DBusRoot_ cmd (Only_ $ Endpoint [] xmonadSesBusName p i $ Method_ m) cl
+    cmd c = void $ withDIO c $ callMethod xmonadSesBusName p i m

 bodyGetBrightness :: Num a => [Variant] -> Maybe a
 bodyGetBrightness [b] = fromIntegral <$> (fromVariant b :: Maybe Int32)
--- a/lib/XMonad/Internal/DBus/Common.hs
+++ b/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
-xmonadBusName = busName_ "org.xmonad"
+xmonadSesBusName :: BusName
+xmonadSesBusName = busName_ "org.xmonad.Session"
+
+xmonadSysBusName :: BusName
+xmonadSysBusName = busName_ "org.xmonad.System"

 btBus :: BusName
 btBus = busName_ "org.bluez"
--- a/lib/XMonad/Internal/DBus/Control.hs
+++ b/lib/XMonad/Internal/DBus/Control.hs
@ -10,7 +10,6 @@ module XMonad.Internal.DBus.Control
  , withDBus
  , withDBus_
  , connectDBus
-  , connectDBusX
  , disconnectDBus
  , disconnectDBusX
  , getDBusClient
@ -23,10 +22,10 @@ where

 import DBus
 import DBus.Client
+import qualified Data.ByteString.Char8 as BC
 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
@ -49,8 +48,21 @@ withDBusX
  => (DBusState -> m a)
  -> m (Maybe a)
 withDBusX f = withDBus $ \db -> do
-  forM (dbSesClient db) $ \ses -> do
-    bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
+  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)
@ -80,14 +92,14 @@ disconnectDBus db = disc dbSesClient >> disc dbSysClient
    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
+-- -- | 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
@ -95,9 +107,18 @@ disconnectDBusX
  => DBusState
  -> m ()
 disconnectDBusX db = do
-  forM_ (dbSesClient db) releaseXMonadName
+  forM_ (dbSesClient db) $ releaseBusName xmonadSesBusName
+  forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName
  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 ())]
@ -116,32 +137,56 @@ dbusExporters
  => [Maybe SesClient -> Sometimes (m (), m ())]
 dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]

-releaseXMonadName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
-  -> m ()
-releaseXMonadName ses = do
-  -- TODO this might error?
-  liftIO $ void $ releaseName (toClient ses) xmonadBusName
-  logInfo "released xmonad name"
+-- releaseXMonadName
+--   :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+--   => c
+--   -> m ()
+-- releaseXMonadName cl = do
+--   -- TODO this might error?
+--   liftIO $ void $ releaseName (toClient cl) xmonadBusName
+--   logInfo "released xmonad name"

-requestXMonadName
-  :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
-  => SesClient
+releaseBusName
+  :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => BusName
+  -> c
  -> m ()
-requestXMonadName ses = do
-  res <- liftIO $ requestName (toClient ses) 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 <> ": " <> xn
-  where
-    xn =
-      Utf8Builder $
-        encodeUtf8Builder $
-          T.pack $
-            formatBusName xmonadBusName
+releaseBusName n cl = do
+  -- TODO this might error?
+  liftIO $ void $ releaseName (toClient cl) n
+  logInfo $ "released bus name: " <> displayBusName n
+
+requestBusName
+  :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
+  => BusName
+  -> c
+  -> m ()
+requestBusName n cl = do
+  res <- try $ liftIO $ requestName (toClient cl) n []
+  case res of
+    Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
+    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
--- a/lib/XMonad/Internal/DBus/Screensaver.hs
+++ b/lib/XMonad/Internal/DBus/Screensaver.hs
@ -119,7 +119,7 @@ exportScreensaver ses =
                }
            ]
        }
-    bus = Bus [] xmonadBusName
+    bus = Bus [] xmonadSesBusName
    ssx = DBusIO $ sysExe [Package Official "xorg-xset"] ssExecutable

 callToggle
@ -131,7 +131,7 @@ callToggle =
    "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