dbus-core 0.3 → 0.4

raw patch · 37 files changed

+2009/−1583 lines, 37 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• DBus/Address.lhs +137/−0
• DBus/Authentication.lhs +70/−0
• DBus/Bus.lhs +9/−9
• DBus/Bus/Address.lhs +0/−148
• DBus/Bus/Connection.lhs +0/−236
• DBus/Connection.lhs +237/−0
• DBus/Constants.lhs +271/−0
• DBus/Marshal.lhs +242/−0
• DBus/Message.lhs +36/−27
• DBus/Padding.lhs +59/−0
• DBus/Protocol/Authentication.lhs +0/−71
• DBus/Protocol/Marshal.lhs +0/−243
• DBus/Protocol/Padding.lhs +0/−60
• DBus/Protocol/Unmarshal.lhs +0/−313
• DBus/Types.lhs +1/−1
• DBus/Types/Atom.lhs +15/−16
• DBus/Types/Containers.lhs +20/−303
• DBus/Types/Containers.lhs-boot +0/−51
• DBus/Types/Containers/Array.lhs +84/−0
• DBus/Types/Containers/Dictionary.lhs +110/−0
• DBus/Types/Containers/Structure.lhs +48/−0
• DBus/Types/Containers/Variant.lhs +186/−0
• DBus/Types/Endianness.lhs +6/−4
• DBus/Types/Names.lhs +37/−10
• DBus/Types/ObjectPath.lhs +7/−2
• DBus/Types/Serial.lhs +4/−4
• DBus/Types/Signature.lhs +11/−4
• DBus/Types/Util.lhs +0/−40
• DBus/Unmarshal.lhs +312/−0
• DBus/Util.lhs +61/−0
• Examples/dbus-monitor.hs +7/−6
• Tests/Address.hs +1/−1
• Tests/Containers.hs +4/−4
• Tests/Instances.hs +10/−11
• Tests/Marshal.hs +2/−3
• dbus-core.cabal +15/−11
• dbus-core.tex +7/−5

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

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

@@ -24,18 +24,19 @@  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.Bus.Address as A-import qualified DBus.Bus.Connection as C++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@@ -92,11 +93,10 @@  \begin{code} hello :: M.MethodCall-hello = M.MethodCall-	(fromJust . T.mkObjectPath $ "/org/freedesktop/DBus")-	(fromJust . T.mkMemberName $ "Hello")-	(T.mkInterfaceName "org.freedesktop.DBus")-	(T.mkBusName "org.freedesktop.DBus")+hello = M.MethodCall dbusPath+	(T.mkMemberName' "Hello")+	(Just dbusInterface)+	(Just dbusName) 	Set.empty 	[] \end{code}

@@ -1,148 +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.Address-	( Address-	, addressMethod-	, addressParameters-	, strAddress-	, parseAddresses-	) where--import Data.Char (ord, digitToInt, chr)-import qualified Data.Map as M-import Data.List (intercalate)-import Text.Printf (printf)-import qualified Text.Parsec as P-import Text.Parsec ((<|>))-\end{code}-}--\section{Addresses}--\subsection{Formatting}--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}--Finally, a couple parser utility functions.--\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}

@@ -1,236 +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.Bus.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.Types as T-import DBus.Message (Message, ReceivedMessage, marshal, unmarshal)-import qualified DBus.Bus.Address as A-import DBus.Protocol.Authentication (authenticate)-\end{code}-}--\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}-

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

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

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

