% Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
% 
% This program is free software: you can redistribute it and/or modify
% it under the terms of the GNU General Public License as published by
% the Free Software Foundation, either version 3 of the License, or
% any later version.
% 
% This program is distributed in the hope that it will be useful,
% but WITHOUT ANY WARRANTY; without even the implied warranty of
% MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
% GNU General Public License for more details.
% 
% You should have received a copy of the GNU General Public License
% along with this program.  If not, see <http://www.gnu.org/licenses/>.

\documentclass[12pt]{article}

\usepackage{color}
\usepackage{hyperref}
\usepackage{noweb}

% Smaller margins
\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry}

% Remove boxes from hyperlinks
\hypersetup{
    colorlinks,
    linkcolor=blue,
}

\makeindex

\begin{document}

\addcontentsline{toc}{section}{Contents}
\tableofcontents

@
\section{Introduction}

This library provides a simplified, high-level interface for use by D-Bus
clients. It implements async operations, remote object proxies, and
local object exporting.

All source code is licensed under the terms of the GNU GPL v3 or later.

<<copyright>>=
{-
  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>
  
  This program is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  any later version.
  
  This program is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.
  
  You should have received a copy of the GNU General Public License
  along with this program.  If not, see <http://www.gnu.org/licenses/>.
-}


@
\section{Clients}

