dbus-core-0.8.5.4: src/wire.anansi

:# Copyright (C) 2009-2010 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}

{\tt DBus.Wire} is also split into an internal and external interface.

:f DBus/Wire.hs
|copyright|
module DBus.Wire (
	|wire exports|
	) where
import DBus.Wire.Internal
import DBus.Wire.Marshal
import DBus.Wire.Unmarshal
:

:f DBus/Wire/Internal.hs
|copyright|
module DBus.Wire.Internal where
import Data.Word (Word8, Word64)
import qualified DBus.Types as T
:

\subsection{Endianness}

:f DBus/Wire/Internal.hs
data Endianness = LittleEndian | BigEndian
	deriving (Show, Eq)

encodeEndianness :: Endianness -> Word8
encodeEndianness LittleEndian = 108
encodeEndianness BigEndian    = 66

decodeEndianness :: Word8 -> Maybe Endianness
decodeEndianness 108 = Just LittleEndian
decodeEndianness 66  = Just BigEndian
decodeEndianness _   = Nothing
:

:d wire exports
  Endianness (..)
:

:f Tests.hs
instance Arbitrary Endianness where
	arbitrary = elements [LittleEndian, BigEndian]
:

\subsection{Alignment}

Every built-in type has an associated alignment. If a value of the given
type is marshaled, it must have {\sc nul} bytes inserted until it starts
on a byte index divisible by its alignment.

:f DBus/Wire/Internal.hs
alignment :: T.Type -> Word8
|alignments|

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

\subsection{Marshaling}

Marshaling is implemented using an error transformer over an internal
state. 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.

