dbus-core 0.8 → 0.8.1

raw patch · 15 files changed

+1233/−934 lines, 15 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Makefile +3/−0
• Tests.nw +2/−0
• dbus-core.cabal +4/−1
• dbus-core.nw +360/−232
• hs/DBus/Bus.hs +1/−1
• hs/DBus/Connection.hs +10/−1
• hs/DBus/MatchRule.hs +3/−3
• hs/DBus/Message/Internal.hs +1/−1
• hs/DBus/Types.hs +136/−78
• hs/DBus/Wire.hs +2/−0
• hs/DBus/Wire/Internal.hs +1/−610
• hs/DBus/Wire/Marshal.hs +276/−0
• hs/DBus/Wire/Unicode.hs +39/−0
• hs/DBus/Wire/Unmarshal.hs +386/−0
• hs/Tests.hs +9/−7

@@ -14,6 +14,9 @@ 	hs/DBus/UUID.hs \ 	hs/DBus/Wire.hs \ 	hs/DBus/Wire/Internal.hs \+	hs/DBus/Wire/Marshal.hs \+	hs/DBus/Wire/Unmarshal.hs \+	hs/DBus/Wire/Unicode.hs \ 	hs/Tests.hs  all: $(HS_SOURCES)

@@ -40,6 +40,8 @@ import DBus.Message.Internal import DBus.Types import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal import qualified DBus.Introspection as I  @ \section{Tests}

@@ -1,5 +1,5 @@ name: dbus-core-version: 0.8+version: 0.8.1 synopsis: Low-level D-Bus protocol implementation license: GPL-3 license-file: License.txt@@ -64,6 +64,9 @@   other-modules:     DBus.Message.Internal     DBus.Wire.Internal+    DBus.Wire.Marshal+    DBus.Wire.Unmarshal+    DBus.Wire.Unicode     DBus.Util  executable dbus-core-tests

@@ -156,29 +156,12 @@   Type (..) , typeCode -@ Certain Haskell types are considered ``built-in'' D-Bus types; that is,-they are directly represented in the D-Bus protocol.--<<DBus/Types.hs>>=-class (Show a, Eq a) => Builtin a where-	builtinDBusType :: a -> Type- @ \subsection{Variants}  A wrapper type is needed for safely storing generic D-Bus values in Haskell. The D-Bus ``variant'' type is perfect for this, because variants may store any D-Bus value. -To cleanly store any D-Bus type, without exposing the internal storage-mechanism, requires existential quantification and some run-time casting.--<<type extensions>>=-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}--<<type imports>>=-import Data.Typeable (Typeable, cast)- @ Any type which is an instance of {\tt Variable} is considered a valid D-Bus value, because it can be used to construct {\tt Variant}s. However, outside of this module, {\tt Variant}s can only be constructed from@@ -186,8 +169,24 @@  <<DBus/Types.hs>>= <<apidoc Variant>>-data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a-	deriving (Typeable)+data Variant+	= VarBoxBool Bool+	| VarBoxWord8 Word8+	| VarBoxInt16 Int16+	| VarBoxInt32 Int32+	| VarBoxInt64 Int64+	| VarBoxWord16 Word16+	| VarBoxWord32 Word32+	| VarBoxWord64 Word64+	| VarBoxDouble Double+	| VarBoxString Text+	| VarBoxSignature Signature+	| VarBoxObjectPath ObjectPath+	| VarBoxVariant Variant+	| VarBoxArray Array+	| VarBoxDictionary Dictionary+	| VarBoxStructure Structure+	deriving (Eq)  class Variable a where 	toVariant :: a -> Variant@@ -204,17 +203,30 @@  <<DBus/Types.hs>>= instance Show Variant where-	showsPrec d (Variant x) = showParen (d > 10) $-		s "Variant " . shows code . s " " . showsPrec 11 x-		where code = typeCode . builtinDBusType $ x-		      s    = showString--@ In the test suite, it's useful to test that two variants have the same-value.+	showsPrec d var = showParen (d > 10) full where+		full = s "Variant " . shows code . s " " . valueStr+		code = typeCode $ variantType var+		s = showString+		valueStr = showsPrecVar 11 var -<<DBus/Types.hs>>=-instance Eq Variant where-	(Variant x) == (Variant y) = cast x == Just y+showsPrecVar :: Int -> Variant -> ShowS+showsPrecVar d var = case var of+	(VarBoxBool x) -> showsPrec d x+	(VarBoxWord8 x) -> showsPrec d x+	(VarBoxInt16 x) -> showsPrec d x+	(VarBoxInt32 x) -> showsPrec d x+	(VarBoxInt64 x) -> showsPrec d x+	(VarBoxWord16 x) -> showsPrec d x+	(VarBoxWord32 x) -> showsPrec d x+	(VarBoxWord64 x) -> showsPrec d x+	(VarBoxDouble x) -> showsPrec d x+	(VarBoxString x) -> showsPrec d x+	(VarBoxSignature x) -> showsPrec d x+	(VarBoxObjectPath x) -> showsPrec d x+	(VarBoxVariant x) -> showsPrec d x+	(VarBoxArray x) -> showsPrec d x+	(VarBoxDictionary x) -> showsPrec d x+	(VarBoxStructure x) -> showsPrec d x  @ Since many operations on D-Bus values depend on having the correct type, {\tt variantType} is used to retrieve which type is actually stored within@@ -223,31 +235,47 @@ <<DBus/Types.hs>>= <<apidoc variantType>> variantType :: Variant -> Type-variantType (Variant x) = builtinDBusType x+variantType var = case var of+	(VarBoxBool _) -> DBusBoolean+	(VarBoxWord8 _) -> DBusByte+	(VarBoxInt16 _) -> DBusInt16+	(VarBoxInt32 _) -> DBusInt32+	(VarBoxInt64 _) -> DBusInt64+	(VarBoxWord16 _) -> DBusWord16+	(VarBoxWord32 _) -> DBusWord32+	(VarBoxWord64 _) -> DBusWord64+	(VarBoxDouble _) -> DBusDouble+	(VarBoxString _) -> DBusString+	(VarBoxSignature _) -> DBusSignature+	(VarBoxObjectPath _) -> DBusObjectPath+	(VarBoxVariant _) -> DBusVariant+	(VarBoxArray x) -> DBusArray (arrayType x)+	(VarBoxDictionary x) -> let+		keyT = dictionaryKeyType x+		valueT = dictionaryValueType x+		in DBusDictionary keyT valueT+	(VarBoxStructure x) -> let+		Structure items = x+		in DBusStructure (map variantType items)  <<type exports>>= , variantType -@ These helper macros will be used for defining instances of Haskell types.+@ A macro is useful for reducing verbosity in simple {\tt Variable}+instances.  <<DBus/Types.hs>>=-#define INSTANCE_BUILTIN(HASKELL, DBUS) \-	instance Builtin HASKELL where \-		{ builtinDBusType _ = DBUS };--#define INSTANCE_VARIABLE(HASKELL) \-	instance Variable HASKELL where \-		{ toVariant = Variant \-		; fromVariant (Variant x) = cast x };--#define BUILTIN_VARIABLE(HASKELL, DBUS) \-	INSTANCE_BUILTIN(HASKELL, DBUS) \-	INSTANCE_VARIABLE(HASKELL)+#define INSTANCE_VARIABLE(TYPE) \+	instance Variable TYPE where \+		{ toVariant = VarBox##TYPE \+		; fromVariant (VarBox##TYPE x) = Just x \+		; fromVariant _ = Nothing \+		} -@ Since {\tt Variant}s are D-Bus values themselves, they have a type.+@ Since {\tt Variant}s are D-Bus values themselves, they can be stored in variants.  <<DBus/Types.hs>>=-BUILTIN_VARIABLE(Variant, DBusVariant)+INSTANCE_VARIABLE(Variant)  @ \subsection{Numerics} @@ -283,15 +311,15 @@ import Data.Int (Int16, Int32, Int64)  <<DBus/Types.hs>>=-BUILTIN_VARIABLE(Bool,   DBusBoolean)-BUILTIN_VARIABLE(Word8,  DBusByte)-BUILTIN_VARIABLE(Int16,  DBusInt16)-BUILTIN_VARIABLE(Int32,  DBusInt32)-BUILTIN_VARIABLE(Int64,  DBusInt64)-BUILTIN_VARIABLE(Word16, DBusWord16)-BUILTIN_VARIABLE(Word32, DBusWord32)-BUILTIN_VARIABLE(Word64, DBusWord64)-BUILTIN_VARIABLE(Double, DBusDouble)+INSTANCE_VARIABLE(Bool)+INSTANCE_VARIABLE(Word8)+INSTANCE_VARIABLE(Int16)+INSTANCE_VARIABLE(Int32)+INSTANCE_VARIABLE(Int64)+INSTANCE_VARIABLE(Word16)+INSTANCE_VARIABLE(Word32)+INSTANCE_VARIABLE(Word64)+INSTANCE_VARIABLE(Double)  @ \subsection{Strings} @@ -300,7 +328,10 @@ strings defined in {\tt Data.Text} are used internally.  <<DBus/Types.hs>>=-BUILTIN_VARIABLE(TL.Text, DBusString)+instance Variable TL.Text where+	toVariant = VarBoxString+	fromVariant (VarBoxString x) = Just x+	fromVariant _ = Nothing  @ There's two different {\tt Text} types, strict and lazy. It'd be a pain to store both and have to convert later, so instead, all strict {\tt Text}@@ -334,9 +365,9 @@ D-Bus signature string into a {\tt Signature}.  <<DBus/Types.hs>>=-BUILTIN_VARIABLE(Signature, DBusSignature)+INSTANCE_VARIABLE(Signature) data Signature = Signature { signatureTypes :: [Type] }-	deriving (Eq, Typeable)+	deriving (Eq)  instance Show Signature where 	showsPrec d x = showParen (d > 10) $@@ -352,9 +383,12 @@ @ It doesn't make much sense to sort signatures, but since they can be used as dictionary keys, it's useful to have them as an instance of {\tt Ord}. +<<type imports>>=+import Data.Ord (comparing)+ <<DBus/Types.hs>>= instance Ord Signature where-	compare x y = compare (strSignature x) (strSignature y)+	compare = comparing strSignature  <<type exports>>=   -- * Signatures@@ -405,61 +439,99 @@ @ \subsubsection{Parsing}  When parsing, additional restrictions apply which are not inherent to the-D-Bus type system:+D-Bus type system. {\tt mkSignature} guarantees that any {\tt Signature} is+valid according to D-Bus rules. -\begin{itemize}-\item Signatures may be at most 255 characters long.-\end{itemize}+<<DBus/Types.hs>>=+mkSignature :: Text -> Maybe Signature+mkSignature text = parsed where+	<<fast signature parser>>+	<<slow signature parser>>+	parsed = case TL.length text of+		0 -> Just $ Signature []+		1 -> fast+		_ -> slow -Parsec is used to parse signatures.+@ Since single-type and empty signatures are very common, they are+special-cased for performance. +<<fast signature parser>>=+just t = Just $ Signature [t]+fast = case TL.head text of+	'b' -> just DBusBoolean+	'y' -> just DBusByte+	'n' -> just DBusInt16+	'i' -> just DBusInt32+	'x' -> just DBusInt64+	'q' -> just DBusWord16+	'u' -> just DBusWord32+	't' -> just DBusWord64+	'd' -> just DBusDouble+	's' -> just DBusString+	'g' -> just DBusSignature+	'o' -> just DBusObjectPath+	'v' -> just DBusVariant+	_   -> Nothing++@ Parsec is used to parse more complex signatures.+ <<type imports>>= import Text.Parsec ((<|>)) import qualified Text.Parsec as P import DBus.Util (checkLength, parseMaybe) -<<DBus/Types.hs>>=-mkSignature :: Text -> Maybe Signature-mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where-	sigParser = do-		types <- P.many parseType-		P.eof-		return $ Signature types-	parseType = parseAtom <|> parseContainer-	parseContainer =-		    parseArray-		<|> parseStruct-		<|> (P.char 'v' >> return DBusVariant)-	parseAtom =-		    (P.char 'b' >> return DBusBoolean)-		<|> (P.char 'y' >> return DBusByte)-		<|> (P.char 'n' >> return DBusInt16)-		<|> (P.char 'i' >> return DBusInt32)-		<|> (P.char 'x' >> return DBusInt64)-		<|> (P.char 'q' >> return DBusWord16)-		<|> (P.char 'u' >> return DBusWord32)-		<|> (P.char 't' >> return DBusWord64)-		<|> (P.char 'd' >> return DBusDouble)-		<|> (P.char 's' >> return DBusString)-		<|> (P.char 'g' >> return DBusSignature)-		<|> (P.char 'o' >> return DBusObjectPath)-	parseArray = do-		P.char 'a'-		parseDict <|> do-		t <- parseType-		return $ DBusArray t-	parseDict = do-		P.char '{'-		keyType <- parseAtom-		valueType <- parseType-		P.char '}'-		return $ DBusDictionary keyType valueType-	parseStruct = do-		P.char '('-		types <- P.many parseType-		P.char ')'-		return $ DBusStructure types+<<slow signature parser>>=+slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text+sigParser = do+	types <- P.many parseType+	P.eof+	return $ Signature types +@ Types may be either containers or atoms. Containers can't be dictionary+keys.++<<slow signature parser>>=+parseType = parseAtom <|> parseContainer+parseContainer =+	    parseArray+	<|> parseStruct+	<|> (P.char 'v' >> return DBusVariant)++<<slow signature parser>>=+parseArray = do+	P.char 'a'+	parseDict <|> fmap DBusArray parseType+parseDict = do+	P.char '{'+	keyType <- parseAtom+	valueType <- parseType+	P.char '}'+	return $ DBusDictionary keyType valueType++@ Structures can contain any types.++<<slow signature parser>>=+parseStruct = do+	P.char '('+	types <- P.many parseType+	P.char ')'+	return $ DBusStructure types++<<slow signature parser>>=+parseAtom =+	    (P.char 'b' >> return DBusBoolean)+	<|> (P.char 'y' >> return DBusByte)+	<|> (P.char 'n' >> return DBusInt16)+	<|> (P.char 'i' >> return DBusInt32)+	<|> (P.char 'x' >> return DBusInt64)+	<|> (P.char 'q' >> return DBusWord16)+	<|> (P.char 'u' >> return DBusWord32)+	<|> (P.char 't' >> return DBusWord64)+	<|> (P.char 'd' >> return DBusDouble)+	<|> (P.char 's' >> return DBusString)+	<|> (P.char 'g' >> return DBusSignature)+	<|> (P.char 'o' >> return DBusObjectPath)+ @ Since many signatures are defined as string literals, it's useful to have a helper function to construct a signature directly from a string. If the input string is invalid, {\tt error} will be called.@@ -489,11 +561,11 @@ @ \subsection{Object paths}  <<DBus/Types.hs>>=-BUILTIN_VARIABLE(ObjectPath, DBusObjectPath)+INSTANCE_VARIABLE(ObjectPath) newtype ObjectPath = ObjectPath 	{ strObjectPath :: Text 	}-	deriving (Eq, Ord, Typeable)+	deriving (Eq, Ord)  instance Show ObjectPath where 	showsPrec d (ObjectPath x) = showParen (d > 10) $@@ -549,10 +621,7 @@ data Array 	= VariantArray Type [Variant] 	| ByteArray ByteString-	deriving (Eq, Typeable)--instance Builtin Array where-	builtinDBusType = DBusArray . arrayType+	deriving (Eq)  <<apidoc arrayType>> arrayType :: Array -> Type@@ -578,8 +647,8 @@ 		s "Array " . showSig . s " [" . s valueString . s "]" where 			s = showString 			showSig = shows . typeCode . arrayType $ array-			vs = [show x | (Variant x) <- arrayItems array]-			valueString = intercalate ", " vs+			showVar var = showsPrecVar 0 var ""+			valueString = intercalate ", " $ map showVar $ arrayItems array  @ Clients constructing an array must provide the expected item type, which will be checked for validity. Every item in the array will be checked against@@ -587,9 +656,7 @@  <<DBus/Types.hs>>= arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems DBusByte vs = do-	bytes <- mapM fromVariant vs-	Just . ByteArray . ByteString.pack $ bytes+arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)  arrayFromItems t vs = do 	mkSignature (typeCode t)@@ -658,10 +725,7 @@ 	, dictionaryValueType :: Type 	, dictionaryItems     :: [(Variant, Variant)] 	}-	deriving (Eq, Typeable)--instance Builtin Dictionary where-	builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt+	deriving (Eq)  <<type exports>>=   -- * Dictionaries@@ -683,8 +747,7 @@ 			s = showString 			showSig = shows $ TL.append (typeCode kt) (typeCode vt) 			valueString = intercalate ", " $ map showPair pairs-			showPair ((Variant k), (Variant v)) =-				show k ++ " -> " ++ show v+			showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""  @ Constructing a {\tt Dictionary} works like constructing an {\tt Array}, except that there are two types to check, and the key type must be atomic.@@ -776,10 +839,7 @@ <<DBus/Types.hs>>= INSTANCE_VARIABLE(Structure) data Structure = Structure [Variant]-	deriving (Show, Eq, Typeable)--instance Builtin Structure where-	builtinDBusType (Structure vs) = DBusStructure $ map variantType vs+	deriving (Show, Eq)  <<type exports>>=   -- * Structures@@ -1195,7 +1255,7 @@ receivedBody (ReceivedMethodReturn _ _ x) = messageBody x receivedBody (ReceivedError        _ _ x) = messageBody x receivedBody (ReceivedSignal       _ _ x) = messageBody x-receivedBody _ = []+receivedBody (ReceivedUnknown      _ _ x) = unknownBody x  <<message exports>>= , ReceivedMessage (..)@@ -1212,19 +1272,13 @@ <<copyright>> module DBus.Wire (<<wire exports>>) where import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal  <<DBus/Wire/Internal.hs>>= <<copyright>>-<<text extensions>>-<<wire extensions>> module DBus.Wire.Internal where-<<text imports>>-<<wire imports>>-import Control.Monad (when, unless)-import Data.Maybe (fromJust, listToMaybe, fromMaybe)-import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-+import Data.Word (Word8, Word64) import qualified DBus.Types as T  @ \subsection{Endianness}@@ -1270,33 +1324,43 @@ byte strings, but it doesn't provide any way to retrieve the length of its internal buffer, so the byte count is tracked separately. -<<wire imports>>=-import qualified Control.Monad.State as ST+<<DBus/Wire/Marshal.hs>>=+<<copyright>>+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module DBus.Wire.Marshal where+<<text imports>>+<<marshal imports>>+import DBus.Wire.Internal+import Control.Monad (when)+import Data.Maybe (fromJust)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import qualified DBus.Types as T++<<marshal imports>>=+import qualified Control.Monad.State as State import qualified Control.Monad.Error as E import qualified Data.ByteString.Lazy as L import qualified Data.Binary.Builder as B -<<wire extensions>>=-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE BangPatterns #-}--<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= data MarshalState = MarshalState Endianness B.Builder !Word64-newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)-	deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)+newtype MarshalM a = MarshalM (E.ErrorT MarshalError (State.State MarshalState) a)+	deriving (Monad, E.MonadError MarshalError, State.MonadState MarshalState) type Marshal = MarshalM ()  @ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, which will generate a {\tt ByteString} with the fully marshaled data. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of+runMarshal (MarshalM m) e = case State.runState (E.runErrorT m) initialState of 	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) 	(Left  x, _) -> Left x 	where initialState = MarshalState e B.empty 0 -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshal :: T.Variant -> Marshal marshal v = marshalType (T.variantType v) where 	x :: T.Variable a => a@@ -1306,34 +1370,34 @@  @ TODO: describe these functions -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= append :: L.ByteString -> Marshal append bytes = do-	(MarshalState e builder count) <- ST.get+	(MarshalState e builder count) <- State.get 	let builder' = B.append builder $ B.fromLazyByteString bytes-	    count' = count + (fromIntegral $ L.length bytes)-	ST.put $ MarshalState e builder' count'+	    count' = count + fromIntegral (L.length bytes)+	State.put $ MarshalState e builder' count' -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= pad :: Word8 -> Marshal pad count = do-	(MarshalState _ _ existing) <- ST.get+	(MarshalState _ _ existing) <- State.get 	let padding' = fromIntegral $ padding existing count 	append $ L.replicate padding' 0  @ Most numeric values already have marshalers implemented in the {\tt Data.Binary.Builder} module; this function lets them be re-used easily. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do 	pad size-	(MarshalState e builder count) <- ST.get+	(MarshalState e builder count) <- State.get 	let builder' = B.append builder $ case e of 		BigEndian -> be x 		LittleEndian -> le x-	let count' = count + (fromIntegral size)-	ST.put $ MarshalState e builder' count'+	let count' = count + fromIntegral size+	State.put $ MarshalState e builder' count'  @ \subsubsection{Errors} @@ -1349,7 +1413,7 @@       ({\tt '\textbackslash{}0'}) or invalid Unicode. \end{itemize} -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= data MarshalError 	= MessageTooLong Word64 	| ArrayTooLong Word64@@ -1379,17 +1443,37 @@  Unmarshaling also uses an error transformer and internal state. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>=+<<copyright>>+<<text extensions>>+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module DBus.Wire.Unmarshal where+<<text imports>>+<<unmarshal imports>>+import Control.Monad (when, unless)+import Data.Maybe (fromJust, listToMaybe, fromMaybe)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import DBus.Wire.Internal+import qualified DBus.Types as T++<<unmarshal imports>>=+import qualified Control.Monad.State as State+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Lazy as L++<<DBus/Wire/Unmarshal.hs>>= data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)-	deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)+newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (State.State UnmarshalState) a)+	deriving (Monad, Functor, E.MonadError UnmarshalError, State.MonadState UnmarshalState) -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where+runUnmarshal (Unmarshal m) e bytes = State.evalState (E.runErrorT m) state where 	state = UnmarshalState e bytes 0 -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes @@ -1398,34 +1482,34 @@  @ TODO: describe these functions -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= consume :: Word64 -> Unmarshal L.ByteString consume count = do-	(UnmarshalState e bytes offset) <- ST.get+	(UnmarshalState e bytes offset) <- State.get 	let (x, bytes') = L.splitAt (fromIntegral count) bytes 	unless (L.length x == fromIntegral count) $ 		E.throwError $ UnexpectedEOF offset 	-	ST.put $ UnmarshalState e bytes' (offset + count)+	State.put $ UnmarshalState e bytes' (offset + count) 	return x -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= skipPadding :: Word8 -> Unmarshal () skipPadding count = do-	(UnmarshalState _ _ offset) <- ST.get+	(UnmarshalState _ _ offset) <- State.get 	bytes <- consume $ padding offset count 	unless (L.all (== 0) bytes) $ 		E.throwError $ InvalidPadding offset -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= skipTerminator :: Unmarshal () skipTerminator = do-	(UnmarshalState _ _ offset) <- ST.get+	(UnmarshalState _ _ offset) <- State.get 	bytes <- consume 1 	unless (L.all (== 0) bytes) $ 		E.throwError $ MissingTerminator offset -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of 	Just x' -> return x'@@ -1437,14 +1521,14 @@ 	x' <- fromMaybeU label f x 	return $ T.toVariant x' -<<wire imports>>=+<<unmarshal imports>>= import qualified Data.Binary.Get as G -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do 	skipPadding count-	(UnmarshalState e _ _) <- ST.get+	(UnmarshalState e _ _) <- State.get 	bs <- consume . fromIntegral $ count 	let get' = case e of 		BigEndian -> be@@ -1455,7 +1539,7 @@               -> Unmarshal T.Variant unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do 	done <- test@@ -1481,7 +1565,7 @@ \item An array's size didn't match the number of elements \end{itemize} -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= data UnmarshalError 	= UnsupportedProtocolVersion Word8 	| UnexpectedEOF Word64@@ -1533,10 +1617,11 @@ @ Because {\tt Word32}s are often used for other types, there's separate functions for handling them. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le +<<DBus/Wire/Unmarshal.hs>>= unmarshalWord32 :: Unmarshal Word32 unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le @@ -1569,14 +1654,17 @@  @ {\tt Double}s are marshaled as in-bit IEEE-754 floating-point format. -<<wire imports>>=+<<marshal imports>>= import Data.Binary.Put (runPut) import qualified Data.Binary.IEEE754 as IEEE +<<unmarshal imports>>=+import qualified Data.Binary.IEEE754 as IEEE+ <<marshalers>>= marshalType T.DBusDouble = do 	pad 8-	(MarshalState e _ _) <- ST.get+	(MarshalState e _ _) <- State.get 	let put = case e of 		BigEndian -> IEEE.putFloat64be 		LittleEndian -> IEEE.putFloat64le@@ -1614,26 +1702,34 @@ Because the encoding functions from {\tt Data.Text} raise exceptions on error, checking their return value requires some ugly workarounds. -<<wire imports>>=+<<DBus/Wire/Unicode.hs>>=+<<copyright>>+module DBus.Wire.Unicode+	( maybeEncodeUtf8+	, maybeDecodeUtf8) where+import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy (Text) import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8) import Data.Text.Encoding.Error (UnicodeException) import qualified Control.Exception as Exc import System.IO.Unsafe (unsafePerformIO) -<<DBus/Wire/Internal.hs>>= excToMaybe :: a -> Maybe a excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError  unicodeError :: UnicodeException -> IO (Maybe a) unicodeError = const $ return Nothing -maybeEncodeUtf8 :: Text -> Maybe L.ByteString+maybeEncodeUtf8 :: Text -> Maybe ByteString maybeEncodeUtf8 = excToMaybe . encodeUtf8 -maybeDecodeUtf8 :: L.ByteString -> Maybe Text+maybeDecodeUtf8 :: ByteString -> Maybe Text maybeDecodeUtf8 = excToMaybe . decodeUtf8 -<<DBus/Wire/Internal.hs>>=+<<marshal imports>>=+import DBus.Wire.Unicode (maybeEncodeUtf8)++<<DBus/Wire/Marshal.hs>>= marshalText :: Text -> Marshal marshalText x = do 	bytes <- case maybeEncodeUtf8 x of@@ -1645,7 +1741,10 @@ 	append bytes 	append (L.singleton 0) -<<DBus/Wire/Internal.hs>>=+<<unmarshal imports>>=+import DBus.Wire.Unicode (maybeDecodeUtf8)++<<DBus/Wire/Unmarshal.hs>>= unmarshalText :: Unmarshal Text unmarshalText = do 	byteCount <- unmarshalWord32@@ -1672,7 +1771,10 @@ Signatures are similar to strings, except their length is limited to 255 characters and is therefore stored as a single byte. -<<DBus/Wire/Internal.hs>>=+<<marshal imports>>=+import Data.Text.Lazy.Encoding (encodeUtf8)++<<DBus/Wire/Marshal.hs>>= marshalSignature :: T.Signature -> Marshal marshalSignature x = do 	let bytes = encodeUtf8 . T.strSignature $ x@@ -1681,7 +1783,7 @@ 	append bytes 	append (L.singleton 0) -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do 	byteCount <- L.head `fmap` consume 1@@ -1716,10 +1818,10 @@ \emph{first} to calculate the array length. This requires building a temporary marshaler, to get the padding right. -<<wire imports>>=+<<marshal imports>>= import qualified DBus.Constants as C -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshalArray :: T.Array -> Marshal marshalArray x = do 	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x@@ -1730,39 +1832,39 @@ 	append $ L.replicate arrayPadding 0 	append arrayBytes -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where 	Just bytes = T.arrayToBytes x -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= getArrayBytes itemType x = do 	let vs = T.arrayItems x-	s <- ST.get-	(MarshalState _ _ afterLength) <- marshalWord32 0 >> ST.get-	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> ST.get+	s <- State.get+	(MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get+	(MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get 	-	ST.put $ MarshalState e B.empty afterPadding-	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> ST.get+	State.put $ MarshalState e B.empty afterPadding+	(MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get 	 	let itemBytes = B.toLazyByteString itemBuilder 	    paddingSize = fromIntegral $ afterPadding - afterLength 	-	ST.put s+	State.put s 	return (paddingSize, itemBytes)  @ Unmarshaling is much easier, especially if it's a byte array. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do 	byteCount <- unmarshalWord32 	T.arrayFromBytes `fmap` consume (fromIntegral byteCount) -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unmarshalArray itemType = do 	let getOffset = do-		(UnmarshalState _ _ o) <- ST.get+		(UnmarshalState _ _ o) <- State.get 		return o 	byteCount <- unmarshalWord32 	skipPadding (alignment itemType)@@ -1829,21 +1931,29 @@  @ \subsection{Messages} -<<wire imports>>=+<<marshal imports>>= import qualified DBus.Message.Internal as M +<<unmarshal imports>>=+import qualified DBus.Message.Internal as M+ @ \subsubsection{Flags} -<<wire imports>>=-import Data.Bits ((.|.), (.&.))+<<unmarshal imports>>=+import Data.Bits ((.&.)) import qualified Data.Set as Set -<<DBus/Wire/Internal.hs>>=+<<marshal imports>>=+import Data.Bits ((.|.))+import qualified Data.Set as Set++<<DBus/Wire/Marshal.hs>>= encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where 	flagValue M.NoReplyExpected = 0x1 	flagValue M.NoAutoStart     = 0x2 +<<DBus/Wire/Unmarshal.hs>>= decodeFlags :: Word8 -> Set.Set M.Flag decodeFlags word = Set.fromList flags where 	flagSet = [ (0x1, M.NoReplyExpected)@@ -1853,7 +1963,7 @@  @ \subsubsection{Header fields} -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x)        = encodeField' 1 x encodeField (M.Interface x)   = encodeField' 2 x@@ -1870,7 +1980,7 @@ 	, T.toVariant $ T.toVariant x 	] -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= decodeField :: Monad m => T.Structure             -> E.ErrorT UnmarshalError m [M.HeaderField] decodeField struct = case unpackField struct of@@ -1890,7 +2000,7 @@ 	Just x' -> return [f x'] 	Nothing -> E.throwError $ InvalidHeaderField label x -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where 	T.Structure [c, v] = struct@@ -1906,7 +2016,7 @@ <<wire exports>>= , marshalMessage -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= <<apidoc marshalMessage>> marshalMessage :: M.Message a => Endianness -> M.Serial -> a                -> Either MarshalError L.ByteString@@ -1914,10 +2024,10 @@ 	body = M.messageBody msg 	marshaler = do 		sig <- checkBodySig body-		empty <- ST.get+		empty <- State.get 		mapM_ marshal body-		(MarshalState _ bodyBytesB _) <- ST.get-		ST.put empty+		(MarshalState _ bodyBytesB _) <- State.get+		State.put empty 		marshalEndianness e 		let bodyBytes = B.toLazyByteString bodyBytesB 		marshalHeader msg serial sig@@ -1926,7 +2036,7 @@ 		append bodyBytes 		checkMaximumSize -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let 	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs@@ -1935,7 +2045,7 @@ 		Just x -> return x 		Nothing -> invalid -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32               -> Marshal marshalHeader msg serial bodySig bodyLength = do@@ -1949,23 +2059,26 @@ 	marshal . T.toVariant . fromJust . T.toArray fieldType 	        $ map encodeField fields -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Marshal.hs>>= checkMaximumSize :: Marshal checkMaximumSize = do-	(MarshalState _ _ messageLength) <- ST.get+	(MarshalState _ _ messageLength) <- State.get 	when (messageLength > fromIntegral C.messageMaximumLength) 		(E.throwError $ MessageTooLong $ fromIntegral messageLength)  @ \subsubsection{Unmarshaling} +<<unmarshal imports>>=+import qualified DBus.Constants as C+ <<wire exports>>= , unmarshalMessage -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= <<apidoc unmarshalMessage>> unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage)@@ -2044,7 +2157,7 @@ let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 getBytes . fromIntegral $ bodyPadding -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe "" signature where 	signature = listToMaybe [x | M.Signature x <- fields]@@ -2064,7 +2177,7 @@ Slightly ugly; to avoid orphan instances of either {\tt Text} or {\tt Either}, a newtype is used to turn {\tt Either} into a monad. -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= newtype EitherM a b = EitherM (Either a b)  instance Monad (EitherM a) where@@ -2082,14 +2195,14 @@  @ This really belongs in the Message section... -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text                         (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage)  @ Method calls -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage 1 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -2102,7 +2215,7 @@  @ Method returns -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage 2 fields = do 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] 	return $ \serial _ body -> let@@ -2113,7 +2226,7 @@  @ Errors -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage 3 fields = do 	name <- require "error name" [x | M.ErrorName x <- fields] 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]@@ -2125,7 +2238,7 @@  @ Signals -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage 4 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -2138,13 +2251,13 @@  @ Unknown -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= buildReceivedMessage typeCode fields = return $ \serial flags body -> let 	sender = listToMaybe [x | M.Sender x <- fields] 	msg = M.Unknown typeCode flags body 	in M.ReceivedUnknown serial sender msg -<<DBus/Wire/Internal.hs>>=+<<DBus/Wire/Unmarshal.hs>>= require :: Text -> [a] -> EitherM Text a require _     (x:_) = return x require label _     = EitherM $ Left label@@ -2332,6 +2445,7 @@ data Transport = Transport 	{ transportSend :: L.ByteString -> IO () 	, transportRecv :: Word32 -> IO L.ByteString+	, transportClose :: IO () 	}  @ If a method has no known transport, attempting to connect using it will@@ -2492,7 +2606,7 @@ handleTransport h = do 	I.hSetBuffering h I.NoBuffering 	I.hSetBinaryMode h True-	return $ Transport (L.hPut h) (L.hGet h . fromIntegral)+	return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h)  @ \subsection{Errors} @@ -2552,6 +2666,16 @@ , connect , connectFirst +@ \subsection{Closing connections}++<<DBus/Connection.hs>>=+<<apidoc connectionClose>>+connectionClose :: Connection -> IO ()+connectionClose = transportClose . connectionTransport++<<connection exports>>=+, connectionClose+ @ \subsection{Authentication}  Authentication is a bit iffy; currently, there's a one specified@@ -2762,7 +2886,7 @@  <<DBus/Bus.hs>>= busForConnection :: C.Connection -> IO (C.Connection, T.BusName)-busForConnection c = sendHello c >>= return . (,) c+busForConnection c = fmap ((,) c) $ sendHello c  <<DBus/Bus.hs>>= <<apidoc getBus>>@@ -3231,7 +3355,7 @@ 	) where <<text imports>> import Data.Word (Word8)-import Data.Maybe (catMaybes, fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified DBus.Types as T import qualified DBus.Message as M@@ -3289,7 +3413,7 @@ formatRule rule = TL.intercalate "," filters where 	filters = structureFilters ++ parameterFilters 	parameterFilters = map formatParameter $ matchParameters rule-	structureFilters = catMaybes $ map unpack+	structureFilters = mapMaybe unpack 		[ ("type", fmap formatType . matchType) 		, ("sender", fmap T.strBusName . matchSender) 		, ("interface", fmap T.strInterfaceName . matchInterface)@@ -3357,7 +3481,7 @@ <<DBus/MatchRule.hs>>= <<apidoc matches>> matches :: MatchRule -> M.ReceivedMessage -> Bool-matches rule msg = and . catMaybes . map ($ rule) $+matches rule msg = and . mapMaybe ($ rule) $ 	[ fmap      (typeMatches msg) . matchType 	, fmap    (senderMatches msg) . matchSender 	, fmap     (ifaceMatches msg) . matchInterface@@ -3851,6 +3975,10 @@ <<apidoc connectFirst>>= -- | Try to open a connection to various addresses, returning the first -- connection which could be successfully opened.++<<apidoc connectionClose>>=+-- | Close an open connection. Once closed, the 'Connection' is no longer+-- valid and must not be used.  <<apidoc send>>= -- | Send a single message, with a generated 'M.Serial'. The second parameter

