-- Copyright (C) 2009-2012 John Millikin <john@john-millikin.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/>.

module DBus.Internal.Wire
    ( Endianness(..)
    , MarshalError
    , marshalErrorMessage

    , UnmarshalError
    , unmarshalErrorMessage

    , marshalMessage
    , unmarshalMessage
    , unmarshalMessageM
    ) where

import qualified Control.Applicative
import           Control.Monad (ap, liftM, when, unless)
import qualified Data.ByteString
import           Data.ByteString (ByteString)
import qualified Data.ByteString.Builder as Builder
import qualified Data.ByteString.Char8
import qualified Data.ByteString.Lazy as Lazy
import           Data.Int (Int16, Int32, Int64)
import qualified Data.Map
import           Data.Map (Map)
import           Data.Maybe (fromJust, listToMaybe, fromMaybe)
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text.Encoding
import qualified Data.Vector
import           Data.Vector (Vector)
import           Data.Word (Word8, Word16, Word32, Word64)
import           Foreign.C.Types (CInt)
import           System.Posix.Types (Fd(..))
import           Prelude

import qualified Data.Serialize.Get as Get
import           Data.Serialize.IEEE754 (getFloat64be, getFloat64le, putFloat64be, putFloat64le)
import           Data.Serialize.Put (runPut)

import           DBus.Internal.Message
import           DBus.Internal.Types

data Endianness = LittleEndian | BigEndian
    deriving (Int -> Endianness -> ShowS
[Endianness] -> ShowS
Endianness -> String
(Int -> Endianness -> ShowS)
-> (Endianness -> String)
-> ([Endianness] -> ShowS)
-> Show Endianness
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Endianness] -> ShowS
$cshowList :: [Endianness] -> ShowS
show :: Endianness -> String
$cshow :: Endianness -> String
showsPrec :: Int -> Endianness -> ShowS
$cshowsPrec :: Int -> Endianness -> ShowS
Show, Endianness -> Endianness -> Bool
(Endianness -> Endianness -> Bool)
-> (Endianness -> Endianness -> Bool) -> Eq Endianness
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Endianness -> Endianness -> Bool
$c/= :: Endianness -> Endianness -> Bool
== :: Endianness -> Endianness -> Bool
$c== :: Endianness -> Endianness -> Bool
Eq)

encodeEndianness :: Endianness -> Word8
encodeEndianness :: Endianness -> Word8
encodeEndianness Endianness
LittleEndian = Word8
0x6C
encodeEndianness Endianness
BigEndian    = Word8
0x42

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

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

