-- 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
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
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 = forall a. a -> Maybe a
Just Endianness
LittleEndian
decodeEndianness Word8
0x42 = forall a. a -> Maybe a
Just Endianness
BigEndian
decodeEndianness Word8
_    = 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' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
count
    missing :: Word64
missing = forall a. Integral a => a -> a -> a
mod Word64
current Word64
count'
    required :: Word64
required = if Word64
missing forall a. Ord a => a -> a -> Bool
> Word64
0
        then Word64
count' 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
    { forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire :: Endianness -> s -> WireR s a
    }

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

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

    {-# INLINE (<*>) #-}
    <*> :: forall a 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 :: forall a. a -> Wire s a
return a
a = forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ s
s -> forall s a. a -> s -> WireR s a
WireRR a
a s
s)

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

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

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

{-# INLINE chooseEndian #-}
chooseEndian :: a -> a -> Wire s a
chooseEndian :: forall a s. a -> a -> Wire s a
chooseEndian a
big a
little = forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
e s
s -> case Endianness
e of
    Endianness
BigEndian -> forall s a. a -> s -> WireR s a
WireRR a
big s
s
    Endianness
LittleEndian -> 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
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
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 = forall s a. (Endianness -> s -> WireR s a) -> Wire s a
Wire (\Endianness
_ (MarshalState Builder
builder Word64
count) -> let
    builder' :: Builder
builder' = forall a. Monoid a => a -> a -> a
mappend Builder
builder Builder
bytes
    count' :: Word64
count' = Word64
count forall a. Num a => a -> a -> a
+ Word64
size
    in 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
    (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
    (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) <- forall s. Wire s s
getState
    let padding' :: Int
padding' = 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 :: forall a.
Word8 -> (a -> Builder) -> (a -> Builder) -> a -> Marshal ()
marshalBuilder Word8
size a -> Builder
be a -> Builder
le a
x = do
    Builder
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 (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
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
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 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Word8
unmarshalWord8
unmarshal Type
TypeWord16 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Word16
unmarshalWord16
unmarshal Type
TypeWord32 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Word32
unmarshalWord32
unmarshal Type
TypeWord64 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Word64
unmarshalWord64
unmarshal Type
TypeInt16 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Int16
unmarshalInt16
unmarshal Type
TypeInt32 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Int32
unmarshalInt32
unmarshal Type
TypeInt64 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Int64
unmarshalInt64
unmarshal Type
TypeDouble = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Double
unmarshalDouble
unmarshal Type
TypeUnixFd = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Fd
unmarshalUnixFd
unmarshal Type
TypeBoolean = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Bool
unmarshalBool
unmarshal Type
TypeString = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Text
unmarshalText
unmarshal Type
TypeObjectPath = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal ObjectPath
unmarshalObjectPath
unmarshal Type
TypeSignature = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal Signature
unmarshalSignature
unmarshal (TypeArray Type
TypeWord8) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a. IsValue a => a -> Value
toValue Unmarshal ByteString
unmarshalByteArray
unmarshal (TypeArray Type
t) = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Type -> Vector Value -> Value
ValueVector Type
t) (Type -> Unmarshal (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 -> Unmarshal ByteString
consume Word64
count = do
    (UnmarshalState ByteString
bytes Word64
offset) <- forall s. Wire s s
getState
    let count' :: Int
count' = 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 forall a. Eq a => a -> a -> Bool
== Int
count'
        then do
            forall s. s -> Wire s ()
putState (ByteString -> Word64 -> UnmarshalState
UnmarshalState ByteString
bytes' (Word64
offset forall a. Num a => a -> a -> a
+ Word64
count))
            forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
x
        else forall s a. String -> Wire s a
throwError (String
"Unexpected EOF at offset " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Word64
offset forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lenConsumed))

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

skipTerminator :: Unmarshal ()
skipTerminator :: Unmarshal ()
skipTerminator = do
    Word8
byte <- Unmarshal Word8
unmarshalWord8
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
byte forall a. Eq a => a -> a -> Bool
/= Word8
0) (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 :: forall a b. Show a => 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' -> forall (m :: * -> *) a. Monad m => a -> m a
return b
x'
    Maybe b
Nothing -> forall s a. String -> Wire s a
throwError (String
"Invalid " forall a. [a] -> [a] -> [a]
++ String
label forall a. [a] -> [a] -> [a]
++ String
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show a
x)

unmarshalGet :: Word8 -> Get.Get a -> Get.Get a -> Unmarshal a
unmarshalGet :: forall a. Word8 -> Get a -> Get a -> Unmarshal a
unmarshalGet Word8
count Get a
be Get a
le = do
    Word8 -> Unmarshal ()
skipPadding Word8
count
    ByteString
bytes <- Word64 -> Unmarshal ByteString
consume (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
count)
    Get a
get <- forall a s. a -> a -> Wire s a
chooseEndian Get a
be Get a
le
    let Right a
ret = forall a. Get a -> ByteString -> Either String a
Get.runGet Get a
get ByteString
bytes
    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 :: Unmarshal Word8
unmarshalWord8 = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM HasCallStack => ByteString -> Word8
Data.ByteString.head (Word64 -> Unmarshal ByteString
consume Word64
1)

marshalWord16 :: Word16 -> Marshal ()
marshalWord16 :: Word16 -> Marshal ()
marshalWord16 = 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 = 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral

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

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

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

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

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

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

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

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

marshalDouble :: Double -> Marshal ()
marshalDouble :: Double -> Marshal ()
marshalDouble Double
x = do
    Double -> Put
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 :: Unmarshal Double
unmarshalDouble = 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 forall a. Ord a => a -> a -> Bool
< CInt
0 = forall s a. String -> Wire s a
throwError (String
"Invalid file descriptor: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
x)
    | forall a. Integral a => a -> Integer
toInteger CInt
x forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: Word32) = forall s a. String -> Wire s a
throwError (String
"D-Bus forbids file descriptors exceeding UINT32_MAX: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show CInt
x)
    | Bool
otherwise = Word32 -> Marshal ()
marshalWord32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
x)

unmarshalUnixFd :: Unmarshal Fd
unmarshalUnixFd :: Unmarshal Fd
unmarshalUnixFd = do
    Word32
x <- Unmarshal Word32
unmarshalWord32
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Integral a => a -> Integer
toInteger Word32
x forall a. Ord a => a -> a -> Bool
> forall a. Integral a => a -> Integer
toInteger (forall a. Bounded a => a
maxBound :: CInt))
        (forall s a. String -> Wire s a
throwError (String
"Invalid file descriptor: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word32
x))
    forall (m :: * -> *) a. Monad m => a -> m a
