:# Copyright (C) 2009-2011 John Millikin :# :# 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 . \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] :