ENH generalize dbus controls
This commit is contained in:
parent
c36a63e251
commit
e508f29bd8
|
@ -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 ++ "'"
|
||||||
|
|
Loading…
Reference in New Issue