dbus-core 0.4 → 0.5

raw patch · 47 files changed

+6686/−4419 lines, 47 filesdep +HaXmldep +QuickCheckdep +prettydep −utf8-stringnew-component:exe:testsPVP ok

version bump matches the API change (PVP)

Dependencies added: HaXml, QuickCheck, pretty, test-framework, test-framework-quickcheck2, text

Dependencies removed: utf8-string

API changes (from Hackage documentation)

Files

• DBus/Address.lhs +0/−137
• DBus/Authentication.lhs +0/−70
• DBus/Bus.lhs +0/−131
• DBus/Connection.lhs +0/−237
• DBus/Constants.lhs +0/−271
• DBus/Marshal.lhs +0/−242
• DBus/Message.lhs +0/−536
• DBus/Padding.lhs +0/−59
• DBus/Types.lhs +0/−47
• DBus/Types/Atom.lhs +0/−108
• DBus/Types/Containers.lhs +0/−49
• DBus/Types/Containers/Array.lhs +0/−84
• DBus/Types/Containers/Dictionary.lhs +0/−110
• DBus/Types/Containers/Structure.lhs +0/−48
• DBus/Types/Containers/Variant.lhs +0/−186
• DBus/Types/Endianness.lhs +0/−51
• DBus/Types/Names.lhs +0/−202
• DBus/Types/ObjectPath.lhs +0/−62
• DBus/Types/Serial.lhs +0/−58
• DBus/Types/Signature.lhs +0/−157
• DBus/Unmarshal.lhs +0/−312
• DBus/Util.lhs +0/−61
• Examples/dbus-monitor.hs +47/−38
• Makefile +38/−0
• Tests.hs +0/−40
• Tests.nw +682/−0
• Tests/Address.hs +0/−107
• Tests/Containers.hs +0/−223
• Tests/Instances.hs +0/−289
• Tests/Marshal.hs +0/−60
• Tests/Messages.hs +0/−131
• Tests/MiscTypes.hs +0/−168
• Tests/Signature.hs +0/−64
• dbus-core.cabal +43/−21
• dbus-core.nw +3085/−0
• dbus-core.tex +0/−60
• hs/DBus/Address.hs +83/−0
• hs/DBus/Bus.hs +112/−0
• hs/DBus/Connection.hs +172/−0
• hs/DBus/Constants.hs +172/−0
• hs/DBus/Introspection.hs +265/−0
• hs/DBus/Message.hs +44/−0
• hs/DBus/Message/Internal.hs +174/−0
• hs/DBus/Types.hs +462/−0
• hs/DBus/Util.hs +44/−0
• hs/DBus/Wire.hs +649/−0
• hs/Tests.hs +614/−0

