#line 89 "src/wire.anansi"
#line 30 "src/introduction.anansi"
#line 90 "src/wire.anansi"
module DBus.Wire.Marshal where
#line 56 "src/introduction.anansi"
import Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as TL
#line 93 "src/wire.anansi"
#line 105 "src/wire.anansi"
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as L
import qualified Data.Binary.Builder as B
#line 514 "src/wire.anansi"
import Data.Binary.Put (runPut)
import qualified Data.Binary.IEEE754 as IEEE
#line 599 "src/wire.anansi"
import DBus.Wire.Unicode (maybeEncodeUtf8)
#line 703 "src/wire.anansi"
import qualified DBus.Constants as C
#line 830 "src/wire.anansi"
import qualified DBus.Message.Internal as M
#line 845 "src/wire.anansi"
import Data.Bits ((.|.))
import qualified Data.Set as Set
#line 94 "src/wire.anansi"
import DBus.Wire.Internal
import Control.Monad (when)
import Data.Maybe (fromJust)
import Data.Word (Word8, Word32, Word64)
import Data.Int (Int64)
import qualified DBus.Types as T
import qualified DBus.Types.Internal as T
#line 111 "src/wire.anansi"
data MarshalState = MarshalState !B.Builder !Word64
data MarshalR a = MarshalRL MarshalError | MarshalRR a !MarshalState
type Marshal = MarshalM ()
newtype MarshalM a = MarshalM { unMarshalM :: Endianness -> MarshalState -> MarshalR a }
instance Monad MarshalM where
return a = MarshalM $ \_ s -> MarshalRR a s
m >>= k = MarshalM $ \e s -> case unMarshalM m e s of
MarshalRL err -> MarshalRL err
MarshalRR a s' -> unMarshalM (k a) e s'
m >> k = MarshalM $ \e s -> case unMarshalM m e s of
MarshalRL err -> MarshalRL err
MarshalRR _ s' -> unMarshalM k e s'
throwError :: MarshalError -> MarshalM a
throwError err = MarshalM $ \_ _ -> MarshalRL err
getState :: MarshalM MarshalState
getState = MarshalM $ \_ s -> MarshalRR s s
putState :: MarshalState -> MarshalM ()
putState s = MarshalM $ \_ _ -> MarshalRR () s
#line 148 "src/wire.anansi"
runMarshal :: Marshal -> Endianness -> Either MarshalError L.ByteString
runMarshal m e = case unMarshalM m e (MarshalState B.empty 0) of
MarshalRL err -> Left err
MarshalRR _ (MarshalState builder _) -> Right $ B.toLazyByteString builder
#line 155 "src/wire.anansi"
marshal :: T.Variant -> Marshal
marshal v = case v of
#line 483 "src/wire.anansi"
T.VarBoxWord8 x -> marshalWord8 x
T.VarBoxWord16 x -> marshalBuilder 2 B.putWord16be B.putWord16le x
T.VarBoxWord32 x -> marshalWord32 x
T.VarBoxWord64 x -> marshalBuilder 8 B.putWord64be B.putWord64le x
T.VarBoxInt16 x -> marshalBuilder 2 B.putWord16be B.putWord16le $ fromIntegral x
T.VarBoxInt32 x -> marshalBuilder 4 B.putWord32be B.putWord32le $ fromIntegral x
T.VarBoxInt64 x -> marshalBuilder 8 B.putWord64be B.putWord64le $ fromIntegral x
#line 523 "src/wire.anansi"
T.VarBoxDouble x -> marshalDouble x
#line 552 "src/wire.anansi"
T.VarBoxBool x -> marshalWord32 $ if x then 1 else 0
#line 634 "src/wire.anansi"
T.VarBoxString x -> marshalText x
T.VarBoxObjectPath x -> marshalText . T.strObjectPath $ x
#line 675 "src/wire.anansi"
T.VarBoxSignature x -> marshalSignature x
#line 691 "src/wire.anansi"
T.VarBoxArray x -> marshalArray x
#line 773 "src/wire.anansi"
T.VarBoxDictionary x -> marshalArray (T.dictionaryToArray x)
#line 790 "src/wire.anansi"
T.VarBoxStructure (T.Structure vs) -> do
pad 8
mapM_ marshal vs
#line 808 "src/wire.anansi"
T.VarBoxVariant x -> do
let textSig = T.typeCode . T.variantType $ x
sig <- case T.variantSignature x of
Just x' -> return x'
Nothing -> throwError $ InvalidVariantSignature textSig
marshalSignature sig
marshal x
#line 163 "src/wire.anansi"
appendS :: BS.ByteString -> Marshal
appendS bytes = MarshalM $ \_ (MarshalState builder count) -> let
builder' = B.append builder $ B.fromByteString bytes
count' = count + fromIntegral (BS.length bytes)
in MarshalRR () (MarshalState builder' count')
#line 171 "src/wire.anansi"
appendL :: L.ByteString -> Marshal
appendL bytes = MarshalM $ \_ (MarshalState builder count) -> let
builder' = B.append builder $ B.fromLazyByteString bytes
count' = count + fromIntegral (L.length bytes)
in MarshalRR () (MarshalState builder' count')
#line 179 "src/wire.anansi"
pad :: Word8 -> Marshal
pad count = MarshalM $ \e s@(MarshalState _ existing) -> let
padding' = fromIntegral $ padding existing count
bytes = BS.replicate padding' 0
in unMarshalM (appendS bytes) e s
#line 190 "src/wire.anansi"
marshalBuilder :: Word8 -> (a -> B.Builder) -> (a -> B.Builder) -> a -> Marshal
marshalBuilder size be le x = do
pad size
MarshalM $ \e (MarshalState builder count) -> let
builder' = B.append builder $ case e of
BigEndian -> be x
LittleEndian -> le x
size' = fromIntegral size
in MarshalRR () (MarshalState builder' (count + size'))
#line 216 "src/wire.anansi"
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]
#line 465 "src/wire.anansi"
marshalWord32 :: Word32 -> Marshal
marshalWord32 = marshalBuilder 4 B.putWord32be B.putWord32le
#line 470 "src/wire.anansi"
marshalWord8 :: Word8 -> Marshal
marshalWord8 x = MarshalM $ \_ (MarshalState builder count) -> let
builder' = B.append builder $ B.singleton x
in MarshalRR () (MarshalState builder' (count + 1))
#line 527 "src/wire.anansi"
marshalDouble :: Double -> Marshal
marshalDouble x = do
pad 8
MarshalM $ \e s -> let
put = case e of
BigEndian -> IEEE.putFloat64be
LittleEndian -> IEEE.putFloat64le
bytes = runPut $ put x
in unMarshalM (appendL bytes) e s
#line 603 "src/wire.anansi"
marshalText :: Text -> Marshal
marshalText x = do
bytes <- case maybeEncodeUtf8 x of
Just x' -> return x'
Nothing -> throwError $ InvalidText x
when (L.any (== 0) bytes) $
throwError $ InvalidText x
marshalWord32 . fromIntegral . L.length $ bytes
appendL bytes
marshalWord8 0
#line 651 "src/wire.anansi"
marshalSignature :: T.Signature -> Marshal
marshalSignature x = do
let bytes = T.bytesSignature x
let size = fromIntegral . BS.length $ bytes
marshalWord8 size
appendS bytes
marshalWord8 0
#line 707 "src/wire.anansi"
marshalArray :: T.Array -> Marshal
marshalArray x = do
(arrayPadding, arrayBytes) <- getArrayBytes (T.arrayType x) x
let arrayLen = L.length arrayBytes
when (arrayLen > fromIntegral C.arrayMaximumLength)
(throwError $ ArrayTooLong $ fromIntegral arrayLen)
marshalWord32 $ fromIntegral arrayLen
appendL $ L.replicate arrayPadding 0
appendL arrayBytes
#line 719 "src/wire.anansi"
getArrayBytes :: T.Type -> T.Array -> MarshalM (Int64, L.ByteString)
getArrayBytes T.DBusByte x = return (0, bytes) where
Just bytes = T.arrayToBytes x
#line 725 "src/wire.anansi"
getArrayBytes itemType x = do
let vs = T.arrayItems x
s <- getState
(MarshalState _ afterLength) <- marshalWord32 0 >> getState
(MarshalState _ afterPadding) <- pad (alignment itemType) >> getState
putState $ MarshalState B.empty afterPadding
(MarshalState itemBuilder _) <- mapM_ marshal vs >> getState
let itemBytes = B.toLazyByteString itemBuilder
paddingSize = fromIntegral $ afterPadding afterLength
putState s
return (paddingSize, itemBytes)
#line 850 "src/wire.anansi"
encodeFlags :: Set.Set M.Flag -> Word8
encodeFlags flags = foldr (.|.) 0 $ map flagValue $ Set.toList flags where
flagValue M.NoReplyExpected = 0x1
flagValue M.NoAutoStart = 0x2
#line 868 "src/wire.anansi"
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
]
#line 925 "src/wire.anansi"
#line 163 "src/api-docs.anansi"
#line 926 "src/wire.anansi"
marshalMessage :: M.Message a => Endianness -> M.Serial -> a
-> Either MarshalError L.ByteString
marshalMessage e serial msg = runMarshal marshaler e where
body = M.messageBody msg
marshaler = do
sig <- checkBodySig body
empty <- getState
mapM_ marshal body
(MarshalState bodyBytesB _) <- getState
putState empty
marshalEndianness e
let bodyBytes = B.toLazyByteString bodyBytesB
marshalHeader msg serial sig
$ fromIntegral . L.length $ bodyBytes
pad 8
appendL bodyBytes
checkMaximumSize
#line 946 "src/wire.anansi"
checkBodySig :: [T.Variant] -> MarshalM T.Signature
checkBodySig vs = let
textSig = TL.concat . map (T.typeCode . T.variantType) $ vs
bytesSig = BS.concat . map (T.typeCodeB . T.variantType) $ vs
invalid = throwError $ InvalidBodySignature textSig
in case T.mkBytesSignature bytesSig of
Just x -> return x
Nothing -> invalid
#line 957 "src/wire.anansi"
marshalHeader :: M.Message a => a -> M.Serial -> T.Signature -> Word32
-> Marshal
marshalHeader msg serial bodySig bodyLength = do
let fields = M.Signature bodySig : M.messageHeaderFields msg
marshalWord8 . M.messageTypeCode $ msg
marshalWord8 . encodeFlags . M.messageFlags $ msg
marshalWord8 C.protocolVersion
marshalWord32 bodyLength
marshalWord32 . M.serialValue $ serial
let fieldType = T.DBusStructure [T.DBusByte, T.DBusVariant]
marshalArray . fromJust . T.toArray fieldType
$ map encodeField fields
#line 972 "src/wire.anansi"
marshalEndianness :: Endianness -> Marshal
marshalEndianness = marshal . T.toVariant . encodeEndianness
#line 977 "src/wire.anansi"
checkMaximumSize :: Marshal
checkMaximumSize = do
(MarshalState _ messageLength) <- getState
when (messageLength > fromIntegral C.messageMaximumLength)
(throwError $ MessageTooLong $ fromIntegral messageLength)