WIP name dbus connections

This commit is contained in:
Nathan Dwarshuis 2023-10-25 20:40:15 -04:00
parent 58b68f298c
commit 78ba3173c3
5 changed files with 107 additions and 52 deletions

View File

@ -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

View File

@ -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)

View File

@ -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"

View File

@ -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 []
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
| res == NamePrimaryOwner = "registering name"
| res == NameAlreadyOwner = "this process already owns name"
| res == NameInQueue
|| res == NameExists =
| 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 <> ": " <> xn
where
xn =
Utf8Builder $
encodeUtf8Builder $
T.pack $
formatBusName xmonadBusName
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

View File

@ -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