{-# Language LambdaCase #-}
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 Data.List (sortOn)
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 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 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 -> 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'
{-# 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 (>>=) #-}
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'
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
!(Map Fd Word32)
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 Map Fd Word32
fds) -> 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 -> Map Fd Word32 -> MarshalState
MarshalState Builder
builder' Word64
count' Map Fd Word32
fds))
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 Map Fd Word32
_) <- 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
![Fd]
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 [Fd]
fds) <- 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 -> [Fd] -> UnmarshalState
UnmarshalState ByteString
bytes' (Word64
offset forall a. Num a => a -> a -> a
+ Word64
count) [Fd]
fds)
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 [Fd]
_) <- 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 :: Fd
fd@(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 = do
MarshalState Builder
builder Word64
count Map Fd Word32
fds <- forall s. Wire s s
getState
case forall k a. Ord k => k -> Map k a -> Maybe a
Data.Map.lookup Fd
fd Map Fd Word32
fds of
Just Word32
i -> Word32 -> Marshal ()
marshalWord32 Word32
i
Maybe Word32
Nothing -> do
let i :: Word32
i = forall a b. (Integral a, Num b) => a -> b
fromIntegral (forall k a. Map k a -> Int
Data.Map.size Map Fd Word32
fds)
forall s. s -> Wire s ()
putState (Builder -> Word64 -> Map Fd Word32 -> MarshalState
MarshalState Builder
builder Word64
count (forall k a. Ord k => k -> a -> Map k a -> Map k a
Data.Map.insert Fd
fd Word32
i Map Fd Word32
fds))
Word32 -> Marshal ()
marshalWord32 Word32
i
unmarshalUnixFd :: Unmarshal Fd
unmarshalUnixFd :: Unmarshal Fd
unmarshalUnixFd = do
Int
x <- forall a b. (Integral a, Num b) => a -> b
fromIntegral forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Unmarshal Word32
unmarshalWord32
UnmarshalState ByteString
_ Word64
_ [Fd]
fds <- forall s. Wire s s
getState
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
x forall a. Ord a => a -> a -> Bool
>= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Fd]
fds) forall a b. (a -> b) -> a -> b
$ do
forall s a. String -> Wire s a
throwError (String
"File descriptor index " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
x forall a. [a] -> [a] -> [a]
++ String
" out of bounds - only " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Fd]
fds) forall a. [a] -> [a] -> [a]
++ String
" file descriptors in message header.")
forall (m :: * -> *) a. Monad m => a -> m a
return ([Fd]
fds forall a. [a] -> Int -> a
!! Int
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 Builder
bytes Word64
count Map Fd Word32
fds) <- forall s. Wire s s
getState
(MarshalState Builder
_ Word64
afterLength Map Fd Word32
_) <- 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 Map Fd Word32
_) <- 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 -> Map Fd Word32 -> MarshalState
MarshalState forall a. Monoid a => a
mempty Word64
afterPadding Map Fd Word32
fds)
(MarshalState Builder
itemBuilder Word64
_ Map Fd Word32
fds') <- 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 (Builder -> Word64 -> Map Fd Word32 -> MarshalState
MarshalState Builder
bytes Word64
count Map Fd Word32
fds')
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 [Fd]
_) <- 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, [Fd])
marshalMessage :: forall a.
Message a =>
Endianness -> Serial -> a -> Either MarshalError (ByteString, [Fd])
marshalMessage Endianness
e Serial
serial a
msg = Either MarshalError (ByteString, [Fd])
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 Builder
emptyBytes Word64
emptyCount Map Fd Word32
_ <- 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
_ Map Fd Word32
fds) <- forall s. Wire s s
getState
forall s. s -> Wire s ()
putState (Builder -> Word64 -> Map Fd Word32 -> MarshalState
MarshalState Builder
emptyBytes Word64
emptyCount Map Fd Word32
fds)
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 -> Int -> Marshal ()
marshalHeader a
msg Serial
serial Signature
sig (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int64
Lazy.length ByteString
bodyBytes)) (forall k a. Map k a -> Int
Data.Map.size Map Fd Word32
fds)
Word8 -> Marshal ()
pad Word8
8
ByteString -> Marshal ()
appendL ByteString
bodyBytes
Marshal ()
checkMaximumSize
emptyState :: MarshalState
emptyState = Builder -> Word64 -> Map Fd Word32 -> MarshalState
MarshalState forall a. Monoid a => a
mempty Word64
0 forall a. Monoid a => a
mempty
runMarshal :: Either MarshalError (ByteString, [Fd])
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
_ Map Fd Word32
fds) ->
let fdList :: [Fd]
fdList = (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Data.Map.toList) Map Fd Word32
fds
in forall a b. b -> Either a b
Right (ByteString -> ByteString
Lazy.toStrict (Builder -> ByteString
Builder.toLazyByteString Builder
builder), [Fd]
fdList)
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 -> Int
-> Marshal ()
a
msg Serial
serial Signature
bodySig Word32
bodyLength Int
numFds = do
let fields :: [HeaderField]
fields = Signature -> HeaderField
HeaderSignature Signature
bodySig forall a. a -> [a] -> [a]
: Int -> [HeaderField] -> [HeaderField]
consUnixFdsField Int
numFds (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))
consUnixFdsField :: Int -> [HeaderField] -> [HeaderField]
consUnixFdsField :: Int -> [HeaderField] -> [HeaderField]
consUnixFdsField Int
numFds [HeaderField]
headers =
if Int
numFds forall a. Eq a => a -> a -> Bool
== Int
0
then [HeaderField]
filteredHeaders
else Word32 -> HeaderField
HeaderUnixFds (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
numFds) forall a. a -> [a] -> [a]
: [HeaderField]
filteredHeaders
where
filteredHeaders :: [HeaderField]
filteredHeaders = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderField -> Bool
isHeaderUnixFds) [HeaderField]
headers
isHeaderUnixFds :: HeaderField -> Bool
isHeaderUnixFds = \case
HeaderUnixFds Word32
_ -> Bool
True
HeaderField
_ -> Bool
False
checkMaximumSize :: Marshal ()
checkMaximumSize :: Marshal ()
checkMaximumSize = do
(MarshalState Builder
_ Word64
messageLength Map Fd Word32
_) <- 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, [Fd]))
-> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM :: forall (m :: * -> *).
Monad m =>
(Int -> m (ByteString, [Fd]))
-> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> m (ByteString, [Fd])
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, [Fd])
getBytes Int
count = do
(ByteString
bytes, [Fd]
fds) <- 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, [Fd])
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, [Fd]
fds)
let Just Signature
fixedSig = forall (m :: * -> *). MonadThrow m => String -> m Signature
parseSignature String
"yyyyuuu"
(ByteString
fixedBytes, [Fd]
fixedFds) <- Int -> ErrorT UnmarshalError m (ByteString, [Fd])
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 -> [Fd] -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
x ByteString
bytes [Fd]
fds = case forall s a. Wire s a -> Endianness -> s -> WireR s a
unWire (Signature -> Wire UnmarshalState [Value]
unmarshalSig Signature
x) Endianness
endianness (ByteString -> Word64 -> [Fd] -> UnmarshalState
UnmarshalState ByteString
bytes Word64
0 [Fd]
fds) 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 -> [Fd] -> 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
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, [Fd]
fieldFds) <- Int -> ErrorT UnmarshalError m (ByteString, [Fd])
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 -> [Fd] -> 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
_, [Fd]
paddingFds) <- Int -> ErrorT UnmarshalError m (ByteString, [Fd])
getBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
bodyPadding)
let bodySig :: Signature
bodySig = [HeaderField] -> Signature
findBodySignature [HeaderField]
fields
(ByteString
bodyBytes, [Fd]
bodyFds) <- Int -> ErrorT UnmarshalError m (ByteString, [Fd])
getBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
bodyLength)
let fds :: [Fd]
fds = [Fd]
fixedFds forall a. Semigroup a => a -> a -> a
<> [Fd]
fieldFds forall a. Semigroup a => a -> a -> a
<> [Fd]
paddingFds forall a. Semigroup a => a -> a -> a
<> [Fd]
bodyFds
forall (m :: * -> *).
Monad m =>
[HeaderField] -> [Fd] -> ErrorT UnmarshalError m ()
checkUnixFdsHeader [HeaderField]
fields [Fd]
fds
[Value]
body <- forall {m :: * -> *}.
Monad m =>
Signature -> ByteString -> [Fd] -> ErrorT UnmarshalError m [Value]
unmarshal' Signature
bodySig ByteString
bodyBytes [Fd]
fds
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))
checkUnixFdsHeader :: Monad m => [HeaderField] -> [Fd] -> ErrorT UnmarshalError m ()
[HeaderField]
fields [Fd]
fds = do
let headerCount :: Int
headerCount = [HeaderField] -> Int
findUnixFds [HeaderField]
fields
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
headerCount forall a. Eq a => a -> a -> Bool
/= forall (t :: * -> *) a. Foldable t => t a -> Int
length [Fd]
fds) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) e a. Monad m => e -> ErrorT e m a
throwErrorT (String -> UnmarshalError
UnmarshalError (String
"File descriptor count in message header"
forall a. Semigroup a => a -> a -> a
<> String
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Int
headerCount forall a. Semigroup a => a -> a -> a
<> String
") does not match the number of file descriptors"
forall a. Semigroup a => a -> a -> a
<> String
" received from the socket (" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Fd]
fds) forall a. Semigroup a => a -> a -> a
<> String
")."))
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])
findUnixFds :: [HeaderField] -> Int
findUnixFds :: [HeaderField] -> Int
findUnixFds [HeaderField]
fields = forall a. a -> Maybe a -> a
fromMaybe Int
0 (forall a. [a] -> Maybe a
listToMaybe [forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
n | HeaderUnixFds Word32
n <- [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 -> [Fd] -> Either UnmarshalError ReceivedMessage
unmarshalMessage :: ByteString -> [Fd] -> Either UnmarshalError ReceivedMessage
unmarshalMessage ByteString
bytes [Fd]
fds = 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, [Fd]))
-> m (Either UnmarshalError ReceivedMessage)
unmarshalMessageM Int -> Get (ByteString, [Fd])
getBytes
getBytes :: Int -> Get (ByteString, [Fd])
getBytes Int
count = do
Int
remaining <- Get Int
Get.remaining
ByteString
buf <- Int -> Get ByteString
Get.getByteString (forall a. Ord a => a -> a -> a
min Int
remaining Int
count)
forall (m :: * -> *) a. Monad m => a -> m a
return (ByteString
buf, if Int
remaining forall a. Eq a => a -> a -> Bool
== ByteString -> Int
Data.ByteString.length ByteString
bytes then [Fd]
fds else [])
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)
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 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 -> 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
>>= :: 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 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 -> 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
>>= :: 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