193 lines
5.5 KiB
Haskell
193 lines
5.5 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- High-level interface for managing XMonad's DBus
|
|
|
|
module XMonad.Internal.DBus.Control
|
|
( Client
|
|
, DBusState (..)
|
|
, withDBusInterfaces
|
|
, withDBusX
|
|
, withDBusX_
|
|
, withDBus
|
|
, withDBus_
|
|
, connectDBus
|
|
, disconnectDBus
|
|
, disconnectDBusX
|
|
, getDBusClient
|
|
, withDBusClient
|
|
, withDBusClient_
|
|
, disconnect
|
|
, dbusExporters
|
|
)
|
|
where
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import Data.Internal.DBus
|
|
import Data.Internal.XIO
|
|
import RIO
|
|
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
|
|
case (dbSesClient db, dbSysClient db) of
|
|
(Just ses, Just sys) -> do
|
|
res <-
|
|
bracket_
|
|
( do
|
|
requestBusName xmonadSesBusName ses
|
|
requestBusName xmonadSysBusName sys
|
|
)
|
|
( do
|
|
releaseBusName xmonadSesBusName ses
|
|
releaseBusName xmonadSysBusName sys
|
|
)
|
|
$ f db
|
|
return $ Just res
|
|
_ -> return Nothing
|
|
|
|
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 :: (MonadUnliftIO m, SafeClient c) => (DBusState -> Maybe c) -> m ()
|
|
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
|
|
-- requestXMonadName2 db
|
|
-- 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) $ releaseBusName xmonadSesBusName
|
|
forM_ (dbSysClient db) $ releaseBusName xmonadSysBusName
|
|
disconnectDBus db
|
|
|
|
-- requestXMonadName2
|
|
-- :: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
-- => DBusState
|
|
-- -> m ()
|
|
-- requestXMonadName2 db = do
|
|
-- forM_ (dbSesClient db) requestXMonadName
|
|
-- forM_ (dbSysClient db) requestXMonadName
|
|
|
|
withDBusInterfaces
|
|
:: DBusState
|
|
-> [Maybe SesClient -> Sometimes (XIO (), XIO ())]
|
|
-> ([XIO ()] -> XIO a)
|
|
-> XIO 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
|
|
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
-- => c
|
|
-- -> m ()
|
|
-- releaseXMonadName cl = do
|
|
-- -- TODO this might error?
|
|
-- liftIO $ void $ releaseName (toClient cl) xmonadBusName
|
|
-- logInfo "released xmonad name"
|
|
|
|
releaseBusName
|
|
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> BusName
|
|
-> c
|
|
-> m ()
|
|
releaseBusName n cl = do
|
|
-- TODO this might error?
|
|
liftIO $ void $ releaseName (toClient cl) n
|
|
logInfo $ "released bus name: " <> displayBusName n
|
|
|
|
requestBusName
|
|
:: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> BusName
|
|
-> c
|
|
-> m ()
|
|
requestBusName n cl = do
|
|
res <- try $ liftIO $ requestName (toClient cl) n []
|
|
case res of
|
|
Left e -> logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
|
Right r -> do
|
|
let msg
|
|
| r == NamePrimaryOwner = "registering name"
|
|
| r == NameAlreadyOwner = "this process already owns name"
|
|
| r == NameInQueue
|
|
|| r == NameExists =
|
|
"another process owns name"
|
|
-- this should never happen
|
|
| otherwise = "unknown error when requesting name"
|
|
logInfo $ msg <> ": " <> displayBusName n
|
|
|
|
-- requestXMonadName
|
|
-- :: (SafeClient c, MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
-- => c
|
|
-- -> m ()
|
|
-- requestXMonadName cl = do
|
|
-- res <- liftIO $ requestName (toClient cl) 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 <> ": " <> displayBusName xmonadBusName
|