return (CInt -> Fd
Fd (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 :: Unmarshal Bool
unmarshalBool = do
    Word32
word <- Unmarshal Word32
unmarshalWord32
    case Word32
word of
        Word32
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Word32
1 -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Word32
_ -> forall s a. String -> Wire s a
throwError (String
"Invalid boolean: " forall a. [a] -> [a] -> [a]
++ 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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Word8 -> Bool) -> ByteString -> Bool
Data.ByteString.any (forall a. Eq a => a -> a -> Bool
== Word8
0) ByteString
bytes)
        (forall s a. String -> Wire s a
throwError (String
"String " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
text forall a. [a] -> [a] -> [a]
++ String
" contained forbidden character: '\\x00'"))
    Word32 -> Marshal ()
marshalWord32 (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 :: Unmarshal Text
unmarshalText = do
    Word32
byteCount <- Unmarshal Word32
unmarshalWord32
    ByteString
bytes <- Word64 -> Unmarshal ByteString
consume (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount)
    Unmarshal ()
skipTerminator
    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 -> forall a. a -> Maybe a
Just Text
text
    Either UnicodeException 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 (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 :: Unmarshal ObjectPath
unmarshalObjectPath = do
    Word32
byteCount <- Unmarshal Word32
unmarshalWord32
    ByteString
bytes <- Word64 -> Unmarshal ByteString
consume (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
byteCount)
    Unmarshal ()
skipTerminator
    forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"object path" 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 (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 (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 :: Unmarshal Signature
unmarshalSignature = do
    Word8
byteCount <- Unmarshal Word8
unmarshalWord8
    ByteString
bytes <- Word64 -> Unmarshal ByteString
consume (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
byteCount)
    Unmarshal ()
skipTerminator
    forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"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
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
arrayLen forall a. Ord a => a -> a -> Bool
> Int64
arrayMaximumLength) (forall s a. String -> Wire s a
throwError (String
"Marshaled array size (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
arrayLen forall a. [a] -> [a] -> [a]
++ String
" bytes) exceeds maximum limit of (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
arrayMaximumLength forall a. [a] -> [a] -> [a]
++ String
" bytes)."))
    Word32 -> Marshal ()
marshalWord32 (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)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
arrayLen forall a. Ord a => a -> a -> Bool
> Int64
arrayMaximumLength) (forall s a. String -> Wire s a
throwError (String
"Marshaled array size (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
arrayLen forall a. [a] -> [a] -> [a]
++ String
" bytes) exceeds maximum limit of (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
arrayMaximumLength forall a. [a] -> [a] -> [a]
++ String
" bytes)."))
    Word32 -> Marshal ()
marshalWord32 (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 <- forall s. Wire s s
getState
    (MarshalState Builder
_ Word64
afterLength) <- Word32 -> Marshal ()
marshalWord32 Word32
0 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. Wire s s
getState
    (MarshalState Builder
_ Word64
afterPadding) <- Word8 -> Marshal ()
pad (Type -> Word8
alignment Type
itemType) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall s. Wire s s
getState

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

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

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

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

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

dictionaryToArray :: Map Atom Value -> Vector Value
dictionaryToArray :: Map Atom Value -> Vector Value
dictionaryToArray = forall a. [a] -> Vector a
Data.Vector.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (Atom, Value) -> Value
step forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 = forall k a. Ord k => [(k, a)] -> Map k a
Data.Map.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Value -> (Atom, Value)
step forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_ = 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 -> Unmarshal (Vector Value)
unmarshalArray Type
pairType
    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
    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 -> Unmarshal ()
skipPadding Word8
8
    forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [Value] -> Value
ValueStructure (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 forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature [Value -> Type
valueType Value
val] of
        Just Signature
x' -> forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x'
        Maybe Signature
Nothing -> forall s a. String -> Wire s a
throwError (String
"Signature " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Type -> String
typeCode (Value -> Type
valueType Value
val)) forall a. [a] -> [a] -> [a]
++ String
" for variant " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Variant
var 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] -> forall a. a -> Maybe a
Just Type
t
            [Type]
_   -> forall a. Maybe a
Nothing

    Type
t <- forall a b. Show a => String -> (a -> Maybe b) -> a -> Unmarshal b
fromMaybeU String
"variant signature" Signature -> Maybe Type
getType forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Unmarshal Signature
unmarshalSignature
    (forall a. IsValue a => a -> Value
toValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Variant
Variant) 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)        = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
1 ObjectPath
x
encodeField (HeaderInterface InterfaceName
x)   = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
2 InterfaceName
x
encodeField (HeaderMember MemberName
x)      = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
3 MemberName
x
encodeField (HeaderErrorName ErrorName
x)   = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
4 ErrorName
x
encodeField (HeaderReplySerial Serial
x) = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
5 Serial
x
encodeField (HeaderDestination BusName
x) = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
6 BusName
x
encodeField (HeaderSender BusName
x)      = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
7 BusName
x
encodeField (HeaderSignature Signature
x)   = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
8 Signature
x
encodeField (HeaderUnixFds Word32
x)     = forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
9 Word32
x

encodeField' :: IsVariant a => Word8 -> a -> Value
encodeField' :: forall a. IsVariant a => Word8 -> a -> Value
encodeField' Word8
code a
x = forall a. IsValue a => a -> Value
toValue (Word8
code, 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) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x ObjectPath -> HeaderField
HeaderPath String
"path"
    (Word8
2, Variant
x) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x InterfaceName -> HeaderField
HeaderInterface String
"interface"
    (Word8
3, Variant
x) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x MemberName -> HeaderField
HeaderMember String
"member"
    (Word8
4, Variant
x) -> 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) -> 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) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x BusName -> HeaderField
HeaderDestination String
"destination"
    (Word8
7, Variant
x) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x BusName -> HeaderField
HeaderSender String
"sender"
    (Word8
8, Variant
x) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x Signature -> HeaderField
HeaderSignature String
"signature"
    (Word8
9, Variant
x) -> forall a b.
IsVariant a =>
Variant -> (a -> b) -> String -> ErrorM UnmarshalError [b]
decodeField' Variant
x Word32 -> HeaderField
HeaderUnixFds String
"unix fds"
    (Word8, Variant)
_      -> forall (m :: * -> *) a. Monad m => a -> m a
return []

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

marshalMessage :: Message a => Endianness -> Serial -> a
               -> Either MarshalError ByteString
marshalMessage :: forall a.
Message a =>
Endianness -> Serial -> a -> Either MarshalError ByteString
marshalMessage Endianness
e Serial
serial a
msg = Either MarshalError ByteString
runMarshal where
    body :: [Variant]
body = forall a. Message a => a -> [Variant]
messageBody a
msg
    marshaler :: Marshal ()
marshaler = do
        Signature
sig <- [Variant] -> Wire MarshalState Signature
checkBodySig [Variant]
body
        MarshalState
empty <- forall s. Wire s s
getState
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Value -> Marshal ()
marshal forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Variant Value
x) -> Value
x)) [Variant]
body
        (MarshalState Builder
bodyBytesB Word64
_) <- forall s. Wire s s
getState
        forall s. s -> Wire s ()