@@ -16,16 +16,30 @@ \ignore{ \begin{code} module DBus.Message-	( 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@@ -38,10 +52,11 @@ import Data.Maybe (fromJust, fromMaybe, listToMaybe, mapMaybe) import qualified Data.Set as S -import qualified DBus.Protocol.Marshal as M-import qualified DBus.Protocol.Unmarshal as U-import DBus.Protocol.Padding (padding)+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} } @@ -61,13 +76,6 @@ 	messageBody         :: a -> [T.Variant] \end{code} -All messages are assumed to be using protocol version 1.--\begin{code}-protocolVersion :: Word8-protocolVersion = 1-\end{code}- \subsection{Flags}  Flags are represented as the integral value of each flag OR'd into a single@@ -99,14 +107,15 @@ \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+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} @@ -128,7 +137,7 @@ 	return (c', v')  instance T.Variable HeaderField where-	defaultSignature _ = fromJust . T.mkSignature $ "(yv)"+	defaultSignature _ = T.mkSignature' "(yv)" 	 	toVariant (Path x)        = header' 1 x 	toVariant (Interface x)   = header' 2 x@@ -272,7 +281,7 @@                -> MessageHeader buildHeader endianness serial m bodyLen = header where 	ts = map T.variantType $ messageBody m-	bodySig = fromJust . T.mkSignature $ concatMap T.typeString ts+	bodySig = T.mkSignature' $ concatMap T.typeString ts 	fields = Signature bodySig : messageHeaderFields m 	header = MessageHeader 		endianness@@ -327,8 +336,8 @@ unknown messages.  \begin{code}-data ReceivedMessage =-	  ReceivedMethodCall   T.Serial (Maybe T.BusName) MethodCall+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@@ -380,8 +389,8 @@ getRaw :: (E.Error e, E.MonadError e m) =>           (Word32 -> m L.ByteString) -> m RawMessage getRaw get = do-	let fixed'Sig = fromJust . T.mkSignature $ "yyyy"-	let fixedSig  = fromJust . T.mkSignature $ "yyyyuuu"+	let fixed'Sig = T.mkSignature' "yyyy"+	let fixedSig  = T.mkSignature' "yyyyuuu" 	 	-- Protocol version 	fixedBytes <- get 16@@ -432,7 +441,7 @@ parseHeader :: (E.Error e, E.MonadError e m)                => T.Endianness -> L.ByteString -> m MessageHeader parseHeader endianness bytes = do-	let signature = fromJust . T.mkSignature $ "yyyyuua(yv)"+	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@@ -453,7 +462,7 @@ \begin{code} findBodySignature :: [HeaderField] -> T.Signature findBodySignature fields = fromMaybe empty signature where-	empty = fromJust . T.mkSignature $ ""+	empty = T.mkSignature' "" 	signature = listToMaybe [x | Signature x <- fields] \end{code} 

@@ -0,0 +1,59 @@+% 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,71 +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}-{-# OPTIONS_HADDOCK hide #-}-module DBus.Protocol.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,243 +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}-{-# OPTIONS_HADDOCK hide #-}-module DBus.Protocol.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.Protocol.Padding (padding, padByType)-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 (padByType 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,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/>.--\ignore{-\begin{code}-{-# OPTIONS_HADDOCK hide #-}-module DBus.Protocol.Padding-	( padding-	, padByType-	) where--import Data.Word (Word8, Word64)-import qualified DBus.Types as T-\end{code}-}--\section{Value padding}--\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}-padByType :: T.Type -> Word8-padByType T.BooleanT          = 4-padByType T.ByteT             = 1-padByType T.UInt16T           = 2-padByType T.UInt32T           = 4-padByType T.UInt64T           = 8-padByType T.Int16T            = 2-padByType T.Int32T            = 4-padByType T.Int64T            = 8-padByType T.DoubleT           = 8-padByType T.StringT           = 4-padByType T.ObjectPathT       = 4-padByType T.SignatureT        = 1-padByType (T.ArrayT _)        = 4-padByType (T.DictionaryT _ _) = 4-padByType (T.StructureT _)    = 8-padByType T.VariantT          = 1-\end{code}-

@@ -1,313 +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}-{-# OPTIONS_HADDOCK hide #-}-{-# LANGUAGE ExistentialQuantification #-}-module DBus.Protocol.Unmarshal (unmarshal) where--import Data.Maybe (fromJust)-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.Protocol.Padding (padding, padByType)-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 = fromJust . T.mkSignature . T.typeString $ t-	-	byteCount <- word32-	skipPadding (padByType 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 = fromJust . T.mkSignature . T.typeString $ kt-	let vSig = fromJust . 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}

@@ -38,10 +38,10 @@ \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}-\input{DBus/Types/Containers.lhs}

