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

469 lines
12 KiB
Haskell
Raw Normal View History

2023-01-03 22:18:55 -05:00
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
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 (..)
2023-01-03 22:18:55 -05:00
, DBusEnv (..)
, DIO
, HasClient (..)
, withDIO
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
, displayBusName
, displayObjectPath
, displayMemberName
, displayInterfaceName
, displayWrapQuote
2022-12-30 14:58:23 -05:00
)
where
import DBus
import DBus.Client
2023-01-01 19:52:01 -05:00
import qualified Data.ByteString.Char8 as BC
2022-12-30 16:29:50 -05:00
import RIO
import RIO.List
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 $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
return Nothing
2022-07-09 17:44:14 -04:00
Right c -> return $ Just c
2023-01-03 22:18:55 -05:00
data DBusEnv env c = DBusEnv {dClient :: !c, dEnv :: !env}
type DIO env c = RIO (DBusEnv env c)
instance HasClient (DBusEnv SimpleApp) where
clientL = lens dClient (\x y -> x {dClient = y})
instance SafeClient c => HasLogFunc (DBusEnv SimpleApp c) where
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
withDIO
:: (MonadUnliftIO m, MonadReader env m, SafeClient c)
=> c
-> DIO env c a
-> m a
withDIO cl x = do
env <- ask
runRIO (DBusEnv cl env) x
class HasClient env where
clientL :: SafeClient c => Lens' (env c) c
--------------------------------------------------------------------------------
2022-12-30 14:58:23 -05:00
-- Methods
type MethodBody = Either T.Text [Variant]
2023-01-03 22:18:55 -05:00
callMethod'
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> MethodCall
-> m MethodBody
callMethod' mc = do
cl <- toClient <$> view clientL
liftIO $ bimap (T.pack . methodErrorMessage) methodReturnBody <$> call cl mc
2022-12-30 14:58:23 -05:00
callMethod
2023-01-03 22:18:55 -05:00
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
=> BusName
2022-12-30 14:58:23 -05:00
-> ObjectPath
-> InterfaceName
-> MemberName
2022-12-30 16:29:50 -05:00
-> m MethodBody
2023-01-03 22:18:55 -05:00
callMethod bus path iface = callMethod' . methodCallBus bus path iface
2021-11-27 13:24:13 -05:00
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"
2023-01-01 19:41:46 -05:00
callGetNameOwner
2023-01-03 22:18:55 -05:00
:: ( SafeClient c
, MonadUnliftIO m
, MonadReader (env c) m
, HasClient env
, HasLogFunc (env c)
)
=> BusName
2023-01-01 19:41:46 -05:00
-> m (Maybe BusName)
2023-01-03 22:18:55 -05:00
callGetNameOwner name = do
res <- callMethod' mc
2023-01-01 19:41:46 -05:00
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return Nothing
Right body -> return $ fromSingletonVariant body
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
-- TODO log failures here?
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
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
2022-12-30 14:58:23 -05:00
=> MatchRule
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 16:29:50 -05:00
-> m SignalHandler
2023-01-03 22:18:55 -05:00
addMatchCallback rule cb = do
cl <- toClient <$> view clientL
withRunInIO $ \run -> do
addMatch 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
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
2022-12-30 14:58:23 -05:00
-> Maybe ObjectPath
-> Maybe InterfaceName
-> Maybe MemberName
2022-12-30 16:29:50 -05:00
-> m (Maybe MatchRule)
2023-01-03 22:18:55 -05:00
matchSignalFull b p i m = do
res <- callGetNameOwner b
case res of
Just o -> return $ Just $ matchSignal (Just o) p i m
Nothing -> do
logError msg
return Nothing
where
bus_ = displayWrapQuote $ displayBusName b
iface_ = displayWrapQuote . displayInterfaceName <$> i
path_ = displayWrapQuote . displayObjectPath <$> p
mem_ = displayWrapQuote . displayMemberName <$> m
match =
intersperse ", " $
mapMaybe (\(k, v) -> fmap ((k <> "=") <>) v) $
zip ["interface", "path", "member"] [iface_, path_, mem_]
stem = "could not get match rule for bus " <> bus_
msg = if null match then stem else stem <> " where " <> mconcat match
2021-11-27 13:24:13 -05:00
--------------------------------------------------------------------------------
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
2023-01-03 22:18:55 -05:00
:: ( HasClient env
, MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
-> InterfaceName
-> MemberName
2022-12-30 16:29:50 -05:00
-> m [Variant]
2023-01-03 22:18:55 -05:00
callPropertyGet bus path iface property = do
cl <- toClient <$> view clientL
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
2023-01-01 19:52:01 -05:00
case res of
Left err -> do
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
return []
Right v -> return [v]
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
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
2022-12-30 14:58:23 -05:00
-> Maybe ObjectPath
2022-12-30 16:29:50 -05:00
-> m (Maybe MatchRule)
2023-01-03 22:18:55 -05:00
matchPropertyFull b p =
matchSignalFull 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
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
=> BusName
2022-12-30 14:58:23 -05:00
-> ObjectPath
2022-12-30 16:29:50 -05:00
-> m ObjectTree
2023-01-03 22:18:55 -05:00
callGetManagedObjects bus path = do
res <- callMethod bus path omInterface getManagedObjects
case res of
Left err -> do
logError $ Utf8Builder $ encodeUtf8Builder err
return M.empty
Right v -> return $ fromMaybe M.empty $ fromSingletonVariant v
2022-12-30 14:58:23 -05:00
addInterfaceChangedListener
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
2022-12-30 14:58:23 -05:00
=> BusName
-> MemberName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
2022-12-30 16:29:50 -05:00
-> m (Maybe SignalHandler)
2023-01-03 22:18:55 -05:00
addInterfaceChangedListener bus prop path sc = do
res <- matchSignalFull bus (Just path) (Just omInterface) (Just prop)
case res of
Nothing -> do
logError $
"could not add listener for property"
<> prop_
<> " at path "
<> path_
<> " on bus "
<> bus_
return Nothing
2023-01-03 22:18:55 -05:00
Just rule -> Just <$> addMatchCallback rule sc
where
bus_ = "'" <> displayBusName bus <> "'"
path_ = "'" <> displayObjectPath path <> "'"
prop_ = "'" <> displayMemberName prop <> "'"
2021-11-27 13:24:13 -05:00
2022-12-30 14:58:23 -05:00
addInterfaceAddedListener
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
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
2023-01-03 22:18:55 -05:00
:: ( MonadReader (env c) m
, HasLogFunc (env c)
, MonadUnliftIO m
, SafeClient c
, HasClient env
)
2022-12-30 14:58:23 -05:00
=> BusName
-> ObjectPath
2022-12-30 16:37:52 -05:00
-> SignalCallback m
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_ = displayObjectPath path
--------------------------------------------------------------------------------
-- logging helpers
displayBusName :: BusName -> Utf8Builder
displayBusName = displayBytesUtf8 . BC.pack . formatBusName
displayObjectPath :: ObjectPath -> Utf8Builder
displayObjectPath = displayBytesUtf8 . BC.pack . formatObjectPath
displayMemberName :: MemberName -> Utf8Builder
displayMemberName = displayBytesUtf8 . BC.pack . formatMemberName
displayInterfaceName :: InterfaceName -> Utf8Builder
displayInterfaceName = displayBytesUtf8 . BC.pack . formatInterfaceName
displayWrapQuote :: Utf8Builder -> Utf8Builder
displayWrapQuote x = "'" <> x <> "'"