% 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.
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}
<<DBus/Client.hs>>=
<<copyright>>
{-# LANGUAGE OverloadedStrings #-}
module DBus.Client
( <<exports>>
) where
<<imports>>
<<imports>>=
import qualified Control.Concurrent.MVar as MV
import qualified Data.Map as Map
import qualified DBus.Connection as C
import qualified DBus.Constants as Const
import qualified DBus.Message as M
import qualified DBus.Types as T
<<DBus/Client.hs>>=
type Callback = (M.ReceivedMessage -> IO ())
data Client = Client C.Connection
(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
<<exports>>=
Client
, clientConnection
<<DBus/Client.hs>>=
mkClient :: IO (C.Connection, T.BusName) -> IO Client
mkClient getBus = do
(c, _) <- getBus
replies <- MV.newMVar Map.empty
exports <- MV.newMVar Map.empty
signals <- MV.newMVar []
let client = Client c replies exports signals
<<initialize client>>
return client
<<exports>>=
, mkClient
<<DBus/Client.hs>>=
send' :: M.Message a => C.Connection -> (M.Serial -> IO b) -> a
-> IO b
send' c f msg = C.send c f msg >>= \result -> case result of
Left x -> error $ show x
Right x -> return x
@
\section{Name reservation}
@ 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.
<<DBus/Client.hs>>=
data RequestNameFlag
= AllowReplacement
| ReplaceExisting
| DoNotQueue
deriving (Show)
<<DBus/Client.hs>>=
data RequestNameReply
= PrimaryOwner
| InQueue
| Exists
| AlreadyOwner
deriving (Show)
<<DBus/Client.hs>>=
data ReleaseNameReply
= Released
| NonExistent
| NotOwner
deriving (Show)
<<exports>>=
, RequestNameFlag (..)
, RequestNameReply (..)
, ReleaseNameReply (..)
@ All name requests are handled by the main bus service, which has names
provided by the {\tt DBus.Constants} module.
<<DBus/Client.hs>>=
dbus :: Proxy
dbus = Proxy (RemoteObject Const.dbusName Const.dbusPath) Const.dbusInterface
@ There are only two methods of interest here, {\tt RequestName} and
{\tt ReleaseName}.
<<DBus/Client.hs>>=
request, release :: T.MemberName
request = T.mkMemberName' "RequestName"
release = T.mkMemberName' "ReleaseName"
@ 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.
<<DBus/Client.hs>>=
requestName :: Client -> T.BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName client name flags = do
returned <- callBlocking client dbus request []
[ T.toVariant name
, T.toVariant . encodeFlags $ flags]
let reply = M.messageBody returned !! 0
case decodeRequestReply =<< T.fromVariant reply of
Just x -> return x
Nothing -> error $ "Unknown request name reply: " ++
show reply
<<exports>>=
, requestName
@ Releasing a name is similar, except there's no flags for releasing a name.
<<DBus/Client.hs>>=
releaseName :: Client -> T.BusName -> IO ReleaseNameReply
releaseName client name = do
returned <- callBlocking client dbus release [] [T.toVariant name]
let reply = M.messageBody returned !! 0
case decodeReleaseReply =<< T.fromVariant reply of
Just x -> return x
Nothing -> error $ "Unknown release name reply: " ++
show reply
<<exports>>=
, releaseName
<<imports>>=
import Data.Word (Word32)
import Data.Bits ((.|.))
<<DBus/Client.hs>>=
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
flagValue AllowReplacement = 0x1
flagValue ReplaceExisting = 0x2
flagValue DoNotQueue = 0x4
<<DBus/Client.hs>>=
decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing
<<DBus/Client.hs>>=
decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing
@
\section{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
<<initialize client>>=
forkIO $ forever (receiveMessages client)
<<DBus/Client.hs>>=
receiveMessages :: Client -> IO ()
receiveMessages client@(Client c _ _ _) = do
received <- C.receive c
msg <- case received of
Left x -> error $ show x
Right x -> return x
case msg of
(M.ReceivedMethodCall _ _ _ ) -> gotMethodCall client msg
(M.ReceivedMethodReturn _ _ msg') -> gotReply client (M.methodReturnSerial msg') msg
(M.ReceivedError _ _ msg') -> gotReply client (M.errorSerial msg') msg
(M.ReceivedSignal _ _ _ ) -> gotSignal client msg
_ -> return ()
<<DBus/Client.hs>>=
gotMethodCall :: Client -> M.ReceivedMessage -> IO ()
gotMethodCall client@(Client _ _ mvar _) msg = do
objects <- MV.readMVar mvar
let M.ReceivedMethodCall _ _ call' = msg
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 = send' c (const $ return ()) errorMsg where
M.ReceivedMethodCall serial sender _ = msg
c = clientConnection client
errorMsg = M.Error
Const.errorUnknownMethod
serial sender
(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
[]
@ 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.
<<imports>>=
import Data.Maybe (isJust, fromJust, isNothing)
<<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 ()
<<DBus/Client.hs>>=
gotSignal :: Client -> M.ReceivedMessage -> IO ()
gotSignal (Client _ _ _ mvar) msg = MV.withMVar mvar $
mapM_ (\cb -> forkIO (cb msg))
@ \subsection{Signals}
<<DBus/Client.hs>>=
onSignal :: Client
-> (T.BusName -> M.Signal -> Bool)
-> (T.BusName -> M.Signal -> IO ())
-> IO ()
onSignal (Client _ _ _ mvar) test callback = MV.modifyMVar_ mvar addCallback where
addCallback callbacks = return $ callback' : callbacks
callback' (M.ReceivedSignal _ sender msg) =
if test (fromJust sender) msg
then callback (fromJust sender) msg
else return ()
callback' _ = undefined
<<DBus/Client.hs>>=
signalFilter :: Maybe T.BusName -> Maybe T.ObjectPath -> Maybe T.InterfaceName
-> Maybe T.MemberName -> T.BusName -> M.Signal -> Bool
signalFilter sender path iface member sender' msg = all id
[ isNothing sender || sender == Just sender'
, isNothing path || path == Just (M.signalPath msg)
, isNothing iface || iface == Just (M.signalInterface msg)
, isNothing member || member == Just (M.signalMember msg)
]
<<exports>>=
, onSignal
, signalFilter
@
\section{Remote object proxies}
<<exports>>=
, RemoteObject (..)
, Proxy (..)
, call
, callBlocking
, onSignalFrom
<<DBus/Client.hs>>=
data RemoteObject = RemoteObject T.BusName T.ObjectPath
data Proxy = Proxy RemoteObject T.InterfaceName
@ \subsection{Method calls}
<<DBus/Client.hs>>=
call :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> (M.Error -> IO ())
-> (M.MethodReturn -> IO ())
-> IO ()
call client proxy name flags body onError onReturn = let
Proxy (RemoteObject dest path) iface = proxy
Client bus mvar _ _ = client
msg = M.MethodCall path name (Just iface) (Just dest)
(Set.fromList flags)
body
callback (M.ReceivedError _ _ z) = onError z
callback (M.ReceivedMethodReturn _ _ z) = onReturn z
callback _ = undefined
addCallback s = MV.modifyMVar_ mvar $ \callbacks ->
return $ Map.insert s callback callbacks
in send' bus addCallback msg
<<DBus/Client.hs>>=
callBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
-> IO M.MethodReturn
callBlocking client proxy name flags body = do
mvar <- MV.newEmptyMVar
call client proxy name flags body
(MV.putMVar mvar . Left)
(MV.putMVar mvar . Right)
reply <- MV.takeMVar mvar
case reply of
Left x -> error (show x)
Right x -> return x
@ \subsection{Signals}
<<DBus/Client.hs>>=
onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ())
-> IO ()
onSignalFrom client proxy member io = onSignal client test io' where
Proxy (RemoteObject dest path) iface = proxy
test = signalFilter (Just dest) (Just path) (Just iface)
(Just member)
io' _ msg = io msg
@
\section{Exporting local objects}
<<imports>>=
import qualified DBus.Introspection as I
<<initialize client>>=
export client (T.mkObjectPath' "/") rootObject
<<DBus/Client.hs>>=
rootObject :: LocalObject
rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where
ifaceName = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
memberName = T.mkMemberName' "Introspect"
inSig = T.mkSignature' ""
outSig = T.mkSignature' "s"
interface = Interface $ Map.fromList [(memberName, impl)]
method = I.Method memberName [] [I.Parameter "xml" outSig]
iface = I.Interface ifaceName [method] [] []
path = T.mkObjectPath' "/"
impl = Method inSig outSig $ \call' -> do
let Client _ _ mvar _ = methodCallClient call'
paths <- fmap Map.keys $ MV.readMVar mvar
let paths' = filter (/= path) paths
let Just xml = I.toXML $ I.Object path [iface]
[I.Object p [] [] | p <- paths']
replyReturn call' [T.toVariant xml]
<<exports>>=
, LocalObject (..)
, Member (..)
, Interface (..)
, MethodCall (..)
, 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 :: 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 = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
iface = Interface $ Map.fromList [(T.mkMemberName' "Introspect", impl)]
impl = Method (T.mkSignature' "") (T.mkSignature' "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>>=
replyReturn :: MethodCall -> [T.Variant] -> IO ()
replyReturn call' body = reply where
c = clientConnection . methodCallClient $ call'
replyInvalid = M.Error
Const.errorFailed
(methodCallSerial call')
(methodCallSender call')
(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
[T.toVariant $ TL.pack "Method return didn't match signature."]
replyValid = M.MethodReturn
(methodCallSerial call')
(methodCallSender call')
(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
body
sendReply :: M.Message a => a -> IO ()
sendReply = send' c (const $ return ())
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>>=
replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO ()
replyError call' name body = send' c (const $ return ()) reply where
c = clientConnection . methodCallClient $ call'
reply = M.Error
name
(methodCallSerial call')
(methodCallSender call')
(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
body
<<exports>>=
, replyReturn
, replyError
@ \end{document}