:f DBus/Wire/Marshal.hs
|copyright|
{-# LANGUAGE TypeFamilies #-}
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 (Int64)

import qualified DBus.Types as T
import qualified DBus.Types.Internal as T
:

:d marshal imports
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.Binary.Builder as B
:

:f DBus/Wire/Marshal.hs
data MarshalState = MarshalState {-# UNPACK #-} !B.Builder {-# UNPACK #-} !Word64

data MarshalR a = MarshalRL MarshalError | MarshalRR a {-# UNPACK #-} !MarshalState

type Marshal = MarshalM ()
newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a }

instance Monad MarshalM where
	{-# INLINE return #-}
	return a = MarshalM $ \_ s -> MarshalRR a s
	
	{-# INLINE (>>=) #-}
	m >>= k = MarshalM $ \e s -> case unMarshalM m e s of
		MarshalRL err -> MarshalRL err
		MarshalRR a s' -> unMarshalM (k a) e s'
	
	{-# INLINE (>>) #-}
	m >> k = MarshalM $ \e s -> case unMarshalM m e s of
		MarshalRL err -> MarshalRL err
		MarshalRR _ s' -> unMarshalM k e s'

throwError :: MarshalError -> MarshalM a
throwError err = MarshalM $ \_ _ -> MarshalRL err

{-# INLINE getState #-}
getState :: MarshalM MarshalState
getState = MarshalM $ \_ s -> MarshalRR s s

{-# INLINE putState #-}
putState :: MarshalState -> MarshalM ()
putState s = MarshalM $ \_ _ -> MarshalRR () s
:

Clients can perform marshaling via {\tt marshal} and {\tt runMarshal},
which will generate a {\tt ByteString} with the fully marshaled data.

:f DBus/Wire/Marshal.hs
runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString
runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of
	MarshalRL err -> Left err
	MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder
:

:f DBus/Wire/Marshal.hs
marshal :: T.Variant -> Marshal
marshal v = case v of
	|marshalers|
:

TODO: describe these functions

:f DBus/Wire/Marshal.hs
appendS :: BS.ByteString -> Marshal
appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let
	builder' = B.append builder $ B.fromByteString bytes
	count' = count + fromIntegral (BS.length bytes)
	in MarshalRR () (MarshalState builder' count')
:

:f DBus/Wire/Marshal.hs
appendL :: L.ByteString -> Marshal
appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let
	builder' = B.append builder $ B.fromLazyByteString bytes
	count' = count + fromIntegral (L.length bytes)
	in MarshalRR () (MarshalState builder' count')
:

:f DBus/Wire/Marshal.hs
pad :: Word8 -> Marshal
pad count = MarshalM $ \e s@(MarshalState _ existing) -> let
	padding' = fromIntegral $ padding existing count
	bytes = BS.replicate padding' 0
	in unMarshalM (appendS bytes) e s
:

Most numeric values already have marshalers implemented in the
{\tt Data.Binary.Builder} module; this function lets them be re-used easily.

:f DBus/Wire/Marshal.hs
marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal
marshalBuilder size be le x = do
	pad size
	MarshalM $ \e (MarshalState builder count) -> let
		builder' = B.append builder $ case e of
			BigEndian -> be x
			LittleEndian -> le x
		size' = fromIntegral size
		in MarshalRR () (MarshalState builder' (count + size'))
:

\subsubsection{Errors}

Marshaling can fail for four reasons:

\begin{itemize}
\item The message exceeds the maximum message size of $2^{27}$ bytes.
\item An array in the message exceeds the maximum array size of $2^{26}$ bytes.
\item The body's signature is not valid (for example, more than 255 fields).
\item A variant's signature is not valid -- same causes as an invalid body
      signature.
\item Some text is invalid -- for example, it contains {\sc nul}
      ({\tt '\textbackslash{}0'}) or invalid Unicode.
\end{itemize}

:f DBus/Wire/Marshal.hs
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]
:

:d wire exports
, MarshalError (..)
:

\subsection{Unmarshaling}

Unmarshaling also uses an error transformer and internal state.

:f DBus/Wire/Unmarshal.hs
|copyright|
|text extensions|
{-# LANGUAGE TypeFamilies #-}
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.Internal as T
import DBus.Util (void)
:

:d unmarshal imports
import Control.Monad (liftM)
import qualified DBus.Util.MonadError as E
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
:

A specialised, state-like monad is used for performance reasons. This is
equivalent to {\tt State.StateT UnmarshalState (E.ErrorM UnmarshalError)}.

:f DBus/Wire/Unmarshal.hs
data UnmarshalState = UnmarshalState BL.ByteString {-# UNPACK #-} !Word64

data UnmarshalR a = UnmarshalRL UnmarshalError | UnmarshalRR a {-# UNPACK #-} !UnmarshalState

newtype Unmarshal a = Unmarshal { unUnmarshal :: Endianness -> UnmarshalState -> UnmarshalR a }

instance Monad Unmarshal where
	{-# INLINE return #-}
	return a = Unmarshal $ \_ s -> UnmarshalRR a s
	
	{-# INLINE (>>=) #-}
	m >>= k = Unmarshal $ \e s -> case unUnmarshal m e s of
		UnmarshalRL err -> UnmarshalRL err
		UnmarshalRR a s' -> unUnmarshal (k a) e s'
	
	{-# INLINE (>>) #-}
	m >> k = Unmarshal $ \e s -> case unUnmarshal m e s of
		UnmarshalRL err -> UnmarshalRL err
		UnmarshalRR _ s' -> unUnmarshal k e s'

throwError :: UnmarshalError -> Unmarshal a
throwError err = Unmarshal $ \_ _ -> UnmarshalRL err

{-# INLINE getState #-}
getState :: Unmarshal UnmarshalState
getState = Unmarshal $ \_ s -> UnmarshalRR s s

{-# INLINE putState #-}
putState :: UnmarshalState -> Unmarshal ()
putState s = Unmarshal $ \_ _ -> UnmarshalRR () s
:

:f DBus/Wire/Unmarshal.hs
runUnmarshal :: Unmarshal a -> Endianness -> BL.ByteString -> Either UnmarshalError a
runUnmarshal m e bytes = case unUnmarshal m e (UnmarshalState bytes 0) of
	UnmarshalRL err -> Left err
	UnmarshalRR a _ -> Right a
:

:f DBus/Wire/Unmarshal.hs
unmarshal :: T.Signature -> Unmarshal [T.Variant]
unmarshal = mapM unmarshalType . T.signatureTypes

unmarshalType :: T.Type -> Unmarshal T.Variant
|unmarshalers|
:

TODO: describe these functions

:f DBus/Wire/Unmarshal.hs
{-# INLINE consume #-}
consume :: Word64 -> Unmarshal BL.ByteString
consume count = Unmarshal $ \_ (UnmarshalState bytes offset) -> let
	count' = fromIntegral count
	(x, bytes') = BL.splitAt count' bytes
	in if BL.length x == count'
		then UnmarshalRR x (UnmarshalState bytes' (offset + count))
		else UnmarshalRL $ UnexpectedEOF offset
:

:f DBus/Wire/Unmarshal.hs
skipPadding :: Word8 -> Unmarshal ()
skipPadding count = do
	(UnmarshalState _ offset) <- getState
	bytes <- consume $ padding offset count
	unless (BL.all (== 0) bytes) $
		throwError $ InvalidPadding offset
:

:f DBus/Wire/Unmarshal.hs
skipTerminator :: Unmarshal ()
skipTerminator = do
	(UnmarshalState _ offset) <- getState
	bytes <- consume 1
	unless (BL.all (== 0) bytes) $
		throwError $ MissingTerminator offset
:

:f 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'
	Nothing -> 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'
:

:d unmarshal imports
import qualified Data.Binary.Get as G
:

:f DBus/Wire/Unmarshal.hs
unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a
unmarshalGet count be le = do
	skipPadding count
	bs <- consume . fromIntegral $ count
	
	Unmarshal $ \e s -> let
		get = case e of
			BigEndian -> be
			LittleEndian -> le
		in UnmarshalRR (G.runGet get bs) s

unmarshalGet' :: T.Variable a => Word8 -> G.Get a -> G.Get a
              -> Unmarshal T.Variant
unmarshalGet' count be le = T.toVariant `liftM` unmarshalGet count be le
:

:f DBus/Wire/Unmarshal.hs
untilM :: Monad m => m Bool -> m a -> m [a]
untilM test comp = do
	done <- test
	if done
		then return []
		else do
			x <- comp
			xs <- untilM test comp
			return $ x:xs
:

\subsubsection{Errors}

Unmarshaling can fail for four reasons:

\begin{itemize}
\item The message's declared protocol version is unsupported.
\item Unexpected {\sc eof}, when there are less bytes remaining than are
      required.
\item An invalid byte sequence for a given value type.
\item Missing required header fields for the declared message type.
\item Non-zero bytes were found where padding was expected.
\item A string, signature, or object path was not {\sc null}-terminated.
\item An array's size didn't match the number of elements
\end{itemize}

:f DBus/Wire/Unmarshal.hs
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"
:

:d wire exports
, UnmarshalError (..)
:

\subsection{Numerics}

Numeric values are fixed-length, and aligned ``naturally'' -- ie, a 4-byte
integer will have a 4-byte alignment.

:d alignments
alignment T.DBusByte    = 1
alignment T.DBusWord16  = 2
alignment T.DBusWord32  = 4
alignment T.DBusWord64  = 8
alignment T.DBusInt16   = 2
alignment T.DBusInt32   = 4
alignment T.DBusInt64   = 8
alignment T.DBusDouble  = 8
:

Because some integral types are often used as components of other values,
there's separate functions for handling them.

:f DBus/Wire/Marshal.hs
marshalWord32 :: Word32 -> Marshal
marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le
:

:f DBus/Wire/Marshal.hs
{-# INLINE marshalWord8 #-}
marshalWord8 :: Word8 -> Marshal
marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let
	builder' = B.append builder $ B.singleton x
	in MarshalRR () (MarshalState builder' (count + 1))
:

:f DBus/Wire/Unmarshal.hs
unmarshalWord32 :: Unmarshal Word32
unmarshalWord32 = unmarshalGet 4 G.getWord32be G.getWord32le
:

:d marshalers
T.VarBoxWord8  x -> marshalWord8 x
T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x
T.VarBoxWord32 x -> marshalWord32 x
T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x
T.VarBoxInt16  x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x
T.VarBoxInt32  x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x
T.VarBoxInt64  x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x
:

:d unmarshalers
unmarshalType T.DBusByte = liftM (T.toVariant . BL.head) $ consume 1
unmarshalType T.DBusWord16 = unmarshalGet' 2 G.getWord16be G.getWord16le
unmarshalType T.DBusWord32 = unmarshalGet' 4 G.getWord32be G.getWord32le
unmarshalType T.DBusWord64 = unmarshalGet' 8 G.getWord64be G.getWord64le

unmarshalType T.DBusInt16  = do
	x <- unmarshalGet 2 G.getWord16be G.getWord16le
	return . T.toVariant $ (fromIntegral x :: Int16)

unmarshalType T.DBusInt32  = do
	x <- unmarshalGet 4 G.getWord32be G.getWord32le
	return . T.toVariant $ (fromIntegral x :: Int32)

unmarshalType T.DBusInt64  = do
	x <- unmarshalGet 8 G.getWord64be G.getWord64le
	return . T.toVariant $ (fromIntegral x :: Int64)
:

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

:d marshal imports
import Data.Binary.Put (runPut)
import qualified Data.Binary.IEEE754 as IEEE
:

:d unmarshal imports
import qualified Data.Binary.IEEE754 as IEEE
:

:d marshalers
T.VarBoxDouble x -> marshalDouble x
:

:f DBus/Wire/Marshal.hs
marshalDouble :: Double -> Marshal
marshalDouble x = do
	pad 8
	MarshalM $ \e s -> let
		put = case e of
			BigEndian -> IEEE.putFloat64be
			LittleEndian -> IEEE.putFloat64le
		bytes = runPut $ put x
		in unMarshalM (appendL bytes) e s
:

:d unmarshalers
unmarshalType T.DBusDouble = unmarshalGet' 8 IEEE.getFloat64be IEEE.getFloat64le
:

\subsection{Booleans}

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

:d alignments
alignment T.DBusBoolean = 4
:

:d marshalers
T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0
:

:d unmarshalers
unmarshalType T.DBusBoolean = unmarshalWord32 >>=
	fromMaybeU' "boolean" (\x -> case x of
		0 -> Just False
		1 -> Just True
		_ -> Nothing)
:

\subsection{Strings and object paths}

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

Because the encoding functions from {\tt Data.Text} raise exceptions on
error, checking their return value requires some ugly workarounds.

:f 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)

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
:

:d marshal imports
import DBus.Wire.Unicode (maybeEncodeUtf8)
:

:f DBus/Wire/Marshal.hs
marshalText :: Text -> Marshal
marshalText x = do
	bytes <- case maybeEncodeUtf8 x of
		Just x' -> return x'
		Nothing -> throwError $ InvalidText x
	when (L.any (== 0) bytes) $
		throwError $ InvalidText x
	marshalWord32 . fromIntegral . L.length $ bytes
	appendL bytes
	marshalWord8 0
:

:d unmarshal imports
import DBus.Wire.Unicode (maybeDecodeUtf8)
:

:f DBus/Wire/Unmarshal.hs
unmarshalText :: Unmarshal Text
unmarshalText = do
	byteCount <- unmarshalWord32
	bytes <- consume . fromIntegral $ byteCount
	skipTerminator
	fromMaybeU "text" maybeDecodeUtf8 bytes
:

:d alignments
alignment T.DBusString     = 4
alignment T.DBusObjectPath = 4
:

:d marshalers
T.VarBoxString x -> marshalText x
T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x
:

:d unmarshalers
unmarshalType T.DBusString = liftM T.toVariant unmarshalText

unmarshalType T.DBusObjectPath = unmarshalText >>=
	fromMaybeU' "object path" T.mkObjectPath
:

\subsection{Signatures}

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

:f DBus/Wire/Marshal.hs
marshalSignature :: T.Signature -> Marshal
marshalSignature x = do
	let bytes = T.bytesSignature x
	let size = fromIntegral . BS.length $ bytes
	marshalWord8 size
	appendS bytes
	marshalWord8 0
:

:f DBus/Wire/Unmarshal.hs
unmarshalSignature :: Unmarshal T.Signature
unmarshalSignature = do
	byteCount <- BL.head `liftM` consume 1
	lazy <- consume $ fromIntegral byteCount
	skipTerminator
	let bytes = B.concat $ BL.toChunks lazy
	fromMaybeU "signature" T.mkBytesSignature bytes
:

:d alignments
alignment T.DBusSignature  = 1
:

:d marshalers
T.VarBoxSignature x -> marshalSignature x
:

:d unmarshalers
unmarshalType T.DBusSignature = liftM T.toVariant unmarshalSignature
:

\subsection{Containers}

\subsubsection{Arrays}

:d alignments
alignment (T.DBusArray _) = 4
:

:d marshalers
T.VarBoxArray x -> marshalArray x
:

:d unmarshalers
unmarshalType (T.DBusArray t) = T.toVariant `liftM` unmarshalArray t
:

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

:d marshal imports
import qualified DBus.Constants as C
:

:f DBus/Wire/Marshal.hs
marshalArray :: T.Array -> Marshal
marshalArray x = do
	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x
	let arrayLen = L.length arrayBytes
	when (arrayLen > fromIntegral C.arrayMaximumLength)
		(throwError $ ArrayTooLong $ fromIntegral arrayLen)
	marshalWord32 $ fromIntegral arrayLen
	appendL $ L.replicate arrayPadding 0
	appendL arrayBytes
:

:f 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
:

:f DBus/Wire/Marshal.hs
getArrayBytes itemType x = do
	let vs = T.arrayItems x
	s <- getState
	(MarshalState _ afterLength) <- marshalWord32 0 >> getState
	(MarshalState _ afterPadding) <- pad (alignment itemType) >> getState
	
	putState $ MarshalState B.empty afterPadding
	(MarshalState itemBuilder _) <- mapM_ marshal vs >> getState
	
	let itemBytes = B.toLazyByteString itemBuilder
	    paddingSize = fromIntegral $ afterPadding - afterLength
	
	putState s
	return (paddingSize, itemBytes)
:

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

:f DBus/Wire/Unmarshal.hs
unmarshalArray :: T.Type -> Unmarshal T.Array
unmarshalArray T.DBusByte = do
	byteCount <- unmarshalWord32
	T.arrayFromBytes `liftM` consume (fromIntegral byteCount)
:

:f DBus/Wire/Unmarshal.hs
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) (unmarshalType itemType)
	end' <- getOffset
	when (end' > end) $
		throwError ArraySizeMismatch
	fromMaybeU "array" (T.arrayFromItems itemType) vs
:

\subsubsection{Dictionaries}

:d alignments
alignment (T.DBusDictionary _ _) = 4
:

:d marshalers
T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x)
:

:d unmarshalers
unmarshalType (T.DBusDictionary kt vt) = do
	let pairType = T.DBusStructure [kt, vt]
	array <- unmarshalArray pairType
	fromMaybeU' "dictionary" T.arrayToDictionary array
:

\subsubsection{Structures}

:d alignments
alignment (T.DBusStructure _) = 8
:

:d marshalers
T.VarBoxStructure (T.Structure vs) -> do
	pad 8
	mapM_ marshal vs
:

:d unmarshalers
unmarshalType (T.DBusStructure ts) = do
	skipPadding 8
	liftM (T.toVariant . T.Structure) $ mapM unmarshalType ts
:

\subsubsection{Variants}

:d alignments
alignment T.DBusVariant = 1
:

:d marshalers
T.VarBoxVariant x -> do
	let textSig = T.typeCode . T.variantType $ x
	sig <- case T.variantSignature x of
		Just x' -> return x'
		Nothing -> throwError $ InvalidVariantSignature textSig
	marshalSignature sig
	marshal x
:

:d unmarshalers
unmarshalType T.DBusVariant = do
	let getType sig = case T.signatureTypes sig of
		[t] -> Just t
		_   -> Nothing
	
	t <- fromMaybeU "variant signature" getType =<< unmarshalSignature
	T.toVariant `liftM` unmarshalType t
:

\subsection{Messages}

:d marshal imports
import qualified DBus.Message.Internal as M
:

:d unmarshal imports
import qualified DBus.Message.Internal as M
:

\subsubsection{Flags}

:d unmarshal imports
import Data.Bits ((.&.))
import qualified Data.Set as Set
:

:d marshal imports
import Data.Bits ((.|.))
import qualified Data.Set as Set
:

:f 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
:

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

\subsubsection{Header fields}

:f DBus/Wire/Marshal.hs
encodeField :: M.HeaderField -> T.Structure
encodeField (M.Path x)        = encodeField' 1 x
encodeField (M.Interface x)   = encodeField' 2 x
encodeField (M.Member x)      = encodeField' 3 x
encodeField (M.ErrorName x)   = encodeField' 4 x
encodeField (M.ReplySerial x) = encodeField' 5 x
encodeField (M.Destination x) = encodeField' 6 x
encodeField (M.Sender x)      = encodeField' 7 x
encodeField (M.Signature x)   = encodeField' 8 x

encodeField' :: T.Variable a => Word8 -> a -> T.Structure
encodeField' code x = T.Structure
	[ T.toVariant code
	, T.toVariant $ T.toVariant x
	]
:

:f DBus/Wire/Unmarshal.hs
decodeField :: T.Structure
            -> E.ErrorM UnmarshalError [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' :: T.Variable a => T.Variant -> (a -> b) -> Text
             -> E.ErrorM UnmarshalError [b]
decodeField' x f label = case T.fromVariant x of
	Just x' -> return [f x']
	Nothing -> E.throwErrorM $ InvalidHeaderField label x
:

:f DBus/Wire/Unmarshal.hs
unpackField :: T.Structure -> (Word8, T.Variant)
unpackField struct = (c', v') where
	T.Structure [c, v] = struct
	c' = fromJust . T.fromVariant $ c
	v' = fromJust . T.fromVariant $ v
:

\subsubsection{Header layout}

TODO: describe header layout here

\subsubsection{Marshaling}

:d wire exports
, marshalMessage
:

:f DBus/Wire/Marshal.hs
|apidoc marshalMessage|
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 <- getState
		mapM_ marshal body
		(MarshalState bodyBytesB _) <- getState
		putState empty
		marshalEndianness e
		let bodyBytes = B.toLazyByteString bodyBytesB
		marshalHeader msg serial sig
			$ fromIntegral . L.length $ bodyBytes
		pad 8
		appendL bodyBytes
		checkMaximumSize
:

:f DBus/Wire/Marshal.hs
checkBodySig :: [T.Variant] -> MarshalM T.Signature
checkBodySig vs = let
	textSig = TL.concat . map (T.typeCode . T.variantType) $ vs
	bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs
	invalid = throwError $ InvalidBodySignature textSig
	in case T.mkBytesSignature bytesSig of
		Just x -> return x
		Nothing -> invalid
:

:f DBus/Wire/Marshal.hs
marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32
              -> Marshal
marshalHeader msg serial bodySig bodyLength = do
	let fields = M.Signature bodySig : M.messageHeaderFields msg
	marshalWord8 . M.messageTypeCode $ msg
	marshalWord8 . encodeFlags . M.messageFlags $ msg
	marshalWord8 C.protocolVersion
	marshalWord32 bodyLength
	marshalWord32 . M.serialValue $ serial
	let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]
	marshalArray . fromJust . T.toArray fieldType
	        $ map encodeField fields
:

:f DBus/Wire/Marshal.hs
marshalEndianness :: Endianness -> Marshal
marshalEndianness = marshal . T.toVariant . encodeEndianness
:

:f DBus/Wire/Marshal.hs
checkMaximumSize :: Marshal
checkMaximumSize = do
	(MarshalState _ messageLength) <- getState
	when (messageLength > fromIntegral C.messageMaximumLength)
		(throwError $ MessageTooLong $ fromIntegral messageLength)
:

\subsubsection{Unmarshaling}

:d unmarshal imports
import qualified DBus.Constants as C
:

:d wire exports
, unmarshalMessage
:

:f DBus/Wire/Unmarshal.hs
|apidoc unmarshalMessage|
unmarshalMessage :: Monad m => (Word32 -> m BL.ByteString)
                 -> m (Either UnmarshalError M.ReceivedMessage)
unmarshalMessage 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 = BL.index fixedBytes 3
when (messageVersion /= C.protocolVersion) $
	E.throwErrorT $ UnsupportedProtocolVersion messageVersion
:

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

:d read fixed-length header
let eByte = BL.index fixedBytes 0
endianness <- case decodeEndianness eByte of
	Just x' -> return x'
	Nothing -> E.throwErrorT . Invalid "endianness" . TL.pack . show $ eByte
:

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

:d read fixed-length header
let unmarshal' x bytes = case runUnmarshal (unmarshal x) endianness bytes of
	Right x' -> return x'
	Left  e  -> E.throwErrorT e
fixed <- unmarshal' fixedSig fixedBytes
let typeCode = fromJust . T.fromVariant $ fixed !! 1
let flags = decodeFlags . fromJust . T.fromVariant $ fixed !! 2
let bodyLength = fromJust . T.fromVariant $ fixed !! 4
let serial = fromJust . T.fromVariant $ fixed !! 5
:

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

:d read fixed-length header
let fieldByteCount = fromJust . T.fromVariant $ fixed !! 6
:

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

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

And the header fields can be parsed.

:d read full header
let fieldArray = fromJust . T.fromVariant $ header !! 6
let fieldStructures = fromJust . T.fromArray $ fieldArray
fields <- case E.runErrorM $ concat `liftM` mapM decodeField fieldStructures 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))
:

:f DBus/Wire/Unmarshal.hs
findBodySignature :: [M.HeaderField] -> T.Signature
findBodySignature fields = fromMaybe "" signature where
	signature = listToMaybe [x | M.Signature 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 typeCode fields of
	Right x -> return x
	Left err -> E.throwErrorT $ MissingHeaderField err
return $ y serial flags body
:

This really belongs in the Message section...

:f DBus/Wire/Unmarshal.hs
buildReceivedMessage :: Word8 -> [M.HeaderField] -> E.ErrorM Text
                        (M.Serial -> (Set.Set M.Flag) -> [T.Variant]
                         -> M.ReceivedMessage)
:

Method calls

:f 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]
	return $ \serial flags body -> let
		iface = listToMaybe [x | M.Interface x <- fields]
		dest = listToMaybe [x | M.Destination x <- fields]
		sender = listToMaybe [x | M.Sender x <- fields]
		msg = M.MethodCall path member iface dest flags body
		in M.ReceivedMethodCall serial sender msg
:

Method returns

:f DBus/Wire/Unmarshal.hs
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
:

Errors

:f 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]
	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
:

Signals

:f 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]
	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
:

Unknown

:f 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
:

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

:f Tests.hs
prop_Unmarshal :: Endianness -> Variant -> Property
prop_Unmarshal e x = valid ==> unmarshaled == Right [x] where
	sig = mkSignature . typeCode . variantType $ x
	Just sig' = sig
	
	bytes = runMarshal (marshal x) e
	Right bytes' = bytes
	
	valid = isJust sig && isRight bytes
	unmarshaled = runUnmarshal (unmarshal sig') e bytes'

prop_MarshalMessage e serial msg expected = valid ==> correct where
	bytes = marshalMessage e serial msg
	Right bytes' = bytes
	
	getBytes = G.getLazyByteString . fromIntegral
	unmarshaled = G.runGet (unmarshalMessage getBytes) bytes'
	
	valid = isRight bytes
	correct = unmarshaled == Right expected

prop_WireMethodCall e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedMethodCall serial Nothing msg

prop_WireMethodReturn e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedMethodReturn serial Nothing msg

prop_WireError e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedError serial Nothing msg

prop_WireSignal e serial msg = prop_MarshalMessage e serial msg
	$ ReceivedSignal serial Nothing msg
:

:d test cases
, F.testGroup "Wire format"
	[ testProperty "Marshal -> Ummarshal" prop_Unmarshal
	, F.testGroup "Messages"
		[ testProperty "Method calls" prop_WireMethodCall
		, testProperty "Method returns" prop_WireMethodReturn
		, testProperty "Errors" prop_WireError
		, testProperty "Signals" prop_WireSignal
		]
	]
: