dbus-core 0.1 → 0.2

raw patch · 17 files changed

+2200/−5 lines, 17 files

Files

DBus/Protocol/Authentication.lhs +71/−0
DBus/Protocol/Marshal.lhs +243/−0
DBus/Protocol/Padding.lhs +60/−0
DBus/Protocol/Unmarshal.lhs +313/−0
DBus/Types/Containers.lhs-boot +51/−0
DBus/Types/Util.lhs +40/−0
Examples/dbus-monitor.hs +273/−0
Tests.hs +40/−0
Tests/Address.hs +107/−0
Tests/Containers.hs +209/−0
Tests/Instances.hs +290/−0
Tests/Marshal.hs +61/−0
Tests/Messages.hs +131/−0
Tests/MiscTypes.hs +168/−0
Tests/Signature.hs +64/−0
dbus-core.cabal +32/−5
dbus-core.tex +47/−0

+ DBus/Protocol/Authentication.lhs view

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

+ DBus/Protocol/Marshal.lhs view

@@ -0,0 +1,243 @@+% 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_ marshal' vs) e+\end{code}++\begin{code}+marshal' :: T.Variant -> Marshal+marshal' x = fromJust $ msum marshalers where+	m f = fmap f . T.fromVariant+	marshalers = map ($ x)+		[ m bool+		, m word8+		, m word16+		, m word32+		, m word64+		, m int16+		, m int32+		, m int64+		, m double+		, m string+		, m objectPath+		, m signature+		, m array+		, m dictionary+		, m structure+		, m variant+		]+\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_ marshal' 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_ marshal' xs+\end{code}++\subsubsection{Variants}++\begin{code}+variant :: T.Variant -> Marshal+variant x = signature (T.variantSignature x) >> marshal' 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}

+ DBus/Protocol/Padding.lhs view

@@ -0,0 +1,60 @@+% 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.VariantT    = 1+padByType (T.ArrayT _)  = 4+padByType (T.DictT _ _) = 4+padByType (T.StructT _) = 8+\end{code}+

+ DBus/Protocol/Unmarshal.lhs view

@@ -0,0 +1,313 @@+% 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.DictT kt vt) = fmap T.toVariant $ dictionary kt vt+unmarshal' (T.StructT 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.StructT [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}

+ DBus/Types/Containers.lhs-boot view

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

+ DBus/Types/Util.lhs view

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

+ Examples/dbus-monitor.hs view

