dbus-core 0.6 → 0.7

raw patch · 8 files changed

+767/−728 lines, 8 filesnew-component:exe:dbus-core-testsPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Makefile +5/−1
• Tests.nw +2/−2
• dbus-core.cabal +4/−3
• dbus-core.nw +86/−77
• hs/DBus/Connection.hs +0/−2
• hs/DBus/Wire.hs +1/−642
• hs/DBus/Wire/Internal.hs +668/−0
• hs/Tests.hs +1/−1

@@ -11,6 +11,7 @@ 	hs/DBus/Types.hs \ 	hs/DBus/Util.hs \ 	hs/DBus/Wire.hs \+	hs/DBus/Wire/Internal.hs \ 	hs/Tests.hs  all: $(HS_SOURCES)@@ -18,7 +19,7 @@ %.tex: %.nw 	noweave -delay "$<" | cpif "$@" -hs/%.hs: dbus-core.nw hs/DBus/Message+hs/%.hs: dbus-core.nw hs/DBus/Message hs/DBus/Wire 	notangle -R"$*.hs" "$<" | cpphs --hashes --noline | cpif "$@"  hs/Tests.hs: Tests.nw hs@@ -32,6 +33,9 @@  hs/DBus/Message: 	mkdir -p hs/DBus/Message++hs/DBus/Wire:+	mkdir -p hs/DBus/Wire  %.pdf: %.tex 	xelatex "$<"

@@ -11,7 +11,7 @@ % 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/>.+% along with this program.  If not, see <http://www.gnu.org/licenses/>.  <<Tests.hs>>= <<copyright>>@@ -39,7 +39,7 @@ import DBus.Address import DBus.Message.Internal import DBus.Types-import DBus.Wire+import DBus.Wire.Internal import qualified DBus.Introspection as I  @ \section{Tests}

@@ -1,5 +1,5 @@ name: dbus-core-version: 0.6+version: 0.7 synopsis: Low-level D-Bus protocol implementation license: GPL license-file: License.txt@@ -55,13 +55,14 @@     DBus.Message     DBus.NameReservation     DBus.Types+    DBus.Wire    other-modules:     DBus.Message.Internal-    DBus.Wire+    DBus.Wire.Internal     DBus.Util -executable tests+executable dbus-core-tests   main-is: Tests.hs   hs-source-dirs: hs 

