480 lines
12 KiB
Haskell
480 lines
12 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- Common internal DBus functions
|
|
|
|
module Data.Internal.DBus
|
|
( SafeClient (..)
|
|
, SysClient (..)
|
|
, SesClient (..)
|
|
, DBusEnv (..)
|
|
, DIO
|
|
, HasClient (..)
|
|
, withDIO
|
|
, addMatchCallback
|
|
, addMatchCallbackSignal
|
|
, matchSignalFull
|
|
, matchProperty
|
|
, matchPropertyFull
|
|
, matchPropertyChanged
|
|
, SignalMatch (..)
|
|
, SignalCallback
|
|
, MethodBody
|
|
, withSignalMatch
|
|
, callPropertyGet
|
|
, callMethod
|
|
, callMethod'
|
|
, methodCallBus
|
|
, callGetManagedObjects
|
|
, ObjectTree
|
|
, getManagedObjects
|
|
, omInterface
|
|
, addInterfaceAddedListener
|
|
, addInterfaceRemovedListener
|
|
, fromSingletonVariant
|
|
, bodyToMaybe
|
|
, exportPair
|
|
, displayBusName
|
|
, displayObjectPath
|
|
, displayMemberName
|
|
, displayInterfaceName
|
|
, displayWrapQuote
|
|
)
|
|
where
|
|
|
|
import DBus
|
|
import DBus.Client
|
|
import qualified Data.ByteString.Char8 as BC
|
|
import RIO
|
|
import RIO.List
|
|
import qualified RIO.Map as M
|
|
import qualified RIO.Text as T
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Type-safe client
|
|
|
|
class SafeClient c where
|
|
toClient :: c -> Client
|
|
|
|
getDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> m (Maybe c)
|
|
|
|
disconnectDBusClient :: MonadUnliftIO m => c -> m ()
|
|
disconnectDBusClient = liftIO . disconnect . toClient
|
|
|
|
withDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (c -> m a)
|
|
-> m (Maybe a)
|
|
withDBusClient f =
|
|
bracket getDBusClient (mapM (liftIO . disconnect . toClient)) $ mapM f
|
|
|
|
withDBusClient_
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (c -> m ())
|
|
-> m ()
|
|
withDBusClient_ = void . withDBusClient
|
|
|
|
fromDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> (c -> a)
|
|
-> m (Maybe a)
|
|
fromDBusClient f = withDBusClient (return . f)
|
|
|
|
newtype SysClient = SysClient Client
|
|
|
|
instance SafeClient SysClient where
|
|
toClient (SysClient cl) = cl
|
|
|
|
getDBusClient = fmap SysClient <$> getDBusClient' True
|
|
|
|
newtype SesClient = SesClient Client
|
|
|
|
instance SafeClient SesClient where
|
|
toClient (SesClient cl) = cl
|
|
|
|
getDBusClient = fmap SesClient <$> getDBusClient' False
|
|
|
|
getDBusClient'
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Bool
|
|
-> m (Maybe Client)
|
|
getDBusClient' sys = do
|
|
res <- try $ liftIO $ if sys then connectSystem else connectSession
|
|
case res of
|
|
Left e -> do
|
|
logInfo $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
|
return Nothing
|
|
Right c -> return $ Just c
|
|
|
|
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 HasLogFunc (DBusEnv SimpleApp c) where
|
|
logFuncL = lens dEnv (\x y -> x {dEnv = y}) . logFuncL
|
|
|
|
withDIO
|
|
:: (MonadUnliftIO m, MonadReader env m)
|
|
=> 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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Methods
|
|
|
|
type MethodBody = Either T.Text [Variant]
|
|
|
|
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
|
|
|
|
callMethod
|
|
:: (SafeClient c, MonadUnliftIO m, MonadReader (env c) m, HasClient env)
|
|
=> BusName
|
|
-> ObjectPath
|
|
-> InterfaceName
|
|
-> MemberName
|
|
-> m MethodBody
|
|
callMethod bus path iface = callMethod' . methodCallBus bus path iface
|
|
|
|
methodCallBus :: BusName -> ObjectPath -> InterfaceName -> MemberName -> MethodCall
|
|
methodCallBus b p i m =
|
|
(methodCall p i m)
|
|
{ methodCallDestination = Just b
|
|
}
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Bus names
|
|
|
|
dbusInterface :: InterfaceName
|
|
dbusInterface = interfaceName_ "org.freedesktop.DBus"
|
|
|
|
callGetNameOwner
|
|
:: ( SafeClient c
|
|
, MonadUnliftIO m
|
|
, MonadReader (env c) m
|
|
, HasClient env
|
|
, HasLogFunc (env c)
|
|
)
|
|
=> BusName
|
|
-> m (Maybe BusName)
|
|
callGetNameOwner name = do
|
|
res <- callMethod' mc
|
|
case res of
|
|
Left err -> do
|
|
logError $ Utf8Builder $ encodeUtf8Builder err
|
|
return Nothing
|
|
Right body -> return $ fromSingletonVariant body
|
|
where
|
|
mc =
|
|
(methodCallBus dbusName dbusPath dbusInterface mem)
|
|
{ methodCallBody = [toVariant name]
|
|
}
|
|
mem = memberName_ "GetNameOwner"
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Variant parsing
|
|
|
|
-- TODO log failures here?
|
|
fromSingletonVariant :: IsVariant a => [Variant] -> Maybe a
|
|
fromSingletonVariant = fromVariant <=< listToMaybe
|
|
|
|
bodyToMaybe :: IsVariant a => MethodBody -> Maybe a
|
|
bodyToMaybe = either (const Nothing) fromSingletonVariant
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Signals
|
|
|
|
type SignalCallback m = [Variant] -> m ()
|
|
|
|
addMatchCallbackSignal
|
|
:: ( MonadReader (env c) m
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> MatchRule
|
|
-> (Signal -> m ())
|
|
-> m SignalHandler
|
|
addMatchCallbackSignal rule cb = do
|
|
cl <- toClient <$> view clientL
|
|
withRunInIO $ \run -> addMatch cl rule $ run . cb
|
|
|
|
addMatchCallback
|
|
:: ( MonadReader (env c) m
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> MatchRule
|
|
-> SignalCallback m
|
|
-> m SignalHandler
|
|
addMatchCallback rule cb = addMatchCallbackSignal rule (cb . signalBody)
|
|
|
|
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
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> Maybe ObjectPath
|
|
-> Maybe InterfaceName
|
|
-> Maybe MemberName
|
|
-> m (Maybe MatchRule)
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Properties
|
|
|
|
propertyInterface :: InterfaceName
|
|
propertyInterface = interfaceName_ "org.freedesktop.DBus.Properties"
|
|
|
|
propertySignal :: MemberName
|
|
propertySignal = memberName_ "PropertiesChanged"
|
|
|
|
callPropertyGet
|
|
:: ( HasClient env
|
|
, MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
)
|
|
=> BusName
|
|
-> ObjectPath
|
|
-> InterfaceName
|
|
-> MemberName
|
|
-> m [Variant]
|
|
callPropertyGet bus path iface property = do
|
|
cl <- toClient <$> view clientL
|
|
res <- liftIO $ getProperty cl $ methodCallBus bus path iface property
|
|
case res of
|
|
Left err -> do
|
|
logError $ displayBytesUtf8 $ BC.pack $ methodErrorMessage err
|
|
return []
|
|
Right v -> return [v]
|
|
|
|
matchProperty :: Maybe BusName -> Maybe ObjectPath -> MatchRule
|
|
matchProperty b p =
|
|
matchSignal b p (Just propertyInterface) (Just propertySignal)
|
|
|
|
matchPropertyFull
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> Maybe ObjectPath
|
|
-> m (Maybe MatchRule)
|
|
matchPropertyFull b p =
|
|
matchSignalFull b p (Just propertyInterface) (Just propertySignal)
|
|
|
|
data SignalMatch a = Match a | NoMatch | Failure deriving (Eq, Show)
|
|
|
|
withSignalMatch :: MonadUnliftIO m => (Maybe a -> m ()) -> SignalMatch a -> m ()
|
|
withSignalMatch f (Match x) = f (Just x)
|
|
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)
|
|
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
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- Object Manager
|
|
|
|
type ObjectTree = M.Map ObjectPath (M.Map InterfaceName (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"
|
|
|
|
callGetManagedObjects
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> ObjectPath
|
|
-> m ObjectTree
|
|
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 $
|
|
fmap (M.mapKeys interfaceName_) $
|
|
fromMaybe M.empty $
|
|
fromSingletonVariant v
|
|
|
|
addInterfaceChangedListener
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> MemberName
|
|
-> ObjectPath
|
|
-> SignalCallback m
|
|
-> m (Maybe SignalHandler)
|
|
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
|
|
Just rule -> Just <$> addMatchCallback rule sc
|
|
where
|
|
bus_ = "'" <> displayBusName bus <> "'"
|
|
path_ = "'" <> displayObjectPath path <> "'"
|
|
prop_ = "'" <> displayMemberName prop <> "'"
|
|
|
|
addInterfaceAddedListener
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> ObjectPath
|
|
-> SignalCallback m
|
|
-> m (Maybe SignalHandler)
|
|
addInterfaceAddedListener bus =
|
|
addInterfaceChangedListener bus omInterfacesAdded
|
|
|
|
addInterfaceRemovedListener
|
|
:: ( MonadReader (env c) m
|
|
, HasLogFunc (env c)
|
|
, MonadUnliftIO m
|
|
, SafeClient c
|
|
, HasClient env
|
|
)
|
|
=> BusName
|
|
-> ObjectPath
|
|
-> SignalCallback m
|
|
-> m (Maybe SignalHandler)
|
|
addInterfaceRemovedListener bus =
|
|
addInterfaceChangedListener bus omInterfacesRemoved
|
|
|
|
--------------------------------------------------------------------------------
|
|
-- 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 <> "'"
|