{-# INLINE padding #-}
padding :: Word64 -> Word8 -> Word64
padding :: Word64 -> Word8 -> Word64
padding Word64
current Word8
count = Word64
required where
    count' :: Word64
count' = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
count
    missing :: Word64
missing = Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
mod Word64
current Word64
count'
    required :: Word64
required = if Word64
missing Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
0
        then Word64
count' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
missing
        else Word64
0

data WireR s a
    = WireRL String
    | WireRR a !s

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

instance Functor (Wire s) where
    {-# INLINE fmap #-}
    fmap :: (a -> b) -> Wire s a -> Wire s b
fmap = (a -> b) -> Wire s a -> Wire s b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Control.Applicative.Applicative (Wire s) where
    {-# INLINE pure #-}
    pure :: a -> Wire s a
pure = a -> Wire s a
forall (m :: * -> *) a. Monad m => a -> m a
return

    {-# INLINE (<*>) #-}
    <*> :: Wire s (a -> b) -> Wire s a -> Wire s b
(<*>) = Wire s (a -> b) -> Wire s a -> Wire s b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (Wire s) where
    {-# INLINE return #-}
    return :: a -> Wire s a
return a
a = (Endianness -> s -> WireR s a) -> Wire s a
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ s
s -> a -> s -> WireR s a
forall s a. a -> s -> WireR s a
WireRR a
a s
s)

    {-# INLINE (>>=) #-}
    Wire s a
m >>= :: Wire s a -> (a -> Wire s b) -> Wire s b
>>= a -> Wire s b
k = (Endianness -> s -> WireR s b) -> Wire s b
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire ((Endianness -> s -> WireR s b) -> Wire s b)
-> (Endianness -> s -> WireR s b) -> Wire s b
forall a b. (a -> b) -> a -> b
$ \Endianness
e s
s -> case Wire s a -> Endianness -> s -> WireR s a
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire Wire s a
m Endianness
e s
s of
        WireRL String
err -> String -> WireR s b
forall s a. String -> WireR s a
WireRL String
err
        WireRR a
a s
s' -> Wire s b -> Endianness -> s -> WireR s b
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire (a -> Wire s b
k a
a) Endianness
e s
s'

    {-# INLINE (>>) #-}
    Wire s a
m >> :: Wire s a -> Wire s b -> Wire s b
>> Wire s b
k = (Endianness -> s -> WireR s b) -> Wire s b
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire ((Endianness -> s -> WireR s b) -> Wire s b)
-> (Endianness -> s -> WireR s b) -> Wire s b
forall a b. (a -> b) -> a -> b
$ \Endianness
e s
s -> case Wire s a -> Endianness -> s -> WireR s a
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire Wire s a
m Endianness
e s
s of
        WireRL String
err -> String -> WireR s b
forall s a. String -> WireR s a
WireRL String
err
        WireRR a
_ s
s' -> Wire s b -> Endianness -> s -> WireR s b
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire Wire s b
k Endianness
e s
s'

throwError :: String -> Wire s a
throwError :: String -> Wire s a
throwError String
err = (Endianness -> s -> WireR s a) -> Wire s a
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ s
_ -> String -> WireR s a
forall s a. String -> WireR s a
WireRL String
err)

{-# INLINE getState #-}
getState :: Wire s s
getState :: Wire s s
getState = (Endianness -> s -> WireR s s) -> Wire s s
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ s
s -> s -> s -> WireR s s
forall s a. a -> s -> WireR s a
WireRR s
s s
s)

{-# INLINE putState #-}
putState :: s -> Wire s ()
putState :: s -> Wire s ()
putState s
s = (Endianness -> s -> WireR s ()) -> Wire s ()
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ s
_ -> () -> s -> WireR s ()
forall s a. a -> s -> WireR s a
WireRR () s
s)

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

type Marshal = Wire MarshalState

newtype MarshalError = MarshalError String
    deriving (Int -> MarshalError -> ShowS
[MarshalError] -> ShowS
MarshalError -> String
(Int -> MarshalError -> ShowS)
-> (MarshalError -> String)
-> ([MarshalError] -> ShowS)
-> Show MarshalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MarshalError] -> ShowS
$cshowList :: [MarshalError] -> ShowS
show :: MarshalError -> String
$cshow :: MarshalError -> String
showsPrec :: Int -> MarshalError -> ShowS
$cshowsPrec :: Int -> MarshalError -> ShowS
Show, MarshalError -> MarshalError -> Bool
(MarshalError -> MarshalError -> Bool)
-> (MarshalError -> MarshalError -> Bool) -> Eq MarshalError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MarshalError -> MarshalError -> Bool
$c/= :: MarshalError -> MarshalError -> Bool
== :: MarshalError -> MarshalError -> Bool
$c== :: MarshalError -> MarshalError -> Bool
Eq)

marshalErrorMessage :: MarshalError -> String
marshalErrorMessage :: MarshalError -> String
marshalErrorMessage (MarshalError String
s) = String
s

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

marshal :: Value -> Marshal ()
marshal :: Value -> Marshal ()
marshal (ValueAtom Atom
x) = Atom -> Marshal ()
marshalAtom Atom
x
marshal (ValueBytes ByteString
xs) = ByteString -> Marshal ()
marshalStrictBytes ByteString
xs
marshal (ValueVector Type
t Vector Value
xs) = Type -> Vector Value -> Marshal ()
marshalVector Type
t Vector Value
xs
marshal (ValueMap Type
kt Type
vt Map Atom Value
xs) = Type -> Type -> Map Atom Value -> Marshal ()
marshalMap Type
kt Type
vt Map Atom Value
xs
marshal (ValueStructure [Value]
xs) = [Value] -> Marshal ()
marshalStructure [Value]
xs
marshal (ValueVariant Variant
x) = Variant -> Marshal ()
marshalVariant Variant
x

marshalAtom :: Atom -> Marshal ()
marshalAtom :: Atom -> Marshal ()
marshalAtom (AtomWord8 Word8
x) = Word8 -> Marshal ()
marshalWord8 Word8
x
marshalAtom (AtomWord16 Word16
x) = Word16 -> Marshal ()
marshalWord16 Word16
x
marshalAtom (AtomWord32 Word32
x) = Word32 -> Marshal ()
marshalWord32 Word32
x
marshalAtom (AtomWord64 Word64
x) = Word64 -> Marshal ()
marshalWord64 Word64
x
marshalAtom (AtomInt16 Int16
x) = Int16 -> Marshal ()
marshalInt16 Int16
x
marshalAtom (AtomInt32 Int32
x) = Int32 -> Marshal ()
marshalInt32 Int32
x
marshalAtom (AtomInt64 Int64
x) = Int64 -> Marshal ()
marshalInt64 Int64
x
marshalAtom (AtomDouble Double
x) = Double -> Marshal ()
marshalDouble Double
x
marshalAtom (AtomUnixFd Fd
x) = Fd -> Marshal ()
marshalUnixFd Fd
x
marshalAtom (AtomBool Bool
x) = Bool -> Marshal ()
marshalBool Bool
x
marshalAtom (AtomText Text
x) = Text -> Marshal ()
marshalText Text
x
marshalAtom (AtomObjectPath ObjectPath
x) = ObjectPath -> Marshal ()
marshalObjectPath ObjectPath
x
marshalAtom (AtomSignature Signature
x) = Signature -> Marshal ()
marshalSignature Signature
x

appendB :: Word64 -> Builder.Builder -> Marshal ()
appendB :: Word64 -> Builder -> Marshal ()
appendB Word64
size Builder
bytes = (Endianness -> MarshalState -> WireR MarshalState ()) -> Marshal ()
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ (MarshalState Builder
builder Word64
count) -> let
    builder' :: Builder
builder' = Builder -> Builder -> Builder
forall a. Monoid a => a -> a -> a
mappend Builder
builder Builder
bytes
    count' :: Word64
count' = Word64
count Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
size
    in () -> MarshalState -> WireR MarshalState ()
forall s a. a -> s -> WireR s a
WireRR () (Builder -> Word64 -> MarshalState
MarshalState Builder
builder' Word64
count'))

appendS :: ByteString -> Marshal ()
appendS :: ByteString -> Marshal ()
appendS ByteString
bytes = Word64 -> Builder -> Marshal ()
appendB
    (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
Data.ByteString.length ByteString
bytes))
    (ByteString -> Builder
Builder.byteString ByteString
bytes)

appendL :: Lazy.ByteString -> Marshal ()
appendL :: ByteString -> Marshal ()
appendL ByteString
bytes = Word64 -> Builder -> Marshal ()
appendB
    (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
Lazy.length ByteString
bytes))
    (ByteString -> Builder
Builder.lazyByteString ByteString
bytes)

pad :: Word8 -> Marshal ()
pad :: Word8 -> Marshal ()
pad Word8
count = do
    (MarshalState Builder
_ Word64
existing) <- Wire MarshalState MarshalState
forall s. Wire s s
getState
    let padding' :: Int
padding' = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64 -> Word8 -> Word64
padding Word64
existing Word8
count)
    ByteString -> Marshal ()
appendS (Int -> Word8 -> ByteString
Data.ByteString.replicate Int
padding' Word8
0)

marshalBuilder :: Word8
               -> (a -> Builder.Builder)
               -> (a -> Builder.Builder)
               -> a -> Marshal ()
marshalBuilder :: Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder Word8
size a -> Builder
be a -> Builder
le a
x = do
    Builder
builder <- Builder -> Builder -> Wire MarshalState Builder
forall a s. a -> a -> Wire s a
chooseEndian (a -> Builder
be a
x) (a -> Builder
le a
x)
    Word8 -> Marshal ()
pad Word8
size
    Word64 -> Builder -> Marshal ()
appendB (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
size) Builder
builder

type Unmarshal = Wire UnmarshalState

newtype UnmarshalError = UnmarshalError String
    deriving (Int -> UnmarshalError -> ShowS
[UnmarshalError] -> ShowS
UnmarshalError -> String
(Int -> UnmarshalError -> ShowS)
-> (UnmarshalError -> String)
-> ([UnmarshalError] -> ShowS)
-> Show UnmarshalError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UnmarshalError] -> ShowS
$cshowList :: [UnmarshalError] -> ShowS
show :: UnmarshalError -> String
$cshow :: UnmarshalError -> String
showsPrec :: Int -> UnmarshalError -> ShowS
$cshowsPrec :: Int -> UnmarshalError -> ShowS
Show, UnmarshalError -> UnmarshalError -> Bool
(UnmarshalError -> UnmarshalError -> Bool)
-> (UnmarshalError -> UnmarshalError -> Bool) -> Eq UnmarshalError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnmarshalError -> UnmarshalError -> Bool
$c/= :: UnmarshalError -> UnmarshalError -> Bool
== :: UnmarshalError -> UnmarshalError -> Bool
$c== :: UnmarshalError -> UnmarshalError -> Bool
Eq)

unmarshalErrorMessage :: UnmarshalError -> String
unmarshalErrorMessage :: UnmarshalError -> String
unmarshalErrorMessage (UnmarshalError String
s) = String
s

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

unmarshal :: Type -> Unmarshal Value
unmarshal :: Type -> Unmarshal Value
unmarshal Type
TypeWord8 = (Word8 -> Value) -> Wire UnmarshalState Word8 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word8 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Word8
unmarshalWord8
unmarshal Type
TypeWord16 = (Word16 -> Value) -> Wire UnmarshalState Word16 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word16 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Word16
unmarshalWord16
unmarshal Type
TypeWord32 = (Word32 -> Value) -> Wire UnmarshalState Word32 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word32 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Word32
unmarshalWord32
unmarshal Type
TypeWord64 = (Word64 -> Value) -> Wire UnmarshalState Word64 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Word64
unmarshalWord64
unmarshal Type
TypeInt16 = (Int16 -> Value) -> Wire UnmarshalState Int16 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int16 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Int16
unmarshalInt16
unmarshal Type
TypeInt32 = (Int32 -> Value) -> Wire UnmarshalState Int32 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int32 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Int32
unmarshalInt32
unmarshal Type
TypeInt64 = (Int64 -> Value) -> Wire UnmarshalState Int64 -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Int64 -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Int64
unmarshalInt64
unmarshal Type
TypeDouble = (Double -> Value) -> Wire UnmarshalState Double -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Double -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Double
unmarshalDouble
unmarshal Type
TypeUnixFd = (Fd -> Value) -> Wire UnmarshalState Fd -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Fd -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Fd
unmarshalUnixFd
unmarshal Type
TypeBoolean = (Bool -> Value) -> Wire UnmarshalState Bool -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Bool
unmarshalBool
unmarshal Type
TypeString = (Text -> Value) -> Wire UnmarshalState Text -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Text -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Text
unmarshalText
unmarshal Type
TypeObjectPath = (ObjectPath -> Value)
-> Wire UnmarshalState ObjectPath -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ObjectPath -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState ObjectPath
unmarshalObjectPath
unmarshal Type
TypeSignature = (Signature -> Value)
-> Wire UnmarshalState Signature -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Signature -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState Signature
unmarshalSignature
unmarshal (TypeArray Type
TypeWord8) = (ByteString -> Value)
-> Wire UnmarshalState ByteString -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Value
forall a. IsValue a => a -> Value
toValue Wire UnmarshalState ByteString
unmarshalByteArray
unmarshal (TypeArray Type
t) = (Vector Value -> Value)
-> Wire UnmarshalState (Vector Value) -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Type -> Vector Value -> Value
ValueVector Type
t) (Type -> Wire UnmarshalState (Vector Value)
unmarshalArray Type
t)
unmarshal (TypeDictionary Type
kt Type
vt) = Type -> Type -> Unmarshal Value
unmarshalDictionary Type
kt Type
vt
unmarshal (TypeStructure [Type]
ts) = [Type] -> Unmarshal Value
unmarshalStructure [Type]
ts
unmarshal Type
TypeVariant = Unmarshal Value
unmarshalVariant

