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

76 lines
2.4 KiB
Haskell
Raw Normal View History

{-# LANGUAGE ScopedTypeVariables #-}
2020-03-20 00:51:36 -04:00
2020-04-01 22:06:00 -04:00
--------------------------------------------------------------------------------
-- | High-level interface for managing XMonad's DBus
2020-04-01 20:17:47 -04:00
module XMonad.Internal.DBus.Control
( Client
, startXMonadService
, getDBusClient
2020-04-01 20:17:47 -04:00
, stopXMonadService
, pathExists
, disconnect
2020-04-01 20:17:47 -04:00
) where
2020-03-20 00:51:36 -04:00
2021-11-20 15:20:22 -05:00
import Control.Exception
import Control.Monad (forM_, void)
import Data.Either
import DBus
import DBus.Client
2020-03-20 00:51:36 -04:00
2021-11-21 00:42:40 -05:00
import XMonad.Internal.DBus.Brightness.ClevoKeyboard
2021-11-20 15:20:22 -05:00
import XMonad.Internal.DBus.Brightness.IntelBacklight
import XMonad.Internal.DBus.Common
2020-04-01 20:17:47 -04:00
import XMonad.Internal.DBus.Screensaver
2021-11-20 15:20:22 -05:00
import XMonad.Internal.Dependency
2020-04-01 20:17:47 -04:00
introspectInterface :: InterfaceName
introspectInterface = interfaceName_ "org.freedesktop.DBus.Introspectable"
introspectMethod :: MemberName
introspectMethod = memberName_ "Introspect"
2021-11-20 15:20:22 -05:00
startXMonadService :: IO (Maybe Client)
2020-03-20 00:51:36 -04:00
startXMonadService = do
client <- getDBusClient False
forM_ client requestXMonadName
mapM_ (\f -> executeFeature_ $ f client) exporters
return client
where
exporters = [exportScreensaver, exportIntelBacklight, exportClevoKeyboard]
2020-03-20 00:51:36 -04:00
stopXMonadService :: Client -> IO ()
stopXMonadService client = do
void $ releaseName client xmonadBusName
2020-03-20 00:51:36 -04:00
disconnect client
2021-11-20 15:20:22 -05:00
getDBusClient :: Bool -> IO (Maybe Client)
getDBusClient sys = do
res <- try $ if sys then connectSystem else connectSession
2021-11-20 15:20:22 -05:00
case res of
Left e -> putStrLn (clientErrorMessage e) >> return Nothing
Right c -> return $ Just c
requestXMonadName :: Client -> IO ()
requestXMonadName client = do
res <- requestName client xmonadBusName []
2021-11-21 00:42:40 -05:00
-- TODO if the client is not released on shutdown the owner will be different
2021-11-20 15:20:22 -05:00
let msg | res == NamePrimaryOwner = Nothing
| res == NameAlreadyOwner = Just $ "this process already owns " ++ xn
| res == NameInQueue
|| res == NameExists = Just $ "another process owns " ++ xn
| otherwise = Just $ "unknown error when requesting " ++ xn
forM_ msg putStrLn
where
xn = "'" ++ formatBusName xmonadBusName ++ "'"
2020-03-20 00:51:36 -04:00
pathExists :: Bool -> BusName -> ObjectPath -> IO Bool
pathExists sysbus n p = do
client <- if sysbus then connectSystem else connectSession
r <- call client (methodCall p introspectInterface introspectMethod)
{ methodCallDestination = Just n }
disconnect client
return $ isRight r