@@ -0,0 +1,273 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++import DBus.Bus+import DBus.Bus.Address+import DBus.Bus.Connection+import DBus.Message+import DBus.Types++import Control.Monad+import qualified Data.Set as Set+import Data.List+import Data.Maybe+import Data.Int+import Data.Word+import System+import System.IO+import System.Console.GetOpt++data Bus = Session | System+	deriving (Show)++data Option = BusOption Bus | AddressOption String+	deriving (Show)++optionInfo :: [OptDescr Option]+optionInfo = [+	  Option [] ["session"] (NoArg (BusOption Session))+	         "Monitor the session message bus. (default)"+	, Option [] ["system"] (NoArg (BusOption System))+	         "Monitor the system message bus."+	, Option [] ["address"] (ReqArg AddressOption "ADDRESS")+	         "Connect to a particular bus address."+	]++usage :: String -> String+usage name = "Usage: " ++ name ++ " [OPTION...]"++findBus :: [Option] -> IO (Connection, BusName)+findBus []    = getSessionBus+findBus (o:_) = case o of+	BusOption Session -> getSessionBus+	BusOption System  -> getSystemBus+	AddressOption addr -> do+		addr' <- case parseAddresses addr of+			Just (x:_) -> return x+			_          -> error $ "Invalid address: " ++ show addr+		c <- connect . findTransport $ addr'+		name <- register c+		return (c, name)++addMatchMsg :: String -> MethodCall+addMatchMsg match = MethodCall+	(fromJust . mkObjectPath $ "/org/freedesktop/DBus")+	(fromJust . mkMemberName $ "AddMatch")+	(mkInterfaceName "org.freedesktop.DBus")+	(mkBusName "org.freedesktop.DBus")+	Set.empty+	[toVariant match]++addMatch :: Connection -> String -> IO ()+addMatch c s = send c return (addMatchMsg s) >> return ()++defaultFilters :: [String]+defaultFilters =+	[ "type='signal'"+	, "type='method_call'"+	, "type='method_return'"+	, "type='error'"+	]++onMessage :: Either String ReceivedMessage -> IO ()+onMessage (Left err) = do+	hPutStrLn stderr err+	exitFailure++onMessage (Right msg) = putStrLn (formatMessage msg ++ "\n")++main :: IO ()+main = do+	args <- getArgs+	let (options, userFilters, errors) = getOpt Permute optionInfo args+	unless (null errors) $ do+		name <- getProgName+		hPutStrLn stderr $ concat errors+		hPutStrLn stderr $ usageInfo (usage name) optionInfo+		exitFailure+	+	(bus, _) <- findBus options+	+	let filters = if null userFilters+		then defaultFilters+		else userFilters+	+	mapM_ (addMatch bus) filters+	+	forever (recv bus >>= onMessage)++-- Message formatting is verbose and mostly uninteresting, except as an+-- excersise in string manipulation.++formatMessage :: ReceivedMessage -> String++-- Method call+formatMessage (ReceivedMethodCall serial sender msg) = concat+	[ "method call"+	, " sender="+	, fromMaybe "(null)" . fmap strBusName $ sender+	, " -> dest="+	, fromMaybe "(null)" . fmap strBusName . methodCallDestination $ msg+	, " serial="+	, show serial+	, " path="+	, strObjectPath . methodCallPath $ msg+	, "; interface="+	, fromMaybe "(null)" . fmap strInterfaceName . methodCallInterface $ msg+	, "; member="+	, strMemberName . methodCallMember $ msg+	, formatBody msg+	]++-- Method return+formatMessage (ReceivedMethodReturn _ sender msg) = concat+	[ "method return"+	, " sender="+	, fromMaybe "(null)" . fmap strBusName $ sender+	, " -> dest="+	, fromMaybe "(null)" . fmap strBusName . methodReturnDestination $ msg+	, " reply_serial="+	, show . methodReturnSerial $ msg+	, formatBody msg+	]++-- Error+formatMessage (ReceivedError _ sender msg) = concat+	[ "error"+	, " sender="+	, fromMaybe "(null)" . fmap strBusName $ sender+	, " -> dest="+	, fromMaybe "(null)" . fmap strBusName . errorDestination $ msg+	, " error_name="+	, strErrorName . errorName $ msg+	, " reply_serial="+	, show . errorSerial $ msg+	, formatBody msg+	]++-- Signal+formatMessage (ReceivedSignal serial sender msg) = concat+	[ "signal"+	, " sender="+	, fromMaybe "(null)" . fmap strBusName $ sender+	, " serial="+	, show serial+	, " path="+	, strObjectPath . signalPath $ msg+	, "; interface="+	, strInterfaceName . signalInterface $ msg+	, "; member="+	, strMemberName . signalMember $ msg+	, formatBody msg+	]++formatMessage (ReceivedUnknown serial sender) = concat+	[ "unknown"+	, " sender="+	, fromMaybe "(null)" . fmap strBusName $ sender+	, " serial="+	, show serial+	]++formatBody :: Message a => a -> String+formatBody msg = formatted where+	tree = Children $ map formatVariant body+	body = messageBody msg+	formatted = intercalate "\n" ([] : collapseTree 1 tree)++-- A string tree allows easy indentation of nested structures+data StringTree = Line String | MultiLine [StringTree] | Children [StringTree]+	deriving (Show)++collapseTree :: Int -> StringTree -> [String]+collapseTree d (Line x)       = [concat (replicate d "   ") ++ x]+collapseTree d (MultiLine xs) = concatMap (collapseTree d) xs+collapseTree d (Children xs)  = concatMap (collapseTree (d + 1)) xs++-- Formatting for various kinds of variants, keyed to their signature type.+formatVariant :: Variant -> StringTree+formatVariant v = formatVariant' type' v where+	[type'] = signatureTypes . variantSignature $ v++formatVariant' :: Type -> Variant -> StringTree++formatVariant' BooleanT x = Line $ "boolean " ++ strX where+	x' = fromJust . fromVariant $ x :: Bool+	strX = if x' then "true" else "false"++formatVariant' ByteT x = Line $ "byte " ++ show x' where+	x' = fromJust . fromVariant $ x :: Word8++formatVariant' Int16T x = Line $ "int16 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Int16++formatVariant' Int32T x = Line $ "int32 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Int32++formatVariant' Int64T x = Line $ "int64 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Int64++formatVariant' UInt16T x = Line $ "uint16 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Word16++formatVariant' UInt32T x = Line $ "uint32 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Word32++formatVariant' UInt64T x = Line $ "uint64 " ++ show x' where+	x' = fromJust . fromVariant $ x :: Word64++formatVariant' DoubleT x = Line $ "double " ++ show x' where+	x' = fromJust . fromVariant $ x :: Double++formatVariant' StringT x = Line $ "string " ++ show x' where+	x' = fromJust . fromVariant $ x :: String++formatVariant' ObjectPathT x = Line $ "object path " ++ show x' where+	x' = strObjectPath . fromJust . fromVariant $ x++formatVariant' SignatureT x = Line $ "signature " ++ show x' where+	x' = strSignature . fromJust . fromVariant $ x++formatVariant' (ArrayT _) x = MultiLine lines' where+	items = arrayItems . fromJust . fromVariant $ x+	lines' =+		[ Line "array ["+		, Children . map formatVariant $ items+		, Line "]"+		]++formatVariant' (DictT _ _) x = MultiLine lines' where+	items = dictionaryItems . fromJust . fromVariant $ x+	lines' = [ Line "dictionary {"+		, Children . map formatItem $ items+		, Line "}"+		]+	formatItem (k, v) = MultiLine $ [Line $ k' ++ " -> " ++ vHead] ++ vTail where+		Line k' = formatVariant (atomToVariant k)+		v' = collapseTree 0 (formatVariant v)+		vHead = head v'+		vTail = map Line $ tail v'++formatVariant' (StructT _) x = MultiLine lines' where+	Structure items = fromJust . fromVariant $ x+	lines' =+		[ Line "struct ("+		, Children . map formatVariant $ items+		, Line ")"+		]++formatVariant' VariantT x = formatVariant . fromJust . fromVariant $ x

+ Tests.hs view

@@ -0,0 +1,40 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++import Test.QuickCheck.Batch+import Tests.Address (addressProperties)+import Tests.Signature (signatureProperties)+import Tests.Containers (containerProperties)+import Tests.Marshal (marshalProperties)+import Tests.Messages (messageProperties)+import Tests.MiscTypes (miscTypeProperties)++options = TestOptions+	{ no_of_tests     = 100+	, length_of_tests = 1+	, debug_tests     = False+	}++main = do+	runTests "simple" options . map run . concat $+		[ addressProperties+		, containerProperties+		, marshalProperties+		, messageProperties+		, miscTypeProperties+		, signatureProperties+		]

+ Tests/Address.hs view

@@ -0,0 +1,107 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++module Tests.Address (addressProperties) where++import Control.Monad (replicateM)+import Data.List (intercalate)+import Data.Map (toList)+import Data.Maybe (isJust, isNothing)+import Test.QuickCheck+import Tests.Instances (sized')+import DBus.Bus.Address++addressProperties = concat+	[ prop_Valid+	, prop_Invalid+	, [ property prop_Identity+	  , property prop_MultipleAddresses+	  , property prop_IgnoreTrailingSemicolon+	  , property prop_IgnoreTrailingComma+	  ]+	]++-- Addresses can be converted to strings and back safely+prop_Identity x = parseAddresses (strAddress x) == Just [x]++-- Multiple addresses may be parsed+prop_MultipleAddresses x y = parseAddresses joined == Just [x, y] where+	joined = concat [strAddress x, ";", strAddress y]++-- Trailing semicolons are ignored+prop_IgnoreTrailingSemicolon x = parseAddresses appended == Just [x] where+	appended = strAddress x ++ ";"++-- Trailing commas are ignored+prop_IgnoreTrailingComma x = hasParams ==> ignoresComma where+	hasParams = not . null $ params+	ignoresComma = parseAddresses (strAddress x ++ ",") == Just [x]+	params = toList . addressParameters $ x++prop_Valid = let valid = property . isJust . parseAddresses in+	[ valid ":"+	, valid "a:"+	, valid "a:b=c"+	, valid "a:;"+	, valid "a:;b:"+	]++prop_Invalid = let invalid = property . isNothing . parseAddresses in+	[ invalid ""+	, invalid "a"+	, invalid "a:b"+	, invalid "a:b="+	]++instance Arbitrary Address where+	coarbitrary = undefined+	arbitrary = genAddress where+		optional = ['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'] ++ "-_/\\*."+		methodChars = filter (flip notElem ":;") ['!'..'~']+		keyChars = filter (flip notElem "=;,") ['!'..'~']+		+		genMethod = sized' 0 $ elements methodChars+		genParam = do+			key <- genKey+			value <- genValue+			return . concat $ [key, "=", value]+		+		genKey = sized' 1 $ elements keyChars+		genValue = oneof [encodedValue, plainValue]+		genHex = elements $ ['0'..'9'] ++ ['a'..'f'] ++ ['A'..'F']+		encodedValue = do+			x1 <- genHex+			x2 <- genHex+			return ['%', x1, x2]+		plainValue = sized' 1 $ elements optional+		+		genParams = do+			params <- sized' 0 genParam+			let params' = intercalate "," params+			extraComma <- if null params+				then return ""+				else elements ["", ","]+			return $ concat [params', extraComma]+		+		genAddress = do+			m <- genMethod+			params <- genParams+			extraSemicolon <- elements ["", ";"]+			let addrStr = concat [m, ":", params, extraSemicolon]+			let Just [addr] = parseAddresses addrStr+			return addr+

+ Tests/Containers.hs view

@@ -0,0 +1,209 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE RankNTypes #-}+module Tests.Containers (containerProperties) where++import Control.Arrow ((&&&))+import Data.Maybe (isJust, fromJust)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)+import Test.QuickCheck++import Tests.Instances ()++import DBus.Types++containerProperties = concat+	[ forAllAtomic prop_AtomEquality+	, forAllVariable prop_VariantEquality+	+	, forAllAtomic prop_AtomWrapping0+	, forAllAtomic prop_AtomWrapping1+	, forAllVariable prop_VariantWrapping+	+	, forAllAtomic prop_AtomSignature+	, forAllAtomic prop_AtomDefaultSignature+	, forAllVariable prop_DefaultSignature+	, variantSignatureProperties+	, [ property prop_VariantSignatureLength ]+	, [ property prop_ArrayHomogeneous+	  , property prop_DictHomogeneous0+	  , property prop_DictHomogeneous1+	  ]+	, props_EmptyArraySignature+	, props_EmptyDictionarySignature+	]++-- Basic equality++prop_AtomEquality gen = forAll gen $ \x y ->+	(x == y) == (toAtom x == toAtom y)++prop_VariantEquality gen = forAll gen $ \x y ->+	(x == y) == (toVariant x == toVariant y)++-- Conversion to/from/between Atom and Variant++prop_AtomWrapping0 gen = forAll gen $ \x ->+	fromAtom (toAtom x) == Just x++prop_AtomWrapping1 gen = forAll gen $ \x ->+	atomToVariant (toAtom x) == toVariant x++prop_VariantWrapping gen = forAll gen $ \x ->+	fromVariant (toVariant x) == Just x++prop_AtomSignature gen = forAll gen $ \x ->+	atomSignature (toAtom x) == variantSignature (toVariant x)++prop_AtomDefaultSignature gen = forAll gen $ \x ->+	variantSignature (toVariant x) == defaultSignature x++prop_DefaultSignature gen = forAll gen $ \x -> let+	sig = strSignature . defaultSignature $ y+	y = head [y, x]+	in not . null $ sig+++-- Test that signatures are set properly+sameSig :: Variable a => a -> Type -> Bool+sameSig x t = [t] == t' where+	t' = signatureTypes . variantSignature . toVariant $ x++sameSig' :: Variable a => (a -> Signature) -> a -> Bool+sameSig' f x = f x == (variantSignature . toVariant) x++variantSignatureProperties =+	[ property $ \x -> sameSig (x :: Bool) BooleanT+	, property $ \x -> sameSig (x :: Word8) ByteT+	, property $ \x -> sameSig (x :: Word16) UInt16T+	, property $ \x -> sameSig (x :: Word32) UInt32T+	, property $ \x -> sameSig (x :: Word64) UInt64T+	, property $ \x -> sameSig (x :: Int16) Int16T+	, property $ \x -> sameSig (x :: Int32) Int32T+	, property $ \x -> sameSig (x :: Int64) Int64T+	, property $ \x -> sameSig (x :: Double) DoubleT+	, property $ \x -> sameSig (x :: String) StringT+	, property $ \x -> sameSig (x :: ObjectPath) ObjectPathT+	, property $ \x -> sameSig (x :: Signature) SignatureT+	, property $ sameSig' arraySignature+	, property $ sameSig' dictionarySignature+	, property $ sameSig' structureSignature+	, property $ \x -> sameSig (x :: Variant) VariantT+	]++-- All variant signatures have one entry+prop_VariantSignatureLength x = length sig == 1 where+	sig = signatureTypes . variantSignature $ x++-- All items in an array have the same signature. If items do not have+-- the same signature, the array can't be constructed+prop_ArrayHomogeneous vs = isJust array == homogeneousTypes where+	array = arrayFromItems sig vs+	homogeneousTypes = if length vs > 0+		then all (== firstType) types+		else True+	types = map (signatureTypes . variantSignature) vs+	firstType = head types+	sig = if length vs > 0+		then variantSignature (head vs)+		else fromJust . mkSignature $ "y"++-- A dictionary must have homogeneous key and value types+prop_DictHomogeneous0 = homogeneousDict++prop_DictHomogeneous1 ks = forAll (vector (length ks)) $ \vs -> let+	dict = dictionaryFromItems kSig vSig (zip ks vs)+	(kSig, vSig) = if null ks+		then (id &&& id) . fromJust . mkSignature $ "y"+		else (atomSignature (head ks), variantSignature (head vs))+	in isJust dict ==> homogeneousDict (fromJust dict)++homogeneousDict :: Dictionary -> Property+homogeneousDict x = length items > 0 ==> homogeneous where+	items = dictionaryItems x+	keys = [k | (k,_) <- items]+	values = [v | (_,v) <- items]+	+	kTypes = map (signatureTypes . atomSignature) keys+	kFirst = head kTypes+	+	vTypes = map (signatureTypes . variantSignature) values+	vFirst = head vTypes+	+	homogeneous = all (== kFirst) kTypes && all (== vFirst) vTypes++props_EmptyArraySignature =+	[ check ([] :: [Word8]) "ay"+	, check ([] :: [Bool]) "ab"+	, check ([] :: [Array]) "aay"+	, check ([] :: [Dictionary]) "aa{yy}"+	, check ([] :: [Structure]) "a()"+	, check ([] :: [Variant]) "av"+	]+	where check xs sig = forAll (return sig) $ checkEmptyArray xs++checkEmptyArray xs sig = arraySignature a == sig' where+	sig' = fromJust . mkSignature $ sig+	a = fromJust . toArray $ xs++props_EmptyDictionarySignature =+	[ check ([] :: [(Word8, Word8)]) "a{yy}"+	, check ([] :: [(Bool, Word8)]) "a{by}"+	, check ([] :: [(Bool, Array)]) "a{bay}"+	, check ([] :: [(Bool, Dictionary)]) "a{ba{yy}}"+	, check ([] :: [(Bool, Structure)]) "a{b()}"+	, check ([] :: [(Bool, Variant)]) "a{bv}"+	]+	where check xs sig = forAll (return sig) $ checkEmptyDict xs++checkEmptyDict xs sig = dictionarySignature a == sig' where+	sig' = fromJust . mkSignature $ sig+	a = fromJust . toDictionary $ xs++-- TODO Conversion to/from array and dictionary++-- TODO: container signatures++-- Helper functions++forAllAtomic :: (forall a. (Show a, Arbitrary a, Atomic a, Eq a) =>+                (Gen a -> Property)) -> [Property]+forAllAtomic t =+	[ t (arbitrary :: Gen Bool)+	, t (arbitrary :: Gen Word8)+	, t (arbitrary :: Gen Word16)+	, t (arbitrary :: Gen Word32)+	, t (arbitrary :: Gen Word64)+	, t (arbitrary :: Gen Int16)+	, t (arbitrary :: Gen Int32)+	, t (arbitrary :: Gen Int64)+	, t (arbitrary :: Gen Double)+	, t (arbitrary :: Gen String)+	, t (arbitrary :: Gen ObjectPath)+	, t (arbitrary :: Gen Signature)+	]++forAllVariable :: (forall a. (Show a, Arbitrary a, Variable a, Eq a) =>+                  (Gen a -> Property)) -> [Property]+forAllVariable t = forAllAtomic t +++	[ t (arbitrary :: Gen Array)+	, t (arbitrary :: Gen Dictionary)+	, t (arbitrary :: Gen Structure)+	, t (arbitrary :: Gen Variant)+	]

+ Tests/Instances.hs view

@@ -0,0 +1,290 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++module Tests.Instances (sized') where++import Control.Monad (replicateM)+import Data.List (intercalate)+import Data.Maybe (fromJust)+import Data.Word (Word8, Word16, Word32, Word64)+import Data.Int (Int16, Int32, Int64)+import Test.QuickCheck+import DBus.Types++instance Arbitrary Char where+	coarbitrary = undefined+	arbitrary = choose ('!', '~') -- TODO: unicode?++instance Arbitrary Word8 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 8 - 1++instance Arbitrary Word16 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 16 - 1++instance Arbitrary Word32 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 32 - 1++instance Arbitrary Word64 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 64 - 1++instance Arbitrary Int16 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 16 - 1++instance Arbitrary Int32 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 32 - 1++instance Arbitrary Int64 where+	coarbitrary = undefined+	arbitrary = gen where+		gen = fmap fromIntegral (choose (0, max') :: Gen Integer)+		max' = iexp 2 64 - 1++sized' :: Int -> Gen a -> Gen [a]+sized' atLeast g = sized $ \n -> do+	n' <- choose (atLeast, max atLeast n)+	replicateM n' g++clampedSize :: Arbitrary a => Int -> Gen String -> (String -> Maybe 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++instance Arbitrary ObjectPath where+	coarbitrary = undefined+	arbitrary = fmap (fromJust . mkObjectPath) path' where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"+		path = fmap (intercalate "/" . ([] :)) genElements+		path' = frequency [(1, return "/"), (9, path)]+		genElements = sized' 1 (sized' 1 (elements c))++instance Arbitrary InterfaceName where+	coarbitrary = undefined+	arbitrary = clampedSize 255 genName mkInterfaceName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = fmap (intercalate ".") genElements+		genElements = sized' 2 genElement+		genElement = do+			x <- elements c+			xs <- sized' 0 (elements c')+			return (x:xs)+		++instance Arbitrary BusName where+	coarbitrary = undefined+	arbitrary = clampedSize 255 (oneof [unique, wellKnown]) mkBusName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_-"+		c' = c ++ ['0'..'9']+		+		unique = do+			elems' <- sized' 2 $ elems c'+			return $ ':' : intercalate "." elems'+		+		wellKnown = do+			elems' <- sized' 2 $ elems c+			return $ intercalate "." elems'+		+		elems start = do+			x <- elements start+			xs <- sized' 0 (elements c')+			return (x:xs)++instance Arbitrary MemberName where+	coarbitrary = undefined+	arbitrary = clampedSize 255 genName mkMemberName where+		c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"+		c' = c ++ ['0'..'9']+		+		genName = do+			x <- elements c+			xs <- sized' 0 (elements c')+			return (x:xs)++instance Arbitrary ErrorName where+	coarbitrary = undefined+	arbitrary = fmap (fromJust . mkErrorName . strInterfaceName) arbitrary++instance Arbitrary Type where+	coarbitrary = undefined+	arbitrary = oneof [atomicType, containerType]++instance Arbitrary Signature where+	coarbitrary = undefined+	arbitrary = clampedSize 255 genSig mkSignature where+		genSig = fmap (concatMap typeString) arbitrary++atomicType = elements+	[ BooleanT+	, ByteT+	, UInt16T+	, UInt32T+	, UInt64T+	, Int16T+	, Int32T+	, Int64T+	, DoubleT+	, StringT+	, ObjectPathT+	, SignatureT+	]++containerType = do+	c <- choose (0,3) :: Gen Int+	case c of+		0 -> fmap ArrayT arbitrary+		1 -> do+			kt <- atomicType+			vt <- arbitrary+			return $ DictT kt vt+		2 -> sized structType+		3 -> return VariantT++structType n | n >= 0 = fmap StructT $ resize (n `div` 2) arbitrary++instance Arbitrary Atom where+	coarbitrary = undefined+	arbitrary = atomicType >>= \t -> case t of+		BooleanT    -> fmap toAtom (arbitrary :: Gen Bool)+		ByteT       -> fmap toAtom (arbitrary :: Gen Word8)+		UInt16T     -> fmap toAtom (arbitrary :: Gen Word16)+		UInt32T     -> fmap toAtom (arbitrary :: Gen Word32)+		UInt64T     -> fmap toAtom (arbitrary :: Gen Word64)+		Int16T      -> fmap toAtom (arbitrary :: Gen Int16)+		Int32T      -> fmap toAtom (arbitrary :: Gen Int32)+		Int64T      -> fmap toAtom (arbitrary :: Gen Int64)+		DoubleT     -> fmap toAtom (arbitrary :: Gen Double)+		StringT     -> fmap toAtom (arbitrary :: Gen String)+		ObjectPathT -> fmap toAtom (arbitrary :: Gen ObjectPath)+		SignatureT  -> fmap toAtom (arbitrary :: Gen Signature)++instance Arbitrary Array where+	coarbitrary = undefined+	arbitrary = do+		-- Only generate arrays of atomic values, as generating+		-- containers randomly almost never results in a valid+		-- array.+		x <- atomicType >>= \t -> case t of+			BooleanT    -> fmap toArray (arbitrary :: Gen [Bool])+			ByteT       -> fmap toArray (arbitrary :: Gen [Word8])+			UInt16T     -> fmap toArray (arbitrary :: Gen [Word16])+			UInt32T     -> fmap toArray (arbitrary :: Gen [Word32])+			UInt64T     -> fmap toArray (arbitrary :: Gen [Word64])+			Int16T      -> fmap toArray (arbitrary :: Gen [Int16])+			Int32T      -> fmap toArray (arbitrary :: Gen [Int32])+			Int64T      -> fmap toArray (arbitrary :: Gen [Int64])+			DoubleT     -> fmap toArray (arbitrary :: Gen [Double])+			StringT     -> fmap toArray (arbitrary :: Gen [String])+			ObjectPathT -> fmap toArray (arbitrary :: Gen [ObjectPath])+			SignatureT  -> fmap toArray (arbitrary :: Gen [Signature])+		+		maybe arbitrary return x++instance Arbitrary Dictionary where+	coarbitrary = undefined+	arbitrary = do+		-- Only generate dictionaries of atomic values, as generating+		-- containers randomly almost never results in a valid+		-- array.+		kt <- atomicType+		vt <- atomicType+		ks <- case kt of+			BooleanT    -> fmap (map toAtom) (arbitrary :: Gen [Bool])+			ByteT       -> fmap (map toAtom) (arbitrary :: Gen [Word8])+			UInt16T     -> fmap (map toAtom) (arbitrary :: Gen [Word16])+			UInt32T     -> fmap (map toAtom) (arbitrary :: Gen [Word32])+			UInt64T     -> fmap (map toAtom) (arbitrary :: Gen [Word64])+			Int16T      -> fmap (map toAtom) (arbitrary :: Gen [Int16])+			Int32T      -> fmap (map toAtom) (arbitrary :: Gen [Int32])+			Int64T      -> fmap (map toAtom) (arbitrary :: Gen [Int64])+			DoubleT     -> fmap (map toAtom) (arbitrary :: Gen [Double])+			StringT     -> fmap (map toAtom) (arbitrary :: Gen [String])+			ObjectPathT -> fmap (map toAtom) (arbitrary :: Gen [ObjectPath])+			SignatureT  -> fmap (map toAtom) (arbitrary :: Gen [Signature])+		vs <- case vt of+			BooleanT    -> fmap (map toVariant) (arbitrary :: Gen [Bool])+			ByteT       -> fmap (map toVariant) (arbitrary :: Gen [Word8])+			UInt16T     -> fmap (map toVariant) (arbitrary :: Gen [Word16])+			UInt32T     -> fmap (map toVariant) (arbitrary :: Gen [Word32])+			UInt64T     -> fmap (map toVariant) (arbitrary :: Gen [Word64])+			Int16T      -> fmap (map toVariant) (arbitrary :: Gen [Int16])+			Int32T      -> fmap (map toVariant) (arbitrary :: Gen [Int32])+			Int64T      -> fmap (map toVariant) (arbitrary :: Gen [Int64])+			DoubleT     -> fmap (map toVariant) (arbitrary :: Gen [Double])+			StringT     -> fmap (map toVariant) (arbitrary :: Gen [String])+			ObjectPathT -> fmap (map toVariant) (arbitrary :: Gen [ObjectPath])+			SignatureT  -> fmap (map toVariant) (arbitrary :: Gen [Signature])+		+		let kSig = fromJust . mkSignature . typeString $ kt+		let vSig = fromJust . mkSignature . typeString $ vt+		maybe arbitrary return (dictionaryFromItems kSig vSig (zip ks vs))++instance Arbitrary Structure where+	coarbitrary = undefined+	arbitrary = sized $ \n ->+		fmap Structure $ resize (n `div` 2) arbitrary++instance Arbitrary Variant where+	coarbitrary = undefined+	arbitrary = arbitrary >>= \t -> case t of+		BooleanT    -> fmap toVariant (arbitrary :: Gen Bool)+		ByteT       -> fmap toVariant (arbitrary :: Gen Word8)+		UInt16T     -> fmap toVariant (arbitrary :: Gen Word16)+		UInt32T     -> fmap toVariant (arbitrary :: Gen Word32)+		UInt64T     -> fmap toVariant (arbitrary :: Gen Word64)+		Int16T      -> fmap toVariant (arbitrary :: Gen Int16)+		Int32T      -> fmap toVariant (arbitrary :: Gen Int32)+		Int64T      -> fmap toVariant (arbitrary :: Gen Int64)+		DoubleT     -> fmap toVariant (arbitrary :: Gen Double)+		StringT     -> fmap toVariant (arbitrary :: Gen String)+		ObjectPathT -> fmap toVariant (arbitrary :: Gen ObjectPath)+		SignatureT  -> fmap toVariant (arbitrary :: Gen Signature)+		ArrayT _    -> fmap toVariant (arbitrary :: Gen Array)+		DictT _ _   -> fmap toVariant (arbitrary :: Gen Dictionary)+		StructT _   -> fmap toVariant (arbitrary :: Gen Structure)+		VariantT    -> fmap toVariant (arbitrary :: Gen Variant)++instance Arbitrary Endianness where+	coarbitrary = undefined+	arbitrary = elements [LittleEndian, BigEndian]++instance Arbitrary Serial where+	coarbitrary = undefined+	arbitrary = fmap Serial arbitrary++iexp :: Integral a => a -> a -> a+iexp x y = floor $ fromIntegral x ** fromIntegral y

+ Tests/Marshal.hs view

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

+ Tests/Messages.hs view

@@ -0,0 +1,131 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++{-# LANGUAGE RankNTypes #-}+module Tests.Messages (messageProperties) where++import Data.Set (fromList)+import Test.QuickCheck+import Tests.Instances ()+import qualified Data.ByteString.Lazy as L+import DBus.Message+import DBus.Types++import qualified Data.Binary.Get as G++messageProperties = concat+	[ headerFieldProperties+	, forAllMessages prop_Marshal+	, [ property prop_Unmarshal0+	  , property prop_Unmarshal1+	  , property prop_Unmarshal2+	  , property prop_Unmarshal3+	  ]+	]++headerFieldProperties =+	[ property prop_HeaderFieldVariable+	]++prop_HeaderFieldVariable x = fromVariant (toVariant x) == Just x+	where types = [x :: HeaderField]++prop_Marshal gen = forAll arbitrary (\e s -> forAll gen (not . L.null . marshal e s))++prop_Unmarshal0 e s msg = checkUnmarshal expected e s msg where+	expected = ReceivedMethodCall s Nothing msg++prop_Unmarshal1 e s msg = checkUnmarshal expected e s msg where+	expected = ReceivedMethodReturn s Nothing msg++prop_Unmarshal2 e s msg = checkUnmarshal expected e s msg where+	expected = ReceivedError s Nothing msg++prop_Unmarshal3 e s msg = checkUnmarshal expected e s msg where+	expected = ReceivedSignal s Nothing msg++checkUnmarshal expected e s msg = unmarshaled == Right expected where+	bytes = marshal e s msg+	getBytes = G.getLazyByteString . fromIntegral+	unmarshaled = G.runGet (unmarshal getBytes) bytes++forAllMessages :: (forall a. (Show a, Arbitrary a, Message a, Eq a) =>+                  (Gen a -> Property)) -> [Property]+forAllMessages t =+	[ t (arbitrary :: Gen MethodCall)+	, t (arbitrary :: Gen MethodReturn)+	, t (arbitrary :: Gen Error)+	, t (arbitrary :: Gen Signal)+	]++instance Arbitrary Flag where+	coarbitrary = undefined+	arbitrary = elements [NoReplyExpected, NoAutoStart]++instance Arbitrary HeaderField where+	coarbitrary = undefined+	arbitrary = do+		x <- choose (1, 8)+		case (x :: Int) of+			1 -> fmap Path arbitrary+			2 -> fmap Interface arbitrary+			3 -> fmap Member arbitrary+			4 -> fmap ErrorName arbitrary+			5 -> fmap ReplySerial arbitrary+			6 -> fmap Destination arbitrary+			7 -> fmap Sender arbitrary+			8 -> fmap Signature arbitrary++instance Arbitrary MethodCall where+	coarbitrary = undefined+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		dest   <- arbitrary+		flags  <- fmap fromList arbitrary+		body   <- sized (\n -> resize (n `div` 2) arbitrary)+		return $ MethodCall path member iface dest flags body++instance Arbitrary MethodReturn where+	coarbitrary = undefined+	arbitrary = do+		serial <- arbitrary+		dest   <- arbitrary+		flags  <- fmap fromList arbitrary+		body   <- sized (\n -> resize (n `div` 2) arbitrary)+		return $ MethodReturn serial dest flags body++instance Arbitrary Error where+	coarbitrary = undefined+	arbitrary = do+		name   <- arbitrary+		serial <- arbitrary+		dest   <- arbitrary+		flags  <- fmap fromList arbitrary+		body   <- sized (\n -> resize (n `div` 2) arbitrary)+		return $ Error name serial dest flags body++instance Arbitrary Signal where+	coarbitrary = undefined+	arbitrary = do+		path   <- arbitrary+		member <- arbitrary+		iface  <- arbitrary+		flags  <- fmap fromList arbitrary+		body   <- sized (\n -> resize (n `div` 2) arbitrary)+		return $ Signal path member iface flags body

+ Tests/MiscTypes.hs view

@@ -0,0 +1,168 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++module Tests.MiscTypes (miscTypeProperties) where++import Data.Maybe (isNothing)+import Data.Word (Word8)+import Test.QuickCheck+import Tests.Instances ()+import DBus.Types++miscTypeProperties = concat+	[ objectPathProperties+	, interfaceNameProperties+	, busNameProperties+	, memberNameProperties+	, errorNameProperties+	, endiannessProperties+	, serialProperties+	]++prop_Equality x = x == x++prop_IsVariable x = fromVariant (toVariant x) == Just x++prop_IsAtomic x = fromAtom (toAtom x) == Just x++-- Object paths++objectPathProperties =+	[ property (prop_Equality :: ObjectPath -> Bool)+	, property (prop_IsVariable :: ObjectPath -> Bool)+	, property (prop_IsAtomic :: ObjectPath -> Bool)+	, property prop_ObjectPathIdentity+	] ++ map property prop_ObjectPathInvalid++prop_ObjectPathIdentity x = mkObjectPath (strObjectPath x) == Just x++prop_ObjectPathInvalid = let invalid = isNothing . mkObjectPath in +	[ invalid ""+	, invalid "a"+	, invalid "/a/"+	, invalid "/a/-"+	]++-- Endianness++endiannessProperties =+	[ property (prop_Equality :: Endianness -> Bool)+	, property prop_EndianToVariant+	, property prop_EndianFromVariant+	]++prop_EndianToVariant x@(LittleEndian) = toVariant x == toVariant (0x6C :: Word8)+prop_EndianToVariant x@(BigEndian) = toVariant x == toVariant (0x42 :: Word8)++endianWords :: Gen Word8+endianWords = oneof [ return 0x6C , return 0x42 , arbitrary]++prop_EndianFromVariant = forAll endianWords $ \x -> let+	v = fromVariant (toVariant x) in case x of+		0x6C -> v == Just LittleEndian+		0x42 -> v == Just BigEndian+		_    -> isNothing v++-- Interface names++interfaceNameProperties =+	[ property (prop_Equality :: InterfaceName -> Bool)+	, property (prop_IsVariable :: InterfaceName -> Bool)+	, property (prop_IsAtomic :: InterfaceName -> Bool)+	, property prop_InterfaceNameIdentity+	] ++ map property prop_InterfaceNameInvalid++prop_InterfaceNameIdentity x = mkInterfaceName (strInterfaceName x) == Just x++prop_InterfaceNameInvalid = let invalid = isNothing . mkInterfaceName in +	[ invalid ""+	, invalid "0"+	, invalid "a"+	, invalid "a."+	, invalid "a.1"+	, invalid $ "a." ++ replicate 255 'b'+	]++-- Bus names++busNameProperties =+	[ property (prop_Equality :: BusName -> Bool)+	, property (prop_IsVariable :: BusName -> Bool)+	, property (prop_IsAtomic :: BusName -> Bool)+	, property prop_BusNameIdentity+	] ++ map property prop_BusNameInvalid++prop_BusNameIdentity x = mkBusName (strBusName x) == Just x++prop_BusNameInvalid = let invalid = isNothing . mkBusName in +	[ invalid ""+	, invalid ":"+	, invalid ":0"+	, invalid ":a"+	, invalid "0"+	, invalid "a"+	, invalid "a."+	, invalid "a.1"+	, invalid $ "a." ++ replicate 255 'b'+	]++-- Member names++memberNameProperties =+	[ property (prop_Equality :: MemberName -> Bool)+	, property (prop_IsVariable :: MemberName -> Bool)+	, property (prop_IsAtomic :: MemberName -> Bool)+	, property prop_MemberNameIdentity+	] ++ map property prop_MemberNameInvalid++prop_MemberNameIdentity x = mkMemberName (strMemberName x) == Just x++prop_MemberNameInvalid = let invalid = isNothing . mkMemberName in +	[ invalid ""+	, invalid "0"+	, invalid $ replicate 256 'a'+	]++-- Error names++errorNameProperties =+	[ property (prop_Equality :: ErrorName -> Bool)+	, property (prop_IsVariable :: ErrorName -> Bool)+	, property (prop_IsAtomic :: ErrorName -> Bool)+	, property prop_ErrorNameIdentity+	] ++ map property prop_ErrorNameInvalid++prop_ErrorNameIdentity x = mkErrorName (strErrorName x) == Just x++prop_ErrorNameInvalid = let invalid = isNothing . mkErrorName in +	[ invalid ""+	, invalid "0"+	, invalid "a"+	, invalid "a."+	, invalid "a.1"+	, invalid $ "a." ++ replicate 255 'b'+	]++-- Serials++serialProperties = +	[ property (prop_IsVariable :: Serial -> Bool)+	, property (prop_IsAtomic :: Serial -> Bool)+	, property prop_SerialIncremented+	]++prop_SerialIncremented x = nextSerial x > x

+ Tests/Signature.hs view

@@ -0,0 +1,64 @@+{-+  Copyright (C) 2009 John Millikin <jmillikin@gmail.com>+  +  This program is free software: you can redistribute it and/or modify+  it under the terms of the GNU General Public License as published by+  the Free Software Foundation, either version 3 of the License, or+  any later version.+  +  This program is distributed in the hope that it will be useful,+  but WITHOUT ANY WARRANTY; without even the implied warranty of+  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+  GNU General Public License for more details.+  +  You should have received a copy of the GNU General Public License+  along with this program.  If not, see <http://www.gnu.org/licenses/>.+-}++module Tests.Signature (signatureProperties) where++import Data.Maybe (isJust, isNothing)+import Test.QuickCheck+import Tests.Instances ()+import DBus.Types++signatureProperties =+	[ property (prop_Equality :: Signature -> Bool)+	, property (prop_Equality :: Type -> Bool)+	, property prop_TypeToSig+	, property prop_Ident+	, property prop_Length0+	, property prop_Length254+	, property prop_Length255+	, property prop_Length256+	, property prop_Invalid0+	, property prop_Invalid1+	, property prop_Invalid2+	, property prop_show0+	, property prop_show1+	]++-- Signatures and type equality+prop_Equality x = x == x++-- Types can be converted to signatures via mkSignature+prop_TypeToSig x = typeString x == strSignature sig where+	Just sig = mkSignature (typeString x)++-- Signatures can be safely converted to strings and back+prop_Ident x = mkSignature (strSignature x) == Just x++-- Signatures may be no more than 255 characters long+prop_Length0   = isJust    . mkSignature $ ""+prop_Length254 = isJust    . mkSignature . replicate 254 $ 'y'+prop_Length255 = isJust    . mkSignature . replicate 255 $ 'y'+prop_Length256 = isNothing . mkSignature . replicate 256 $ 'y'++-- Invalid signatures are not parsed+prop_Invalid0 = isNothing . mkSignature $ "a"+prop_Invalid1 = isNothing . mkSignature $ "0"+prop_Invalid2 = isNothing . mkSignature $ "a{vy}"++-- Show is useful+prop_show0 x = showsPrec 10 x "" == "Signature \"" ++ strSignature x ++ "\""+prop_show1 x = showsPrec 11 x "" == "(Signature \"" ++ strSignature x ++ "\")"

dbus-core.cabal view

@@ -1,6 +1,6 @@ name: dbus-core-version: 0.1-synopsis: DBus protocol+version: 0.2+synopsis: Low-level DBus protocol implementation license: GPL license-file: License.txt author: John Millikin@@ -11,10 +11,30 @@ stability: experimental bug-reports: mailto:jmillikin@gmail.com +extra-source-files:+  dbus-core.tex+  Examples/*.hs+  Tests/*.hs+  Tests.hs+  DBus/Types/Containers.lhs-boot++source-repository head+  type: darcs+  location: http://patch-tag.com/r/dbus-core/pullrepo+ library-  build-depends: base >=4 && < 5, parsec >= 3, bytestring,-                 data-binary-ieee754, binary, utf8-string, mtl,-                 containers, unix, network+  build-depends:+    base >=4 && < 5,+    parsec >= 3,+    binary,+    bytestring,+    data-binary-ieee754,+    utf8-string,+    mtl,+    containers,+    unix,+    network+   exposed-modules:     DBus.Bus     DBus.Bus.Address@@ -28,3 +48,10 @@     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-core.tex view

@@ -0,0 +1,47 @@+\documentclass[12pt]{article}++\usepackage{color}+\usepackage{hyperref}+\usepackage{textcomp}+\usepackage{booktabs}+\usepackage{multirow}++% Smaller margins+\usepackage[left=1.5cm,top=2cm,right=1.5cm,nohead,nofoot]{geometry}++% Remove boxes from hyperlinks+\hypersetup{+    colorlinks,+    linkcolor=blue,+}++\usepackage{listings}+\lstnewenvironment{code}{+	\lstset+		{language=Haskell+		,basicstyle=\footnotesize\tt+		,showstringspaces=false+		,frame=single+		,upquote=true+		}}+		{}++\long\def\ignore#1{}++\makeindex++\begin{document}++\addcontentsline{toc}{section}{Contents}+\tableofcontents++\input{DBus/Bus/Address.lhs}+\input{DBus/Bus/Connection.lhs}+\input{DBus/Bus.lhs}+\input{DBus/Types.lhs}+\input{DBus/Message.lhs}+\input{DBus/Protocol/Marshal.lhs}+\input{DBus/Protocol/Unmarshal.lhs}+\input{DBus/Protocol/Padding.lhs}++\end{document}