module DBus.Client
(
Client
, clientName
, mkClient
, call
, callBlocking
, callBlocking_
, emitSignal
, requestName
, releaseName
, onSignal
, RemoteObject (..)
, Proxy (..)
, callProxy
, callProxyBlocking
, callProxyBlocking_
, onSignalFrom
, LocalObject (..)
, Interface (..)
, Member (..)
, export
, MethodCall (..)
, replyReturn
, replyError
) where
import qualified Control.Concurrent.MVar as MV
import qualified Data.Map as Map
import qualified DBus.Connection as C
import qualified DBus.Message as M
import qualified DBus.Types as T
import Control.Concurrent (forkIO)
import Control.Monad (forever)
import qualified Data.Set as Set
import qualified DBus.Constants as Const
import Data.Maybe (isJust)
import qualified DBus.NameReservation as NR
import qualified DBus.MatchRule as MR
import Data.Maybe (fromJust)
import qualified DBus.Introspection as I
import qualified Data.Text.Lazy as TL
type Callback = (M.ReceivedMessage -> IO ())
data Client = Client C.Connection T.BusName
(MV.MVar (Map.Map M.Serial Callback))
(MV.MVar (Map.Map T.ObjectPath Callback))
(MV.MVar [Callback])
clientConnection :: Client -> C.Connection
clientConnection (Client x _ _ _ _) = x
clientName :: Client -> T.BusName
clientName (Client _ x _ _ _) = x
mkClient :: (C.Connection, T.BusName) -> IO Client
mkClient (c, name) = do
replies <- MV.newMVar Map.empty
exports <- MV.newMVar Map.empty
signals <- MV.newMVar []
let client = Client c name replies exports signals
forkIO $ forever (receiveMessages client)
export client ("/") rootObject
return client
send_ :: M.Message a => Client -> (M.Serial -> IO b) -> a -> IO b
send_ c f msg = do
result <- C.send (clientConnection c) f msg
case result of
Left x -> error $ show x
Right x -> return x
sendOnly_ :: M.Message a => Client -> a -> IO ()
sendOnly_ c = send_ c (const $ return ())
call :: Client -> M.MethodCall
-> (M.Error -> IO ())
-> (M.MethodReturn -> IO ())
-> IO ()
call client msg onError onReturn = send_ client addCallback msg where
Client _ _ mvar _ _ = client
addCallback s = MV.modifyMVar_ mvar $ return . Map.insert s callback
callback (M.ReceivedError _ _ msg') = onError msg'
callback (M.ReceivedMethodReturn _ _ msg') = onReturn msg'
callback _ = return ()
callBlocking :: Client -> M.MethodCall -> IO (Either M.Error M.MethodReturn)
callBlocking client msg = do
mvar <- MV.newEmptyMVar
call client msg
(MV.putMVar mvar . Left)
(MV.putMVar mvar . Right)
MV.takeMVar mvar
callBlocking_ :: Client -> M.MethodCall -> IO M.MethodReturn
callBlocking_ client msg = do
reply <- callBlocking client msg
case reply of
Left x -> error . TL.unpack . M.errorMessage $ x
Right x -> return x
emitSignal :: Client -> M.Signal -> IO ()
emitSignal = sendOnly_
receiveMessages :: Client -> IO ()
receiveMessages client = do
received <- C.receive $ clientConnection client
case received of
Left x -> error $ show x
Right x -> handleMessage client x
handleMessage :: Client -> M.ReceivedMessage -> IO ()
handleMessage client msg@(M.ReceivedMethodCall _ _ call') = do
let Client _ _ _ mvar _ = client
objects <- MV.readMVar mvar
case Map.lookup (M.methodCallPath call') objects of
Just x -> x msg
Nothing -> unknownMethod client msg
handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') =
gotReply c (M.methodReturnSerial msg') msg
handleMessage c msg@(M.ReceivedError _ _ msg') =
gotReply c (M.errorSerial msg') msg
handleMessage c msg@(M.ReceivedSignal _ _ _) = let
Client _ _ _ _ mvar = c
in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg))
handleMessage _ _ = return ()
unknownMethod :: Client -> M.ReceivedMessage -> IO ()
unknownMethod client msg = sendOnly_ client errorMsg where
M.ReceivedMethodCall serial sender _ = msg
errorMsg = M.Error
Const.errorUnknownMethod
serial sender
[]
gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO ()
gotReply (Client _ _ mvar _ _) serial msg = do
callback <- MV.modifyMVar mvar $ \callbacks -> let
x = Map.lookup serial callbacks
callbacks' = if isJust x
then Map.delete serial callbacks
else callbacks
in return (callbacks', x)
case callback of
Just x -> forkIO (x msg) >> return ()
Nothing -> return ()
requestName :: Client -> T.BusName -> [NR.RequestNameFlag]
-> IO NR.RequestNameReply
requestName client name flags = do
reply <- callBlocking_ client $ NR.requestName name flags
case NR.mkRequestNameReply reply of
Nothing -> error $ "Invalid reply to RequestName"
Just x -> return x
releaseName :: Client -> T.BusName -> IO NR.ReleaseNameReply
releaseName client name = do
reply <- callBlocking_ client $ NR.releaseName name
case NR.mkReleaseNameReply reply of
Nothing -> error $ "Invalid reply to ReleaseName"
Just x -> return x
onSignal :: Client -> MR.MatchRule
-> (T.BusName -> M.Signal -> IO ())
-> IO ()
onSignal client rule callback = let
(Client _ _ _ _ mvar) = client
rule' = rule { MR.matchType = Just MR.Signal }
callback' msg@(M.ReceivedSignal _ sender signal)
| MR.matches rule' msg = callback (fromJust sender) signal
callback' _ = return ()
in do
callBlocking_ client $ MR.addMatch rule'
MV.modifyMVar_ mvar $ return . (callback' :)
data RemoteObject = RemoteObject T.BusName T.ObjectPath
data Proxy = Proxy RemoteObject T.InterfaceName
buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> M.MethodCall
buildMethodCall proxy name flags body = msg where
Proxy (RemoteObject dest path) iface = proxy
msg = M.MethodCall path name (Just iface) (Just dest)
(Set.fromList flags) body
callProxy :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> (M.Error -> IO ())
-> (M.MethodReturn -> IO ())
-> IO ()
callProxy client proxy name flags body onError onReturn = let
msg = buildMethodCall proxy name flags body
in call client msg onError onReturn
callProxyBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag]
-> [T.Variant]
-> IO (Either M.Error M.MethodReturn)
callProxyBlocking client proxy name flags body =
callBlocking client $ buildMethodCall proxy name flags body
callProxyBlocking_ :: Client -> Proxy -> T.MemberName -> [M.Flag]
-> [T.Variant]
-> IO M.MethodReturn
callProxyBlocking_ client proxy name flags body =
callBlocking_ client $ buildMethodCall proxy name flags body
onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ())
-> IO ()
onSignalFrom client proxy member io = onSignal client rule io' where
Proxy (RemoteObject dest path) iface = proxy
rule = MR.MatchRule
{ MR.matchType = Nothing
, MR.matchSender = Just dest
, MR.matchInterface = Just iface
, MR.matchMember = Just member
, MR.matchPath = Just path
, MR.matchDestination = Nothing
, MR.matchParameters = []
}
io' _ msg = io msg
rootObject :: LocalObject
rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where
ifaceName = "org.freedesktop.DBus.Introspectable"
memberName = "Introspect"
interface = Interface $ Map.fromList [(memberName, impl)]
method = I.Method memberName [] [I.Parameter "xml" "s"]
iface = I.Interface ifaceName [method] [] []
impl = Method "" "s" $ \call' -> do
let Client _ _ _ mvar _ = methodCallClient call'
paths <- fmap Map.keys $ MV.readMVar mvar
let paths' = filter (/= "/") paths
let Just xml = I.toXML $ I.Object "/" [iface]
[I.Object p [] [] | p <- paths']
replyReturn call' [T.toVariant xml]
newtype LocalObject = LocalObject (Map.Map T.InterfaceName Interface)
newtype Interface = Interface (Map.Map T.MemberName Member)
data Member
= Method T.Signature T.Signature (MethodCall -> IO ())
| Signal T.Signature
export :: Client -> T.ObjectPath -> LocalObject -> IO ()
export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $
return . Map.insert path (onMethodCall client (addIntrospectable path obj))
addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject
addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where
ifaces' = Map.insertWith (\_ x -> x) name iface ifaces
name = "org.freedesktop.DBus.Introspectable"
iface = Interface $ Map.fromList [("Introspect", impl)]
impl = Method "" "s" $ \call' -> do
let Just xml = I.toXML . introspect path . methodCallObject $ call'
replyReturn call' [T.toVariant xml]
introspect :: T.ObjectPath -> LocalObject -> I.Object
introspect path obj = I.Object path interfaces [] where
LocalObject ifaceMap = obj
interfaces = map introspectIface (Map.toList ifaceMap)
introspectIface :: (T.InterfaceName, Interface) -> I.Interface
introspectIface (name, iface) = I.Interface name methods signals [] where
Interface memberMap = iface
members = Map.toList memberMap
methods = concatMap introspectMethod members
signals = concatMap introspectSignal members
introspectMethod :: (T.MemberName, Member) -> [I.Method]
introspectMethod (name, (Method inSig outSig _)) = [I.Method name
(map introspectParam (T.signatureTypes inSig))
(map introspectParam (T.signatureTypes outSig))]
introspectMethod _ = []
introspectSignal :: (T.MemberName, Member) -> [I.Signal]
introspectSignal (name, (Signal sig)) = [I.Signal name
(map introspectParam (T.signatureTypes sig))]
introspectSignal _ = []
introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode
data MethodCall = MethodCall
{ methodCallObject :: LocalObject
, methodCallClient :: Client
, methodCallMethod :: Member
, methodCallSerial :: M.Serial
, methodCallSender :: Maybe T.BusName
, methodCallFlags :: Set.Set M.Flag
, methodCallBody :: [T.Variant]
}
findMember :: M.MethodCall -> LocalObject -> Maybe Member
findMember call' (LocalObject ifaces) = do
iface <- M.methodCallInterface call'
Interface members <- Map.lookup iface ifaces
Map.lookup (M.methodCallMember call') members
onMethodCall :: Client -> LocalObject -> M.ReceivedMessage -> IO ()
onMethodCall client obj msg = do
let M.ReceivedMethodCall serial sender call' = msg
sigStr = TL.concat . map (T.typeCode . T.variantType)
. M.methodCallBody $ call'
sig = T.mkSignature_ sigStr
case findMember call' obj of
Just method@(Method inSig _ x) -> let
call'' = MethodCall obj client method
serial sender
(M.methodCallFlags call')
(M.methodCallBody call')
invalidArgs = replyError call'' Const.errorInvalidArgs []
in if inSig == sig
then x call''
else invalidArgs
_ -> unknownMethod client msg
replyReturn :: MethodCall -> [T.Variant] -> IO ()
replyReturn call' body = reply where
replyInvalid = M.Error
Const.errorFailed
(methodCallSerial call')
(methodCallSender call')
[T.toVariant $ TL.pack "Method return didn't match signature."]
replyValid = M.MethodReturn
(methodCallSerial call')
(methodCallSender call')
body
sendReply :: M.Message a => a -> IO ()
sendReply = sendOnly_ (methodCallClient call')
sigStr = TL.concat . map (T.typeCode . T.variantType) $ body
(Method _ outSig _) = methodCallMethod call'
reply = if T.mkSignature sigStr == Just outSig
then sendReply replyValid
else sendReply replyInvalid
replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO ()
replyError call' name body = sendOnly_ c reply where
c = methodCallClient call'
reply = M.Error
name
(methodCallSerial call')
(methodCallSender call')
body