@@ -1174,11 +1174,18 @@ @ \section{Wire format} +{\tt DBus.Wire} is also split into an internal and external interface.+ <<DBus/Wire.hs>>= <<copyright>>+module DBus.Wire (<<wire exports>>) where+import DBus.Wire.Internal++<<DBus/Wire/Internal.hs>>=+<<copyright>> <<text extensions>> <<wire extensions>>-module DBus.Wire (<<wire exports>>) where+module DBus.Wire.Internal where <<text imports>> <<wire imports>> import Control.Monad (when, unless)@@ -1190,7 +1197,7 @@  @ \subsection{Endianness} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= data Endianness = LittleEndian | BigEndian 	deriving (Show, Eq) @@ -1212,7 +1219,7 @@ type is marshaled, it must have {\sc nul} bytes inserted until it starts on a byte index divisible by its alignment. -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= alignment :: T.Type -> Word8 <<alignments>> @@ -1224,9 +1231,6 @@ 		then count' - missing 		else 0 -<<wire exports>>=-, alignment- @ \subsection{Marshaling}  Marshaling is implemented using an error transformer over an internal@@ -1244,7 +1248,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE BangPatterns #-} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= data MarshalState = MarshalState Endianness B.Builder !Word64 newtype MarshalM a = MarshalM (E.ErrorT MarshalError (ST.State MarshalState) a) 	deriving (Monad, E.MonadError MarshalError, ST.MonadState MarshalState)@@ -1253,20 +1257,14 @@ @ Clients can perform marshaling via {\tt marshal} and {\tt runMarshal}, which will generate a {\tt ByteString} with the fully marshaled data. -<<wire exports>>=-, MarshalM-, Marshal-, marshal-, runMarshal--<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString runMarshal (MarshalM m) e = case ST.runState (E.runErrorT m) initialState of 	(Right _, MarshalState _ builder _) -> Right (B.toLazyByteString builder) 	(Left  x, _) -> Left x 	where initialState = MarshalState e B.empty 0 -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshal :: T.Variant -> Marshal marshal v = marshalType (T.variantType v) where 	x :: T.Variable a => a@@ -1276,7 +1274,7 @@  @ TODO: describe these functions -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= append :: L.ByteString -> Marshal append bytes = do 	(MarshalState e builder count) <- ST.get@@ -1284,7 +1282,7 @@ 	    count' = count + (fromIntegral $ L.length bytes) 	ST.put $ MarshalState e builder' count' -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= pad :: Word8 -> Marshal pad count = do 	(MarshalState _ _ existing) <- ST.get@@ -1294,7 +1292,7 @@ @ Most numeric values already have marshalers implemented in the {\tt Data.Binary.Builder} module; this function lets them be re-used easily. -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal marshalBuilder size be le x = do 	pad size@@ -1315,16 +1313,17 @@ \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 contains {\sc nul} ({\tt '\textbackslash{}0'}).+\item Some text is invalid -- for example, it contains {\sc nul}+      ({\tt '\textbackslash{}0'}) or invalid Unicode. \end{itemize} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= data MarshalError 	= MessageTooLong Word64 	| ArrayTooLong Word64 	| InvalidBodySignature Text 	| InvalidVariantSignature Text-	| TextContainsNUL Text+	| InvalidText Text 	deriving (Eq)  instance Show MarshalError where@@ -1336,8 +1335,8 @@ 		["Invalid body signature: ", show x] 	show (InvalidVariantSignature x) = concat 		["Invalid variant signature: ", show x]-	show (TextContainsNUL x) = concat-		["Text contains NUL: ", show x]+	show (InvalidText x) = concat+		["Text cannot be marshaled: ", show x]  instance E.Error MarshalError @@ -1348,22 +1347,17 @@  Unmarshaling also uses an error transformer and internal state. -<<wire exports>>=-, Unmarshal-, unmarshal-, runUnmarshal--<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= data UnmarshalState = UnmarshalState Endianness L.ByteString !Word64 newtype Unmarshal a = Unmarshal (E.ErrorT UnmarshalError (ST.State UnmarshalState) a) 	deriving (Monad, Functor, E.MonadError UnmarshalError, ST.MonadState UnmarshalState) -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= runUnmarshal :: Unmarshal a -> Endianness -> L.ByteString -> Either UnmarshalError a runUnmarshal (Unmarshal m) e bytes = ST.evalState (E.runErrorT m) state where 	state = UnmarshalState e bytes 0 -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshal :: T.Signature -> Unmarshal [T.Variant] unmarshal = mapM unmarshalType . T.signatureTypes @@ -1372,7 +1366,7 @@  @ TODO: describe these functions -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= consume :: Word64 -> Unmarshal L.ByteString consume count = do 	(UnmarshalState e bytes offset) <- ST.get@@ -1383,7 +1377,7 @@ 	ST.put $ UnmarshalState e bytes' (offset + count) 	return x -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= skipPadding :: Word8 -> Unmarshal () skipPadding count = do 	(UnmarshalState _ _ offset) <- ST.get@@ -1391,7 +1385,7 @@ 	unless (L.all (== 0) bytes) $ 		E.throwError $ InvalidPadding offset -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= skipTerminator :: Unmarshal () skipTerminator = do 	(UnmarshalState _ _ offset) <- ST.get@@ -1399,7 +1393,7 @@ 	unless (L.all (== 0) bytes) $ 		E.throwError $ MissingTerminator offset -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= fromMaybeU :: Show a => Text -> (a -> Maybe b) -> a -> Unmarshal b fromMaybeU label f x = case f x of 	Just x' -> return x'@@ -1414,7 +1408,7 @@ <<wire imports>>= import qualified Data.Binary.Get as G -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalGet :: Word8 -> G.Get a -> G.Get a -> Unmarshal a unmarshalGet count be le = do 	skipPadding count@@ -1429,7 +1423,7 @@               -> Unmarshal T.Variant unmarshalGet' count be le = T.toVariant `fmap` unmarshalGet count be le -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= untilM :: Monad m => m Bool -> m a -> m [a] untilM test comp = do 	done <- test@@ -1455,7 +1449,7 @@ \item An array's size didn't match the number of elements \end{itemize} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= data UnmarshalError 	= UnsupportedProtocolVersion Word8 	| UnexpectedEOF Word64@@ -1507,7 +1501,7 @@ @ Because {\tt Word32}s are often used for other types, there's separate functions for handling them. -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalWord32 :: Word32 -> Marshal marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le @@ -1585,31 +1579,47 @@ their length. Object paths are marshaled just like strings, though additional checks are required when unmarshaling. -TODO: If the input is invalid, these {\sc utf8} functions will raise an-exception, rather than return an error value. Eventually they should be-wrapped with {\tt unsafePerformIO} and be tweaked to return a proper-{\tt Maybe} or {\tt Either}.+Because the encoding functions from {\tt Data.Text} raise exceptions on+error, checking their return value requires some ugly workarounds.  <<wire imports>>= import Data.Text.Lazy.Encoding (encodeUtf8, decodeUtf8)+import Data.Text.Encoding.Error (UnicodeException)+import qualified Control.Exception as Exc+import System.IO.Unsafe (unsafePerformIO) -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>=+excToMaybe :: a -> Maybe a+excToMaybe x = unsafePerformIO $ fmap Just (Exc.evaluate x) `Exc.catch` unicodeError++unicodeError :: UnicodeException -> IO (Maybe a)+unicodeError = const $ return Nothing++maybeEncodeUtf8 :: Text -> Maybe L.ByteString+maybeEncodeUtf8 = excToMaybe . encodeUtf8++maybeDecodeUtf8 :: L.ByteString -> Maybe Text+maybeDecodeUtf8 = excToMaybe . decodeUtf8++<<DBus/Wire/Internal.hs>>= marshalText :: Text -> Marshal marshalText x = do-	let bytes = encodeUtf8 x+	bytes <- case maybeEncodeUtf8 x of+		Just x' -> return x'+		Nothing -> E.throwError $ InvalidText x 	when (L.any (== 0) bytes) $-		E.throwError $ TextContainsNUL x+		E.throwError $ InvalidText x 	marshalWord32 . fromIntegral . L.length $ bytes 	append bytes 	append (L.singleton 0) -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalText :: Unmarshal Text unmarshalText = do 	byteCount <- unmarshalWord32 	bytes <- consume . fromIntegral $ byteCount 	skipTerminator-	return . decodeUtf8 $ bytes+	fromMaybeU "text" maybeDecodeUtf8 bytes  <<alignments>>= alignment T.DBusString     = 4@@ -1630,7 +1640,7 @@ Signatures are similar to strings, except their length is limited to 255 characters and is therefore stored as a single byte. -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalSignature :: T.Signature -> Marshal marshalSignature x = do 	let bytes = encodeUtf8 . T.strSignature $ x@@ -1639,11 +1649,12 @@ 	append bytes 	append (L.singleton 0) -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalSignature :: Unmarshal T.Signature unmarshalSignature = do 	byteCount <- L.head `fmap` consume 1-	sigText <- fmap decodeUtf8 $ consume . fromIntegral $ byteCount+	bytes <- consume $ fromIntegral byteCount+	sigText <- fromMaybeU "text" maybeDecodeUtf8 bytes 	skipTerminator 	fromMaybeU "signature" T.mkSignature sigText @@ -1676,7 +1687,7 @@ <<wire imports>>= import qualified DBus.Constants as C -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalArray :: T.Array -> Marshal marshalArray x = do 	(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x@@ -1687,12 +1698,12 @@ 	append $ L.replicate arrayPadding 0 	append arrayBytes -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString) getArrayBytes T.DBusByte x = return (0, bytes) where 	Just bytes = T.arrayToBytes x -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= getArrayBytes itemType x = do 	let vs = T.arrayItems x 	s <- ST.get@@ -1710,13 +1721,13 @@  @ Unmarshaling is much easier, especially if it's a byte array. -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalArray :: T.Type -> Unmarshal T.Array unmarshalArray T.DBusByte = do 	byteCount <- unmarshalWord32 	T.arrayFromBytes `fmap` consume (fromIntegral byteCount) -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalArray itemType = do 	let getOffset = do 		(UnmarshalState _ _ o) <- ST.get@@ -1795,7 +1806,7 @@ import Data.Bits ((.|.), (.&.)) import qualified Data.Set as Set -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= encodeFlags :: Set.Set M.Flag -> Word8 encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where 	flagValue M.NoReplyExpected = 0x1@@ -1810,7 +1821,7 @@  @ \subsubsection{Header fields} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= encodeField :: M.HeaderField -> T.Structure encodeField (M.Path x)        = encodeField' 1 x encodeField (M.Interface x)   = encodeField' 2 x@@ -1827,7 +1838,7 @@ 	, T.toVariant $ T.toVariant x 	] -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= decodeField :: Monad m => T.Structure             -> E.ErrorT UnmarshalError m [M.HeaderField] decodeField struct = case unpackField struct of@@ -1847,7 +1858,7 @@ 	Just x' -> return [f x'] 	Nothing -> E.throwError $ InvalidHeaderField label x -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unpackField :: T.Structure -> (Word8, T.Variant) unpackField struct = (c', v') where 	T.Structure [c, v] = struct@@ -1863,7 +1874,7 @@ <<wire exports>>= , marshalMessage -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalMessage :: M.Message a => Endianness -> M.Serial -> a                -> Either MarshalError L.ByteString marshalMessage e serial msg = runMarshal marshaler e where@@ -1882,7 +1893,7 @@ 		append bodyBytes 		checkMaximumSize -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= checkBodySig :: [T.Variant] -> MarshalM T.Signature checkBodySig vs = let 	sigStr = TL.concat . map (T.typeCode . T.variantType) $ vs@@ -1891,7 +1902,7 @@ 		Just x -> return x 		Nothing -> invalid -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32               -> Marshal marshalHeader msg serial bodySig bodyLength = do@@ -1905,11 +1916,11 @@ 	marshal . T.toVariant . fromJust . T.toArray fieldType 	        $ map encodeField fields -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= marshalEndianness :: Endianness -> Marshal marshalEndianness = marshal . T.toVariant . encodeEndianness -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= checkMaximumSize :: Marshal checkMaximumSize = do 	(MarshalState _ _ messageLength) <- ST.get@@ -1921,7 +1932,7 @@ <<wire exports>>= , unmarshalMessage -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= unmarshalMessage :: Monad m => (Word32 -> m L.ByteString)                  -> m (Either UnmarshalError M.ReceivedMessage) unmarshalMessage getBytes' = E.runErrorT $ do@@ -1999,7 +2010,7 @@ let bodyPadding = padding (fromIntegral fieldByteCount + 16) 8 getBytes . fromIntegral $ bodyPadding -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= findBodySignature :: [M.HeaderField] -> T.Signature findBodySignature fields = fromMaybe empty signature where 	empty = T.mkSignature' ""@@ -2027,14 +2038,14 @@  @ This really belongs in the Message section... -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage :: Word8 -> [M.HeaderField] -> Either Text                          (M.Serial -> (Set.Set M.Flag) -> [T.Variant]                          -> M.ReceivedMessage)  @ Method calls -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage 1 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -2047,7 +2058,7 @@  @ Method returns -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage 2 fields = do 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields] 	return $ \serial _ body -> let@@ -2058,7 +2069,7 @@  @ Errors -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage 3 fields = do 	name <- require "error name" [x | M.ErrorName x <- fields] 	replySerial <- require "reply serial" [x | M.ReplySerial x <- fields]@@ -2070,7 +2081,7 @@  @ Signals -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage 4 fields = do 	path <- require "path" [x | M.Path x <- fields] 	member <- require "member name" [x | M.Member x <- fields]@@ -2083,20 +2094,20 @@  @ Unknown -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= buildReceivedMessage typeCode fields = return $ \serial flags body -> let 	sender = listToMaybe [x | M.Sender x <- fields] 	msg = M.Unknown typeCode flags body 	in M.ReceivedUnknown serial sender msg -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= require :: Text -> [a] -> Either Text a require _     (x:_) = Right x require label _     = Left label  @ This is just needed for the Monad instance of {\tt Either Text} -<<DBus/Wire.hs>>=+<<DBus/Wire/Internal.hs>>= instance E.Error Text where 	strMsg = TL.pack @@ -2455,8 +2466,6 @@  <<connection exports>>= , ConnectionError (..)-, W.MarshalError (..)-, W.UnmarshalError (..)  @ \subsection{Establishing a connection} 

@@ -22,8 +22,6 @@         (   Connection            , ConnectionError (..)-          , W.MarshalError (..)-          , W.UnmarshalError (..)            , connect           , connectFirst

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

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

@@ -39,7 +39,7 @@ import DBus.Address import DBus.Message.Internal import DBus.Types-import DBus.Wire+import DBus.Wire.Internal import qualified DBus.Introspection as I  tests :: [Test]