{-# INLINE consume #-}
consume :: Word64 -> Unmarshal ByteString
consume :: Word64 -> Wire UnmarshalState ByteString
consume Word64
count = do
    (UnmarshalState ByteString
bytes Word64
offset) <- Wire UnmarshalState UnmarshalState
forall s. Wire s s
getState
    let count' :: Int
count' = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
count
    let (ByteString
x, ByteString
bytes') = Int -> ByteString -> (ByteString, ByteString)
Data.ByteString.splitAt Int
count' ByteString
bytes
    let lenConsumed :: Int
lenConsumed = ByteString -> Int
Data.ByteString.length ByteString
x
    if Int
lenConsumed Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
count'
        then do
            UnmarshalState -> Wire UnmarshalState ()
forall s. s -> Wire s ()
putState (ByteString -> Word64 -> UnmarshalState
UnmarshalState ByteString
bytes' (Word64
offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
count))
            ByteString -> Wire UnmarshalState ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
        else String -> Wire UnmarshalState ByteString
forall s a. String -> Wire s a
throwError (String
"Unexpected EOF at offset " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show (Word64
offset Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenConsumed))

skipPadding :: Word8 -> Unmarshal ()
skipPadding :: Word8 -> Wire UnmarshalState ()
skipPadding Word8
count = do
    (UnmarshalState ByteString
_ Word64
offset) <- Wire UnmarshalState UnmarshalState
forall s. Wire s s
getState
    ByteString
bytes <- Word64 -> Wire UnmarshalState ByteString
consume (Word64 -> Word8 -> Word64
padding Word64
offset Word8
count)
    Bool -> Wire UnmarshalState () -> Wire UnmarshalState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ((Word8 -> Bool) -> ByteString -> Bool
Data.ByteString.all (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bytes)
        (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError (String
"Value padding " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
bytes String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" contains invalid bytes."))

skipTerminator :: Unmarshal ()
skipTerminator :: Wire UnmarshalState ()
skipTerminator = do
    Word8
byte <- Wire UnmarshalState Word8
unmarshalWord8
    Bool -> Wire UnmarshalState () -> Wire UnmarshalState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
byte Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
0) (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError String
"Textual value is not NUL-terminated.")

fromMaybeU :: Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU :: String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
label a -> Maybe b
f a
x = case a -> Maybe b
f a
x of
    Just b
x' -> b -> Unmarshal b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x'
    Maybe b
Nothing -> String -> Unmarshal b
forall s a. String -> Wire s a
throwError (String
"Invalid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
": " String -> ShowS
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
x)

unmarshalGet :: Word8 -> Get.Get a -> Get.Get a -> Unmarshal a
unmarshalGet :: Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
count Get a
be Get a
le = do
    Word8 -> Wire UnmarshalState ()
skipPadding Word8
count
    ByteString
bytes <- Word64 -> Wire UnmarshalState ByteString
consume (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
count)
    Get a
get <- Get a -> Get a -> Wire UnmarshalState (Get a)
forall a s. a -> a -> Wire s a
chooseEndian Get a
be Get a
le
    let Right a
ret = Get a -> ByteString -> Either String a
forall a. Get a -> ByteString -> Either String a
Get.runGet Get a
get ByteString
bytes
    a -> Unmarshal a
forall (m :: * -> *) a. Monad m => a -> m a
return a
ret

marshalWord8 :: Word8 -> Marshal ()
marshalWord8 :: Word8 -> Marshal ()
marshalWord8 Word8
x = Word64 -> Builder -> Marshal ()
appendB Word64
1 (Word8 -> Builder
Builder.word8 Word8
x)

unmarshalWord8 :: Unmarshal Word8
unmarshalWord8 :: Wire UnmarshalState Word8
unmarshalWord8 = (ByteString -> Word8)
-> Wire UnmarshalState ByteString -> Wire UnmarshalState Word8
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Word8
Data.ByteString.head (Word64 -> Wire UnmarshalState ByteString
consume Word64
1)

marshalWord16 :: Word16 -> Marshal ()
marshalWord16 :: Word16 -> Marshal ()
marshalWord16 = Word8
-> (Word16 -> Builder)
-> (Word16 -> Builder)
-> Word16
-> Marshal ()
forall a.
Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder Word8
2
    Word16 -> Builder
Builder.word16BE
    Word16 -> Builder
Builder.word16LE

marshalWord32 :: Word32 -> Marshal ()
marshalWord32 :: Word32 -> Marshal ()
marshalWord32 = Word8
-> (Word32 -> Builder)
-> (Word32 -> Builder)
-> Word32
-> Marshal ()
forall a.
Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder Word8
4
    Word32 -> Builder
Builder.word32BE
    Word32 -> Builder
Builder.word32LE

marshalWord64 :: Word64 -> Marshal ()
marshalWord64 :: Word64 -> Marshal ()
marshalWord64 = Word8
-> (Word64 -> Builder)
-> (Word64 -> Builder)
-> Word64
-> Marshal ()
forall a.
Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder Word8
8
    Word64 -> Builder
Builder.word64BE
    Word64 -> Builder
Builder.word64LE

marshalInt16 :: Int16 -> Marshal ()
marshalInt16 :: Int16 -> Marshal ()
marshalInt16 = Word16 -> Marshal ()
marshalWord16 (Word16 -> Marshal ()) -> (Int16 -> Word16) -> Int16 -> Marshal ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int16 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral

marshalInt32 :: Int32 -> Marshal ()
marshalInt32 :: Int32 -> Marshal ()
marshalInt32 = Word32 -> Marshal ()
marshalWord32 (Word32 -> Marshal ()) -> (Int32 -> Word32) -> Int32 -> Marshal ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral

marshalInt64 :: Int64 -> Marshal ()
marshalInt64 :: Int64 -> Marshal ()
marshalInt64 = Word64 -> Marshal ()
marshalWord64 (Word64 -> Marshal ()) -> (Int64 -> Word64) -> Int64 -> Marshal ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral

unmarshalWord16 :: Unmarshal Word16
unmarshalWord16 :: Wire UnmarshalState Word16
unmarshalWord16 = Word8 -> Get Word16 -> Get Word16 -> Wire UnmarshalState Word16
forall a. Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
2
    Get Word16
Get.getWord16be
    Get Word16
Get.getWord16le

unmarshalWord32 :: Unmarshal Word32
unmarshalWord32 :: Wire UnmarshalState Word32
unmarshalWord32 = Word8 -> Get Word32 -> Get Word32 -> Wire UnmarshalState Word32
forall a. Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
4
    Get Word32
Get.getWord32be
    Get Word32
Get.getWord32le

unmarshalWord64 :: Unmarshal Word64
unmarshalWord64 :: Wire UnmarshalState Word64
unmarshalWord64 = Word8 -> Get Word64 -> Get Word64 -> Wire UnmarshalState Word64
forall a. Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
8
    Get Word64
Get.getWord64be
    Get Word64
Get.getWord64le

unmarshalInt16 :: Unmarshal Int16
unmarshalInt16 :: Wire UnmarshalState Int16
unmarshalInt16 = (Word16 -> Int16)
-> Wire UnmarshalState Word16 -> Wire UnmarshalState Int16
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word16 -> Int16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Wire UnmarshalState Word16
unmarshalWord16

unmarshalInt32 :: Unmarshal Int32
unmarshalInt32 :: Wire UnmarshalState Int32
unmarshalInt32 = (Word32 -> Int32)
-> Wire UnmarshalState Word32 -> Wire UnmarshalState Int32
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word32 -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Wire UnmarshalState Word32
unmarshalWord32

unmarshalInt64 :: Unmarshal Int64
unmarshalInt64 :: Wire UnmarshalState Int64
unmarshalInt64 = (Word64 -> Int64)
-> Wire UnmarshalState Word64 -> Wire UnmarshalState Int64
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Word64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Wire UnmarshalState Word64
unmarshalWord64

marshalDouble :: Double -> Marshal ()
marshalDouble :: Double -> Marshal ()
marshalDouble Double
x = do
    Double -> Put
put <- (Double -> Put)
-> (Double -> Put) -> Wire MarshalState (Double -> Put)
forall a s. a -> a -> Wire s a
chooseEndian Double -> Put
putFloat64be Double -> Put
putFloat64le
    Word8 -> Marshal ()
pad Word8
8
    ByteString -> Marshal ()
appendS (Put -> ByteString
runPut (Double -> Put
put Double
x))

unmarshalDouble :: Unmarshal Double
unmarshalDouble :: Wire UnmarshalState Double
unmarshalDouble = Word8 -> Get Double -> Get Double -> Wire UnmarshalState Double
forall a. Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
8
    Get Double
getFloat64be
    Get Double
getFloat64le

marshalUnixFd :: Fd -> Marshal ()
marshalUnixFd :: Fd -> Marshal ()
marshalUnixFd (Fd CInt
x)
    | CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< CInt
0 = String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"Invalid file descriptor: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
x)
    | CInt -> Integer
forall a. Integral a => a -> Integer
toInteger CInt
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger (Word32
forall a. Bounded a => a
maxBound :: Word32) = String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"D-Bus forbids file descriptors exceeding UINT32_MAX: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
x)
    | Bool
otherwise = Word32 -> Marshal ()
marshalWord32 (CInt -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x)

unmarshalUnixFd :: Unmarshal Fd
unmarshalUnixFd :: Wire UnmarshalState Fd
unmarshalUnixFd = do
    Word32
x <- Wire UnmarshalState Word32
unmarshalWord32
    Bool -> Wire UnmarshalState () -> Wire UnmarshalState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
x Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> CInt -> Integer
forall a. Integral a => a -> Integer
toInteger (CInt
forall a. Bounded a => a
maxBound :: CInt))
        (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError (String
"Invalid file descriptor: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
x))
    Fd -> Wire UnmarshalState Fd
forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Fd
Fd (Word32 -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
x))

marshalBool :: Bool -> Marshal ()
marshalBool :: Bool -> Marshal ()
marshalBool Bool
False = Word32 -> Marshal ()
marshalWord32 Word32
0
marshalBool Bool
True  = Word32 -> Marshal ()
marshalWord32 Word32
1

unmarshalBool :: Unmarshal Bool
unmarshalBool :: Wire UnmarshalState Bool
unmarshalBool = do
    Word32
word <- Wire UnmarshalState Word32
unmarshalWord32
    case Word32
word of
        Word32