putState MarshalState
empty
        Value -> Marshal ()
marshal (forall a. IsValue a => a -> Value
toValue (Endianness -> Word8
encodeEndianness Endianness
e))
        let bodyBytes :: ByteString
bodyBytes = Builder -> ByteString
Builder.toLazyByteString Builder
bodyBytesB
        forall a.
Message a =>
a -> Serial -> Signature -> Word32 -> Marshal ()
marshalHeader a
msg Serial
serial Signature
sig (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 forall a. Monoid a => a
mempty Word64
0
    runMarshal :: Either MarshalError ByteString
runMarshal = case forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire Marshal ()
marshaler Endianness
e MarshalState
emptyState of
        WireRL String
err -> forall a b. a -> Either a b
Left (String -> MarshalError
MarshalError String
err)
        WireRR ()
_ (MarshalState Builder
builder Word64
_) -> 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 forall (m :: * -> *). MonadThrow m => [Type] -> m Signature
signature (forall a b. (a -> b) -> [a] -> [b]
map Variant -> Type
variantType [Variant]
vs) of
    Just Signature
x -> forall (m :: * -> *) a. Monad m => a -> m a
return Signature
x
    Maybe Signature
Nothing -> forall s a. String -> Wire s a
throwError (String
"Message body " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Variant]
vs forall a. [a] -> [a] -> [a]
++ String
" has too many items")