<<DBus/Client.hs>>=
<<copyright>>
{-# LANGUAGE OverloadedStrings #-}
module DBus.Client
	( <<exports>>
	) where
<<imports>>

<<imports>>=
import qualified Control.Concurrent.MVar as MV
import qualified Data.Map as Map
import qualified DBus.Connection as C
import qualified DBus.Constants as Const
import qualified DBus.Message as M
import qualified DBus.Types as T

<<DBus/Client.hs>>=
type Callback = (M.ReceivedMessage -> IO ())

data Client = Client C.Connection
	(MV.MVar (Map.Map M.Serial Callback))
	(MV.MVar (Map.Map T.ObjectPath Callback))
	(MV.MVar [Callback])

clientConnection :: Client -> C.Connection
clientConnection (Client x _ _ _) = x

<<exports>>=
  Client
, clientConnection

<<DBus/Client.hs>>=
mkClient :: IO (C.Connection, T.BusName) -> IO Client
mkClient getBus = do
	(c, _) <- getBus
	replies <- MV.newMVar Map.empty
	exports <- MV.newMVar Map.empty
	signals <- MV.newMVar []
	let client = Client c replies exports signals
	<<initialize client>>
	return client

<<exports>>=
, mkClient

<<DBus/Client.hs>>=
send' :: M.Message a => C.Connection -> (M.Serial -> IO b) -> a
      -> IO b
send' c f msg = C.send c f msg >>= \result -> case result of
	Left x -> error $ show x
	Right x -> return x

@
\section{Name reservation}

@ A client can request a ``well-known'' name from the bus. This allows
messages sent to that name to be received by the client, without senders
being aware of which application is actually handling requests.

<<DBus/Client.hs>>=
data RequestNameFlag
	= AllowReplacement
	| ReplaceExisting
	| DoNotQueue
	deriving (Show)

<<DBus/Client.hs>>=
data RequestNameReply
	= PrimaryOwner
	| InQueue
	| Exists
	| AlreadyOwner
	deriving (Show)

<<DBus/Client.hs>>=
data ReleaseNameReply
	= Released
	| NonExistent
	| NotOwner
	deriving (Show)

<<exports>>=
, RequestNameFlag (..)
, RequestNameReply (..)
, ReleaseNameReply (..)

@ All name requests are handled by the main bus service, which has names
provided by the {\tt DBus.Constants} module.

<<DBus/Client.hs>>=
dbus :: Proxy
dbus = Proxy (RemoteObject Const.dbusName Const.dbusPath) Const.dbusInterface

@ There are only two methods of interest here, {\tt RequestName} and
{\tt ReleaseName}.

<<DBus/Client.hs>>=
request, release :: T.MemberName
request = T.mkMemberName' "RequestName"
release = T.mkMemberName' "ReleaseName"

@ A name may be requested for any client, using the given flags. The bus's
reply will be returned, or an exception raised if the reply was invalid.

<<DBus/Client.hs>>=
requestName :: Client -> T.BusName -> [RequestNameFlag] -> IO RequestNameReply
requestName client name flags = do
	returned <- callBlocking client dbus request []
		[ T.toVariant name
		, T.toVariant . encodeFlags $ flags]
	
	let reply = M.messageBody returned !! 0
	case decodeRequestReply =<< T.fromVariant reply of
		Just x  -> return x
		Nothing -> error $ "Unknown request name reply: " ++
		                   show reply

<<exports>>=
, requestName

@ Releasing a name is similar, except there's no flags for releasing a name.

<<DBus/Client.hs>>=
releaseName :: Client -> T.BusName -> IO ReleaseNameReply
releaseName client name = do
	returned <- callBlocking client dbus release [] [T.toVariant name]
	
	let reply = M.messageBody returned !! 0
	case decodeReleaseReply =<< T.fromVariant reply of
		Just x  -> return x
		Nothing -> error $ "Unknown release name reply: " ++
		                   show reply

<<exports>>=
, releaseName

<<imports>>=
import Data.Word (Word32)
import Data.Bits ((.|.))

<<DBus/Client.hs>>=
encodeFlags :: [RequestNameFlag] -> Word32
encodeFlags = foldr (.|.) 0 . map flagValue where
	flagValue AllowReplacement = 0x1
	flagValue ReplaceExisting  = 0x2
	flagValue DoNotQueue       = 0x4

<<DBus/Client.hs>>=
decodeRequestReply :: Word32 -> Maybe RequestNameReply
decodeRequestReply 1 = Just PrimaryOwner
decodeRequestReply 2 = Just InQueue
decodeRequestReply 3 = Just Exists
decodeRequestReply 4 = Just AlreadyOwner
decodeRequestReply _ = Nothing

<<DBus/Client.hs>>=
decodeReleaseReply :: Word32 -> Maybe ReleaseNameReply
decodeReleaseReply 1 = Just Released
decodeReleaseReply 2 = Just NonExistent
decodeReleaseReply 3 = Just NotOwner
decodeReleaseReply _ = Nothing

@
\section{Receiving messages}

Each client runs a separate thread for receiving messages, and every callback
is called in a separate thread. This allows callbacks to perform long
computations without blocking receipt of other messages.

<<imports>>=
import Control.Concurrent (forkIO)
import Control.Monad (forever)
import qualified Data.Set as Set

<<initialize client>>=
forkIO $ forever (receiveMessages client)

<<DBus/Client.hs>>=
receiveMessages :: Client -> IO ()
receiveMessages client@(Client c _ _ _) = do
	received <- C.receive c
	msg <- case received of
		Left x -> error $ show x
		Right x -> return x
	case msg of
		(M.ReceivedMethodCall   _ _ _   ) -> gotMethodCall client msg
		(M.ReceivedMethodReturn _ _ msg') -> gotReply client (M.methodReturnSerial msg') msg
		(M.ReceivedError        _ _ msg') -> gotReply client (M.errorSerial msg') msg
		(M.ReceivedSignal       _ _ _   ) -> gotSignal client msg
		_                                 -> return ()

<<DBus/Client.hs>>=
gotMethodCall :: Client -> M.ReceivedMessage -> IO ()
gotMethodCall client@(Client _ _ mvar _) msg = do
	objects <- MV.readMVar mvar
	let M.ReceivedMethodCall _ _ call' = msg
	case Map.lookup (M.methodCallPath call') objects of
		Just x  -> x msg
		Nothing -> unknownMethod client msg

<<DBus/Client.hs>>=
unknownMethod :: Client -> M.ReceivedMessage -> IO ()
unknownMethod client msg = send' c (const $ return ()) errorMsg where
	M.ReceivedMethodCall serial sender _ = msg
	c = clientConnection client
	errorMsg = M.Error
		Const.errorUnknownMethod
		serial sender
		(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
		[]

@ Method returns and errors both have a serial attached, which is used to
find the proper callback. If the callback cannot be found, no action will
be taken.

<<imports>>=
import Data.Maybe (isJust, fromJust, isNothing)

<<DBus/Client.hs>>=
gotReply :: Client -> M.Serial -> M.ReceivedMessage -> IO ()
gotReply (Client _ mvar _ _) serial msg = do
	callback <- MV.modifyMVar mvar $ \callbacks -> let
		x = Map.lookup serial callbacks
		callbacks' = if isJust x
			then Map.delete serial callbacks
			else callbacks
		in return (callbacks', x)
	case callback of
		Just x -> forkIO (x msg) >> return ()
		Nothing -> return ()

<<DBus/Client.hs>>=
gotSignal :: Client -> M.ReceivedMessage -> IO ()
gotSignal (Client _ _ _ mvar) msg = MV.withMVar mvar $
	mapM_ (\cb -> forkIO (cb msg))

@ \subsection{Signals}

<<DBus/Client.hs>>=
onSignal :: Client
            -> (T.BusName -> M.Signal -> Bool)
            -> (T.BusName -> M.Signal -> IO ())
            -> IO ()
onSignal (Client _ _ _ mvar) test callback = MV.modifyMVar_ mvar addCallback where
	addCallback callbacks = return $ callback' : callbacks
	callback' (M.ReceivedSignal _ sender msg) =
		if test (fromJust sender) msg
			then callback (fromJust sender) msg
			else return ()
	callback' _ = undefined

<<DBus/Client.hs>>=
signalFilter :: Maybe T.BusName -> Maybe T.ObjectPath -> Maybe T.InterfaceName
             -> Maybe T.MemberName -> T.BusName -> M.Signal -> Bool
signalFilter sender path iface member sender' msg = all id
	[ isNothing sender || sender == Just sender'
	, isNothing path   || path == Just (M.signalPath msg)
	, isNothing iface  || iface == Just (M.signalInterface msg)
	, isNothing member || member == Just (M.signalMember msg)
	]

<<exports>>=
, onSignal
, signalFilter

@
\section{Remote object proxies}

<<exports>>=
, RemoteObject (..)
, Proxy (..)
, call
, callBlocking
, onSignalFrom

<<DBus/Client.hs>>=
data RemoteObject = RemoteObject T.BusName T.ObjectPath
data Proxy = Proxy RemoteObject T.InterfaceName

@ \subsection{Method calls}

<<DBus/Client.hs>>=
call :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
     -> (M.Error -> IO ())
     -> (M.MethodReturn -> IO ())
     -> IO ()
call client proxy name flags body onError onReturn = let
	Proxy (RemoteObject dest path) iface = proxy
	Client bus mvar _ _ = client
	msg = M.MethodCall path name (Just iface) (Just dest)
		(Set.fromList flags)
		body
	
	callback (M.ReceivedError _ _ z) = onError z
	callback (M.ReceivedMethodReturn _ _ z) = onReturn z
	callback _ = undefined
	
	addCallback s = MV.modifyMVar_ mvar $ \callbacks ->
		return $ Map.insert s callback callbacks
	in send' bus addCallback msg

<<DBus/Client.hs>>=
callBlocking :: Client -> Proxy -> T.MemberName -> [M.Flag] -> [T.Variant]
             -> IO M.MethodReturn
callBlocking client proxy name flags body = do
	mvar <- MV.newEmptyMVar
	call client proxy name flags body
		(MV.putMVar mvar . Left)
		(MV.putMVar mvar . Right)
	reply <- MV.takeMVar mvar
	case reply of
		Left x  -> error (show x)
		Right x -> return x

@ \subsection{Signals}

<<DBus/Client.hs>>=
onSignalFrom :: Client -> Proxy -> T.MemberName -> (M.Signal -> IO ())
             -> IO ()
onSignalFrom client proxy member io = onSignal client test io' where
	Proxy (RemoteObject dest path) iface = proxy
	test = signalFilter (Just dest) (Just path) (Just iface)
	                    (Just member)
	io' _ msg = io msg

@
\section{Exporting local objects}

<<imports>>=
import qualified DBus.Introspection as I

<<initialize client>>=
export client (T.mkObjectPath' "/") rootObject

<<DBus/Client.hs>>=
rootObject :: LocalObject
rootObject = LocalObject $ Map.fromList [(ifaceName, interface)] where
	ifaceName = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
	memberName = T.mkMemberName' "Introspect"
	inSig = T.mkSignature' ""
	outSig = T.mkSignature' "s"
	interface = Interface $ Map.fromList [(memberName, impl)]
	
	method = I.Method memberName [] [I.Parameter "xml" outSig]
	iface = I.Interface ifaceName [method] [] []
	path = T.mkObjectPath' "/"
	
	impl = Method inSig outSig $ \call' -> do
		let Client _ _ mvar _ = methodCallClient call'
		paths <- fmap Map.keys $ MV.readMVar mvar
		
		let paths' = filter (/= path) paths
		let Just xml = I.toXML $ I.Object path [iface]
			[I.Object p [] [] | p <- paths']
		replyReturn call' [T.toVariant xml]

<<exports>>=
, LocalObject (..)
, Member (..)
, Interface (..)
, MethodCall (..)
, export

<<imports>>=
import qualified Data.Text.Lazy as TL

<<DBus/Client.hs>>=
newtype LocalObject = LocalObject (Map.Map T.InterfaceName Interface)
newtype Interface = Interface (Map.Map T.MemberName Member)
data Member
	= Method T.Signature T.Signature (MethodCall -> IO ())
	| Signal T.Signature

<<DBus/Client.hs>>=
export :: Client -> T.ObjectPath -> LocalObject -> IO ()
export client@(Client _ _ mvar _) path obj = MV.modifyMVar_ mvar $
	return . Map.insert path (onMethodCall client (addIntrospectable path obj))

<<DBus/Client.hs>>=
addIntrospectable :: T.ObjectPath -> LocalObject -> LocalObject
addIntrospectable path (LocalObject ifaces) = LocalObject ifaces' where
	ifaces' = Map.insertWith (\_ x -> x) name iface ifaces
	name = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"
	iface = Interface $ Map.fromList [(T.mkMemberName' "Introspect", impl)]
	impl = Method (T.mkSignature' "") (T.mkSignature' "s") $ \call' -> do
		let Just xml = I.toXML . introspect path . methodCallObject $ call'
		replyReturn call' [T.toVariant xml]

<<DBus/Client.hs>>=
introspect :: T.ObjectPath -> LocalObject -> I.Object
introspect path obj = I.Object path interfaces [] where
	LocalObject ifaceMap = obj
	interfaces = map introspectIface (Map.toList ifaceMap)
	
	introspectIface :: (T.InterfaceName, Interface) -> I.Interface
	introspectIface (name, iface) = I.Interface name methods signals [] where
		Interface memberMap = iface
		members = Map.toList memberMap
		methods = concatMap introspectMethod members
		signals = concatMap introspectSignal members
	
	introspectMethod :: (T.MemberName, Member) -> [I.Method]
	introspectMethod (name, (Method inSig outSig _)) = [I.Method name
		(map introspectParam (T.signatureTypes inSig))
		(map introspectParam (T.signatureTypes outSig))]
	introspectMethod _ = []
	
	introspectSignal :: (T.MemberName, Member) -> [I.Signal]
	introspectSignal (name, (Signal sig)) = [I.Signal name
		(map introspectParam (T.signatureTypes sig))]
	introspectSignal _ = []
	
	introspectParam = I.Parameter "" . T.mkSignature' . T.typeCode

@ \subsection{Responding to method calls}

<<DBus/Client.hs>>=
data MethodCall = MethodCall
	{ methodCallObject :: LocalObject
	, methodCallClient :: Client
	, methodCallMethod :: Member
	, methodCallSerial :: M.Serial
	, methodCallSender :: Maybe T.BusName
	, methodCallFlags  :: Set.Set M.Flag
	, methodCallBody   :: [T.Variant]
	}

@ Technically method calls don't have to specify an interface if there's only
one available in the destination object, but that'll never be the case here,
so treat an unspecified interface as unknown.

<<DBus/Client.hs>>=
findMember :: M.MethodCall -> LocalObject -> Maybe Member
findMember call' (LocalObject ifaces) = do
	iface <- M.methodCallInterface call'
	Interface members <- Map.lookup iface ifaces
	Map.lookup (M.methodCallMember call') members

<<DBus/Client.hs>>=
onMethodCall :: Client -> LocalObject -> M.ReceivedMessage -> IO ()
onMethodCall client obj msg = do
	let M.ReceivedMethodCall serial sender call' = msg
	    sigStr = TL.concat . map (T.typeCode . T.variantType)
	                       . M.methodCallBody $ call'
	    sig = T.mkSignature' sigStr
	
	case findMember call' obj of
		Just method@(Method inSig _ x) -> let
			call'' = MethodCall obj client method
				serial sender
				(M.methodCallFlags call')
				(M.methodCallBody call')
			invalidArgs = replyError call'' Const.errorInvalidArgs []
			in if inSig == sig
				then x call''
				else invalidArgs
		_               -> unknownMethod client msg
		

<<DBus/Client.hs>>=
replyReturn :: MethodCall -> [T.Variant] -> IO ()
replyReturn call' body = reply where
	c = clientConnection . methodCallClient $ call'
	replyInvalid = M.Error
		Const.errorFailed
		(methodCallSerial call')
		(methodCallSender call')
		(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
		[T.toVariant $ TL.pack "Method return didn't match signature."]
	
	replyValid = M.MethodReturn
		(methodCallSerial call')
		(methodCallSender call')
		(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
		body
	
	sendReply :: M.Message a => a -> IO ()
	sendReply = send' c (const $ return ())
	
	sigStr = TL.concat . map (T.typeCode . T.variantType) $ body
	(Method _ outSig _) = methodCallMethod call'
	reply = if T.mkSignature sigStr == Just outSig
		then sendReply replyValid
		else sendReply replyInvalid

<<DBus/Client.hs>>=
replyError :: MethodCall -> T.ErrorName -> [T.Variant] -> IO ()
replyError call' name body = send' c (const $ return ()) reply where
	c = clientConnection . methodCallClient $ call'
	reply = M.Error
		name
		(methodCallSerial call')
		(methodCallSender call')
		(Set.fromList [M.NoReplyExpected, M.NoAutoStart])
		body

<<exports>>=
, replyReturn
, replyError

@ \end{document}