dbus-core-0.9.3: src/wire.anansi

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

\section{Wire format}

\begin{multicols}{2}

\dbus{} uses a simple binary format to serialize messages. Because the format
is binary, the \emph{endianness} of serialized values is important. \dbus{}
supports both big- and little-endian serialization, so clients can choose
whichever is more efficient on their hardware.

\vfill
\columnbreak

:d DBus.Wire
data Endianness = LittleEndian | BigEndian
	deriving (Show, Eq)
:

\end{multicols}

\begin{multicols}{2}

When written over the wire, message endianness is represented as a single
byte: {\tt 0x6C} for little-endian, {\tt 0x42} for big-endian. These magic
numbers are the {\sc ascii} values for {\tt 'l'} and {\tt 'B'}, respectively.

\vfill
\columnbreak

:d DBus.Wire
encodeEndianness :: Endianness -> Word8
encodeEndianness LittleEndian = 0x6C
encodeEndianness BigEndian    = 0x42

decodeEndianness :: Word8 -> Maybe Endianness
decodeEndianness 0x6C = Just LittleEndian
decodeEndianness 0x42 = Just BigEndian
decodeEndianness _    = Nothing
:

\end{multicols}

\begin{multicols}{2}

Each built-in type has an associated alignment. When serialized, padding is
inserted between values to ensure they always start at their preferred
alignment.

Numeric values are fixed-length, and aligned ``naturally''; eg, a 4-byte
integer will have a 4-byte alignment. Types with a length prefix, such as
strings and arrays, use their length's alignment.

\vfill
\columnbreak

:d DBus.Wire
alignment :: Type -> Word8
alignment TypeBoolean = 4
alignment TypeWord8 = 1
alignment TypeWord16 = 2
alignment TypeWord32 = 4
alignment TypeWord64 = 8
alignment TypeInt16 = 2
alignment TypeInt32 = 4
alignment TypeInt64 = 8
alignment TypeDouble = 8
alignment TypeString = 4
alignment TypeObjectPath = 4
alignment TypeSignature = 1
alignment (TypeArray _) = 4
alignment (TypeDictionary _ _) = 4
alignment (TypeStructure _) = 8
alignment TypeVariant = 1
:

:d DBus.Wire
padding :: Word64 -> Word8 -> Word64
padding current count = required where
	count' = fromIntegral count
	missing = mod current count'
	required = if missing > 0
		then count' - missing
		else 0
:

\end{multicols}

\clearpage
\subsection{Serialization support}

\begin{multicols}{2}

Messages can be quite large, so it's important that both the serializer and
parser be efficient. The standard {\tt Get} and {\tt Put} monads are too slow,
so I define my own type for building and parsing binary data. This is
equivalent to an {\tt ErrorT . ReaderT . StateT} stack, but inlined and
strict.

\vfill
\columnbreak