@@ -13,13 +13,12 @@ % You should have received a copy of the GNU General Public License % along with this program.  If not, see <http://www.gnu.org/licenses/>. -\subsection{Atoms}- \ignore{ \begin{code} {-# LANGUAGE TypeSynonymInstances #-} module DBus.Types.Atom-	( Atom+	( -- * Atoms+	  Atom 	, Atomic 	, toAtom 	, fromAtom@@ -34,27 +33,29 @@ import Data.Int (Int16, Int32, Int64) import qualified DBus.Types.Signature as S import qualified DBus.Types.ObjectPath as O-import {-# SOURCE #-} qualified DBus.Types.Containers as C+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 C.Variant+newtype Atom = Atom V.Variant 	deriving (Show, Eq) -class C.Variable a => Atomic a where+class V.Variable a => Atomic a where 	toAtom :: a -> Atom -atomToVariant :: Atom -> C.Variant+atomToVariant :: Atom -> V.Variant atomToVariant (Atom x) = x -atomFromVariant :: C.Variant -> Maybe Atom+atomFromVariant :: V.Variant -> Maybe Atom atomFromVariant v = msum as where-	v' :: C.Variable a => Maybe a-	v' = C.fromVariant v+	v' :: V.Variable a => Maybe a+	v' = V.fromVariant v 	fa :: (Atomic a, Functor f) => f a -> f Atom 	fa = fmap toAtom 	@@ -74,13 +75,13 @@ \end{code}  \begin{code}-fromAtom :: C.Variable a => Atom -> Maybe a-fromAtom (Atom x) = C.fromVariant x+fromAtom :: V.Variable a => Atom -> Maybe a+fromAtom (Atom x) = V.fromVariant x \end{code}  \begin{code} atomSignature :: Atom -> S.Signature-atomSignature (Atom v) = C.variantSignature v+atomSignature (Atom v) = V.variantSignature v \end{code}  \begin{code}@@ -88,11 +89,9 @@ atomType = head . S.signatureTypes . atomSignature \end{code} -\subsubsection{Built-in atomic types}- \begin{code} toAtom' :: Atomic a => a -> Atom-toAtom' = Atom . C.toVariant+toAtom' = Atom . V.toVariant  instance Atomic Bool         where toAtom = toAtom' instance Atomic Word8        where toAtom = toAtom'

