% 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}