module DBus.Client (
module DBus.Bus
, module DBus.Types
, module DBus.Message
, Client
, C.Connection
, clientName
, newClient
, DBus
, DBusException
, runDBus
, getClient
, processMessage
, send
, send_
, receive
, mainLoop
, call
, callBlocking
, callBlocking_
, onSignal
, NR.RequestNameFlag (..)
, NR.RequestNameReply (..)
, NR.ReleaseNameReply (..)
, requestName
, releaseName
, requestName_
, releaseName_
, Object (..)
, Interface (..)
, Member (..)
, Method (..)
, export
, object
, interface
, method
, MethodCtx (..)
, replyReturn
, replyError
, Proxy (..)
, callProxy
, callProxyBlocking
, callProxyBlocking_
, onProxySignal
) where
import DBus.Bus
import DBus.Types
import DBus.Message
import qualified DBus.Connection as C
import qualified DBus.Constants as Const
import qualified DBus.Introspection as I
import qualified DBus.MatchRule as MR
import qualified DBus.Message as M
import qualified DBus.NameReservation as NR
import qualified DBus.Types as T
import qualified DBus.Wire as W
import qualified Control.Concurrent.MVar as MV
import qualified Data.Map as Map
import Control.Monad (liftM, ap, forever)
import Control.Monad.IO.Class (liftIO)
import qualified Control.Monad.IO.Class as MIO
import qualified Control.Monad.Reader as R
import qualified Control.Applicative as A
import Data.Typeable (Typeable)
import qualified Control.Exception as Exc
import qualified Control.Monad.Error as E
import Data.Maybe (isJust)
import qualified Data.Set as Set
import Data.Monoid (mconcat)
data Client = Client
{ clientConnection :: C.Connection
, clientName :: T.BusName
, clientCallbacks :: MV.MVar (Map.Map M.Serial MessageHandler)
, clientObjects :: MV.MVar (Map.Map T.ObjectPath Object)
, clientSignalHandlers :: MV.MVar [MessageHandler]
}
type MessageHandler = (M.ReceivedMessage -> DBus ())
newClient :: (C.Connection, T.BusName) -> IO Client
newClient (c, name) = do
callbacks <- MV.newMVar Map.empty
objects <- MV.newMVar Map.empty
signals <- MV.newMVar []
let client = Client c name callbacks objects signals
liftIO $ MV.modifyMVar_ objects $ return . Map.insert "/" rootObject
return client
newtype DBus a = DBus { unDBus :: R.ReaderT Client IO a }
instance Monad DBus where
return = DBus . return
(>>=) (DBus m) f = DBus $ m >>= unDBus . f
instance MIO.MonadIO DBus where
liftIO = DBus . MIO.liftIO
instance Functor DBus where
fmap = liftM
instance A.Applicative DBus where
pure = return
(<*>) = ap
data DBusException
= MarshalFailed W.MarshalError
| UnmarshalFailed W.UnmarshalError
| MethodCallFailed M.Error
| InvalidRequestNameReply M.MethodReturn
| InvalidReleaseNameReply M.MethodReturn
deriving (Show, Eq, Typeable)
instance Exc.Exception DBusException
instance E.MonadError DBus where
type E.ErrorType DBus = DBusException
throwError = MIO.liftIO . Exc.throwIO
catchError dbus h = do
c <- getClient
liftIO $ Exc.catch
(runDBus c dbus)
(runDBus c . h)
runDBus :: Client -> DBus a -> IO a
runDBus c (DBus m) = R.runReaderT m c
getClient :: DBus Client
getClient = DBus R.ask
getConnection :: DBus C.Connection
getConnection = fmap clientConnection getClient
processMessage :: M.ReceivedMessage -> DBus ()
processMessage received = p received where
p (M.ReceivedUnknown _ _ _) = return ()
p (M.ReceivedMethodReturn _ _ msg) = reply $ M.methodReturnSerial msg
p (M.ReceivedError _ _ msg) = reply $ M.errorSerial msg
p (M.ReceivedSignal _ _ _) = do
mvar <- fmap clientSignalHandlers getClient
handlers <- liftIO $ MV.readMVar mvar
mapM_ ($ received) handlers
p (M.ReceivedMethodCall _ _ msg) = do
mvar <- fmap clientObjects getClient
objects <- liftIO $ MV.readMVar mvar
case findMethod objects msg of
Just (obj, m) -> onMethodCall obj m received
Nothing -> unknownMethod received
reply s = onReply s received
send :: M.Message msg => (M.Serial -> DBus a) -> msg -> DBus a
send onSerial msg = do
c <- getConnection
client <- getClient
sent <- liftIO $ C.send c (runDBus client . onSerial) msg
case sent of
Left err -> E.throwError $ MarshalFailed err
Right a -> return a
send_ :: M.Message msg => msg -> DBus ()
send_ = send (const $ return ())
receive :: DBus M.ReceivedMessage
receive = do
c <- getConnection
parsed <- liftIO $ C.receive c
case parsed of
Left err -> E.throwError $ UnmarshalFailed err
Right msg -> return msg
mainLoop :: DBus ()
mainLoop = forever $ receive >>= processMessage
call :: M.MethodCall
-> (M.Error -> DBus ())
-> (M.MethodReturn -> DBus ())
-> DBus ()
call msg onError onReturn = send addCallback msg where
cb (M.ReceivedError _ _ msg') = onError msg'
cb (M.ReceivedMethodReturn _ _ msg') = onReturn msg'
cb _ = return ()
addCallback s = do
mvar <- fmap clientCallbacks getClient
liftIO $ MV.modifyMVar_ mvar $ return . Map.insert s cb
onReply :: M.Serial -> M.ReceivedMessage -> DBus ()
onReply serial msg = do
mvar <- fmap clientCallbacks getClient
maybeCB <- liftIO $ 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 maybeCB of
Just cb -> cb msg
Nothing -> return ()
callBlocking :: M.MethodCall -> DBus (Either M.Error M.MethodReturn)
callBlocking msg = do
mvar <- liftIO $ MV.newEmptyMVar
call msg
(liftIO . MV.putMVar mvar . Left)
(liftIO . MV.putMVar mvar . Right)
liftIO $ MV.takeMVar mvar
callBlocking_ :: M.MethodCall -> DBus M.MethodReturn
callBlocking_ msg = do
reply <- callBlocking msg
case reply of
Left err -> E.throwError $ MethodCallFailed err
Right x -> return x
onSignal :: MR.MatchRule
-> (T.BusName -> M.Signal -> DBus ())
-> DBus ()
onSignal rule h = addHandler where
rule' = rule { MR.matchType = Just MR.Signal }
handler msg@(M.ReceivedSignal _ (Just sender) signal)
| MR.matches rule' msg = h sender signal
handler _ = return ()
addHandler = do
callBlocking_ $ MR.addMatch rule'
mvar <- fmap clientSignalHandlers getClient
liftIO $ MV.modifyMVar_ mvar $ return . (handler :)
requestName :: T.BusName
-> [NR.RequestNameFlag]
-> (M.Error -> DBus ())
-> (NR.RequestNameReply -> DBus ())
-> DBus ()
requestName name flags onError callback =
call (NR.requestName name flags) onError $ \reply ->
case NR.mkRequestNameReply reply of
Nothing -> E.throwError $ InvalidRequestNameReply reply
Just x -> callback x
releaseName :: T.BusName
-> (M.Error -> DBus ())
-> (NR.ReleaseNameReply -> DBus ())
-> DBus ()
releaseName name onError callback =
call (NR.releaseName name) onError $ \reply ->
case NR.mkReleaseNameReply reply of
Nothing -> E.throwError $ InvalidReleaseNameReply reply
Just x -> callback x
requestName_ :: T.BusName -> [NR.RequestNameFlag] -> DBus NR.RequestNameReply
requestName_ name flags = do
reply <- callBlocking_ $ NR.requestName name flags
case NR.mkRequestNameReply reply of
Nothing -> E.throwError $ InvalidRequestNameReply reply
Just x -> return x
releaseName_ :: T.BusName -> DBus NR.ReleaseNameReply
releaseName_ name = do
reply <- callBlocking_ $ NR.releaseName name
case NR.mkReleaseNameReply reply of
Nothing -> E.throwError $ InvalidReleaseNameReply reply
Just x -> return x
newtype Object = Object (Map.Map T.InterfaceName Interface)
newtype Interface = Interface (Map.Map T.MemberName Member)
data Member
= MemberMethod Method
| MemberSignal T.Signature
data Method = Method T.Signature T.Signature (MethodCtx -> DBus ())
export :: T.ObjectPath -> Object -> DBus ()
export path obj = do
let obj' = addIntrospectable path obj
mvar <- fmap clientObjects getClient
liftIO $ MV.modifyMVar_ mvar $ return . Map.insert path obj'
object :: [(T.InterfaceName, Interface)] -> Object
object = Object . Map.fromList
interface :: [(T.MemberName, Member)] -> Interface
interface = Interface . Map.fromList
method :: T.Signature
-> T.Signature
-> (MethodCtx -> DBus ())
-> Member
method inSig outSig cb = MemberMethod $ Method inSig outSig cb
data MethodCtx = MethodCtx
{ methodCtxObject :: Object
, methodCtxMethod :: Method
, methodCtxSerial :: M.Serial
, methodCtxSender :: Maybe T.BusName
, methodCtxFlags :: Set.Set M.Flag
, methodCtxBody :: [T.Variant]
}
replyReturn :: MethodCtx -> [T.Variant] -> DBus ()
replyReturn call' body = if valid then sendReply else sendError where
sendError = replyError call' Const.errorFailed
[T.toVariant ("Method return didn't match signature." :: String)]
sendReply = send_ $ M.MethodReturn
(methodCtxSerial call')
(methodCtxSender call')
body
(Method _ outSig _) = methodCtxMethod call'
valid = listSig body == Just outSig
replyError :: MethodCtx -> T.ErrorName -> [T.Variant] -> DBus ()
replyError call' name body = send_ $ M.Error
name
(methodCtxSerial call')
(methodCtxSender call')
body
unknownMethod :: M.ReceivedMessage -> DBus ()
unknownMethod msg = send_ errorMsg where
M.ReceivedMethodCall serial sender _ = msg
errorMsg = M.Error
Const.errorUnknownMethod
serial sender
[]
findMethod :: Map.Map T.ObjectPath Object -> M.MethodCall -> Maybe (Object, Method)
findMethod objects call' = do
Object obj <- Map.lookup (M.methodCallPath call') objects
ifaceName <- M.methodCallInterface call'
Interface iface <- Map.lookup ifaceName obj
member <- Map.lookup (M.methodCallMember call') iface
case member of
MemberMethod m -> return (Object obj, m)
_ -> Nothing
onMethodCall :: Object -> Method -> M.ReceivedMessage -> DBus ()
onMethodCall obj method' received = runCall where
M.ReceivedMethodCall serial sender msg = received
sig = listSig $ M.methodCallBody msg
Method inSig _ cb = method'
call' = MethodCtx obj method' serial sender
(M.methodCallFlags msg)
(M.methodCallBody msg)
runCall = if sig == Just inSig
then cb call'
else replyError call' Const.errorInvalidArgs []
addIntrospectable :: T.ObjectPath -> Object -> Object
addIntrospectable path (Object ifaces) = Object ifaces' where
ifaces' = Map.insertWith (\_ x -> x) name iface ifaces
name = Const.interfaceIntrospectable
iface = interface [("Introspect", impl)]
impl = method "" "s" $ \call' -> do
let Just xml = I.toXML . introspect path . methodCtxObject $ call'
replyReturn call' [T.toVariant xml]
introspect :: T.ObjectPath -> Object -> I.Object
introspect path obj = I.Object path interfaces [] where
Object 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, (MemberMethod (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, (MemberSignal sig)) = [I.Signal name
(map introspectParam (T.signatureTypes sig))]
introspectSignal _ = []
introspectParam = I.Parameter "" . T.mkSignature_ . T.typeCode
rootObject :: Object
rootObject = object [(ifaceName, interface [(memberName, impl)])] where
ifaceName = Const.interfaceIntrospectable
memberName = "Introspect"
methodXML = I.Method memberName [] [I.Parameter "xml" "s"]
ifaceXML = I.Interface ifaceName [methodXML] [] []
impl = method "" "s" $ \call' -> do
mvar <- fmap clientObjects getClient
paths <- liftIO $ fmap Map.keys $ MV.readMVar mvar
let paths' = filter (/= "/") paths
let Just xml = I.toXML $ I.Object "/" [ifaceXML]
[I.Object p [] [] | p <- paths']
replyReturn call' [T.toVariant xml]
data Proxy = Proxy
{ proxyName :: T.BusName
, proxyObjectPath :: T.ObjectPath
, proxyInterface :: T.InterfaceName
}
deriving (Show, Eq)
callProxy :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> (M.Error -> DBus ())
-> (M.MethodReturn -> DBus ())
-> DBus ()
callProxy proxy name flags body onError onReturn = let
msg = buildMethodCall proxy name flags body
in call msg onError onReturn
callProxyBlocking :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> DBus (Either M.Error M.MethodReturn)
callProxyBlocking proxy name flags body =
callBlocking $ buildMethodCall proxy name flags body
callProxyBlocking_ :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> DBus M.MethodReturn
callProxyBlocking_ proxy name flags body =
callBlocking_ $ buildMethodCall proxy name flags body
onProxySignal :: Proxy -> T.MemberName -> (M.Signal -> DBus ())
-> DBus ()
onProxySignal proxy member handler = onSignal rule handler' where
Proxy 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 = []
}
handler' _ msg = handler msg
buildMethodCall :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> M.MethodCall
buildMethodCall proxy name flags body = msg where
Proxy dest path iface = proxy
msg = M.MethodCall path name (Just iface) (Just dest)
(Set.fromList flags) body
listSig :: [T.Variant] -> Maybe T.Signature
listSig = T.mkSignature . mconcat . map (T.typeCode . T.variantType)