@@ -15,318 +15,35 @@  \ignore{ \begin{code}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.Containers-	( Variant-	, Variable-	, toVariant-	, fromVariant-	, defaultSignature+	( -- * Containers+	+	  -- ** Variants+	  Variant+	, Variable (..) 	, variantSignature 	, variantType 	-	, Array-	, toArray-	, fromArray-	, arrayItems-	, arrayFromItems-	, arraySignature+	  -- ** Arrays+	, module DBus.Types.Containers.Array 	-	, Dictionary-	, toDictionary-	, fromDictionary-	, dictionaryItems-	, dictionaryFromItems-	, dictionarySignature+	  -- ** Dictionaries+	, module DBus.Types.Containers.Dictionary 	-	, Structure (..)-	, structureSignature+	  -- ** Structures+	, module DBus.Types.Containers.Structure 	) where -import Control.Arrow ((***))-import Data.Typeable (Typeable, cast)-import Data.Maybe (fromJust)-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.Atom as A+import DBus.Types.Containers.Variant+import DBus.Types.Containers.Array+import DBus.Types.Containers.Dictionary+import DBus.Types.Containers.Structure \end{code} }-\subsection{Containers} -\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 _ = sig' "v"-	toVariant = variant' "v"-	fromVariant = cast'-\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 _ = sig' "b"-	toVariant = variant' "b"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Word8 where-	defaultSignature _ = sig' "y"-	toVariant = variant' "y"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Word16 where-	defaultSignature _ = sig' "q"-	toVariant = variant' "q"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Word32 where-	defaultSignature _ = sig' "u"-	toVariant = variant' "u"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Word64 where-	defaultSignature _ = sig' "t"-	toVariant = variant' "t"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Int16 where-	defaultSignature _ = sig' "n"-	toVariant = variant' "n"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Int32 where-	defaultSignature _ = sig' "i"-	toVariant = variant' "i"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Int64 where-	defaultSignature _ = sig' "x"-	toVariant = variant' "x"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable Double where-	defaultSignature _ = sig' "d"-	toVariant = variant' "d"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable String where-	defaultSignature _ = sig' "s"-	toVariant = variant' "s"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable O.ObjectPath where-	defaultSignature _ = sig' "o"-	toVariant = variant' "o"-	fromVariant = cast'-\end{code}--\begin{code}-instance Variable S.Signature where-	defaultSignature _ = sig' "g"-	toVariant = variant' "g"-	fromVariant = cast'-\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 [Variant]-	deriving (Show, Eq, Typeable)--instance Variable Array where-	defaultSignature _ = sig' "ay"-	toVariant x = Variant (arraySignature x) x-	fromVariant = cast'--toArray :: Variable a => [a] -> Maybe Array-toArray vs@([]) = Just $ Array sig [] where-	itemSig = defaultSignature . head $ undefined:vs-	sig = sig' $ 'a' : S.strSignature itemSig--toArray vs = arrayFromItems sig variants where-	variants = map toVariant vs-	sig = variantSignature . head $ variants--fromArray :: Variable a => Array -> Maybe [a]-fromArray (Array _ vs) = mapM fromVariant vs--arrayItems :: Array -> [Variant]-arrayItems (Array _ vs) = vs--arrayFromItems :: S.Signature -> [Variant] -> Maybe Array-arrayFromItems itemSig vs = maybeArray where-	maybeArray = if hasSignature itemSig vs-		then Just (Array sig vs)-		else Nothing-	sig = sig' $ 'a' : S.strSignature itemSig--arraySignature :: Array -> S.Signature-arraySignature (Array s _) = s-\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, Variant)]-	deriving (Show, Eq, Typeable)--instance Variable Dictionary where-	defaultSignature _ = sig' "a{yy}"-	toVariant x = Variant (dictionarySignature x) x-	fromVariant = cast'--toDictionary :: (A.Atomic a, Variable b) => [(a, b)] -> Maybe Dictionary-toDictionary vs@([]) = Just $ Dictionary sig [] where-	fake = head $ (undefined, undefined) : vs-	kSig = S.strSignature . defaultSignature . fst $ fake-	vSig = S.strSignature . defaultSignature . snd $ fake-	sig = sig' $ "a{" ++ kSig ++ vSig ++ "}"--toDictionary pairs = dictionaryFromItems kSig vSig pairs' where-	pairs' = map (A.toAtom *** toVariant) pairs-	kSig = A.atomSignature  . fst . head $ pairs'-	vSig = variantSignature . snd . head $ pairs'--fromDictionary :: (A.Atomic a, Variable b) => Dictionary -> Maybe [(a, b)]-fromDictionary (Dictionary _ vs) = mapM fromVariant' vs where-	fromVariant' (k, v) = do-		k' <- A.fromAtom k-		v' <- fromVariant v-		return (k', v')--dictionaryItems :: Dictionary -> [(A.Atom, Variant)]-dictionaryItems (Dictionary _ vs) = vs--dictionaryFromItems :: S.Signature -> S.Signature -> [(A.Atom, 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 = sig' $ "a{" ++ kSig' ++ vSig' ++ "}"--dictionarySignature :: Dictionary -> S.Signature-dictionarySignature (Dictionary s _) = s-\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 [Variant]-	deriving (Show, Eq, Typeable)--instance Variable Structure where-	defaultSignature _ = sig' "()"-	toVariant x = Variant (structureSignature x) x-	fromVariant = cast'--structureSignature :: Structure -> S.Signature-structureSignature (Structure vs) = sig where-	sigs = [s | (Variant s _) <- vs]-	sig = sig' $ "(" ++ concatMap S.strSignature sigs ++ ")"-\end{code}--\subsubsection*{Helper functions}--\begin{code}-sig' :: String -> S.Signature-sig' = fromJust . S.mkSignature--variant' :: (Variable a, Typeable a, Show a) => String -> a -> Variant-variant' = Variant . sig'--cast' :: Typeable a => Variant -> Maybe a-cast' (Variant _ x) = cast x+\subsection{Containers} -hasSignature :: S.Signature -> [Variant] -> Bool-hasSignature _   [] = True-hasSignature sig vs = all (== sig) . map variantSignature $ vs-\end{code}+\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,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/>.--This is just a stub file so {\tt Atom} can implement {\tt Variable}.--\begin{code}-{-# LANGUAGE TypeSynonymInstances #-}-module DBus.Types.Containers where--import Data.Word (Word8, Word16, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-import DBus.Types.Signature (Signature)-import DBus.Types.ObjectPath (ObjectPath)--class Variable a where-	defaultSignature :: a -> Signature-	toVariant :: a -> Variant-	fromVariant :: Variant -> Maybe a--data Variant--instance Show Variant-instance Eq Variant--instance Variable Bool-instance Variable Word8-instance Variable Word16-instance Variable Word32-instance Variable Word64-instance Variable Int16-instance Variable Int32-instance Variable Int64-instance Variable Double-instance Variable String-instance Variable ObjectPath-instance Variable Signature--variantSignature :: Variant -> Signature-\end{code}

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

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

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

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

@@ -15,12 +15,14 @@  \ignore{ \begin{code}-module DBus.Types.Endianness (Endianness (..)) where+module DBus.Types.Endianness+	( -- * Endianness+	  Endianness (..)+	) where  import Data.Word (Word8)-import Data.Maybe (fromJust) import qualified DBus.Types.Containers as C-import DBus.Types.Signature (mkSignature)+import DBus.Types.Signature (mkSignature') \end{code} } @@ -37,7 +39,7 @@  \begin{code} instance C.Variable Endianness where-	defaultSignature _ = fromJust . mkSignature $ "y"+	defaultSignature _ = mkSignature' "y" 	toVariant LittleEndian = C.toVariant (0x6C :: Word8) 	toVariant BigEndian = C.toVariant (0x42 :: Word8) 	fromVariant v = do

@@ -16,35 +16,42 @@ \ignore{ \begin{code} module DBus.Types.Names-	( InterfaceName+	( -- * 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 Data.Maybe (fromJust) 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.Types.Util (checkLength, parseMaybe)+import DBus.Types.Signature (mkSignature')+import DBus.Util (checkLength, parseMaybe, mkUnsafe) \end{code} } -\subsubsection{Names}- All names have a length limit of 255 characters.  \subsubsection{Interface names}@@ -60,7 +67,7 @@  \begin{code} instance C.Variable InterfaceName where-	defaultSignature _ = fromJust . mkSignature $ "s"+	defaultSignature _ = mkSignature' "s" 	toVariant = A.atomToVariant . A.toAtom 	fromVariant = (mkInterfaceName =<<) . C.fromVariant instance A.Atomic InterfaceName where@@ -78,6 +85,11 @@ \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}@@ -94,7 +106,7 @@  \begin{code} instance C.Variable ErrorName where-	defaultSignature _ = fromJust . mkSignature $ "s"+	defaultSignature _ = mkSignature' "s" 	toVariant = A.atomToVariant . A.toAtom 	fromVariant = (mkErrorName =<<) . C.fromVariant instance A.Atomic ErrorName where@@ -107,6 +119,11 @@ \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}@@ -120,7 +137,7 @@  \begin{code} instance C.Variable BusName where-	defaultSignature _ = fromJust . mkSignature $ "s"+	defaultSignature _ = mkSignature' "s" 	toVariant = A.atomToVariant . A.toAtom 	fromVariant = (mkBusName =<<) . C.fromVariant instance A.Atomic BusName where@@ -140,6 +157,11 @@ \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}@@ -153,7 +175,7 @@  \begin{code} instance C.Variable MemberName where-	defaultSignature _ = fromJust . mkSignature $ "s"+	defaultSignature _ = mkSignature' "s" 	toVariant = A.atomToVariant . A.toAtom 	fromVariant = (mkMemberName =<<) . C.fromVariant instance A.Atomic MemberName where@@ -167,6 +189,11 @@ 	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}

@@ -17,14 +17,16 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.ObjectPath-	( ObjectPath+	( -- * Object paths+	  ObjectPath 	, mkObjectPath+	, mkObjectPath' 	, strObjectPath 	) where  import Data.Typeable (Typeable) import qualified Text.Parsec as P-import DBus.Types.Util (parseMaybe)+import DBus.Util (parseMaybe, mkUnsafe) \end{code} } @@ -51,6 +53,9 @@ 	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

@@ -16,16 +16,16 @@ \ignore{ \begin{code} module DBus.Types.Serial-	( Serial (..)+	( -- * Message serials+	  Serial (..) 	, nextSerial 	, firstSerial 	) where  import Data.Word (Word32)-import Data.Maybe (fromJust) import qualified DBus.Types.Atom as A import qualified DBus.Types.Containers as C-import DBus.Types.Signature (mkSignature)+import DBus.Types.Signature (mkSignature') \end{code} } @@ -42,7 +42,7 @@ 	toAtom (Serial x) = A.toAtom x  instance C.Variable Serial where-	defaultSignature _ = fromJust . mkSignature $ "u"+	defaultSignature _ = mkSignature' "u" 	toVariant (Serial x) = C.toVariant x 	fromVariant = fmap Serial . C.fromVariant \end{code}

@@ -17,17 +17,19 @@ \begin{code} {-# LANGUAGE DeriveDataTypeable #-} module DBus.Types.Signature-	( Signature+	( -- * Signatures+	  Signature 	, Type(..) 	, signatureTypes 	, mkSignature+	, mkSignature' 	, strSignature 	, typeString 	) where  import Data.Typeable (Typeable) import Text.Parsec (char, (<|>), many, eof)-import DBus.Types.Util (checkLength, parseMaybe)+import DBus.Util (checkLength, parseMaybe, mkUnsafe) \end{code} } @@ -99,6 +101,11 @@ 		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}@@ -111,8 +118,8 @@ must go through {\tt parseSignature}.  \begin{code}-data Type =-	  BooleanT+data Type+	= BooleanT 	| ByteT 	| Int16T 	| UInt16T

@@ -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/>.--\clearpage-\section{Misc. utility functions}--\ignore{-\begin{code}-{-# OPTIONS_HADDOCK hide #-}-module DBus.Types.Util-	( checkLength-	, parseMaybe-	) where--import Text.Parsec (Parsec, parse)-\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}

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

@@ -0,0 +1,61 @@+% 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,9 +15,10 @@   along with this program.  If not, see <http://www.gnu.org/licenses/>. -} +import DBus.Address import DBus.Bus-import DBus.Bus.Address-import DBus.Bus.Connection+import DBus.Connection+import DBus.Constants import DBus.Message import DBus.Types @@ -62,10 +63,10 @@  addMatchMsg :: String -> MethodCall addMatchMsg match = MethodCall-	(fromJust . mkObjectPath $ "/org/freedesktop/DBus")-	(fromJust . mkMemberName $ "AddMatch")-	(mkInterfaceName "org.freedesktop.DBus")-	(mkBusName "org.freedesktop.DBus")+	dbusPath+	(mkMemberName' "AddMatch")+	(Just dbusInterface)+	(Just dbusName) 	Set.empty 	[toVariant match] 

@@ -23,7 +23,7 @@ import Data.Maybe (isJust, isNothing) import Test.QuickCheck import Tests.Instances (sized')-import DBus.Bus.Address+import DBus.Address  addressProperties = concat 	[ prop_Valid

@@ -136,7 +136,7 @@ 	firstType = head types 	sig = if length vs > 0 		then variantSignature (head vs)-		else fromJust . mkSignature $ "y"+		else mkSignature' "y"  -- A dictionary must have homogeneous key and value types prop_DictHomogeneous0 = homogeneousDict@@ -144,7 +144,7 @@ prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let 	dict = dictionaryFromItems kSig vSig (zip ks vs) 	(kSig, vSig) = if null ks-		then (id &&& id) . fromJust . mkSignature $ "y"+		then (id &&& id) . mkSignature' $ "y" 		else (atomSignature (head ks), variantSignature (head vs)) 	in isJust dict ==> homogeneousDict (fromJust dict) @@ -173,7 +173,7 @@ 	where check xs sig = forAll (return sig) $ checkEmptyArray xs  checkEmptyArray xs sig = arraySignature a == sig' where-	sig' = fromJust . mkSignature $ sig+	sig' = mkSignature' sig 	a = fromJust . toArray $ xs  props_EmptyDictionarySignature =@@ -187,7 +187,7 @@ 	where check xs sig = forAll (return sig) $ checkEmptyDict xs  checkEmptyDict xs sig = dictionarySignature a == sig' where-	sig' = fromJust . mkSignature $ sig+	sig' = mkSignature' sig 	a = fromJust . toDictionary $ xs  -- TODO Conversion to/from array and dictionary

@@ -19,7 +19,6 @@  import Control.Monad (replicateM) import Data.List (intercalate)-import Data.Maybe (fromJust) import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int16, Int32, Int64) import Test.QuickCheck@@ -76,16 +75,16 @@ 	n' <- choose (atLeast, max atLeast n) 	replicateM n' g -clampedSize :: Arbitrary a => Int -> Gen String -> (String -> Maybe a) -> Gen a+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 . fromJust . f $ s+		else return . f $ s  instance Arbitrary ObjectPath where 	coarbitrary = undefined-	arbitrary = fmap (fromJust . mkObjectPath) path' where+	arbitrary = fmap mkObjectPath' path' where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_" 		path = fmap (intercalate "/" . ([] :)) genElements 		path' = frequency [(1, return "/"), (9, path)]@@ -93,7 +92,7 @@  instance Arbitrary InterfaceName where 	coarbitrary = undefined-	arbitrary = clampedSize 255 genName mkInterfaceName where+	arbitrary = clampedSize 255 genName mkInterfaceName' where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 		c' = c ++ ['0'..'9'] 		@@ -107,7 +106,7 @@  instance Arbitrary BusName where 	coarbitrary = undefined-	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName where+	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName' where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-" 		c' = c ++ ['0'..'9'] 		@@ -126,7 +125,7 @@  instance Arbitrary MemberName where 	coarbitrary = undefined-	arbitrary = clampedSize 255 genName mkMemberName where+	arbitrary = clampedSize 255 genName mkMemberName' where 		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_" 		c' = c ++ ['0'..'9'] 		@@ -137,7 +136,7 @@  instance Arbitrary ErrorName where 	coarbitrary = undefined-	arbitrary = fmap (fromJust . mkErrorName . strInterfaceName) arbitrary+	arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary  instance Arbitrary Type where 	coarbitrary = undefined@@ -145,7 +144,7 @@  instance Arbitrary Signature where 	coarbitrary = undefined-	arbitrary = clampedSize 255 genSig mkSignature where+	arbitrary = clampedSize 255 genSig mkSignature' where 		genSig = fmap (concatMap typeString) arbitrary  atomicType = elements@@ -249,8 +248,8 @@ 			ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath]) 			SignatureT  -> fmap (map toVariant) (arbitrary :: Gen [Signature]) 		-		let kSig = fromJust . mkSignature . typeString $ kt-		let vSig = fromJust . mkSignature . typeString $ vt+		let kSig = mkSignature' . typeString $ kt+		let vSig = mkSignature' . typeString $ vt 		maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs))  instance Arbitrary Structure where

@@ -21,13 +21,12 @@ import System.IO.Unsafe (unsafePerformIO) import qualified Data.ByteString.Lazy as L import Data.Word-import Data.Maybe (fromJust)  import Test.QuickCheck import Tests.Instances () import DBus.Types-import DBus.Protocol.Marshal-import DBus.Protocol.Unmarshal+import DBus.Marshal+import DBus.Unmarshal  marshalProperties :: [Property] marshalProperties =

@@ -1,5 +1,5 @@ name: dbus-core-version: 0.3+version: 0.4 synopsis: Low-level DBus protocol implementation license: GPL license-file: License.txt@@ -16,7 +16,6 @@   Examples/*.hs   Tests/*.hs   Tests.hs-  DBus/Types/Containers.lhs-boot  source-repository head   type: darcs@@ -38,22 +37,27 @@     network    exposed-modules:+    DBus.Address     DBus.Bus-    DBus.Bus.Address-    DBus.Bus.Connection+    DBus.Connection+    DBus.Constants     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--  other-modules:-    DBus.Protocol.Authentication-    DBus.Protocol.Marshal-    DBus.Protocol.Unmarshal-    DBus.Protocol.Padding-    DBus.Types.Util+    DBus.Marshal+    DBus.Padding+    DBus.Unmarshal+    DBus.Util

@@ -46,13 +46,15 @@ \addcontentsline{toc}{section}{Contents} \tableofcontents +\input{DBus/Address.lhs}+\input{DBus/Connection.lhs} \input{DBus/Bus.lhs}-\input{DBus/Bus/Address.lhs}-\input{DBus/Bus/Connection.lhs}+\input{DBus/Internal/Authentication.lhs} \input{DBus/Types.lhs} \input{DBus/Message.lhs}-\input{DBus/Protocol/Marshal.lhs}-\input{DBus/Protocol/Unmarshal.lhs}-\input{DBus/Protocol/Padding.lhs}+\input{DBus/Internal/Marshal.lhs}+\input{DBus/Internal/Unmarshal.lhs}+\input{DBus/Internal/Padding.lhs}+\input{DBus/Util.lhs}  \end{document}