dbus-client 0.3.0.1 → 0.4

raw patch · 8 files changed

+1617/−1120 lines, 8 filesdep +monads-tfdep +transformersdep ~containersdep ~text

Dependencies added: monads-tf, transformers

Dependency ranges changed: containers, text

Files

• Examples/exporting.hs +65/−0
• Examples/introspect.hs +107/−0
• Examples/simple.hs +14/−10
• Makefile +0/−18
• dbus-client.anansi +966/−0
• dbus-client.cabal +9/−8
• dbus-client.nw +0/−662
• hs/DBus/Client.hs +456/−422

@@ -0,0 +1,65 @@+-- Copyright (C) 2009-2010 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/>.++{-# LANGUAGE OverloadedStrings #-}+module Main (main) where+import Control.Monad.IO.Class (liftIO)+import DBus.Client+import DBus.Constants+import qualified Data.Map as Map++a :: String -> Object+a x = object+	[ ("test.iface_1", interface+	  [ ("Foo", onFoo "a" x)+	  , ("Bar", onBar "a" x)+	  ])+	]++b :: String -> Object+b x = object+	[ ("test.iface_1", interface+	  [ ("Foo", onFoo "b" x)+	  , ("Bar", onBar "b" x)+	  ])+	]++onFoo :: String -> String -> Member+onFoo x y = method "" "s" $ \call -> do+	liftIO $ putStrLn $ "Foo " ++ x ++ " " ++ y+	replyReturn call [toVariant $ "Foo " ++ x ++ " " ++ y]++onBar :: String -> String -> Member+onBar x y = method "" "s" $ \call -> do+	liftIO $ putStrLn $ "Bar " ++ x ++ " " ++ y+	replyError call errorFailed [toVariant $ "Bar " ++ x ++ " " ++ y]++main :: IO ()+main = do+	-- Connect to the bus+	client <- newClient =<< getSessionBus+	runDBus client $ do+		-- Request a unique name on the bus. If the name is already+		-- in use, continue without it.+		requestName "org.test.exporting" []+			(\e -> liftIO $ putStrLn "Error requesting unique name")+			(\response -> return ())+		+		-- Export two example objects+		export "/a" (a "hello")+		export "/b" (b "world")+		+		-- Wait forever for method calls+		mainLoop

@@ -0,0 +1,107 @@+-- Copyright (C) 2009-2010 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/>.++{-# LANGUAGE OverloadedStrings #-}+module Main (main) where+import Prelude hiding (replicate)+import qualified Prelude as Prelude+import qualified Data.Text.Lazy as TL+import Control.Monad.IO.Class (liftIO)+import Control.Concurrent (forkIO)+import Data.Maybe++import DBus.Client+import qualified DBus.Introspection as I+import System (getArgs)++main :: IO ()+main = do+	[service, path] <- getArgs+	c <- newClient =<< getSessionBus+	let introspect' p = runDBus c $ introspect (mkBusName_ $ TL.pack service) p+	forkIO $ runDBus c mainLoop+	printObj introspect' 0 (mkObjectPath_ $ TL.pack path)++introspect :: BusName -> ObjectPath -> DBus I.Object+introspect service path = do+	let proxy = Proxy service path "org.freedesktop.DBus.Introspectable"+	+	reply <- callProxyBlocking_ proxy "Introspect" [] []+	let text = fromJust $ fromVariant (methodReturnBody reply !! 0)+	return . fromJust $ I.fromXML path text++-- most of this stuff is just boring text formatting++printObj :: (ObjectPath -> IO I.Object) -> Integer -> ObjectPath -> IO ()+printObj get depth path = do+	let strPath = strObjectPath path+	putStr $ replicate (depth * 4) ' '+	putStrLn $ TL.unpack strPath+	+	(I.Object _ interfaces children) <- get path+	+	putStr $ replicate (depth * 4) ' '+	putStrLn $ replicate (fromIntegral $ TL.length strPath) '='+	+	mapM_ (printIface (depth + 1)) interfaces+	+	mapM_ (printObj get (depth + 1)) [x | (I.Object x _ _) <- children]++printIface :: Integer -> I.Interface -> IO ()+printIface depth (I.Interface name methods signals properties) = do+	let strName = strInterfaceName name+	putStr $ replicate (depth * 4) ' '+	putStrLn . TL.unpack $ strName+	putStr $ replicate (depth * 4) ' '+	putStrLn $ replicate (fromIntegral $ TL.length strName) '-'+	+	mapM_ (printMethod (depth + 1)) methods+	mapM_ (printSignal (depth + 1)) signals+	mapM_ (printProperty (depth + 1)) properties++printMethod :: Integer -> I.Method -> IO ()+printMethod depth (I.Method name inParams outParams) = do+	putStr $ replicate (depth * 4) ' '+	putStr "M "+	putStrLn . TL.unpack . strMemberName $ name+	+	mapM_ (printParam "IN" (depth + 1)) inParams+	mapM_ (printParam "OUT" (depth + 1)) outParams++printSignal :: Integer -> I.Signal -> IO ()+printSignal depth (I.Signal name params) = do+	putStr $ replicate (depth * 4) ' '+	putStr "S "+	putStrLn . TL.unpack . strMemberName $ name+	+	mapM_ (printParam "OUT" (depth + 1)) params++printProperty :: Integer -> I.Property -> IO ()+printProperty depth (I.Property name sig access) = do+	putStr $ replicate (depth * 4) ' '+	putStr $ "P " ++ show (strSignature sig) ++ " "+	putStrLn $ TL.unpack name+	putStr $ replicate ((depth + 1) * 4) ' '+	putStrLn $ show access+	+printParam :: String -> Integer -> I.Parameter -> IO ()+printParam label depth (I.Parameter name sig) = do+	putStr $ replicate (depth * 4) ' '+	putStr $ "[" ++ label ++ " "+	putStr $ show (strSignature sig) ++ " ] "+	putStrLn $ TL.unpack name++replicate :: Integer -> a -> [a]+replicate = Prelude.replicate . fromInteger

@@ -1,4 +1,4 @@--- Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+-- Copyright (C) 2009-2010 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@@ -16,27 +16,31 @@ {-# LANGUAGE OverloadedStrings #-} module Main (main) where -import DBus.Bus import DBus.Client-import DBus.Message-import DBus.Types+import Control.Concurrent (forkIO)+import Control.Monad (forever) import Data.List (sort)  dbus :: Proxy-dbus = Proxy (RemoteObject "org.freedesktop.DBus" "/org/freedesktop/DBus") "org.freedesktop.DBus"+dbus = Proxy "org.freedesktop.DBus" "/org/freedesktop/DBus" "org.freedesktop.DBus"  main :: IO () main = do 	-- Connect to the bus, and print which name was assigned to this 	-- connection.-	client <- mkClient =<< getSessionBus+	client <- newClient =<< getSessionBus 	putStrLn $ "Connected as: " ++ show (clientName client) 	-	-- Request a list of connected clients from the bus-	reply <- callProxyBlocking_ client dbus "ListNames" [] []+	-- Start message handling in another thread+	forkIO $ runDBus client mainLoop 	-	-- Pull out the body, and convert it to [String]-	let Just names = fromArray =<< fromVariant (messageBody reply !! 0)+	-- Request a list of connected clients from the bus+	names <- runDBus client $ do+		reply <- callProxyBlocking_ dbus "ListNames" [] []+		+		-- Pull out the body, and convert it to [String]+		let Just names = fromArray =<< fromVariant (messageBody reply !! 0)+		return names 	 	-- Print each name on a line, sorted so reserved names are below 	-- temporary names.

@@ -1,18 +0,0 @@-HS_SOURCES=hs/DBus/Client.hs--all: $(HS_SOURCES)--%.tex: %.nw-	noweave -delay "$<" | cpif "$@"--hs/%.hs: dbus-client.nw hs/DBus-	notangle -R"$*.hs" "$<" | cpif "$@"--hs/DBus:-	mkdir -p hs/DBus--dbus-client.pdf: dbus-client.tex-	xelatex dbus-client.tex-	xelatex dbus-client.tex--pdf: dbus-client.pdf

@@ -0,0 +1,966 @@+:# 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.++:f DBus/Client.hs+|copyright|+|language extensions|+module DBus.Client (+	|exports|+	) where+|imports|+:++{\tt DBus.Client} also re-exports some modules from the {\tt dbus-core}+package.++:d exports+  module DBus.Bus+, module DBus.Types+, module DBus.Message+:++:d imports+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+:++All source code is licensed under the terms of the GNU GPL v3 or later.++:d 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/>.+:++:d language extensions+{-# LANGUAGE OverloadedStrings #-}+:++\section{DBus Clients}++The {\tt Client} type provides an opaque handle to internal client state,+including callback registration and the open connection.++:d imports+import qualified Control.Concurrent.MVar as MV+import qualified Data.Map as Map+:++:f DBus/Client.hs+|apidoc Client|+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 ())+:++:d exports+  -- * Clients+, Client+, C.Connection+, clientName+:++The signature of {\tt newClient} is a bit weird so it can be called with+results from the {\tt DBus.Bus} family of computations, without having to+unwrap or curry.++:f DBus/Client.hs+|apidoc newClient|+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+	|initialize client|+	return client+:++:d exports+, newClient+:++\section{Monadic interface}++Most of this module uses the {\tt DBus} monad, which wraps up the DBus+connection into a more abstract form.++:d imports+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+:++:f DBus/Client.hs+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+:++The low-level DBus module prefers to return errors in the standard+{\tt Either} type, to let clients explicitly handle errors. Most of the+time, there's no reasonable way to handle such an error, so any errors+encountered when running a DBus client are thrown as exceptions.++:d language extensions+{-# LANGUAGE DeriveDataTypeable #-}+:++:d imports+import Data.Typeable (Typeable)+import qualified Control.Exception as Exc+:++Errors marshaling and unmarshaling are supported. Additionally, uncaught+errors from blocking method calls may be thrown from some computations.++:f DBus/Client.hs+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+:++Having to run {\tt liftIO} everywhere is annoying, so {\tt MonadError}+is instanced to let clients throw/catch more easily.++:d language extensions+{-# LANGUAGE TypeFamilies #-}+:++:d imports+import qualified Control.Monad.Error as E+:++:f DBus/Client.hs+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)+:++Typical monad unwrapper, and some access computations.++:f DBus/Client.hs+|apidoc runDBus|+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+:+++:d exports+, DBus+, DBusException+, runDBus+, getClient+:++\subsection{Dispatching messages}++Messages are read sequentially from the connection (typically in a central+loop), and then processed according to the client's message handler maps.+Unknown message types are ignored.++:f DBus/Client.hs+|apidoc processMessage|+processMessage :: M.ReceivedMessage -> DBus ()+processMessage received = p received where+	p (M.ReceivedUnknown _ _ _) = return ()+	|process messages|+	reply s = onReply s received+:++:d exports+, processMessage+:++\subsection{Useful wrappers}++Sending and receiving messages is common enough to use some small wrapper+functions.++:f DBus/Client.hs+|apidoc send|+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++|apidoc send_|+send_ :: M.Message msg => msg -> DBus ()+send_ = send (const $ return ())+:++:f DBus/Client.hs+|apidoc receive|+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+:++:f DBus/Client.hs+|apidoc mainLoop|+mainLoop :: DBus ()+mainLoop = forever $ receive >>= processMessage+:++:d exports+, send+, send_+, receive+, mainLoop+:++\section{Method calls}++DBus is inherently asynchronous. Method calls are sent over the bus, and+at some future point a response might be received.++Because all messages are sent and received over a single connection, waiting+for replies should be performed from a single thread. However, it's safe to+send messages from any thread.++\subsection{Asynchronous}++:f DBus/Client.hs+|apidoc call|+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+:++:d exports+, call+:++:d process messages+p (M.ReceivedMethodReturn _ _ msg) = reply $ M.methodReturnSerial msg+p (M.ReceivedError _ _ msg) = reply $ M.errorSerial msg+:++When a {\tt MethodReturn} or {\tt Error} message is received, DBus expects+that its stored serial refers to a registered callback. Sometimes this isn't+true -- for example, a client might have used {\tt send} to call a method and+ignore its return value. In these cases, the return message should be+ignored.++:d imports+import Data.Maybe (isJust)+:++:f DBus/Client.hs+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 ()+:++\subsection{Synchronous}++Synchronous (or ``blocking'') operation is emulated using an {\tt MVar}.++:f DBus/Client.hs+|apidoc callBlocking|+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++|apidoc callBlocking_|+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+:++:d exports+, callBlocking+, callBlocking_+:++\section{Handling 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.++:f DBus/Client.hs+|apidoc onSignal|+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 :)+:++:d process messages+p (M.ReceivedSignal _ _ _) = do+	mvar <- fmap clientSignalHandlers getClient+	handlers <- liftIO $ MV.readMVar mvar+	mapM_ ($ received) handlers+:++:d exports+-- * Handling signals+, onSignal+:++\section{Name reservation}++:d exports+-- * Name reservation+, NR.RequestNameFlag (..)+, NR.RequestNameReply (..)+, NR.ReleaseNameReply (..)+, requestName+, releaseName+, requestName_+, releaseName_+:++:f DBus/Client.hs+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+:++:f DBus/Client.hs+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+:++:f DBus/Client.hs+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+:++:f DBus/Client.hs+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+:++\section{Exporting local objects}++DBus is an object-oriented design, and most languages with DBus libraries+conform at least vaguely to object-oriented principles. Since Haskell is+functional, it's somewhat difficult to make exporting local behavior as+simple as it is in other languages.++In DBus, the basic unit of behavior is a ``member''. Members may be either+methods, which are called, or signals, which are emitted. A collection of+members indexed by name is an ``interface''. A collection interfaces (also+indexed by name) is an ``object''.++A method has two signatures, one for inputs and another for outputs. DBus+does not support in-out (aka ``reference'') parameters. Signals have only+one signature, which is of their output.++:f DBus/Client.hs+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 ())+:++:d exports+  -- * Exporting local objects+, Object (..)+, Interface (..)+, Member (..)+, Method (..)+:++Exporting is mostly just a matter of adding the object and its path to the+client's lookup map. However, note the call to {\tt addIntrospectable} --+DBus supports remote object introspection, and it's useful to generate a+basic schema by default.++:f DBus/Client.hs+|apidoc export|+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'+:++:d exports+, export+:++To simplify building objects from existing functions, some helper functions+are defined.++:f DBus/Client.hs+object :: [(T.InterfaceName, Interface)] -> Object+object = Object . Map.fromList++interface :: [(T.MemberName, Member)] -> Interface+interface = Interface . Map.fromList++method :: T.Signature -- ^ Input signature+       -> T.Signature -- ^ Output signature+       -> (MethodCtx -> DBus ()) -- ^ Implementation+       -> Member+method inSig outSig cb = MemberMethod $ Method inSig outSig cb+:++:d exports+, object+, interface+, method+:++\subsection{Responding to method calls}++When a method call message is received for a local object, relevant+information for replying to the call is placed in a {\tt MethodCtx} value.++:d imports+import qualified Data.Set as Set+:++:f DBus/Client.hs+data MethodCtx = MethodCtx+	{ methodCtxObject :: Object+	, methodCtxMethod :: Method+	, methodCtxSerial :: M.Serial+	, methodCtxSender :: Maybe T.BusName+	, methodCtxFlags  :: Set.Set M.Flag+	, methodCtxBody   :: [T.Variant]+	}+:++{\tt replyReturn} and {\tt replyError} can be used by client code to+send a response message to a method call. Using these is easier than+constructing the reply manually.++:f DBus/Client.hs+|apidoc replyReturn|+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+:++:f DBus/Client.hs+replyError :: MethodCtx -> T.ErrorName -> [T.Variant] -> DBus ()+replyError call' name body = send_ $ M.Error+	name+	(methodCtxSerial call')+	(methodCtxSender call')+	body+:++:d exports+  -- ** Responding to method calls+, MethodCtx (..)+, replyReturn+, replyError+:++\subsection{Dispatching method calls}++Method calls are dispatched using the client's object map. If the+specified method is not found, an error will be returned.++:d process messages+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+:++:f DBus/Client.hs+unknownMethod :: M.ReceivedMessage -> DBus ()+unknownMethod msg = send_ errorMsg where+	M.ReceivedMethodCall serial sender _ = msg+	errorMsg = M.Error+		Const.errorUnknownMethod+		serial sender+		[]+:++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.++:f DBus/Client.hs+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+:++If the method was found, it needs to have its parameter list validated+before being sent on to the inner callback. This prevents DBus's dynamic+typing from causing trouble in Haskell code.++:f DBus/Client.hs+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 []+:++\subsection{Automatic introspection}++Some basic introspection can be performed automatically, based on the+contents of an {\tt Object}. This is only added to objects which do not+already define the {\tt Introspectable} interface -- that way, clients can+provide their own implementations if needed.++:f DBus/Client.hs+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]+:++:f DBus/Client.hs+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+:++\subsection{The root object}++Every client exports a ``root'' object, which provides introspection for+all exported objects. Although the DBus export list is hierarchical, this+module models it as a flat map.++:f DBus/Client.hs+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]+:++:d initialize client+liftIO $ MV.modifyMVar_ objects $ return . Map.insert "/" rootObject+:++\section{Remote object proxies}++Most DBus libraries support the concept of an ``object proxy'', which+behaves like a native object but runs its operations in another process.+A {\tt Proxy} is an approximation of this model for Haskell.++:f DBus/Client.hs+data Proxy = Proxy+	{ proxyName :: T.BusName+	, proxyObjectPath :: T.ObjectPath+	, proxyInterface :: T.InterfaceName+	}+	deriving (Show, Eq)+:++:f DBus/Client.hs+|apidoc callProxy|+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+:++:f DBus/Client.hs+|apidoc callProxyBlocking|+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+:++:f DBus/Client.hs+|apidoc callProxyBlocking_|+callProxyBlocking_ :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]+                   -> DBus M.MethodReturn+callProxyBlocking_ proxy name flags body =+	callBlocking_ $ buildMethodCall proxy name flags body+:++:f DBus/Client.hs+|apidoc onProxySignal|+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+:++:d exports+, Proxy (..)+, callProxy+, callProxyBlocking+, callProxyBlocking_+, onProxySignal+:++:f DBus/Client.hs+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+:++\section{Utility functions}++:d imports+import Data.Monoid (mconcat)+:++:f DBus/Client.hs+listSig :: [T.Variant] -> Maybe T.Signature+listSig = T.mkSignature . mconcat . map (T.typeCode . T.variantType)+:++\section{Haddock API documentation}++:d apidoc Client+-- | 'Client's are opaque handles to an open connection and other internal+-- state.+:++:d apidoc newClient+-- | Create a new 'Client' from an open connection and bus name. The weird+-- signature allows @newClient@ to use the computations in "DBus.Bus"+-- directly, without unpacking:+--+-- @+-- client <- newClient =<< 'getSessionBus'+-- @+--+-- Only one client should be created for any given connection. Otherwise,+-- they will compete to receive messages.+:++:d apidoc runDBus+-- | Run a DBus computation with the given client callbacks. Errors+-- encountered while running will be thrown as exceptions, using the+-- 'DBusException' type.+--+-- Use the 'E.MonadError' instance for 'DBus' to handle errors inside+-- the computation.+:++:d apidoc processMessage+-- | Run message handlers with the received message. If any method reply+-- callbacks or signal handlers are found, they will be run in the current+-- thread.+:++:d apidoc send+-- | A wrapper around 'C.send'.+:++:d apidoc send_+-- | A wrapper around 'C.send', which does not allow the message serial+-- to be recorded. This is a useful shortcut when sending messages which+-- are not expected to receive a reply.+:++:d apidoc receive+-- | A wrapper around 'C.receive'.+:++:d apidoc mainLoop+-- | Run in a loop forever, processing messages.+--+-- This is commonly run in a separate thread, ie+--+-- > client <- newClient =<< getSessionBus+-- > forkIO $ runDBus client mainLoop+:++:d apidoc call+-- | Perform an asynchronous method call. One of the provided computations+-- will be performed depending on what message type the destination sends+-- back.+:++:d apidoc callBlocking+-- | Sends a method call, and then blocks until a reply is received. Use+-- this when the receive/process loop is running in a separate thread.+:++:d apidoc callBlocking_+-- | A variant of 'callBlocking', which throws an exception if the+-- remote client returns 'M.Error'.+:++:d apidoc onSignal+-- | Perform some computation every time this client receives a matching+-- signal.+:++:d apidoc export+-- | 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.+:++:d apidoc replyReturn+-- | Send a successful return reply for a method call.+:++:d apidoc replyError+-- | Send an error reply for a method call.+:++:d apidoc callProxy+-- | As 'call', except that the proxy's information is used to+-- build the message.+:++:d apidoc callProxyBlocking+-- | As 'callBlocking', except that the proxy's information is used+-- to build the message.+:++:d apidoc callProxyBlocking_+-- | As 'callBlocking_', except that the proxy's information is used+-- to build the message.+:++:d apidoc onProxySignal+-- | As 'onSIgnal', except that the proxy's information is used+-- to build the match rule.+:

@@ -1,6 +1,6 @@ name: dbus-client-version: 0.3.0.1-synopsis: D-Bus client libraries+version: 0.4+synopsis: Monadic and object-oriented interfaces to DBus license: GPL-3 license-file: License.txt author: John Millikin@@ -11,26 +11,27 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com homepage: http://ianen.org/haskell/dbus/-tested-with: GHC==6.10.4+tested-with: GHC==6.12.1  extra-source-files:-  dbus-client.nw+  dbus-client.anansi   Examples/*.hs-  Makefile  source-repository head   type: darcs   location: http://ianen.org/haskell/dbus/client/  library-  ghc-options: -Wall+  ghc-options: -Wall -fno-warn-unused-do-bind   hs-source-dirs: hs    build-depends:       base >=3 && < 5     , dbus-core >= 0.8 && < 0.9-    , containers-    , text+    , containers >= 0.1 && < 0.4+    , text >= 0.7 && < 0.8+    , transformers >= 0.2 && < 0.3+    , monads-tf >= 0.1 && < 0.2    exposed-modules:     DBus.Client

@@ -1,662 +0,0 @@--% 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}

@@ -1,457 +1,491 @@-{--  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/>.--}-+-- 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/>. {-# LANGUAGE OverloadedStrings #-}-module DBus.Client-        (   -- * Clients-            Client-          , clientName--          , mkClient--            -- ** Sending messages-          , call-          , callBlocking-          , callBlocking_--            -- *** Emitting signals-          , emitSignal--            -- * Name reservation-          , requestName-          , releaseName--            -- * Receiving signals-          , onSignal--            -- * Remote objects and proxies-          , RemoteObject (..)-          , Proxy (..)--          , callProxy-          , callProxyBlocking-          , callProxyBlocking_--          , onSignalFrom--            -- * Exporting local objects-          , LocalObject (..)-          , Interface (..)-          , Member (..)-          , export--            -- ** Responding to method calls-          , MethodCall (..)-          , replyReturn-          , replyError+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TypeFamilies #-}+module DBus.Client (+	  module DBus.Bus+	, module DBus.Types+	, module DBus.Message+	  -- * Clients+	, Client+	, C.Connection+	, clientName+	, newClient+	, DBus+	, DBusException+	, runDBus+	, getClient+	, processMessage+	, send+	, send_+	, receive+	, mainLoop+	, call+	, callBlocking+	, callBlocking_+	-- * Handling signals+	, onSignal+	-- * Name reservation+	, NR.RequestNameFlag (..)+	, NR.RequestNameReply (..)+	, NR.ReleaseNameReply (..)+	, requestName+	, releaseName+	, requestName_+	, releaseName_+	  -- * Exporting local objects+	, Object (..)+	, Interface (..)+	, Member (..)+	, Method (..)+	, export+	, object+	, interface+	, method+	  -- ** Responding to method calls+	, MethodCtx (..)+	, replyReturn+	, replyError+	, Proxy (..)+	, callProxy+	, callProxyBlocking+	, callProxyBlocking_+	, onProxySignal+	) where+import DBus.Bus+import DBus.Types+import DBus.Message -        ) where-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.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 Control.Concurrent (forkIO)-import Control.Monad (forever)-import qualified Data.Set as Set-import qualified DBus.Constants as Const-+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 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 ())-+import qualified Data.Set as Set+import Data.Monoid (mconcat) -- | '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])--clientConnection :: Client -> C.Connection-clientConnection (Client x _ _ _ _) = x--clientName :: Client -> T.BusName-clientName (Client _ x _ _ _) = x-+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 ()) -- | Create a new 'Client' from an open connection and bus name. The weird---- signature allows 'mkClient' to use the computations in "DBus.Bus"+-- signature allows @newClient@ to use the computations in "DBus.Bus" -- directly, without unpacking:--- +-- -- @--- client <- mkClient =<< getSessionBus+-- client <- newClient =<< '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-        forkIO $ forever (receiveMessages client)+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 } -        export client ("/") rootObject+instance Monad DBus where+	return = DBus . return+	(>>=) (DBus m) f = DBus $ m >>= unDBus . f -        return client+instance MIO.MonadIO DBus where+	liftIO = DBus . MIO.liftIO -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+instance Functor DBus where+	fmap = liftM -sendOnly_ :: M.Message a => Client -> a -> IO ()-sendOnly_ c = send_ c (const $ return ())+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)+-- | Run a DBus computation with the given client callbacks. Errors+-- encountered while running will be thrown as exceptions, using the+-- 'DBusException' type.+--+-- Use the 'E.MonadError' instance for 'DBus' to handle errors inside+-- the computation.+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+-- | Run message handlers with the received message. If any method reply+-- callbacks or signal handlers are found, they will be run in the current+-- thread.+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+-- | A wrapper around 'C.send'.+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++-- | A wrapper around 'C.send', which does not allow the message serial+-- to be recorded. This is a useful shortcut when sending messages which+-- are not expected to receive a reply.+send_ :: M.Message msg => msg -> DBus ()+send_ = send (const $ return ())+-- | A wrapper around 'C.receive'.+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+-- | Run in a loop forever, processing messages.+--+-- This is commonly run in a separate thread, ie+--+-- > client <- newClient =<< getSessionBus+-- > forkIO $ runDBus client mainLoop+mainLoop :: DBus ()+mainLoop = forever $ receive >>= processMessage -- | 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 ()---- | 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---- | 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--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 ()---- | 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---- | 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+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 ()+-- | Sends a method call, and then blocks until a reply is received. Use+-- this when the receive/process loop is running in a separate thread.+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 +-- | A variant of 'callBlocking', which throws an exception if the+-- remote client returns 'M.Error'.+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 -- | 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' :)--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---- | 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---- | 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---- | 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--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)+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-        = Method T.Signature T.Signature (MethodCall -> IO ())-        | Signal T.Signature-+	= MemberMethod Method+	| MemberSignal T.Signature+data Method = Method T.Signature T.Signature (MethodCtx -> DBus ()) -- | 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))--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+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 -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-                +interface :: [(T.MemberName, Member)] -> Interface+interface = Interface . Map.fromList +method :: T.Signature -- ^ Input signature+       -> T.Signature -- ^ Output signature+       -> (MethodCtx -> DBus ()) -- ^ Implementation+       -> 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]+	} -- | 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---- | 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-+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)+-- | As 'call', except that the proxy's information is used to+-- build the message.+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+-- | As 'callBlocking', except that the proxy's information is used+-- to build the message.+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+-- | As 'callBlocking_', except that the proxy's information is used+-- to build the message.+callProxyBlocking_ :: Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]+                   -> DBus M.MethodReturn+callProxyBlocking_ proxy name flags body =+	callBlocking_ $ buildMethodCall proxy name flags body+-- | As 'onSIgnal', except that the proxy's information is used+-- to build the match rule.+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)