@@ -1,137 +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/>.--\ignore{-\begin{code}-module DBus.Address-	( Address-	, addressMethod-	, addressParameters-	, strAddress-	, parseAddresses-	) where--import Data.Char (ord, chr)-import qualified Data.Map as M-import Data.List (intercalate)-import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))-import DBus.Util (hexToInt, eitherToMaybe)-\end{code}-}--\clearpage-\section{Addresses}--\subsection{Address syntax}--A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}-where the method may be empty and parameters are optional. An address's-parameter list, if present, may end with a comma. Addresses in environment-variables are separated by semicolons, and the full address list may end-in a semicolon. Multiple parameters may have the same key; in this case,-only the first parameter for each key will be stored.--The bytes allowed in each component of the address are given by the following-chart, where each character is understood to be its ASCII value:--\begin{table}[h]-\begin{center}-\begin{tabular}{ll}-\toprule-Component   & Allowed Characters \\-\midrule-Method      & Any except {\tt `;'} and {\tt `:'} \\-Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\-Param value & {\tt `0'} to {\tt `9'} \\-            & {\tt `a'} to {\tt `z'} \\-            & {\tt `A'} to {\tt `Z'} \\-            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\-\bottomrule-\end{tabular}-\end{center}-\end{table}--In parameter values, any byte may be encoded by prepending the \% character-to its value in hexadecimal. \% is not allowed to appear unless it is-followed by two hexadecimal digits. Every other allowed byte is termed-an ``optionally encoded'' byte, and may appear unescaped in parameter-values.--\begin{code}-optionallyEncoded :: String-optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."-\end{code}--The address simply stores its method and parameter map, with a custom-{\tt Show} instance to provide easier debugging.--\begin{code}-data Address = Address-	{ addressMethod     :: String-	, addressParameters :: M.Map String String-	} deriving (Eq)--instance Show Address where-	showsPrec d x = showParen (d> 10) $-		showString' ["Address \"", strAddress x, "\""] where-		showString' = foldr (.) id . map showString-\end{code}--Parsing is straightforward; the input string is divided into addresses by-semicolons, then further by colons and commas. Parsing will fail if any-of the addresses in the input failed to parse.--\begin{code}-parseAddresses :: String -> Maybe [Address]-parseAddresses s = eitherToMaybe $ P.parse parser "" s where-	address = do-		method <- P.many (P.noneOf ":;")-		P.char ':'-		params <- P.sepEndBy param (P.char ',')-		return $ Address method (M.fromList params)-	-	param = do-		key <- P.many1 (P.noneOf "=;,")-		P.char '='-		value <- P.many1 (encodedValue <|> unencodedValue)-		return (key, value)-	-	parser = do-		as <- P.sepEndBy1 address (P.char ';')-		P.eof-		return as-	-	unencodedValue = P.oneOf optionallyEncoded-	encodedValue = do-		P.char '%'-		hex <- P.count 2 P.hexDigit-		return . chr . hexToInt $ hex-\end{code}--Converting an {\tt Address} back to a {\tt String} is just the reverse-operation. Note that because the original parameter order is not preserved,-the string produced might differ from the original input.--\begin{code}-strAddress :: Address -> String-strAddress (Address t ps) = t ++ ":" ++ ps' where-	ps' = intercalate "," $ do-		(k, v) <- M.toList ps-		[k ++ "=" ++ (v >>= encode)]-	encode c | elem c optionallyEncoded = [c]-	         | otherwise       = printf "%%%02X" (ord c)-\end{code}

@@ -1,70 +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/>.--\ignore{-\begin{code}-module DBus.Authentication (authenticate) where--import Data.Char (ord)-import Data.Word (Word32)-import Data.List (isPrefixOf)-import System.Posix.User (getRealUserID)-import Text.Printf (printf)-\end{code}-}--\section{Authentication}--\begin{code}-authenticate :: (String -> IO ()) -> (Word32 -> IO String)-                -> IO ()-authenticate put get = do-	put "\x00"-\end{code}--{\tt EXTERNAL} authentication is performed using the process's real user-ID, converted to a string, and then hex-encoded.--\begin{code}-	uid <- getRealUserID-	let authToken = concatMap (printf "%02X" . ord) (show uid)-	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"-\end{code}--If authentication was successful, the server responds with {\tt OK-<server GUID>}.  The GUID is intended to enable connection sharing, which-is currently unimplemented, so it's ignored.--\begin{code}-	response <- readUntil '\n' get-	if "OK" `isPrefixOf` response-		then put "BEGIN\r\n"-		else do-			putStrLn $ "response = " ++ show response-			error "Server rejected authentication token."-\end{code}--\begin{code}-readUntil :: Monad m => Char -> (Word32 -> m String) -> m String-readUntil = readUntil' ""--readUntil' :: Monad m => String -> Char -> (Word32 -> m String) -> m String-readUntil' xs c f = do-	[x] <- f 1-	let xs' = xs ++ [x]-	if x == c-		then return xs'-		else readUntil' xs' c f-\end{code}

@@ -1,131 +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/>.--\ignore{-\begin{code}-module DBus.Bus-	( getSystemBus-	, getSessionBus-	, getFirstBus-	, getBus-	) where--import qualified Control.Exception as E-import Control.Monad (when)-import Data.Maybe (fromJust, isNothing)-import qualified Data.Set as Set-import System.Environment (getEnv)--import qualified DBus.Address as A-import qualified DBus.Connection as C-import DBus.Constants (dbusName, dbusPath, dbusInterface)-import qualified DBus.Message as M-import qualified DBus.Types as T-\end{code}-}--\clearpage-\section{Connecting to a message bus}--Connecting to a message bus is a bit more involved than just connecting-over an app-to-app connection: the bus must be notified of the new client,-using a "hello message", before it will begin forwarding messages.--\begin{code}-getBus :: A.Address -> IO (C.Connection, T.BusName)-getBus addr = do-	c <- C.connect addr-	name <- sendHello c-	return (c, name)-\end{code}--Optionally, multiple addresses may be provided. The first successfully-connected bus will be returned.--\begin{code}-getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus as = getFirstBus' as as--getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName)-getFirstBus' orig     [] = E.throwIO $ C.NoWorkingAddress orig-getFirstBus' orig (a:as) = E.catch (getBus a) onError where-	onError :: E.SomeException -> IO (C.Connection, T.BusName)-	onError _ = getFirstBus' orig as-\end{code}--\subsection{Default connections}--Two default buses are defined, the ``system'' and ``session'' buses. The system-bus is global for the OS, while the session bus runs only for the duration-of the user's session.--\begin{code}-getSystemBus :: IO (C.Connection, T.BusName)-getSystemBus = getBus addr where-	systemBusPath = "unix:path=/var/run/dbus/system_bus_socket"-	Just [addr] = A.parseAddresses systemBusPath-\end{code}--\begin{code}-getSessionBus :: IO (C.Connection, T.BusName)-getSessionBus = do-	env <- getEnv "DBUS_SESSION_BUS_ADDRESS"-	-	case A.parseAddresses env of-		Just [x] -> getBus x-		Just  x  -> getFirstBus x-		_        -> E.throwIO $ C.InvalidAddress env-\end{code}--\subsection{Sending the ``hello'' message}--\begin{code}-hello :: M.MethodCall-hello = M.MethodCall dbusPath-	(T.mkMemberName' "Hello")-	(Just dbusInterface)-	(Just dbusName)-	Set.empty-	[]-\end{code}--\begin{code}-sendHello :: C.Connection -> IO T.BusName-sendHello c = do-	serial <- C.send c return hello-	reply <- waitForReply c serial-	let name = case M.methodReturnBody reply of-		[x] -> T.fromVariant x-		_   -> Nothing-	-	when (isNothing name)-		(E.throwIO . C.ProtocolException $-		 "Received inappropriate reply to Hello().")-	-	return . fromJust $ name-\end{code}--\begin{code}-waitForReply :: C.Connection -> T.Serial -> IO M.MethodReturn-waitForReply c serial = do-	msg <- C.receive c-	case msg of-		(M.ReceivedMethodReturn _ _ reply) ->-			if M.methodReturnSerial reply == serial-				then return reply-				else waitForReply c serial-		_ -> waitForReply c serial-\end{code}-

@@ -1,237 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Connection-	( Connection-	, ConnectionException (..)-	, ProtocolException (..)-	, connect-	, send-	, receive-	) where--import qualified Control.Concurrent as C-import qualified Control.Exception as E--import Data.Word (Word32)-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Lazy.UTF8 (toString, fromString)-import qualified Data.Map as Map-import Data.Typeable (Typeable)--import qualified Network as N-import qualified System.IO as I--import qualified DBus.Address as A-import qualified DBus.Types as T-import DBus.Message (Message, ReceivedMessage, marshal, unmarshal)-import DBus.Authentication (authenticate)-\end{code}-}--\clearpage-\section{Connections}--A {\tt Connection} is an opaque handle to an open DBus channel, with-an internal state for maintaining the current message serial.--\begin{code}-data Connection = Connection A.Address Transport (C.MVar T.Serial)-\end{code}--While not particularly useful for other functions, being able to {\tt show}-a {\tt Connection} is useful when debugging.--\begin{code}-instance Show Connection where-	showsPrec d (Connection a _ _) = showParen (d > 10) $-		showString' ["<connection \"", A.strAddress a, "\">"] where-		showString' = foldr (.) id . map showString-\end{code}--A connection can be opened to any valid address, though actually connecting-might fail due to external factors.--\begin{code}-connect :: A.Address -> IO Connection-connect a = do-	t <- connectTransport a-	let putS = transportSend t . fromString-	let getS = fmap toString . transportRecv t-	authenticate putS getS-	serialMVar <- C.newMVar T.firstSerial-	return $ Connection a t serialMVar-\end{code}--Sending a message will increment the connection's internal serial state.-The second parameter is present to allow registration of a callback before-the message has actually been sent, which avoids race conditions in-multi-threaded clients.--\begin{code}-send :: Message a => Connection -> (T.Serial -> IO b) -> a -> IO b-send (Connection _ t mvar) io msg = withSerial mvar $ \serial -> do-	x <- io serial-	transportSend t . marshal T.LittleEndian serial $ msg-	return x--withSerial :: C.MVar T.Serial -> (T.Serial -> IO a) -> IO a-withSerial m io = E.block $ do-	s <- C.takeMVar m-	let s' = T.nextSerial s-	x <- E.unblock (io s) `E.onException` C.putMVar m s'-	C.putMVar m s'-	return x-\end{code}--Messages are received wrapped in a {\tt ReceivedMessage} value. If an error-is encountered while unmarshaling, an exception will be thrown.--\begin{code}-receive :: Connection -> IO ReceivedMessage-receive (Connection _ t _) = do-	either' <- unmarshal $ transportRecv t-	case either' of-		Right x -> return x-		Left err -> E.throwIO . ProtocolException $ err-\end{code}--\section{Transports}--A transport is anything which can send and receive bytestrings, typically-over a socket.--\begin{code}-data Transport = Transport-	{ transportSend :: L.ByteString -> IO ()-	, transportRecv :: Word32 -> IO L.ByteString-	}-\end{code}--\begin{code}-connectTransport :: A.Address -> IO Transport-connectTransport a = transport' (A.addressMethod a) a where-	transport' "unix" = unix-	transport' _      = unknownTransport-\end{code}--\subsection{UNIX}--The {\sc unix} transport accepts two parameters: {\tt path}, which is a-simple filesystem path, and {\tt abstract}, which is a path in the-Linux-specific abstract domain. One, and only one, of these parameters must-be specified.--\begin{code}-unix :: A.Address -> IO Transport-unix a = handleTransport . N.connectTo "localhost" =<< port where-	params = A.addressParameters a-	path = Map.lookup "path" params-	abstract = Map.lookup "abstract" params-	-	tooMany = "Only one of `path' or `abstract' may be specified for the"-	          ++ " `unix' method."-	tooFew = "One of `path' or `abstract' must be specified for the"-	         ++ " `unix' transport."-	-	port = fmap N.UnixSocket path'-	path' = case (path, abstract) of-		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany-		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew-		(Just x, Nothing) -> return x-		(Nothing, Just x) -> return $ '\x00':x-\end{code}--\subsection{TCP}--known parameters:--\begin{itemize}-\item {\tt host} (optional, default "{\tt localhost}")-\item {\tt port}-\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}"-\end{itemize}--TCP support is TODO--\begin{otherCode}-tcp :: A.Address -> IO Transport-tcp a@(A.Address _ params) = handleTransport a connect' where-	host = lookup "host" params-	port = parsePort =<< lookup "post" params-	family = parseFamily =<< lookup "family" params-	connect' = do-		-- check host-		-- check port-		-- check family-		-- return handle-parsePort :: String -> Maybe PortNumber--parseFamily :: String -> Maybe Family-\end{otherCode}--\subsection{Generic handle-based transport}--Both UNIX and TCP are backed by standard handles, and can therefore use-a shared handle-based transport backend.--\begin{code}-handleTransport :: IO I.Handle -> IO Transport-handleTransport io = do-	h <- io-	I.hSetBuffering h I.NoBuffering-	I.hSetBinaryMode h True-	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)-\end{code}--\subsection{Unknown transports}--If a method has no known transport, attempting to connect using it will-just result in an exception.--\begin{code}-unknownTransport :: A.Address -> IO Transport-unknownTransport = E.throwIO . UnknownMethod-\end{code}--\subsection{Errors}--If connecting to DBus fails, a {\tt ConnectionException} will be thrown.-The constructor describes which exception occurred.--\begin{code}-data ConnectionException-	= InvalidAddress String-	| BadParameters A.Address String-	| UnknownMethod A.Address-	| NoWorkingAddress [A.Address]-	deriving (Show, Typeable)--instance E.Exception ConnectionException-\end{code}--If a message cannot be unmarshaled --- for example, due to malformed or-truncated input --- a {\tt ProtocolException} will be thrown.--\begin{code}-data ProtocolException = ProtocolException String-	deriving (Show, Typeable)--instance E.Exception ProtocolException-\end{code}-

@@ -1,271 +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/>.--\ignore{-\begin{code}-module DBus.Constants where-import qualified DBus.Types as T-import Data.Word (Word8)-\end{code}-}--\clearpage-\section{Constants}--\begin{code}-protocolVersion :: Word8-protocolVersion = 1-\end{code}--\subsection{Main bus location}--\begin{code}-dbusName :: T.BusName-dbusName = T.mkBusName' "org.freedesktop.DBus"-\end{code}--\begin{code}-dbusPath :: T.ObjectPath-dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"-\end{code}--\begin{code}-dbusInterface :: T.InterfaceName-dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"-\end{code}--\subsection{Other pre-defined interfaces}--\begin{code}-interfaceIntrospectable :: T.InterfaceName-interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"-\end{code}--\begin{code}-interfaceProperties :: T.InterfaceName-interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"-\end{code}--\begin{code}-interfacePeer :: T.InterfaceName-interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"-\end{code}--\subsection{Pre-defined error names}--\begin{code}-errorFailed :: T.ErrorName-errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"-\end{code}--\begin{code}-errorNoMemory :: T.ErrorName-errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"-\end{code}--\begin{code}-errorServiceUnknown :: T.ErrorName-errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"-\end{code}--\begin{code}-errorNameHasNoOwner :: T.ErrorName-errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"-\end{code}--\begin{code}-errorNoReply :: T.ErrorName-errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"-\end{code}--\begin{code}-errorIOError :: T.ErrorName-errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"-\end{code}--\begin{code}-errorBadAddress :: T.ErrorName-errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"-\end{code}--\begin{code}-errorNotSupported :: T.ErrorName-errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"-\end{code}--\begin{code}-errorLimitsExceeded :: T.ErrorName-errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"-\end{code}--\begin{code}-errorAccessDenied :: T.ErrorName-errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"-\end{code}--\begin{code}-errorAuthFailed :: T.ErrorName-errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"-\end{code}--\begin{code}-errorNoServer :: T.ErrorName-errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"-\end{code}--\begin{code}-errorTimeout :: T.ErrorName-errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"-\end{code}--\begin{code}-errorNoNetwork :: T.ErrorName-errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"-\end{code}--\begin{code}-errorAddressInUse :: T.ErrorName-errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"-\end{code}--\begin{code}-errorDisconnected :: T.ErrorName-errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"-\end{code}--\begin{code}-errorInvalidArgs :: T.ErrorName-errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"-\end{code}--\begin{code}-errorFileNotFound :: T.ErrorName-errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"-\end{code}--\begin{code}-errorFileExists :: T.ErrorName-errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"-\end{code}--\begin{code}-errorUnknownMethod :: T.ErrorName-errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"-\end{code}--\begin{code}-errorTimedOut :: T.ErrorName-errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"-\end{code}--\begin{code}-errorMatchRuleNotFound :: T.ErrorName-errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"-\end{code}--\begin{code}-errorMatchRuleInvalid :: T.ErrorName-errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"-\end{code}--\begin{code}-errorSpawnExecFailed :: T.ErrorName-errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"-\end{code}--\begin{code}-errorSpawnForkFailed :: T.ErrorName-errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"-\end{code}--\begin{code}-errorSpawnChildExited :: T.ErrorName-errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"-\end{code}--\begin{code}-errorSpawnChildSignaled :: T.ErrorName-errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"-\end{code}--\begin{code}-errorSpawnFailed :: T.ErrorName-errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"-\end{code}--\begin{code}-errorSpawnFailedToSetup :: T.ErrorName-errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"-\end{code}--\begin{code}-errorSpawnConfigInvalid :: T.ErrorName-errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"-\end{code}--\begin{code}-errorSpawnServiceNotValid :: T.ErrorName-errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"-\end{code}--\begin{code}-errorSpawnServiceNotFound :: T.ErrorName-errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"-\end{code}--\begin{code}-errorSpawnPermissionsInvalid :: T.ErrorName-errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"-\end{code}--\begin{code}-errorSpawnFileInvalid :: T.ErrorName-errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"-\end{code}--\begin{code}-errorSpawnNoMemory :: T.ErrorName-errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"-\end{code}--\begin{code}-errorUnixProcessIdUnknown :: T.ErrorName-errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"-\end{code}--\begin{code}-errorInvalidFileContent :: T.ErrorName-errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"-\end{code}--\begin{code}-errorSELinuxSecurityContextUnknown :: T.ErrorName-errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"-\end{code}--\begin{code}-errorAdtAuditDataUnknown :: T.ErrorName-errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"-\end{code}--\begin{code}-errorObjectPathInUse :: T.ErrorName-errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"-\end{code}--\begin{code}-errorInconsistentMessage :: T.ErrorName-errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"-\end{code}

@@ -1,242 +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/>.--\ignore{-\begin{code}-module DBus.Marshal (marshal) where--import Control.Arrow (first)-import Control.Monad (msum)-import qualified Control.Monad.State as S-import Data.Maybe (fromJust)-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Lazy.UTF8 (fromString)-import qualified Data.Binary.Put as P-import qualified Data.Binary.IEEE754 as IEEE--import DBus.Padding (padding, alignment)-import qualified DBus.Types as T-\end{code}-}--\clearpage-\section{Marshaling}-\subsection{\tt marshal}--\begin{code}-marshal :: T.Endianness -> [T.Variant] -> L.ByteString-marshal e vs = runMarshal (mapM_ marshalAny vs) e-\end{code}--\begin{code}-marshalAny :: T.Variant -> Marshal-marshalAny x = marshal' (T.variantType x) x where-	v :: T.Variable a => T.Variant -> a-	v = fromJust . T.fromVariant-	-	marshal'  T.BooleanT         = bool       . v-	marshal'  T.ByteT            = word8      . v-	marshal'  T.UInt16T          = word16     . v-	marshal'  T.UInt32T          = word32     . v-	marshal'  T.UInt64T          = word64     . v-	marshal'  T.Int16T           = int16      . v-	marshal'  T.Int32T           = int32      . v-	marshal'  T.Int64T           = int64      . v-	marshal'  T.DoubleT          = double     . v-	marshal'  T.StringT          = string     . v-	marshal'  T.ObjectPathT      = objectPath . v-	marshal'  T.SignatureT       = signature  . v-	marshal' (T.ArrayT _)        = array      . v-	marshal' (T.DictionaryT _ _) = dictionary . v-	marshal' (T.StructureT _)    = structure  . v-	marshal'  T.VariantT         = variant    . v-\end{code}--\subsection{Atoms}--\begin{code}-bool :: Bool -> Marshal-bool x = word32 (if x then 1 else 0)-\end{code}--\begin{code}-word8 :: Word8 -> Marshal-word8 x = append (L.pack [x])-\end{code}--\begin{code}-word16 :: Word16 -> Marshal-word16 = appendPut P.putWord16be-\end{code}--\begin{code}-word32 :: Word32 -> Marshal-word32 = appendPut P.putWord32be-\end{code}--\begin{code}-word64 :: Word64 -> Marshal-word64 = appendPut P.putWord64be-\end{code}--\begin{code}-int16 :: Int16 -> Marshal-int16 = appendPut P.putWord16be . fromIntegral-\end{code}--\begin{code}-int32 :: Int32 -> Marshal-int32 = appendPut P.putWord32be . fromIntegral-\end{code}--\begin{code}-int64 :: Int64 -> Marshal-int64 = appendPut P.putWord64be . fromIntegral-\end{code}--\begin{code}-double :: Double -> Marshal-double = appendPut IEEE.putFloat64be-\end{code}--\begin{code}-string :: String -> Marshal-string x = do-	let bytes = fromString x-	word32 . fromIntegral . L.length $ bytes-	append bytes-	append (L.pack [0])-\end{code}--\begin{code}-objectPath :: T.ObjectPath -> Marshal-objectPath = string . T.strObjectPath-\end{code}--\begin{code}-signature :: T.Signature -> Marshal-signature x = do-	let bytes = fromString . T.strSignature $ x-	word8 . fromIntegral . L.length $ bytes-	append bytes-	append (L.pack [0])-\end{code}--\subsection{Containers}--\subsubsection{Arrays}--Marshaling arrays is complicated, because the array body must be marshaled-\emph{first} to calculate the array length. This requires building a-temporary marshaler, to get the padding right.--\begin{code}-array :: T.Array -> Marshal-array x = do-	(arrayPadding, arrayBytes) <- getArrayBytes x-	word32 . fromIntegral . L.length $ arrayBytes-	append arrayPadding-	append arrayBytes-\end{code}--\begin{code}-getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString)-getArrayBytes x = do-	let vs = T.arrayItems x-	let [T.ArrayT itemType] = T.signatureTypes . T.arraySignature $ x-	s <- S.get-	(MarshalState _ afterLength) <- word32 0 >> S.get-	(MarshalState _ afterPadding) <- pad (alignment itemType) >> S.get-	(MarshalState _ afterItems) <- mapM_ marshalAny vs >> S.get-	-	let paddingBytes = L.drop (L.length afterLength) afterPadding-	let itemBytes = L.drop (L.length afterPadding) afterItems-	-	S.put s-	return (paddingBytes, itemBytes)-\end{code}--\subsubsection{Dictionaries}--\begin{code}-dictionary :: T.Dictionary -> Marshal-dictionary x = array x' where-	pairs = map (first T.atomToVariant) (T.dictionaryItems x)-	structs = [T.Structure [k,v] | (k,v) <- pairs]-	x' = fromJust . T.toArray $ structs-\end{code}--\subsubsection{Structures}--\begin{code}-structure :: T.Structure -> Marshal-structure (T.Structure xs) = pad 8 >> mapM_ marshalAny xs-\end{code}--\subsubsection{Variants}--\begin{code}-variant :: T.Variant -> Marshal-variant x = signature (T.variantSignature x) >> marshalAny x-\end{code}--\subsection{The {\tt Marshal} monad}--{\tt Marshal} implements stateful marshaling, which is required for padding-to be calculated properly.--\begin{code}-data MarshalState = MarshalState T.Endianness L.ByteString-type MarshalM = S.State MarshalState-type Marshal = MarshalM ()-\end{code}--\begin{code}-runMarshal :: Marshal -> T.Endianness -> L.ByteString-runMarshal m e = bytes where-	initialState = MarshalState e L.empty-	(MarshalState _ bytes) = S.execState m initialState-\end{code}--\begin{code}-append :: L.ByteString -> Marshal-append bs = do-	(MarshalState e bs') <- S.get-	S.put $ MarshalState e (L.append bs' bs)-\end{code}--Add padding to the end of the marshaled bytes, until the length is a-multiple of {\tt count}.--\begin{code}-pad :: Word8 -> Marshal-pad count = do-	(MarshalState _ bytes) <- S.get-	let padding' = padding (fromIntegral . L.length $ bytes) count-	append $ L.replicate (fromIntegral padding') 0-\end{code}--\begin{code}-appendPut :: (a -> P.Put) -> a -> Marshal-appendPut put x = do-	let bytes = P.runPut $ put x-	(MarshalState e _) <- S.get-	pad . fromIntegral . L.length $ bytes-	append $ case e of-		T.BigEndian -> bytes-		T.LittleEndian -> L.reverse bytes-\end{code}

@@ -1,536 +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/>.--\ignore{-\begin{code}-module DBus.Message-	( -- * Message structure and fields-	  Message (..)-	, Flag (..)-	, HeaderField (..)-	-	  -- * Message types-	  -- ** Method calls-	, MethodCall (..)-	-	  -- ** Method returns-	, MethodReturn (..)-	-	  -- ** Errors-	, Error (..)-	-	  -- ** Signals-	, Signal (..)-	-	  -- * Received messages-	, ReceivedMessage (..)-	, receivedSerial-	, receivedSender-	-	  -- * (Un)marshaling-	, marshal-	, unmarshal-	) where--import Control.Monad (unless)-import qualified Control.Monad.Error as E-import Data.Bits ((.|.), (.&.))-import Data.Word (Word8, Word32)-import qualified Data.ByteString.Lazy as L-import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe)-import qualified Data.Set as S--import qualified DBus.Marshal as M-import qualified DBus.Unmarshal as U-import DBus.Padding (padding)-import qualified DBus.Types as T-import DBus.Constants (protocolVersion)-\end{code}-}--\clearpage-\section{Messages}--A message represents a single message, with a header and body. Some parts-of the header, such as the serial, endianness, and body length, are not-included in the message --- instead, they are generated when a message is-marshalled.--\begin{code}-class Message a where-	messageTypeCode     :: a -> Word8-	messageHeaderFields :: a -> [HeaderField]-	messageFlags        :: a -> S.Set Flag-	messageBody         :: a -> [T.Variant]-\end{code}--\subsection{Flags}--Flags are represented as the integral value of each flag OR'd into a single-byte.--The instance of {\tt Ord} only exists for storing flags in a set. Flags have-no inherent ordering.--\begin{code}-data Flag = NoReplyExpected-          | NoAutoStart-	deriving (Show, Eq, Ord)-\end{code}--\begin{code}-encodeFlags :: [Flag] -> Word8-encodeFlags flags = foldr (.|.) 0 $ map flagValue flags where-	flagValue NoReplyExpected = 0x1-	flagValue NoAutoStart     = 0x2-\end{code}--\begin{code}-decodeFlags :: Word8 -> [Flag]-decodeFlags flagsByte = flags where-	flagSet = [(0x1, NoReplyExpected), (0x2, NoAutoStart)]-	flags = flagSet >>= \(x, y) -> [y | flagsByte .&. x > 0]-\end{code}--\subsection{Header fields}--\begin{code}-data HeaderField-	= Path        T.ObjectPath-	| Interface   T.InterfaceName-	| Member      T.MemberName-	| ErrorName   T.ErrorName-	| ReplySerial T.Serial-	| Destination T.BusName-	| Sender      T.BusName-	| Signature   T.Signature-	deriving (Show, Eq)-\end{code}--\begin{code}-header' :: T.Variable a => Word8 -> a -> T.Variant-header' code x = T.toVariant $ T.Structure-	[ T.toVariant code-	, T.toVariant $ T.toVariant x-	]--unheader :: T.Variant -> Maybe (Word8, T.Variant)-unheader structV = do-	struct <- T.fromVariant structV-	(c, v) <- case struct of-		T.Structure [x, y] -> return  (x, y)-		_                  -> Nothing-	c' <- T.fromVariant c-	v' <- T.fromVariant v-	return (c', v')--instance T.Variable HeaderField where-	defaultSignature _ = T.mkSignature' "(yv)"-	-	toVariant (Path x)        = header' 1 x-	toVariant (Interface x)   = header' 2 x-	toVariant (Member x)      = header' 3 x-	toVariant (ErrorName x)   = header' 4 x-	toVariant (ReplySerial x) = header' 5 x-	toVariant (Destination x) = header' 6 x-	toVariant (Sender x)      = header' 7 x-	toVariant (Signature x)   = header' 8 x-	-	fromVariant v = unheader v >>= \v' -> case v' of-		(1, x) -> fmap Path        $ T.fromVariant x-		(2, x) -> fmap Interface   $ T.fromVariant x-		(3, x) -> fmap Member      $ T.fromVariant x-		(4, x) -> fmap ErrorName   $ T.fromVariant x-		(5, x) -> fmap ReplySerial $ T.fromVariant x-		(6, x) -> fmap Destination $ T.fromVariant x-		(7, x) -> fmap Sender      $ T.fromVariant x-		(8, x) -> fmap Signature   $ T.fromVariant x-		_      -> Nothing-\end{code}--\subsection{Message types}--\subsubsection{Method calls}--\begin{code}-data MethodCall = MethodCall-	{ methodCallPath        :: T.ObjectPath-	, methodCallMember      :: T.MemberName-	, methodCallInterface   :: Maybe T.InterfaceName-	, methodCallDestination :: Maybe T.BusName-	, methodCallFlags       :: S.Set Flag-	, methodCallBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodCall where-	messageTypeCode _ = 1-	messageFlags      = methodCallFlags-	messageBody       = methodCallBody-	messageHeaderFields m = concat-		[ [ Path    $ methodCallPath m-		  ,  Member $ methodCallMember m-		  ]-		, maybe' Interface . methodCallInterface $ m-		, maybe' Destination . methodCallDestination $ m-		]-\end{code}--\subsubsection{Method returns}--\begin{code}-data MethodReturn = MethodReturn-	{ methodReturnSerial      :: T.Serial-	, methodReturnDestination :: Maybe T.BusName-	, methodReturnFlags       :: S.Set Flag-	, methodReturnBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message MethodReturn where-	messageTypeCode _ = 2-	messageFlags      = methodReturnFlags-	messageBody       = methodReturnBody-	messageHeaderFields m = concat-		[ [ ReplySerial $ methodReturnSerial m-		  ]-		, maybe' Destination . methodReturnDestination $ m-		]-\end{code}--\subsubsection{Errors}--\begin{code}-data Error = Error-	{ errorName        :: T.ErrorName-	, errorSerial      :: T.Serial-	, errorDestination :: Maybe T.BusName-	, errorFlags       :: S.Set Flag-	, errorBody        :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Error where-	messageTypeCode _ = 3-	messageFlags      = errorFlags-	messageBody       = errorBody-	messageHeaderFields m = concat-		[ [ ErrorName   $ errorName m-		  , ReplySerial $ errorSerial m-		  ]-		, maybe' Destination . errorDestination $ m-		]-\end{code}--\subsubsection{Signals}--\begin{code}-data Signal = Signal-	{ signalPath      :: T.ObjectPath-	, signalMember    :: T.MemberName-	, signalInterface :: T.InterfaceName-	, signalFlags     :: S.Set Flag-	, signalBody      :: [T.Variant]-	}-	deriving (Show, Eq)--instance Message Signal where-	messageTypeCode _ = 4-	messageFlags      = signalFlags-	messageBody       = signalBody-	messageHeaderFields m =-		[ Path      $ signalPath m-		, Member    $ signalMember m-		, Interface $ signalInterface m-		]-\end{code}--\begin{code}-maybe' :: (a -> b) -> Maybe a -> [b]-maybe' f = maybe [] (\x' -> [f x'])-\end{code}--\subsection{Message headers}--\begin{code}-data MessageHeader = MessageHeader-	{ headerEndianness :: T.Endianness-	, headerTypeCode   :: Word8-	, headerFlags      :: S.Set Flag-	, headerProtocol   :: Word8-	, headerBodySize   :: Word32-	, headerSerial     :: T.Serial-	, headerFields     :: [HeaderField]-	} deriving (Show, Eq)-\end{code}--\begin{code}-buildHeader :: Message a => T.Endianness -> T.Serial -> a -> Word32-               -> MessageHeader-buildHeader endianness serial m bodyLen = header where-	ts = map T.variantType $ messageBody m-	bodySig = T.mkSignature' $ concatMap T.typeString ts-	fields = Signature bodySig : messageHeaderFields m-	header = MessageHeader-		endianness-		(messageTypeCode m)-		(messageFlags m)-		protocolVersion-		bodyLen-		serial-		fields-\end{code}--\subsection{Marshaling}--{\tt marshal} converts a message into a byte string, suitable for sending-over the bus.--\begin{code}-marshal :: Message a => T.Endianness -> T.Serial -> a -> L.ByteString-marshal e s m = L.append headerBytes bodyBytes where-	bodyBytes = M.marshal e $ messageBody m-	bodyLength = fromIntegral . L.length $ bodyBytes-	header = marshalHeader (buildHeader e s m bodyLength)-	headerBytes = M.marshal e $ header ++ [T.toVariant (T.Structure [])]-\end{code}--Build the header struct for a message. Endianness, the serial, and body-length are provided.--\begin{code}-marshalHeader :: MessageHeader -> [T.Variant]-marshalHeader h = map ($ h)-	[ T.toVariant . headerEndianness-	, T.toVariant . headerTypeCode-	, T.toVariant . encodeFlags . S.toList . headerFlags-	, T.toVariant . headerProtocol-	, T.toVariant . headerBodySize-	, T.toVariant . headerSerial-	, T.toVariant . fromJust . T.toArray . headerFields-	]-\end{code}--\subsection{Unmarshaling}--\subsubsection{Received messages}--Any messages parsed from the connection are stored in a-{\tt ReceivedMessage} value, so clients can know which type of message-was received, where it was sent from, and its serial.--Unknown message types are parsed, but only to get the serial and bus name-(which might be useful for returning an {\tt Error}). Clients should ignore-unknown messages.--\begin{code}-data ReceivedMessage-	= ReceivedMethodCall   T.Serial (Maybe T.BusName) MethodCall-	| ReceivedMethodReturn T.Serial (Maybe T.BusName) MethodReturn-	| ReceivedError        T.Serial (Maybe T.BusName) Error-	| ReceivedSignal       T.Serial (Maybe T.BusName) Signal-	| ReceivedUnknown      T.Serial (Maybe T.BusName)-	deriving (Show, Eq)--receivedSerial :: ReceivedMessage -> T.Serial-receivedSerial (ReceivedMethodCall   s _ _) = s-receivedSerial (ReceivedMethodReturn s _ _) = s-receivedSerial (ReceivedError        s _ _) = s-receivedSerial (ReceivedSignal       s _ _) = s-receivedSerial (ReceivedUnknown      s _) = s--receivedSender :: ReceivedMessage -> Maybe T.BusName-receivedSender (ReceivedMethodCall   _ s _) = s-receivedSender (ReceivedMethodReturn _ s _) = s-receivedSender (ReceivedError        _ s _) = s-receivedSender (ReceivedSignal       _ s _) = s-receivedSender (ReceivedUnknown      _ s) = s-\end{code}--Unmarshaling is a three-step process: retrieve the raw bytes, parse the-header, then parse the body. With the header and body, it is possible to-construct a {\tt ReceivedMessage} of the proper type and attributes.--\begin{code}-unmarshal :: Monad m => (Word32 -> m L.ByteString)-          -> m (Either String ReceivedMessage)-unmarshal getBytes = E.runErrorT $ do-	(endianness, headerBytes, bodyBytes) <- getRaw $ E.lift . getBytes-	header <- parseHeader endianness headerBytes-	let signature = findBodySignature . headerFields $ header-	body <- U.unmarshal endianness signature bodyBytes-	-	mkReceived-		(headerTypeCode header)-		(headerSerial header)-		(headerFields header)-		(headerFlags header)-		body-\end{code}--First, some minimal parsing is required to retrieve the full byte buffer-from the input. This depends on the fixed structure of the message header to-pull in every required byte without fully parsing the header fields.--\begin{code}-type RawMessage = (T.Endianness, L.ByteString, L.ByteString)-getRaw :: (E.Error e, E.MonadError e m) =>-          (Word32 -> m L.ByteString) -> m RawMessage-getRaw get = do-	let fixed'Sig = T.mkSignature' "yyyy"-	let fixedSig  = T.mkSignature' "yyyyuuu"-	-	-- Protocol version-	fixedBytes <- get 16-	fixed' <- U.unmarshal T.LittleEndian fixed'Sig fixedBytes-	checkMatchingVersion $ fixed' !! 3-	-	-- Endianness-	endianness <- getEndianness $ fixed' !! 0-	-	-- Header field bytes-	fixed <- U.unmarshal endianness fixedSig fixedBytes-	let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6-	fieldBytes <- get fieldByteCount-	-	-- Post-field padding-	let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-	get . fromIntegral $ bodyPadding-	-	-- Body bytes-	let bodyByteCount = fromJust . T.fromVariant $ fixed !! 4-	bodyBytes <- get bodyByteCount-	return (endianness, L.append fixedBytes fieldBytes, bodyBytes)-\end{code}--\begin{code}-checkMatchingVersion :: (E.Error e, E.MonadError e m) => T.Variant -> m ()-checkMatchingVersion v = unless (messageVersion == protocolVersion) $-	E.throwError . E.strMsg . concat $-		[ "Protocol version mismatch: "-		, show messageVersion-		, " != "-		, show protocolVersion-		]-	where messageVersion = fromJust . T.fromVariant $ v-\end{code}--\begin{code}-getEndianness :: (E.Error e, E.MonadError e m) => T.Variant -> m T.Endianness-getEndianness v = maybe bad return $ T.fromVariant v where-	word = fromJust . T.fromVariant $ v :: Word8-	bad = E.throwError . E.strMsg-	      $ "Invalid endianness code: " ++ show word-\end{code}--Next, the header is parsed into a proper {\tt MessageHeader}.--\begin{code}-parseHeader :: (E.Error e, E.MonadError e m)-               => T.Endianness -> L.ByteString -> m MessageHeader-parseHeader endianness bytes = do-	let signature = T.mkSignature' "yyyyuua(yv)"-	vs <- U.unmarshal endianness signature bytes-	let fieldArray = fromJust . T.fromVariant $ vs !! 6-	let fields = mapMaybe T.fromVariant $ T.arrayItems fieldArray-	let flagByte = fromJust . T.fromVariant $ vs !! 2-	return $ MessageHeader-		endianness-		(fromJust . T.fromVariant $ vs !! 1)-		(S.fromList . decodeFlags $ flagByte)-		(fromJust . T.fromVariant $ vs !! 3)-		(fromJust . T.fromVariant $ vs !! 4)-		(fromJust . T.fromVariant $ vs !! 5)-		fields-\end{code}--If the header fields contain a body signature, it should be used for-unmarshaling the body. Otherwise, the body is assumed to be empty.--\begin{code}-findBodySignature :: [HeaderField] -> T.Signature-findBodySignature fields = fromMaybe empty signature where-	empty = T.mkSignature' ""-	signature = listToMaybe [x | Signature x <- fields]-\end{code}--\begin{code}-mkReceived :: (E.Error e, E.MonadError e m)-               => Word8 -> T.Serial -> [HeaderField] -> S.Set Flag-               -> [T.Variant] -> m ReceivedMessage-mkReceived 1 = mkReceived' ReceivedMethodCall mkMethodCall-mkReceived 2 = mkReceived' ReceivedMethodReturn mkMethodReturn-mkReceived 3 = mkReceived' ReceivedError mkError-mkReceived 4 = mkReceived' ReceivedSignal mkSignal-mkReceived _ = undefined -- mkReceived' ReceivedUnknown    mkUnknown-\end{code}--\begin{code}-mkReceived' :: (E.Error e, E.MonadError e m)-               => (T.Serial -> Maybe T.BusName -> a -> ReceivedMessage)-               -> ([HeaderField] -> S.Set Flag -> [T.Variant] -> m a)-               -> T.Serial -> [HeaderField] -> S.Set Flag -> [T.Variant]-               -> m ReceivedMessage-mkReceived' mkRecv mkMsg serial fields flags body = do-	msg <- mkMsg fields flags body-	let sender = listToMaybe [x | Sender x <- fields]-	return $ mkRecv serial sender msg-\end{code}--\begin{code}-mkMethodCall :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag-                -> [T.Variant] -> m MethodCall-mkMethodCall fields flags body = do-	path <- require "path" [x | Path x <- fields]-	member <- require "member name" [x | Member x <- fields]-	let iface = listToMaybe [x | Interface x <- fields]-	let dest = listToMaybe [x | Destination x <- fields]-	return $ MethodCall path member iface dest flags body-\end{code}--\begin{code}-mkMethodReturn :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag-                  -> [T.Variant] -> m MethodReturn-mkMethodReturn fields flags body = do-	serial <- require "reply serial" [x | ReplySerial x <- fields]-	let dest = listToMaybe [x | Destination x <- fields]-	return $ MethodReturn serial dest flags body-\end{code}--\begin{code}-mkError :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag-           -> [T.Variant] -> m Error-mkError fields flags body = do-	name <- require "error name" [x | ErrorName x <- fields]-	serial <- require "reply serial" [x | ReplySerial x <- fields]-	let dest = listToMaybe [x | Destination x <- fields]-	return $ Error name serial dest flags body-\end{code}--\begin{code}-mkSignal :: (E.Error e, E.MonadError e m) => [HeaderField] -> S.Set Flag-            -> [T.Variant] -> m Signal-mkSignal fields flags body = do-	path <- require "path" [x | Path x <- fields]-	member <- require "member" [x | Member x <- fields]-	iface <- require "interface" [x | Interface x <- fields]-	return $ Signal path member iface flags body-\end{code}--\begin{code}-require :: (E.Error e, E.MonadError e m) => String -> [a] -> m a-require _     (x:_) = return x-require label _     = E.throwError . E.strMsg $ "Required field " ++ show label ++ " is missing."-\end{code}

@@ -1,59 +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/>.--\ignore{-\begin{code}-module DBus.Padding-	( padding-	, alignment-	) where--import Data.Word (Word8, Word64)-import qualified DBus.Types as T-\end{code}-}--\section{Byte padding and alignment}--\begin{code}-padding :: Word64 -> Word8 -> Word64-padding current count = required where-	count' = fromIntegral count-	missing = mod current count'-	required = if missing > 0-		then count' - missing-		else 0-\end{code}--\begin{code}-alignment :: T.Type -> Word8-alignment  T.BooleanT         = 4-alignment  T.ByteT            = 1-alignment  T.UInt16T          = 2-alignment  T.UInt32T          = 4-alignment  T.UInt64T          = 8-alignment  T.Int16T           = 2-alignment  T.Int32T           = 4-alignment  T.Int64T           = 8-alignment  T.DoubleT          = 8-alignment  T.StringT          = 4-alignment  T.ObjectPathT      = 4-alignment  T.SignatureT       = 1-alignment (T.ArrayT _)        = 4-alignment (T.DictionaryT _ _) = 4-alignment (T.StructureT _)    = 8-alignment  T.VariantT         = 1-\end{code}-

@@ -1,47 +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/>.--\ignore{-\begin{code}-module DBus.Types-	( module DBus.Types.Atom-	, module DBus.Types.Containers-	, module DBus.Types.Endianness-	, module DBus.Types.Names-	, module DBus.Types.ObjectPath-	, module DBus.Types.Serial-	, module DBus.Types.Signature-	) where--import DBus.Types.Atom-import DBus.Types.Containers-import DBus.Types.Endianness-import DBus.Types.Names-import DBus.Types.ObjectPath-import DBus.Types.Serial-import DBus.Types.Signature-\end{code}-}--\clearpage-\section{Types}--\input{DBus/Types/Containers.lhs}-\input{DBus/Types/Atom.lhs}-\input{DBus/Types/Signature.lhs}-\input{DBus/Types/Names.lhs}-\input{DBus/Types/ObjectPath.lhs}-\input{DBus/Types/Serial.lhs}-\input{DBus/Types/Endianness.lhs}

@@ -1,108 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE TypeSynonymInstances #-}-module DBus.Types.Atom-	( -- * Atoms-	  Atom-	, Atomic-	, toAtom-	, fromAtom-	, atomSignature-	, atomType-	, atomToVariant-	, atomFromVariant-	) where--import Control.Monad (msum)-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import qualified DBus.Types.Signature as S-import qualified DBus.Types.ObjectPath as O-import qualified DBus.Types.Containers.Variant as V-\end{code}-}--\subsection{Atoms}--Any atomic value can be used as a dictionary key. Types which might be-used for dict keys should implement {\tt Atomic}.--\begin{code}-newtype Atom = Atom V.Variant-	deriving (Show, Eq)--class V.Variable a => Atomic a where-	toAtom :: a -> Atom--atomToVariant :: Atom -> V.Variant-atomToVariant (Atom x) = x--atomFromVariant :: V.Variant -> Maybe Atom-atomFromVariant v = msum as where-	v' :: V.Variable a => Maybe a-	v' = V.fromVariant v-	fa :: (Atomic a, Functor f) => f a -> f Atom-	fa = fmap toAtom-	-	as = [fa (v' :: Maybe Bool)-	     ,fa (v' :: Maybe Word8)-	     ,fa (v' :: Maybe Word16)-	     ,fa (v' :: Maybe Word32)-	     ,fa (v' :: Maybe Word64)-	     ,fa (v' :: Maybe Int16)-	     ,fa (v' :: Maybe Int32)-	     ,fa (v' :: Maybe Int64)-	     ,fa (v' :: Maybe Double)-	     ,fa (v' :: Maybe String)-	     ,fa (v' :: Maybe O.ObjectPath)-	     ,fa (v' :: Maybe S.Signature)-	     ]-\end{code}--\begin{code}-fromAtom :: V.Variable a => Atom -> Maybe a-fromAtom (Atom x) = V.fromVariant x-\end{code}--\begin{code}-atomSignature :: Atom -> S.Signature-atomSignature (Atom v) = V.variantSignature v-\end{code}--\begin{code}-atomType :: Atom -> S.Type-atomType = head . S.signatureTypes . atomSignature-\end{code}--\begin{code}-toAtom' :: Atomic a => a -> Atom-toAtom' = Atom . V.toVariant--instance Atomic Bool         where toAtom = toAtom'-instance Atomic Word8        where toAtom = toAtom'-instance Atomic Word16       where toAtom = toAtom'-instance Atomic Word32       where toAtom = toAtom'-instance Atomic Word64       where toAtom = toAtom'-instance Atomic Int16        where toAtom = toAtom'-instance Atomic Int32        where toAtom = toAtom'-instance Atomic Int64        where toAtom = toAtom'-instance Atomic Double       where toAtom = toAtom'-instance Atomic String       where toAtom = toAtom'-instance Atomic O.ObjectPath where toAtom = toAtom'-instance Atomic S.Signature  where toAtom = toAtom'-\end{code}

@@ -1,49 +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/>.--\ignore{-\begin{code}-module DBus.Types.Containers-	( -- * Containers-	-	  -- ** Variants-	  Variant-	, Variable (..)-	, variantSignature-	, variantType-	-	  -- ** Arrays-	, module DBus.Types.Containers.Array-	-	  -- ** Dictionaries-	, module DBus.Types.Containers.Dictionary-	-	  -- ** Structures-	, module DBus.Types.Containers.Structure-	) where--import DBus.Types.Containers.Variant-import DBus.Types.Containers.Array-import DBus.Types.Containers.Dictionary-import DBus.Types.Containers.Structure-\end{code}-}--\subsection{Containers}--\input{DBus/Types/Containers/Array.lhs}-\input{DBus/Types/Containers/Dictionary.lhs}-\input{DBus/Types/Containers/Structure.lhs}-\input{DBus/Types/Containers/Variant.lhs}

@@ -1,84 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.Containers.Array-	( Array-	, toArray-	, fromArray-	, arrayItems-	, arrayFromItems-	, arraySignature-	) where--import Data.Typeable (Typeable, cast)-import qualified DBus.Types.Signature as S-import qualified DBus.Types.Containers.Variant as V-\end{code}-}--\subsubsection{Arrays}--Arrays are homogeneous sequences of any valid type. They may be-converted to and from standard Haskell lists, where the list contains elements with-a valid type.--\begin{code}-data Array = Array S.Signature [V.Variant]-	deriving (Show, Eq, Typeable)-\end{code}--\begin{code}-instance V.Variable Array where-	defaultSignature _ = S.mkSignature' "ay"-	toVariant x = V.Variant (arraySignature x) x-	fromVariant (V.Variant _ x) = cast x-\end{code}--\begin{code}-toArray :: V.Variable a => [a] -> Maybe Array-toArray vs = arrayFromItems sig variants where-	variants = map V.toVariant vs-	sig = case vs of-		[] -> V.defaultSignature . head $ undefined : vs-		_  -> V.variantSignature . head $ variants-\end{code}--\begin{code}-arrayFromItems :: S.Signature -> [V.Variant] -> Maybe Array-arrayFromItems itemSig vs = array where-	array = if sameSignature-		then Just (Array sig vs)-		else Nothing-	sig = S.mkSignature' $ 'a' : S.strSignature itemSig-	sameSignature = all (== itemSig) . map V.variantSignature $ vs-\end{code}--\begin{code}-fromArray :: V.Variable a => Array -> Maybe [a]-fromArray (Array _ vs) = mapM V.fromVariant vs-\end{code}--\begin{code}-arrayItems :: Array -> [V.Variant]-arrayItems (Array _ vs) = vs-\end{code}--\begin{code}-arraySignature :: Array -> S.Signature-arraySignature (Array s _) = s-\end{code}

@@ -1,110 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.Containers.Dictionary-	( Dictionary-	, toDictionary-	, fromDictionary-	, dictionaryItems-	, dictionaryFromItems-	, dictionarySignature-	) where--import Control.Arrow ((***))-import Data.Typeable (Typeable, cast)-import qualified DBus.Types.Signature as S-import qualified DBus.Types.Atom as A-import qualified DBus.Types.Containers.Variant as V-\end{code}-}--\subsubsection{Dictionaries}--Dictionaries are a key $\rightarrow$ value mapping, where the keys must be of an-{\tt Atomic} type, and the values may be of any valid DBus type.--\begin{code}-data Dictionary = Dictionary S.Signature [(A.Atom, V.Variant)]-	deriving (Show, Eq, Typeable)-\end{code}--\begin{code}-instance V.Variable Dictionary where-	defaultSignature _ = S.mkSignature' "a{yy}"-	toVariant x = V.Variant (dictionarySignature x) x-	fromVariant (V.Variant _ x) = cast x-\end{code}--\begin{code}-toDictionary :: (A.Atomic a, V.Variable b) => [(a, b)] -> Maybe Dictionary-toDictionary pairs = dictionaryFromItems kSig vSig pairs' where-	fakePair = head $ (undefined, undefined) : pairs-	kSigFake = V.defaultSignature . fst $ fakePair-	vSigFake = V.defaultSignature . snd $ fakePair-	-	pairs' = map (A.toAtom *** V.toVariant) pairs-	kSigReal = A.atomSignature  . fst . head $ pairs'-	vSigReal = V.variantSignature . snd . head $ pairs'-	-	(kSig, vSig) = case pairs of-		[] -> (kSigFake, vSigFake)-		_  -> (kSigReal, vSigReal)-\end{code}--\begin{code}-dictionaryFromItems :: S.Signature -> S.Signature -> [(A.Atom, V.Variant)]-                    -> Maybe Dictionary-dictionaryFromItems kSig vSig pairs = maybeDict where-	maybeDict = if hasSignature kSig ks && hasSignature vSig vs-		then Just (Dictionary sig pairs)-		else Nothing-	-	ks = map (A.atomToVariant . fst) pairs-	vs = map snd pairs-	-	kSig' = S.strSignature kSig-	vSig' = S.strSignature vSig-	sig = S.mkSignature' $ "a{" ++ kSig' ++ vSig' ++ "}"-\end{code}--\begin{code}-fromDictionary :: (A.Atomic a, V.Variable b) => Dictionary -> Maybe [(a, b)]-fromDictionary (Dictionary _ vs) = mapM fromVariant' vs where-	fromVariant' (k, v) = do-		k' <- A.fromAtom k-		v' <- V.fromVariant v-		return (k', v')-\end{code}--\begin{code}-dictionaryItems :: Dictionary -> [(A.Atom, V.Variant)]-dictionaryItems (Dictionary _ vs) = vs-\end{code}--\begin{code}-dictionarySignature :: Dictionary -> S.Signature-dictionarySignature (Dictionary s _) = s-\end{code}--\subsubsection*{Helper functions}--\begin{code}-hasSignature :: S.Signature -> [V.Variant] -> Bool-hasSignature _   [] = True-hasSignature sig vs = all (== sig) . map V.variantSignature $ vs-\end{code}

@@ -1,48 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.Containers.Structure-	( Structure (..)-	, structureSignature-	) where--import Data.Typeable (Typeable, cast)-import qualified DBus.Types.Signature as S-import qualified DBus.Types.Containers.Variant as V-\end{code}-}--\subsubsection{Structures}--Structures contain a heterogenous list of DBus values. Any value may be-contained within a structure.--\begin{code}-data Structure = Structure [V.Variant]-	deriving (Show, Eq, Typeable)--instance V.Variable Structure where-	defaultSignature _ = S.mkSignature' "()"-	toVariant x = V.Variant (structureSignature x) x-	fromVariant (V.Variant _ x) = cast x--structureSignature :: Structure -> S.Signature-structureSignature (Structure vs) = sig where-	sigs = [s | (V.Variant s _) <- vs]-	sig = S.mkSignature' $ "(" ++ concatMap S.strSignature sigs ++ ")"-\end{code}

@@ -1,186 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.Containers.Variant-	( Variant (..)-	, Variable (..)-	, variantSignature-	, variantType-	) where--import Data.Typeable (Typeable, cast)-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import qualified DBus.Types.Signature as S-import qualified DBus.Types.ObjectPath as O-\end{code}-}--\subsubsection{Variants}--Any value which can be converted to a {\tt Variant} can be stored in D-Bus-containers or marshaled. Additionally, external types may implement the-{\tt Variable} interface to provide custom conversion to/from built-in D-Bus-types.--The {\tt defaultSignature} function will be passed {\tt unknown} to determine-the signature an empty array or dictionary.--\begin{code}-class Variable a where-	defaultSignature :: a -> S.Signature-	toVariant :: a -> Variant-	fromVariant :: Variant -> Maybe a-\end{code}--\begin{code}-data Variant = forall a. (Variable a, Typeable a, Show a) =>-               Variant S.Signature a-	deriving (Typeable)--instance Show Variant where-	showsPrec d (Variant sig x) = showParen (d > 10) $-		s "Variant " . s sigStr . s " " . showsPrec 11 x-		where sigStr = show . S.strSignature $ sig-		      s    = showString-\end{code}--Ghetto Eq instance -- the types contained in variants are known to have-fixed {\tt show} representations, so this works well enough.--It might not work right for {\tt Double}, though.--\begin{code}-instance Eq Variant where-	x == y = show x == show y-\end{code}--Variants are themselves variables.--\begin{code}-instance Variable Variant where-	defaultSignature _ = S.mkSignature' "v"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-variantSignature :: Variant -> S.Signature-variantSignature (Variant s _) = s-\end{code}--\begin{code}-variantType :: Variant -> S.Type-variantType = head . S.signatureTypes . variantSignature-\end{code}--\begin{code}-instance Variable Bool where-	defaultSignature _ = S.mkSignature' "b"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Word8 where-	defaultSignature _ = S.mkSignature' "y"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Word16 where-	defaultSignature _ = S.mkSignature' "q"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Word32 where-	defaultSignature _ = S.mkSignature' "u"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Word64 where-	defaultSignature _ = S.mkSignature' "t"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Int16 where-	defaultSignature _ = S.mkSignature' "n"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Int32 where-	defaultSignature _ = S.mkSignature' "i"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Int64 where-	defaultSignature _ = S.mkSignature' "x"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable Double where-	defaultSignature _ = S.mkSignature' "d"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable String where-	defaultSignature _ = S.mkSignature' "s"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable O.ObjectPath where-	defaultSignature _ = S.mkSignature' "o"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\begin{code}-instance Variable S.Signature where-	defaultSignature _ = S.mkSignature' "g"-	toVariant = toVariant'-	fromVariant = fromVariant'-\end{code}--\subsubsection*{Helper functions}--\begin{code}-toVariant' :: (Variable a, Typeable a, Show a) => a -> Variant-toVariant' x = Variant (defaultSignature x) x--fromVariant' :: Typeable a => Variant -> Maybe a-fromVariant' (Variant _ x) = cast x-\end{code}

@@ -1,51 +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/>.--\ignore{-\begin{code}-module DBus.Types.Endianness-	( -- * Endianness-	  Endianness (..)-	) where--import Data.Word (Word8)-import qualified DBus.Types.Containers as C-import DBus.Types.Signature (mkSignature')-\end{code}-}--\subsubsection{Endianness}--\begin{code}-data Endianness = LittleEndian | BigEndian-	deriving (Show, Eq)-\end{code}--Endianness is encoded in the header as a single ASCII character, either-{\tt 'l'} ({\tt 0x6C}) for little-endian or {\tt 'B'} ({\tt 0x42}) for-big-endian.--\begin{code}-instance C.Variable Endianness where-	defaultSignature _ = mkSignature' "y"-	toVariant LittleEndian = C.toVariant (0x6C :: Word8)-	toVariant BigEndian = C.toVariant (0x42 :: Word8)-	fromVariant v = do-		b <- C.fromVariant v :: Maybe Word8-		case b of-			0x6C -> Just LittleEndian-			0x42 -> Just BigEndian-			_    -> Nothing-\end{code}

@@ -1,202 +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/>.--\ignore{-\begin{code}-module DBus.Types.Names-	( -- * Names-	-	  -- ** Interface names-	  InterfaceName-	, mkInterfaceName-	, mkInterfaceName'-	, strInterfaceName-	-	  -- ** Bus names-	, BusName-	, mkBusName-	, mkBusName'-	, strBusName-	-	  -- ** Member names-	, MemberName-	, mkMemberName-	, mkMemberName'-	, strMemberName-	-	  -- ** Error names-	, ErrorName-	, mkErrorName-	, mkErrorName'-	, strErrorName-	) where--import Text.Parsec ((<|>))-import qualified Text.Parsec as P-import qualified DBus.Types.Atom as A-import qualified DBus.Types.Containers as C-import DBus.Types.Signature (mkSignature')-import DBus.Util (checkLength, parseMaybe, mkUnsafe)-\end{code}-}--All names have a length limit of 255 characters.--\subsubsection{Interface names}--An interface name consists of two or more {\tt '.'}-separated elements. Each-element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not-start with a digit, and must have at least one character.--\begin{code}-newtype InterfaceName = InterfaceName String-	deriving (Show, Eq, Ord)-\end{code}--\begin{code}-instance C.Variable InterfaceName where-	defaultSignature _ = mkSignature' "s"-	toVariant = A.atomToVariant . A.toAtom-	fromVariant = (mkInterfaceName =<<) . C.fromVariant-instance A.Atomic InterfaceName where-	toAtom = A.toAtom . strInterfaceName-\end{code}--\begin{code}-mkInterfaceName :: String -> Maybe InterfaceName-mkInterfaceName s = checkLength 255 s >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	element = P.oneOf c >> P.many (P.oneOf c')-	name = element >> P.many1 (P.char '.' >> element)-	parser = name >> P.eof >> return (InterfaceName s)-\end{code}--\begin{code}-mkInterfaceName' :: String -> InterfaceName-mkInterfaceName' = mkUnsafe "interface name" mkInterfaceName-\end{code}--\begin{code}-strInterfaceName :: InterfaceName -> String-strInterfaceName (InterfaceName x) = x-\end{code}--\subsubsection{Error names}--Error names have the same rules as interface names, so just re-use that-validation logic.--\begin{code}-newtype ErrorName = ErrorName String-	deriving (Show, Eq, Ord)-\end{code}--\begin{code}-instance C.Variable ErrorName where-	defaultSignature _ = mkSignature' "s"-	toVariant = A.atomToVariant . A.toAtom-	fromVariant = (mkErrorName =<<) . C.fromVariant-instance A.Atomic ErrorName where-	toAtom = A.toAtom . strErrorName-\end{code}--\begin{code}-mkErrorName :: String -> Maybe ErrorName-mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName-\end{code}--\begin{code}-mkErrorName' :: String -> ErrorName-mkErrorName' = mkUnsafe "error name" mkErrorName-\end{code}--\begin{code}-strErrorName :: ErrorName -> String-strErrorName (ErrorName x) = x-\end{code}--\subsubsection{Bus names}--\begin{code}-newtype BusName = BusName String-	deriving (Show, Eq, Ord)-\end{code}--\begin{code}-instance C.Variable BusName where-	defaultSignature _ = mkSignature' "s"-	toVariant = A.atomToVariant . A.toAtom-	fromVariant = (mkBusName =<<) . C.fromVariant-instance A.Atomic BusName where-	toAtom = A.toAtom . strBusName-\end{code}--\begin{code}-mkBusName :: String -> Maybe BusName-mkBusName s = checkLength 255 s >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-	c' = c ++ ['0'..'9']-	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)-	unique = P.char ':' >> elems c'-	wellKnown = elems c-	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)-	elem' start = P.oneOf start >> P.many (P.oneOf c')-\end{code}--\begin{code}-mkBusName' :: String -> BusName-mkBusName' = mkUnsafe "bus name" mkBusName-\end{code}--\begin{code}-strBusName :: BusName -> String-strBusName (BusName x) = x-\end{code}--\subsubsection{Member names}--\begin{code}-newtype MemberName = MemberName String-	deriving (Show, Eq, Ord)-\end{code}--\begin{code}-instance C.Variable MemberName where-	defaultSignature _ = mkSignature' "s"-	toVariant = A.atomToVariant . A.toAtom-	fromVariant = (mkMemberName =<<) . C.fromVariant-instance A.Atomic MemberName where-	toAtom = A.toAtom . strMemberName-\end{code}--\begin{code}-mkMemberName :: String -> Maybe MemberName-mkMemberName s = checkLength 255 s >>= parseMaybe parser where-	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-	c' = c ++ ['0'..'9']-	name = P.oneOf c >> P.many (P.oneOf c')-	parser = name >> P.eof >> return (MemberName s)-\end{code}--\begin{code}-mkMemberName' :: String -> MemberName-mkMemberName' = mkUnsafe "member name" mkMemberName-\end{code}--\begin{code}-strMemberName :: MemberName -> String-strMemberName (MemberName x) = x-\end{code}

@@ -1,62 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.ObjectPath-	( -- * Object paths-	  ObjectPath-	, mkObjectPath-	, mkObjectPath'-	, strObjectPath-	) where--import Data.Typeable (Typeable)-import qualified Text.Parsec as P-import DBus.Util (parseMaybe, mkUnsafe)-\end{code}-}--\subsubsection{Object paths}--An object path may be one of--\begin{itemize}-\item The root path, {\tt "/"}.-\item {\tt '/'}, followed by one or more element names. Each element name-      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at-      least one character.-\end{itemize}--Element names are separated by {\tt '/'}, and the path may not end in-{\tt '/'} unless it is the root path.--\begin{code}-newtype ObjectPath = ObjectPath String-	deriving (Show, Eq, Ord, Typeable)--mkObjectPath :: String -> Maybe ObjectPath-mkObjectPath s = parseMaybe path' s where-	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char-	path' = path >> P.eof >> return (ObjectPath s)--mkObjectPath' :: String -> ObjectPath-mkObjectPath' = mkUnsafe "object path" mkObjectPath--strObjectPath :: ObjectPath -> String-strObjectPath (ObjectPath x) = x-\end{code}

@@ -1,58 +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/>.--\ignore{-\begin{code}-module DBus.Types.Serial-	( -- * Message serials-	  Serial (..)-	, nextSerial-	, firstSerial-	) where--import Data.Word (Word32)-import qualified DBus.Types.Atom as A-import qualified DBus.Types.Containers as C-import DBus.Types.Signature (mkSignature')-\end{code}-}--\subsubsection{Message Serials}--\begin{code}-newtype Serial = Serial Word32-	deriving (Eq, Ord)--instance Show Serial where-	show (Serial x) = show x--instance A.Atomic Serial where-	toAtom (Serial x) = A.toAtom x--instance C.Variable Serial where-	defaultSignature _ = mkSignature' "u"-	toVariant (Serial x) = C.toVariant x-	fromVariant = fmap Serial . C.fromVariant-\end{code}--\begin{code}-nextSerial :: Serial -> Serial-nextSerial (Serial x) = Serial (x + 1)-\end{code}--\begin{code}-firstSerial :: Serial-firstSerial = Serial 1-\end{code}

@@ -1,157 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE DeriveDataTypeable #-}-module DBus.Types.Signature-	( -- * Signatures-	  Signature-	, Type(..)-	, signatureTypes-	, mkSignature-	, mkSignature'-	, strSignature-	, typeString-	) where--import Data.Typeable (Typeable)-import Text.Parsec (char, (<|>), many, eof)-import DBus.Util (checkLength, parseMaybe, mkUnsafe)-\end{code}-}--\subsubsection{Signatures}--Valid DBus type signatures must obey certain rules, such as "dict entries-may only appear in arrays". A signature is guaranteed to be valid according-to these rules. Creating them requires using the {\tt parseSignature}-function, which will convert a valid DBus signature string into a-{\tt Signature}.--\begin{code}-data Signature = Signature { signatureTypes :: [Type] }-	deriving (Eq, Typeable)-\end{code}--Use a custom {\tt Show} instance to avoid displaying signature types directly.--\begin{code}-instance Show Signature where-	showsPrec d s = showParen (d > 10) $-		showString' ["Signature \"", strSignature s, "\""] where-		showString' = foldr (.) id . map showString-\end{code}--Parse a signature string such as {\tt "yya{is}"} to a signature. If the-string is invalid, {\tt Nothing} will be returned instead.--\begin{code}-mkSignature :: String -> Maybe Signature-mkSignature = (parseMaybe sigParser =<<) . checkLength 255 where-	sigParser = do-		types <- many parseType-		eof-		return $ Signature types-	parseType = parseAtom <|> parseContainer-	parseContainer =-		    parseArray-		<|> parseStruct-		<|> (char 'v' >> return VariantT)-	parseAtom =-		    (char 'b' >> return BooleanT)-		<|> (char 'y' >> return ByteT)-		<|> (char 'n' >> return Int16T)-		<|> (char 'q' >> return UInt16T)-		<|> (char 'i' >> return Int32T)-		<|> (char 'u' >> return UInt32T)-		<|> (char 'x' >> return Int64T)-		<|> (char 't' >> return UInt64T)-		<|> (char 'd' >> return DoubleT)-		<|> (char 's' >> return StringT)-		<|> (char 'o' >> return ObjectPathT)-		<|> (char 'g' >> return SignatureT)-	parseArray = do-		char 'a'-		parseDict <|> do-		t <- parseType-		return $ ArrayT t-	parseDict = do-		char '{'-		keyType <- parseAtom-		valueType <- parseType-		char '}'-		return $ DictionaryT keyType valueType-	parseStruct = do-		char '('-		types <- many parseType-		char ')'-		return $ StructureT types-\end{code}--\begin{code}-mkSignature' :: String -> Signature-mkSignature' = mkUnsafe "signature" mkSignature-\end{code}--Convert a signature to a string, for marshaling over the bus or display.--\begin{code}-strSignature :: Signature -> String-strSignature (Signature ts) = concatMap typeString ts-\end{code}--Data types which may be contained in a signature. No checks are performed to-ensure correct nesting when using these, so all generation of signatures-must go through {\tt parseSignature}.--\begin{code}-data Type-	= BooleanT-	| ByteT-	| Int16T-	| UInt16T-	| Int32T-	| UInt32T-	| Int64T-	| UInt64T-	| DoubleT-	| StringT-	| ObjectPathT-	| SignatureT-	| ArrayT Type-	| DictionaryT Type Type-	| StructureT [Type]-	| VariantT-	deriving (Show, Eq)--typeString :: Type -> String-typeString BooleanT            = "b"-typeString ByteT               = "y"-typeString Int16T              = "n"-typeString UInt16T             = "q"-typeString Int32T              = "i"-typeString UInt32T             = "u"-typeString Int64T              = "x"-typeString UInt64T             = "t"-typeString DoubleT             = "d"-typeString StringT             = "s"-typeString ObjectPathT         = "o"-typeString SignatureT          = "g"-typeString (ArrayT t)          = 'a' : typeString t-typeString (DictionaryT kt vt) = "a{" ++ typeString kt ++ typeString vt ++ "}"-typeString (StructureT ts)     = "(" ++ concatMap typeString ts ++ ")"-typeString VariantT            = "v"-\end{code}

@@ -1,312 +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/>.--\ignore{-\begin{code}-{-# LANGUAGE ExistentialQuantification #-}-module DBus.Unmarshal (unmarshal) where--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import qualified Control.Monad.State as S-import qualified Control.Monad.Error as E-import qualified Data.ByteString.Lazy as L-import Data.ByteString.Lazy.UTF8 (toString)-import qualified Data.Binary.Get as G-import qualified Data.Binary.IEEE754 as IEEE--import DBus.Padding (padding, alignment)-import qualified DBus.Types as T-\end{code}-}--\clearpage-\section{Unmarshaling}-\subsection{\tt unmarshal}--\begin{code}-unmarshal :: (E.Error e, E.MonadError e m)-             => T.Endianness -> T.Signature -> L.ByteString-             -> m [T.Variant]-unmarshal e sig bytes = either' where-	either' = case runUnmarshal x e bytes of-		Left  y -> E.throwError . E.strMsg . show $ y-		Right y -> return y-	x = mapM unmarshal' $ T.signatureTypes sig-\end{code}--\begin{code}-unmarshal' :: T.Type -> Unmarshal T.Variant-unmarshal'  T.BooleanT           = fmap T.toVariant bool-unmarshal'  T.ByteT              = fmap T.toVariant word8-unmarshal'  T.UInt16T            = fmap T.toVariant word16-unmarshal'  T.UInt32T            = fmap T.toVariant word32-unmarshal'  T.UInt64T            = fmap T.toVariant word64-unmarshal'  T.Int16T             = fmap T.toVariant int16-unmarshal'  T.Int32T             = fmap T.toVariant int32-unmarshal'  T.Int64T             = fmap T.toVariant int64-unmarshal'  T.DoubleT            = fmap T.toVariant double-unmarshal'  T.StringT            = fmap T.toVariant string-unmarshal'  T.ObjectPathT        = fmap T.toVariant objectPath-unmarshal'  T.SignatureT         = fmap T.toVariant signature-unmarshal' (T.ArrayT t)          = fmap T.toVariant $ array t-unmarshal' (T.DictionaryT kt vt) = fmap T.toVariant $ dictionary kt vt-unmarshal' (T.StructureT ts)     = fmap T.toVariant $ structure ts-unmarshal'  T.VariantT           = fmap T.toVariant variant-\end{code}--\subsection{Atoms}--\begin{code}-bool :: Unmarshal Bool-bool = word32 >>= \x -> case x of-	0 -> return False-	1 -> return True-	_ -> E.throwError $ Invalid "boolean" x-\end{code}--\begin{code}-word8 :: Unmarshal Word8-word8 = do-	bs <- consume 1-	let [b] = L.unpack bs-	return b-\end{code}--\begin{code}-word16 :: Unmarshal Word16-word16 = eitherEndian 2 G.getWord16be G.getWord16le-\end{code}--\begin{code}-word32 :: Unmarshal Word32-word32 = eitherEndian 4 G.getWord32be G.getWord32le-\end{code}--\begin{code}-word64 :: Unmarshal Word64-word64 = eitherEndian 8 G.getWord64be G.getWord64le-\end{code}--\begin{code}-int16 :: Unmarshal Int16-int16 = fmap fromIntegral $ eitherEndian 2 G.getWord16be G.getWord16le-\end{code}--\begin{code}-int32 :: Unmarshal Int32-int32 = fmap fromIntegral $ eitherEndian 4 G.getWord32be G.getWord32le-\end{code}--\begin{code}-int64 :: Unmarshal Int64-int64 = fmap fromIntegral $ eitherEndian 8 G.getWord64be G.getWord64le-\end{code}--\begin{code}-double :: Unmarshal Double-double = eitherEndian 8 IEEE.getFloat64be IEEE.getFloat64le-\end{code}--\begin{code}-string :: Unmarshal String-string = do-	byteCount <- word32-	bytes <- consume . fromIntegral $ byteCount-	skipNulls 1-	return . toString $ bytes-\end{code}--\begin{code}-objectPath :: Unmarshal T.ObjectPath-objectPath = do-	s <- string-	fromMaybe T.mkObjectPath s "object path"-\end{code}--\begin{code}-signature :: Unmarshal T.Signature-signature = do-	byteCount <- word8-	bytes <- consume . fromIntegral $ byteCount-	skipNulls 1-	fromMaybe T.mkSignature (toString bytes) "signature"-\end{code}--\subsection{Containers}--\subsubsection{Arrays}--\begin{code}-array :: T.Type -> Unmarshal T.Array-array t = do-	let getOffset = do-		(UnmarshalState _ _ o) <- get-		return o-	let sig = T.mkSignature' . T.typeString $ t-	-	byteCount <- word32-	skipPadding (alignment t)-	start <- getOffset-	let end = start + fromIntegral byteCount-	vs <- untilM (fmap (>= end) getOffset) (unmarshal' t)-	end' <- getOffset-	assert (end == end') "Array contained fewer bytes than expected."-	fromMaybe (T.arrayFromItems sig) vs "array"-\end{code}--\subsubsection{Dictionaries}--\begin{code}-dictionary :: T.Type -> T.Type -> Unmarshal T.Dictionary-dictionary kt vt = do-	arr <- array $ T.StructureT [kt, vt]-	structs <- fromMaybe T.fromArray arr "dictionary"-	pairs <- mapM mkPair structs-	let kSig = T.mkSignature' . T.typeString $ kt-	let vSig = T.mkSignature' . T.typeString $ vt-	fromMaybe (T.dictionaryFromItems kSig vSig) pairs "dictionary"--mkPair :: T.Structure -> Unmarshal (T.Atom, T.Variant)-mkPair (T.Structure [k, v]) = do-	k' <- fromMaybe T.atomFromVariant k "dictionary key"-	return (k', v)-mkPair s = E.throwError $ Invalid "dictionary item" s-\end{code}--\subsubsection{Structures}--\begin{code}-structure :: [T.Type] -> Unmarshal T.Structure-structure ts = do-	skipPadding 8-	fmap T.Structure $ mapM unmarshal' ts-\end{code}--\subsubsection{Variants}--\begin{code}-variant :: Unmarshal T.Variant-variant = do-	sig <- signature-	t <- case T.signatureTypes sig of-		[t'] -> return t'-		_    -> E.throwError $ Invalid "variant signature"-		                     $ T.strSignature sig-	unmarshal' t-\end{code}--\subsection{The {\tt Unmarshal} monad}--\begin{code}-data UnmarshalState = UnmarshalState T.Endianness L.ByteString Word64-type Unmarshal = E.ErrorT UnmarshalError (S.State UnmarshalState)-\end{code}--\begin{code}-runUnmarshal :: Unmarshal a -> T.Endianness -> L.ByteString-                -> Either UnmarshalError a-runUnmarshal x e bytes = S.evalState (E.runErrorT x) state where-	state = UnmarshalState e bytes 0-\end{code}--\begin{code}-get :: Unmarshal UnmarshalState-get = E.lift S.get--put :: UnmarshalState -> Unmarshal ()-put = E.lift . S.put-\end{code}--\begin{code}-consume :: Word64 -> Unmarshal L.ByteString-consume count = do-	(UnmarshalState e bytes offset) <- get-	let bytes' = L.drop (fromIntegral offset) bytes-	let x = L.take (fromIntegral count) bytes'-	if L.length x == fromIntegral count-		then do-			let offset' = offset + count-			put $ UnmarshalState e bytes offset'-			return x-		else E.throwError $ UnexpectedEOF offset-\end{code}--\begin{code}-skipPadding :: Word8 -> Unmarshal ()-skipPadding count = do-	(UnmarshalState _ _ offset) <- get-	bytes <- consume $ padding offset count-	assert (L.all (== 0) bytes) "Non-zero bytes in padding."-\end{code}--\begin{code}-skipNulls :: Word8 -> Unmarshal ()-skipNulls count = do-	bytes <- consume $ fromIntegral count-	assert (L.all (== 0) bytes) "Non-zero bytes in padding."-\end{code}--\begin{code}-eitherEndian :: Word8 -> G.Get a -> G.Get a -> Unmarshal a-eitherEndian count be le = do-	skipPadding count-	(UnmarshalState e _ _) <- get-	bs <- consume . fromIntegral $ count-	let get' = case e of-		T.BigEndian -> be-		T.LittleEndian -> le-	return $ G.runGet get' bs-\end{code}--\begin{code}-untilM :: Monad m => m Bool -> m a -> m [a]-untilM test comp = do-	done <- test-	if done-		then return []-		else do-			x <- comp-			xs <- untilM test comp-			return $ x:xs-\end{code}--\subsection{Errors}--\begin{code}-data UnmarshalError-	= UnexpectedEOF Word64-	| forall a. (Show a) => Invalid String a-	| GenericError String--instance E.Error UnmarshalError where-	strMsg = GenericError--instance Show UnmarshalError where-	show (UnexpectedEOF pos) = "Unexpected EOF at position " ++ show pos-	show (Invalid label x)   = "Invalid " ++ label ++ ": " ++ show x-	show (GenericError msg)  = "Error unmarshaling: " ++ msg-\end{code}--\begin{code}-assert :: Bool -> String -> Unmarshal ()-assert True  _   = return ()-assert False msg = E.throwError $ E.strMsg msg-\end{code}--\begin{code}-fromMaybe :: Show a => (a -> Maybe b) -> a -> String -> Unmarshal b-fromMaybe f x s = maybe (E.throwError $ Invalid s x) return $ f x-\end{code}

@@ -1,61 +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/>.--\clearpage-\section{Misc. utility functions}--\ignore{-\begin{code}-module DBus.Util-	( checkLength-	, parseMaybe-	, mkUnsafe-	, hexToInt-	, eitherToMaybe-	) where--import Text.Parsec (Parsec, parse)-import Data.Char (digitToInt)-\end{code}-}--\begin{code}-checkLength :: Int -> String -> Maybe String-checkLength length' s | length s <= length' = Just s-checkLength _ _ = Nothing-\end{code}--\begin{code}-parseMaybe :: Parsec String () a -> String -> Maybe a-parseMaybe p = either (const Nothing) Just . parse p ""-\end{code}--\begin{code}-mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b-mkUnsafe label f x = case f x of-	Just x' -> x'-	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x-\end{code}--\begin{code}-hexToInt :: String -> Int-hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt-\end{code}--\begin{code}-eitherToMaybe :: Either a b -> Maybe b-eitherToMaybe (Left  _) = Nothing-eitherToMaybe (Right x) = Just x-\end{code}

@@ -15,6 +15,8 @@   along with this program.  If not, see <http://www.gnu.org/licenses/>. -} +{-# LANGUAGE OverloadedStrings #-}+ import DBus.Address import DBus.Bus import DBus.Connection@@ -28,6 +30,8 @@ import Data.Maybe import Data.Int import Data.Word+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL import System import System.IO import System.Console.GetOpt@@ -56,7 +60,7 @@ findBus (o:_) = case o of 	BusOption Session -> getSessionBus 	BusOption System  -> getSystemBus-	AddressOption addr -> case parseAddresses addr of+	AddressOption addr -> case mkAddresses (TL.pack addr) of 			Just [x] -> getBus x 			Just  x  -> getFirstBus x 			_        -> error $ "Invalid address: " ++ show addr@@ -82,7 +86,7 @@ 	]  onMessage :: ReceivedMessage -> IO ()-onMessage msg = putStrLn (formatMessage msg ++ "\n")+onMessage msg = putStrLn $ (TL.unpack $ formatMessage msg) ++ "\n"  main :: IO () main = do@@ -107,17 +111,17 @@ -- Message formatting is verbose and mostly uninteresting, except as an -- excersise in string manipulation. -formatMessage :: ReceivedMessage -> String+formatMessage :: ReceivedMessage -> Text  -- Method call-formatMessage (ReceivedMethodCall serial sender msg) = concat+formatMessage (ReceivedMethodCall serial sender msg) = TL.concat 	[ "method call" 	, " sender=" 	, fromMaybe "(null)" . fmap strBusName $ sender 	, " -> dest=" 	, fromMaybe "(null)" . fmap strBusName . methodCallDestination $ msg 	, " serial="-	, show serial+	, TL.pack . show $ serial 	, " path=" 	, strObjectPath . methodCallPath $ msg 	, "; interface="@@ -128,19 +132,19 @@ 	]  -- Method return-formatMessage (ReceivedMethodReturn _ sender msg) = concat+formatMessage (ReceivedMethodReturn _ sender msg) = TL.concat 	[ "method return" 	, " sender=" 	, fromMaybe "(null)" . fmap strBusName $ sender 	, " -> dest=" 	, fromMaybe "(null)" . fmap strBusName . methodReturnDestination $ msg 	, " reply_serial="-	, show . methodReturnSerial $ msg+	, TL.pack . show . methodReturnSerial $ msg 	, formatBody msg 	]  -- Error-formatMessage (ReceivedError _ sender msg) = concat+formatMessage (ReceivedError _ sender msg) = TL.concat 	[ "error" 	, " sender=" 	, fromMaybe "(null)" . fmap strBusName $ sender@@ -149,17 +153,19 @@ 	, " error_name=" 	, strErrorName . errorName $ msg 	, " reply_serial="-	, show . errorSerial $ msg+	, TL.pack . show . errorSerial $ msg 	, formatBody msg 	]  -- Signal-formatMessage (ReceivedSignal serial sender msg) = concat+formatMessage (ReceivedSignal serial sender msg) = TL.concat 	[ "signal" 	, " sender=" 	, fromMaybe "(null)" . fmap strBusName $ sender+	, " -> dest="+	, fromMaybe "(null)" . fmap strBusName . signalDestination $ msg 	, " serial="-	, show serial+	, TL.pack . show $ serial 	, " path=" 	, strObjectPath . signalPath $ msg 	, "; interface="@@ -169,74 +175,76 @@ 	, formatBody msg 	] -formatMessage (ReceivedUnknown serial sender) = concat+formatMessage (ReceivedUnknown serial sender _) = TL.concat 	[ "unknown" 	, " sender=" 	, fromMaybe "(null)" . fmap strBusName $ sender 	, " serial="-	, show serial+	, TL.pack .  show $ serial 	] -formatBody :: Message a => a -> String+formatBody :: Message a => a -> Text formatBody msg = formatted where 	tree = Children $ map formatVariant body 	body = messageBody msg-	formatted = intercalate "\n" ([] : collapseTree 1 tree)+	formatted = TL.intercalate "\n" (TL.empty : collapseTree 1 tree)  -- A string tree allows easy indentation of nested structures-data StringTree = Line String | MultiLine [StringTree] | Children [StringTree]+data StringTree = Line Text | MultiLine [StringTree] | Children [StringTree] 	deriving (Show) -collapseTree :: Int -> StringTree -> [String]-collapseTree d (Line x)       = [concat (replicate d "   ") ++ x]+collapseTree :: Int64 -> StringTree -> [Text]+collapseTree d (Line x)       = [TL.append (TL.replicate d "   ") x] collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs collapseTree d (Children xs)  = concatMap (collapseTree (d + 1)) xs  -- Formatting for various kinds of variants, keyed to their signature type. formatVariant :: Variant -> StringTree-formatVariant v = formatVariant' type' v where-	[type'] = signatureTypes . variantSignature $ v+formatVariant v = formatVariant' (variantType v) v where +showT :: Show a => a -> Text+showT = TL.pack . show+ formatVariant' :: Type -> Variant -> StringTree -formatVariant' BooleanT x = Line $ "boolean " ++ strX where+formatVariant' DBusBoolean x = Line $ TL.append "boolean " strX where 	x' = fromJust . fromVariant $ x :: Bool 	strX = if x' then "true" else "false" -formatVariant' ByteT x = Line $ "byte " ++ show x' where+formatVariant' DBusByte x = Line $ TL.append "byte " $ showT x' where 	x' = fromJust . fromVariant $ x :: Word8 -formatVariant' Int16T x = Line $ "int16 " ++ show x' where+formatVariant' DBusInt16 x = Line $ TL.append "int16 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Int16 -formatVariant' Int32T x = Line $ "int32 " ++ show x' where+formatVariant' DBusInt32 x = Line $ TL.append "int32 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Int32 -formatVariant' Int64T x = Line $ "int64 " ++ show x' where+formatVariant' DBusInt64 x = Line $ TL.append "int64 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Int64 -formatVariant' UInt16T x = Line $ "uint16 " ++ show x' where+formatVariant' DBusWord16 x = Line $ TL.append "uint16 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Word16 -formatVariant' UInt32T x = Line $ "uint32 " ++ show x' where+formatVariant' DBusWord32 x = Line $ TL.append "uint32 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Word32 -formatVariant' UInt64T x = Line $ "uint64 " ++ show x' where+formatVariant' DBusWord64 x = Line $ TL.append "uint64 " $ showT x' where 	x' = fromJust . fromVariant $ x :: Word64 -formatVariant' DoubleT x = Line $ "double " ++ show x' where+formatVariant' DBusDouble x = Line $ TL.append "double " $ showT x' where 	x' = fromJust . fromVariant $ x :: Double -formatVariant' StringT x = Line $ "string " ++ show x' where+formatVariant' DBusString x = Line $ TL.append "string " $ showT x' where 	x' = fromJust . fromVariant $ x :: String -formatVariant' ObjectPathT x = Line $ "object path " ++ show x' where+formatVariant' DBusObjectPath x = Line $ TL.append "object path " $ showT x' where 	x' = strObjectPath . fromJust . fromVariant $ x -formatVariant' SignatureT x = Line $ "signature " ++ show x' where+formatVariant' DBusSignature x = Line $ TL.append "signature " $ showT x' where 	x' = strSignature . fromJust . fromVariant $ x -formatVariant' (ArrayT _) x = MultiLine lines' where+formatVariant' (DBusArray _) x = MultiLine lines' where 	items = arrayItems . fromJust . fromVariant $ x 	lines' = 		[ Line "array ["@@ -244,19 +252,20 @@ 		, Line "]" 		] -formatVariant' (DictionaryT _ _) x = MultiLine lines' where+formatVariant' (DBusDictionary _ _) x = MultiLine lines' where 	items = dictionaryItems . fromJust . fromVariant $ x 	lines' = [ Line "dictionary {" 		, Children . map formatItem $ items 		, Line "}" 		]-	formatItem (k, v) = MultiLine $ [Line $ k' ++ " -> " ++ vHead] ++ vTail where-		Line k' = formatVariant (atomToVariant k)+	formatItem (k, v) = MultiLine $ firstLine : vTail where+		Line k' = formatVariant k 		v' = collapseTree 0 (formatVariant v) 		vHead = head v' 		vTail = map Line $ tail v'+		firstLine = Line $ TL.concat [k', " -> ", vHead] -formatVariant' (StructureT _) x = MultiLine lines' where+formatVariant' (DBusStructure _) x = MultiLine lines' where 	Structure items = fromJust . fromVariant $ x 	lines' = 		[ Line "struct ("@@ -264,4 +273,4 @@ 		, Line ")" 		] -formatVariant' VariantT x = formatVariant . fromJust . fromVariant $ x+formatVariant' DBusVariant x = formatVariant . fromJust . fromVariant $ x

@@ -0,0 +1,38 @@+HS_SOURCES=\+	hs/DBus/Address.hs \+	hs/DBus/Bus.hs \+	hs/DBus/Connection.hs \+	hs/DBus/Constants.hs \+	hs/DBus/Introspection.hs \+	hs/DBus/Message.hs \+	hs/DBus/Message/Internal.hs \+	hs/DBus/Types.hs \+	hs/DBus/Util.hs \+	hs/DBus/Wire.hs \+	hs/Tests.hs++all: $(HS_SOURCES)++%.tex: %.nw+	noweave -delay "$<" | cpif "$@"++hs/%.hs: dbus-core.nw hs/DBus/Message+	notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@"++hs/Tests.hs: Tests.nw hs+	notangle -R"Tests.hs" "$<" dbus-core.nw | cpphs --hashes --noline | cpif "$@"++hs:+	mkdir -p hs++hs/DBus:+	mkdir -p hs/DBus++hs/DBus/Message:+	mkdir -p hs/DBus/Message++%.pdf: %.tex+	xelatex "$<"+	xelatex "$<"++pdfs: dbus-core.pdf manual.pdf

@@ -1,40 +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/>.--}--import Test.QuickCheck.Batch-import Tests.Address (addressProperties)-import Tests.Signature (signatureProperties)-import Tests.Containers (containerProperties)-import Tests.Marshal (marshalProperties)-import Tests.Messages (messageProperties)-import Tests.MiscTypes (miscTypeProperties)--options = TestOptions-	{ no_of_tests     = 100-	, length_of_tests = 1-	, debug_tests     = False-	}--main = do-	runTests "simple" options . map run . concat $-		[ addressProperties-		, containerProperties-		, marshalProperties-		, messageProperties-		, miscTypeProperties-		, signatureProperties-		]

@@ -0,0 +1,682 @@+% 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/>.++<<Tests.hs>>=+<<copyright>>+{-# LANGUAGE OverloadedStrings #-}+module Main (tests) where++import Test.QuickCheck+import Test.Framework (Test, testGroup)+import qualified Test.Framework as F+import Test.Framework.Providers.QuickCheck2 (testProperty)++import Control.Arrow ((&&&))+import Control.Monad (replicateM)+import qualified Data.Binary.Get as G+import Data.Char (isPrint)+import Data.List (intercalate, isInfixOf)+import Data.Maybe (fromJust, isJust, isNothing)+import qualified Data.Map as Map+import qualified Data.Set as Set+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import DBus.Address+import DBus.Message.Internal+import DBus.Types+import DBus.Wire+import qualified DBus.Introspection as I++@ \section{Tests}++<<Tests.hs>>=+tests :: [Test]+tests = [<<tests>>+	]++main :: IO ()+main = F.defaultMain tests++@ \subsection{Types}++<<tests>>=+  testGroup "Types"+	[ testGroup "Atomic types"+		[<<atom tests>>+		]+	, testGroup "Container types"+		[<<container tests>>+		]+	]++<<atom tests>>=++<<container tests>>=++@ \subsubsection{Atoms}++<<atom tests>>=+  testGroup "Bool" $ commonVariantTests (arbitrary :: Gen Bool)+, testGroup "Word8"   $ commonVariantTests (arbitrary :: Gen Word8)+, testGroup "Word16"  $ commonVariantTests (arbitrary :: Gen Word16)+, testGroup "Word32"  $ commonVariantTests (arbitrary :: Gen Word32)+, testGroup "Word64"  $ commonVariantTests (arbitrary :: Gen Word64)+, testGroup "Int16"   $ commonVariantTests (arbitrary :: Gen Int16)+, testGroup "Int32"   $ commonVariantTests (arbitrary :: Gen Int32)+, testGroup "Int64"   $ commonVariantTests (arbitrary :: Gen Int64)+, testGroup "Double"  $ commonVariantTests (arbitrary :: Gen Double)+, testGroup "String"  $ commonVariantTests (arbitrary :: Gen String) +++	[ testProperty "String -> strict Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ T.pack x)+	, testProperty "String <- strict Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ T.unpack x)+	, testProperty "String -> lazy Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack x)+	, testProperty "String <- lazy Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ TL.unpack x)+	, testProperty "Strict Text -> lazy Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ TL.pack . T.unpack $ x)+	, testProperty "Strict Text <- lazy Text"+		$ \x -> (fromVariant . toVariant) x == (Just $ T.pack . TL.unpack $ x)+	]++<<Tests.hs>>=+atomicType :: Gen Type+atomicType = elements+	[ DBusBoolean+	, DBusByte+	, DBusWord16+	, DBusWord32+	, DBusWord64+	, DBusInt16+	, DBusInt32+	, DBusInt64+	, DBusDouble+	, DBusString+	, DBusObjectPath+	, DBusSignature+	]++containerType :: Gen Type+containerType = do+	c <- choose (0,3) :: Gen Int+	case c of+		0 -> fmap DBusArray arbitrary+		1 -> do+			kt <- atomicType+			vt <- arbitrary+			return $ DBusDictionary kt vt+		2 -> fmap DBusStructure $ shrinkingGen arbitrary+		3 -> return DBusVariant++instance Arbitrary Type where+	arbitrary = oneof [atomicType, containerType]++instance Arbitrary Signature where+	arbitrary = clampedSize 255 genSig mkSignature' where+		genSig = fmap (TL.concat . map typeCode) arbitrary++<<atom tests>>=+, testGroup "Signature" $ commonVariantTests (arbitrary :: Gen Signature) +++	[ testProperty "Signature identity"+		$ \x -> (mkSignature . strSignature) x == Just x+	, testProperty "Signature show"+		$ \x -> show (strSignature x) `isInfixOf` show x+	]++<<Tests.hs>>=+instance Arbitrary ObjectPath where+	arbitrary = fmap (mkObjectPath' . TL.pack) path' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+		path = fmap (intercalate "/" . ([] :)) genElements+		path' = frequency [(1, return "/"), (9, path)]+		genElements = sized' 1 (sized' 1 (elements c))++<<atom tests>>=+, testGroup "ObjectPath" $ commonVariantTests (arbitrary :: Gen ObjectPath) +++	[ testProperty "ObjectPath identity"+		$ \x -> (mkObjectPath . strObjectPath) x == Just x+	]++<<Tests.hs>>=+instance Arbitrary BusName where+	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+		c' = c ++ ['0'..'9']+		+		unique = do+			elems' <- sized' 2 $ elems c'+			return . TL.pack $ ':' : intercalate "." elems'+		+		wellKnown = do+			elems' <- sized' 2 $ elems c+			return . TL.pack $ intercalate "." elems'+		+		elems start = do+			x <- elements start+			xs <- sized' 0 (elements c')+			return (x:xs)++<<atom tests>>=+, testGroup "BusName" $ commonVariantTests (arbitrary :: Gen BusName) +++	[ testProperty "BusName identity"+		$ \x -> (mkBusName . strBusName) x == Just x+	]++<<Tests.hs>>=+instance Arbitrary InterfaceName where+	arbitrary = clampedSize 255 genName mkInterfaceName' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = fmap (TL.pack . intercalate ".") genElements+		genElements = sized' 2 genElement+		genElement = do+			x <- elements c+			xs <- sized' 0 (elements c')+			return (x:xs)++<<atom tests>>=+, testGroup "InterfaceName" $ commonVariantTests (arbitrary :: Gen InterfaceName) +++	[ testProperty "InterfaceName identity"+		$ \x -> (mkInterfaceName . strInterfaceName) x == Just x+	]++<<Tests.hs>>=+instance Arbitrary ErrorName where+	arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary++<<atom tests>>=+, testGroup "ErrorName" $ commonVariantTests (arbitrary :: Gen ErrorName) +++	[ testProperty "ErrorName identity"+		$ \x -> (mkErrorName . strErrorName) x == Just x+	]++<<Tests.hs>>=+instance Arbitrary MemberName where+	arbitrary = clampedSize 255 genName mkMemberName' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = do+			x <- elements c+			xs <- sized' 0 (elements c')+			return . TL.pack $ (x:xs)++<<atom tests>>=+, testGroup "MemberName" $ commonVariantTests (arbitrary :: Gen MemberName) +++	[ testProperty "MemberName identity"+		$ \x -> (mkMemberName . strMemberName) x == Just x+	]++@ \subsubsection{Containers}++@ All variable types must obey these properties.++<<Tests.hs>>=+prop_VariantIdentity gen = testProperty "Variant identity" . forAll gen+	$ \x -> (fromVariant . toVariant) x == Just x++prop_VariantEquality gen = testProperty "Variant equality" . forAll gen+	$ \x y -> (x == y) == (toVariant x == toVariant y)++@ Since all atomic types are also variable, the Variant properties are+added to the set of common Atom tests.++<<common atom tests>>=+, prop_VariantIdentity gen+, prop_VariantEquality gen++<<Tests.hs>>=+commonVariantTests gen =+	[ prop_VariantIdentity gen+	, prop_VariantEquality gen+	]++<<Tests.hs>>=+genVariant :: Type -> Gen Variant+genVariant  DBusBoolean         = fmap toVariant (arbitrary :: Gen Bool)+genVariant  DBusByte            = fmap toVariant (arbitrary :: Gen Word8)+genVariant  DBusWord16          = fmap toVariant (arbitrary :: Gen Word16)+genVariant  DBusWord32          = fmap toVariant (arbitrary :: Gen Word32)+genVariant  DBusWord64          = fmap toVariant (arbitrary :: Gen Word64)+genVariant  DBusInt16           = fmap toVariant (arbitrary :: Gen Int16)+genVariant  DBusInt32           = fmap toVariant (arbitrary :: Gen Int32)+genVariant  DBusInt64           = fmap toVariant (arbitrary :: Gen Int64)+genVariant  DBusDouble          = fmap toVariant (arbitrary :: Gen Double)+genVariant  DBusString          = fmap toVariant (arbitrary :: Gen String)+genVariant  DBusObjectPath      = fmap toVariant (arbitrary :: Gen ObjectPath)+genVariant  DBusSignature       = fmap toVariant (arbitrary :: Gen Signature)+genVariant (DBusArray _)        = fmap toVariant (arbitrary :: Gen Array)+genVariant (DBusDictionary _ _) = fmap toVariant (arbitrary :: Gen Dictionary)+genVariant (DBusStructure _)    = fmap toVariant (arbitrary :: Gen Structure)+genVariant  DBusVariant         = fmap toVariant (arbitrary :: Gen Variant)++instance Arbitrary Variant where+	arbitrary = arbitrary >>= genVariant++<<Tests.hs>>=+genAtom :: Type -> Gen Variant+genAtom DBusBoolean    = fmap toVariant (arbitrary :: Gen Bool)+genAtom DBusByte       = fmap toVariant (arbitrary :: Gen Word8)+genAtom DBusWord16     = fmap toVariant (arbitrary :: Gen Word16)+genAtom DBusWord32     = fmap toVariant (arbitrary :: Gen Word32)+genAtom DBusWord64     = fmap toVariant (arbitrary :: Gen Word64)+genAtom DBusInt16      = fmap toVariant (arbitrary :: Gen Int16)+genAtom DBusInt32      = fmap toVariant (arbitrary :: Gen Int32)+genAtom DBusInt64      = fmap toVariant (arbitrary :: Gen Int64)+genAtom DBusDouble     = fmap toVariant (arbitrary :: Gen Double)+genAtom DBusString     = fmap toVariant (arbitrary :: Gen String)+genAtom DBusObjectPath = fmap toVariant (arbitrary :: Gen ObjectPath)+genAtom DBusSignature  = fmap toVariant (arbitrary :: Gen Signature)++<<container tests>>=+  testGroup "Variant" $ commonVariantTests (arbitrary :: Gen Variant)++<<Tests.hs>>=+instance Arbitrary Array where+	arbitrary = do+		-- Only generate arrays of atomic values, as generating+		-- containers randomly almost never results in a valid+		-- array.+		t <- atomicType+		xs <- listOf $ genVariant t+		return . fromJust $ arrayFromItems t xs++prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where+	array = arrayFromItems firstType vs+	homogeneousTypes = all (== firstType) types+	types = map variantType vs+	firstType = if null types+		then DBusByte+		else head types++<<container tests>>=+, testGroup "Array" $ commonVariantTests (arbitrary :: Gen Array) +++	[ testProperty "Array identity"+		$ \x -> Just x == arrayFromItems (arrayType x) (arrayItems x)+	, testProperty "Array homogeneity" prop_ArrayHomogeneous+	]++<<Tests.hs>>=+instance Arbitrary Dictionary where+	arbitrary = do+		-- Only generate dictionaries of atomic values, as generating+		-- containers randomly almost never results in a valid+		-- dictionary.+		kt <- atomicType+		vt <- atomicType+		ks <- listOf $ genAtom kt+		vs <- vectorOf (length ks) $ genVariant vt+		+		return . fromJust $ dictionaryFromItems kt vt $ zip ks vs++prop_DictionaryHomogeneous x = all correctType pairs where+	pairs = dictionaryItems x+	kType = dictionaryKeyType x+	vType = dictionaryValueType x+	correctType (k, v) = variantType k == kType &&+	                     variantType v == vType++<<container tests>>=+, testGroup "Dictionary" $ commonVariantTests (arbitrary :: Gen Dictionary) +++	[ testProperty "Dictionary identity"+		$ \x -> Just x == dictionaryFromItems+			(dictionaryKeyType x)+			(dictionaryValueType x)+			(dictionaryItems x)+	, testProperty "Dictionary homogeneity" prop_DictionaryHomogeneous+	, testProperty "Dictionary must have atomic keys" +		$ \vt -> forAll containerType $ \kt ->+			isNothing (dictionaryFromItems kt vt [])+	, testProperty "Dictionary <-> Array conversion"+		$ \x -> arrayToDictionary (dictionaryToArray x) == Just x+	]++<<Tests.hs>>=+instance Arbitrary Structure where+	arbitrary = sized $ \n ->+		fmap Structure $ shrinkingGen arbitrary++<<container tests>>=+, testGroup "Structure" $ commonVariantTests (arbitrary :: Gen Structure)++@ \subsection{Addresses}++<<Tests.hs>>=+singleTests :: Testable a => [a] -> [Test]+singleTests ts = singleTests' 1 ts where+	singleTests' _ []     = []+	singleTests' n (t:ts') = plusOptions (testProperty (name n) t)+	                         : singleTests' (n + 1) ts'+	+	total = length ts+	options = F.TestOptions Nothing (Just 1) Nothing Nothing+	plusOptions = F.plusTestOptions options+	name n = "Test " ++ show n ++ "/" ++ show total++<<tests>>=+, testGroup "Addresses"+	[ testProperty "Address identity"+		$ \x -> mkAddresses (strAddress x) == Just [x]+	, testProperty "Multiple addresses"+		$ \x y -> let+		joined = TL.concat [strAddress x, ";", strAddress y]+		in mkAddresses joined == Just [x, y]+	, testProperty "Ignore trailing semicolon"+		$ \x -> mkAddresses (TL.append (strAddress x) ";") == Just [x]+	, testProperty "Ignore trailing comma"+		$ \x -> let+		hasParams = not . Map.null . addressParameters $ x+		parsed = mkAddresses (TL.append (strAddress x) ",")+		in hasParams ==> parsed == Just [x]+	, testGroup "Valid addresses" $ singleTests+		[ isJust . mkAddresses $ ":"+		, isJust . mkAddresses $ "a:"+		, isJust . mkAddresses $ "a:b=c"+		, isJust . mkAddresses $ "a:;"+		, isJust . mkAddresses $ "a:;b:"+		, isJust . mkAddresses $ "a:b=c,"+		]+	, testGroup "Invalid addresses" $ singleTests+		[ isNothing . mkAddresses $ ""+		, isNothing . mkAddresses $ "a"+		, isNothing . mkAddresses $ "a:b"+		, isNothing . mkAddresses $ "a:b="+		, isNothing . mkAddresses $ "a:,"+		]+	]++<<Tests.hs>>=+instance Arbitrary Address where+	arbitrary = genAddress where+		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."+		methodChars = filter (flip notElem ":;") ['!'..'~']+		keyChars = filter (flip notElem "=;,") ['!'..'~']+		+		genMethod = sized' 0 $ elements methodChars+		genParam = do+			key <- genKey+			value <- genValue+			return . concat $ [key, "=", value]+		+		genKey = sized' 1 $ elements keyChars+		genValue = oneof [encodedValue, plainValue]+		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']+		encodedValue = do+			x1 <- genHex+			x2 <- genHex+			return ['%', x1, x2]+		plainValue = sized' 1 $ elements optional+		+		genParams = do+			params <- sized' 0 genParam+			let params' = intercalate "," params+			extraComma <- if null params+				then return ""+				else elements ["", ","]+			return $ concat [params', extraComma]+		+		genAddress = do+			m <- genMethod+			params <- genParams+			extraSemicolon <- elements ["", ";"]+			let addrStr = concat [m, ":", params, extraSemicolon]+			let Just [addr] = mkAddresses $ TL.pack addrStr+			return addr++@ \subsection{Messages}++<<Tests.hs>>=+instance Arbitrary Serial where+	arbitrary = fmap Serial arbitrary++instance Arbitrary Flag where+	arbitrary = elements [NoReplyExpected, NoAutoStart]++instance Arbitrary MethodCall where+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ MethodCall path member iface dest flags body++instance Arbitrary MethodReturn where+	arbitrary = do+		serial <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ MethodReturn serial dest flags body++instance Arbitrary Error where+	arbitrary = do+		name   <- arbitrary+		serial <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ Error name serial dest flags body++instance Arbitrary Signal where+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		flags  <- fmap Set.fromList arbitrary+		Structure body <- arbitrary+		return $ Signal path member iface dest flags body++@ \subsection{Wire format}++<<Tests.hs>>=+isRight :: Either a b -> Bool+isRight = either (const False) (const True)++prop_Unmarshal :: Endianness -> Variant -> Property+prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where+	sig = mkSignature . typeCode . variantType $ x+	Just sig' = sig+	+	bytes = runMarshal (marshal x) e+	Right bytes' = bytes+	+	valid = isJust sig && isRight bytes+	unmarshaled = runUnmarshal (unmarshal sig') e bytes'++prop_MarshalMessage e serial msg expected = valid ==> correct where+	bytes = marshalMessage e serial msg+	Right bytes' = bytes+	+	getBytes = G.getLazyByteString . fromIntegral+	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'+	+	valid = isRight bytes+	correct = unmarshaled == Right expected++prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedMethodCall serial Nothing msg++prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedMethodReturn serial Nothing msg++prop_WireError e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedError serial Nothing msg++prop_WireSignal e serial msg = prop_MarshalMessage e serial msg+	$ ReceivedSignal serial Nothing msg++<<tests>>=+, testGroup "Wire format"+	[ testProperty "Marshal -> Ummarshal" prop_Unmarshal+	, testGroup "Messages"+		[ testProperty "Method calls" prop_WireMethodCall+		, testProperty "Method returns" prop_WireMethodReturn+		, testProperty "Errors" prop_WireError+		, testProperty "Signals" prop_WireSignal+		]+	]++<<Tests.hs>>=+instance Arbitrary Endianness where+	arbitrary = elements [LittleEndian, BigEndian]++@ \subsection{Introspection}++<<tests>>=+, testGroup "Introspection"+	[ testProperty "Generate -> Parse"+		$ \x@(I.Object path _ _) -> let+		xml = I.toXML x+		Just xml' = xml+		parsed = I.fromXML path xml'+		in isJust xml ==> I.fromXML path xml' == Just x+	]++<<Tests.hs>>=+subObject :: ObjectPath -> Gen I.Object+subObject parentPath = sized $ \n -> resize (min n 4) $ do+	let nonRoot = do+		x <- arbitrary+		case strObjectPath x of+			"/" -> nonRoot+			x'  -> return x'+	+	thisPath <- nonRoot+	let path' = case strObjectPath parentPath of+		"/" -> thisPath+		x   -> TL.append x thisPath+	let path = mkObjectPath' path'+	ifaces <- arbitrary+	children <- shrinkingGen . listOf . subObject $ path+	return $ I.Object path ifaces children++instance Arbitrary I.Object where+	arbitrary = arbitrary >>= subObject++instance Arbitrary I.Interface where+	arbitrary = do+		name <- arbitrary+		methods <- arbitrary+		signals <- arbitrary+		properties <- arbitrary+		return $ I.Interface name methods signals properties++instance Arbitrary I.Method where+	arbitrary = do+		name <- arbitrary+		inParams <- arbitrary+		outParams <- arbitrary+		return $ I.Method name inParams outParams++instance Arbitrary I.Signal where+	arbitrary = do+		name <- arbitrary+		params <- arbitrary+		return $ I.Signal name params++singleType :: Gen Signature+singleType = do+	t <- arbitrary+	case mkSignature $ typeCode t of+		Just x -> return x+		Nothing -> singleType++instance Arbitrary I.Parameter where+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		return $ I.Parameter (TL.pack name) sig++instance Arbitrary I.Property where+	arbitrary = do+		name <- listOf $ arbitrary `suchThat` isPrint+		sig <- singleType+		access <- elements+			[[], [I.Read], [I.Write],+			 [I.Read, I.Write]]+		return $ I.Property (TL.pack name) sig access++@ \subsection{Other instances}++<<Tests.hs>>=+iexp :: Integral a => a -> a -> a+iexp x y = floor $ fromIntegral x ** fromIntegral y++instance Arbitrary Word8 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 8 - 1++instance Arbitrary Word16 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 16 - 1++instance Arbitrary Word32 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 32 - 1++instance Arbitrary Word64 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 64 - 1++instance Arbitrary Int16 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 16 - 1++instance Arbitrary Int32 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 32 - 1++instance Arbitrary Int64 where+	arbitrary = fmap fromIntegral gen where+		gen = choose (0, max') :: Gen Integer+		max' = iexp 2 64 - 1++instance Arbitrary T.Text where+	arbitrary = fmap T.pack arbitrary++instance Arbitrary TL.Text where+	arbitrary = fmap TL.pack arbitrary++sized' :: Int -> Gen a -> Gen [a]+sized' atLeast g = sized $ \n -> do+	n' <- choose (atLeast, max atLeast n)+	replicateM n' g++clampedSize :: Arbitrary a => Int64 -> Gen TL.Text -> (TL.Text -> a) -> Gen a+clampedSize maxSize gen f = do+	s <- gen+	if TL.length s > maxSize+		then shrinkingGen arbitrary+		else return . f $ s++shrinkingGen :: Gen a -> Gen a+shrinkingGen gen = sized $ \n -> if n > 0 then+	resize (n `div` 2) gen+	else gen+

@@ -1,107 +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/>.--}--module Tests.Address (addressProperties) where--import Control.Monad (replicateM)-import Data.List (intercalate)-import Data.Map (toList)-import Data.Maybe (isJust, isNothing)-import Test.QuickCheck-import Tests.Instances (sized')-import DBus.Address--addressProperties = concat-	[ prop_Valid-	, prop_Invalid-	, [ property prop_Identity-	  , property prop_MultipleAddresses-	  , property prop_IgnoreTrailingSemicolon-	  , property prop_IgnoreTrailingComma-	  ]-	]---- Addresses can be converted to strings and back safely-prop_Identity x = parseAddresses (strAddress x) == Just [x]---- Multiple addresses may be parsed-prop_MultipleAddresses x y = parseAddresses joined == Just [x, y] where-	joined = concat [strAddress x, ";", strAddress y]---- Trailing semicolons are ignored-prop_IgnoreTrailingSemicolon x = parseAddresses appended == Just [x] where-	appended = strAddress x ++ ";"---- Trailing commas are ignored-prop_IgnoreTrailingComma x = hasParams ==> ignoresComma where-	hasParams = not . null $ params-	ignoresComma = parseAddresses (strAddress x ++ ",") == Just [x]-	params = toList . addressParameters $ x--prop_Valid = let valid = property . isJust . parseAddresses in-	[ valid ":"-	, valid "a:"-	, valid "a:b=c"-	, valid "a:;"-	, valid "a:;b:"-	]--prop_Invalid = let invalid = property . isNothing . parseAddresses in-	[ invalid ""-	, invalid "a"-	, invalid "a:b"-	, invalid "a:b="-	]--instance Arbitrary Address where-	coarbitrary = undefined-	arbitrary = genAddress where-		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."-		methodChars = filter (flip notElem ":;") ['!'..'~']-		keyChars = filter (flip notElem "=;,") ['!'..'~']-		-		genMethod = sized' 0 $ elements methodChars-		genParam = do-			key <- genKey-			value <- genValue-			return . concat $ [key, "=", value]-		-		genKey = sized' 1 $ elements keyChars-		genValue = oneof [encodedValue, plainValue]-		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']-		encodedValue = do-			x1 <- genHex-			x2 <- genHex-			return ['%', x1, x2]-		plainValue = sized' 1 $ elements optional-		-		genParams = do-			params <- sized' 0 genParam-			let params' = intercalate "," params-			extraComma <- if null params-				then return ""-				else elements ["", ","]-			return $ concat [params', extraComma]-		-		genAddress = do-			m <- genMethod-			params <- genParams-			extraSemicolon <- elements ["", ";"]-			let addrStr = concat [m, ":", params, extraSemicolon]-			let Just [addr] = parseAddresses addrStr-			return addr-

@@ -1,223 +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/>.--}--{-# LANGUAGE RankNTypes #-}-module Tests.Containers (containerProperties) where--import Control.Arrow ((&&&))-import Data.Maybe (isJust, fromJust)-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import Test.QuickCheck--import Tests.Instances ()--import DBus.Types--containerProperties = concat-	[ forAllAtomic prop_AtomEquality-	, forAllVariable prop_VariantEquality-	-	, forAllAtomic prop_AtomWrapping0-	, forAllAtomic prop_AtomWrapping1-	, forAllVariable prop_VariantWrapping-	-	, forAllAtomic prop_AtomSignature-	, forAllAtomic prop_AtomDefaultSignature-	, forAllVariable prop_DefaultSignature-	, variantSignatureProperties-	-	, [ property prop_VariantSignatureLength-	  , property prop_VariantType-	  , property prop_AtomType-	  ]-	-	-	, [ property prop_ArrayHomogeneous-	  , property prop_DictHomogeneous0-	  , property prop_DictHomogeneous1-	  ]-	, props_EmptyArraySignature-	, props_EmptyDictionarySignature-	]---- Basic equality--prop_AtomEquality gen = forAll gen $ \x y ->-	(x == y) == (toAtom x == toAtom y)--prop_VariantEquality gen = forAll gen $ \x y ->-	(x == y) == (toVariant x == toVariant y)---- Conversion to/from/between Atom and Variant--prop_AtomWrapping0 gen = forAll gen $ \x ->-	fromAtom (toAtom x) == Just x--prop_AtomWrapping1 gen = forAll gen $ \x ->-	atomToVariant (toAtom x) == toVariant x--prop_VariantWrapping gen = forAll gen $ \x ->-	fromVariant (toVariant x) == Just x--prop_AtomSignature gen = forAll gen $ \x ->-	atomSignature (toAtom x) == variantSignature (toVariant x)--prop_AtomDefaultSignature gen = forAll gen $ \x ->-	variantSignature (toVariant x) == defaultSignature x--prop_DefaultSignature gen = forAll gen $ \x -> let-	sig = strSignature . defaultSignature $ y-	y = head [y, x]-	in not . null $ sig----- Test that signatures are set properly-sameSig :: Variable a => a -> Type -> Bool-sameSig x t = t == (variantType . toVariant) x--sameSig' :: Variable a => (a -> Signature) -> a -> Bool-sameSig' f x = f x == (variantSignature . toVariant) x--variantSignatureProperties =-	[ property $ \x -> sameSig (x :: Bool) BooleanT-	, property $ \x -> sameSig (x :: Word8) ByteT-	, property $ \x -> sameSig (x :: Word16) UInt16T-	, property $ \x -> sameSig (x :: Word32) UInt32T-	, property $ \x -> sameSig (x :: Word64) UInt64T-	, property $ \x -> sameSig (x :: Int16) Int16T-	, property $ \x -> sameSig (x :: Int32) Int32T-	, property $ \x -> sameSig (x :: Int64) Int64T-	, property $ \x -> sameSig (x :: Double) DoubleT-	, property $ \x -> sameSig (x :: String) StringT-	, property $ \x -> sameSig (x :: ObjectPath) ObjectPathT-	, property $ \x -> sameSig (x :: Signature) SignatureT-	, property $ sameSig' arraySignature-	, property $ sameSig' dictionarySignature-	, property $ sameSig' structureSignature-	, property $ \x -> sameSig (x :: Variant) VariantT-	]---- All variant signatures have one entry-prop_VariantSignatureLength x = length sig == 1 where-	sig = signatureTypes . variantSignature $ x---- variantType is a shortcut for getting the type in a variant's--- signature.-prop_VariantType x = variantType x == t where-	t = head . signatureTypes . variantSignature $ x---- Ditto atomType-prop_AtomType x = atomType x == t where-	t = head . signatureTypes . atomSignature $ x---- All items in an array have the same signature. If items do not have--- the same signature, the array can't be constructed-prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where-	array = arrayFromItems sig vs-	homogeneousTypes = if length vs > 0-		then all (== firstType) types-		else True-	types = map variantType vs-	firstType = head types-	sig = if length vs > 0-		then variantSignature (head vs)-		else mkSignature' "y"---- A dictionary must have homogeneous key and value types-prop_DictHomogeneous0 = homogeneousDict--prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let-	dict = dictionaryFromItems kSig vSig (zip ks vs)-	(kSig, vSig) = if null ks-		then (id &&& id) . mkSignature' $ "y"-		else (atomSignature (head ks), variantSignature (head vs))-	in isJust dict ==> homogeneousDict (fromJust dict)--homogeneousDict :: Dictionary -> Property-homogeneousDict x = length items > 0 ==> homogeneous where-	items = dictionaryItems x-	keys = [k | (k,_) <- items]-	values = [v | (_,v) <- items]-	-	kTypes = map atomType keys-	kFirst = head kTypes-	-	vTypes = map variantType values-	vFirst = head vTypes-	-	homogeneous = all (== kFirst) kTypes && all (== vFirst) vTypes--props_EmptyArraySignature =-	[ check ([] :: [Word8]) "ay"-	, check ([] :: [Bool]) "ab"-	, check ([] :: [Array]) "aay"-	, check ([] :: [Dictionary]) "aa{yy}"-	, check ([] :: [Structure]) "a()"-	, check ([] :: [Variant]) "av"-	]-	where check xs sig = forAll (return sig) $ checkEmptyArray xs--checkEmptyArray xs sig = arraySignature a == sig' where-	sig' = mkSignature' sig-	a = fromJust . toArray $ xs--props_EmptyDictionarySignature =-	[ check ([] :: [(Word8, Word8)]) "a{yy}"-	, check ([] :: [(Bool, Word8)]) "a{by}"-	, check ([] :: [(Bool, Array)]) "a{bay}"-	, check ([] :: [(Bool, Dictionary)]) "a{ba{yy}}"-	, check ([] :: [(Bool, Structure)]) "a{b()}"-	, check ([] :: [(Bool, Variant)]) "a{bv}"-	]-	where check xs sig = forAll (return sig) $ checkEmptyDict xs--checkEmptyDict xs sig = dictionarySignature a == sig' where-	sig' = mkSignature' sig-	a = fromJust . toDictionary $ xs---- TODO Conversion to/from array and dictionary---- TODO: container signatures---- Helper functions--forAllAtomic :: (forall a. (Show a, Arbitrary a, Atomic a, Eq a) =>-                (Gen a -> Property)) -> [Property]-forAllAtomic t =-	[ t (arbitrary :: Gen Bool)-	, t (arbitrary :: Gen Word8)-	, t (arbitrary :: Gen Word16)-	, t (arbitrary :: Gen Word32)-	, t (arbitrary :: Gen Word64)-	, t (arbitrary :: Gen Int16)-	, t (arbitrary :: Gen Int32)-	, t (arbitrary :: Gen Int64)-	, t (arbitrary :: Gen Double)-	, t (arbitrary :: Gen String)-	, t (arbitrary :: Gen ObjectPath)-	, t (arbitrary :: Gen Signature)-	]--forAllVariable :: (forall a. (Show a, Arbitrary a, Variable a, Eq a) =>-                  (Gen a -> Property)) -> [Property]-forAllVariable t = forAllAtomic t ++-	[ t (arbitrary :: Gen Array)-	, t (arbitrary :: Gen Dictionary)-	, t (arbitrary :: Gen Structure)-	, t (arbitrary :: Gen Variant)-	]

@@ -1,289 +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/>.--}--module Tests.Instances (sized') where--import Control.Monad (replicateM)-import Data.List (intercalate)-import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import Test.QuickCheck-import DBus.Types--instance Arbitrary Char where-	coarbitrary = undefined-	arbitrary = choose ('!', '~') -- TODO: unicode?--instance Arbitrary Word8 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 8 - 1--instance Arbitrary Word16 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 16 - 1--instance Arbitrary Word32 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 32 - 1--instance Arbitrary Word64 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 64 - 1--instance Arbitrary Int16 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 16 - 1--instance Arbitrary Int32 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 32 - 1--instance Arbitrary Int64 where-	coarbitrary = undefined-	arbitrary = gen where-		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)-		max' = iexp 2 64 - 1--sized' :: Int -> Gen a -> Gen [a]-sized' atLeast g = sized $ \n -> do-	n' <- choose (atLeast, max atLeast n)-	replicateM n' g--clampedSize :: Arbitrary a => Int -> Gen String -> (String -> a) -> Gen a-clampedSize maxSize gen f = do-	s <- gen-	if length s > maxSize-		then sized (\n -> resize (n `div` 2) arbitrary)-		else return . f $ s--instance Arbitrary ObjectPath where-	coarbitrary = undefined-	arbitrary = fmap mkObjectPath' path' where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"-		path = fmap (intercalate "/" . ([] :)) genElements-		path' = frequency [(1, return "/"), (9, path)]-		genElements = sized' 1 (sized' 1 (elements c))--instance Arbitrary InterfaceName where-	coarbitrary = undefined-	arbitrary = clampedSize 255 genName mkInterfaceName' where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-		c' = c ++ ['0'..'9']-		-		genName = fmap (intercalate ".") genElements-		genElements = sized' 2 genElement-		genElement = do-			x <- elements c-			xs <- sized' 0 (elements c')-			return (x:xs)-		--instance Arbitrary BusName where-	coarbitrary = undefined-	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"-		c' = c ++ ['0'..'9']-		-		unique = do-			elems' <- sized' 2 $ elems c'-			return $ ':' : intercalate "." elems'-		-		wellKnown = do-			elems' <- sized' 2 $ elems c-			return $ intercalate "." elems'-		-		elems start = do-			x <- elements start-			xs <- sized' 0 (elements c')-			return (x:xs)--instance Arbitrary MemberName where-	coarbitrary = undefined-	arbitrary = clampedSize 255 genName mkMemberName' where-		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"-		c' = c ++ ['0'..'9']-		-		genName = do-			x <- elements c-			xs <- sized' 0 (elements c')-			return (x:xs)--instance Arbitrary ErrorName where-	coarbitrary = undefined-	arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary--instance Arbitrary Type where-	coarbitrary = undefined-	arbitrary = oneof [atomicType, containerType]--instance Arbitrary Signature where-	coarbitrary = undefined-	arbitrary = clampedSize 255 genSig mkSignature' where-		genSig = fmap (concatMap typeString) arbitrary--atomicType = elements-	[ BooleanT-	, ByteT-	, UInt16T-	, UInt32T-	, UInt64T-	, Int16T-	, Int32T-	, Int64T-	, DoubleT-	, StringT-	, ObjectPathT-	, SignatureT-	]--containerType = do-	c <- choose (0,3) :: Gen Int-	case c of-		0 -> fmap ArrayT arbitrary-		1 -> do-			kt <- atomicType-			vt <- arbitrary-			return $ DictionaryT kt vt-		2 -> sized structType-		3 -> return VariantT--structType n | n >= 0 = fmap StructureT $ resize (n `div` 2) arbitrary--instance Arbitrary Atom where-	coarbitrary = undefined-	arbitrary = atomicType >>= \t -> case t of-		BooleanT    -> fmap toAtom (arbitrary :: Gen Bool)-		ByteT       -> fmap toAtom (arbitrary :: Gen Word8)-		UInt16T     -> fmap toAtom (arbitrary :: Gen Word16)-		UInt32T     -> fmap toAtom (arbitrary :: Gen Word32)-		UInt64T     -> fmap toAtom (arbitrary :: Gen Word64)-		Int16T      -> fmap toAtom (arbitrary :: Gen Int16)-		Int32T      -> fmap toAtom (arbitrary :: Gen Int32)-		Int64T      -> fmap toAtom (arbitrary :: Gen Int64)-		DoubleT     -> fmap toAtom (arbitrary :: Gen Double)-		StringT     -> fmap toAtom (arbitrary :: Gen String)-		ObjectPathT -> fmap toAtom (arbitrary :: Gen ObjectPath)-		SignatureT  -> fmap toAtom (arbitrary :: Gen Signature)--instance Arbitrary Array where-	coarbitrary = undefined-	arbitrary = do-		-- Only generate arrays of atomic values, as generating-		-- containers randomly almost never results in a valid-		-- array.-		x <- atomicType >>= \t -> case t of-			BooleanT    -> fmap toArray (arbitrary :: Gen [Bool])-			ByteT       -> fmap toArray (arbitrary :: Gen [Word8])-			UInt16T     -> fmap toArray (arbitrary :: Gen [Word16])-			UInt32T     -> fmap toArray (arbitrary :: Gen [Word32])-			UInt64T     -> fmap toArray (arbitrary :: Gen [Word64])-			Int16T      -> fmap toArray (arbitrary :: Gen [Int16])-			Int32T      -> fmap toArray (arbitrary :: Gen [Int32])-			Int64T      -> fmap toArray (arbitrary :: Gen [Int64])-			DoubleT     -> fmap toArray (arbitrary :: Gen [Double])-			StringT     -> fmap toArray (arbitrary :: Gen [String])-			ObjectPathT -> fmap toArray (arbitrary :: Gen [ObjectPath])-			SignatureT  -> fmap toArray (arbitrary :: Gen [Signature])-		-		maybe arbitrary return x--instance Arbitrary Dictionary where-	coarbitrary = undefined-	arbitrary = do-		-- Only generate dictionaries of atomic values, as generating-		-- containers randomly almost never results in a valid-		-- array.-		kt <- atomicType-		vt <- atomicType-		ks <- case kt of-			BooleanT    -> fmap (map toAtom) (arbitrary :: Gen [Bool])-			ByteT       -> fmap (map toAtom) (arbitrary :: Gen [Word8])-			UInt16T     -> fmap (map toAtom) (arbitrary :: Gen [Word16])-			UInt32T     -> fmap (map toAtom) (arbitrary :: Gen [Word32])-			UInt64T     -> fmap (map toAtom) (arbitrary :: Gen [Word64])-			Int16T      -> fmap (map toAtom) (arbitrary :: Gen [Int16])-			Int32T      -> fmap (map toAtom) (arbitrary :: Gen [Int32])-			Int64T      -> fmap (map toAtom) (arbitrary :: Gen [Int64])-			DoubleT     -> fmap (map toAtom) (arbitrary :: Gen [Double])-			StringT     -> fmap (map toAtom) (arbitrary :: Gen [String])-			ObjectPathT -> fmap (map toAtom) (arbitrary :: Gen [ObjectPath])-			SignatureT  -> fmap (map toAtom) (arbitrary :: Gen [Signature])-		vs <- case vt of-			BooleanT    -> fmap (map toVariant) (arbitrary :: Gen [Bool])-			ByteT       -> fmap (map toVariant) (arbitrary :: Gen [Word8])-			UInt16T     -> fmap (map toVariant) (arbitrary :: Gen [Word16])-			UInt32T     -> fmap (map toVariant) (arbitrary :: Gen [Word32])-			UInt64T     -> fmap (map toVariant) (arbitrary :: Gen [Word64])-			Int16T      -> fmap (map toVariant) (arbitrary :: Gen [Int16])-			Int32T      -> fmap (map toVariant) (arbitrary :: Gen [Int32])-			Int64T      -> fmap (map toVariant) (arbitrary :: Gen [Int64])-			DoubleT     -> fmap (map toVariant) (arbitrary :: Gen [Double])-			StringT     -> fmap (map toVariant) (arbitrary :: Gen [String])-			ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath])-			SignatureT  -> fmap (map toVariant) (arbitrary :: Gen [Signature])-		-		let kSig = mkSignature' . typeString $ kt-		let vSig = mkSignature' . typeString $ vt-		maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs))--instance Arbitrary Structure where-	coarbitrary = undefined-	arbitrary = sized $ \n ->-		fmap Structure $ resize (n `div` 2) arbitrary--instance Arbitrary Variant where-	coarbitrary = undefined-	arbitrary = arbitrary >>= \t -> case t of-		BooleanT          -> fmap toVariant (arbitrary :: Gen Bool)-		ByteT             -> fmap toVariant (arbitrary :: Gen Word8)-		UInt16T           -> fmap toVariant (arbitrary :: Gen Word16)-		UInt32T           -> fmap toVariant (arbitrary :: Gen Word32)-		UInt64T           -> fmap toVariant (arbitrary :: Gen Word64)-		Int16T            -> fmap toVariant (arbitrary :: Gen Int16)-		Int32T            -> fmap toVariant (arbitrary :: Gen Int32)-		Int64T            -> fmap toVariant (arbitrary :: Gen Int64)-		DoubleT           -> fmap toVariant (arbitrary :: Gen Double)-		StringT           -> fmap toVariant (arbitrary :: Gen String)-		ObjectPathT       -> fmap toVariant (arbitrary :: Gen ObjectPath)-		SignatureT        -> fmap toVariant (arbitrary :: Gen Signature)-		ArrayT _          -> fmap toVariant (arbitrary :: Gen Array)-		DictionaryT _ _   -> fmap toVariant (arbitrary :: Gen Dictionary)-		StructureT _      -> fmap toVariant (arbitrary :: Gen Structure)-		VariantT          -> fmap toVariant (arbitrary :: Gen Variant)--instance Arbitrary Endianness where-	coarbitrary = undefined-	arbitrary = elements [LittleEndian, BigEndian]--instance Arbitrary Serial where-	coarbitrary = undefined-	arbitrary = fmap Serial arbitrary--iexp :: Integral a => a -> a -> a-iexp x y = floor $ fromIntegral x ** fromIntegral y

@@ -1,60 +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/>.--}--module Tests.Marshal (marshalProperties) where--import qualified Control.Exception as E-import System.IO.Unsafe (unsafePerformIO)-import qualified Data.ByteString.Lazy as L-import Data.Word--import Test.QuickCheck-import Tests.Instances ()-import DBus.Types-import DBus.Marshal-import DBus.Unmarshal--marshalProperties :: [Property]-marshalProperties =-	[ property prop_MarshalAnyVariant-	, property prop_MarshalAtom-	, property prop_Unmarshal-	]---- Check that any variant can be marshaled successfully.-prop_MarshalAnyVariant e x = noError $ marshal e [x]---- Any atomic value should marshal to *something*-prop_MarshalAtom e x = not . L.null . marshal e $ [atomToVariant x]---- TODO: test bytes of marshaled atoms---- TODO: test bytes of marshaled containers---- Any value, when marshaled, can be unmarshaled to the same value-prop_Unmarshal e x = unmarshaled == Right [x] where-	bytes = marshal e [x]-	unmarshaled :: Either String [Variant]-	unmarshaled = unmarshal e (variantSignature x) bytes---- Helper to determine whether the given pure function raised an exception.--- No exceptions should be raised during the normal process of marshaling.-noError :: a -> Bool-noError x = unsafePerformIO $ E.catch io onError where-	onError :: E.SomeException -> IO Bool-	onError = const (return False)-	io = E.evaluate x >> return True

@@ -1,131 +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/>.--}--{-# LANGUAGE RankNTypes #-}-module Tests.Messages (messageProperties) where--import Data.Set (fromList)-import Test.QuickCheck-import Tests.Instances ()-import qualified Data.ByteString.Lazy as L-import DBus.Message-import DBus.Types--import qualified Data.Binary.Get as G--messageProperties = concat-	[ headerFieldProperties-	, forAllMessages prop_Marshal-	, [ property prop_Unmarshal0-	  , property prop_Unmarshal1-	  , property prop_Unmarshal2-	  , property prop_Unmarshal3-	  ]-	]--headerFieldProperties =-	[ property prop_HeaderFieldVariable-	]--prop_HeaderFieldVariable x = fromVariant (toVariant x) == Just x-	where types = [x :: HeaderField]--prop_Marshal gen = forAll arbitrary (\e s -> forAll gen (not . L.null . marshal e s))--prop_Unmarshal0 e s msg = checkUnmarshal expected e s msg where-	expected = ReceivedMethodCall s Nothing msg--prop_Unmarshal1 e s msg = checkUnmarshal expected e s msg where-	expected = ReceivedMethodReturn s Nothing msg--prop_Unmarshal2 e s msg = checkUnmarshal expected e s msg where-	expected = ReceivedError s Nothing msg--prop_Unmarshal3 e s msg = checkUnmarshal expected e s msg where-	expected = ReceivedSignal s Nothing msg--checkUnmarshal expected e s msg = unmarshaled == Right expected where-	bytes = marshal e s msg-	getBytes = G.getLazyByteString . fromIntegral-	unmarshaled = G.runGet (unmarshal getBytes) bytes--forAllMessages :: (forall a. (Show a, Arbitrary a, Message a, Eq a) =>-                  (Gen a -> Property)) -> [Property]-forAllMessages t =-	[ t (arbitrary :: Gen MethodCall)-	, t (arbitrary :: Gen MethodReturn)-	, t (arbitrary :: Gen Error)-	, t (arbitrary :: Gen Signal)-	]--instance Arbitrary Flag where-	coarbitrary = undefined-	arbitrary = elements [NoReplyExpected, NoAutoStart]--instance Arbitrary HeaderField where-	coarbitrary = undefined-	arbitrary = do-		x <- choose (1, 8)-		case (x :: Int) of-			1 -> fmap Path arbitrary-			2 -> fmap Interface arbitrary-			3 -> fmap Member arbitrary-			4 -> fmap ErrorName arbitrary-			5 -> fmap ReplySerial arbitrary-			6 -> fmap Destination arbitrary-			7 -> fmap Sender arbitrary-			8 -> fmap Signature arbitrary--instance Arbitrary MethodCall where-	coarbitrary = undefined-	arbitrary = do-		path   <- arbitrary-		member <- arbitrary-		iface  <- arbitrary-		dest   <- arbitrary-		flags  <- fmap fromList arbitrary-		body   <- sized (\n -> resize (n `div` 2) arbitrary)-		return $ MethodCall path member iface dest flags body--instance Arbitrary MethodReturn where-	coarbitrary = undefined-	arbitrary = do-		serial <- arbitrary-		dest   <- arbitrary-		flags  <- fmap fromList arbitrary-		body   <- sized (\n -> resize (n `div` 2) arbitrary)-		return $ MethodReturn serial dest flags body--instance Arbitrary Error where-	coarbitrary = undefined-	arbitrary = do-		name   <- arbitrary-		serial <- arbitrary-		dest   <- arbitrary-		flags  <- fmap fromList arbitrary-		body   <- sized (\n -> resize (n `div` 2) arbitrary)-		return $ Error name serial dest flags body--instance Arbitrary Signal where-	coarbitrary = undefined-	arbitrary = do-		path   <- arbitrary-		member <- arbitrary-		iface  <- arbitrary-		flags  <- fmap fromList arbitrary-		body   <- sized (\n -> resize (n `div` 2) arbitrary)-		return $ Signal path member iface flags body

@@ -1,168 +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/>.--}--module Tests.MiscTypes (miscTypeProperties) where--import Data.Maybe (isNothing)-import Data.Word (Word8)-import Test.QuickCheck-import Tests.Instances ()-import DBus.Types--miscTypeProperties = concat-	[ objectPathProperties-	, interfaceNameProperties-	, busNameProperties-	, memberNameProperties-	, errorNameProperties-	, endiannessProperties-	, serialProperties-	]--prop_Equality x = x == x--prop_IsVariable x = fromVariant (toVariant x) == Just x--prop_IsAtomic x = fromAtom (toAtom x) == Just x---- Object paths--objectPathProperties =-	[ property (prop_Equality :: ObjectPath -> Bool)-	, property (prop_IsVariable :: ObjectPath -> Bool)-	, property (prop_IsAtomic :: ObjectPath -> Bool)-	, property prop_ObjectPathIdentity-	] ++ map property prop_ObjectPathInvalid--prop_ObjectPathIdentity x = mkObjectPath (strObjectPath x) == Just x--prop_ObjectPathInvalid = let invalid = isNothing . mkObjectPath in -	[ invalid ""-	, invalid "a"-	, invalid "/a/"-	, invalid "/a/-"-	]---- Endianness--endiannessProperties =-	[ property (prop_Equality :: Endianness -> Bool)-	, property prop_EndianToVariant-	, property prop_EndianFromVariant-	]--prop_EndianToVariant x@(LittleEndian) = toVariant x == toVariant (0x6C :: Word8)-prop_EndianToVariant x@(BigEndian) = toVariant x == toVariant (0x42 :: Word8)--endianWords :: Gen Word8-endianWords = oneof [ return 0x6C , return 0x42 , arbitrary]--prop_EndianFromVariant = forAll endianWords $ \x -> let-	v = fromVariant (toVariant x) in case x of-		0x6C -> v == Just LittleEndian-		0x42 -> v == Just BigEndian-		_    -> isNothing v---- Interface names--interfaceNameProperties =-	[ property (prop_Equality :: InterfaceName -> Bool)-	, property (prop_IsVariable :: InterfaceName -> Bool)-	, property (prop_IsAtomic :: InterfaceName -> Bool)-	, property prop_InterfaceNameIdentity-	] ++ map property prop_InterfaceNameInvalid--prop_InterfaceNameIdentity x = mkInterfaceName (strInterfaceName x) == Just x--prop_InterfaceNameInvalid = let invalid = isNothing . mkInterfaceName in -	[ invalid ""-	, invalid "0"-	, invalid "a"-	, invalid "a."-	, invalid "a.1"-	, invalid $ "a." ++ replicate 255 'b'-	]---- Bus names--busNameProperties =-	[ property (prop_Equality :: BusName -> Bool)-	, property (prop_IsVariable :: BusName -> Bool)-	, property (prop_IsAtomic :: BusName -> Bool)-	, property prop_BusNameIdentity-	] ++ map property prop_BusNameInvalid--prop_BusNameIdentity x = mkBusName (strBusName x) == Just x--prop_BusNameInvalid = let invalid = isNothing . mkBusName in -	[ invalid ""-	, invalid ":"-	, invalid ":0"-	, invalid ":a"-	, invalid "0"-	, invalid "a"-	, invalid "a."-	, invalid "a.1"-	, invalid $ "a." ++ replicate 255 'b'-	]---- Member names--memberNameProperties =-	[ property (prop_Equality :: MemberName -> Bool)-	, property (prop_IsVariable :: MemberName -> Bool)-	, property (prop_IsAtomic :: MemberName -> Bool)-	, property prop_MemberNameIdentity-	] ++ map property prop_MemberNameInvalid--prop_MemberNameIdentity x = mkMemberName (strMemberName x) == Just x--prop_MemberNameInvalid = let invalid = isNothing . mkMemberName in -	[ invalid ""-	, invalid "0"-	, invalid $ replicate 256 'a'-	]---- Error names--errorNameProperties =-	[ property (prop_Equality :: ErrorName -> Bool)-	, property (prop_IsVariable :: ErrorName -> Bool)-	, property (prop_IsAtomic :: ErrorName -> Bool)-	, property prop_ErrorNameIdentity-	] ++ map property prop_ErrorNameInvalid--prop_ErrorNameIdentity x = mkErrorName (strErrorName x) == Just x--prop_ErrorNameInvalid = let invalid = isNothing . mkErrorName in -	[ invalid ""-	, invalid "0"-	, invalid "a"-	, invalid "a."-	, invalid "a.1"-	, invalid $ "a." ++ replicate 255 'b'-	]---- Serials--serialProperties = -	[ property (prop_IsVariable :: Serial -> Bool)-	, property (prop_IsAtomic :: Serial -> Bool)-	, property prop_SerialIncremented-	]--prop_SerialIncremented x = nextSerial x > x

@@ -1,64 +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/>.--}--module Tests.Signature (signatureProperties) where--import Data.Maybe (isJust, isNothing)-import Test.QuickCheck-import Tests.Instances ()-import DBus.Types--signatureProperties =-	[ property (prop_Equality :: Signature -> Bool)-	, property (prop_Equality :: Type -> Bool)-	, property prop_TypeToSig-	, property prop_Ident-	, property prop_Length0-	, property prop_Length254-	, property prop_Length255-	, property prop_Length256-	, property prop_Invalid0-	, property prop_Invalid1-	, property prop_Invalid2-	, property prop_show0-	, property prop_show1-	]---- Signatures and type equality-prop_Equality x = x == x---- Types can be converted to signatures via mkSignature-prop_TypeToSig x = typeString x == strSignature sig where-	Just sig = mkSignature (typeString x)---- Signatures can be safely converted to strings and back-prop_Ident x = mkSignature (strSignature x) == Just x---- Signatures may be no more than 255 characters long-prop_Length0   = isJust    . mkSignature $ ""-prop_Length254 = isJust    . mkSignature . replicate 254 $ 'y'-prop_Length255 = isJust    . mkSignature . replicate 255 $ 'y'-prop_Length256 = isNothing . mkSignature . replicate 256 $ 'y'---- Invalid signatures are not parsed-prop_Invalid0 = isNothing . mkSignature $ "a"-prop_Invalid1 = isNothing . mkSignature $ "0"-prop_Invalid2 = isNothing . mkSignature $ "a{vy}"---- Show is useful-prop_show0 x = showsPrec 10 x "" == "Signature \"" ++ strSignature x ++ "\""-prop_show1 x = showsPrec 11 x "" == "(Signature \"" ++ strSignature x ++ "\")"

@@ -1,6 +1,6 @@ name: dbus-core-version: 0.4-synopsis: Low-level DBus protocol implementation+version: 0.5+synopsis: Low-level D-Bus protocol implementation license: GPL license-file: License.txt author: John Millikin@@ -12,17 +12,24 @@ bug-reports: mailto:jmillikin@gmail.com  extra-source-files:-  dbus-core.tex+  dbus-core.nw   Examples/*.hs-  Tests/*.hs-  Tests.hs+  Makefile+  Tests.nw  source-repository head   type: darcs   location: http://patch-tag.com/r/jmillikin/dbus-core/pullrepo +flag test+  default: False++flag hpc+  default: False+ library   ghc-options: -Wall+  hs-source-dirs: hs    build-depends:     base >=4 && < 5,@@ -30,7 +37,9 @@     binary,     bytestring,     data-binary-ieee754 >= 0.3,-    utf8-string,+    HaXml >= 1.19.7,+    pretty,+    text,     mtl,     containers,     unix,@@ -41,23 +50,36 @@     DBus.Bus     DBus.Connection     DBus.Constants+    DBus.Introspection     DBus.Message     DBus.Types    other-modules:-    DBus.Authentication-    DBus.Types.Atom-    DBus.Types.Containers-    DBus.Types.Containers.Array-    DBus.Types.Containers.Dictionary-    DBus.Types.Containers.Structure-    DBus.Types.Containers.Variant-    DBus.Types.Endianness-    DBus.Types.Names-    DBus.Types.ObjectPath-    DBus.Types.Serial-    DBus.Types.Signature-    DBus.Marshal-    DBus.Padding-    DBus.Unmarshal+    DBus.Message.Internal+    DBus.Wire     DBus.Util++executable tests+  main-is: Tests.hs+  hs-source-dirs: hs++  if flag(test)+    build-depends:+        QuickCheck >= 2+      , test-framework+      , test-framework-quickcheck2+  else+    buildable: False++  if flag(hpc)+    ghc-options: -fhpc++  other-modules:+    DBus.Address+    DBus.Constants+    DBus.Introspection+    DBus.Message+    DBus.Types+    DBus.Wire+    DBus.Util+

@@ -0,0 +1,3085 @@++% 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{booktabs}+\usepackage{multirow}+\usepackage{noweb}+\usepackage{url}++% 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}++D-Bus is a low-latency, asynchronous IPC protocol. It is primarily used on+Linux, BSD, and other free UNIX-like systems. More information is available+at \url{http://dbus.freedesktop.org/}.++This package is an implementation of the D-Bus protocol. It is intended+for use in either a client or server, though currently only the client+portion of connection establishment is implemented. Additionally, it+implements the introspection file format.++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{Text values}++Most of the functions in this library use the types and functions defined+in {\tt Data.Text}, in preference to the {\tt String} type.++<<text extensions>>=+{-# LANGUAGE OverloadedStrings #-}++<<text imports>>=+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++@+\section{Types}++The {\tt DBus.Types module} defines interfaces for storing, building, and+deconstructing D-Bus values.++<<DBus/Types.hs>>=+<<copyright>>+<<text extensions>>+<<type extensions>>+module DBus.Types (<<type exports>>) where+<<text imports>>+<<type imports>>++@ DBus types are divided into two categories, ``atomic'' and ``container''+types. Atoms are actual values -- strings, numbers, etc. Containers store+atoms and other containers. The most interesting difference between the two+is that atoms may be used as the keys in associative mappings+(``dictionaries'').++Internally, types are represented using an enumeration.++<<DBus/Types.hs>>=+data Type+	= DBusBoolean+	| DBusByte+	| DBusInt16+	| DBusInt32+	| DBusInt64+	| DBusWord16+	| DBusWord32+	| DBusWord64+	| DBusDouble+	| DBusString+	| DBusSignature+	| DBusObjectPath+	| DBusVariant+	| DBusArray Type+	| DBusDictionary Type Type+	| DBusStructure [Type]+	deriving (Show, Eq)++<<DBus/Types.hs>>=+isAtomicType :: Type -> Bool+isAtomicType DBusBoolean    = True+isAtomicType DBusByte       = True+isAtomicType DBusInt16      = True+isAtomicType DBusInt32      = True+isAtomicType DBusInt64      = True+isAtomicType DBusWord16     = True+isAtomicType DBusWord32     = True+isAtomicType DBusWord64     = True+isAtomicType DBusDouble     = True+isAtomicType DBusString     = True+isAtomicType DBusSignature  = True+isAtomicType DBusObjectPath = True+isAtomicType _              = False++@ Each type can be converted to a textual representation, used in ``type+signatures'' or for debugging.++<<DBus/Types.hs>>=+typeCode :: Type -> Text++<<type exports>>=+  -- * Available types+  Type (..)+, typeCode++@ Certain Haskell types are considered ``built-in'' D-Bus types; that is,+they are directly represented in the D-Bus protocol.++<<DBus/Types.hs>>=+class (Show a, Eq a) => Builtin a where+	builtinDBusType :: a -> Type++@ \subsection{Variants}++A wrapper type is needed for safely storing generic D-Bus values in Haskell.+The D-Bus ``variant'' type is perfect for this, because variants may store+any D-Bus value.++To cleanly store any D-Bus type, without exposing the internal storage+mechanism, requires existential quantification and some run-time casting.++<<type extensions>>=+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ExistentialQuantification #-}++<<type imports>>=+import Data.Typeable (Typeable, cast)++@ Any type which is an instance of {\tt Variable} is considered a valid+D-Bus value, because it can be used to construct {\tt Variant}s. However,+outside of this module, {\tt Variant}s can only be constructed from+pre-defined types.++<<DBus/Types.hs>>=+data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a+	deriving (Typeable)++class Variable a where+	toVariant :: a -> Variant+	fromVariant :: Variant -> Maybe a++<<type exports>>=+  -- * Variants+, Variant+, Variable (..)++@ Variants can be printed, for debugging purposes -- this instance shouldn't+be parsed or inspected or anything like that, since the output format might+change drastically.++<<DBus/Types.hs>>=+instance Show Variant where+	showsPrec d (Variant x) = showParen (d > 10) $+		s "Variant " . shows code . s " " . showsPrec 11 x+		where code = typeCode . builtinDBusType $ x+		      s    = showString++@ In the test suite, it's useful to test that two variants have the same+value.++<<DBus/Types.hs>>=+instance Eq Variant where+	(Variant x) == (Variant y) = cast x == Just y++@ Since many operations on D-Bus values depend on having the correct type,+{\tt variantType} is used to retrieve which type is actually stored within+a {\tt Variant}.++<<DBus/Types.hs>>=+variantType :: Variant -> Type+variantType (Variant x) = builtinDBusType x++<<type exports>>=+, variantType++@ These helper macros will be used for defining instances of Haskell types.++<<DBus/Types.hs>>=+#define INSTANCE_BUILTIN(HASKELL, DBUS) \+	instance Builtin HASKELL where \+		{ builtinDBusType _ = DBUS };++#define INSTANCE_VARIABLE(HASKELL) \+	instance Variable HASKELL where \+		{ toVariant = Variant \+		; fromVariant (Variant x) = cast x };++#define BUILTIN_VARIABLE(HASKELL, DBUS) \+	INSTANCE_BUILTIN(HASKELL, DBUS) \+	INSTANCE_VARIABLE(HASKELL)++@ Since {\tt Variant}s are D-Bus values themselves, they have a type.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Variant, DBusVariant)++@ \subsection{Numerics}++D-Bus supports most common numeric types:++\begin{table}[h]+\caption{D-Bus Numeric types}+\begin{center}+\begin{tabular}{ll}+\toprule+Type        & Description \\+\midrule+Boolean     & Either {\tt True} or {\tt False} \\+Byte        & 8-bit unsigned integer \\+Int16       & 16-bit signed integer \\+Int32       & 32-bit signed integer \\+Int64       & 64-bit signed integer \\+Word16      & 16-bit unsigned integer \\+Word32      & 32-bit unsigned integer \\+Word64      & 64-bit unsigned integer \\+Double      & 64-bit IEEE754 floating-point \\+\bottomrule+\end{tabular}+\end{center}+\end{table}++All D-Bus numeric types are fixed-length, so the {\tt Int} and {\tt Integer}+types can't be used. Instead, instances for the fixed-length integer types+are defined and any others will have to be converted.++<<type imports>>=+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Bool,   DBusBoolean)+BUILTIN_VARIABLE(Word8,  DBusByte)+BUILTIN_VARIABLE(Int16,  DBusInt16)+BUILTIN_VARIABLE(Int32,  DBusInt32)+BUILTIN_VARIABLE(Int64,  DBusInt64)+BUILTIN_VARIABLE(Word16, DBusWord16)+BUILTIN_VARIABLE(Word32, DBusWord32)+BUILTIN_VARIABLE(Word64, DBusWord64)+BUILTIN_VARIABLE(Double, DBusDouble)++@ \subsection{Strings}++Strings are a weird case; the built-in type, {\tt String}, is horribly+inefficent. To provide better performance for large strings, packed Unicode+strings defined in {\tt Data.Text} are used internally.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(TL.Text, DBusString)++@ There's two different {\tt Text} types, strict and lazy. It'd be a pain+to store both and have to convert later, so instead, all strict {\tt Text}+values are converted to lazy values.++<<type imports>>=+import qualified Data.Text as T++<<DBus/Types.hs>>=+instance Variable T.Text where+	toVariant = toVariant . TL.fromChunks . (:[])+	fromVariant = fmap (T.concat . TL.toChunks) . fromVariant++@ Built-in {\tt String}s can still be stored, of course, but it requires+a language extension.++<<type extensions>>=+{-# LANGUAGE TypeSynonymInstances #-}++<<DBus/Types.hs>>=+instance Variable String where+	toVariant = toVariant . TL.pack+	fromVariant = fmap TL.unpack . fromVariant++@ \subsection{Signatures}++@ Valid DBus types must obey certain rules, such as ``dict keys must be+atomic'', which are difficult to express in the Haskell type system.  A+{\tt Signature} is guaranteed to be valid according to these rules. Creating+one requires using the {\tt mkSignature} function, which will convert a valid+DBus signature string into a {\tt Signature}.++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(Signature, DBusSignature)+data Signature = Signature { signatureTypes :: [Type] }+	deriving (Eq, Typeable)++instance Show Signature where+	showsPrec d x = showParen (d > 10) $+		showString "Signature " . shows (strSignature x)++@ Signatures can also be converted back into text, by concatenating the+type codes of their contained types.++<<DBus/Types.hs>>=+strSignature :: Signature -> Text+strSignature (Signature ts) = TL.concat $ map typeCode ts++@ It doesn't make much sense to sort signatures, but since they can be used+as dictionary keys, it's useful to have them as an instance of {\tt Ord}.++<<DBus/Types.hs>>=+instance Ord Signature where+	compare x y = compare (strSignature x) (strSignature y)++<<type exports>>=+  -- * Signatures+, Signature+, signatureTypes+, strSignature++@ \subsubsection{Type codes}++@ For atomic types, the type code is a single letter. Arrays, structures,+and dictionary types are multiple characters.++<<DBus/Types.hs>>=+typeCode DBusBoolean    = "b"+typeCode DBusByte       = "y"+typeCode DBusInt16      = "n"+typeCode DBusInt32      = "i"+typeCode DBusInt64      = "x"+typeCode DBusWord16     = "q"+typeCode DBusWord32     = "u"+typeCode DBusWord64     = "t"+typeCode DBusDouble     = "d"+typeCode DBusString     = "s"+typeCode DBusSignature  = "g"+typeCode DBusObjectPath = "o"+typeCode DBusVariant    = "v"++@ An array's type code is ``a'' followed by the type it contains. For example,+an array of booleans would have the type string ``ab''.++<<DBus/Types.hs>>=+typeCode (DBusArray t) = TL.cons 'a' $ typeCode t++@ A dictionary's type code is ``a\{$key\_type$ $value\_type$\}''. For example,+a dictionary of bytes to booleans would have the type string ``a{yb}''.++<<DBus/Types.hs>>=+typeCode (DBusDictionary k v) = TL.concat ["a{", typeCode k, typeCode v, "}"]++@ A structure's type code is the concatenation of its contained types,+wrapped by ``('' and ``)''. Structures may be empty, in which case their+type code is simply ``()''.++<<DBus/Types.hs>>=+typeCode (DBusStructure ts) = TL.concat $+	["("] ++ map typeCode ts ++ [")"]++@ \subsubsection{Parsing}++When parsing, additional restrictions apply which are not inherent to the+D-Bus type system:++\begin{itemize}+\item Signatures may be at most 255 characters long.+\end{itemize}++Parsec is used to parse signatures.++<<type imports>>=+import Text.Parsec ((<|>))+import qualified Text.Parsec as P+import DBus.Util (checkLength, parseMaybe)++<<DBus/Types.hs>>=+mkSignature :: Text -> Maybe Signature+mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where+	sigParser = do+		types <- P.many parseType+		P.eof+		return $ Signature types+	parseType = parseAtom <|> parseContainer+	parseContainer =+		    parseArray+		<|> parseStruct+		<|> (P.char 'v' >> return DBusVariant)+	parseAtom =+		    (P.char 'b' >> return DBusBoolean)+		<|> (P.char 'y' >> return DBusByte)+		<|> (P.char 'n' >> return DBusInt16)+		<|> (P.char 'i' >> return DBusInt32)+		<|> (P.char 'x' >> return DBusInt64)+		<|> (P.char 'q' >> return DBusWord16)+		<|> (P.char 'u' >> return DBusWord32)+		<|> (P.char 't' >> return DBusWord64)+		<|> (P.char 'd' >> return DBusDouble)+		<|> (P.char 's' >> return DBusString)+		<|> (P.char 'g' >> return DBusSignature)+		<|> (P.char 'o' >> return DBusObjectPath)+	parseArray = do+		P.char 'a'+		parseDict <|> do+		t <- parseType+		return $ DBusArray t+	parseDict = do+		P.char '{'+		keyType <- parseAtom+		valueType <- parseType+		P.char '}'+		return $ DBusDictionary keyType valueType+	parseStruct = do+		P.char '('+		types <- P.many parseType+		P.char ')'+		return $ DBusStructure types++@ Since many signatures are defined as string literals, it's useful to+have a helper function to construct a signature directly from a string.+If the input string is invalid, {\tt error} will be called.++<<type imports>>=+import DBus.Util (mkUnsafe)++<<DBus/Types.hs>>=+mkSignature' :: Text -> Signature+mkSignature' = mkUnsafe "signature" mkSignature++@ Most signature-related functions are exposed to clients, except the+{\tt Signature} value constructor. If that were exposed, clients could+construct invalid signatures.++<<type exports>>=+, mkSignature+, mkSignature'++@ \subsection{Object paths}++<<DBus/Types.hs>>=+BUILTIN_VARIABLE(ObjectPath, DBusObjectPath)+newtype ObjectPath = ObjectPath+	{ strObjectPath :: Text+	}+	deriving (Show, Eq, Ord, Typeable)++@ An object path may be one of++\begin{itemize}+\item The root path, {\tt "/"}.+\item {\tt '/'}, followed by one or more element names. Each element name+      contains characters in the set {\tt [a-zA-Z0-9\_]}, and must have at+      least one character.+\end{itemize}++Element names are separated by {\tt '/'}, and the path may not end in+{\tt '/'} unless it is the root path.++<<DBus/Types.hs>>=+mkObjectPath :: Text -> Maybe ObjectPath+mkObjectPath s = parseMaybe path' (TL.unpack s) where+	c = P.oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+	path = P.char '/' >>= P.optional . P.sepBy (P.many1 c) . P.char+	path' = path >> P.eof >> return (ObjectPath s)++mkObjectPath' :: Text -> ObjectPath+mkObjectPath' = mkUnsafe "object path" mkObjectPath++<<type exports>>=+  -- * Object paths+, ObjectPath+, strObjectPath+, mkObjectPath+, mkObjectPath'++@ \subsection{Arrays}++Arrays are homogenous sequences of any valid DBus type. Arrays might be+empty, so the type they contain is stored instead of being calculated from+their contents (as in {\tt variantType}).++TODO: There ought to be a specialised constructor for arrays of bytes, based+on the {\tt ByteString} type. Storing bytes individually in a list of+{\tt Variant}s is inefficient.++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Array)+data Array = Array+	{ arrayType  :: Type+	, arrayItems :: [Variant]+	}+	deriving (Eq, Typeable)++instance Builtin Array where+	builtinDBusType = DBusArray . arrayType++<<type exports>>=+  -- * Arrays+, Array+, arrayType+, arrayItems++@ Like {\tt Variant}, deriving {\tt Show} for {\tt Array} is mostly+just useful for debugging.++<<DBus/Types.hs>>=+instance Show Array where+	showsPrec d (Array t vs) = showParen (d > 10) $+		s "Array " . showSig . s " [" . s valueString . s "]" where+			s = showString+			showSig = shows $ typeCode t+			vs' = [show x | (Variant x) <- vs]+			valueString = intercalate ", " vs'++@ Clients constructing an array must provide the expected item type, which+will be checked for validity. Every item in the array will be checked against+the item type, to ensure the array is homogenous.++<<DBus/Types.hs>>=+arrayFromItems :: Type -> [Variant] -> Maybe Array+arrayFromItems t vs = do+	mkSignature (typeCode t)+	if all (\x -> variantType x == t) vs+		then Just $ Array t vs+		else Nothing++@ Additionally, for ease of use, an {\tt Array} can be converted directly+to/from lists of {\tt Variable} values.++<<DBus/Types.hs>>=+toArray :: Variable a => Type -> [a] -> Maybe Array+toArray t = arrayFromItems t . map toVariant++fromArray :: Variable a => Array -> Maybe [a]+fromArray = mapM fromVariant . arrayItems++<<type exports>>=+, toArray+, fromArray+, arrayFromItems++@ \subsection{Dictionaries}++Dictionaries are a homogenous (key $\rightarrow$ value) mapping, where the+key type must be atomic. Values may be of any valid DBus type. Like+{\tt Array}, {\tt Dictionary} stores its contained types.++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Dictionary)+data Dictionary = Dictionary+	{ dictionaryKeyType   :: Type+	, dictionaryValueType :: Type+	, dictionaryItems     :: [(Variant, Variant)]+	}+	deriving (Eq, Typeable)++instance Builtin Dictionary where+	builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt++<<type exports>>=+  -- * Dictionaries+, Dictionary+, dictionaryItems+, dictionaryKeyType+, dictionaryValueType++@ {\tt show}ing a {\tt Dictionary} displays the mapping in a more readable+format than a list of pairs.++<<type imports>>=+import Data.List (intercalate)++<<DBus/Types.hs>>=+instance Show Dictionary where+	showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $+		s "Dictionary " . showSig . s " {" . s valueString . s "}" where+			s = showString+			showSig = shows $ TL.append (typeCode kt) (typeCode vt)+			valueString = intercalate ", " $ map showPair pairs+			showPair ((Variant k), (Variant v)) =+				show k ++ " -> " ++ show v++@ Constructing a {\tt Dictionary} works like constructing an {\tt Array},+except that there are two types to check, and the key type must be atomic.++<<type imports>>=+import Control.Monad (unless)++<<DBus/Types.hs>>=+dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary+dictionaryFromItems kt vt pairs = do+	unless (isAtomicType kt) Nothing+	mkSignature (typeCode kt)+	mkSignature (typeCode vt)+	+	let sameType (k, v) = variantType k == kt &&+	                      variantType v == vt+	if all sameType pairs+		then Just $ Dictionary kt vt pairs+		else Nothing++@ The closest match for dictionary semantics in Haskell is the+{\tt Data.Map.Map} type. Therefore, the utility conversion functions work+with {\tt Map}s instead of pair lists.++<<type imports>>=+import Control.Arrow ((***))+import qualified Data.Map as Map++<<DBus/Types.hs>>=+toDictionary :: (Variable a, Variable b) => Type -> Type -> Map.Map a b+             -> Maybe Dictionary+toDictionary kt vt = dictionaryFromItems kt vt . pairs where+	pairs = map (toVariant *** toVariant) . Map.toList++<<type imports>>=+import Control.Monad (forM)++<<DBus/Types.hs>>=+fromDictionary :: (Variable a, Ord a, Variable b) => Dictionary+               -> Maybe (Map.Map a b)+fromDictionary (Dictionary _ _ vs) = do+	pairs <- forM vs $ \(k, v) -> do+		k' <- fromVariant k+		v' <- fromVariant v+		return (k', v')+	return $ Map.fromList pairs++<<type exports>>=+, toDictionary+, fromDictionary+, dictionaryFromItems++@ \subsubsection{Converting between {\tt Array} and {\tt Dictionary}}++Converting between {\tt Array} and {\tt Dictionary} is useful when+(un)marshaling -- dictionaries can be thought of as arrays of two-element+structures, much as a {\tt Map} is a list of pairs.++<<DBus/Types.hs>>=+dictionaryToArray :: Dictionary -> Array+dictionaryToArray (Dictionary kt vt items) = array where+	Just array = toArray itemType structs+	itemType = DBusStructure [kt, vt]+	structs = [Structure [k, v] | (k, v) <- items]++<<DBus/Types.hs>>=+arrayToDictionary :: Array -> Maybe Dictionary+arrayToDictionary (Array t items) = do+	let toPair x = do+		struct <- fromVariant x+		case struct of+			Structure [k, v] -> Just (k, v)+			_                -> Nothing+	(kt, vt) <- case t of+		DBusStructure [kt, vt] -> Just (kt, vt)+		_                      -> Nothing+	pairs <- mapM toPair items+	dictionaryFromItems kt vt pairs++<<type exports>>=+, dictionaryToArray+, arrayToDictionary++@ \subsection{Structures}++A heterogeneous, fixed-length container; equivalent in purpose to a Haskell+tuple.++<<DBus/Types.hs>>=+INSTANCE_VARIABLE(Structure)+data Structure = Structure [Variant]+	deriving (Show, Eq, Typeable)++instance Builtin Structure where+	builtinDBusType (Structure vs) = DBusStructure $ map variantType vs++<<type exports>>=+  -- * Structures+, Structure (..)++@ \subsection{Names}++Various aspects of DBus require the use of specially-formatted strings,+called ``names''. All names are limited to 255 characters, and use subsets+of ASCII.++Since all names have basically the same structure (a {\tt newtype}+declaration and some helper functions), I define a macro to automate+the definitions.++<<DBus/Types.hs>>=+#define NAME_TYPE(TYPE, NAME) \+	newtype TYPE = TYPE {str##TYPE :: Text} \+		deriving (Show, Eq, Ord); \+		                          \+	instance Variable TYPE where \+		{ toVariant = toVariant . str##TYPE \+		; fromVariant = (mk##TYPE =<<) . fromVariant }; \+		                                                \+	mk##TYPE##' :: Text -> TYPE; \+	mk##TYPE##' = mkUnsafe NAME mk##TYPE++<<type exports>>=+-- * Names++@ \subsubsection{Bus names}++There are two forms of bus names, ``unique'' and ``well-known''.++Unique names begin with {\tt `:'} and contain two or more elements, separated+by {\tt `.'}. Each element consists of characters from the set+{\tt [a-zA-Z0-9\_-]}.++Well-known names contain two or more elements, separated by {\tt `.'}. Each+element consists of characters from the set {\tt [a-zA-Z0-9\_-]}, and must+not start with a digit.++<<DBus/Types.hs>>=+NAME_TYPE(BusName, "bus name")++mkBusName :: Text -> Maybe BusName+mkBusName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+	c' = c ++ ['0'..'9']+	parser = (unique <|> wellKnown) >> P.eof >> return (BusName s)+	unique = P.char ':' >> elems c'+	wellKnown = elems c+	elems start = elem' start >> P.many1 (P.char '.' >> elem' start)+	elem' start = P.oneOf start >> P.many (P.oneOf c')++<<type exports>>=+  -- ** Bus names+, BusName+, strBusName+, mkBusName+, mkBusName'++@ \subsubsection{Interface names}++An interface name consists of two or more {\tt '.'}-separated elements. Each+element constists of characters from the set {\tt [a-zA-Z0-9\_]}, may not+start with a digit, and must have at least one character.++<<DBus/Types.hs>>=+NAME_TYPE(InterfaceName, "interface name")++mkInterfaceName :: Text -> Maybe InterfaceName+mkInterfaceName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	element = P.oneOf c >> P.many (P.oneOf c')+	name = element >> P.many1 (P.char '.' >> element)+	parser = name >> P.eof >> return (InterfaceName s)++<<type exports>>=+  -- ** Interface names+, InterfaceName+, strInterfaceName+, mkInterfaceName+, mkInterfaceName'++@ \subsubsection{Error names}++Error names have the same format as interface names, so the parser logic+can just be re-purposed.++<<DBus/Types.hs>>=+NAME_TYPE(ErrorName, "error name")++mkErrorName :: Text -> Maybe ErrorName+mkErrorName = fmap (ErrorName . strInterfaceName) . mkInterfaceName++<<type exports>>=+  -- ** Error names+, ErrorName+, strErrorName+, mkErrorName+, mkErrorName'++@ \subsubsection{Member names}++Member names must contain only characters from the set {\tt [a-zA-Z0-9\_]},+may not begin with a digit, and must be at least one character long.++<<DBus/Types.hs>>=+NAME_TYPE(MemberName, "member name")++mkMemberName :: Text -> Maybe MemberName+mkMemberName s = checkLength 255 (TL.unpack s) >>= parseMaybe parser where+	c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+	c' = c ++ ['0'..'9']+	name = P.oneOf c >> P.many (P.oneOf c')+	parser = name >> P.eof >> return (MemberName s)++<<type exports>>=+  -- ** Member names+, MemberName+, strMemberName+, mkMemberName+, mkMemberName'++@+\section{Messages}++@ To prevent internal details of messages from leaking out to clients,+declarations are contained in an internal module and then re-exported+in the public module.++<<DBus/Message.hs>>=+<<copyright>>+module DBus.Message+	(<<message exports>>+	) where+import DBus.Message.Internal++<<DBus/Message/Internal.hs>>=+<<copyright>>+module DBus.Message.Internal where+import qualified Data.Set as S+import Data.Word (Word8, Word32)+import qualified DBus.Types as T++<<DBus/Message/Internal.hs>>=+class Message a where+	messageTypeCode     :: a -> Word8+	messageHeaderFields :: a -> [HeaderField]+	messageFlags        :: a -> S.Set Flag+	messageBody         :: a -> [T.Variant]++<<message exports>>=+Message ( messageFlags+        , messageBody+        )++@ \subsection{Flags}++The instance of {\tt Ord} only exists for storing flags in a set. Flags have+no inherent ordering.++<<DBus/Message/Internal.hs>>=+data Flag+	= NoReplyExpected+	| NoAutoStart+	deriving (Show, Eq, Ord)++<<message exports>>=+, Flag (..)++@ \subsection{Header fields}++<<DBus/Message/Internal.hs>>=+data HeaderField+	= Path        T.ObjectPath+	| Interface   T.InterfaceName+	| Member      T.MemberName+	| ErrorName   T.ErrorName+	| ReplySerial Serial+	| Destination T.BusName+	| Sender      T.BusName+	| Signature   T.Signature+	deriving (Show, Eq)++@ \subsection{Serials}++{\tt Serial} is just a wrapper around {\tt Word32}, to provide a bit of+added type-safety.++<<DBus/Message/Internal.hs>>=+newtype Serial = Serial { serialValue :: Word32 }+	deriving (Eq, Ord)++instance Show Serial where+	show (Serial x) = show x++instance T.Variable Serial where+	toVariant (Serial x) = T.toVariant x+	fromVariant = fmap Serial . T.fromVariant++@ Additionally, some useful functions exist for incrementing serials.++<<DBus/Message/Internal.hs>>=+firstSerial :: Serial+firstSerial = Serial 1++nextSerial :: Serial -> Serial+nextSerial (Serial x) = Serial (x + 1)++@ The {\tt Serial} constructor isn't useful to clients, because building+arbitrary serials doesn't make any sense.++<<message exports>>=+, Serial+, serialValue++@ \subsection{Message types}++<<DBus/Message/Internal.hs>>=+maybe' :: (a -> b) -> Maybe a -> [b]+maybe' f = maybe [] (\x' -> [f x'])++@ \subsubsection{Method calls}++<<DBus/Message/Internal.hs>>=+data MethodCall = MethodCall+	{ methodCallPath        :: T.ObjectPath+	, methodCallMember      :: T.MemberName+	, methodCallInterface   :: Maybe T.InterfaceName+	, methodCallDestination :: Maybe T.BusName+	, methodCallFlags       :: S.Set Flag+	, methodCallBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message MethodCall where+	messageTypeCode _ = 1+	messageFlags      = methodCallFlags+	messageBody       = methodCallBody+	messageHeaderFields m = concat+		[ [ Path    $ methodCallPath m+		  ,  Member $ methodCallMember m+		  ]+		, maybe' Interface . methodCallInterface $ m+		, maybe' Destination . methodCallDestination $ m+		]++<<message exports>>=+, MethodCall (..)++@ \subsubsection{Method returns}++<<DBus/Message/Internal.hs>>=+data MethodReturn = MethodReturn+	{ methodReturnSerial      :: Serial+	, methodReturnDestination :: Maybe T.BusName+	, methodReturnFlags       :: S.Set Flag+	, methodReturnBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message MethodReturn where+	messageTypeCode _ = 2+	messageFlags      = methodReturnFlags+	messageBody       = methodReturnBody+	messageHeaderFields m = concat+		[ [ ReplySerial $ methodReturnSerial m+		  ]+		, maybe' Destination . methodReturnDestination $ m+		]++<<message exports>>=+, MethodReturn (..)++@ \subsubsection{Errors}++<<DBus/Message/Internal.hs>>=+data Error = Error+	{ errorName        :: T.ErrorName+	, errorSerial      :: Serial+	, errorDestination :: Maybe T.BusName+	, errorFlags       :: S.Set Flag+	, errorBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message Error where+	messageTypeCode _ = 3+	messageFlags      = errorFlags+	messageBody       = errorBody+	messageHeaderFields m = concat+		[ [ ErrorName   $ errorName m+		  , ReplySerial $ errorSerial m+		  ]+		, maybe' Destination . errorDestination $ m+		]++<<message exports>>=+, Error (..)++@ \subsubsection{Signals}++<<DBus/Message/Internal.hs>>=+data Signal = Signal+	{ signalPath        :: T.ObjectPath+	, signalMember      :: T.MemberName+	, signalInterface   :: T.InterfaceName+	, signalDestination :: Maybe T.BusName+	, signalFlags       :: S.Set Flag+	, signalBody        :: [T.Variant]+	}+	deriving (Show, Eq)++instance Message Signal where+	messageTypeCode _ = 4+	messageFlags      = signalFlags+	messageBody       = signalBody+	messageHeaderFields m = concat+		[ [ Path      $ signalPath m+		  , Member    $ signalMember m+		  , Interface $ signalInterface m+		  ]+		, maybe' Destination . signalDestination $ m+		]++<<message exports>>=+, Signal (..)++@ \subsubsection{Unknown messages}++Unknown messages are used for storing information about messages without+a recognized type code. They are not instances of {\tt Message}, because+if they were, then clients could accidentally send invalid messages over+the bus.++<<DBus/Message/Internal.hs>>=+data Unknown = Unknown+	{ unknownType    :: Word8+	, unknownFlags   :: S.Set Flag+	, unknownBody    :: [T.Variant]+	}+	deriving (Show, Eq)++<<message exports>>=+, Unknown (..)++@ \subsection{Received messages}++Messages received from a bus have additional fields which do not make sense+when sending.++If a message has an unknown type, its serial and origin are still useful+for sending an error reply.++<<DBus/Message/Internal.hs>>=+data ReceivedMessage+	= ReceivedMethodCall   Serial (Maybe T.BusName) MethodCall+	| ReceivedMethodReturn Serial (Maybe T.BusName) MethodReturn+	| ReceivedError        Serial (Maybe T.BusName) Error+	| ReceivedSignal       Serial (Maybe T.BusName) Signal+	| ReceivedUnknown      Serial (Maybe T.BusName) Unknown+	deriving (Show, Eq)++<<DBus/Message/Internal.hs>>=+receivedSerial :: ReceivedMessage -> Serial+receivedSerial (ReceivedMethodCall   s _ _) = s+receivedSerial (ReceivedMethodReturn s _ _) = s+receivedSerial (ReceivedError        s _ _) = s+receivedSerial (ReceivedSignal       s _ _) = s+receivedSerial (ReceivedUnknown      s _ _) = s++<<DBus/Message/Internal.hs>>=+receivedSender :: ReceivedMessage -> Maybe T.BusName+receivedSender (ReceivedMethodCall   _ s _) = s+receivedSender (ReceivedMethodReturn _ s _) = s+receivedSender (ReceivedError        _ s _) = s+receivedSender (ReceivedSignal       _ s _) = s+receivedSender (ReceivedUnknown      _ s _) = s++<<message exports>>=+, ReceivedMessage (..)+, receivedSerial+, receivedSender++@+\section{Wire format}++<<DBus/Wire.hs>>=+<<copyright>>+<<text extensions>>+<<wire extensions>>+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Wire (<<wire exports>>) where+<<text imports>>+<<wire imports>>+import Control.Monad (when, unless)+import Data.Maybe (fromJust, listToMaybe, fromMaybe)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)+import Data.Typeable (Typeable)++import qualified DBus.Types as T++@ \subsection{Endianness}++<<DBus/Wire.hs>>=+data Endianness = LittleEndian | BigEndian+	deriving (Show, Eq)++encodeEndianness :: Endianness -> Word8+encodeEndianness LittleEndian = 108+encodeEndianness BigEndian    = 66++decodeEndianness :: Word8 -> Maybe Endianness+decodeEndianness 108 = Just LittleEndian+decodeEndianness 66  = Just BigEndian+decodeEndianness _   = Nothing++<<wire exports>>=+  Endianness (..)++@ \subsection{Alignment}++Every built-in type has an associated alignment. If a value of the given+type is marshaled, it must have {\sc nul} bytes inserted until it starts+on a byte index divisible by its alignment.++<<DBus/Wire.hs>>=+alignment :: T.Type -> Word8+<<alignments>>++padding :: Word64 -> Word8 -> Word64+padding current count = required where+	count' = fromIntegral count+	missing = mod current count'+	required = if missing > 0+		then count' - missing+		else 0++<<wire exports>>=+, alignment++@ \subsection{Marshaling}++Marshaling is implemented using an error transformer over an internal+state.++<<wire imports>>=+import qualified Control.Monad.State as ST+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Lazy as L++<<wire extensions>>=+{-# LANGUAGE GeneralizedNewtypeDeriving #-}++<<DBus/Wire.hs>>=+data MarshalState = MarshalState Endianness L.ByteString+newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)+	deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)+type Marshal = MarshalM ()++@ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},+which will generate a {\tt ByteString} with the fully marshaled data.++<<wire exports>>=+, MarshalM+, Marshal+, marshal+, runMarshal++<<DBus/Wire.hs>>=+runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString+runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of+	(Right _, MarshalState _ bytes) -> Right bytes+	(Left  x, _) -> Left x+	where initialState = MarshalState e L.empty++<<DBus/Wire.hs>>=+marshal :: T.Variant -> Marshal+marshal v = marshalType (T.variantType v) where+	x :: T.Variable a => a+	x = fromJust . T.fromVariant $ v+	marshalType :: T.Type -> Marshal+	<<marshalers>>++@ TODO: describe these functions++<<DBus/Wire.hs>>=+append :: L.ByteString -> Marshal+append bs = do+	(MarshalState e bs') <- ST.get+	ST.put $ MarshalState e (L.append bs' bs)++<<DBus/Wire.hs>>=+pad :: Word8 -> Marshal+pad count = do+	(MarshalState _ bytes) <- ST.get+	let padding' = padding (fromIntegral . L.length $ bytes) count+	append $ L.replicate (fromIntegral padding') 0++@ Most numeric values already have marshalers implemented in the+{\tt Data.Binary.Put} module; this function lets them be re-used easily.++<<wire imports>>=+import qualified Data.Binary.Put as P++<<DBus/Wire.hs>>=+marshalPut :: (a -> P.Put) -> a -> Marshal+marshalPut put x = do+	let bytes = P.runPut $ put x+	(MarshalState e _) <- ST.get+	pad . fromIntegral . L.length $ bytes+	append $ case e of+		BigEndian -> bytes+		LittleEndian -> L.reverse bytes++@ \subsubsection{Errors}++Marshaling can fail for four reasons:++\begin{itemize}+\item The message exceeds the maximum message size of $2^{27}$ bytes.+\item An array in the message exceeds the maximum array size of $2^{26}$ bytes.+\item The body's signature is not valid (for example, more than 255 fields).+\item A variant's signature is not valid -- same causes as an invalid body+      signature.+\end{itemize}++<<DBus/Wire.hs>>=+data MarshalError+	= MessageTooLong Word64+	| ArrayTooLong Word64+	| InvalidBodySignature Text+	| InvalidVariantSignature Text+	deriving (Eq, Typeable)++instance Show MarshalError where+	show (MessageTooLong x) = concat+		["Message too long (", show x, " bytes)."]+	show (ArrayTooLong x) = concat+		["Array too long (", show x, " bytes)."]+	show (InvalidBodySignature x) = concat+		["Invalid body signature: ", show x]+	show (InvalidVariantSignature x) = concat+		["Invalid variant signature: ", show x]++instance E.Error MarshalError++<<wire exports>>=+, MarshalError (..)++@ \subsection{Unmarshaling}++Unmarshaling also uses an error transformer and internal state.++<<wire exports>>=+, Unmarshal+, unmarshal+, runUnmarshal++<<DBus/Wire.hs>>=+data UnmarshalState = UnmarshalState Endianness L.ByteString Word64+newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)+	deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)++<<DBus/Wire.hs>>=+runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a+runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where+	state = UnmarshalState e bytes 0++<<DBus/Wire.hs>>=+unmarshal :: T.Signature -> Unmarshal [T.Variant]+unmarshal = mapM unmarshalType . T.signatureTypes++unmarshalType :: T.Type -> Unmarshal T.Variant+<<unmarshalers>>++@ TODO: describe these functions++<<DBus/Wire.hs>>=+consume :: Word64 -> Unmarshal L.ByteString+consume count = do+	(UnmarshalState e bytes offset) <- ST.get+	let bytes' = L.drop (fromIntegral offset) bytes+	let x = L.take (fromIntegral count) bytes'+	unless (L.length x == fromIntegral count) $+		E.throwError $ UnexpectedEOF offset+	+	ST.put $ UnmarshalState e bytes (offset + count)+	return x++<<DBus/Wire.hs>>=+skipPadding :: Word8 -> Unmarshal ()+skipPadding count = do+	(UnmarshalState _ _ offset) <- ST.get+	bytes <- consume $ padding offset count+	unless (L.all (== 0) bytes) $+		E.throwError $ InvalidPadding offset++<<DBus/Wire.hs>>=+skipTerminator :: Unmarshal ()+skipTerminator = do+	(UnmarshalState _ _ offset) <- ST.get+	bytes <- consume 1+	unless (L.all (== 0) bytes) $+		E.throwError $ MissingTerminator offset++<<DBus/Wire.hs>>=+fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b+fromMaybeU label f x = case f x of+	Just x' -> return x'+	Nothing -> E.throwError . Invalid label . TL.pack . show $ x++fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a+           -> Unmarshal T.Variant+fromMaybeU' label f x = do+	x' <- fromMaybeU label f x+	return $ T.toVariant x'++<<wire imports>>=+import qualified Data.Binary.Get as G++<<DBus/Wire.hs>>=+unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a+unmarshalGet count be le = do+	skipPadding count+	(UnmarshalState e _ _) <- ST.get+	bs <- consume . fromIntegral $ count+	let get' = case e of+		BigEndian -> be+		LittleEndian -> le+	return $ G.runGet get' bs++unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a+              -> Unmarshal T.Variant+unmarshalGet' count be le = fmap T.toVariant $ unmarshalGet count be le++<<DBus/Wire.hs>>=+untilM :: Monad m => m Bool -> m a -> m [a]+untilM test comp = do+	done <- test+	if done+		then return []+		else do+			x <- comp+			xs <- untilM test comp+			return $ x:xs++@ \subsubsection{Errors}++Unmarshaling can fail for four reasons:++\begin{itemize}+\item The message's declared protocol version is unsupported.+\item Unexpected {\sc eof}, when there are less bytes remaining than are+      required.+\item An invalid byte sequence for a given value type.+\item Missing required header fields for the declared message type.+\item Non-zero bytes were found where padding was expected.+\item A string, signature, or object path was not {\sc null}-terminated.+\item An array's size didn't match the number of elements+\end{itemize}++<<DBus/Wire.hs>>=+data UnmarshalError+	= UnsupportedProtocolVersion Word8+	| UnexpectedEOF Word64+	| Invalid Text Text+	| MissingHeaderField Text+	| InvalidHeaderField Text T.Variant+	| InvalidPadding Word64+	| MissingTerminator Word64+	| ArraySizeMismatch+	deriving (Eq, Typeable)++instance Show UnmarshalError where+	show (UnsupportedProtocolVersion x) = concat+		["Unsupported protocol version: ", show x]+	show (UnexpectedEOF pos) = concat+		["Unexpected EOF at position ", show pos]+	show (Invalid label x) = TL.unpack $ TL.concat+		["Invalid ", label, ": ", x]+	show (MissingHeaderField x) = concat+		["Required field " , show x , " is missing."]+	show (InvalidHeaderField x got) = concat+		[ "Invalid header field ", show x, ": ", show got]+	show (InvalidPadding pos) = concat+		["Invalid padding at position ", show pos]+	show (MissingTerminator pos) = concat+		["Missing NUL terminator at position ", show pos]+	show ArraySizeMismatch = "Array size mismatch"++instance E.Error UnmarshalError++<<wire exports>>=+, UnmarshalError (..)++@ \subsection{Numerics}++Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte+integer will have a 4-byte alignment.++<<alignments>>=+alignment T.DBusByte    = 1+alignment T.DBusWord16  = 2+alignment T.DBusWord32  = 4+alignment T.DBusWord64  = 8+alignment T.DBusInt16   = 2+alignment T.DBusInt32   = 4+alignment T.DBusInt64   = 8+alignment T.DBusDouble  = 8++@ Because {\tt Word32}s are often used for other types, there's+separate functions for handling them.++<<DBus/Wire.hs>>=+marshalWord32 :: Word32 -> Marshal+marshalWord32 = marshalPut P.putWord32be++unmarshalWord32 :: Unmarshal Word32+unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le++<<marshalers>>=+marshalType T.DBusByte   = append $ L.singleton x+marshalType T.DBusWord16 = marshalPut P.putWord16be x+marshalType T.DBusWord32 = marshalPut P.putWord32be x+marshalType T.DBusWord64 = marshalPut P.putWord64be x+marshalType T.DBusInt16  = marshalPut P.putWord16be $ fromIntegral (x :: Int16)+marshalType T.DBusInt32  = marshalPut P.putWord32be $ fromIntegral (x :: Int32)+marshalType T.DBusInt64  = marshalPut P.putWord64be $ fromIntegral (x :: Int64)++<<unmarshalers>>=+unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1+unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le+unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le+unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le++unmarshalType T.DBusInt16  = do+	x <- unmarshalGet 2 G.getWord16be G.getWord16le+	return . T.toVariant $ (fromIntegral x :: Int16)++unmarshalType T.DBusInt32  = do+	x <- unmarshalGet 4 G.getWord32be G.getWord32le+	return . T.toVariant $ (fromIntegral x :: Int32)++unmarshalType T.DBusInt64  = do+	x <- unmarshalGet 8 G.getWord64be G.getWord64le+	return . T.toVariant $ (fromIntegral x :: Int64)++@ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format.++<<wire imports>>=+import qualified Data.Binary.IEEE754 as IEEE++<<marshalers>>=+marshalType T.DBusDouble = marshalPut IEEE.putFloat64be x++<<unmarshalers>>=+unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le++@ \subsection{Booleans}++Booleans are marshaled as 4-byte unsigned integers containing either of+the values 0 or 1. Yes, really.++<<alignments>>=+alignment T.DBusBoolean = 4++<<marshalers>>=+marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0++<<unmarshalers>>=+unmarshalType T.DBusBoolean = unmarshalWord32 >>=+	fromMaybeU' "boolean" (\x -> case x of+		0 -> Just False+		1 -> Just True+		_ -> Nothing)++@ \subsection{Strings and object paths}++Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed+with their length as an unsigned 32-bit integer. Their alignment is that of+their length. Object paths are marshaled just like strings, though additional+checks are required when unmarshaling.++TODO: If the input is invalid, these {\sc utf8} functions will raise an+exception, rather than return an error value. Eventually they should be+wrapped with {\tt unsafePerformIO} and be tweaked to return a proper+{\tt Maybe} or {\tt Either}.++<<wire imports>>=+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)++<<DBus/Wire.hs>>=+marshalText :: Text -> Marshal+marshalText x = do+	let bytes = encodeUtf8 x+	marshalWord32 . fromIntegral . L.length $ bytes+	append bytes+	append (L.singleton 0)++<<DBus/Wire.hs>>=+unmarshalText :: Unmarshal Text+unmarshalText = do+	byteCount <- unmarshalWord32+	bytes <- consume . fromIntegral $ byteCount+	skipTerminator+	return . decodeUtf8 $ bytes++<<alignments>>=+alignment T.DBusString     = 4+alignment T.DBusObjectPath = 4++<<marshalers>>=+marshalType T.DBusString = marshalText x+marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x++<<unmarshalers>>=+unmarshalType T.DBusString = fmap T.toVariant unmarshalText++unmarshalType T.DBusObjectPath = unmarshalText >>=+	fromMaybeU' "object path" T.mkObjectPath++@ \subsection{Signatures}++Signatures are similar to strings, except their length is limited to 255+characters and is therefore stored as a single byte.++<<DBus/Wire.hs>>=+marshalSignature :: T.Signature -> Marshal+marshalSignature x = do+	let bytes = encodeUtf8 . T.strSignature $ x+	let size = fromIntegral . L.length $ bytes+	append (L.singleton size)+	append bytes+	append (L.singleton 0)++<<DBus/Wire.hs>>=+unmarshalSignature :: Unmarshal T.Signature+unmarshalSignature = do+	byteCount <- fmap L.head $ consume 1+	sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount+	skipTerminator+	fromMaybeU "signature" T.mkSignature sigText++<<alignments>>=+alignment T.DBusSignature  = 1++<<marshalers>>=+marshalType T.DBusSignature = marshalSignature x++<<unmarshalers>>=+unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature++@ \subsection{Containers}++@ \subsubsection{Arrays}++<<alignments>>=+alignment (T.DBusArray _) = 4++<<marshalers>>=+marshalType (T.DBusArray _) = marshalArray x++<<unmarshalers>>=+unmarshalType (T.DBusArray t) = fmap T.toVariant $ unmarshalArray t++@ Marshaling arrays is complicated, because the array body must be marshaled+\emph{first} to calculate the array length. This requires building a+temporary marshaler, to get the padding right.++<<wire imports>>=+import qualified DBus.Constants as C++<<DBus/Wire.hs>>=+marshalArray :: T.Array -> Marshal+marshalArray x = do+	(arrayPadding, arrayBytes) <- getArrayBytes x+	let arrayLen = L.length arrayBytes+	when (arrayLen > fromIntegral C.arrayMaximumLength)+		(E.throwError $ ArrayTooLong $ fromIntegral arrayLen)+	marshalWord32 $ fromIntegral arrayLen+	append arrayPadding+	append arrayBytes++<<DBus/Wire.hs>>=+getArrayBytes :: T.Array -> MarshalM (L.ByteString, L.ByteString)+getArrayBytes x = do+	let vs = T.arrayItems x+	let itemType = T.arrayType x+	s <- ST.get+	(MarshalState _ afterLength) <- marshalWord32 0 >> ST.get+	(MarshalState _ afterPadding) <- pad (alignment itemType) >> ST.get+	(MarshalState _ afterItems) <- mapM_ marshal vs >> ST.get+	+	let paddingBytes = L.drop (L.length afterLength) afterPadding+	let itemBytes = L.drop (L.length afterPadding) afterItems+	+	ST.put s+	return (paddingBytes, itemBytes)++@ Unmarshaling is much easier++<<DBus/Wire.hs>>=+unmarshalArray :: T.Type -> Unmarshal T.Array+unmarshalArray itemType = do+	let getOffset = do+		(UnmarshalState _ _ o) <- ST.get+		return o+	byteCount <- unmarshalWord32+	skipPadding (alignment itemType)+	start <- getOffset+	let end = start + fromIntegral byteCount+	vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)+	end' <- getOffset+	when (end' > end) $+		E.throwError ArraySizeMismatch+	fromMaybeU "array" (T.arrayFromItems itemType) vs++@ \subsubsection{Dictionaries}++<<alignments>>=+alignment (T.DBusDictionary _ _) = 4++<<marshalers>>=+marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)++<<unmarshalers>>=+unmarshalType (T.DBusDictionary kt vt) = do+	let pairType = T.DBusStructure [kt, vt]+	array <- unmarshalArray pairType+	fromMaybeU' "dictionary" T.arrayToDictionary array++@ \subsubsection{Structures}++<<alignments>>=+alignment (T.DBusStructure _) = 8++<<marshalers>>=+marshalType (T.DBusStructure _) = do+	let T.Structure vs = x+	pad 8+	mapM_ marshal vs++<<unmarshalers>>=+unmarshalType (T.DBusStructure ts) = do+	skipPadding 8+	fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts++@ \subsubsection{Variants}++<<alignments>>=+alignment T.DBusVariant = 1++<<marshalers>>=+marshalType T.DBusVariant = do+	let rawSig = T.typeCode . T.variantType $ x+	sig <- case T.mkSignature rawSig of+		Just x' -> return x'+		Nothing -> E.throwError $ InvalidVariantSignature rawSig+	marshalSignature sig+	marshal x++<<unmarshalers>>=+unmarshalType T.DBusVariant = do+	let getType sig = case T.signatureTypes sig of+		[t] -> Just t+		_   -> Nothing+	+	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature+	fmap T.toVariant $ unmarshalType t++@ \subsection{Messages}++<<wire imports>>=+import qualified DBus.Message.Internal as M++@ \subsubsection{Flags}++<<wire imports>>=+import Data.Bits ((.|.), (.&.))+import qualified Data.Set as Set++<<DBus/Wire.hs>>=+encodeFlags :: Set.Set M.Flag -> Word8+encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where+	flagValue M.NoReplyExpected = 0x1+	flagValue M.NoAutoStart     = 0x2++decodeFlags :: Word8 -> Set.Set M.Flag+decodeFlags word = Set.fromList flags where+	flagSet = [ (0x1, M.NoReplyExpected)+	          , (0x2, M.NoAutoStart)+	          ]+	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]++@ \subsubsection{Header fields}++<<DBus/Wire.hs>>=+encodeField :: M.HeaderField -> T.Structure+encodeField (M.Path x)        = encodeField' 1 x+encodeField (M.Interface x)   = encodeField' 2 x+encodeField (M.Member x)      = encodeField' 3 x+encodeField (M.ErrorName x)   = encodeField' 4 x+encodeField (M.ReplySerial x) = encodeField' 5 x+encodeField (M.Destination x) = encodeField' 6 x+encodeField (M.Sender x)      = encodeField' 7 x+encodeField (M.Signature x)   = encodeField' 8 x++encodeField' :: T.Variable a => Word8 -> a -> T.Structure+encodeField' code x = T.Structure+	[ T.toVariant code+	, T.toVariant $ T.toVariant x+	]++<<DBus/Wire.hs>>=+decodeField :: Monad m => T.Structure+            -> E.ErrorT UnmarshalError m [M.HeaderField]+decodeField struct = case unpackField struct of+	(1, x) -> decodeField' x M.Path "path"+	(2, x) -> decodeField' x M.Interface "interface"+	(3, x) -> decodeField' x M.Member "member"+	(4, x) -> decodeField' x M.ErrorName "error name"+	(5, x) -> decodeField' x M.ReplySerial "reply serial"+	(6, x) -> decodeField' x M.Destination "destination"+	(7, x) -> decodeField' x M.Sender "sender"+	(8, x) -> decodeField' x M.Signature "signature"+	_      -> return []++decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text+             -> E.ErrorT UnmarshalError m [b]+decodeField' x f label = case T.fromVariant x of+	Just x' -> return [f x']+	Nothing -> E.throwError $ InvalidHeaderField label x++<<DBus/Wire.hs>>=+unpackField :: T.Structure -> (Word8, T.Variant)+unpackField struct = (c', v') where+	T.Structure [c, v] = struct+	c' = fromJust . T.fromVariant $ c+	v' = fromJust . T.fromVariant $ v++@ \subsubsection{Header layout}++TODO: describe header layout here++@ \subsubsection{Marshaling}++<<wire exports>>=+, marshalMessage++<<DBus/Wire.hs>>=+marshalMessage :: M.Message a => Endianness -> M.Serial -> a+               -> Either MarshalError L.ByteString+marshalMessage e serial msg = runMarshal marshaler e where+	body = M.messageBody msg+	marshaler = do+		sig <- checkBodySig body+		empty <- ST.get+		mapM_ marshal body+		(MarshalState _ bodyBytes) <- ST.get+		ST.put empty+		marshalEndianness e+		marshalHeader msg serial sig+			$ fromIntegral . L.length $ bodyBytes+		pad 8+		append bodyBytes+		checkMaximumSize++<<DBus/Wire.hs>>=+checkBodySig :: [T.Variant] -> MarshalM T.Signature+checkBodySig vs = let+	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs+	invalid = E.throwError $ InvalidBodySignature sigStr+	in case T.mkSignature sigStr of+		Just x -> return x+		Nothing -> invalid++<<DBus/Wire.hs>>=+marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32+              -> Marshal+marshalHeader msg serial bodySig bodyLength = do+	let fields = M.Signature bodySig : M.messageHeaderFields msg+	marshal . T.toVariant . M.messageTypeCode $ msg+	marshal . T.toVariant . encodeFlags . M.messageFlags $ msg+	marshal . T.toVariant $ C.protocolVersion+	marshalWord32 bodyLength+	marshal . T.toVariant $ serial+	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]+	marshal . T.toVariant . fromJust . T.toArray fieldType+	        $ map encodeField fields++<<DBus/Wire.hs>>=+marshalEndianness :: Endianness -> Marshal+marshalEndianness = marshal . T.toVariant . encodeEndianness++<<DBus/Wire.hs>>=+checkMaximumSize :: Marshal+checkMaximumSize = do+	(MarshalState _ messageBytes) <- ST.get+	let messageLength = L.length messageBytes+	when (messageLength > fromIntegral C.messageMaximumLength)+		(E.throwError $ MessageTooLong $ fromIntegral messageLength)++@ \subsubsection{Unmarshaling}++<<wire exports>>=+, unmarshalMessage++<<DBus/Wire.hs>>=+unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)+                 -> m (Either UnmarshalError M.ReceivedMessage)+unmarshalMessage getBytes' = E.runErrorT $ do+	let getBytes = E.lift . getBytes'+	+	<<read fixed-length header>>+	<<read full header>>+	<<read body>>+	<<build message>>++@ The first part of the header has a fixed size of 16 bytes, so it can be+retrieved without any size calculations.++<<read fixed-length header>>=+let fixedSig = T.mkSignature' "yyyyuuu"+fixedBytes <- getBytes 16++@ The first field of interest is the protocol version; if the incoming+message's version is different from this library, the message cannot be+parsed.++<<read fixed-length header>>=+let messageVersion = L.index fixedBytes 3+when (messageVersion /= C.protocolVersion) $+	E.throwError $ UnsupportedProtocolVersion messageVersion++@ Next is the endianness, used for parsing pretty much every other field.++<<read fixed-length header>>=+let eByte = L.index fixedBytes 0+endianness <- case decodeEndianness eByte of+	Just x' -> return x'+	Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte++@ With the endianness out of the way, the rest of the fixed header+can be decoded++<<read fixed-length header>>=+let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of+	Right x' -> return x'+	Left  e  -> E.throwError e+fixed <- unmarshal' fixedSig fixedBytes+let typeCode = fromJust . T.fromVariant $ fixed !! 1+let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2+let bodyLength = fromJust . T.fromVariant $ fixed !! 4+let serial = fromJust . T.fromVariant $ fixed !! 5++@ The last field of the fixed header is actually part of the field array,+but is treated as a single {\tt Word32} so it'll be known how many bytes+to retrieve.++<<read fixed-length header>>=+let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6++@ With the field byte count, the remainder of the header bytes can be+pulled out of the monad.++<<read full header>>=+let headerSig  = T.mkSignature' "yyyyuua(yv)"+fieldBytes <- getBytes fieldByteCount+let headerBytes = L.append fixedBytes fieldBytes+header <- unmarshal' headerSig headerBytes++@ And the header fields can be parsed.++<<read full header>>=+let fieldArray = fromJust . T.fromVariant $ header !! 6+let fieldStructures = fromJust . T.fromArray $ fieldArray+fields <- fmap concat $ mapM decodeField fieldStructures++@ The body is always aligned to 8 bytes, so pull out the padding before+unmarshaling it.++<<read body>>=+let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8+getBytes . fromIntegral $ bodyPadding++<<DBus/Wire.hs>>=+findBodySignature :: [M.HeaderField] -> T.Signature+findBodySignature fields = fromMaybe empty signature where+	empty = T.mkSignature' ""+	signature = listToMaybe [x | M.Signature x <- fields]++<<read body>>=+let bodySig = findBodySignature fields++@ Then pull the body bytes, and unmarshal it.++<<read body>>=+bodyBytes <- getBytes bodyLength+body <- unmarshal' bodySig bodyBytes++@ Even if the received message was structurally valid, building the+{\tt ReceivedMessage} can still fail due to missing header fields.++<<build message>>=+y <- case buildReceivedMessage typeCode fields of+	Right x -> return x+	Left x -> E.throwError $ MissingHeaderField x++<<build message>>=+return $ y serial flags body++@ This really belongs in the Message section...++<<DBus/Wire.hs>>=+buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text +                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]+                         -> M.ReceivedMessage)++@ Method calls++<<DBus/Wire.hs>>=+buildReceivedMessage 1 fields = do+	path <- require "path" [x | M.Path x <- fields]+	member <- require "member name" [x | M.Member x <- fields]+	return $ \serial flags body -> let+		iface = listToMaybe [x | M.Interface x <- fields]+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.MethodCall path member iface dest flags body+		in M.ReceivedMethodCall serial sender msg++@ Method returns++<<DBus/Wire.hs>>=+buildReceivedMessage 2 fields = do+	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+	return $ \serial flags body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.MethodReturn replySerial dest flags body+		in M.ReceivedMethodReturn serial sender msg++@ Errors++<<DBus/Wire.hs>>=+buildReceivedMessage 3 fields = do+	name <- require "error name" [x | M.ErrorName x <- fields]+	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+	return $ \serial flags body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.Error name replySerial dest flags body+		in M.ReceivedError serial sender msg++@ Signals++<<DBus/Wire.hs>>=+buildReceivedMessage 4 fields = do+	path <- require "path" [x | M.Path x <- fields]+	member <- require "member name" [x | M.Member x <- fields]+	iface <- require "interface" [x | M.Interface x <- fields]+	return $ \serial flags body -> let+		dest = listToMaybe [x | M.Destination x <- fields]+		sender = listToMaybe [x | M.Sender x <- fields]+		msg = M.Signal path member iface dest flags body+		in M.ReceivedSignal serial sender msg++@ Unknown++<<DBus/Wire.hs>>=+buildReceivedMessage typeCode fields = return $ \serial flags body -> let+	sender = listToMaybe [x | M.Sender x <- fields]+	msg = M.Unknown typeCode flags body+	in M.ReceivedUnknown serial sender msg++<<DBus/Wire.hs>>=+require :: Text -> [a] -> Either Text a+require _     (x:_) = Right x+require label _     = Left label++@ This is just needed for the Monad instance of {\tt Either Text}++<<DBus/Wire.hs>>=+instance E.Error Text where+	strMsg = TL.pack++@+\section{Connections}++<<DBus/Connection.hs>>=+<<copyright>>+<<text extensions>>+{-# LANGUAGE DeriveDataTypeable #-}+module DBus.Connection+	( <<connection exports>>+	) where+<<text imports>>+<<connection imports>>++@ A {\tt Connection} is an opaque handle to an open DBus channel, with+an internal state for maintaining the current message serial.++<<connection imports>>=+import qualified Control.Concurrent as C+import qualified DBus.Address as A+import qualified DBus.Message.Internal as M++<<DBus/Connection.hs>>=+data Connection = Connection A.Address Transport (C.MVar M.Serial)++<<connection exports>>=+  Connection++@ While not particularly useful for other functions, being able to+{\tt show} a {\tt Connection} is useful when debugging.++<<DBus/Connection.hs>>=+instance Show Connection where+	showsPrec d (Connection a _ _) = showParen (d > 10) $+		showString' ["<connection ", show $ A.strAddress a, ">"] where+		showString' = foldr (.) id . map showString++@ \subsection{Transports}++A transport is anything which can send and receive bytestrings, typically+over a socket.++<<connection imports>>=+import qualified Data.ByteString.Lazy as L+import Data.Word (Word32)++<<DBus/Connection.hs>>=+data Transport = Transport+	{ transportSend :: L.ByteString -> IO ()+	, transportRecv :: Word32 -> IO L.ByteString+	}++<<DBus/Connection.hs>>=+connectTransport :: A.Address -> IO Transport+connectTransport a = transport' (A.addressMethod a) a where+	transport' "unix" = unix+	transport' _      = unknownTransport++@ \subsubsection{UNIX}++The {\sc unix} transport accepts two parameters: {\tt path}, which is a+simple filesystem path, and {\tt abstract}, which is a path in the+Linux-specific abstract domain. One, and only one, of these parameters must+be specified.++<<connection imports>>=+import qualified Network as N+import qualified Data.Map as Map++<<DBus/Connection.hs>>=+unix :: A.Address -> IO Transport+unix a = handleTransport . N.connectTo "localhost" =<< port where+	params = A.addressParameters a+	path = Map.lookup "path" params+	abstract = Map.lookup "abstract" params+	+	tooMany = "Only one of `path' or `abstract' may be specified for the\+	          \ `unix' method."+	tooFew = "One of `path' or `abstract' must be specified for the\+	         \ `unix' transport."+	+	port = fmap N.UnixSocket path'+	path' = case (path, abstract) of+		(Just _, Just _) -> E.throwIO $ BadParameters a tooMany+		(Nothing, Nothing) -> E.throwIO $ BadParameters a tooFew+		(Just x, Nothing) -> return $ TL.unpack x+		(Nothing, Just x) -> return $ '\x00' : TL.unpack x++@ \subsubsection{TCP}++known parameters:++\begin{itemize}+\item {\tt host} (optional, default "{\tt localhost}")+\item {\tt port}+\item {\tt family} (optional, choices are "{\tt ipv4}" or "{\tt ipv6}"+\end{itemize}++TCP support is TODO++<<TODO>>=+tcp :: A.Address -> IO Transport+tcp a@(A.Address _ params) = handleTransport a connect' where+	host = lookup "host" params+	port = parsePort =<< lookup "post" params+	family = parseFamily =<< lookup "family" params+	connect' = do+		-- check host+		-- check port+		-- check family+		-- return handle+parsePort :: String -> Maybe PortNumber++parseFamily :: String -> Maybe Family++@ \subsubsection{Generic handle-based transport}++Both UNIX and TCP are backed by standard handles, and can therefore use+a shared handle-based transport backend.++<<connection imports>>=+import qualified System.IO as I++<<DBus/Connection.hs>>=+handleTransport :: IO I.Handle -> IO Transport+handleTransport io = do+	h <- io+	I.hSetBuffering h I.NoBuffering+	I.hSetBinaryMode h True+	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)++@ \subsubsection{Unknown transports}++If a method has no known transport, attempting to connect using it will+just result in an exception.++<<DBus/Connection.hs>>=+unknownTransport :: A.Address -> IO Transport+unknownTransport = E.throwIO . UnknownMethod++@ \subsection{Errors}++If connecting to DBus fails, a {\tt ConnectionError} will be thrown.+The constructor describes which exception occurred.++<<connection imports>>=+import qualified Control.Exception as E+import Data.Typeable (Typeable)++<<DBus/Connection.hs>>=+data ConnectionError+	= InvalidAddress Text+	| BadParameters A.Address Text+	| UnknownMethod A.Address+	| NoWorkingAddress [A.Address]+	deriving (Show, Typeable)++instance E.Exception ConnectionError++<<connection exports>>=+, ConnectionError (..)+, W.MarshalError (..)+, W.UnmarshalError (..)++@ \subsection{Establishing a connection}++A connection can be opened to any valid address, though actually connecting+might fail due to external factors.++<<connection imports>>=+import Data.Text.Lazy.Encoding (decodeUtf8, encodeUtf8)++<<DBus/Connection.hs>>=+connect :: A.Address -> IO Connection+connect a = do+	t <- connectTransport a+	let putS = transportSend t . encodeUtf8 . TL.pack+	let getS = fmap (TL.unpack . decodeUtf8) . transportRecv t+	authenticate putS getS+	serialMVar <- C.newMVar M.firstSerial+	return $ Connection a t serialMVar++<<connection exports>>=+, connect++@ \subsection{Authentication}++<<DBus/Connection.hs>>=+authenticate :: (String -> IO ()) -> (Word32 -> IO String)+                -> IO ()+authenticate put get = do+	put "\x00"++@ {\sc external} authentication is performed using the process's real user+ID, converted to a string, and then hex-encoded.++<<connection imports>>=+import System.Posix.User (getRealUserID)+import Data.Char (ord)+import Text.Printf (printf)++<<DBus/Connection.hs>>=+	uid <- getRealUserID+	let authToken = concatMap (printf "%02X" . ord) (show uid)+	put $ "AUTH EXTERNAL " ++ authToken ++ "\r\n"++@ If authentication was successful, the server responds with {\tt OK+<server GUID>}.  The GUID is intended to enable connection sharing, which+is currently unimplemented, so it's ignored.++<<connection imports>>=+import Data.List (isPrefixOf)++<<DBus/Connection.hs>>=+	response <- readUntil '\n' get+	if "OK" `isPrefixOf` response+		then put "BEGIN\r\n"+		else do+			putStrLn $ "response = " ++ show response+			error "Server rejected authentication token."++<<DBus/Connection.hs>>=+readUntil :: Monad m => Char -> (Word32 -> m String) -> m String+readUntil = readUntil' "" where+	readUntil' xs c f = do+		[x] <- f 1+		let xs' = xs ++ [x]+		if x == c+			then return xs'+			else readUntil' xs' c f++@ \subsection{Sending and receiving messages}++Sending a message will increment the connection's internal serial state.+The second parameter is present to allow registration of a callback before+the message has actually been sent, which avoids race conditions in+multi-threaded clients.++<<connection imports>>=+import qualified DBus.Wire as W++<<DBus/Connection.hs>>=+send :: M.Message a => Connection -> (M.Serial -> IO b) -> a+     -> IO (Either W.MarshalError b)+send (Connection _ t mvar) io msg = withSerial mvar $ \serial ->+	case W.marshalMessage W.LittleEndian serial msg of+		Right bytes -> do+			x <- io serial+			transportSend t bytes+			return $ Right x+		Left  err   -> return $ Left err++<<connection exports>>=+, send++<<DBus/Connection.hs>>=+withSerial :: C.MVar M.Serial -> (M.Serial -> IO a) -> IO a+withSerial m io = E.block $ do+	s <- C.takeMVar m+	let s' = M.nextSerial s+	x <- E.unblock (io s) `E.onException` C.putMVar m s'+	C.putMVar m s'+	return x++@ Messages are received wrapped in a {\tt ReceivedMessage} value. If an+error is encountered while unmarshaling, an exception will be thrown.++<<DBus/Connection.hs>>=+receive :: Connection -> IO (Either W.UnmarshalError M.ReceivedMessage)+receive (Connection _ t _) = W.unmarshalMessage $ transportRecv t++<<connection exports>>=+, receive++@+\section{The central bus}++<<DBus/Bus.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Bus+	( getSystemBus+	, getSessionBus+	, getStarterBus+	, getFirstBus+	, getBus+	) where+<<text imports>>++import qualified Control.Exception as E+import Control.Monad (when)+import Data.Maybe (fromJust, isNothing)+import qualified Data.Set as Set+import System.Environment (getEnv)++import qualified DBus.Address as A+import qualified DBus.Connection as C+import DBus.Constants (dbusName, dbusPath, dbusInterface)+import qualified DBus.Message as M+import qualified DBus.Types as T+import DBus.Util (fromRight)++@ Connecting to a message bus is a bit more involved than just connecting+over an app-to-app connection: the bus must be notified of the new client,+using a "hello message", before it will begin forwarding messages.++<<DBus/Bus.hs>>=+getBus :: A.Address -> IO (C.Connection, T.BusName)+getBus addr = do+	c <- C.connect addr+	name <- sendHello c+	return (c, name)++@ Optionally, multiple addresses may be provided. The first successfully+connected bus will be returned.++<<DBus/Bus.hs>>=+getFirstBus :: [A.Address] -> IO (C.Connection, T.BusName)+getFirstBus as = getFirstBus' as as++getFirstBus' :: [A.Address] -> [A.Address] -> IO (C.Connection, T.BusName)+getFirstBus' orig     [] = E.throwIO $ C.NoWorkingAddress orig+getFirstBus' orig (a:as) = E.catch (getBus a) onError where+	onError :: E.SomeException -> IO (C.Connection, T.BusName)+	onError _ = getFirstBus' orig as++@ \subsection{Default connections}++Two default buses are defined, the ``system'' and ``session'' buses. The system+bus is global for the OS, while the session bus runs only for the duration+of the user's session.++<<DBus/Bus.hs>>=+getSystemBus :: IO (C.Connection, T.BusName)+getSystemBus = getBus' $ fromEnv `E.catch` noEnv where+	defaultAddr = "unix:path=/var/run/dbus/system_bus_socket"+	fromEnv = getEnv "DBUS_SYSTEM_BUS_ADDRESS"+	noEnv (E.SomeException _) = return defaultAddr++<<DBus/Bus.hs>>=+getSessionBus :: IO (C.Connection, T.BusName)+getSessionBus = getBus' $ getEnv "DBUS_SESSION_BUS_ADDRESS"++<<DBus/Bus.hs>>=+getStarterBus :: IO (C.Connection, T.BusName)+getStarterBus = getBus' $ getEnv "DBUS_STARTER_ADDRESS"++<<DBus/Bus.hs>>=+getBus' :: IO String -> IO (C.Connection, T.BusName)+getBus' io = do+	addr <- fmap TL.pack io+	case A.mkAddresses addr of+		Just [x] -> getBus x+		Just  x  -> getFirstBus x+		_        -> E.throwIO $ C.InvalidAddress addr++@ \subsection{Sending the ``hello'' message}++<<DBus/Bus.hs>>=+hello :: M.MethodCall+hello = M.MethodCall dbusPath+	(T.mkMemberName' "Hello")+	(Just dbusInterface)+	(Just dbusName)+	Set.empty+	[]++<<DBus/Bus.hs>>=+sendHello :: C.Connection -> IO T.BusName+sendHello c = do+	serial <- fromRight `fmap` C.send c return hello+	reply <- waitForReply c serial+	let name = case M.methodReturnBody reply of+		(x:_) -> T.fromVariant x+		_     -> Nothing+	+	when (isNothing name) $+		E.throwIO $ E.AssertionFailed "Invalid response to Hello()"+	+	return . fromJust $ name++<<DBus/Bus.hs>>=+waitForReply :: C.Connection -> M.Serial -> IO M.MethodReturn+waitForReply c serial = do+	received <- C.receive c+	msg <- case received of+		Right x -> return x+		Left err -> E.throwIO $ E.AssertionFailed "Invalid response to Hello()"+	case msg of+		(M.ReceivedMethodReturn _ _ reply) ->+			if M.methodReturnSerial reply == serial+				then return reply+				else waitForReply c serial+		_ -> waitForReply c serial++@+\section{Addresses}++<<DBus/Address.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Address+	( Address+	, addressMethod+	, addressParameters+	, mkAddresses+	, strAddress+	) where+<<text imports>>++import Data.Char (ord, chr)+import qualified Data.Map as M+import Text.Printf (printf)+import qualified Text.Parsec as P+import Text.Parsec ((<|>))+import DBus.Util (hexToInt, eitherToMaybe)++@ \subsection{Address syntax}++A bus address is in the format {\tt $method$:$key$=$value$,$key$=$value$...}+where the method may be empty and parameters are optional. An address's+parameter list, if present, may end with a comma. Addresses in environment+variables are separated by semicolons, and the full address list may end+in a semicolon. Multiple parameters may have the same key; in this case,+only the first parameter for each key will be stored.++The bytes allowed in each component of the address are given by the following+chart, where each character is understood to be its ASCII value:++\begin{table}[h]+\begin{center}+\begin{tabular}{ll}+\toprule+Component   & Allowed Characters \\+\midrule+Method      & Any except {\tt `;'} and {\tt `:'} \\+Param key   & Any except {\tt `;'}, {\tt `,'}, and {\tt `='} \\+Param value & {\tt `0'} to {\tt `9'} \\+            & {\tt `a'} to {\tt `z'} \\+            & {\tt `A'} to {\tt `Z'} \\+            & Any of: {\tt - \textunderscore{} / \textbackslash{} * . \%} \\+\bottomrule+\end{tabular}+\end{center}+\end{table}++In parameter values, any byte may be encoded by prepending the \% character+to its value in hexadecimal. \% is not allowed to appear unless it is+followed by two hexadecimal digits. Every other allowed byte is termed+an ``optionally encoded'' byte, and may appear unescaped in parameter+values.++<<DBus/Address.hs>>=+optionallyEncoded :: [Char]+optionallyEncoded = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."++@+The address simply stores its method and parameter map, with a custom+{\tt Show} instance to provide easier debugging.++<<DBus/Address.hs>>=+data Address = Address+	{ addressMethod     :: Text+	, addressParameters :: M.Map Text Text+	} deriving (Eq)++instance Show Address where+	showsPrec d x = showParen (d> 10) $+		showString "Address " . shows (strAddress x)++@+Parsing is straightforward; the input string is divided into addresses by+semicolons, then further by colons and commas. Parsing will fail if any+of the addresses in the input failed to parse.++<<DBus/Address.hs>>=+mkAddresses :: Text -> Maybe [Address]+mkAddresses s = eitherToMaybe . P.parse parser "" . TL.unpack $ s where+	address = do+		method <- P.many (P.noneOf ":;")+		P.char ':'+		params <- P.sepEndBy param (P.char ',')+		return $ Address (TL.pack method) (M.fromList params)+	+	param = do+		key <- P.many1 (P.noneOf "=;,")+		P.char '='+		value <- P.many1 (encodedValue <|> unencodedValue)+		return (TL.pack key, TL.pack value)+	+	parser = do+		as <- P.sepEndBy1 address (P.char ';')+		P.eof+		return as+	+	unencodedValue = P.oneOf optionallyEncoded+	encodedValue = do+		P.char '%'+		hex <- P.count 2 P.hexDigit+		return . chr . hexToInt $ hex++@+Converting an {\tt Address} back to a {\tt String} is just the reverse+operation. Note that because the original parameter order is not preserved,+the string produced might differ from the original input.++<<DBus/Address.hs>>=+strAddress :: Address -> Text+strAddress (Address t ps) = TL.concat [t, ":", ps'] where+	ps' = TL.intercalate "," $ do+		(k, v) <- M.toList ps+		return $ TL.concat [k, "=", TL.concatMap encode v]+	encode c | elem c optionallyEncoded = TL.singleton c+	         | otherwise       = TL.pack $ printf "%%%02X" (ord c)+++@+\section{Introspection}++@ DBus objects may be ``introspected'' to determine which methods, signals,+etc they support. Intospection data is sent over the bus in {\sc xml}, in+a mostly standardised but undocumented format.++An XML introspection document looks like this:++\begin{verbatim}+<!DOCTYPE node PUBLIC "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+         "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd">+<node name="/org/example/example">+	<interface name="org.example.ExampleInterface">+		<method name="Echo">+			<arg name="text" type="s" direction="in"/>+			<arg type="s" direction="out"/>+		</method>+		<signal name="Echoed">+			<arg type="s"/>+		</signal>+		<property name="EchoCount" type="u" access="read"/>+	</interface>+	<node name="child_a"/>+	<node name="child/b"/>+</node>+\end{verbatim}++<<DBus/Introspection.hs>>=+<<copyright>>+<<text extensions>>+module DBus.Introspection+	( Object (..)+	, Interface (..)+	, Method (..)+	, Signal (..)+	, Parameter (..)+	, Property (..)+	, PropertyAccess (..)+	, toXML+	, fromXML+	) where+<<text imports>>+<<introspection imports>>+import qualified DBus.Types as T++@ HaXml is used to do the heavy lifting of XML parsing because HXT cannot+be combined with Parsec 3.++<<introspection imports>>=+import qualified Text.XML.HaXml as H++@ \subsection{Data types}++<<DBus/Introspection.hs>>=+data Object = Object T.ObjectPath [Interface] [Object]+	deriving (Show, Eq)++data Interface = Interface T.InterfaceName [Method] [Signal] [Property]+	deriving (Show, Eq)++data Method = Method T.MemberName [Parameter] [Parameter]+	deriving (Show, Eq)++data Signal = Signal T.MemberName [Parameter]+	deriving (Show, Eq)++data Parameter = Parameter Text T.Signature+	deriving (Show, Eq)++data Property = Property Text T.Signature [PropertyAccess]+	deriving (Show, Eq)++data PropertyAccess = Read | Write+	deriving (Show, Eq)++@ \subsection{Parsing XML}++The root {\tt node} is special, in that it's the only {\tt node} which is+not required to have a {\tt name} attribute. If the root has no {\tt name},+its path will default to the path of the introspected object.++If parsing fails, {\tt fromXML} will return {\tt Nothing}. Aside from the+elements directly accessed by the parser, no effort is made to check the+document's validity because there is no DTD as of yet.++<<introspection imports>>=+import Text.XML.HaXml.Parse (xmlParse')+import DBus.Util (eitherToMaybe)++<<DBus/Introspection.hs>>=+fromXML :: T.ObjectPath -> Text -> Maybe Object+fromXML path text = do+	doc <- eitherToMaybe . xmlParse' "" . TL.unpack $ text+	let (H.Document _ _ root _) = doc+	parseRoot path root++@ Even though the root object's {\tt name} is optional, if present, it must+still be a valid object path.++<<DBus/Introspection.hs>>=+parseRoot :: T.ObjectPath -> H.Element a -> Maybe Object+parseRoot defaultPath e = do+	path <- case getAttr "name" e of+		Nothing -> Just defaultPath+		Just x  -> T.mkObjectPath x+	parseObject' path e++@ Child {\tt nodes} have ``relative'' paths -- that is, their {\tt name}+attribute is not a valid object path, but should be valid when appended to+the root object's path.++<<DBus/Introspection.hs>>=+parseChild :: T.ObjectPath -> H.Element a -> Maybe Object+parseChild parentPath e = do+	let parentPath' = case T.strObjectPath parentPath of+		"/" -> "/"+		x   -> TL.append x "/"+	pathSegment <- getAttr "name" e+	path <- T.mkObjectPath $ TL.append parentPath' pathSegment+	parseObject' path e++@ Other than the name, both root and non-root {\tt nodes} have identical+contents.  They may contain interface definitions, and child {\tt node}s.++<<DBus/Introspection.hs>>=+parseObject' :: T.ObjectPath -> H.Element a -> Maybe Object+parseObject' path e@(H.Elem "node" _ _)  = do+	interfaces <- children parseInterface (H.tag "interface") e+	children' <- children (parseChild path) (H.tag "node") e+	return $ Object path interfaces children'+parseObject' _ _ = Nothing++@ Interfaces may contain methods, signals, and properties.++<<DBus/Introspection.hs>>=+parseInterface :: H.Element a -> Maybe Interface+parseInterface e = do+	name <- T.mkInterfaceName =<< getAttr "name" e+	methods <- children parseMethod (H.tag "method") e+	signals <- children parseSignal (H.tag "signal") e+	properties <- children parseProperty (H.tag "property") e+	return $ Interface name methods signals properties++@ Methods contain a list of parameters, which default to ``in'' parameters+if no direction is specified.++<<DBus/Introspection.hs>>=+parseMethod :: H.Element a -> Maybe Method+parseMethod e = do+	name <- T.mkMemberName =<< getAttr "name" e+	paramsIn <- children parseParameter (isParam ["in", ""]) e+	paramsOut <- children parseParameter (isParam ["out"]) e+	return $ Method name paramsIn paramsOut++@ Signals are similar to methods, except they have no ``in'' parameters.++<<DBus/Introspection.hs>>=+parseSignal :: H.Element a -> Maybe Signal+parseSignal e = do+	name <- T.mkMemberName =<< getAttr "name" e+	params <- children parseParameter (isParam ["out", ""]) e+	return $ Signal name params++@ A parameter has a free-form name, and a single valid type.++<<DBus/Introspection.hs>>=+parseParameter :: H.Element a -> Maybe Parameter+parseParameter e = do+	let name = getAttr' "name" e+	sig <- parseType e+	return $ Parameter name sig++<<DBus/Introspection.hs>>=+parseType :: H.Element a -> Maybe T.Signature+parseType e = do+	sig <- T.mkSignature =<< getAttr "type" e+	case T.signatureTypes sig of+		[_] -> Just sig+		_   -> Nothing++@ Properties are used by the {\tt org.freedesktop.DBus.Properties} interface.+Each property may be read, written, or both, and has an associated type.++<<DBus/Introspection.hs>>=+parseProperty :: H.Element a -> Maybe Property+parseProperty e = do+	let name = getAttr' "name" e+	sig <- parseType e+	access <- case getAttr' "access" e of+		""          -> Just []+		"read"      -> Just [Read]+		"write"     -> Just [Write]+		"readwrite" -> Just [Read, Write]+		_           -> Nothing+	return $ Property name sig access++@ HaXml doesn't seem to have any way to retrieve the ``real'' value of an+attribute, so {\tt attrValue} implements this.++<<introspection imports>>=+import Data.Char (chr)++<<DBus/Introspection.hs>>=+attrValue :: H.AttValue -> Maybe Text+attrValue attr = fmap (TL.pack . concat) $ mapM unescape parts where+	(H.AttValue parts) = attr+	+	unescape (Left x) = Just x+	unescape (Right (H.RefEntity x)) = lookup x namedRefs+	unescape (Right (H.RefChar x)) = Just [chr x]+	+	namedRefs =+		[ ("lt", "<")+		, ("gt", ">")+		, ("amp", "&")+		, ("apos", "'")+		, ("quot", "\"")+		]++@ Some helper functions for dealing with HaXml filters++<<introspection imports>>=+import Data.Maybe (fromMaybe)++<<DBus/Introspection.hs>>=+getAttr :: String -> H.Element a -> Maybe Text+getAttr name (H.Elem _ attrs _) = lookup name attrs >>= attrValue++getAttr' :: String -> H.Element a -> Text+getAttr' = (fromMaybe "" .) . getAttr++<<DBus/Introspection.hs>>=+isParam :: [Text] -> H.CFilter a+isParam dirs content = do+	arg@(H.CElem e _) <- H.tag "arg" content+	let direction = getAttr' "direction" e+	[arg | direction `elem` dirs]++<<DBus/Introspection.hs>>=+children :: Monad m => (H.Element a -> m b) -> H.CFilter a -> H.Element a -> m [b]+children f filt (H.Elem _ _ contents) = do+	mapM f [x | (H.CElem x _) <- concatMap filt contents]++@ \subsection{Generating XML}++<<DBus/Introspection.hs>>=+dtdPublicID, dtdSystemID :: String+dtdPublicID = "-//freedesktop//DTD D-BUS Object Introspection 1.0//EN"+dtdSystemID = "http://www.freedesktop.org/standards/dbus/1.0/introspect.dtd"++@ HaXml punts to the {\tt pretty} package for serialising XML.++<<introspection imports>>=+import Text.XML.HaXml.Pretty (document)+import Text.PrettyPrint.HughesPJ (render)++@ Generating XML can fail; if a child object's path is not a sub-path of the+parent, {\tt toXML} will return {\tt Nothing}.++<<DBus/Introspection.hs>>=+toXML :: Object -> Maybe Text+toXML obj = fmap (TL.pack . render . document) doc where+	prolog = H.Prolog Nothing [] (Just doctype) []+	doctype = H.DTD "node" (Just (H.PUBLIC+		(H.PubidLiteral dtdPublicID)+		(H.SystemLiteral dtdSystemID))) []+	doc = do+		root <- xmlRoot obj+		return $ H.Document prolog H.emptyST root []++@ When writing objects to {\tt node}s, the root object must have an absolute+path, and children must have paths relative to their parent.++<<DBus/Introspection.hs>>=+xmlRoot :: Object -> Maybe (H.Element a)+xmlRoot obj@(Object path _ _) = do+	(H.CElem root _) <- xmlObject' (T.strObjectPath path) obj+	return $ root++<<DBus/Introspection.hs>>=+xmlObject :: T.ObjectPath -> Object -> Maybe (H.Content a)+xmlObject parentPath obj@(Object path _ _) = do+	let path' = T.strObjectPath path+	    parent' = T.strObjectPath parentPath+	relpath <- if TL.isPrefixOf parent' path'+		then Just $ if parent' == "/"+			then TL.drop 1 path'+			else TL.drop (TL.length parent' + 1) path'+		else Nothing+	xmlObject' relpath obj++<<DBus/Introspection.hs>>=+xmlObject' :: Text -> Object -> Maybe (H.Content a)+xmlObject' path (Object fullPath interfaces children') = do+	children'' <- mapM (xmlObject fullPath) children'+	return $ mkElement "node"+		[mkAttr "name" $ TL.unpack path]+		$ concat+			[ map xmlInterface interfaces+			, children''+			]++<<DBus/Introspection.hs>>=+xmlInterface :: Interface -> H.Content a+xmlInterface (Interface name methods signals properties) =+	mkElement "interface"+		[mkAttr "name" . TL.unpack . T.strInterfaceName $ name]+		$ concat+			[ map xmlMethod methods+			, map xmlSignal signals+			, map xmlProperty properties+			]++<<DBus/Introspection.hs>>=+xmlMethod :: Method -> H.Content a+xmlMethod (Method name inParams outParams) = mkElement "method"+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ concat+		[ map (xmlParameter "in") inParams+		, map (xmlParameter "out") outParams+		]++<<DBus/Introspection.hs>>=+xmlSignal :: Signal -> H.Content a+xmlSignal (Signal name params) = mkElement "signal"+	[mkAttr "name" . TL.unpack . T.strMemberName $ name]+	$ map (xmlParameter "out") params++<<DBus/Introspection.hs>>=+xmlParameter :: String -> Parameter -> H.Content a+xmlParameter direction (Parameter name sig) = mkElement "arg"+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "direction" direction+	] []++<<DBus/Introspection.hs>>=+xmlProperty :: Property -> H.Content a+xmlProperty (Property name sig access) = mkElement "property"+	[ mkAttr "name" . TL.unpack $ name+	, mkAttr "type" . TL.unpack . T.strSignature $ sig+	, mkAttr "access" $ xmlAccess access+	] []++<<DBus/Introspection.hs>>=+xmlAccess :: [PropertyAccess] -> String+xmlAccess access = read ++ write where+	read = if elem Read access then "read" else ""+	write = if elem Write access then "write" else ""++<<DBus/Introspection.hs>>=+mkElement :: String -> [H.Attribute] -> [H.Content a] -> H.Content a+mkElement name attrs contents = H.CElem (H.Elem name attrs contents) undefined++<<DBus/Introspection.hs>>=+mkAttr :: String -> String -> H.Attribute+mkAttr name value = (name, H.AttValue [Left escaped]) where+	raw = H.CString True value ()+	escaped = H.verbatim $ H.xmlEscapeContent H.stdXmlEscaper [raw]++@+\section{Constants}++<<DBus/Constants.hs>>=+<<copyright>>+{-# LANGUAGE OverloadedStrings #-}+module DBus.Constants where+import qualified DBus.Types as T+import Data.Word (Word8, Word32)++<<DBus/Constants.hs>>=+protocolVersion :: Word8+protocolVersion = 1++messageMaximumLength :: Word32+messageMaximumLength = 134217728++arrayMaximumLength :: Word32+arrayMaximumLength = 67108864++@ \subsection{The message bus}++<<DBus/Constants.hs>>=+dbusName :: T.BusName+dbusName = T.mkBusName' "org.freedesktop.DBus"++dbusPath :: T.ObjectPath+dbusPath = T.mkObjectPath' "/org/freedesktop/DBus"++dbusInterface :: T.InterfaceName+dbusInterface = T.mkInterfaceName' "org.freedesktop.DBus"++@ \subsection{Pre-defined interfaces}++<<DBus/Constants.hs>>=+interfaceIntrospectable :: T.InterfaceName+interfaceIntrospectable = T.mkInterfaceName' "org.freedesktop.DBus.Introspectable"++interfaceProperties :: T.InterfaceName+interfaceProperties = T.mkInterfaceName' "org.freedesktop.DBus.Properties"++interfacePeer :: T.InterfaceName+interfacePeer = T.mkInterfaceName' "org.freedesktop.DBus.Peer"++@ \subsection{Pre-defined error names}++<<DBus/Constants.hs>>=+errorFailed :: T.ErrorName+errorFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Failed"++errorNoMemory :: T.ErrorName+errorNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.NoMemory"++errorServiceUnknown :: T.ErrorName+errorServiceUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.ServiceUnknown"++errorNameHasNoOwner :: T.ErrorName+errorNameHasNoOwner = T.mkErrorName' "org.freedesktop.DBus.Error.NameHasNoOwner"++errorNoReply :: T.ErrorName+errorNoReply = T.mkErrorName' "org.freedesktop.DBus.Error.NoReply"++errorIOError :: T.ErrorName+errorIOError = T.mkErrorName' "org.freedesktop.DBus.Error.IOError"++errorBadAddress :: T.ErrorName+errorBadAddress = T.mkErrorName' "org.freedesktop.DBus.Error.BadAddress"++errorNotSupported :: T.ErrorName+errorNotSupported = T.mkErrorName' "org.freedesktop.DBus.Error.NotSupported"++errorLimitsExceeded :: T.ErrorName+errorLimitsExceeded = T.mkErrorName' "org.freedesktop.DBus.Error.LimitsExceeded"++errorAccessDenied :: T.ErrorName+errorAccessDenied = T.mkErrorName' "org.freedesktop.DBus.Error.AccessDenied"++errorAuthFailed :: T.ErrorName+errorAuthFailed = T.mkErrorName' "org.freedesktop.DBus.Error.AuthFailed"++errorNoServer :: T.ErrorName+errorNoServer = T.mkErrorName' "org.freedesktop.DBus.Error.NoServer"++errorTimeout :: T.ErrorName+errorTimeout = T.mkErrorName' "org.freedesktop.DBus.Error.Timeout"++errorNoNetwork :: T.ErrorName+errorNoNetwork = T.mkErrorName' "org.freedesktop.DBus.Error.NoNetwork"++errorAddressInUse :: T.ErrorName+errorAddressInUse = T.mkErrorName' "org.freedesktop.DBus.Error.AddressInUse"++errorDisconnected :: T.ErrorName+errorDisconnected = T.mkErrorName' "org.freedesktop.DBus.Error.Disconnected"++errorInvalidArgs :: T.ErrorName+errorInvalidArgs = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidArgs"++errorFileNotFound :: T.ErrorName+errorFileNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.FileNotFound"++errorFileExists :: T.ErrorName+errorFileExists = T.mkErrorName' "org.freedesktop.DBus.Error.FileExists"++errorUnknownMethod :: T.ErrorName+errorUnknownMethod = T.mkErrorName' "org.freedesktop.DBus.Error.UnknownMethod"++errorTimedOut :: T.ErrorName+errorTimedOut = T.mkErrorName' "org.freedesktop.DBus.Error.TimedOut"++errorMatchRuleNotFound :: T.ErrorName+errorMatchRuleNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleNotFound"++errorMatchRuleInvalid :: T.ErrorName+errorMatchRuleInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.MatchRuleInvalid"++errorSpawnExecFailed :: T.ErrorName+errorSpawnExecFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ExecFailed"++errorSpawnForkFailed :: T.ErrorName+errorSpawnForkFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ForkFailed"++errorSpawnChildExited :: T.ErrorName+errorSpawnChildExited = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildExited"++errorSpawnChildSignaled :: T.ErrorName+errorSpawnChildSignaled = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ChildSignaled"++errorSpawnFailed :: T.ErrorName+errorSpawnFailed = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.Failed"++errorSpawnFailedToSetup :: T.ErrorName+errorSpawnFailedToSetup = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FailedToSetup"++errorSpawnConfigInvalid :: T.ErrorName+errorSpawnConfigInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ConfigInvalid"++errorSpawnServiceNotValid :: T.ErrorName+errorSpawnServiceNotValid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotValid"++errorSpawnServiceNotFound :: T.ErrorName+errorSpawnServiceNotFound = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.ServiceNotFound"++errorSpawnPermissionsInvalid :: T.ErrorName+errorSpawnPermissionsInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.PermissionsInvalid"++errorSpawnFileInvalid :: T.ErrorName+errorSpawnFileInvalid = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.FileInvalid"++errorSpawnNoMemory :: T.ErrorName+errorSpawnNoMemory = T.mkErrorName' "org.freedesktop.DBus.Error.Spawn.NoMemory"++errorUnixProcessIdUnknown :: T.ErrorName+errorUnixProcessIdUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.UnixProcessIdUnknown"++errorInvalidFileContent :: T.ErrorName+errorInvalidFileContent = T.mkErrorName' "org.freedesktop.DBus.Error.InvalidFileContent"++errorSELinuxSecurityContextUnknown :: T.ErrorName+errorSELinuxSecurityContextUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.SELinuxSecurityContextUnknown"++errorAdtAuditDataUnknown :: T.ErrorName+errorAdtAuditDataUnknown = T.mkErrorName' "org.freedesktop.DBus.Error.AdtAuditDataUnknown"++errorObjectPathInUse :: T.ErrorName+errorObjectPathInUse = T.mkErrorName' "org.freedesktop.DBus.Error.ObjectPathInUse"++errorInconsistentMessage :: T.ErrorName+errorInconsistentMessage = T.mkErrorName' "org.freedesktop.DBus.Error.InconsistentMessage"++@+\section{Misc. utility functions}++<<DBus/Util.hs>>=+<<copyright>>+module DBus.Util where+import Text.Parsec (Parsec, parse)+import Data.Char (digitToInt)++checkLength :: Int -> String -> Maybe String+checkLength length' s | length s <= length' = Just s+checkLength _ _ = Nothing++parseMaybe :: Parsec String () a -> String -> Maybe a+parseMaybe p = either (const Nothing) Just . parse p ""++mkUnsafe :: Show a => String -> (a -> Maybe b) -> a -> b+mkUnsafe label f x = case f x of+	Just x' -> x'+	Nothing -> error $ "Invalid " ++ label ++ ": " ++ show x++hexToInt :: String -> Int+hexToInt = foldl ((+) . (16 *)) 0 . map digitToInt++eitherToMaybe :: Either a b -> Maybe b+eitherToMaybe (Left  _) = Nothing+eitherToMaybe (Right x) = Just x++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "DBus.Util.fromRight: Left"++@ \end{document}