marshalHeader :: Message a => a -> Serial -> Signature -> Word32
              -> Marshal ()
marshalHeader :: forall a.
Message a =>
a -> Serial -> Signature -> Word32 -> Marshal ()
marshalHeader a
msg Serial
serial Signature
bodySig Word32
bodyLength = do
    let fields :: [HeaderField]
fields = Signature -> HeaderField
HeaderSignature Signature
bodySig forall a. a -> [a] -> [a]
: forall a. Message a => a -> [HeaderField]
messageHeaderFields a
msg
    Word8 -> Marshal ()
marshalWord8 (forall a. Message a => a -> Word8
messageTypeCode a
msg)
    Word8 -> Marshal ()
marshalWord8 (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 (forall a. [a] -> Vector a
Data.Vector.fromList (forall a b. (a -> b) -> [a] -> [b]
map HeaderField -> Value
encodeField [HeaderField]
fields))

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

unmarshalMessageM :: Monad m => (Int -> m ByteString)
                  -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM :: forall (m :: * -> *).
Monad m =>
(Int -> m ByteString) -> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> m ByteString
getBytes' = forall e (m :: * -> *) a. ErrorT e m a -> m (Either e a)
runErrorT forall a b. (a -> b) -> a -> b
$ do
    let getBytes :: Int -> ErrorT UnmarshalError m ByteString
getBytes Int
count = do
            ByteString
bytes <- forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT (forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM forall a b. b -> Either a b
Right (Int -> m ByteString
getBytes' Int
count))
            if ByteString -> Int
Data.ByteString.length ByteString
bytes forall a. Ord a => a -> a -> Bool
< Int
count
                then 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 forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
bytes

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

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

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

    let unmarshalSig :: Signature -> Wire UnmarshalState [Value]
unmarshalSig = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Type -> Unmarshal Value
unmarshal 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 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [Value]
x'
            WireRL String
err  -> forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError String
err)
    [Value]
