150 lines
4.0 KiB
Haskell
150 lines
4.0 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- High-level interface for managing XMonad's DBus
|
|
|
|
module XMonad.Internal.DBus.Control
|
|
( Client
|
|
, DBusState (..)
|
|
, withDBusInterfaces
|
|
, withDBusX
|
|
, withDBusX_
|
|
, withDBus
|
|
, withDBus_
|
|
, connectDBus
|
|
, connectDBusX
|
|
, disconnectDBus
|
|
, disconnectDBusX
|
|
, getDBusClient
|
|
, withDBusClient
|
|
, withDBusClient_
|
|
, disconnect
|
|
, dbusExporters
|
|
)
|
|
where
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import Data.Internal.DBus
|
|
import Data.Internal.Dependency
|
|
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
|
|
import XMonad.Internal.DBus.Screensaver
|
|
|
|
-- | Current connections to the DBus (session and system buses)
|
|
data DBusState = DBusState
|
|
{ dbSesClient :: Maybe SesClient
|
|
, dbSysClient :: Maybe SysClient
|
|
}
|
|
|
|
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 ()
|
|
withDBus_ = void . withDBus
|
|
|
|
withDBus
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (DBusState -> m a)
|
|
-> m a
|
|
withDBus = bracket connectDBus disconnectDBus
|
|
|
|
-- | Connect to the DBus
|
|
connectDBus
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> m DBusState
|
|
connectDBus = do
|
|
ses <- getDBusClient
|
|
sys <- getDBusClient
|
|
return DBusState {dbSesClient = ses, dbSysClient = sys}
|
|
|
|
-- | Disconnect from the DBus
|
|
disconnectDBus :: MonadUnliftIO m => DBusState -> m ()
|
|
disconnectDBus db = disc dbSesClient >> disc dbSysClient
|
|
where
|
|
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
|
|
|
|
-- | Disconnect from DBus and release the XMonad name
|
|
disconnectDBusX
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> DBusState
|
|
-> m ()
|
|
disconnectDBusX db = do
|
|
forM_ (dbSesClient db) releaseXMonadName
|
|
disconnectDBus db
|
|
|
|
withDBusInterfaces
|
|
:: DBusState
|
|
-> [Maybe SesClient -> Sometimes (FIO (), FIO ())]
|
|
-> ([FIO ()] -> FIO a)
|
|
-> FIO a
|
|
withDBusInterfaces db interfaces = bracket up sequence
|
|
where
|
|
up = do
|
|
pairs <- catMaybes <$> mapM (\f -> evalSometimes $ f $ dbSesClient db) interfaces
|
|
mapM_ fst pairs
|
|
return $ snd <$> pairs
|
|
|
|
-- | All exporter features to be assigned to the DBus
|
|
dbusExporters
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> [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"
|
|
|
|
requestXMonadName
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> SesClient
|
|
-> 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
|