@@ -43,7 +43,7 @@ import DBus.Util (fromRight)  busForConnection :: C.Connection -> IO (C.Connection, T.BusName)-busForConnection c = sendHello c >>= return . (,) c+busForConnection c = fmap ((,) c) $ sendHello c  -- | Similar to 'C.connect', but additionally sends @Hello@ messages to the -- central bus.

@@ -28,6 +28,8 @@           , connect           , connectFirst +          , connectionClose+           , send            , receive@@ -84,6 +86,7 @@ data Transport = Transport         { transportSend :: L.ByteString -> IO ()         , transportRecv :: Word32 -> IO L.ByteString+        , transportClose :: IO ()         }  connectTransport :: A.Address -> IO Transport@@ -172,7 +175,7 @@ handleTransport h = do         I.hSetBuffering h I.NoBuffering         I.hSetBinaryMode h True-        return $ Transport (L.hPut h) (L.hGet h . fromIntegral)+        return $ Transport (L.hPut h) (L.hGet h . fromIntegral) (I.hClose h)  data ConnectionError         = InvalidAddress Text@@ -204,6 +207,12 @@         connectFirst'     [] = E.throwIO $ NoWorkingAddress allAddrs         connectFirst' ((mech, a):as) = E.catch (connect mech a) $                 \(E.SomeException _) -> connectFirst' as++-- | Close an open connection. Once closed, the 'Connection' is no longer+-- valid and must not be used.++connectionClose :: Connection -> IO ()+connectionClose = transportClose . connectionTransport  -- | Send a single message, with a generated 'M.Serial'. The second parameter -- exists to prevent race conditions when registering a reply handler; it

