xmonad-config/lib/Data/Internal/DBus.hs

329 lines
8.6 KiB
Haskell
Raw Normal View History

2023-01-01 13:26:09 -05:00
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Common internal DBus functions
2022-07-09 17:44:14 -04:00
module Data.Internal.DBus
2022-12-30 14:58:23 -05:00
( SafeClient (..)
, SysClient (..)
, SesClient (..)
2022-07-09 17:44:14 -04:00
, addMatchCallback
, matchProperty
2021-11-27 13:24:13 -05:00
, matchPropertyFull
, matchPropertyChanged
2022-12-30 14:58:23 -05:00
, SignalMatch (..)
, SignalCallback
, MethodBody
, withSignalMatch
, callPropertyGet
, callMethod
, callMethod'
2021-11-27 13:24:13 -05:00
, methodCallBus
, callGetManagedObjects
, ObjectTree
, getManagedObjects
, omInterface
, addInterfaceAddedListener
, addInterfaceRemovedListener
2021-11-27 13:24:13 -05:00
, fromSingletonVariant
, bodyToMaybe
2023-01-01 13:26:09 -05:00
, exportPair
2022-12-30 14:58:23 -05:00
)
where
import DBus
import DBus.Client
2022-12-30 16:29:50 -05:00
import RIO
2022-12-31 19:47:02 -05:00
import qualified RIO.Map as M
2022-12-30 14:58:23 -05:00
import qualified RIO.Text as T
2022-07-09 17:44:14 -04:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Type-safe client
2022-07-09 17:44:14 -04:00
class SafeClient c where
toClient :: c -> Client
getDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> m (Maybe c)
2022-12-30 16:29:50 -05:00
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
disconnectDBusClient = liftIO . disconnect . toClient
withDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m a)
-> m (Maybe a)
2022-12-31 19:50:32 -05:00
withDBusClient f =
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
2022-07-09 17:44:14 -04:00
withDBusClient_
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> m ())
-> m ()
2022-07-09 17:44:14 -04:00
withDBusClient_ = void . withDBusClient
fromDBusClient
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> (c -> a)
-> m (Maybe a)
2022-07-09 17:44:14 -04:00
fromDBusClient f = withDBusClient (return . f)
newtype SysClient = SysClient Client
instance SafeClient SysClient where
toClient (SysClient cl) = cl
getDBusClient = fmap SysClient <$> getDBusClient' True
2022-07-09 17:44:14 -04:00
newtype SesClient = SesClient Client
instance SafeClient SesClient where
toClient (SesClient cl) = cl
getDBusClient = fmap SesClient <$> getDBusClient' False
2022-07-09 17:44:14 -04:00
getDBusClient'
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
=> Bool
-> m (Maybe Client)
getDBusClient' sys = do
2022-12-30 16:29:50 -05:00
res <- try $ liftIO $ if sys then connectSystem else connectSession
2022-07-09 17:44:14 -04:00
case res of
Left e -> do
logInfo $ Utf8Builder $ encodeUtf8Builder $ T.pack $ clientErrorMessage e
return Nothing
2022-07-09 17:44:14 -04:00
Right c -> return $ Just c
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Methods
type MethodBody = Either T.Text [Variant]
2022-12-30 16:29:50 -05:00
callMethod' :: (MonadUnliftIO m, SafeClient c) => c -> MethodCall -> m MethodBody
2022-12-30 14:58:23 -05:00
callMethod' cl =
2022-12-30 16:29:50 -05:00
liftIO
. fmap (bimap (T.pack . methodErrorMessage) methodReturnBody)
2022-12-30 14:58:23 -05:00
. call (toClient cl)
callMethod
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> c
-> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
2022-12-30 16:29:50 -05:00
-> m MethodBody
2021-11-27 13:24:13 -05:00
callMethod client bus path iface = callMethod' client . methodCallBus bus path iface
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
2022-12-30 14:58:23 -05:00
methodCallBus b p i m =
(methodCall p i m)
{ methodCallDestination = Just b
}
2021-11-27 13:24:13 -05:00
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Bus names
2021-11-27 13:24:13 -05:00
dbusInterface :: InterfaceName
dbusInterface = interfaceName_ "org.freedesktop.DBus"
2022-12-30 16:29:50 -05:00
callGetNameOwner :: (MonadUnliftIO m, SafeClient c) => c -> BusName -> m (Maybe BusName)
2022-07-09 17:44:14 -04:00
callGetNameOwner cl name = bodyToMaybe <$> callMethod' cl mc
2021-11-27 13:24:13 -05:00
where
2022-12-30 14:58:23 -05:00
mc =
(methodCallBus dbusName dbusPath dbusInterface mem)
{ methodCallBody = [toVariant name]
}
2021-11-27 13:24:13 -05:00
mem = memberName_ "GetNameOwner"
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Variant parsing
2021-11-27 13:24:13 -05:00
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
fromSingletonVariant = fromVariant <=< listToMaybe
bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
bodyToMaybe = either (const Nothing) fromSingletonVariant
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Signals
2022-12-30 16:37:52 -05:00
type SignalCallback m = [Variant] -> m ()
2022-12-30 14:58:23 -05:00
addMatchCallback
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> MatchRule
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 14:58:23 -05:00
-> c
2022-12-30 16:29:50 -05:00
-> m SignalHandler
2022-12-30 16:37:52 -05:00
addMatchCallback rule cb cl = withRunInIO $ \run -> do
addMatch (toClient cl) rule $ run . cb . signalBody
2022-12-30 14:58:23 -05:00
matchSignal
:: Maybe BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
-> MatchRule
matchSignal b p i m =
matchAny
{ matchPath = p
, matchSender = b
, matchInterface = i
, matchMember = m
}
matchSignalFull
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> c
-> BusName
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
2022-12-30 16:29:50 -05:00
-> m (Maybe MatchRule)
2021-11-27 13:24:13 -05:00
matchSignalFull client b p i m =
fmap (\o -> matchSignal (Just o) p i m) <$> callGetNameOwner client b
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Properties
propertyInterface :: InterfaceName
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
propertySignal :: MemberName
propertySignal = memberName_ "PropertiesChanged"
2022-12-30 14:58:23 -05:00
callPropertyGet
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
-> c
2022-12-30 16:29:50 -05:00
-> m [Variant]
2022-12-30 14:58:23 -05:00
callPropertyGet bus path iface property cl =
2022-12-30 16:29:50 -05:00
liftIO $
fmap (either (const []) (: [])) $
getProperty (toClient cl) $
methodCallBus bus path iface property
2021-11-27 13:24:13 -05:00
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
matchProperty b p =
matchSignal b p (Just propertyInterface) (Just propertySignal)
2022-12-30 14:58:23 -05:00
matchPropertyFull
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> c
-> BusName
-> Maybe ObjectPath
2022-12-30 16:29:50 -05:00
-> m (Maybe MatchRule)
2022-07-09 17:44:14 -04:00
matchPropertyFull cl b p =
matchSignalFull cl b p (Just propertyInterface) (Just propertySignal)
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
2022-12-30 16:29:50 -05:00
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
withSignalMatch f (Match x) = f (Just x)
2022-12-30 14:58:23 -05:00
withSignalMatch f Failure = f Nothing
withSignalMatch _ NoMatch = return ()
matchPropertyChanged
:: IsVariant a
=> InterfaceName
-> T.Text
-> [Variant]
-> SignalMatch a
matchPropertyChanged iface property [i, body, _] =
let i' = (fromVariant i :: Maybe T.Text)
2022-12-30 14:58:23 -05:00
b = toMap body
in case (i', b) of
(Just i'', Just b') ->
if i'' == T.pack (formatInterfaceName iface)
then maybe NoMatch Match $ fromVariant =<< M.lookup property b'
else NoMatch
_ -> Failure
where
toMap v = fromVariant v :: Maybe (M.Map T.Text Variant)
matchPropertyChanged _ _ _ = Failure
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Object Manager
type ObjectTree = M.Map ObjectPath (M.Map T.Text (M.Map T.Text Variant))
omInterface :: InterfaceName
omInterface = interfaceName_ "org.freedesktop.DBus.ObjectManager"
getManagedObjects :: MemberName
getManagedObjects = memberName_ "GetManagedObjects"
omInterfacesAdded :: MemberName
omInterfacesAdded = memberName_ "InterfacesAdded"
omInterfacesRemoved :: MemberName
omInterfacesRemoved = memberName_ "InterfacesRemoved"
2022-12-30 14:58:23 -05:00
callGetManagedObjects
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> c
-> BusName
-> ObjectPath
2022-12-30 16:29:50 -05:00
-> m ObjectTree
2022-07-09 17:44:14 -04:00
callGetManagedObjects cl bus path =
2021-11-27 13:24:13 -05:00
either (const M.empty) (fromMaybe M.empty . fromSingletonVariant)
2022-12-30 14:58:23 -05:00
<$> callMethod cl bus path omInterface getManagedObjects
addInterfaceChangedListener
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> BusName
-> MemberName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 14:58:23 -05:00
-> c
2022-12-30 16:29:50 -05:00
-> m (Maybe SignalHandler)
2022-07-09 17:44:14 -04:00
addInterfaceChangedListener bus prop path sc cl = do
rule <- matchSignalFull cl bus (Just path) (Just omInterface) (Just prop)
forM rule $ \r -> addMatchCallback r sc cl
2021-11-27 13:24:13 -05:00
2022-12-30 14:58:23 -05:00
addInterfaceAddedListener
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 14:58:23 -05:00
-> c
2022-12-30 16:29:50 -05:00
-> m (Maybe SignalHandler)
2021-11-27 13:24:13 -05:00
addInterfaceAddedListener bus =
addInterfaceChangedListener bus omInterfacesAdded
2022-12-30 14:58:23 -05:00
addInterfaceRemovedListener
2022-12-30 16:29:50 -05:00
:: (MonadUnliftIO m, SafeClient c)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 14:58:23 -05:00
-> c
2022-12-30 16:29:50 -05:00
-> m (Maybe SignalHandler)
2021-11-27 13:24:13 -05:00
addInterfaceRemovedListener bus =
addInterfaceChangedListener bus omInterfacesRemoved
2023-01-01 13:26:09 -05:00
--------------------------------------------------------------------------------
-- Interface export/unexport
exportPair
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m, SafeClient c)
=> ObjectPath
-> (Client -> m Interface)
-> c
-> (m (), m ())
exportPair path toIface cl = (up, down)
where
cl_ = toClient cl
up = do
logInfo $ "adding interface: " <> path_
i <- toIface cl_
liftIO $ export cl_ path i
down = do
logInfo $ "removing interface: " <> path_
liftIO $ unexport cl_ path
path_ = Utf8Builder $ encodeUtf8Builder $ T.pack $ formatObjectPath path