590 lines
16 KiB
Haskell
590 lines
16 KiB
Haskell
--------------------------------------------------------------------------------
|
|
-- Common internal DBus functions
|
|
|
|
module Data.Internal.DBus
|
|
( SafeClient (..)
|
|
, SysClient (..)
|
|
, SesClient (..)
|
|
, NamedConnection (..)
|
|
, NamedSesConnection
|
|
, NamedSysConnection
|
|
, DBusEnv (..)
|
|
, DIO
|
|
, HasClient (..)
|
|
, releaseBusName
|
|
, 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
|
|
, busNameT
|
|
, interfaceNameT
|
|
, memberNameT
|
|
, objectPathT
|
|
)
|
|
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
|
|
|
|
data NamedConnection c = NamedConnection
|
|
{ ncClient :: !Client
|
|
, ncHumanName :: !(Maybe BusName)
|
|
--, ncUniqueName :: !BusName
|
|
, ncType :: !c
|
|
}
|
|
|
|
type NamedSesConnection = NamedConnection SesClient
|
|
|
|
type NamedSysConnection = NamedConnection SysClient
|
|
|
|
class SafeClient c where
|
|
getDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Maybe BusName
|
|
-> m (Maybe (NamedConnection c))
|
|
|
|
disconnectDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> NamedConnection c
|
|
-> m ()
|
|
disconnectDBusClient c = do
|
|
releaseBusName c
|
|
liftIO $ disconnect $ ncClient c
|
|
|
|
withDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Maybe BusName
|
|
-> (NamedConnection c -> m a)
|
|
-> m (Maybe a)
|
|
withDBusClient n f =
|
|
bracket (getDBusClient n) (mapM (liftIO . disconnect . ncClient)) $ mapM f
|
|
|
|
withDBusClient_
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Maybe BusName
|
|
-> (NamedConnection c -> m ())
|
|
-> m ()
|
|
withDBusClient_ n = void . withDBusClient n
|
|
|
|
fromDBusClient
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Maybe BusName
|
|
-> (NamedConnection c -> a)
|
|
-> m (Maybe a)
|
|
fromDBusClient n f = withDBusClient n (return . f)
|
|
|
|
data SysClient = SysClient
|
|
|
|
instance SafeClient SysClient where
|
|
getDBusClient = connectToDBusWithName True SysClient
|
|
|
|
data SesClient = SesClient
|
|
|
|
instance SafeClient SesClient where
|
|
-- TODO wet
|
|
getDBusClient = connectToDBusWithName False SesClient
|
|
|
|
connectToDBusWithName
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> Bool
|
|
-> c
|
|
-> Maybe BusName
|
|
-> m (Maybe (NamedConnection c))
|
|
connectToDBusWithName sys t n = do
|
|
clRes <- getDBusClient' sys
|
|
case clRes of
|
|
Nothing -> do
|
|
logError "could not get client"
|
|
return Nothing
|
|
Just cl -> do
|
|
--helloRes <- liftIO $ callHello cl
|
|
--case helloRes of
|
|
-- Nothing -> do
|
|
-- logError "count not get unique name"
|
|
-- return Nothing
|
|
-- Just unique -> do
|
|
n' <- maybe (return Nothing) (`requestBusName` cl) n
|
|
return $
|
|
Just $
|
|
NamedConnection
|
|
{ ncClient = cl
|
|
, ncHumanName = n'
|
|
-- , ncUniqueName = unique
|
|
, ncType = t
|
|
}
|
|
|
|
releaseBusName
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> NamedConnection c
|
|
-> m ()
|
|
releaseBusName NamedConnection {ncClient, ncHumanName} = do
|
|
-- TODO this might error?
|
|
case ncHumanName of
|
|
Just n -> do
|
|
liftIO $ void $ releaseName ncClient n
|
|
logInfo $ "released bus name: " <> displayBusName n
|
|
Nothing -> return ()
|
|
|
|
requestBusName
|
|
:: (MonadReader env m, HasLogFunc env, MonadUnliftIO m)
|
|
=> BusName
|
|
-> Client
|
|
-> m (Maybe BusName)
|
|
requestBusName n cl = do
|
|
res <- try $ liftIO $ requestName cl n []
|
|
case res of
|
|
Left e -> do
|
|
logError $ displayBytesUtf8 $ BC.pack $ clientErrorMessage e
|
|
return Nothing
|
|
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
|
|
case r of
|
|
NamePrimaryOwner -> return $ Just n
|
|
_ -> return Nothing
|
|
|
|
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
|
|
|
|
--callHello :: Client -> IO (Maybe BusName)
|
|
--callHello cl = do
|
|
-- reply <- call_ cl $ methodCallBus dbusName dbusPath dbusInterface "Hello"
|
|
-- case methodReturnBody reply of
|
|
-- [name] | Just nameStr <- fromVariant name -> do
|
|
-- busName <- parseBusName nameStr
|
|
-- return $ Just busName
|
|
-- _ -> return Nothing
|
|
--
|
|
data DBusEnv env c = DBusEnv {dClient :: !(NamedConnection 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)
|
|
=> NamedConnection 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) (NamedConnection 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 <- ncClient <$> 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 <- ncClient <$> 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 <- ncClient <$> 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
|
|
-> MemberName
|
|
-> [Variant]
|
|
-> SignalMatch a
|
|
matchPropertyChanged iface property [sigIface, sigValues, _] =
|
|
let i = fromVariant sigIface :: Maybe T.Text
|
|
v = fromVariant sigValues :: Maybe (M.Map T.Text Variant)
|
|
in case (i, v) of
|
|
(Just i', Just v') ->
|
|
if i' == interfaceNameT iface
|
|
then
|
|
maybe NoMatch Match $
|
|
fromVariant =<< M.lookup (memberNameT property) v'
|
|
else NoMatch
|
|
_ -> Failure
|
|
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)
|
|
=> ObjectPath
|
|
-> (Client -> m Interface)
|
|
-> NamedConnection c
|
|
-> (m (), m ())
|
|
exportPair path toIface cl = (up, down)
|
|
where
|
|
cl_ = ncClient 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
|
|
|
|
busNameT :: BusName -> T.Text
|
|
busNameT = T.pack . formatBusName
|
|
|
|
objectPathT :: ObjectPath -> T.Text
|
|
objectPathT = T.pack . formatObjectPath
|
|
|
|
interfaceNameT :: InterfaceName -> T.Text
|
|
interfaceNameT = T.pack . formatInterfaceName
|
|
|
|
memberNameT :: MemberName -> T.Text
|
|
memberNameT = T.pack . formatMemberName
|
|
|
|
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 <> "'"
|