@@ -30,7 +30,7 @@ import qualified Data.Text.Lazy as TL  import Data.Word (Word8)-import Data.Maybe (catMaybes, fromMaybe)+import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import qualified DBus.Types as T import qualified DBus.Message as M@@ -83,7 +83,7 @@ formatRule rule = TL.intercalate "," filters where         filters = structureFilters ++ parameterFilters         parameterFilters = map formatParameter $ matchParameters rule-        structureFilters = catMaybes $ map unpack+        structureFilters = mapMaybe unpack                 [ ("type", fmap formatType . matchType)                 , ("sender", fmap T.strBusName . matchSender)                 , ("interface", fmap T.strInterfaceName . matchInterface)@@ -137,7 +137,7 @@ -- for implementing signal handlers.  matches :: MatchRule -> M.ReceivedMessage -> Bool-matches rule msg = and . catMaybes . map ($ rule) $+matches rule msg = and . mapMaybe ($ rule) $         [ fmap      (typeMatches msg) . matchType         , fmap    (senderMatches msg) . matchSender         , fmap     (ifaceMatches msg) . matchInterface

@@ -196,5 +196,5 @@ receivedBody (ReceivedMethodReturn _ _ x) = messageBody x receivedBody (ReceivedError        _ _ x) = messageBody x receivedBody (ReceivedSignal       _ _ x) = messageBody x-receivedBody _ = []+receivedBody (ReceivedUnknown      _ _ x) = unknownBody x 

@@ -17,9 +17,6 @@  {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE ExistentialQuantification #-}- {-# LANGUAGE TypeSynonymInstances #-}  module DBus.Types (  -- * Available types@@ -103,13 +100,13 @@ import Data.Text.Lazy (Text) import qualified Data.Text.Lazy as TL -import Data.Typeable (Typeable, cast)- import Data.Word (Word8, Word16, Word32, Word64) import Data.Int (Int16, Int32, Int64)  import qualified Data.Text as T +import Data.Ord (comparing)+ import Text.Parsec ((<|>)) import qualified Text.Parsec as P import DBus.Util (checkLength, parseMaybe)@@ -196,41 +193,86 @@         ["("] ++ map typeCode ts ++ [")"]  -class (Show a, Eq a) => Builtin a where-        builtinDBusType :: a -> Type- -- | 'Variant's may contain any other built-in D-Bus value. Besides -- representing native @VARIANT@ values, they allow type-safe storage and -- deconstruction of heterogeneous collections. -data Variant = forall a. (Variable a, Builtin a, Typeable a) => Variant a-        deriving (Typeable)+data Variant+        = VarBoxBool Bool+        | VarBoxWord8 Word8+        | VarBoxInt16 Int16+        | VarBoxInt32 Int32+        | VarBoxInt64 Int64+        | VarBoxWord16 Word16+        | VarBoxWord32 Word32+        | VarBoxWord64 Word64+        | VarBoxDouble Double+        | VarBoxString Text+        | VarBoxSignature Signature+        | VarBoxObjectPath ObjectPath+        | VarBoxVariant Variant+        | VarBoxArray Array+        | VarBoxDictionary Dictionary+        | VarBoxStructure Structure+        deriving (Eq)  class Variable a where         toVariant :: a -> Variant         fromVariant :: Variant -> Maybe a  instance Show Variant where-        showsPrec d (Variant x) = showParen (d > 10) $-                s "Variant " . shows code . s " " . showsPrec 11 x-                where code = typeCode . builtinDBusType $ x-                      s    = showString+        showsPrec d var = showParen (d > 10) full where+                full = s "Variant " . shows code . s " " . valueStr+                code = typeCode $ variantType var+                s = showString+                valueStr = showsPrecVar 11 var -instance Eq Variant where-        (Variant x) == (Variant y) = cast x == Just y+showsPrecVar :: Int -> Variant -> ShowS+showsPrecVar d var = case var of+        (VarBoxBool x) -> showsPrec d x+        (VarBoxWord8 x) -> showsPrec d x+        (VarBoxInt16 x) -> showsPrec d x+        (VarBoxInt32 x) -> showsPrec d x+        (VarBoxInt64 x) -> showsPrec d x+        (VarBoxWord16 x) -> showsPrec d x+        (VarBoxWord32 x) -> showsPrec d x+        (VarBoxWord64 x) -> showsPrec d x+        (VarBoxDouble x) -> showsPrec d x+        (VarBoxString x) -> showsPrec d x+        (VarBoxSignature x) -> showsPrec d x+        (VarBoxObjectPath x) -> showsPrec d x+        (VarBoxVariant x) -> showsPrec d x+        (VarBoxArray x) -> showsPrec d x+        (VarBoxDictionary x) -> showsPrec d x+        (VarBoxStructure x) -> showsPrec d x  -- | Every variant is strongly-typed; that is, the type of its contained -- value is known at all times. This function retrieves that type, so that -- the correct cast can be used to retrieve the value.  variantType :: Variant -> Type-variantType (Variant x) = builtinDBusType x------+variantType var = case var of+        (VarBoxBool _) -> DBusBoolean+        (VarBoxWord8 _) -> DBusByte+        (VarBoxInt16 _) -> DBusInt16+        (VarBoxInt32 _) -> DBusInt32+        (VarBoxInt64 _) -> DBusInt64+        (VarBoxWord16 _) -> DBusWord16+        (VarBoxWord32 _) -> DBusWord32+        (VarBoxWord64 _) -> DBusWord64+        (VarBoxDouble _) -> DBusDouble+        (VarBoxString _) -> DBusString+        (VarBoxSignature _) -> DBusSignature+        (VarBoxObjectPath _) -> DBusObjectPath+        (VarBoxVariant _) -> DBusVariant+        (VarBoxArray x) -> DBusArray (arrayType x)+        (VarBoxDictionary x) -> let+                keyT = dictionaryKeyType x+                valueT = dictionaryValueType x+                in DBusDictionary keyT valueT+        (VarBoxStructure x) -> let+                Structure items = x+                in DBusStructure (map variantType items)   @@ -239,19 +281,22 @@   -instance Builtin Variant where                 { builtinDBusType _ = DBusVariant };         instance Variable Variant where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Variant where                 { toVariant = VarBoxVariant                 ; fromVariant (VarBoxVariant x) = Just x                 ; fromVariant _ = Nothing                 } -instance Builtin Bool where                 { builtinDBusType _ = DBusBoolean };         instance Variable Bool where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Word8 where                 { builtinDBusType _ = DBusByte };         instance Variable Word8 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Int16 where                 { builtinDBusType _ = DBusInt16 };         instance Variable Int16 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Int32 where                 { builtinDBusType _ = DBusInt32 };         instance Variable Int32 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Int64 where                 { builtinDBusType _ = DBusInt64 };         instance Variable Int64 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Word16 where                 { builtinDBusType _ = DBusWord16 };         instance Variable Word16 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Word32 where                 { builtinDBusType _ = DBusWord32 };         instance Variable Word32 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Word64 where                 { builtinDBusType _ = DBusWord64 };         instance Variable Word64 where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };-instance Builtin Double where                 { builtinDBusType _ = DBusDouble };         instance Variable Double where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Bool where                 { toVariant = VarBoxBool                 ; fromVariant (VarBoxBool x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Word8 where                 { toVariant = VarBoxWord8                 ; fromVariant (VarBoxWord8 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Int16 where                 { toVariant = VarBoxInt16                 ; fromVariant (VarBoxInt16 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Int32 where                 { toVariant = VarBoxInt32                 ; fromVariant (VarBoxInt32 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Int64 where                 { toVariant = VarBoxInt64                 ; fromVariant (VarBoxInt64 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Word16 where                 { toVariant = VarBoxWord16                 ; fromVariant (VarBoxWord16 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Word32 where                 { toVariant = VarBoxWord32                 ; fromVariant (VarBoxWord32 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Word64 where                 { toVariant = VarBoxWord64                 ; fromVariant (VarBoxWord64 x) = Just x                 ; fromVariant _ = Nothing                 }+instance Variable Double where                 { toVariant = VarBoxDouble                 ; fromVariant (VarBoxDouble x) = Just x                 ; fromVariant _ = Nothing                 } -instance Builtin TL.Text where                 { builtinDBusType _ = DBusString };         instance Variable TL.Text where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable TL.Text where+        toVariant = VarBoxString+        fromVariant (VarBoxString x) = Just x+        fromVariant _ = Nothing  instance Variable T.Text where         toVariant = toVariant . TL.fromChunks . (:[])@@ -261,9 +306,9 @@         toVariant = toVariant . TL.pack         fromVariant = fmap TL.unpack . fromVariant -instance Builtin Signature where                 { builtinDBusType _ = DBusSignature };         instance Variable Signature where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Signature where                 { toVariant = VarBoxSignature                 ; fromVariant (VarBoxSignature x) = Just x                 ; fromVariant _ = Nothing                 } data Signature = Signature { signatureTypes :: [Type] }-        deriving (Eq, Typeable)+        deriving (Eq)  instance Show Signature where         showsPrec d x = showParen (d > 10) $@@ -273,60 +318,85 @@ strSignature (Signature ts) = TL.concat $ map typeCode ts  instance Ord Signature where-        compare x y = compare (strSignature x) (strSignature y)+        compare = comparing strSignature  mkSignature :: Text -> Maybe Signature-mkSignature = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack where+mkSignature text = parsed where+        just t = Just $ Signature [t]+        fast = case TL.head text of+                'b' -> just DBusBoolean+                'y' -> just DBusByte+                'n' -> just DBusInt16+                'i' -> just DBusInt32+                'x' -> just DBusInt64+                'q' -> just DBusWord16+                'u' -> just DBusWord32+                't' -> just DBusWord64+                'd' -> just DBusDouble+                's' -> just DBusString+                'g' -> just DBusSignature+                'o' -> just DBusObjectPath+                'v' -> just DBusVariant+                _   -> Nothing++        slow = (parseMaybe sigParser =<<) . checkLength 255 . TL.unpack $ text         sigParser = do                 types <- P.many parseType                 P.eof                 return $ Signature types+         parseType = parseAtom <|> parseContainer         parseContainer =                     parseArray                 <|> parseStruct                 <|> (P.char 'v' >> return DBusVariant)-        parseAtom =-                    (P.char 'b' >> return DBusBoolean)-                <|> (P.char 'y' >> return DBusByte)-                <|> (P.char 'n' >> return DBusInt16)-                <|> (P.char 'i' >> return DBusInt32)-                <|> (P.char 'x' >> return DBusInt64)-                <|> (P.char 'q' >> return DBusWord16)-                <|> (P.char 'u' >> return DBusWord32)-                <|> (P.char 't' >> return DBusWord64)-                <|> (P.char 'd' >> return DBusDouble)-                <|> (P.char 's' >> return DBusString)-                <|> (P.char 'g' >> return DBusSignature)-                <|> (P.char 'o' >> return DBusObjectPath)+         parseArray = do                 P.char 'a'-                parseDict <|> do-                t <- parseType-                return $ DBusArray t+                parseDict <|> fmap DBusArray parseType         parseDict = do                 P.char '{'                 keyType <- parseAtom                 valueType <- parseType                 P.char '}'                 return $ DBusDictionary keyType valueType+         parseStruct = do                 P.char '('                 types <- P.many parseType                 P.char ')'                 return $ DBusStructure types +        parseAtom =+                    (P.char 'b' >> return DBusBoolean)+                <|> (P.char 'y' >> return DBusByte)+                <|> (P.char 'n' >> return DBusInt16)+                <|> (P.char 'i' >> return DBusInt32)+                <|> (P.char 'x' >> return DBusInt64)+                <|> (P.char 'q' >> return DBusWord16)+                <|> (P.char 'u' >> return DBusWord32)+                <|> (P.char 't' >> return DBusWord64)+                <|> (P.char 'd' >> return DBusDouble)+                <|> (P.char 's' >> return DBusString)+                <|> (P.char 'g' >> return DBusSignature)+                <|> (P.char 'o' >> return DBusObjectPath)++        parsed = case TL.length text of+                0 -> Just $ Signature []+                1 -> fast+                _ -> slow+ mkSignature_ :: Text -> Signature mkSignature_ = mkUnsafe "signature" mkSignature  instance String.IsString Signature where         fromString = mkSignature_ . TL.pack -instance Builtin ObjectPath where                 { builtinDBusType _ = DBusObjectPath };         instance Variable ObjectPath where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable ObjectPath where                 { toVariant = VarBoxObjectPath                 ; fromVariant (VarBoxObjectPath x) = Just x                 ; fromVariant _ = Nothing                 } newtype ObjectPath = ObjectPath         { strObjectPath :: Text         }-        deriving (Eq, Ord, Typeable)+        deriving (Eq, Ord)  instance Show ObjectPath where         showsPrec d (ObjectPath x) = showParen (d > 10) $@@ -344,14 +414,11 @@ mkObjectPath_ :: Text -> ObjectPath mkObjectPath_ = mkUnsafe "object path" mkObjectPath -instance Variable Array where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Array where                 { toVariant = VarBoxArray                 ; fromVariant (VarBoxArray x) = Just x                 ; fromVariant _ = Nothing                 } data Array         = VariantArray Type [Variant]         | ByteArray ByteString-        deriving (Eq, Typeable)--instance Builtin Array where-        builtinDBusType = DBusArray . arrayType+        deriving (Eq)  -- | This is the type contained within the array, not the type of the array -- itself.@@ -369,13 +436,11 @@                 s "Array " . showSig . s " [" . s valueString . s "]" where                         s = showString                         showSig = shows . typeCode . arrayType $ array-                        vs = [show x | (Variant x) <- arrayItems array]-                        valueString = intercalate ", " vs+                        showVar var = showsPrecVar 0 var ""+                        valueString = intercalate ", " $ map showVar $ arrayItems array  arrayFromItems :: Type -> [Variant] -> Maybe Array-arrayFromItems DBusByte vs = do-        bytes <- mapM fromVariant vs-        Just . ByteArray . ByteString.pack $ bytes+arrayFromItems DBusByte vs = fmap (ByteArray . ByteString.pack) (mapM fromVariant vs)  arrayFromItems t vs = do         mkSignature (typeCode t)@@ -406,16 +471,13 @@                 chunks <- ByteString.toChunks `fmap` fromVariant x                 return $ StrictByteString.concat chunks -instance Variable Dictionary where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Dictionary where                 { toVariant = VarBoxDictionary                 ; fromVariant (VarBoxDictionary x) = Just x                 ; fromVariant _ = Nothing                 } data Dictionary = Dictionary         { dictionaryKeyType   :: Type         , dictionaryValueType :: Type         , dictionaryItems     :: [(Variant, Variant)]         }-        deriving (Eq, Typeable)--instance Builtin Dictionary where-        builtinDBusType (Dictionary kt vt _) = DBusDictionary kt vt+        deriving (Eq)  instance Show Dictionary where         showsPrec d (Dictionary kt vt pairs) = showParen (d > 10) $@@ -423,8 +485,7 @@                         s = showString                         showSig = shows $ TL.append (typeCode kt) (typeCode vt)                         valueString = intercalate ", " $ map showPair pairs-                        showPair ((Variant k), (Variant v)) =-                                show k ++ " -> " ++ show v+                        showPair (k, v) = (showsPrecVar 0 k . showString " -> " . showsPrecVar 0 v) ""  dictionaryFromItems :: Type -> Type -> [(Variant, Variant)] -> Maybe Dictionary dictionaryFromItems kt vt pairs = do@@ -471,12 +532,9 @@         pairs <- mapM toPair $ arrayItems array         dictionaryFromItems kt vt pairs -instance Variable Structure where                 { toVariant = Variant                 ; fromVariant (Variant x) = cast x };+instance Variable Structure where                 { toVariant = VarBoxStructure                 ; fromVariant (VarBoxStructure x) = Just x                 ; fromVariant _ = Nothing                 } data Structure = Structure [Variant]-        deriving (Show, Eq, Typeable)--instance Builtin Structure where-        builtinDBusType (Structure vs) = DBusStructure $ map variantType vs+        deriving (Show, Eq)   

@@ -26,4 +26,6 @@                   , unmarshalMessage ) where import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal 

@@ -15,42 +15,8 @@   along with this program.  If not, see <http://www.gnu.org/licenses/>. -} -{-# LANGUAGE OverloadedStrings #-}--{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE BangPatterns #-}- module DBus.Wire.Internal where-import Data.Text.Lazy (Text)-import qualified Data.Text.Lazy as TL--import qualified Control.Monad.State as ST-import qualified Control.Monad.Error as E-import qualified Data.ByteString.Lazy as L-import qualified Data.Binary.Builder as B--import qualified Data.Binary.Get as G--import Data.Binary.Put (runPut)-import qualified Data.Binary.IEEE754 as IEEE--import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)-import Data.Text.Encoding.Error (UnicodeException)-import qualified Control.Exception as Exc-import System.IO.Unsafe (unsafePerformIO)--import qualified DBus.Constants as C--import qualified DBus.Message.Internal as M--import Data.Bits ((.|.), (.&.))-import qualified Data.Set as Set--import Control.Monad (when, unless)-import Data.Maybe (fromJust, listToMaybe, fromMaybe)-import Data.Word (Word8, Word32, Word64)-import Data.Int (Int16, Int32, Int64)-+import Data.Word (Word8, Word64) import qualified DBus.Types as T  data Endianness = LittleEndian | BigEndian@@ -98,579 +64,4 @@         required = if missing > 0                 then count' - missing                 else 0--data MarshalState = MarshalState Endianness B.Builder !Word64-newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a)-        deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)-type Marshal = MarshalM ()--runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString-runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of-        (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)-        (Left  x, _) -> Left x-        where initialState = MarshalState e B.empty 0--marshal :: T.Variant -> Marshal-marshal v = marshalType (T.variantType v) where-        x :: T.Variable a => a-        x = fromJust . T.fromVariant $ v-        marshalType :: T.Type -> Marshal-        marshalType T.DBusByte   = append $ L.singleton x-        marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x-        marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x-        marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x-        marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)-        marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)-        marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)--        marshalType T.DBusDouble = do-                pad 8-                (MarshalState e _ _) <- ST.get-                let put = case e of-                        BigEndian -> IEEE.putFloat64be-                        LittleEndian -> IEEE.putFloat64le-                let bytes = runPut $ put x-                append bytes--        marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0--        marshalType T.DBusString = marshalText x-        marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x--        marshalType T.DBusSignature = marshalSignature x--        marshalType (T.DBusArray _) = marshalArray x--        marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)--        marshalType (T.DBusStructure _) = do-                let T.Structure vs = x-                pad 8-                mapM_ marshal vs--        marshalType T.DBusVariant = do-                let rawSig = T.typeCode . T.variantType $ x-                sig <- case T.mkSignature rawSig of-                        Just x' -> return x'-                        Nothing -> E.throwError $ InvalidVariantSignature rawSig-                marshalSignature sig-                marshal x---append :: L.ByteString -> Marshal-append bytes = do-        (MarshalState e builder count) <- ST.get-        let builder' = B.append builder $ B.fromLazyByteString bytes-            count' = count + (fromIntegral $ L.length bytes)-        ST.put $ MarshalState e builder' count'--pad :: Word8 -> Marshal-pad count = do-        (MarshalState _ _ existing) <- ST.get-        let padding' = fromIntegral $ padding existing count-        append $ L.replicate padding' 0--marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal-marshalBuilder size be le x = do-        pad size-        (MarshalState e builder count) <- ST.get-        let builder' = B.append builder $ case e of-                BigEndian -> be x-                LittleEndian -> le x-        let count' = count + (fromIntegral size)-        ST.put $ MarshalState e builder' count'--data MarshalError-        = MessageTooLong Word64-        | ArrayTooLong Word64-        | InvalidBodySignature Text-        | InvalidVariantSignature Text-        | InvalidText Text-        deriving (Eq)--instance Show MarshalError where-        show (MessageTooLong x) = concat-                ["Message too long (", show x, " bytes)."]-        show (ArrayTooLong x) = concat-                ["Array too long (", show x, " bytes)."]-        show (InvalidBodySignature x) = concat-                ["Invalid body signature: ", show x]-        show (InvalidVariantSignature x) = concat-                ["Invalid variant signature: ", show x]-        show (InvalidText x) = concat-                ["Text cannot be marshaled: ", show x]--instance E.Error MarshalError--data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64-newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a)-        deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState)--runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a-runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where-        state = UnmarshalState e bytes 0--unmarshal :: T.Signature -> Unmarshal [T.Variant]-unmarshal = mapM unmarshalType . T.signatureTypes--unmarshalType :: T.Type -> Unmarshal T.Variant-unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1-unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le-unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le-unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le--unmarshalType T.DBusInt16  = do-        x <- unmarshalGet 2 G.getWord16be G.getWord16le-        return . T.toVariant $ (fromIntegral x :: Int16)--unmarshalType T.DBusInt32  = do-        x <- unmarshalGet 4 G.getWord32be G.getWord32le-        return . T.toVariant $ (fromIntegral x :: Int32)--unmarshalType T.DBusInt64  = do-        x <- unmarshalGet 8 G.getWord64be G.getWord64le-        return . T.toVariant $ (fromIntegral x :: Int64)--unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le--unmarshalType T.DBusBoolean = unmarshalWord32 >>=-        fromMaybeU' "boolean" (\x -> case x of-                0 -> Just False-                1 -> Just True-                _ -> Nothing)--unmarshalType T.DBusString = fmap T.toVariant unmarshalText--unmarshalType T.DBusObjectPath = unmarshalText >>=-        fromMaybeU' "object path" T.mkObjectPath--unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature--unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t--unmarshalType (T.DBusDictionary kt vt) = do-        let pairType = T.DBusStructure [kt, vt]-        array <- unmarshalArray pairType-        fromMaybeU' "dictionary" T.arrayToDictionary array--unmarshalType (T.DBusStructure ts) = do-        skipPadding 8-        fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts--unmarshalType T.DBusVariant = do-        let getType sig = case T.signatureTypes sig of-                [t] -> Just t-                _   -> Nothing-        -        t <- fromMaybeU "variant signature" getType =<< unmarshalSignature-        T.toVariant `fmap` unmarshalType t---consume :: Word64 -> Unmarshal L.ByteString-consume count = do-        (UnmarshalState e bytes offset) <- ST.get-        let (x, bytes') = L.splitAt (fromIntegral count) bytes-        unless (L.length x == fromIntegral count) $-                E.throwError $ UnexpectedEOF offset-        -        ST.put $ UnmarshalState e bytes' (offset + count)-        return x--skipPadding :: Word8 -> Unmarshal ()-skipPadding count = do-        (UnmarshalState _ _ offset) <- ST.get-        bytes <- consume $ padding offset count-        unless (L.all (== 0) bytes) $-                E.throwError $ InvalidPadding offset--skipTerminator :: Unmarshal ()-skipTerminator = do-        (UnmarshalState _ _ offset) <- ST.get-        bytes <- consume 1-        unless (L.all (== 0) bytes) $-                E.throwError $ MissingTerminator offset--fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b-fromMaybeU label f x = case f x of-        Just x' -> return x'-        Nothing -> E.throwError . Invalid label . TL.pack . show $ x--fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a-           -> Unmarshal T.Variant-fromMaybeU' label f x = do-        x' <- fromMaybeU label f x-        return $ T.toVariant x'--unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a-unmarshalGet count be le = do-        skipPadding count-        (UnmarshalState e _ _) <- ST.get-        bs <- consume . fromIntegral $ count-        let get' = case e of-                BigEndian -> be-                LittleEndian -> le-        return $ G.runGet get' bs--unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a-              -> Unmarshal T.Variant-unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le--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--data UnmarshalError-        = UnsupportedProtocolVersion Word8-        | UnexpectedEOF Word64-        | Invalid Text Text-        | MissingHeaderField Text-        | InvalidHeaderField Text T.Variant-        | InvalidPadding Word64-        | MissingTerminator Word64-        | ArraySizeMismatch-        deriving (Eq)--instance Show UnmarshalError where-        show (UnsupportedProtocolVersion x) = concat-                ["Unsupported protocol version: ", show x]-        show (UnexpectedEOF pos) = concat-                ["Unexpected EOF at position ", show pos]-        show (Invalid label x) = TL.unpack $ TL.concat-                ["Invalid ", label, ": ", x]-        show (MissingHeaderField x) = concat-                ["Required field " , show x , " is missing."]-        show (InvalidHeaderField x got) = concat-                [ "Invalid header field ", show x, ": ", show got]-        show (InvalidPadding pos) = concat-                ["Invalid padding at position ", show pos]-        show (MissingTerminator pos) = concat-                ["Missing NUL terminator at position ", show pos]-        show ArraySizeMismatch = "Array size mismatch"--instance E.Error UnmarshalError--marshalWord32 :: Word32 -> Marshal-marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le--unmarshalWord32 :: Unmarshal Word32-unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le--excToMaybe :: a -> Maybe a-excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError--unicodeError :: UnicodeException -> IO (Maybe a)-unicodeError = const $ return Nothing--maybeEncodeUtf8 :: Text -> Maybe L.ByteString-maybeEncodeUtf8 = excToMaybe . encodeUtf8--maybeDecodeUtf8 :: L.ByteString -> Maybe Text-maybeDecodeUtf8 = excToMaybe . decodeUtf8--marshalText :: Text -> Marshal-marshalText x = do-        bytes <- case maybeEncodeUtf8 x of-                Just x' -> return x'-                Nothing -> E.throwError $ InvalidText x-        when (L.any (== 0) bytes) $-                E.throwError $ InvalidText x-        marshalWord32 . fromIntegral . L.length $ bytes-        append bytes-        append (L.singleton 0)--unmarshalText :: Unmarshal Text-unmarshalText = do-        byteCount <- unmarshalWord32-        bytes <- consume . fromIntegral $ byteCount-        skipTerminator-        fromMaybeU "text" maybeDecodeUtf8 bytes--marshalSignature :: T.Signature -> Marshal-marshalSignature x = do-        let bytes = encodeUtf8 . T.strSignature $ x-        let size = fromIntegral . L.length $ bytes-        append (L.singleton size)-        append bytes-        append (L.singleton 0)--unmarshalSignature :: Unmarshal T.Signature-unmarshalSignature = do-        byteCount <- L.head `fmap` consume 1-        bytes <- consume $ fromIntegral byteCount-        sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes-        skipTerminator-        fromMaybeU "signature" T.mkSignature sigText--marshalArray :: T.Array -> Marshal-marshalArray x = do-        (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x-        let arrayLen = L.length arrayBytes-        when (arrayLen > fromIntegral C.arrayMaximumLength)-                (E.throwError $ ArrayTooLong $ fromIntegral arrayLen)-        marshalWord32 $ fromIntegral arrayLen-        append $ L.replicate arrayPadding 0-        append arrayBytes--getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)-getArrayBytes T.DBusByte x = return (0, bytes) where-        Just bytes = T.arrayToBytes x--getArrayBytes itemType x = do-        let vs = T.arrayItems x-        s <- ST.get-        (MarshalState _ _ afterLength) <- marshalWord32 0 >> ST.get-        (MarshalState e _ afterPadding) <- pad (alignment itemType) >> ST.get-        -        ST.put $ MarshalState e B.empty afterPadding-        (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> ST.get-        -        let itemBytes = B.toLazyByteString itemBuilder-            paddingSize = fromIntegral $ afterPadding - afterLength-        -        ST.put s-        return (paddingSize, itemBytes)--unmarshalArray :: T.Type -> Unmarshal T.Array-unmarshalArray T.DBusByte = do-        byteCount <- unmarshalWord32-        T.arrayFromBytes `fmap` consume (fromIntegral byteCount)--unmarshalArray itemType = do-        let getOffset = do-                (UnmarshalState _ _ o) <- ST.get-                return o-        byteCount <- unmarshalWord32-        skipPadding (alignment itemType)-        start <- getOffset-        let end = start + fromIntegral byteCount-        vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)-        end' <- getOffset-        when (end' > end) $-                E.throwError ArraySizeMismatch-        fromMaybeU "array" (T.arrayFromItems itemType) vs--encodeFlags :: Set.Set M.Flag -> Word8-encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where-        flagValue M.NoReplyExpected = 0x1-        flagValue M.NoAutoStart     = 0x2--decodeFlags :: Word8 -> Set.Set M.Flag-decodeFlags word = Set.fromList flags where-        flagSet = [ (0x1, M.NoReplyExpected)-                  , (0x2, M.NoAutoStart)-                  ]-        flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]--encodeField :: M.HeaderField -> T.Structure-encodeField (M.Path x)        = encodeField' 1 x-encodeField (M.Interface x)   = encodeField' 2 x-encodeField (M.Member x)      = encodeField' 3 x-encodeField (M.ErrorName x)   = encodeField' 4 x-encodeField (M.ReplySerial x) = encodeField' 5 x-encodeField (M.Destination x) = encodeField' 6 x-encodeField (M.Sender x)      = encodeField' 7 x-encodeField (M.Signature x)   = encodeField' 8 x--encodeField' :: T.Variable a => Word8 -> a -> T.Structure-encodeField' code x = T.Structure-        [ T.toVariant code-        , T.toVariant $ T.toVariant x-        ]--decodeField :: Monad m => T.Structure-            -> E.ErrorT UnmarshalError m [M.HeaderField]-decodeField struct = case unpackField struct of-        (1, x) -> decodeField' x M.Path "path"-        (2, x) -> decodeField' x M.Interface "interface"-        (3, x) -> decodeField' x M.Member "member"-        (4, x) -> decodeField' x M.ErrorName "error name"-        (5, x) -> decodeField' x M.ReplySerial "reply serial"-        (6, x) -> decodeField' x M.Destination "destination"-        (7, x) -> decodeField' x M.Sender "sender"-        (8, x) -> decodeField' x M.Signature "signature"-        _      -> return []--decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text-             -> E.ErrorT UnmarshalError m [b]-decodeField' x f label = case T.fromVariant x of-        Just x' -> return [f x']-        Nothing -> E.throwError $ InvalidHeaderField label x--unpackField :: T.Structure -> (Word8, T.Variant)-unpackField struct = (c', v') where-        T.Structure [c, v] = struct-        c' = fromJust . T.fromVariant $ c-        v' = fromJust . T.fromVariant $ v---- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is--- possible for marshaling to fail -- if this occurs, an appropriate error--- will be returned instead.--marshalMessage :: M.Message a => Endianness -> M.Serial -> a-               -> Either MarshalError L.ByteString-marshalMessage e serial msg = runMarshal marshaler e where-        body = M.messageBody msg-        marshaler = do-                sig <- checkBodySig body-                empty <- ST.get-                mapM_ marshal body-                (MarshalState _ bodyBytesB _) <- ST.get-                ST.put empty-                marshalEndianness e-                let bodyBytes = B.toLazyByteString bodyBytesB-                marshalHeader msg serial sig-                        $ fromIntegral . L.length $ bodyBytes-                pad 8-                append bodyBytes-                checkMaximumSize--checkBodySig :: [T.Variant] -> MarshalM T.Signature-checkBodySig vs = let-        sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs-        invalid = E.throwError $ InvalidBodySignature sigStr-        in case T.mkSignature sigStr of-                Just x -> return x-                Nothing -> invalid--marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32-              -> Marshal-marshalHeader msg serial bodySig bodyLength = do-        let fields = M.Signature bodySig : M.messageHeaderFields msg-        marshal . T.toVariant . M.messageTypeCode $ msg-        marshal . T.toVariant . encodeFlags . M.messageFlags $ msg-        marshal . T.toVariant $ C.protocolVersion-        marshalWord32 bodyLength-        marshal . T.toVariant $ serial-        let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]-        marshal . T.toVariant . fromJust . T.toArray fieldType-                $ map encodeField fields--marshalEndianness :: Endianness -> Marshal-marshalEndianness = marshal . T.toVariant . encodeEndianness--checkMaximumSize :: Marshal-checkMaximumSize = do-        (MarshalState _ _ messageLength) <- ST.get-        when (messageLength > fromIntegral C.messageMaximumLength)-                (E.throwError $ MessageTooLong $ fromIntegral messageLength)---- | Read bytes from a monad until a complete message has been received.-unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)-                 -> m (Either UnmarshalError M.ReceivedMessage)-unmarshalMessage getBytes' = E.runErrorT $ do-        let getBytes = E.lift . getBytes'-        -        let fixedSig = "yyyyuuu"-        fixedBytes <- getBytes 16--        let messageVersion = L.index fixedBytes 3-        when (messageVersion /= C.protocolVersion) $-                E.throwError $ UnsupportedProtocolVersion messageVersion--        let eByte = L.index fixedBytes 0-        endianness <- case decodeEndianness eByte of-                Just x' -> return x'-                Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte--        let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of-                Right x' -> return x'-                Left  e  -> E.throwError e-        fixed <- unmarshal' fixedSig fixedBytes-        let typeCode = fromJust . T.fromVariant $ fixed !! 1-        let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2-        let bodyLength = fromJust . T.fromVariant $ fixed !! 4-        let serial = fromJust . T.fromVariant $ fixed !! 5--        let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6--        let headerSig  = "yyyyuua(yv)"-        fieldBytes <- getBytes fieldByteCount-        let headerBytes = L.append fixedBytes fieldBytes-        header <- unmarshal' headerSig headerBytes--        let fieldArray = fromJust . T.fromVariant $ header !! 6-        let fieldStructures = fromJust . T.fromArray $ fieldArray-        fields <- concat `fmap` mapM decodeField fieldStructures--        let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8-        getBytes . fromIntegral $ bodyPadding--        let bodySig = findBodySignature fields--        bodyBytes <- getBytes bodyLength-        body <- unmarshal' bodySig bodyBytes--        y <- case buildReceivedMessage typeCode fields of-                EitherM (Right x) -> return x-                EitherM (Left x) -> E.throwError $ MissingHeaderField x--        return $ y serial flags body---findBodySignature :: [M.HeaderField] -> T.Signature-findBodySignature fields = fromMaybe "" signature where-        signature = listToMaybe [x | M.Signature x <- fields]--newtype EitherM a b = EitherM (Either a b)--instance Monad (EitherM a) where-        return = EitherM . Right-        (EitherM (Left x)) >>= _ = EitherM (Left x)-        (EitherM (Right x)) >>= k = k x--buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text-                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]-                         -> M.ReceivedMessage)--buildReceivedMessage 1 fields = do-        path <- require "path" [x | M.Path x <- fields]-        member <- require "member name" [x | M.Member x <- fields]-        return $ \serial flags body -> let-                iface = listToMaybe [x | M.Interface x <- fields]-                dest = listToMaybe [x | M.Destination x <- fields]-                sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.MethodCall path member iface dest flags body-                in M.ReceivedMethodCall serial sender msg--buildReceivedMessage 2 fields = do-        replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-        return $ \serial _ body -> let-                dest = listToMaybe [x | M.Destination x <- fields]-                sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.MethodReturn replySerial dest body-                in M.ReceivedMethodReturn serial sender msg--buildReceivedMessage 3 fields = do-        name <- require "error name" [x | M.ErrorName x <- fields]-        replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]-        return $ \serial _ body -> let-                dest = listToMaybe [x | M.Destination x <- fields]-                sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.Error name replySerial dest body-                in M.ReceivedError serial sender msg--buildReceivedMessage 4 fields = do-        path <- require "path" [x | M.Path x <- fields]-        member <- require "member name" [x | M.Member x <- fields]-        iface <- require "interface" [x | M.Interface x <- fields]-        return $ \serial _ body -> let-                dest = listToMaybe [x | M.Destination x <- fields]-                sender = listToMaybe [x | M.Sender x <- fields]-                msg = M.Signal path member iface dest body-                in M.ReceivedSignal serial sender msg--buildReceivedMessage typeCode fields = return $ \serial flags body -> let-        sender = listToMaybe [x | M.Sender x <- fields]-        msg = M.Unknown typeCode flags body-        in M.ReceivedUnknown serial sender msg--require :: Text -> [a] -> EitherM Text a-require _     (x:_) = return x-require label _     = EitherM $ Left label 

@@ -0,0 +1,276 @@+{-+  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 GeneralizedNewtypeDeriving #-}+module DBus.Wire.Marshal where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++import qualified Control.Monad.State as State+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Lazy as L+import qualified Data.Binary.Builder as B++import Data.Binary.Put (runPut)+import qualified Data.Binary.IEEE754 as IEEE++import DBus.Wire.Unicode (maybeEncodeUtf8)++import Data.Text.Lazy.Encoding (encodeUtf8)++import qualified DBus.Constants as C++import qualified DBus.Message.Internal as M++import Data.Bits ((.|.))+import qualified Data.Set as Set++import DBus.Wire.Internal+import Control.Monad (when)+import Data.Maybe (fromJust)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import qualified DBus.Types as T++data MarshalState = MarshalState Endianness B.Builder !Word64+newtype MarshalM a = MarshalM (E.ErrorT MarshalError (State.State MarshalState) a)+        deriving (Monad, E.MonadError MarshalError, State.MonadState MarshalState)+type Marshal = MarshalM ()++runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString+runMarshal (MarshalM m) e = case State.runState (E.runErrorT m) initialState of+        (Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder)+        (Left  x, _) -> Left x+        where initialState = MarshalState e B.empty 0++marshal :: T.Variant -> Marshal+marshal v = marshalType (T.variantType v) where+        x :: T.Variable a => a+        x = fromJust . T.fromVariant $ v+        marshalType :: T.Type -> Marshal+        marshalType T.DBusByte   = append $ L.singleton x+        marshalType T.DBusWord16 = marshalBuilder 2 B.putWord16be B.putWord16le x+        marshalType T.DBusWord32 = marshalBuilder 4 B.putWord32be B.putWord32le x+        marshalType T.DBusWord64 = marshalBuilder 8 B.putWord64be B.putWord64le x+        marshalType T.DBusInt16  = marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral (x :: Int16)+        marshalType T.DBusInt32  = marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral (x :: Int32)+        marshalType T.DBusInt64  = marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral (x :: Int64)++        marshalType T.DBusDouble = do+                pad 8+                (MarshalState e _ _) <- State.get+                let put = case e of+                        BigEndian -> IEEE.putFloat64be+                        LittleEndian -> IEEE.putFloat64le+                let bytes = runPut $ put x+                append bytes++        marshalType T.DBusBoolean = marshalWord32 $ if x then 1 else 0++        marshalType T.DBusString = marshalText x+        marshalType T.DBusObjectPath = marshalText . T.strObjectPath $ x++        marshalType T.DBusSignature = marshalSignature x++        marshalType (T.DBusArray _) = marshalArray x++        marshalType (T.DBusDictionary _ _) = marshalArray (T.dictionaryToArray x)++        marshalType (T.DBusStructure _) = do+                let T.Structure vs = x+                pad 8+                mapM_ marshal vs++        marshalType T.DBusVariant = do+                let rawSig = T.typeCode . T.variantType $ x+                sig <- case T.mkSignature rawSig of+                        Just x' -> return x'+                        Nothing -> E.throwError $ InvalidVariantSignature rawSig+                marshalSignature sig+                marshal x+++append :: L.ByteString -> Marshal+append bytes = do+        (MarshalState e builder count) <- State.get+        let builder' = B.append builder $ B.fromLazyByteString bytes+            count' = count + fromIntegral (L.length bytes)+        State.put $ MarshalState e builder' count'++pad :: Word8 -> Marshal+pad count = do+        (MarshalState _ _ existing) <- State.get+        let padding' = fromIntegral $ padding existing count+        append $ L.replicate padding' 0++marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal+marshalBuilder size be le x = do+        pad size+        (MarshalState e builder count) <- State.get+        let builder' = B.append builder $ case e of+                BigEndian -> be x+                LittleEndian -> le x+        let count' = count + fromIntegral size+        State.put $ MarshalState e builder' count'++data MarshalError+        = MessageTooLong Word64+        | ArrayTooLong Word64+        | InvalidBodySignature Text+        | InvalidVariantSignature Text+        | InvalidText Text+        deriving (Eq)++instance Show MarshalError where+        show (MessageTooLong x) = concat+                ["Message too long (", show x, " bytes)."]+        show (ArrayTooLong x) = concat+                ["Array too long (", show x, " bytes)."]+        show (InvalidBodySignature x) = concat+                ["Invalid body signature: ", show x]+        show (InvalidVariantSignature x) = concat+                ["Invalid variant signature: ", show x]+        show (InvalidText x) = concat+                ["Text cannot be marshaled: ", show x]++instance E.Error MarshalError++marshalWord32 :: Word32 -> Marshal+marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le++marshalText :: Text -> Marshal+marshalText x = do+        bytes <- case maybeEncodeUtf8 x of+                Just x' -> return x'+                Nothing -> E.throwError $ InvalidText x+        when (L.any (== 0) bytes) $+                E.throwError $ InvalidText x+        marshalWord32 . fromIntegral . L.length $ bytes+        append bytes+        append (L.singleton 0)++marshalSignature :: T.Signature -> Marshal+marshalSignature x = do+        let bytes = encodeUtf8 . T.strSignature $ x+        let size = fromIntegral . L.length $ bytes+        append (L.singleton size)+        append bytes+        append (L.singleton 0)++marshalArray :: T.Array -> Marshal+marshalArray x = do+        (arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x+        let arrayLen = L.length arrayBytes+        when (arrayLen > fromIntegral C.arrayMaximumLength)+                (E.throwError $ ArrayTooLong $ fromIntegral arrayLen)+        marshalWord32 $ fromIntegral arrayLen+        append $ L.replicate arrayPadding 0+        append arrayBytes++getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)+getArrayBytes T.DBusByte x = return (0, bytes) where+        Just bytes = T.arrayToBytes x++getArrayBytes itemType x = do+        let vs = T.arrayItems x+        s <- State.get+        (MarshalState _ _ afterLength) <- marshalWord32 0 >> State.get+        (MarshalState e _ afterPadding) <- pad (alignment itemType) >> State.get+        +        State.put $ MarshalState e B.empty afterPadding+        (MarshalState _ itemBuilder _) <- mapM_ marshal vs >> State.get+        +        let itemBytes = B.toLazyByteString itemBuilder+            paddingSize = fromIntegral $ afterPadding - afterLength+        +        State.put s+        return (paddingSize, itemBytes)++encodeFlags :: Set.Set M.Flag -> Word8+encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where+        flagValue M.NoReplyExpected = 0x1+        flagValue M.NoAutoStart     = 0x2++encodeField :: M.HeaderField -> T.Structure+encodeField (M.Path x)        = encodeField' 1 x+encodeField (M.Interface x)   = encodeField' 2 x+encodeField (M.Member x)      = encodeField' 3 x+encodeField (M.ErrorName x)   = encodeField' 4 x+encodeField (M.ReplySerial x) = encodeField' 5 x+encodeField (M.Destination x) = encodeField' 6 x+encodeField (M.Sender x)      = encodeField' 7 x+encodeField (M.Signature x)   = encodeField' 8 x++encodeField' :: T.Variable a => Word8 -> a -> T.Structure+encodeField' code x = T.Structure+        [ T.toVariant code+        , T.toVariant $ T.toVariant x+        ]++-- | Convert a 'M.Message' into a 'L.ByteString'. Although unusual, it is+-- possible for marshaling to fail -- if this occurs, an appropriate error+-- will be returned instead.++marshalMessage :: M.Message a => Endianness -> M.Serial -> a+               -> Either MarshalError L.ByteString+marshalMessage e serial msg = runMarshal marshaler e where+        body = M.messageBody msg+        marshaler = do+                sig <- checkBodySig body+                empty <- State.get+                mapM_ marshal body+                (MarshalState _ bodyBytesB _) <- State.get+                State.put empty+                marshalEndianness e+                let bodyBytes = B.toLazyByteString bodyBytesB+                marshalHeader msg serial sig+                        $ fromIntegral . L.length $ bodyBytes+                pad 8+                append bodyBytes+                checkMaximumSize++checkBodySig :: [T.Variant] -> MarshalM T.Signature+checkBodySig vs = let+        sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs+        invalid = E.throwError $ InvalidBodySignature sigStr+        in case T.mkSignature sigStr of+                Just x -> return x+                Nothing -> invalid++marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32+              -> Marshal+marshalHeader msg serial bodySig bodyLength = do+        let fields = M.Signature bodySig : M.messageHeaderFields msg+        marshal . T.toVariant . M.messageTypeCode $ msg+        marshal . T.toVariant . encodeFlags . M.messageFlags $ msg+        marshal . T.toVariant $ C.protocolVersion+        marshalWord32 bodyLength+        marshal . T.toVariant $ serial+        let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]+        marshal . T.toVariant . fromJust . T.toArray fieldType+                $ map encodeField fields++marshalEndianness :: Endianness -> Marshal+marshalEndianness = marshal . T.toVariant . encodeEndianness++checkMaximumSize :: Marshal+checkMaximumSize = do+        (MarshalState _ _ messageLength) <- State.get+        when (messageLength > fromIntegral C.messageMaximumLength)+                (E.throwError $ MessageTooLong $ fromIntegral messageLength)+

@@ -0,0 +1,39 @@+{-+  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 DBus.Wire.Unicode+        ( maybeEncodeUtf8+        , maybeDecodeUtf8) where+import Data.ByteString.Lazy (ByteString)+import Data.Text.Lazy (Text)+import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)+import Data.Text.Encoding.Error (UnicodeException)+import qualified Control.Exception as Exc+import System.IO.Unsafe (unsafePerformIO)++excToMaybe :: a -> Maybe a+excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError++unicodeError :: UnicodeException -> IO (Maybe a)+unicodeError = const $ return Nothing++maybeEncodeUtf8 :: Text -> Maybe ByteString+maybeEncodeUtf8 = excToMaybe . encodeUtf8++maybeDecodeUtf8 :: ByteString -> Maybe Text+maybeDecodeUtf8 = excToMaybe . decodeUtf8+

@@ -0,0 +1,386 @@+{-+  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 OverloadedStrings #-}++{-# LANGUAGE GeneralizedNewtypeDeriving #-}+module DBus.Wire.Unmarshal where+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as TL++import qualified Control.Monad.State as State+import qualified Control.Monad.Error as E+import qualified Data.ByteString.Lazy as L++import qualified Data.Binary.Get as G++import qualified Data.Binary.IEEE754 as IEEE++import DBus.Wire.Unicode (maybeDecodeUtf8)++import qualified DBus.Message.Internal as M++import Data.Bits ((.&.))+import qualified Data.Set as Set++import qualified DBus.Constants as C++import Control.Monad (when, unless)+import Data.Maybe (fromJust, listToMaybe, fromMaybe)+import Data.Word (Word8, Word32, Word64)+import Data.Int (Int16, Int32, Int64)++import DBus.Wire.Internal+import qualified DBus.Types as T++data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64+newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (State.State UnmarshalState) a)+        deriving (Monad, Functor, E.MonadError UnmarshalError, State.MonadState UnmarshalState)++runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a+runUnmarshal (Unmarshal m) e bytes = State.evalState (E.runErrorT m) state where+        state = UnmarshalState e bytes 0++unmarshal :: T.Signature -> Unmarshal [T.Variant]+unmarshal = mapM unmarshalType . T.signatureTypes++unmarshalType :: T.Type -> Unmarshal T.Variant+unmarshalType T.DBusByte = fmap (T.toVariant . L.head) $ consume 1+unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le+unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le+unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le++unmarshalType T.DBusInt16  = do+        x <- unmarshalGet 2 G.getWord16be G.getWord16le+        return . T.toVariant $ (fromIntegral x :: Int16)++unmarshalType T.DBusInt32  = do+        x <- unmarshalGet 4 G.getWord32be G.getWord32le+        return . T.toVariant $ (fromIntegral x :: Int32)++unmarshalType T.DBusInt64  = do+        x <- unmarshalGet 8 G.getWord64be G.getWord64le+        return . T.toVariant $ (fromIntegral x :: Int64)++unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le++unmarshalType T.DBusBoolean = unmarshalWord32 >>=+        fromMaybeU' "boolean" (\x -> case x of+                0 -> Just False+                1 -> Just True+                _ -> Nothing)++unmarshalType T.DBusString = fmap T.toVariant unmarshalText++unmarshalType T.DBusObjectPath = unmarshalText >>=+        fromMaybeU' "object path" T.mkObjectPath++unmarshalType T.DBusSignature = fmap T.toVariant unmarshalSignature++unmarshalType (T.DBusArray t) = T.toVariant `fmap` unmarshalArray t++unmarshalType (T.DBusDictionary kt vt) = do+        let pairType = T.DBusStructure [kt, vt]+        array <- unmarshalArray pairType+        fromMaybeU' "dictionary" T.arrayToDictionary array++unmarshalType (T.DBusStructure ts) = do+        skipPadding 8+        fmap (T.toVariant . T.Structure) $ mapM unmarshalType ts++unmarshalType T.DBusVariant = do+        let getType sig = case T.signatureTypes sig of+                [t] -> Just t+                _   -> Nothing+        +        t <- fromMaybeU "variant signature" getType =<< unmarshalSignature+        T.toVariant `fmap` unmarshalType t+++consume :: Word64 -> Unmarshal L.ByteString+consume count = do+        (UnmarshalState e bytes offset) <- State.get+        let (x, bytes') = L.splitAt (fromIntegral count) bytes+        unless (L.length x == fromIntegral count) $+                E.throwError $ UnexpectedEOF offset+        +        State.put $ UnmarshalState e bytes' (offset + count)+        return x++skipPadding :: Word8 -> Unmarshal ()+skipPadding count = do+        (UnmarshalState _ _ offset) <- State.get+        bytes <- consume $ padding offset count+        unless (L.all (== 0) bytes) $+                E.throwError $ InvalidPadding offset++skipTerminator :: Unmarshal ()+skipTerminator = do+        (UnmarshalState _ _ offset) <- State.get+        bytes <- consume 1+        unless (L.all (== 0) bytes) $+                E.throwError $ MissingTerminator offset++fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b+fromMaybeU label f x = case f x of+        Just x' -> return x'+        Nothing -> E.throwError . Invalid label . TL.pack . show $ x++fromMaybeU' :: (Show a, T.Variable b) => Text -> (a -> Maybe b) -> a+           -> Unmarshal T.Variant+fromMaybeU' label f x = do+        x' <- fromMaybeU label f x+        return $ T.toVariant x'++unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a+unmarshalGet count be le = do+        skipPadding count+        (UnmarshalState e _ _) <- State.get+        bs <- consume . fromIntegral $ count+        let get' = case e of+                BigEndian -> be+                LittleEndian -> le+        return $ G.runGet get' bs++unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a+              -> Unmarshal T.Variant+unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le++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++data UnmarshalError+        = UnsupportedProtocolVersion Word8+        | UnexpectedEOF Word64+        | Invalid Text Text+        | MissingHeaderField Text+        | InvalidHeaderField Text T.Variant+        | InvalidPadding Word64+        | MissingTerminator Word64+        | ArraySizeMismatch+        deriving (Eq)++instance Show UnmarshalError where+        show (UnsupportedProtocolVersion x) = concat+                ["Unsupported protocol version: ", show x]+        show (UnexpectedEOF pos) = concat+                ["Unexpected EOF at position ", show pos]+        show (Invalid label x) = TL.unpack $ TL.concat+                ["Invalid ", label, ": ", x]+        show (MissingHeaderField x) = concat+                ["Required field " , show x , " is missing."]+        show (InvalidHeaderField x got) = concat+                [ "Invalid header field ", show x, ": ", show got]+        show (InvalidPadding pos) = concat+                ["Invalid padding at position ", show pos]+        show (MissingTerminator pos) = concat+                ["Missing NUL terminator at position ", show pos]+        show ArraySizeMismatch = "Array size mismatch"++instance E.Error UnmarshalError++unmarshalWord32 :: Unmarshal Word32+unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le++unmarshalText :: Unmarshal Text+unmarshalText = do+        byteCount <- unmarshalWord32+        bytes <- consume . fromIntegral $ byteCount+        skipTerminator+        fromMaybeU "text" maybeDecodeUtf8 bytes++unmarshalSignature :: Unmarshal T.Signature+unmarshalSignature = do+        byteCount <- L.head `fmap` consume 1+        bytes <- consume $ fromIntegral byteCount+        sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes+        skipTerminator+        fromMaybeU "signature" T.mkSignature sigText++unmarshalArray :: T.Type -> Unmarshal T.Array+unmarshalArray T.DBusByte = do+        byteCount <- unmarshalWord32+        T.arrayFromBytes `fmap` consume (fromIntegral byteCount)++unmarshalArray itemType = do+        let getOffset = do+                (UnmarshalState _ _ o) <- State.get+                return o+        byteCount <- unmarshalWord32+        skipPadding (alignment itemType)+        start <- getOffset+        let end = start + fromIntegral byteCount+        vs <- untilM (fmap (>= end) getOffset) (unmarshalType itemType)+        end' <- getOffset+        when (end' > end) $+                E.throwError ArraySizeMismatch+        fromMaybeU "array" (T.arrayFromItems itemType) vs++decodeFlags :: Word8 -> Set.Set M.Flag+decodeFlags word = Set.fromList flags where+        flagSet = [ (0x1, M.NoReplyExpected)+                  , (0x2, M.NoAutoStart)+                  ]+        flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]++decodeField :: Monad m => T.Structure+            -> E.ErrorT UnmarshalError m [M.HeaderField]+decodeField struct = case unpackField struct of+        (1, x) -> decodeField' x M.Path "path"+        (2, x) -> decodeField' x M.Interface "interface"+        (3, x) -> decodeField' x M.Member "member"+        (4, x) -> decodeField' x M.ErrorName "error name"+        (5, x) -> decodeField' x M.ReplySerial "reply serial"+        (6, x) -> decodeField' x M.Destination "destination"+        (7, x) -> decodeField' x M.Sender "sender"+        (8, x) -> decodeField' x M.Signature "signature"+        _      -> return []++decodeField' :: (Monad m, T.Variable a) => T.Variant -> (a -> b) -> Text+             -> E.ErrorT UnmarshalError m [b]+decodeField' x f label = case T.fromVariant x of+        Just x' -> return [f x']+        Nothing -> E.throwError $ InvalidHeaderField label x++unpackField :: T.Structure -> (Word8, T.Variant)+unpackField struct = (c', v') where+        T.Structure [c, v] = struct+        c' = fromJust . T.fromVariant $ c+        v' = fromJust . T.fromVariant $ v++-- | Read bytes from a monad until a complete message has been received.++unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)+                 -> m (Either UnmarshalError M.ReceivedMessage)+unmarshalMessage getBytes' = E.runErrorT $ do+        let getBytes = E.lift . getBytes'+        +        let fixedSig = "yyyyuuu"+        fixedBytes <- getBytes 16++        let messageVersion = L.index fixedBytes 3+        when (messageVersion /= C.protocolVersion) $+                E.throwError $ UnsupportedProtocolVersion messageVersion++        let eByte = L.index fixedBytes 0+        endianness <- case decodeEndianness eByte of+                Just x' -> return x'+                Nothing -> E.throwError . Invalid "endianness" . TL.pack . show $ eByte++        let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of+                Right x' -> return x'+                Left  e  -> E.throwError e+        fixed <- unmarshal' fixedSig fixedBytes+        let typeCode = fromJust . T.fromVariant $ fixed !! 1+        let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2+        let bodyLength = fromJust . T.fromVariant $ fixed !! 4+        let serial = fromJust . T.fromVariant $ fixed !! 5++        let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6++        let headerSig  = "yyyyuua(yv)"+        fieldBytes <- getBytes fieldByteCount+        let headerBytes = L.append fixedBytes fieldBytes+        header <- unmarshal' headerSig headerBytes++        let fieldArray = fromJust . T.fromVariant $ header !! 6+        let fieldStructures = fromJust . T.fromArray $ fieldArray+        fields <- concat `fmap` mapM decodeField fieldStructures++        let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8+        getBytes . fromIntegral $ bodyPadding++        let bodySig = findBodySignature fields++        bodyBytes <- getBytes bodyLength+        body <- unmarshal' bodySig bodyBytes++        y <- case buildReceivedMessage typeCode fields of+                EitherM (Right x) -> return x+                EitherM (Left x) -> E.throwError $ MissingHeaderField x++        return $ y serial flags body+++findBodySignature :: [M.HeaderField] -> T.Signature+findBodySignature fields = fromMaybe "" signature where+        signature = listToMaybe [x | M.Signature x <- fields]++newtype EitherM a b = EitherM (Either a b)++instance Monad (EitherM a) where+        return = EitherM . Right+        (EitherM (Left x)) >>= _ = EitherM (Left x)+        (EitherM (Right x)) >>= k = k x++buildReceivedMessage :: Word8 -> [M.HeaderField] -> EitherM Text+                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]+                         -> M.ReceivedMessage)++buildReceivedMessage 1 fields = do+        path <- require "path" [x | M.Path x <- fields]+        member <- require "member name" [x | M.Member x <- fields]+        return $ \serial flags body -> let+                iface = listToMaybe [x | M.Interface x <- fields]+                dest = listToMaybe [x | M.Destination x <- fields]+                sender = listToMaybe [x | M.Sender x <- fields]+                msg = M.MethodCall path member iface dest flags body+                in M.ReceivedMethodCall serial sender msg++buildReceivedMessage 2 fields = do+        replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+        return $ \serial _ body -> let+                dest = listToMaybe [x | M.Destination x <- fields]+                sender = listToMaybe [x | M.Sender x <- fields]+                msg = M.MethodReturn replySerial dest body+                in M.ReceivedMethodReturn serial sender msg++buildReceivedMessage 3 fields = do+        name <- require "error name" [x | M.ErrorName x <- fields]+        replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]+        return $ \serial _ body -> let+                dest = listToMaybe [x | M.Destination x <- fields]+                sender = listToMaybe [x | M.Sender x <- fields]+                msg = M.Error name replySerial dest body+                in M.ReceivedError serial sender msg++buildReceivedMessage 4 fields = do+        path <- require "path" [x | M.Path x <- fields]+        member <- require "member name" [x | M.Member x <- fields]+        iface <- require "interface" [x | M.Interface x <- fields]+        return $ \serial _ body -> let+                dest = listToMaybe [x | M.Destination x <- fields]+                sender = listToMaybe [x | M.Sender x <- fields]+                msg = M.Signal path member iface dest body+                in M.ReceivedSignal serial sender msg++buildReceivedMessage typeCode fields = return $ \serial flags body -> let+        sender = listToMaybe [x | M.Sender x <- fields]+        msg = M.Unknown typeCode flags body+        in M.ReceivedUnknown serial sender msg++require :: Text -> [a] -> EitherM Text a+require _     (x:_) = return x+require label _     = EitherM $ Left label+

@@ -40,6 +40,8 @@ import DBus.Message.Internal import DBus.Types import DBus.Wire.Internal+import DBus.Wire.Marshal+import DBus.Wire.Unmarshal import qualified DBus.Introspection as I  tests :: [Test]@@ -219,18 +221,18 @@         arbitrary = oneof [atomicType, containerType]  instance Arbitrary Signature where-        arbitrary = clampedSize 255 genSig mkSignature' where+        arbitrary = clampedSize 255 genSig mkSignature_ where                 genSig = fmap (TL.concat . map typeCode) arbitrary  instance Arbitrary ObjectPath where-        arbitrary = fmap (mkObjectPath' . TL.pack) path' where+        arbitrary = fmap (mkObjectPath_ . TL.pack) path' where                 c = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_"                 path = fmap (intercalate "/" . ([] :)) genElements                 path' = frequency [(1, return "/"), (9, path)]                 genElements = sized' 1 (sized' 1 (elements c))  instance Arbitrary BusName where-        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']                 @@ -248,7 +250,7 @@                         return (x:xs)  instance Arbitrary InterfaceName where-        arbitrary = clampedSize 255 genName mkInterfaceName' where+        arbitrary = clampedSize 255 genName mkInterfaceName_ where                 c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"                 c' = c ++ ['0'..'9']                 @@ -260,10 +262,10 @@                         return (x:xs)  instance Arbitrary ErrorName where-        arbitrary = fmap (mkErrorName' . strInterfaceName) arbitrary+        arbitrary = fmap (mkErrorName_ . strInterfaceName) arbitrary  instance Arbitrary MemberName where-        arbitrary = clampedSize 255 genName mkMemberName' where+        arbitrary = clampedSize 255 genName mkMemberName_ where                 c = ['a'..'z'] ++ ['A'..'Z'] ++ "_"                 c' = c ++ ['0'..'9']                 @@ -497,7 +499,7 @@         let path' = case strObjectPath parentPath of                 "/" -> thisPath                 x   -> TL.append x thisPath-        let path = mkObjectPath' path'+        let path = mkObjectPath_ path'         ifaces <- arbitrary         children <- shrinkingGen . listOf . subObject $ path         return $ I.Object path ifaces children