-- 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 LittleEndian = 0x6C
encodeEndianness BigEndian    = 0x42

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

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

{-# INLINE padding #-}
padding :: Word64 -> Word8 -> Word64
padding :: Word64 -> Word8 -> Word64
padding current :: Word64
current count :: 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
> 0
        then Word64
count' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
missing
        else 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
a = (Endianness -> s -> WireR s a) -> Wire s a
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\_ s :: s
s -> a -> s -> WireR s a
forall s a. a -> s -> WireR s a
WireRR a
a s
s)

    {-# INLINE (>>=) #-}
    m :: Wire s a
m >>= :: Wire s a -> (a -> Wire s b) -> Wire s b
>>= k :: 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
$ \e :: Endianness
e s :: 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 err :: String
err -> String -> WireR s b
forall s a. String -> WireR s a
WireRL String
err
        WireRR a :: a
a s' :: 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 (>>) #-}
    m :: Wire s a
m >> :: Wire s a -> Wire s b -> Wire s b
>> k :: 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
$ \e :: Endianness
e s :: 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 err :: String
err -> String -> WireR s b
forall s a. String -> WireR s a
WireRL String
err
        WireRR _ s' :: 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 err :: String
err = (Endianness -> s -> WireR s a) -> Wire s a
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\_ _ -> 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 (\_ s :: 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
s = (Endianness -> s -> WireR s ()) -> Wire s ()
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\_ _ -> () -> 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 big :: a
big little :: a
little = (Endianness -> s -> WireR s a) -> Wire s a
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\e :: Endianness
e s :: s
s -> case Endianness
e of
    BigEndian -> a -> s -> WireR s a
forall s a. a -> s -> WireR s a
WireRR a
big s
s
    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 s :: String
s) = String
s

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

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

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

appendB :: Word64 -> Builder.Builder -> Marshal ()
appendB :: Word64 -> Builder -> Marshal ()
appendB size :: Word64
size bytes :: Builder
bytes = (Endianness -> MarshalState -> WireR MarshalState ()) -> Marshal ()
forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\_ (MarshalState builder :: Builder
builder count :: 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 bytes :: 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 bytes :: 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 count :: Word8
count = do
    (MarshalState _ existing :: 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' 0)

marshalBuilder :: Word8
               -> (a -> Builder.Builder)
               -> (a -> Builder.Builder)
               -> a -> Marshal ()
marshalBuilder :: Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder size :: Word8
size be :: a -> Builder
be le :: a -> Builder
le x :: 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 s :: String
s) = String
s

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

unmarshal :: Type -> Unmarshal Value
unmarshal :: Type -> Unmarshal Value
unmarshal 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 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 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 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 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 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 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 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 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 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 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 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 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 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 t :: 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 kt :: Type
kt vt :: Type
vt) = Type -> Type -> Unmarshal Value
unmarshalDictionary Type
kt Type
vt
unmarshal (TypeStructure ts :: [Type]
ts) = [Type] -> Unmarshal Value
unmarshalStructure [Type]
ts
unmarshal TypeVariant = Unmarshal Value
unmarshalVariant

{-# INLINE consume #-}
consume :: Word64 -> Unmarshal ByteString
consume :: Word64 -> Wire UnmarshalState ByteString
consume count :: Word64
count = do
    (UnmarshalState bytes :: ByteString
bytes offset :: 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 (x :: ByteString
x, bytes' :: 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 ("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 count :: Word8
count = do
    (UnmarshalState _ offset :: 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
== 0) ByteString
bytes)
        (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError ("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]
++ " 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
/= 0) (String -> Wire UnmarshalState ()
forall s a. String -> Wire s a
throwError "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 label :: String
label f :: a -> Maybe b
f x :: a
x = case a -> Maybe b
f a
x of
    Just x' :: b
x' -> b -> Unmarshal b
forall (m :: * -> *) a. Monad m => a -> m a
return b
x'
    Nothing -> String -> Unmarshal b
forall s a. String -> Wire s a
throwError ("Invalid " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
label String -> ShowS
forall a. [a] -> [a] -> [a]
++ ": " 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 count :: Word8
count be :: Get a
be le :: 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 ret :: 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 x :: Word8
x = Word64 -> Builder -> Marshal ()
appendB 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 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 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 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 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 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 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 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 x :: 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 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 8
    Get Double
getFloat64be
    Get Double
getFloat64le

marshalUnixFd :: Fd -> Marshal ()
marshalUnixFd :: Fd -> Marshal ()
marshalUnixFd (Fd x :: CInt
x)
    | CInt
x CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
< 0 = String -> Marshal ()
forall s a. String -> Wire s a
throwError ("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 ("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 ("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 False = Word32 -> Marshal ()
marshalWord32 0
marshalBool True  = Word32 -> Marshal ()
marshalWord32 1

unmarshalBool :: Unmarshal Bool
unmarshalBool :: Wire UnmarshalState Bool
unmarshalBool = do
    Word32
word <- Wire UnmarshalState Word32
unmarshalWord32
    case Word32
word of
        0 -> Bool -> Wire UnmarshalState Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        1 -> Bool -> Wire UnmarshalState Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        _ -> String -> Wire UnmarshalState Bool
forall s a. String -> Wire s a
throwError ("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
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
== 0) ByteString
bytes)
        (String -> Marshal ()
forall s a. String -> Wire s a
throwError ("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]
++ " 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 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 "text" ByteString -> Maybe Text
maybeDecodeUtf8 ByteString
bytes

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

marshalObjectPath :: ObjectPath -> Marshal ()
marshalObjectPath :: ObjectPath -> Marshal ()
marshalObjectPath p :: 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 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 "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 ts :: [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 x :: 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 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 "signature" ByteString -> Maybe Signature
forall (m :: * -> *). MonadThrow m => ByteString -> m Signature
parseSignatureBytes ByteString
bytes

arrayMaximumLength :: Int64
arrayMaximumLength :: Int64
arrayMaximumLength = 67108864

marshalVector :: Type -> Vector Value -> Marshal ()
marshalVector :: Type -> Vector Value -> Marshal ()
marshalVector t :: Type
t x :: Vector Value
x = do
    (arrayPadding :: Int
arrayPadding, arrayBytes :: 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 ("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]
++ " 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]
++ " 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 0)
    ByteString -> Marshal ()
appendL ByteString
arrayBytes

marshalStrictBytes :: ByteString -> Marshal ()
marshalStrictBytes :: ByteString -> Marshal ()
marshalStrictBytes bytes :: 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 ("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]
++ " 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]
++ " 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 itemType :: Type
itemType vs :: Vector Value
vs = do
    MarshalState
s <- Wire MarshalState MarshalState
forall s. Wire s s
getState
    (MarshalState _ afterLength :: Word64
afterLength) <- Word32 -> Marshal ()
marshalWord32 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 _ afterPadding :: 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 itemBuilder :: Builder
itemBuilder _) <- (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 itemType :: Type
itemType = do
    let getOffset :: Wire UnmarshalState Word64
getOffset = do
            (UnmarshalState _ o :: 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 ("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 (k :: Atom
k, v :: 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 k :: Atom
k, v :: Value
v]) = (Atom
k, Value
v)
    step _ = String -> (Atom, Value)
forall a. HasCallStack => String -> a
error "arrayToDictionary: internal error"

marshalMap :: Type -> Type -> Map Atom Value -> Marshal ()
marshalMap :: Type -> Type -> Map Atom Value -> Marshal ()
marshalMap kt :: Type
kt vt :: Type
vt x :: 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 kt :: Type
kt vt :: 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 vs :: [Value]
vs = do
    Word8 -> Marshal ()
pad 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 ts :: [Type]
ts = do
    Word8 -> Wire UnmarshalState ()
skipPadding 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 val :: Value
val) = do
    Signature
sig <- case [Type] -> Maybe Signature
forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Value -> Type
valueType Value
val] of
        Just x' :: Signature
x' -> Signature -> Wire MarshalState Signature
forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x'
        Nothing -> String -> Wire MarshalState Signature
forall s a. String -> Wire s a
throwError ("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]
++ " 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]
++ " 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 sig :: Signature
sig = case Signature -> [Type]
signatureTypes Signature
sig of
            [t :: Type
t] -> Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t
            _   -> 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 "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 = 1

messageMaximumLength :: Integer
messageMaximumLength :: Integer
messageMaximumLength = 134217728

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

encodeField' :: IsVariant a => Word8 -> a -> Value
encodeField' :: Word8 -> a -> Value
encodeField' code :: Word8
code x :: 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 struct :: (Word8, Variant)
struct = case (Word8, Variant)
struct of
    (1, x :: 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 "path"
    (2, x :: 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 "interface"
    (3, x :: 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 "member"
    (4, x :: 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 "error name"
    (5, x :: 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 "reply serial"
    (6, x :: 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 "destination"
    (7, x :: 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 "sender"
    (8, x :: 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 "signature"
    (9, x :: 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 "unix fds"
    _      -> [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' x :: Variant
x f :: a -> b
f label :: String
label = case Variant -> Maybe a
forall a. IsVariant a => Variant -> Maybe a
fromVariant Variant
x of
    Just x' :: a
x' -> [b] -> ErrorM UnmarshalError [b]
forall (m :: * -> *) a. Monad m => a -> m a
return [a -> b
f a
x']
    Nothing -> UnmarshalError -> ErrorM UnmarshalError [b]
forall e a. e -> ErrorM e a
throwErrorM (String -> UnmarshalError
UnmarshalError ("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]
++ " 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 e :: Endianness
e serial :: Serial
serial msg :: 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 x :: Value
x) -> Value
x)) [Variant]
body
        (MarshalState bodyBytesB :: Builder
bodyBytesB _) <- 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 8
        ByteString -> Marshal ()
appendL ByteString
bodyBytes
        Marshal ()
checkMaximumSize
    emptyState :: MarshalState
emptyState = Builder -> Word64 -> MarshalState
MarshalState Builder
forall a. Monoid a => a
mempty 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 err :: String
err -> MarshalError -> Either MarshalError ByteString
forall a b. a -> Either a b
Left (String -> MarshalError
MarshalError String
err)
        WireRR _ (MarshalState builder :: Builder
builder _) -> 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 vs :: [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 x :: Signature
x -> Signature -> Wire MarshalState Signature
forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x
    Nothing -> String -> Wire MarshalState Signature
forall s a. String -> Wire s a
throwError ("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]
++ " has too many items")

marshalHeader :: Message a => a -> Serial -> Signature -> Word32
              -> Marshal ()
marshalHeader :: a -> Serial -> Signature -> Word32 -> Marshal ()
marshalHeader msg :: a
msg serial :: Serial
serial bodySig :: Signature
bodySig bodyLength :: 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 _ messageLength :: 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 ("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]
++ " 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]
++ " bytes)."))

unmarshalMessageM :: Monad m => (Int -> m ByteString)
                  -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM :: (Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM getBytes' :: 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 count :: 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 "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 fixedSig :: Signature
fixedSig = String -> Maybe Signature
forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature "yyyyuuu"
    ByteString
fixedBytes <- Int -> ErrorT UnmarshalError m ByteString
getBytes 16

    let messageVersion :: Word8
messageVersion = ByteString -> Int -> Word8
Data.ByteString.index ByteString
fixedBytes 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 ("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 0
    Endianness
endianness <- case Word8 -> Maybe Endianness
decodeEndianness Word8
eByte of
        Just x' :: Endianness
x' -> Endianness -> ErrorT UnmarshalError m Endianness
forall (m :: * -> *) a. Monad m => a -> m a
return Endianness
x'
        Nothing -> UnmarshalError -> ErrorT UnmarshalError m Endianness
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError ("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' x :: Signature
x bytes :: 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 0) of
            WireRR x' :: [Value]
x' _ -> [Value] -> ErrorT UnmarshalError m [Value]
forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
x'
            WireRL err :: 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
!! 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
!! 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
!! 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
!! 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
!! 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
+ 16) 8

    -- Forbid messages larger than 'messageMaximumLength'
    let messageLength :: Integer
messageLength = 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 ("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]
++ " exceeds limit of " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Integer -> String
forall a. Show a => a -> String
show Integer
messageMaximumLength))

    let Just headerSig :: Signature
headerSig  = String -> Maybe Signature
forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature "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
!! 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 err :: UnmarshalError
err -> UnmarshalError -> ErrorT UnmarshalError m [HeaderField]
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT UnmarshalError
err
        Right x :: [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 x :: 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 err :: 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 ("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]
++ " 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 fields :: [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 x :: Signature
x <- [HeaderField]
fields])

buildReceivedMessage :: Word8 -> [HeaderField] -> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
buildReceivedMessage :: Word8
-> [HeaderField]
-> ErrorM String (Serial -> Word8 -> [Variant] -> ReceivedMessage)
buildReceivedMessage 1 fields :: [HeaderField]
fields = do
    ObjectPath
path <- String -> [ObjectPath] -> ErrorM String ObjectPath
forall a. String -> [a] -> ErrorM String a
require "path" [ObjectPath
x | HeaderPath x :: ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- String -> [MemberName] -> ErrorM String MemberName
forall a. String -> [a] -> ErrorM String a
require "member name" [MemberName
x | HeaderMember x :: 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
serial flags :: Word8
flags body :: [Variant]
body -> let
        iface :: Maybe InterfaceName
iface = [InterfaceName] -> Maybe InterfaceName
forall a. [a] -> Maybe a
listToMaybe [InterfaceName
x | HeaderInterface x :: InterfaceName
x <- [HeaderField]
fields]
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination x :: BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender x :: 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 2 fields :: [HeaderField]
fields = do
    Serial
replySerial <- String -> [Serial] -> ErrorM String Serial
forall a. String -> [a] -> ErrorM String a
require "reply serial" [Serial
x | HeaderReplySerial x :: 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
serial _ body :: [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination x :: BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender x :: 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 3 fields :: [HeaderField]
fields = do
    ErrorName
name <- String -> [ErrorName] -> ErrorM String ErrorName
forall a. String -> [a] -> ErrorM String a
require "error name" [ErrorName
x | HeaderErrorName x :: ErrorName
x <- [HeaderField]
fields]
    Serial
replySerial <- String -> [Serial] -> ErrorM String Serial
forall a. String -> [a] -> ErrorM String a
require "reply serial" [Serial
x | HeaderReplySerial x :: 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
serial _ body :: [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination x :: BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender x :: 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 4 fields :: [HeaderField]
fields = do
    ObjectPath
path <- String -> [ObjectPath] -> ErrorM String ObjectPath
forall a. String -> [a] -> ErrorM String a
require "path" [ObjectPath
x | HeaderPath x :: ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- String -> [MemberName] -> ErrorM String MemberName
forall a. String -> [a] -> ErrorM String a
require "member name" [MemberName
x | HeaderMember x :: MemberName
x <- [HeaderField]
fields]
    InterfaceName
iface <- String -> [InterfaceName] -> ErrorM String InterfaceName
forall a. String -> [a] -> ErrorM String a
require "interface" [InterfaceName
x | HeaderInterface x :: 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
serial _ body :: [Variant]
body -> let
        dest :: Maybe BusName
dest = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination x :: BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender x :: 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 messageType :: Word8
messageType fields :: [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
serial _ body :: [Variant]
body -> let
    sender :: Maybe BusName
sender = [BusName] -> Maybe BusName
forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderSender x :: 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 _     (x :: a
x:_) = a -> ErrorM String a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x
require label :: String
label _     = 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 bytes :: 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 count :: 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 err :: String
err) = UnmarshalError -> Either UnmarshalError b
forall a b. a -> Either a b
Left (String -> UnmarshalError
UnmarshalError String
err)
    checkError (Right x :: 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 test :: m Bool
test comp :: 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 f :: a -> b
f m :: 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 err :: e
err -> e -> Either e b
forall a b. a -> Either a b
Left e
err
        Right x :: 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
(>>=) m :: ErrorM e a
m k :: 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 err :: 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 x :: 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
(>>=) m :: ErrorT e m a
m k :: 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 l :: 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 r :: 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