ndwarshuis
/
xmonad-config
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

ENH generalize dbus controls

This commit is contained in:
Nathan Dwarshuis 2022-12-30 17:11:06 -05:00
parent c36a63e251
commit e508f29bd8
1 changed files with 10 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
lib/XMonad/Internal/DBus/Control.hs
View File

@ -18,11 +18,11 @@ module XMonad.Internal.DBus.Control
) )
where where
import Control.Monad
import DBus import DBus
import DBus.Client import DBus.Client
import Data.Internal.DBus import Data.Internal.DBus
import Data.Internal.Dependency import Data.Internal.Dependency
import RIO
import XMonad.Internal.DBus.Brightness.ClevoKeyboard import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common import XMonad.Internal.DBus.Common
@ -35,27 +35,27 @@ data DBusState = DBusState
} }
-- | Connect to the DBus -- | Connect to the DBus
connectDBus :: IO DBusState connectDBus :: MonadUnliftIO m => m DBusState
connectDBus = do connectDBus = do
ses <- getDBusClient ses <- getDBusClient
sys <- getDBusClient sys <- getDBusClient
return DBusState {dbSesClient = ses, dbSysClient = sys} return DBusState {dbSesClient = ses, dbSysClient = sys}
-- | Disconnect from the DBus -- | Disconnect from the DBus
disconnectDBus :: DBusState -> IO () disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
disconnectDBus db = disc dbSesClient >> disc dbSysClient disconnectDBus db = disc dbSesClient >> disc dbSysClient
where where
disc f = maybe (return ()) disconnectDBusClient $ f db disc f = maybe (return ()) disconnectDBusClient $ f db
-- | Connect to the DBus and request the XMonad name -- | Connect to the DBus and request the XMonad name
connectDBusX :: IO DBusState connectDBusX :: MonadUnliftIO m => m DBusState
connectDBusX = do connectDBusX = do
db <- connectDBus db <- connectDBus
forM_ (dbSesClient db) requestXMonadName forM_ (dbSesClient db) requestXMonadName
return db return db
-- | Disconnect from DBus and release the XMonad name -- | Disconnect from DBus and release the XMonad name
disconnectDBusX :: DBusState -> IO () disconnectDBusX :: MonadUnliftIO m => DBusState -> m ()
disconnectDBusX db = do disconnectDBusX db = do
forM_ (dbSesClient db) releaseXMonadName forM_ (dbSesClient db) releaseXMonadName
disconnectDBus db disconnectDBus db
@ -64,12 +64,12 @@ disconnectDBusX db = do
dbusExporters :: [Maybe SesClient -> SometimesIO] dbusExporters :: [Maybe SesClient -> SometimesIO]
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard] dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
releaseXMonadName :: SesClient -> IO () releaseXMonadName :: MonadUnliftIO m => SesClient -> m ()
releaseXMonadName ses = void $ releaseName (toClient ses) xmonadBusName releaseXMonadName ses = liftIO $ void $ releaseName (toClient ses) xmonadBusName
requestXMonadName :: SesClient -> IO () requestXMonadName :: MonadUnliftIO m => SesClient -> m ()
requestXMonadName ses = do requestXMonadName ses = do
res <- requestName (toClient ses) xmonadBusName [] res <- liftIO $ requestName (toClient ses) xmonadBusName []
-- TODO if the client is not released on shutdown the owner will be different -- TODO if the client is not released on shutdown the owner will be different
let msg let msg
| res == NamePrimaryOwner = Nothing | res == NamePrimaryOwner = Nothing
@ -78,6 +78,6 @@ requestXMonadName ses = do
|| res == NameExists = || res == NameExists =
Just $ "another process owns " ++ xn Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn | otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn liftIO $ forM_ msg putStrLn
where where
xn = "'" ++ formatBusName xmonadBusName ++ "'" xn = "'" ++ formatBusName xmonadBusName ++ "'"