:d DBus.Wire
data WireR s a
	= WireRL String
	| WireRR a {-# UNPACK #-} !s

newtype Wire s a = Wire
	{ unWire :: Endianness -> s -> WireR s a
	}

instance Monad (Wire s) where
	{-# INLINE return #-}
	return a = Wire (\_ s -> WireRR a s)
	
	{-# INLINE (>>=) #-}
	m >>= k = Wire $ \e s -> case unWire m e s of
		WireRL err -> WireRL err
		WireRR a s' -> unWire (k a) e s'
	
	{-# INLINE (>>) #-}
	m >> k = Wire $ \e s -> case unWire m e s of
		WireRL err -> WireRL err
		WireRR _ s' -> unWire k e s'

throwError :: String -> Wire s a
throwError err = Wire (\_ _ -> WireRL err)

{-# INLINE getState #-}
getState :: Wire s s
getState = Wire (\_ s -> WireRR s s)

{-# INLINE putState #-}
putState :: s -> Wire s ()
putState s = Wire (\_ _ -> WireRR () s)

{-# INLINE chooseEndian #-}
chooseEndian :: a -> a -> Wire s a
chooseEndian big little = Wire (\e s -> case e of
	BigEndian -> WireRR big s
	LittleEndian -> WireRR little s)
:

\end{multicols}

\clearpage
\subsubsection{Marshaling}

\begin{multicols}{2}

Marshaling is the process of converting a sequence of values into a
{\tt ByteString}. The {\tt Builder} type is used for efficient construction
of lazy byte strings, but it doesn't provide any way to retrieve the length
of its internal buffer, so the byte count is tracked separately.

\vfill
\columnbreak

:d DBus.Wire
type Marshal = Wire MarshalState

newtype MarshalError = MarshalError Text
	deriving (Show, Eq)

data MarshalState = MarshalState
	{-# UNPACK #-} !Data.Binary.Builder.Builder
	{-# UNPACK #-} !Word64
:

\end{multicols}

\begin{multicols}{2}

TODO

\vfill
\columnbreak

:d DBus.Wire
marshal :: Value -> Marshal ()
marshal (ValueAtom x) = marshalAtom x
marshal (ValueBytes xs) = marshalStrictBytes xs
marshal (ValueVector t xs) = marshalVector t xs
marshal (ValueMap kt vt xs) = marshalMap kt vt xs
marshal (ValueStructure xs) = marshalStructure xs
marshal (ValueVariant x) = marshalVariant x
:

:d DBus.Wire
marshalAtom :: Atom -> Marshal ()
marshalAtom (AtomWord8 x) = marshalWord8 x
marshalAtom (AtomWord16 x) = marshalWord16 x
marshalAtom (AtomWord32 x) = marshalWord32 x
marshalAtom (AtomWord64 x) = marshalWord64 x
marshalAtom (AtomInt16 x) = marshalInt16 x
marshalAtom (AtomInt32 x) = marshalInt32 x
marshalAtom (AtomInt64 x) = marshalInt64 x
marshalAtom (AtomDouble x) = marshalDouble x
marshalAtom (AtomBool x) = marshalBool x
marshalAtom (AtomText x) = marshalText x
marshalAtom (AtomObjectPath x) = marshalObjectPath x
marshalAtom (AtomSignature x) = marshalSignature x
:

\end{multicols}

\clearpage

TODO: describe these functions

:d DBus.Wire
appendB :: Word64 -> Data.Binary.Builder.Builder -> Marshal ()
appendB size bytes = Wire (\_ (MarshalState builder count) -> let
	builder' = Data.Binary.Builder.append builder bytes
	count' = count + size
	in WireRR () (MarshalState builder' count'))
:

:d DBus.Wire
appendS :: ByteString -> Marshal ()
appendS bytes = appendB
	(fromIntegral (Data.ByteString.length bytes))
	(Data.Binary.Builder.fromByteString bytes)
:

:d DBus.Wire
appendL :: Data.ByteString.Lazy.ByteString -> Marshal ()
appendL bytes = appendB
	(fromIntegral (Data.ByteString.Lazy.length bytes))
	(Data.Binary.Builder.fromLazyByteString bytes)
:

:d DBus.Wire
pad :: Word8 -> Marshal ()
pad count = do
	(MarshalState _ existing) <- getState
	let padding' = fromIntegral (padding existing count)
	appendS (Data.ByteString.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.

:d DBus.Wire
marshalBuilder :: Word8
               -> (a -> Data.Binary.Builder.Builder)
               -> (a -> Data.Binary.Builder.Builder)
               -> a -> Marshal ()
marshalBuilder size be le x = do
	builder <- chooseEndian (be x) (le x)
	pad size
	appendB (fromIntegral size) builder
:


\clearpage
\subsubsection{Unmarshaling}

\begin{multicols}{2}

TODO

\vfill
\columnbreak

:d DBus.Wire
type Unmarshal = Wire UnmarshalState

newtype UnmarshalError = UnmarshalError Text
	deriving (Show, Eq)

data UnmarshalState = UnmarshalState
	{-# UNPACK #-} !ByteString
	{-# UNPACK #-} !Word64
:

\end{multicols}

\begin{multicols}{2}

TODO

\vfill
\columnbreak

:d DBus.Wire
unmarshal :: Type -> Unmarshal Value
unmarshal TypeWord8 = liftM toValue unmarshalWord8
unmarshal TypeWord16 = liftM toValue unmarshalWord16
unmarshal TypeWord32 = liftM toValue unmarshalWord32
unmarshal TypeWord64 = liftM toValue unmarshalWord64
unmarshal TypeInt16 = liftM toValue unmarshalInt16
unmarshal TypeInt32 = liftM toValue unmarshalInt32
unmarshal TypeInt64 = liftM toValue unmarshalInt64
unmarshal TypeDouble = liftM toValue unmarshalDouble
unmarshal TypeBoolean = liftM toValue unmarshalBool
unmarshal TypeString = liftM toValue unmarshalText
unmarshal TypeObjectPath = liftM toValue unmarshalObjectPath
unmarshal TypeSignature = liftM toValue unmarshalSignature
unmarshal (TypeArray TypeWord8) = liftM toValue unmarshalByteArray
unmarshal (TypeArray t) = liftM (ValueVector t) (unmarshalArray t)
unmarshal (TypeDictionary kt vt) = unmarshalDictionary kt vt
unmarshal (TypeStructure ts) = unmarshalStructure ts
unmarshal TypeVariant = unmarshalVariant
:

\end{multicols}

\clearpage

TODO: describe these functions

:d DBus.Wire
{-# INLINE consume #-}
consume :: Word64 -> Unmarshal ByteString
consume count = do
	(UnmarshalState bytes offset) <- getState
	let count' = fromIntegral count
	let (x, bytes') = Data.ByteString.splitAt count' bytes
	let lenConsumed = Data.ByteString.length x
	if lenConsumed == count'
		then do
			putState (UnmarshalState bytes' (offset + count))
			return x
		else throwError (concat
			[ "Unexpected EOF at offset "
			, show (offset + fromIntegral lenConsumed)
			])
:

:d DBus.Wire
skipPadding :: Word8 -> Unmarshal ()
skipPadding count = do
	(UnmarshalState _ offset) <- getState
	bytes <- consume (padding offset count)
	unless (Data.ByteString.all (== 0) bytes) (throwError (concat
		[ "Value padding ", show bytes
		, " contains invalid bytes."
		]))
:

:d DBus.Wire
skipTerminator :: Unmarshal ()
skipTerminator = do
	byte <- unmarshalWord8
	when (byte /= 0) (throwError "Textual value is not NUL-terminated.")
:

:d DBus.Wire
fromMaybeU :: Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU label f x = case f x of
	Just x' -> return x'
	Nothing -> throwError (concat ["Invalid ", label, ": ", show x])
:

:d DBus.Wire
unmarshalGet :: Word8 -> Data.Binary.Get.Get a -> Data.Binary.Get.Get a -> Unmarshal a
unmarshalGet count be le = do
	skipPadding count
	bytes <- consume (fromIntegral count)
	get <- chooseEndian be le
	let lazy = Data.ByteString.Lazy.fromChunks [bytes]
	return (Data.Binary.Get.runGet get lazy)
:


\clearpage
\subsection{Atoms}
\subsubsection{Integers}

:d DBus.Wire
marshalWord8 :: Word8 -> Marshal ()
marshalWord8 x = appendB 1 (Data.Binary.Builder.singleton x)

unmarshalWord8 :: Unmarshal Word8
unmarshalWord8 = liftM Data.ByteString.head (consume 1)
:

\begin{multicols}{2}

:d DBus.Wire
marshalWord16 :: Word16 -> Marshal ()
marshalWord16 = marshalBuilder 2
	Data.Binary.Builder.putWord16be
	Data.Binary.Builder.putWord16le

marshalWord32 :: Word32 -> Marshal ()
marshalWord32 = marshalBuilder 4
	Data.Binary.Builder.putWord32be
	Data.Binary.Builder.putWord32le

marshalWord64 :: Word64 -> Marshal ()
marshalWord64 = marshalBuilder 8
	Data.Binary.Builder.putWord64be
	Data.Binary.Builder.putWord64le

marshalInt16 :: Int16 -> Marshal ()
marshalInt16 = marshalWord16 . fromIntegral

marshalInt32 :: Int32 -> Marshal ()
marshalInt32 = marshalWord32 . fromIntegral

marshalInt64 :: Int64 -> Marshal ()
marshalInt64 = marshalWord64 . fromIntegral
:

\columnbreak

:d DBus.Wire
unmarshalWord16 :: Unmarshal Word16
unmarshalWord16 = unmarshalGet 2
	Data.Binary.Get.getWord16be
	Data.Binary.Get.getWord16le

unmarshalWord32 :: Unmarshal Word32
unmarshalWord32 = unmarshalGet 4
	Data.Binary.Get.getWord32be
	Data.Binary.Get.getWord32le

unmarshalWord64 :: Unmarshal Word64
unmarshalWord64 = unmarshalGet 8
	Data.Binary.Get.getWord64be
	Data.Binary.Get.getWord64le

unmarshalInt16 :: Unmarshal Int16
unmarshalInt16 = liftM fromIntegral unmarshalWord16

unmarshalInt32 :: Unmarshal Int32
unmarshalInt32 = liftM fromIntegral unmarshalWord32

unmarshalInt64 :: Unmarshal Int64
unmarshalInt64 = liftM fromIntegral unmarshalWord64
:

\end{multicols}

\clearpage
\subsubsection{Doubles}

\begin{multicols}{2}

{\tt Double}s are marshaled in 64-bit IEEE-754 floating-point format.

\vfill
\columnbreak

:d DBus.Wire
marshalDouble :: Double -> Marshal ()
marshalDouble x = do
	put <- chooseEndian
		Data.Binary.IEEE754.putFloat64be
		Data.Binary.IEEE754.putFloat64le
	pad 8
	appendL (runPut (put x))

unmarshalDouble :: Unmarshal Double
unmarshalDouble = unmarshalGet 8
	Data.Binary.IEEE754.getFloat64be
	Data.Binary.IEEE754.getFloat64le
:

\end{multicols}

\subsubsection{Booleans}

\begin{multicols}{2}

Booleans are marshaled as 4-byte unsigned integers containing either of
the values 0 or 1. Yes, really.

\vfill
\columnbreak

:d DBus.Wire
marshalBool :: Bool -> Marshal ()
marshalBool False = marshalWord32 0
marshalBool True  = marshalWord32 1

unmarshalBool :: Unmarshal Bool
unmarshalBool = do
	word <- unmarshalWord32
	case word of
		0 -> return False
		1 -> return True
		_ -> throwError (concat
			[ "Invalid boolean: "
			, show word
			])
:

\end{multicols}

\clearpage
\subsubsection{Strings and object paths}

Strings are encoded in {\sc utf-8}, terminated with {\tt NUL}, and prefixed
with their length as an unsigned 32-bit integer. Their alignment is that of
their length. Object paths are marshaled just like strings, though additional
checks are required when unmarshaling.

:d DBus.Wire
marshalText :: Text -> Marshal ()
marshalText text = do
	let bytes = Data.Text.Encoding.encodeUtf8 text
	when (Data.ByteString.any (== 0) bytes) (throwError (concat
		[ "String "
		, show text
		, " contained forbidden character: '\\x00'"
		]))
	marshalWord32 (fromIntegral (Data.ByteString.length bytes))
	appendS bytes
	marshalWord8 0
:

:d DBus.Wire
unmarshalText :: Unmarshal Text
unmarshalText = do
	byteCount <- unmarshalWord32
	bytes <- consume (fromIntegral byteCount)
	skipTerminator
	fromMaybeU "text" maybeDecodeUtf8 bytes

maybeDecodeUtf8 :: ByteString -> Maybe Text
maybeDecodeUtf8 bs = case Data.Text.Encoding.decodeUtf8' bs of
	Right text -> Just text
	_ -> Nothing
:

:d DBus.Wire
marshalObjectPath :: ObjectPath -> Marshal ()
marshalObjectPath = marshalText . objectPathText
:

:d DBus.Wire
unmarshalObjectPath :: Unmarshal ObjectPath
unmarshalObjectPath = do
	text <- unmarshalText
	fromMaybeU "object path" objectPath text
:

\clearpage
\subsubsection{Signatures}

Signatures are similar to strings, except their length is limited to 255
characters and is therefore stored as a single byte.

:d DBus.Wire
signatureBytes :: Signature -> ByteString
signatureBytes (Signature ts) = Data.ByteString.Char8.pack (concatMap typeCode ts)

marshalSignature :: Signature -> Marshal ()
marshalSignature x = do
	let bytes = signatureBytes x
	marshalWord8 (fromIntegral (Data.ByteString.length bytes))
	appendS bytes
	marshalWord8 0
:

:d DBus.Wire
unmarshalSignature :: Unmarshal Signature
unmarshalSignature = do
	byteCount <- unmarshalWord8
	bytes <- consume (fromIntegral byteCount)
	skipTerminator
	fromMaybeU "signature" parseSignature bytes
:

\clearpage
\subsection{Containers}
\subsubsection{Arrays}

Marshaling arrays is complicated, because the array body must be marshaled
\emph{first} to calculate the array length. This requires building a
temporary marshaler, to get the padding right.

:d DBus.Wire
arrayMaximumLength :: Int64
arrayMaximumLength = 67108864
:

:d DBus.Wire
marshalVector :: Type -> Vector Value -> Marshal ()
marshalVector t x = do
	(arrayPadding, arrayBytes) <- getArrayBytes t x
	let arrayLen = Data.ByteString.Lazy.length arrayBytes
	when (arrayLen > arrayMaximumLength) (throwError (concat
		[ "Marshaled array size ("
		, show arrayLen
		, " bytes) exceeds maximum limit of ("
		, show arrayMaximumLength
		, " bytes)."
		]))
	marshalWord32 (fromIntegral arrayLen)
	appendL (Data.ByteString.Lazy.replicate arrayPadding 0)
	appendL arrayBytes

marshalStrictBytes :: ByteString -> Marshal ()
marshalStrictBytes bytes = do
	let arrayLen = Data.ByteString.length bytes
	when (fromIntegral arrayLen > arrayMaximumLength) (throwError (concat
		[ "Marshaled array size ("
		, show arrayLen
		, " bytes) exceeds maximum limit of ("
		, show arrayMaximumLength
		, " bytes)."
		]))
	marshalWord32 (fromIntegral arrayLen)
	appendS bytes
:

:d DBus.Wire
getArrayBytes :: Type -> Vector Value -> Marshal (Int64, Data.ByteString.Lazy.ByteString)
getArrayBytes itemType vs = do
	s <- getState
	(MarshalState _ afterLength) <- marshalWord32 0 >> getState
	(MarshalState _ afterPadding) <- pad (alignment itemType) >> getState
	
	putState (MarshalState Data.Binary.Builder.empty afterPadding)
	(MarshalState itemBuilder _) <- Data.Vector.mapM_ marshal vs >> getState
	
	let itemBytes = Data.Binary.Builder.toLazyByteString itemBuilder
	    paddingSize = fromIntegral (afterPadding - afterLength)
	
	putState s
	return (paddingSize, itemBytes)
:

Unmarshaling is much easier, especially if it's a byte array.

:d DBus.Wire
unmarshalByteArray :: Unmarshal ByteString
unmarshalByteArray = do
	byteCount <- unmarshalWord32
	consume (fromIntegral byteCount)

unmarshalArray :: Type -> Unmarshal (Vector Value)
unmarshalArray itemType = do
	let getOffset = do
		(UnmarshalState _ o) <- getState
		return o
	byteCount <- unmarshalWord32
	skipPadding (alignment itemType)
	start <- getOffset
	let end = start + fromIntegral byteCount
	vs <- untilM (liftM (>= end) getOffset) (unmarshal itemType)
	end' <- getOffset
	when (end' > end) (throwError (concat
		[ "Array data size exeeds array size of "
		, show end
		]))
	return (Data.Vector.fromList vs)
:

\clearpage
\subsubsection{Dictionaries}

:d DBus.Wire
dictionaryToArray :: Map Atom Value -> Vector Value
dictionaryToArray = Data.Vector.fromList . map step . Data.Map.toList where
	step (k, v) = ValueStructure [ValueAtom k, v]
:

:d DBus.Wire
arrayToDictionary :: Vector Value -> Map Atom Value
arrayToDictionary = Data.Map.fromList . map step . Data.Vector.toList where
	step (ValueStructure [ValueAtom k, v]) = (k, v)
	step _ = error "arrayToDictionary: internal error"
:

:d DBus.Wire
marshalMap :: Type -> Type -> Map Atom Value -> Marshal ()
marshalMap kt vt x = let
	structType = TypeStructure [kt, vt]
	array = dictionaryToArray x
	in marshalVector structType array
:

:d DBus.Wire
unmarshalDictionary :: Type -> Type -> Unmarshal Value
unmarshalDictionary kt vt = do
	let pairType = TypeStructure [kt, vt]
	array <- unmarshalArray pairType
	return (ValueMap kt vt (arrayToDictionary array))
:

\clearpage
\subsubsection{Structures}

:d DBus.Wire
marshalStructure :: [Value] -> Marshal ()
marshalStructure vs = do
	pad 8
	mapM_ marshal vs
:

:d DBus.Wire
unmarshalStructure :: [Type] -> Unmarshal Value
unmarshalStructure ts = do
	skipPadding 8
	liftM ValueStructure (mapM unmarshal ts)
:

\subsubsection{Variants}

:d DBus.Wire
marshalVariant :: Variant -> Marshal ()
marshalVariant var@(Variant val) = do
	sig <- case checkSignature [valueType val] of
		Just x' -> return x'
		Nothing -> throwError (concat
			[ "Signature "
			, show (typeCode (valueType val))
			, " for variant "
			, show var
			, " is malformed or too large."
			])
	marshalSignature sig
	marshal val
:

:d DBus.Wire
unmarshalVariant :: Unmarshal Value
unmarshalVariant = do
	let getType sig = case signatureTypes sig of
		[t] -> Just t
		_   -> Nothing
	
	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature
	(toValue . Variant) `liftM` unmarshal t
:

\clearpage
\subsection{Messages}

:d DBus.Wire
protocolVersion :: Word8
protocolVersion = 1

messageMaximumLength :: Word64
messageMaximumLength = 134217728
:

\subsubsection{Flags}

:d DBus.Wire
encodeFlags :: Set Flag -> Word8
encodeFlags flags = foldr (.|.) 0 (map flagValue (Data.Set.toList flags)) where
	flagValue NoReplyExpected = 0x1
	flagValue NoAutoStart     = 0x2
:

:d DBus.Wire
decodeFlags :: Word8 -> Set Flag
decodeFlags word = Data.Set.fromList flags where
	flagSet = [ (0x1, NoReplyExpected)
	          , (0x2, NoAutoStart)
	          ]
	flags = flagSet >>= \(x, y) -> [y | word .&. x > 0]
:

\clearpage
\subsubsection{Header fields}

:d DBus.Wire
encodeField :: HeaderField -> Value
encodeField (HeaderPath x)        = encodeField' 1 x
encodeField (HeaderInterface x)   = encodeField' 2 x
encodeField (HeaderMember x)      = encodeField' 3 x
encodeField (HeaderErrorName x)   = encodeField' 4 x
encodeField (HeaderReplySerial x) = encodeField' 5 x
encodeField (HeaderDestination x) = encodeField' 6 x
encodeField (HeaderSender x)      = encodeField' 7 x
encodeField (HeaderSignature x)   = encodeField' 8 x

encodeField' :: IsVariant a => Word8 -> a -> Value
encodeField' code x = toValue (code, toVariant x)
:

:d DBus.Wire
decodeField :: (Word8, Variant)
            -> E.ErrorM UnmarshalError [HeaderField]
decodeField struct = case struct of
	(1, x) -> decodeField' x HeaderPath "path"
	(2, x) -> decodeField' x HeaderInterface "interface"
	(3, x) -> decodeField' x HeaderMember "member"
	(4, x) -> decodeField' x HeaderErrorName "error name"
	(5, x) -> decodeField' x HeaderReplySerial "reply serial"
	(6, x) -> decodeField' x HeaderDestination "destination"
	(7, x) -> decodeField' x HeaderSender "sender"
	(8, x) -> decodeField' x HeaderSignature "signature"
	_      -> return []

decodeField' :: IsVariant a => Variant -> (a -> b) -> Text
             -> E.ErrorM UnmarshalError [b]
decodeField' x f label = case fromVariant x of
	Just x' -> return [f x']
	Nothing -> E.throwErrorM (UnmarshalError (Data.Text.pack (concat
		[ "Header field "
		, show label
		, " contains invalid value "
		, show x
		])))
:

\clearpage
\subsubsection{Marshaling}

:d DBus.Wire
|apidoc DBus.Wire.marshalMessage|
marshalMessage :: Message a => Endianness -> Serial -> a
               -> Either MarshalError Data.ByteString.ByteString
marshalMessage e serial msg = runMarshal where
	body = messageBody msg
	marshaler = do
		sig <- checkBodySig body
		empty <- getState
		mapM_ (marshal . (\(Variant x) -> x)) body
		(MarshalState bodyBytesB _) <- getState
		putState empty
		marshal (toValue (encodeEndianness e))
		let bodyBytes = Data.Binary.Builder.toLazyByteString bodyBytesB
		marshalHeader msg serial sig (fromIntegral (Data.ByteString.Lazy.length bodyBytes))
		pad 8
		appendL bodyBytes
		checkMaximumSize
	emptyState = MarshalState Data.Binary.Builder.empty 0
	runMarshal = case unWire marshaler e emptyState of
		WireRL err -> Left (MarshalError (Data.Text.pack err))
		WireRR _ (MarshalState builder _) -> Right (toStrict builder)
	toStrict = Data.ByteString.concat
	         . Data.ByteString.Lazy.toChunks
	         . Data.Binary.Builder.toLazyByteString

checkBodySig :: [Variant] -> Marshal Signature
checkBodySig vs = case checkSignature (map variantType vs) of
	Just x -> return x
	Nothing -> throwError (concat
		[ "Message body ", show vs
		, " has too many items"
		])

marshalHeader :: Message a => a -> Serial -> Signature -> Word32
              -> Marshal ()
marshalHeader msg serial bodySig bodyLength = do
	let fields = HeaderSignature bodySig : messageHeaderFields msg
	marshalWord8 (messageTypeCode msg)
	marshalWord8 (encodeFlags (messageFlags msg))
	marshalWord8 protocolVersion
	marshalWord32 bodyLength
	marshalWord32 (serialValue serial)
	let fieldType = TypeStructure [TypeWord8, TypeVariant]
	marshalVector fieldType (Data.Vector.fromList (map encodeField fields))

checkMaximumSize :: Marshal ()
checkMaximumSize = do
	(MarshalState _ messageLength) <- getState
	when (messageLength > messageMaximumLength) (throwError (concat
		[ "Marshaled message size (", show messageLength
		, " bytes) exeeds maximum limit of ("
		, show messageMaximumLength, " bytes)."
		]))
:

\clearpage
\subsubsection{Unmarshaling}

:d DBus.Wire
unmarshalMessageM :: Monad m => (Word32 -> m ByteString)
                  -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM getBytes' = E.runErrorT $ do
	let getBytes = E.ErrorT . liftM Right . getBytes'
	
	|read fixed-length header|
	|read full header|
	|read body|
	|build message|
:

The first part of the header has a fixed size of 16 bytes, so it can be
retrieved without any size calculations.

:d read fixed-length header
let fixedSig = "yyyyuuu"
fixedBytes <- getBytes 16
:

The first field of interest is the protocol version; if the incoming
message's version is different from this library, the message cannot be
parsed.

:d read fixed-length header
let messageVersion = Data.ByteString.index fixedBytes 3
when (messageVersion /= protocolVersion) (E.throwErrorT (UnmarshalError (Data.Text.pack (concat
	[ "Unsupported protocol version: "
	, show messageVersion
	]))))
:

Next is the endianness, used for parsing pretty much every other field.

:d read fixed-length header
let eByte = Data.ByteString.index fixedBytes 0
endianness <- case decodeEndianness eByte of
	Just x' -> return x'
	Nothing -> E.throwErrorT (UnmarshalError (Data.Text.pack (concat
		[ "Invalid endianness: "
		, show eByte
		])))
:

With the endianness out of the way, the rest of the fixed header
can be decoded

:d read fixed-length header
let unmarshalSig = mapM unmarshal . signatureTypes
let unmarshal' x bytes = case unWire (unmarshalSig x) endianness (UnmarshalState bytes 0) of
	WireRR x' _ -> return x'
	WireRL err  -> E.throwErrorT (UnmarshalError (Data.Text.pack err))
fixed <- unmarshal' fixedSig fixedBytes
let messageType = fromJust (fromValue (fixed !! 1))
let flags = decodeFlags (fromJust (fromValue (fixed !! 2)))
let bodyLength = fromJust (fromValue (fixed !! 4))
let serial = fromJust (fromVariant (Variant (fixed !! 5)))
:

The last field of the fixed header is actually part of the field array,
but is treated as a single {\tt Word32} so it'll be known how many bytes
to retrieve.

:d read fixed-length header
let fieldByteCount = fromJust (fromValue (fixed !! 6))
:

With the field byte count, the remainder of the header bytes can be
pulled out of the monad.

:d read full header
let headerSig  = "yyyyuua(yv)"
fieldBytes <- getBytes fieldByteCount
let headerBytes = Data.ByteString.append fixedBytes fieldBytes
header <- unmarshal' headerSig headerBytes
:

And the header fields can be parsed.

:d read full header
let fieldArray = Data.Vector.toList (fromJust (fromValue (header !! 6)))
fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldArray of
	Left err -> E.throwErrorT err
	Right x -> return x
:

The body is always aligned to 8 bytes, so pull out the padding before
unmarshaling it.

:d read body
let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8
void (getBytes (fromIntegral bodyPadding))
:

:d DBus.Wire
findBodySignature :: [HeaderField] -> Signature
findBodySignature fields = fromMaybe "" (listToMaybe [x | HeaderSignature x <- fields])
:

:d read body
let bodySig = findBodySignature fields
:

Then pull the body bytes, and unmarshal it.

:d read body
bodyBytes <- getBytes bodyLength
body <- unmarshal' bodySig bodyBytes
:

Even if the received message was structurally valid, building the
{\tt ReceivedMessage} can still fail due to missing header fields.

:d build message
y <- case E.runErrorM (buildReceivedMessage messageType fields) of
	Right x -> return x
	Left err -> E.throwErrorT (UnmarshalError (Data.Text.pack (concat
		[ "Header field "
		, show err
		, " is required, but missing"
		])))
return (y serial flags (map Variant body))
:

This really belongs in the Message section...

:d DBus.Wire
buildReceivedMessage :: Word8 -> [HeaderField] -> E.ErrorM Text
                        (Serial -> (Set Flag) -> [Variant]
                         -> ReceivedMessage)
:

Method calls

:d DBus.Wire
buildReceivedMessage 1 fields = do
	path <- require "path" [x | HeaderPath x <- fields]
	member <- require "member name" [x | HeaderMember x <- fields]
	return $ \serial flags body -> let
		iface = listToMaybe [x | HeaderInterface x <- fields]
		dest = listToMaybe [x | HeaderDestination x <- fields]
		sender = listToMaybe [x | HeaderSender x <- fields]
		msg = MethodCall path member iface dest flags body
		in ReceivedMethodCall serial sender msg
:

Method returns

:d DBus.Wire
buildReceivedMessage 2 fields = do
	replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | HeaderDestination x <- fields]
		sender = listToMaybe [x | HeaderSender x <- fields]
		msg = MethodReturn replySerial dest body
		in ReceivedMethodReturn serial sender msg
:

Errors

:d DBus.Wire
buildReceivedMessage 3 fields = do
	name <- require "error name" [x | HeaderErrorName x <- fields]
	replySerial <- require "reply serial" [x | HeaderReplySerial x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | HeaderDestination x <- fields]
		sender = listToMaybe [x | HeaderSender x <- fields]
		msg = Error name replySerial dest body
		in ReceivedError serial sender msg
:

Signals

:d DBus.Wire
buildReceivedMessage 4 fields = do
	path <- require "path" [x | HeaderPath x <- fields]
	member <- require "member name" [x | HeaderMember x <- fields]
	iface <- require "interface" [x | HeaderInterface x <- fields]
	return $ \serial _ body -> let
		dest = listToMaybe [x | HeaderDestination x <- fields]
		sender = listToMaybe [x | HeaderSender x <- fields]
		msg = Signal dest path iface member body
		in ReceivedSignal serial sender msg
:

Unknown

:d DBus.Wire
buildReceivedMessage messageType fields = return $ \serial flags body -> let
	sender = listToMaybe [x | HeaderSender x <- fields]
	msg = Unknown messageType flags body
	in ReceivedUnknown serial sender msg
:

:d DBus.Wire
require :: Text -> [a] -> E.ErrorM Text a
require _     (x:_) = return x
require label _     = E.throwErrorM label
:

To simplify the public interface, the incremental interface to message
unmarshaling is hidden. Clients just need to pass in a single bytestring.
This is OK, because clients do not need to read full messages off a socket
(they typically use this for parsing stored messages).

:d DBus.Wire
|apidoc DBus.Wire.unmarshalMessage|
unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage
unmarshalMessage = Data.Binary.Get.runGet get . toLazy where
	get = unmarshalMessageM getBytes
	getBytes = Data.Binary.Get.getByteString . fromIntegral
	toLazy bs = Data.ByteString.Lazy.fromChunks [bs]
: