% Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
%
% This program is free software: you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation, either version 3 of the License, or
% any later version.
%
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
% GNU General Public License for more details.
%
% You should have received a copy of the GNU General Public License
% along with this program. If not, see <http://www.gnu.org/licenses/>.
\documentclass[12pt]{article}
\usepackage{color}
\usepackage{hyperref}
\usepackage{noweb}
% Smaller margins
\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry}
% Remove boxes from hyperlinks
\hypersetup{
colorlinks,
linkcolor=blue,
}
\makeindex
\begin{document}
\addcontentsline{toc}{section}{Contents}
\tableofcontents
@
\section{Introduction}
This library provides a simplified, high-level interface for use by D-Bus
clients. It implements async operations, remote object proxies, and
local object exporting.
The {\tt DBus.Client} module provides the public interface to this library.
<<DBus/Client.hs>>=
<<copyright>>
{-# LANGUAGE OverloadedStrings #-}
module DBus.Client
( <<exports>>
) where
<<imports>>
@ All source code is licensed under the terms of the GNU GPL v3 or later.
<<copyright>>=
{-
Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
This program is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or
any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see <http://www.gnu.org/licenses/>.
-}
@
\section{Clients}
The {\tt Client} type provides an opaque handle to internal client state,
including callback registration and the open connection.
<<imports>>=
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
<<DBus/Client.hs>>=
type Callback = (M.ReceivedMessage -> IO ())
-- | 'Client's are opaque handles to an open connection and other internal
-- state.
--
data Client = Client C.Connection T.BusName
(MV.MVar (Map.Map M.Serial Callback))
(MV.MVar (Map.Map T.ObjectPath Callback))
(MV.MVar [Callback])
@ Two accessor functions are defined for the {\tt Client}'s {\tt Connection}
and unique bus name. The {\tt Connection} is used internally by this module,
but is not otherwise useful -- sharing a {\tt Connection} between two
{\tt Client}s is a bad idea.
The {\tt Client}'s bus name might be useful, and there's no harm in exposing
it.
<<DBus/Client.hs>>=
clientConnection :: Client -> C.Connection
clientConnection (Client x _ _ _ _) = x
clientName :: Client -> T.BusName
clientName (Client _ x _ _ _) = x
<<exports>>=
-- * Clients
Client
, clientName
<<DBus/Client.hs>>=
-- | Create a new 'Client' from an open connection and bus name. The weird
-- signature allows 'mkClient' to use the computations in "DBus.Bus"
-- directly, without unpacking:
--
-- @
-- client <- mkClient =<< getSessionBus
-- @
--
-- Only one client should be created for any given connection. Otherwise,
-- they will compete to receive messages.
--
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
<<initialize client>>
return client
<<exports>>=
, mkClient
@ \subsection{Sending messages}
To simplify error conditions, errors returned from the {\tt DBus.Connection}
computations are converted to exceptions via {\tt error}. These errors only
occur if the message is malformed, so it's not worth the additional API
complexity to handle them.
<<DBus/Client.hs>>=
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
@ And since most uses of {\tt send\_} don't care about the message's
serial, it can be reduced further.
<<DBus/Client.hs>>=
sendOnly_ :: M.Message a => Client -> a -> IO ()
sendOnly_ c = send_ c (const $ return ())
@ Additional helper computations are useful for sending method calls, to
keep track of which pending calls are currently expecting replies. The
{\tt call} computation is asynchronous; it will return immediately, and
one of the provided computations will be invoked depending on whether a
{\tt MethodReturn} or {\tt Error} were received.
TODO: pending method calls should be removed periodically, after a
decently long timeout.
TODO: if method calls with the {\tt NoReplyExpected} flag are sent, a
callback will be added but never removed. This could cause a space leak.
<<DBus/Client.hs>>=
-- | Perform an asynchronous method call. One of the provided computations
-- will be performed depending on what message type the destination sends
-- back.
--
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 ()
<<DBus/Client.hs>>=
-- | Similar to 'call', except that it waits for the reply and returns it
-- in the current 'IO' thread.
--
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
<<DBus/Client.hs>>=
-- | Similar to 'callBlocking', except that an exception is raised if the
-- destination sends back an error.
--
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
<<exports>>=
-- ** Sending messages
, call
, callBlocking
, callBlocking_
@ \subsubsection{Emitting signals}
TODO: this should be written in terms of locally exported objects; having
to construct a {\tt Signal} is a pain.
<<DBus/Client.hs>>=
emitSignal :: Client -> M.Signal -> IO ()
emitSignal = sendOnly_
<<exports>>=
-- *** Emitting signals
, emitSignal
@ \subsection{Receiving messages}
Each client runs a separate thread for receiving messages, and every callback
is called in a separate thread. This allows callbacks to perform long
computations without blocking receipt of other messages.
<<imports>>=
import Control.Concurrent (forkIO)
import Control.Monad (forever)
import qualified Data.Set as Set
import qualified DBus.Constants as Const
<<initialize client>>=
forkIO $ forever (receiveMessages client)
@ FIXME: does raising an exception here cause the thread to terminate?
<<DBus/Client.hs>>=
receiveMessages :: Client -> IO ()
receiveMessages client = do
received <- C.receive $ clientConnection client
case received of
Left x -> error $ show x
Right x -> handleMessage client x
<<DBus/Client.hs>>=
handleMessage :: Client -> M.ReceivedMessage -> IO ()
<<message handlers>>
handleMessage _ _ = return ()
@ \subsubsection{Method calls}
Method calls are dispatched to the client's list of exported objects. If
no object is available at the requested path, an error will be returned.
<<message handlers>>=
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
<<DBus/Client.hs>>=
unknownMethod :: Client -> M.ReceivedMessage -> IO ()
unknownMethod client msg = sendOnly_ client errorMsg where
M.ReceivedMethodCall serial sender _ = msg
errorMsg = M.Error
Const.errorUnknownMethod
serial sender
[]
@ \subsubsection{Replies}
@ Method returns and errors both have a serial attached, which is used to
find the proper callback. If the callback cannot be found, no action will
be taken.
<<message handlers>>=
handleMessage c msg@(M.ReceivedMethodReturn _ _ msg') =
gotReply c (M.methodReturnSerial msg') msg
handleMessage c msg@(M.ReceivedError _ _ msg') =
gotReply c (M.errorSerial msg') msg
<<imports>>=
import Data.Maybe (isJust)
<<DBus/Client.hs>>=
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 ()
@ \subsubsection{Signals}
Signals are dispatched to the list of active signal handlers.
<<message handlers>>=
handleMessage c msg@(M.ReceivedSignal _ _ _) = let
Client _ _ _ _ mvar = c
in MV.withMVar mvar $ mapM_ (\cb -> forkIO (cb msg))
@
\section{Name reservation}
<<imports>>=
import qualified DBus.NameReservation as NR
<<DBus/Client.hs>>=
-- | A client can request a \"well-known\" name from the bus. This allows
-- messages sent to that name to be received by the client, without senders
-- being aware of which application is actually handling requests.
--
-- A name may be requested for any client, using the given flags. The bus's
-- reply will be returned, or an exception raised if the reply was invalid.
--
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
<<DBus/Client.hs>>=
-- | Clients may also release names they've requested.
--
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
<<exports>>=
-- * Name reservation
, requestName
, releaseName
@ \subsection{Listening for Signals}
Before the bus forwards any signals to this client, the client must send a
match rule to the bus. The rule is kept around so the correct callback can
be found when the signal is received.
<<imports>>=
import qualified DBus.MatchRule as MR
import Data.Maybe (fromJust)
<<DBus/Client.hs>>=
-- | Perform some computation every time this client receives a matching
-- signal.
--
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' :)
<<exports>>=
-- * Receiving signals
, onSignal
@
\section{Remote objects and proxies}
TODO: document this section
<<exports>>=
-- * Remote objects and proxies
, RemoteObject (..)
, Proxy (..)
<<DBus/Client.hs>>=
data RemoteObject = RemoteObject T.BusName T.ObjectPath
data Proxy = Proxy RemoteObject T.InterfaceName
@ \subsection{Method calls}
<<DBus/Client.hs>>=
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
<<DBus/Client.hs>>=
-- | As 'call', except that the proxy's information is used to
-- build the message.
--
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
<<DBus/Client.hs>>=
-- | As 'callBlocking', except that the proxy's information is used
-- to build the message.
--
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
<<DBus/Client.hs>>=
-- | As 'callBlocking_', except that the proxy's information is used
-- to build the message.
--
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
<<exports>>=
, callProxy
, callProxyBlocking
, callProxyBlocking_
@ \subsection{Signals}
<<DBus/Client.hs>>=
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
<<exports>>=
, onSignalFrom
@
\section{Exporting local objects}
FIXME: the introspection stuff is \emph{really} ugly.
<<imports>>=
import qualified DBus.Introspection as I
<<initialize client>>=
export client ("/") rootObject
<<DBus/Client.hs>>=
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]
<<exports>>=
-- * Exporting local objects
, LocalObject (..)
, Interface (..)
, Member (..)
, export
<<imports>>=
import qualified Data.Text.Lazy as TL
<<DBus/Client.hs>>=
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
<<DBus/Client.hs>>=
-- | Export a set of interfaces on the bus. Whenever a method call is
-- received which matches the object's path, interface, and member name,
-- one of its members will be called.
--
-- Exported objects automatically implement the
-- @org.freedesktop.DBus.Introspectable@ interface.
--
export :: Client -> T.ObjectPath -> LocalObject -> IO ()
export client@(Client _ _ _ mvar _) path obj = MV.modifyMVar_ mvar $
return . Map.insert path (onMethodCall client (addIntrospectable path obj))
<<DBus/Client.hs>>=
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]
<<DBus/Client.hs>>=
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
@ \subsection{Responding to method calls}
<<DBus/Client.hs>>=
data MethodCall = MethodCall
{ methodCallObject :: LocalObject
, methodCallClient :: Client
, methodCallMethod :: Member
, methodCallSerial :: M.Serial
, methodCallSender :: Maybe T.BusName
, methodCallFlags :: Set.Set M.Flag
, methodCallBody :: [T.Variant]
}
@ Technically method calls don't have to specify an interface if there's only
one available in the destination object, but that'll never be the case here,
so treat an unspecified interface as unknown.
<<DBus/Client.hs>>=
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
<<DBus/Client.hs>>=
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
<<DBus/Client.hs>>=
-- | Send a successful return reply for a method call.
--
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
<<DBus/Client.hs>>=
-- | Send an error reply for a method call.
--
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
<<exports>>=
-- ** Responding to method calls
, MethodCall (..)
, replyReturn
, replyError
@ \end{document}