101 lines
2.9 KiB
Haskell
101 lines
2.9 KiB
Haskell
-- | High-level interface for managing XMonad's DBus
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module XMonad.Internal.DBus.Control
|
|
( Client
|
|
, DBusState(..)
|
|
, connectDBus
|
|
, connectDBusX
|
|
, disconnectDBus
|
|
, disconnectDBusX
|
|
, getDBusClient
|
|
, withDBusClient
|
|
, withDBusClient_
|
|
, disconnect
|
|
, dbusExporters
|
|
) where
|
|
|
|
import Data.Internal.DBus
|
|
import Data.Internal.Dependency
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
|
|
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
|
|
}
|
|
|
|
-- | Connect to the DBus
|
|
connectDBus
|
|
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
|
=> 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
|
|
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
|
=> m DBusState
|
|
connectDBusX = do
|
|
db <- connectDBus
|
|
forM_ (dbSesClient db) requestXMonadName
|
|
return db
|
|
|
|
-- | Disconnect from DBus and release the XMonad name
|
|
disconnectDBusX
|
|
:: (MonadUnliftIO m)
|
|
=> DBusState
|
|
-> m ()
|
|
disconnectDBusX db = do
|
|
forM_ (dbSesClient db) releaseXMonadName
|
|
disconnectDBus db
|
|
|
|
-- | All exporter features to be assigned to the DBus
|
|
dbusExporters :: [Maybe SesClient -> SometimesIO]
|
|
dbusExporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
|
|
|
|
releaseXMonadName
|
|
:: (MonadUnliftIO m)
|
|
=> SesClient
|
|
-> m ()
|
|
releaseXMonadName ses = void $ liftIO $ releaseName (toClient ses) xmonadBusName
|
|
|
|
requestXMonadName
|
|
:: (MonadUnliftIO m, MonadReader env m, HasLogFunc env)
|
|
=> SesClient
|
|
-> m ()
|
|
requestXMonadName ses = do
|
|
res <- liftIO $ requestName (toClient ses) xmonadBusName []
|
|
-- TODO if the client is not released on shutdown the owner will be different
|
|
let msg | res == NamePrimaryOwner = Nothing
|
|
| res == NameAlreadyOwner = Just "this process already owns bus name"
|
|
| res == NameInQueue
|
|
|| res == NameExists = Just "another process owns bus name"
|
|
| otherwise = Just "unknown error when requesting bus name"
|
|
forM_ msg $ \m ->
|
|
logError $ Utf8Builder $ encodeUtf8Builder $ T.concat [m, ": ", xn]
|
|
where
|
|
xn = T.pack $ formatBusName xmonadBusName
|