0 -> Bool -> Wire UnmarshalState Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Word32
1 -> Bool -> Wire UnmarshalState Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Word32
_ -> String -> Wire UnmarshalState Bool
forall s a. String -> Wire s a
throwError (String
"Invalid boolean: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word32 -> String
forall a. Show a => a -> String
show Word32
word)

marshalText :: Text -> Marshal ()
marshalText :: Text -> Marshal ()
marshalText Text
text = do
    let bytes :: ByteString
bytes = Text -> ByteString
Data.Text.Encoding.encodeUtf8 Text
text
    Bool -> Marshal () -> Marshal ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Word8 -> Bool) -> ByteString -> Bool
Data.ByteString.any (Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bytes)
        (String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"String " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Text -> String
forall a. Show a => a -> String
show Text
text String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" contained forbidden character: '\\x00'"))
    Word32 -> Marshal ()
marshalWord32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
Data.ByteString.length ByteString
bytes))
    ByteString -> Marshal ()
appendS ByteString
bytes
    Word8 -> Marshal ()
marshalWord8 Word8
0

unmarshalText :: Unmarshal Text
unmarshalText :: Wire UnmarshalState Text
unmarshalText = do
    Word32
byteCount <- Wire UnmarshalState Word32
unmarshalWord32
    ByteString
bytes <- Word64 -> Wire UnmarshalState ByteString
consume (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount)
    Wire UnmarshalState ()
skipTerminator
    String
-> (ByteString -> Maybe Text)
-> ByteString
-> Wire UnmarshalState Text
forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"text" ByteString -> Maybe Text
maybeDecodeUtf8 ByteString
bytes

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

marshalObjectPath :: ObjectPath -> Marshal ()
marshalObjectPath :: ObjectPath -> Marshal ()
marshalObjectPath ObjectPath
p = do
    let bytes :: ByteString
bytes = String -> ByteString
Data.ByteString.Char8.pack (ObjectPath -> String
formatObjectPath ObjectPath
p)
    Word32 -> Marshal ()
marshalWord32 (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
Data.ByteString.length ByteString
bytes))
    ByteString -> Marshal ()
appendS ByteString
bytes
    Word8 -> Marshal ()
marshalWord8 Word8
0

unmarshalObjectPath :: Unmarshal ObjectPath
unmarshalObjectPath :: Wire UnmarshalState ObjectPath
unmarshalObjectPath = do
    Word32
byteCount <- Wire UnmarshalState Word32
unmarshalWord32
    ByteString
bytes <- Word64 -> Wire UnmarshalState ByteString
consume (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount)
    Wire UnmarshalState ()
skipTerminator
    String
-> (String -> Maybe ObjectPath)
-> String
-> Wire UnmarshalState ObjectPath
forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"object path" String -> Maybe ObjectPath
forall (m :: * -> *). MonadThrow m => String -> m ObjectPath
parseObjectPath (ByteString -> String
Data.ByteString.Char8.unpack ByteString
bytes)

signatureBytes :: Signature -> ByteString
signatureBytes :: Signature -> ByteString
signatureBytes (Signature [Type]
ts) = String -> ByteString
Data.ByteString.Char8.pack ((Type -> String) -> [Type] -> String
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap Type -> String
typeCode [Type]
ts)

marshalSignature :: Signature -> Marshal ()
marshalSignature :: Signature -> Marshal ()
marshalSignature Signature
x = do
    let bytes :: ByteString
bytes = Signature -> ByteString
signatureBytes Signature
x
    Word8 -> Marshal ()
marshalWord8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
Data.ByteString.length ByteString
bytes))
    ByteString -> Marshal ()
appendS ByteString
bytes
    Word8 -> Marshal ()
marshalWord8 Word8
0

unmarshalSignature :: Unmarshal Signature
unmarshalSignature :: Wire UnmarshalState Signature
unmarshalSignature = do
    Word8
byteCount <- Wire UnmarshalState Word8
unmarshalWord8
    ByteString
bytes <- Word64 -> Wire UnmarshalState ByteString
consume (Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byteCount)
    Wire UnmarshalState ()
skipTerminator
    String
-> (ByteString -> Maybe Signature)
-> ByteString
-> Wire UnmarshalState Signature
forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"signature" ByteString -> Maybe Signature
forall (m :: * -> *). MonadThrow m => ByteString -> m Signature
parseSignatureBytes ByteString
bytes

arrayMaximumLength :: Int64
arrayMaximumLength :: Int64
arrayMaximumLength = Int64
67108864

marshalVector :: Type -> Vector Value -> Marshal ()
marshalVector :: Type -> Vector Value -> Marshal ()
marshalVector Type
t Vector Value
x = do
    (Int
arrayPadding, ByteString
arrayBytes) <- Type -> Vector Value -> Marshal (Int, ByteString)
getArrayBytes Type
t Vector Value
x
    let arrayLen :: Int64
arrayLen = ByteString -> Int64
Lazy.length ByteString
arrayBytes
    Bool -> Marshal () -> Marshal ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
arrayLen Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
arrayMaximumLength) (String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"Marshaled array size (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
arrayLen String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes) exceeds maximum limit of (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
arrayMaximumLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)."))
    Word32 -> Marshal ()
marshalWord32 (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
arrayLen)
    ByteString -> Marshal ()
appendS (Int -> Word8 -> ByteString
Data.ByteString.replicate Int
arrayPadding Word8
0)
    ByteString -> Marshal ()
appendL ByteString
arrayBytes

marshalStrictBytes :: ByteString -> Marshal ()
marshalStrictBytes :: ByteString -> Marshal ()
marshalStrictBytes ByteString
bytes = do
    let arrayLen :: Int64
arrayLen = ByteString -> Int64
Lazy.length (ByteString -> ByteString
Lazy.fromStrict ByteString
bytes)
    Bool -> Marshal () -> Marshal ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64 -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
arrayLen Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
> Int64
arrayMaximumLength) (String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"Marshaled array size (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
arrayLen String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes) exceeds maximum limit of (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Int64 -> String
forall a. Show a => a -> String
show Int64
arrayMaximumLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)."))
    Word32 -> Marshal ()
marshalWord32 (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
arrayLen)
    ByteString -> Marshal ()
appendS ByteString
bytes

getArrayBytes :: Type -> Vector Value -> Marshal (Int, Lazy.ByteString)
getArrayBytes :: Type -> Vector Value -> Marshal (Int, ByteString)
getArrayBytes Type
itemType Vector Value
vs = do
    MarshalState
s <- Wire MarshalState MarshalState
forall s. Wire s s
getState
    (MarshalState Builder
_ Word64
afterLength) <- Word32 -> Marshal ()
marshalWord32 Word32
0 Marshal ()
-> Wire MarshalState MarshalState -> Wire MarshalState MarshalState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Wire MarshalState MarshalState
forall s. Wire s s
getState
    (MarshalState Builder
_ Word64
afterPadding) <- Word8 -> Marshal ()
pad (Type -> Word8
alignment Type
itemType) Marshal ()
-> Wire MarshalState MarshalState -> Wire MarshalState MarshalState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Wire MarshalState MarshalState
forall s. Wire s s
getState

    MarshalState -> Marshal ()
forall s. s -> Wire s ()
putState (Builder -> Word64 -> MarshalState
MarshalState Builder
forall a. Monoid a => a
mempty Word64
afterPadding)
    (MarshalState Builder
itemBuilder Word64
_) <- (Value -> Marshal ()) -> Vector Value -> Marshal ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
Data.Vector.mapM_ Value -> Marshal ()
marshal Vector Value
vs Marshal ()
-> Wire MarshalState MarshalState -> Wire MarshalState MarshalState
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Wire MarshalState MarshalState
forall s. Wire s s
getState

    let itemBytes :: ByteString
itemBytes = Builder -> ByteString
Builder.toLazyByteString Builder
itemBuilder
        paddingSize :: Int
paddingSize = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
afterPadding Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
afterLength)

    MarshalState -> Marshal ()
forall s. s -> Wire s ()
putState MarshalState
s
    (Int, ByteString) -> Marshal (Int, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int
paddingSize, ByteString
itemBytes)

unmarshalByteArray :: Unmarshal ByteString
unmarshalByteArray :: Wire UnmarshalState ByteString
unmarshalByteArray = do
    Word32
byteCount <- Wire UnmarshalState Word32
unmarshalWord32
    Word64 -> Wire UnmarshalState ByteString
consume (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount)

unmarshalArray :: Type -> Unmarshal (Vector Value)
unmarshalArray :: Type -> Wire UnmarshalState (Vector Value)
unmarshalArray Type
itemType = do
    let getOffset :: Wire UnmarshalState Word64
getOffset = do
            (UnmarshalState ByteString
_ Word64
o) <- Wire UnmarshalState UnmarshalState
forall s. Wire s s
getState
            Word64 -> Wire UnmarshalState Word64
forall (m :: * -> *) a. Monad m => a -> m a
return Word64
o
    Word32
