From 78ba3173c35f896e4569437579f6b74ac97e0607 Mon Sep 17 00:00:00 2001 From: ndwarshuis Date: Wed, 25 Oct 2023 20:40:15 -0400 Subject: [PATCH] WIP name dbus connections --- lib/Data/Internal/DBus.hs | 6 + lib/XMonad/Internal/DBus/Brightness/Common.hs | 10 +- lib/XMonad/Internal/DBus/Common.hs | 10 +- lib/XMonad/Internal/DBus/Control.hs | 125 ++++++++++++------ lib/XMonad/Internal/DBus/Screensaver.hs | 8 +- 5 files changed, 107 insertions(+), 52 deletions(-) diff --git a/lib/Data/Internal/DBus.hs b/lib/Data/Internal/DBus.hs index 144901a..c5a0f2d 100644 --- 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 diff --git a/lib/XMonad/Internal/DBus/Brightness/Common.hs b/lib/XMonad/Internal/DBus/Brightness/Common.hs index 13746f4..68aab36 100644 --- 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) diff --git a/lib/XMonad/Internal/DBus/Common.hs b/lib/XMonad/Internal/DBus/Common.hs index 65c6006..1b7d8e0 100644 --- 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" diff --git a/lib/XMonad/Internal/DBus/Control.hs b/lib/XMonad/Internal/DBus/Control.hs index c19ebb4..6e43ff0 100644 --- 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 diff --git a/lib/XMonad/Internal/DBus/Screensaver.hs b/lib/XMonad/Internal/DBus/Screensaver.hs index 7d0d35d..f01c4ef 100644 --- 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