xmonad-config/lib/XMonad/Internal/DBus/Control.hs

148 lines
4.0 KiB
Haskell
Raw Normal View History

--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- High-level interface for managing XMonad's DBus
2020-04-01 20:17:47 -04:00
module XMonad.Internal.DBus.Control
( Client
2022-12-30 14:58:23 -05:00
, DBusState (..)
2023-01-01 12:43:54 -05:00
, withDBusInterfaces
, withDBusX
, withDBusX_
2022-12-31 22:31:23 -05:00
, withDBus
, withDBus_
2022-07-03 18:23:32 -04:00
, connectDBus
, connectDBusX
, disconnectDBus
, disconnectDBusX
, getDBusClient
2021-11-23 18:28:38 -05:00
, withDBusClient
, withDBusClient_
, disconnect
, dbusExporters
2022-12-30 14:58:23 -05:00
)
where
2020-03-20 00:51:36 -04:00
2022-12-30 14:58:23 -05:00
import DBus
import DBus.Client
import Data.Internal.DBus
2023-01-01 18:33:02 -05:00
import Data.Internal.XIO
2022-12-30 17:11:06 -05:00
import RIO
import qualified RIO.Text as T
2022-12-30 14:58:23 -05:00
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
import XMonad.Internal.DBus.Screensaver
2020-04-01 20:17:47 -04:00
2022-07-03 18:23:32 -04:00
-- | Current connections to the DBus (session and system buses)
data DBusState = DBusState
2022-12-30 14:58:23 -05:00
{ dbSesClient :: Maybe SesClient
, dbSysClient :: Maybe SysClient
}
2020-03-20 00:51:36 -04:00
withDBusX_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m ()
withDBusX_ = void . withDBusX
withDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m (Maybe a)
withDBusX f = withDBus $ \db -> do
forM (dbSesClient db) $ \ses -> do
bracket_ (requestXMonadName ses) (releaseXMonadName ses) $ f db
withDBus_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m ()
2022-12-31 22:31:23 -05:00
withDBus_ = void . withDBus
withDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (DBusState -> m a)
-> m a
2022-12-31 22:31:23 -05:00
withDBus = bracket connectDBus disconnectDBus
2022-07-03 18:23:32 -04:00
-- | Connect to the DBus
connectDBus
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
2022-07-03 18:23:32 -04:00
connectDBus = do
2022-07-09 17:08:10 -04:00
ses <- getDBusClient
sys <- getDBusClient
2022-12-30 14:58:23 -05:00
return DBusState {dbSesClient = ses, dbSysClient = sys}
2022-07-03 18:23:32 -04:00
-- | Disconnect from the DBus
2022-12-30 17:11:06 -05:00
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
2022-07-09 18:04:26 -04:00
disconnectDBus db = disc dbSesClient >> disc dbSysClient
where
2023-02-12 23:08:05 -05:00
disc :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
2022-07-09 18:04:26 -04:00
disc f = maybe (return ()) disconnectDBusClient $ f db
2022-07-03 18:23:32 -04:00
-- | Connect to the DBus and request the XMonad name
connectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m DBusState
2022-07-03 18:23:32 -04:00
connectDBusX = do
db <- connectDBus
2022-07-09 18:04:26 -04:00
forM_ (dbSesClient db) requestXMonadName
2022-07-03 18:23:32 -04:00
return db
-- | Disconnect from DBus and release the XMonad name
2022-12-31 23:56:23 -05:00
disconnectDBusX
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> DBusState
-> m ()
2022-07-03 18:23:32 -04:00
disconnectDBusX db = do
2022-07-09 18:04:26 -04:00
forM_ (dbSesClient db) releaseXMonadName
2022-07-03 18:23:32 -04:00
disconnectDBus db
2023-01-01 12:49:56 -05:00
withDBusInterfaces
:: DBusState
2023-01-01 15:00:40 -05:00
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
-> ([XIO ()] -> XIO a)
-> XIO a
2023-01-01 12:49:56 -05:00
withDBusInterfaces db interfaces = bracket up sequence
2023-01-01 12:43:54 -05:00
where
up = do
2023-01-01 12:49:56 -05:00
pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
2023-01-01 12:43:54 -05:00
mapM_ fst pairs
return $ snd <$> pairs
2022-07-03 18:23:32 -04:00
-- | All exporter features to be assigned to the DBus
2023-01-01 13:07:10 -05:00
dbusExporters
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> [Maybe SesClient -> Sometimes (m (), m ())]
2022-07-03 18:23:32 -04:00
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
2022-12-31 23:56:23 -05:00
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"
2021-11-20 15:20:22 -05:00
requestXMonadName
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> SesClient
-> m ()
2022-07-09 18:04:26 -04:00
requestXMonadName ses = do
2022-12-30 17:11:06 -05:00
res <- liftIO $ requestName (toClient ses) xmonadBusName []
2022-12-30 14:58:23 -05:00
let msg
| res == NamePrimaryOwner = "registering name"
| res == NameAlreadyOwner = "this process already owns name"
2022-12-30 14:58:23 -05:00
| res == NameInQueue
|| res == NameExists =
"another process owns name"
| otherwise = "unknown error when requesting name"
logInfo $ msg <> ": " <> xn
2021-11-20 15:20:22 -05:00
where
xn =
Utf8Builder $
encodeUtf8Builder $
T.pack $
formatBusName xmonadBusName