byteCount <- Wire UnmarshalState Word32
unmarshalWord32
    Word8 -> Wire UnmarshalState ()
skipPadding (Type -> Word8
alignment Type
itemType)
    Word64
start <- Wire UnmarshalState Word64
getOffset
    let end :: Word64
end = Word64
start Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount
    [Value]
vs <- Wire UnmarshalState Bool
-> Unmarshal Value -> Wire UnmarshalState [Value]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
untilM ((Word64 -> Bool)
-> Wire UnmarshalState Word64 -> Wire UnmarshalState Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word64
end) Wire UnmarshalState Word64
getOffset) (Type -> Unmarshal Value
unmarshal Type
itemType)
    Word64
end' <- Wire UnmarshalState Word64
getOffset
    Bool -> Wire UnmarshalState () -> Wire UnmarshalState ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64
end' Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
> Word64
end) (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError (String
"Array data size exeeds array size of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
end))
    Vector Value -> Wire UnmarshalState (Vector Value)
forall (m :: * -> *) a. Monad m => a -> m a
return ([Value] -> Vector Value
forall a. [a] -> Vector a
Data.Vector.fromList [Value]
vs)

dictionaryToArray :: Map Atom Value -> Vector Value
dictionaryToArray :: Map Atom Value -> Vector Value
dictionaryToArray = [Value] -> Vector Value
forall a. [a] -> Vector a
Data.Vector.fromList ([Value] -> Vector Value)
-> (Map Atom Value -> [Value]) -> Map Atom Value -> Vector Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Atom, Value) -> Value) -> [(Atom, Value)] -> [Value]
forall a b. (a -> b) -> [a] -> [b]
map (Atom, Value) -> Value
step ([(Atom, Value)] -> [Value])
-> (Map Atom Value -> [(Atom, Value)]) -> Map Atom Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Atom Value -> [(Atom, Value)]
forall k a. Map k a -> [(k, a)]
Data.Map.toList where
    step :: (Atom, Value) -> Value
step (Atom
k, Value
v) = [Value] -> Value
ValueStructure [Atom -> Value
ValueAtom Atom
k, Value
v]

arrayToDictionary :: Vector Value -> Map Atom Value
arrayToDictionary :: Vector Value -> Map Atom Value
arrayToDictionary = [(Atom, Value)] -> Map Atom Value
forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList ([(Atom, Value)] -> Map Atom Value)
-> (Vector Value -> [(Atom, Value)])
-> Vector Value
-> Map Atom Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Value -> (Atom, Value)) -> [Value] -> [(Atom, Value)]
forall a b. (a -> b) -> [a] -> [b]
map Value -> (Atom, Value)
step ([Value] -> [(Atom, Value)])
-> (Vector Value -> [Value]) -> Vector Value -> [(Atom, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Vector Value -> [Value]
forall a. Vector a -> [a]
Data.Vector.toList where
    step :: Value -> (Atom, Value)
step (ValueStructure [ValueAtom Atom
k, Value
v]) = (Atom
k, Value
v)
    step Value
_ = String -> (Atom, Value)
forall a. HasCallStack => String -> a
error String
"arrayToDictionary: internal error"

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

unmarshalDictionary :: Type -> Type -> Unmarshal Value
unmarshalDictionary :: Type -> Type -> Unmarshal Value
unmarshalDictionary Type
kt Type
vt = do
    let pairType :: Type
pairType = [Type] -> Type
TypeStructure [Type
kt, Type
vt]
    Vector Value
array <- Type -> Wire UnmarshalState (Vector Value)
unmarshalArray Type
pairType
    Value -> Unmarshal Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> Type -> Map Atom Value -> Value
ValueMap Type
kt Type
vt (Vector Value -> Map Atom Value
arrayToDictionary Vector Value
array))

marshalStructure :: [Value] -> Marshal ()
marshalStructure :: [Value] -> Marshal ()
marshalStructure [Value]
vs = do
    Word8 -> Marshal ()
pad Word8
8
    (Value -> Marshal ()) -> [Value] -> Marshal ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Value -> Marshal ()
marshal [Value]
vs

unmarshalStructure :: [Type] -> Unmarshal Value
unmarshalStructure :: [Type] -> Unmarshal Value
unmarshalStructure [Type]
ts = do
    Word8 -> Wire UnmarshalState ()
skipPadding Word8
8
    ([Value] -> Value)
-> Wire UnmarshalState [Value] -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Value] -> Value
ValueStructure ((Type -> Unmarshal Value) -> [Type] -> Wire UnmarshalState [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Unmarshal Value
unmarshal [Type]
ts)

marshalVariant :: Variant -> Marshal ()
marshalVariant :: Variant -> Marshal ()
marshalVariant var :: Variant
var@(Variant Value
val) = do
    Signature
sig <- case [Type] -> Maybe Signature
forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Value -> Type
valueType Value
val] of
        Just Signature
x' -> Signature -> Wire MarshalState Signature
forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x'
        Maybe Signature