fixed <- forall {m :: * -> *}.
Monad m =>
Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
fixedSig ByteString
fixedBytes
    let messageType :: Word8
messageType = forall a. HasCallStack => Maybe a -> a
fromJust (forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed forall a. [a] -> Int -> a
!! Int
1))
    let flags :: Word8
flags = forall a. HasCallStack => Maybe a -> a
fromJust (forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed forall a. [a] -> Int -> a
!! Int
2))
    let bodyLength :: Word32
bodyLength = forall a. HasCallStack => Maybe a -> a
fromJust (forall a. IsValue a => Value -> Maybe a
fromValue ([Value]
fixed forall a. [a] -> Int -> a
!! Int
4)) :: Word32
    let serial :: Serial
serial = forall a. HasCallStack => Maybe a -> a
fromJust (forall a. IsVariant a => Variant -> Maybe a
fromVariant (Value -> Variant
Variant ([Value]
fixed forall a. [a] -> Int -> a
!! Int
5)))

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

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

    let Just Signature
headerSig  = forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature String
"yyyyuua(yv)"
    ByteString
fieldBytes <- Int -> ErrorT UnmarshalError m ByteString
getBytes (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 <- forall {m :: * -> *}.
Monad m =>
Signature -> ByteString -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
headerSig ByteString
headerBytes

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

findBodySignature :: [HeaderField] -> Signature
findBodySignature :: [HeaderField] -> Signature
findBodySignature [HeaderField]
fields = forall a. a -> Maybe a -> a
fromMaybe ([Type] -> Signature
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 <- forall a. String -> [a] -> ErrorM String a
require String
"path" [ObjectPath
x | HeaderPath ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- forall a. String -> [a] -> ErrorM String a
require String
"member name" [MemberName
x | HeaderMember MemberName
x <- [HeaderField]
fields]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
flags [Variant]
body -> let
        iface :: Maybe InterfaceName
iface = forall a. [a] -> Maybe a
listToMaybe [InterfaceName
x | HeaderInterface InterfaceName
x <- [HeaderField]
fields]
        dest :: Maybe BusName
dest = forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = 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 <- forall a. String -> [a] -> ErrorM String a
require String
"reply serial" [Serial
x | HeaderReplySerial Serial
x <- [HeaderField]
fields]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = 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 <- forall a. String -> [a] -> ErrorM String a
require String
"error name" [ErrorName
x | HeaderErrorName ErrorName
x <- [HeaderField]
fields]
    Serial
replySerial <- forall a. String -> [a] -> ErrorM String a
require String
"reply serial" [Serial
x | HeaderReplySerial Serial
x <- [HeaderField]
fields]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = 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 <- forall a. String -> [a] -> ErrorM String a
require String
"path" [ObjectPath
x | HeaderPath ObjectPath
x <- [HeaderField]
fields]
    MemberName
member <- forall a. String -> [a] -> ErrorM String a
require String
"member name" [MemberName
x | HeaderMember MemberName
x <- [HeaderField]
fields]
    InterfaceName
iface <- forall a. String -> [a] -> ErrorM String a
require String
"interface" [InterfaceName
x | HeaderInterface InterfaceName
x <- [HeaderField]
fields]
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
        dest :: Maybe BusName
dest = forall a. [a] -> Maybe a
listToMaybe [BusName
x | HeaderDestination BusName
x <- [HeaderField]
fields]
        sender :: Maybe BusName
sender = 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \Serial
serial Word8
_ [Variant]
body -> let
    sender :: Maybe BusName
sender = 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 :: forall a. String -> [a] -> ErrorM String a
require String
_     (a
x:[a]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return a
x
require String
label [a]
_     = forall e a. e -> ErrorM e a
throwErrorM String
label

unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage
unmarshalMessage :: ByteString -> Either UnmarshalError ReceivedMessage
unmarshalMessage ByteString
bytes = forall {b}.
Either String (Either UnmarshalError b) -> Either UnmarshalError b
checkError (forall a. Get a -> ByteString -> Either String a
Get.runGet Get (Either UnmarshalError ReceivedMessage)
get ByteString
bytes) where
    get :: Get (Either UnmarshalError ReceivedMessage)
get = 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 (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) = 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 :: forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
untilM m Bool
test m a
comp = do
    Bool
done <- m Bool
test
    if Bool
done
        then forall (m :: * -> *) a. Monad m => a -> m a
return []
        else do
            a
x <- m a
comp
            [a]
xs <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m [a]
untilM m Bool
test m a
comp
            forall (m :: * -> *) a. Monad m => a -> m a
return (a
xforall 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 { forall e a. ErrorM e a -> Either e a
runErrorM :: Either e a }

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

instance Control.Applicative.Applicative (ErrorM e) where
    pure :: forall a. a -> ErrorM e a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a 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 :: forall a. a -> ErrorM e a
return = forall e a. Either e a -> ErrorM e a
ErrorM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    >>= :: forall a b. ErrorM e a -> (a -> ErrorM e b) -> ErrorM e b
(>>=) ErrorM e a
m a -> ErrorM e b
k = case forall e a. ErrorM e a -> Either e a
runErrorM ErrorM e a
m of
        Left e
err -> forall e a. Either e a -> ErrorM e a
ErrorM (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 :: forall e a. e -> ErrorM e a
throwErrorM = forall e a. Either e a -> ErrorM e a
ErrorM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left

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

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

instance Monad m => Control.Applicative.Applicative (ErrorT e m) where
    pure :: forall a. a -> ErrorT e m a
pure = forall (m :: * -> *) a. Monad m => a -> m a
return
    <*> :: forall a 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 :: forall a. a -> ErrorT e m a
return = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. b -> Either a b
Right
    >>= :: forall a b. ErrorT e m a -> (a -> ErrorT e m b) -> ErrorT e m b
(>>=) ErrorT e m a
m a -> ErrorT e m b
k = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall a b. (a -> b) -> a -> b
$ do
        Either e a
x <- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. a -> Either a b
Left e
l)
            Right a
r -> 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 :: forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT = forall e (m :: * -> *) a. m (Either e a) -> ErrorT e m a
ErrorT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left