Nothing -> String -> Wire MarshalState Signature
forall s a. String -> Wire s a
throwError (String
"Signature " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show (Type -> String
typeCode (Value -> Type
valueType Value
val)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" for variant " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Variant -> String
forall a. Show a => a -> String
show Variant
var String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is malformed or too large.")
    Signature -> Marshal ()
marshalSignature Signature
sig
    Value -> Marshal ()
marshal Value
val

unmarshalVariant :: Unmarshal Value
unmarshalVariant :: Unmarshal Value
unmarshalVariant = do
    let getType :: Signature -> Maybe Type
getType Signature
sig = case Signature -> [Type]
signatureTypes Signature
sig of
            [Type
t] -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
            [Type]
_   -> Maybe Type
forall a. Maybe a
Nothing

    Type
t <- String -> (Signature -> Maybe Type) -> Signature -> Unmarshal Type
forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"variant signature" Signature -> Maybe Type
getType (Signature -> Unmarshal Type)
-> Wire UnmarshalState Signature -> Unmarshal Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Wire UnmarshalState Signature
unmarshalSignature
    (Variant -> Value
forall a. IsValue a => a -> Value
toValue (Variant -> Value) -> (Value -> Variant) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Variant
Variant) (Value -> Value) -> Unmarshal Value -> Unmarshal Value
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` Type -> Unmarshal Value
unmarshal Type
t

protocolVersion :: Word8
protocolVersion :: Word8
protocolVersion = Word8
1

messageMaximumLength :: Integer
messageMaximumLength :: Integer
messageMaximumLength = Integer
134217728

encodeField :: HeaderField -> Value
encodeField :: HeaderField -> Value
encodeField (HeaderPath ObjectPath
x)        = Word8 -> ObjectPath -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
1 ObjectPath
x
encodeField (HeaderInterface InterfaceName
x)   = Word8 -> InterfaceName -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
2 InterfaceName
x
encodeField (HeaderMember MemberName
x)      = Word8 -> MemberName -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
3 MemberName
x
encodeField (HeaderErrorName ErrorName
x)   = Word8 -> ErrorName -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
4 ErrorName
x
encodeField (HeaderReplySerial Serial
x) = Word8 -> Serial -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
5 Serial
x
encodeField (HeaderDestination BusName
x) = Word8 -> BusName -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
6 BusName
x
encodeField (HeaderSender BusName
x)      = Word8 -> BusName -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
7 BusName
x
encodeField (HeaderSignature Signature
x)   = Word8 -> Signature -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
8 Signature
x
encodeField (HeaderUnixFds Word32
x)     = Word8 -> Word32 -> Value
forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
9 Word32
x

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

decodeField :: (Word8, Variant)
            -> ErrorM UnmarshalError [HeaderField]
decodeField :: (Word8, Variant) -> ErrorM UnmarshalError [HeaderField]
decodeField (Word8, Variant)
struct = case (Word8, Variant)
struct of
    (Word8
1, Variant
x) -> Variant
-> (ObjectPath -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x ObjectPath -> HeaderField
HeaderPath String
"path"
    (Word8
2, Variant
x) -> Variant
-> (InterfaceName -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x InterfaceName -> HeaderField
HeaderInterface String
"interface"
    (Word8
3, Variant
x) -> Variant
-> (MemberName -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x MemberName -> HeaderField
HeaderMember String
"member"
    (Word8
4, Variant
x) -> Variant
-> (ErrorName -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x ErrorName -> HeaderField
HeaderErrorName String
"error name"
    (Word8
5, Variant
x) -> Variant
-> (Serial -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x Serial -> HeaderField
HeaderReplySerial String
"reply serial"
    (Word8
6, Variant
x) -> Variant
-> (BusName -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x BusName -> HeaderField
HeaderDestination String
"destination"
    (Word8
7, Variant
x) -> Variant
-> (BusName -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x BusName -> HeaderField
HeaderSender String
"sender"
    (Word8
8, Variant
x) -> Variant
-> (Signature -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x Signature -> HeaderField
HeaderSignature String
"signature"
    (Word8
9, Variant
x) -> Variant
-> (Word32 -> HeaderField)
-> String
-> ErrorM UnmarshalError [HeaderField]
forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x Word32 -> HeaderField
HeaderUnixFds String
"unix fds"
    (Word8, Variant)
_      -> [HeaderField] -> ErrorM UnmarshalError [HeaderField]
forall (m :: * -> *) a. Monad m => a -> m a
return []

decodeField' :: IsVariant a => Variant -> (a -> b) -> String
             -> ErrorM UnmarshalError [b]
decodeField' :: Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x a -> b
f String
label = case Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
x of
    Just a
x' -> [b] -> ErrorM UnmarshalError [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [a -> b
f a
x']
    Maybe a
Nothing -> UnmarshalError -> ErrorM UnmarshalError [b]
forall e a. e -> ErrorM e a
throwErrorM (String -> UnmarshalError
UnmarshalError (String
"Header field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" contains invalid value " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Variant -> String
forall a. Show a => a -> String
show Variant
x))

marshalMessage :: Message a => Endianness -> Serial -> a
               -> Either MarshalError ByteString
marshalMessage :: Endianness -> Serial -> a -> Either MarshalError ByteString
marshalMessage Endianness
e Serial
serial a
msg = Either MarshalError ByteString
runMarshal where
    body :: [Variant]
body = a -> [Variant]
forall a. Message a => a -> [Variant]
messageBody a
msg
    marshaler :: Marshal ()
marshaler = do
        Signature
sig <- [Variant] -> Wire MarshalState Signature
checkBodySig [Variant]
body
        MarshalState
empty <- Wire MarshalState MarshalState
forall s. Wire s s
getState
        (Variant -> Marshal ()) -> [Variant] -> Marshal ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> Marshal ()
marshal (Value -> Marshal ())
-> (Variant -> Value) -> Variant -> Marshal ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Variant Value
x) -> Value
x)) [Variant]
body
        (MarshalState Builder
bodyBytesB Word64
_) <- Wire MarshalState MarshalState
forall s. Wire s s
getState
        MarshalState -> Marshal ()
forall s. s -> Wire s ()
putState MarshalState
empty
        Value -> Marshal ()
marshal (Word8 -> Value
forall a. IsValue a => a -> Value
toValue (Endianness -> Word8
encodeEndianness Endianness
e))
        let bodyBytes :: ByteString
bodyBytes = Builder -> ByteString
Builder.toLazyByteString Builder
bodyBytesB
        a -> Serial -> Signature -> Word32 -> Marshal ()
forall a.
Message a =>
a -> Serial -> Signature -> Word32 -> Marshal ()
marshalHeader a
msg Serial
serial Signature
sig (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
Lazy.length ByteString
bodyBytes))
        Word8 -> Marshal ()
pad Word8
8
        ByteString -> Marshal ()
appendL ByteString
bodyBytes
        Marshal ()
checkMaximumSize
    emptyState :: MarshalState
emptyState = Builder -> Word64 -> MarshalState
MarshalState Builder
forall a. Monoid a => a
mempty Word64
0
    runMarshal :: Either MarshalError ByteString
runMarshal = case Marshal () -> Endianness -> MarshalState -> WireR MarshalState ()
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire Marshal ()
marshaler Endianness
e MarshalState
emptyState of
        WireRL String
err -> MarshalError -> Either MarshalError ByteString
forall a b. a -> Either a b
Left (String -> MarshalError
MarshalError String
err)
        WireRR ()
_ (MarshalState Builder
builder Word64
_) -> ByteString -> Either MarshalError ByteString
forall a b. b -> Either a b
Right (ByteString -> ByteString
Lazy.toStrict (Builder -> ByteString
Builder.toLazyByteString Builder
builder))

checkBodySig :: [Variant] -> Marshal Signature
checkBodySig :: [Variant] -> Wire MarshalState Signature
checkBodySig [Variant]
vs = case [Type] -> Maybe Signature
forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature ((Variant -> Type) -> [Variant] -> [Type]
forall a b. (a -> b) -> [a] -> [b]
map Variant -> Type
variantType [Variant]
vs) of
    Just Signature
x -> Signature -> Wire MarshalState Signature
forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x
    Maybe Signature
Nothing -> String -> Wire MarshalState Signature
forall s a. String -> Wire s a
throwError (String
"Message body " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Variant] -> String
forall a. Show a => a -> String
show [Variant]
vs String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" has too many items")

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

checkMaximumSize :: Marshal ()
checkMaximumSize :: Marshal ()
checkMaximumSize = do
    (MarshalState Builder
_ Word64
messageLength) <- Wire MarshalState MarshalState
forall s. Wire s s
getState
    Bool -> Marshal () -> Marshal ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
messageLength Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
messageMaximumLength)
        (String -> Marshal ()
forall s a. String -> Wire s a
throwError (String
"Marshaled message size (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word64 -> String
forall a. Show a => a -> String
show Word64
messageLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes) exeeds maximum limit of (" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
messageMaximumLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" bytes)."))

unmarshalMessageM :: Monad m => (Int -> m ByteString)
                  -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM :: (Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> m ByteString
getBytes' = ErrorT UnmarshalError m ReceivedMessage
-> m (Either UnmarshalError ReceivedMessage)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (ErrorT UnmarshalError m ReceivedMessage
 -> m (Either UnmarshalError ReceivedMessage))
-> ErrorT UnmarshalError m ReceivedMessage
-> m (Either UnmarshalError ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ do
    let getBytes :: Int -> ErrorT UnmarshalError m ByteString
getBytes Int
count = do
            ByteString
bytes <- m (Either UnmarshalError ByteString)
-> ErrorT UnmarshalError m ByteString
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT ((ByteString -> Either UnmarshalError ByteString)
-> m ByteString -> m (Either UnmarshalError ByteString)
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM ByteString -> Either UnmarshalError ByteString
forall a b. b -> Either a b
Right (Int -> m ByteString
getBytes' Int
count))
            if ByteString -> Int
Data.ByteString.length ByteString
bytes Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
count
                then UnmarshalError -> ErrorT UnmarshalError m ByteString
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError String
"Unexpected end of input while parsing message header.")
                else ByteString -> ErrorT UnmarshalError m ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes

    let Just Signature
fixedSig = String -> Maybe Signature
forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature String
"yyyyuuu"
    ByteString
fixedBytes <- Int -> ErrorT UnmarshalError m ByteString
getBytes Int
16

    let messageVersion :: Word8
messageVersion = ByteString -> Int -> Word8
Data.ByteString.index ByteString
fixedBytes Int
3
    Bool -> ErrorT UnmarshalError m () -> ErrorT UnmarshalError m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
messageVersion Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word8
protocolVersion) (UnmarshalError -> ErrorT UnmarshalError m ()
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError (String
"Unsupported protocol version: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
messageVersion)))

    let eByte :: Word8
eByte = ByteString -> Int -> Word8
Data.ByteString.index ByteString
fixedBytes Int
0
    Endianness
endianness <- case Word8 -> Maybe Endianness
decodeEndianness Word8
eByte of
        Just Endianness
x' -> Endianness -> ErrorT UnmarshalError m Endianness
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
x'
        Maybe Endianness
Nothing -> UnmarshalError -> ErrorT UnmarshalError m Endianness
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError (String
"Invalid endianness: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Word8 -> String
forall a. Show a => a -> String
show Word8
eByte))

    let unmarshalSig :: Signature -> Wire UnmarshalState [Value]
unmarshalSig = (Type -> Unmarshal Value) -> [Type] -> Wire UnmarshalState [Value]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Unmarshal Value
unmarshal ([Type] -> Wire UnmarshalState [Value])
-> (Signature -> [Type])
-> Signature
-> Wire UnmarshalState [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Signature -> [Type]
signatureTypes
    let unmarshal' :: Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
x ByteString
bytes = case Wire UnmarshalState [Value]
-> Endianness -> UnmarshalState -> WireR UnmarshalState [Value]
forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire (Signature -> Wire UnmarshalState [Value]
unmarshalSig Signature
x) Endianness
endianness (ByteString -> Word64 -> UnmarshalState
UnmarshalState ByteString
bytes Word64
0) of
            WireRR [Value]
x' UnmarshalState
_ -> [Value] -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
x'
            WireRL String
err  -> UnmarshalError -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError String
err)
    [Value]
fixed <- Signature -> ByteString -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *).
Monad m =>
Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
fixedSig ByteString
fixedBytes
    let messageType :: Word8
messageType = Maybe Word8 -> Word8
forall a. HasCallStack => Maybe a -> a
fromJust (Value -> Maybe Word8
forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
1))
    let flags :: Word8
flags = Maybe Word8 -> Word8
forall a. HasCallStack => Maybe a -> a
fromJust (Value -> Maybe Word8
forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
2))
    let bodyLength :: Word32
bodyLength = Maybe Word32 -> Word32
forall a. HasCallStack => Maybe a -> a
fromJust (Value -> Maybe Word32
forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
4)) :: Word32
    let serial :: Serial
serial = Maybe Serial -> Serial
forall a. HasCallStack => Maybe a -> a
fromJust (Variant -> Maybe Serial
forall a. IsVariant a => Variant -> Maybe a
fromVariant (Value -> Variant
Variant ([Value]
fixed [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
5)))

    let fieldByteCount :: Word32
fieldByteCount = Maybe Word32 -> Word32
forall a. HasCallStack => Maybe a -> a
fromJust (Value -> Maybe Word32
forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
6)) :: Word32
    let bodyPadding :: Word64
bodyPadding = Word64 -> Word8 -> Word64
padding (Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
fieldByteCount Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
16) Word8
8

    -- Forbid messages larger than 'messageMaximumLength'
    let messageLength :: Integer
messageLength = Integer
16 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
fieldByteCount Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word64 -> Integer
forall a. Integral a => a -> Integer
toInteger Word64
bodyPadding Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Word32 -> Integer
forall a. Integral a => a -> Integer
toInteger Word32
bodyLength
    Bool -> ErrorT UnmarshalError m () -> ErrorT UnmarshalError m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Integer
messageLength Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
messageMaximumLength) (ErrorT UnmarshalError m () -> ErrorT UnmarshalError m ())
-> ErrorT UnmarshalError m () -> ErrorT UnmarshalError m ()
forall a b. (a -> b) -> a -> b
$
        UnmarshalError -> ErrorT UnmarshalError m ()
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError (String
"Message size " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
messageLength String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" exceeds limit of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
messageMaximumLength))

    let Just Signature
headerSig  = String -> Maybe Signature
forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature String
"yyyyuua(yv)"
    ByteString
fieldBytes <- Int -> ErrorT UnmarshalError m ByteString
getBytes (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
fieldByteCount)
    let headerBytes :: ByteString
headerBytes = ByteString -> ByteString -> ByteString
Data.ByteString.append ByteString
fixedBytes ByteString
fieldBytes
    [Value]
header <- Signature -> ByteString -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *).
Monad m =>
Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
headerSig ByteString
headerBytes

    let fieldArray :: [(Word8, Variant)]
fieldArray = Vector (Word8, Variant) -> [(Word8, Variant)]
forall a. Vector a -> [a]
Data.Vector.toList (Maybe (Vector (Word8, Variant)) -> Vector (Word8, Variant)
forall a. HasCallStack => Maybe a -> a
fromJust (Value -> Maybe (Vector (Word8, Variant))
forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
header [Value] -> Int -> Value
forall a. [a] -> Int -> a
!! Int
6)))
    [HeaderField]
fields <- case ErrorM UnmarshalError [HeaderField]
-> Either UnmarshalError [HeaderField]
forall e a. ErrorM e a -> Either e a
runErrorM (ErrorM UnmarshalError [HeaderField]
 -> Either UnmarshalError [HeaderField])
-> ErrorM UnmarshalError [HeaderField]
-> Either UnmarshalError [HeaderField]
forall a b. (a -> b) -> a -> b
$ [[HeaderField]] -> [HeaderField]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[HeaderField]] -> [HeaderField])
-> ErrorM UnmarshalError [[HeaderField]]
-> ErrorM UnmarshalError [HeaderField]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
`liftM` ((Word8, Variant) -> ErrorM UnmarshalError [HeaderField])
-> [(Word8, Variant)] -> ErrorM UnmarshalError [[HeaderField]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Word8, Variant) -> ErrorM UnmarshalError [HeaderField]
decodeField [(Word8, Variant)]
fieldArray of
        Left UnmarshalError
err -> UnmarshalError -> ErrorT UnmarshalError m [HeaderField]
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT UnmarshalError
err
        Right [HeaderField]
x -> [HeaderField] -> ErrorT UnmarshalError m [HeaderField]
forall (m :: * -> *) a. Monad m => a -> m a
return [HeaderField]
x
    ByteString
_ <- Int -> ErrorT UnmarshalError m ByteString
getBytes (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bodyPadding)
    let bodySig :: Signature
bodySig = [HeaderField] -> Signature
findBodySignature [HeaderField]
fields
    ByteString
bodyBytes <- Int -> ErrorT UnmarshalError m ByteString
getBytes (Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
bodyLength)
    [Value]
body <- Signature -> ByteString -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *).
Monad m =>
Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
bodySig ByteString
bodyBytes
    Serial -> Word8 -> [Variant] -> ReceivedMessage
y <- case ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> Either String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall e a. ErrorM e a -> Either e a
runErrorM (Word8
-> [HeaderField]
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
buildReceivedMessage Word8
messageType [HeaderField]
fields) of
        Right Serial -> Word8 -> [Variant] -> ReceivedMessage
x -> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorT
     UnmarshalError m (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return Serial -> Word8 -> [Variant] -> ReceivedMessage
x
        Left String
err -> UnmarshalError
-> ErrorT
     UnmarshalError m (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError (String
"Header field " String -> ShowS
forall a. [a] -> [a] -> [a]
++ ShowS
forall a. Show a => a -> String
show String
err String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" is required, but missing"))
    ReceivedMessage -> ErrorT UnmarshalError m ReceivedMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (Serial -> Word8 -> [Variant] -> ReceivedMessage
y Serial
serial Word8
flags ((Value -> Variant) -> [Value] -> [Variant]
forall a b. (a -> b) -> [a] -> [b]
map Value -> Variant
Variant [Value]
body))

findBodySignature :: [HeaderField] -> Signature
findBodySignature :: [HeaderField] -> Signature
findBodySignature [HeaderField]
fields = Signature -> Maybe Signature -> Signature
forall a. a -> Maybe a -> a
fromMaybe ([Type] -> Signature
signature_ []) ([Signature] -> Maybe Signature
forall a. [a] -> Maybe a
listToMaybe [Signature
x | HeaderSignature Signature
x <- [HeaderField]
fields])

buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
buildReceivedMessage :: Word8
-> [HeaderField]
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
buildReceivedMessage Word8
1 [HeaderField]
fields = do
    ObjectPath
path <- String -> [ObjectPath] -> ErrorM String ObjectPath
forall a. String -> [a] -> ErrorM String a
require String
"path" [ObjectPath
x | HeaderPath ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- String -> [MemberName] -> ErrorM String MemberName
forall a. String -> [a] -> ErrorM String a
require String
"member name" [MemberName
x | HeaderMember MemberName
x <- [HeaderField]
fields]
    (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Serial -> Word8 -> [Variant] -> ReceivedMessage)
 -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage))
-> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
flags [Variant]
body -> let
        iface :: Maybe InterfaceName
iface = [InterfaceName] -> Maybe InterfaceName
forall a. [a] -> Maybe a
listToMaybe [InterfaceName
x | HeaderInterface InterfaceName
x <- [HeaderField]
fields]
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender BusName
x <- [HeaderField]
fields]
        msg :: MethodCall
msg = ObjectPath
-> Maybe InterfaceName
-> MemberName
-> Maybe BusName
-> Maybe BusName
-> Bool
-> Bool
-> [Variant]
-> MethodCall
MethodCall ObjectPath
path Maybe InterfaceName
iface MemberName
member Maybe BusName
sender Maybe BusName
dest Bool
True Bool
True [Variant]
body
        in Serial -> MethodCall -> ReceivedMessage
ReceivedMethodCall Serial
serial (MethodCall -> Word8 -> MethodCall
setMethodCallFlags MethodCall
msg Word8
flags)

buildReceivedMessage Word8
2 [HeaderField]
fields = do
    Serial
replySerial <- String -> [Serial] -> ErrorM String Serial
forall a. String -> [a] -> ErrorM String a
require String
"reply serial" [Serial
x | HeaderReplySerial Serial
x <- [HeaderField]
fields]
    (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Serial -> Word8 -> [Variant] -> ReceivedMessage)
 -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage))
-> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender BusName
x <- [HeaderField]
fields]
        msg :: MethodReturn
msg = Serial
-> Maybe BusName -> Maybe BusName -> [Variant] -> MethodReturn
MethodReturn Serial
replySerial Maybe BusName
sender Maybe BusName
dest [Variant]
body
        in Serial -> MethodReturn -> ReceivedMessage
ReceivedMethodReturn Serial
serial MethodReturn
msg

buildReceivedMessage Word8
3 [HeaderField]
fields = do
    ErrorName
name <- String -> [ErrorName] -> ErrorM String ErrorName
forall a. String -> [a] -> ErrorM String a
require String
"error name" [ErrorName
x | HeaderErrorName ErrorName
x <- [HeaderField]
fields]
    Serial
replySerial <- String -> [Serial] -> ErrorM String Serial
forall a. String -> [a] -> ErrorM String a
require String
"reply serial" [Serial
x | HeaderReplySerial Serial
x <- [HeaderField]
fields]
    (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Serial -> Word8 -> [Variant] -> ReceivedMessage)
 -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage))
-> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender BusName
x <- [HeaderField]
fields]
        msg :: MethodError
msg = ErrorName
-> Serial
-> Maybe BusName
-> Maybe BusName
-> [Variant]
-> MethodError
MethodError ErrorName
name Serial
replySerial Maybe BusName
sender Maybe BusName
dest [Variant]
body
        in Serial -> MethodError -> ReceivedMessage
ReceivedMethodError Serial
serial MethodError
msg

buildReceivedMessage Word8
4 [HeaderField]
fields = do
    ObjectPath
path <- String -> [ObjectPath] -> ErrorM String ObjectPath
forall a. String -> [a] -> ErrorM String a
require String
"path" [ObjectPath
x | HeaderPath ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- String -> [MemberName] -> ErrorM String MemberName
forall a. String -> [a] -> ErrorM String a
require String
"member name" [MemberName
x | HeaderMember MemberName
x <- [HeaderField]
fields]
    InterfaceName
iface <- String -> [InterfaceName] -> ErrorM String InterfaceName
forall a. String -> [a] -> ErrorM String a
require String
"interface" [InterfaceName
x | HeaderInterface InterfaceName
x <- [HeaderField]
fields]
    (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Serial -> Word8 -> [Variant] -> ReceivedMessage)
 -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage))
-> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender BusName
x <- [HeaderField]
fields]
        msg :: Signal
msg = ObjectPath
-> InterfaceName
-> MemberName
-> Maybe BusName
-> Maybe BusName
-> [Variant]
-> Signal
Signal ObjectPath
path InterfaceName
iface MemberName
member Maybe BusName
sender Maybe BusName
dest [Variant]
body
        in Serial -> Signal -> ReceivedMessage
ReceivedSignal Serial
serial Signal
msg

buildReceivedMessage Word8
messageType [HeaderField]
fields = (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Serial -> Word8 -> [Variant] -> ReceivedMessage)
 -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage))
-> (Serial -> Word8 -> [Variant] -> ReceivedMessage)
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
    sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender BusName
x <- [HeaderField]
fields]
    msg :: UnknownMessage
msg = Word8 -> Maybe BusName -> [Variant] -> UnknownMessage
UnknownMessage Word8
messageType Maybe BusName
sender [Variant]
body
    in Serial -> UnknownMessage -> ReceivedMessage
ReceivedUnknown Serial
serial UnknownMessage
msg

require :: String -> [a] -> ErrorM String a
require :: String -> [a] -> ErrorM String a
require String
_     (a
x:[a]
_) = a -> ErrorM String a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
require String
label [a]
_     = String -> ErrorM String a
forall e a. e -> ErrorM e a
throwErrorM String
label

unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage
unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage
unmarshalMessage ByteString
bytes = Either String (Either UnmarshalError ReceivedMessage)
-> Either UnmarshalError ReceivedMessage
forall b.
Either String (Either UnmarshalError b) -> Either UnmarshalError b
checkError (Get (Either UnmarshalError ReceivedMessage)
-> ByteString
-> Either String (Either UnmarshalError ReceivedMessage)
forall a. Get a -> ByteString -> Either String a
Get.runGet Get (Either UnmarshalError ReceivedMessage)
get ByteString
bytes) where
    get :: Get (Either UnmarshalError ReceivedMessage)
get = (Int -> Get ByteString)
-> Get (Either UnmarshalError ReceivedMessage)
forall (m :: * -> *).
Monad m =>
(Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> Get ByteString
getBytes

    -- wrap getByteString, so it will behave like transportGet and return
    -- a truncated result on EOF instead of throwing an exception.
    getBytes :: Int -> Get ByteString
getBytes Int
count = do
        Int
remaining <- Get Int
Get.remaining
        Int -> Get ByteString
Get.getByteString (Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
remaining Int
count)

    checkError :: Either String (Either UnmarshalError b) -> Either UnmarshalError b
checkError (Left String
err) = UnmarshalError -> Either UnmarshalError b
forall a b. a -> Either a b
Left (String -> UnmarshalError
UnmarshalError String
err)
    checkError (Right Either UnmarshalError b
x) = Either UnmarshalError b
x

untilM :: Monad m => m Bool -> m a -> m [a]
untilM :: m Bool -> m a -> m [a]
untilM m Bool
test m a
comp = do
    Bool
done <- m Bool
test
    if Bool
done
        then [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
            a
x <- m a
comp
            [a]
xs <- m Bool -> m a -> m [a]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
untilM m Bool
test m a
comp
            [a] -> m [a]
forall (m :: * -> *) a. Monad m => a -> m a
return (a
xa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a]
xs)

-------------------------------------------------------------------------------
-- local ErrorT and MonadError, which don't have the silly Error => dependency
-- found in the "transformers" package.
-------------------------------------------------------------------------------

newtype ErrorM e a = ErrorM { ErrorM e a -> Either e a
runErrorM :: Either e a }

instance Functor (ErrorM e) where
    fmap :: (a -> b) -> ErrorM e a -> ErrorM e b
fmap a -> b
f ErrorM e a
m = Either e b -> ErrorM e b
forall e a. Either e a -> ErrorM e a
ErrorM (Either e b -> ErrorM e b) -> Either e b -> ErrorM e b
forall a b. (a -> b) -> a -> b
$ case ErrorM e a -> Either e a
forall e a. ErrorM e a -> Either e a
runErrorM ErrorM e a
m of
        Left e
err -> e -> Either e b
forall a b. a -> Either a b
Left e
err
        Right a
x -> b -> Either e b
forall a b. b -> Either a b
Right (a -> b
f a
x)

instance Control.Applicative.Applicative (ErrorM e) where
    pure :: a -> ErrorM e a
pure = a -> ErrorM e a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: ErrorM e (a -> b) -> ErrorM e a -> ErrorM e b
(<*>) = ErrorM e (a -> b) -> ErrorM e a -> ErrorM e b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad (ErrorM e) where
    return :: a -> ErrorM e a
return = Either e a -> ErrorM e a
forall e a. Either e a -> ErrorM e a
ErrorM (Either e a -> ErrorM e a) -> (a -> Either e a) -> a -> ErrorM e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right
    >>= :: ErrorM e a -> (a -> ErrorM e b) -> ErrorM e b
(>>=) ErrorM e a
m a -> ErrorM e b
k = case ErrorM e a -> Either e a
forall e a. ErrorM e a -> Either e a
runErrorM ErrorM e a
m of
        Left e
err -> Either e b -> ErrorM e b
forall e a. Either e a -> ErrorM e a
ErrorM (e -> Either e b
forall a b. a -> Either a b
Left e
err)
        Right a
x -> a -> ErrorM e b
k a
x

throwErrorM :: e -> ErrorM e a
throwErrorM :: e -> ErrorM e a
throwErrorM = Either e a -> ErrorM e a
forall e a. Either e a -> ErrorM e a
ErrorM (Either e a -> ErrorM e a) -> (e -> Either e a) -> e -> ErrorM e a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left

newtype ErrorT e m a = ErrorT { ErrorT e m a -> m (Either e a)
runErrorT :: m (Either e a) }

instance Monad m => Functor (ErrorT e m) where
    fmap :: (a -> b) -> ErrorT e m a -> ErrorT e m b
fmap = (a -> b) -> ErrorT e m a -> ErrorT e m b
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM

instance Monad m => Control.Applicative.Applicative (ErrorT e m) where
    pure :: a -> ErrorT e m a
pure = a -> ErrorT e m a
forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: ErrorT e m (a -> b) -> ErrorT e m a -> ErrorT e m b
(<*>) = ErrorT e m (a -> b) -> ErrorT e m a -> ErrorT e m b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad m => Monad (ErrorT e m) where
    return :: a -> ErrorT e m a
return = m (Either e a) -> ErrorT e m a
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (m (Either e a) -> ErrorT e m a)
-> (a -> m (Either e a)) -> a -> ErrorT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a))
-> (a -> Either e a) -> a -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either e a
forall a b. b -> Either a b
Right
    >>= :: ErrorT e m a -> (a -> ErrorT e m b) -> ErrorT e m b
(>>=) ErrorT e m a
m a -> ErrorT e m b
k = m (Either e b) -> ErrorT e m b
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (m (Either e b) -> ErrorT e m b) -> m (Either e b) -> ErrorT e m b
forall a b. (a -> b) -> a -> b
$ do
        Either e a
x <- ErrorT e m a -> m (Either e a)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT ErrorT e m a
m
        case Either e a
x of
            Left e
l -> Either e b -> m (Either e b)
forall (m :: * -> *) a. Monad m => a -> m a
return (e -> Either e b
forall a b. a -> Either a b
Left e
l)
            Right a
r -> ErrorT e m b -> m (Either e b)
forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT (a -> ErrorT e m b
k a
r)

throwErrorT :: Monad m => e -> ErrorT e m a
throwErrorT :: e -> ErrorT e m a
throwErrorT = m (Either e a) -> ErrorT e m a
forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (m (Either e a) -> ErrorT e m a)
-> (e -> m (Either e a)) -> e -> ErrorT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either e a -> m (Either e a))
-> (e -> Either e a) -> e -> m (Either e a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> Either e a
forall a b. a -> Either a b
Left