{-# LANGUAGE BangPatterns        #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module      :  Pinch.Protocol.Binary
-- Copyright   :  (c) Abhinav Gupta 2015
-- License     :  BSD3
--
-- Maintainer  :  Abhinav Gupta <mail@abhinavg.net>
-- Stability   :  experimental
--
-- Implements the Thrift Binary Protocol as a 'Protocol'.
module Pinch.Protocol.Binary (binaryProtocol) where


import Control.Monad
import Data.Bits           (shiftR, (.&.))
import Data.ByteString     (ByteString)
import Data.HashMap.Strict (HashMap)
import Data.Int            (Int16, Int32, Int8)

import qualified Data.ByteString        as B
import qualified Data.HashMap.Strict    as M
import qualified Data.Serialize.Get     as G
import qualified Data.Serialize.IEEE754 as G
import qualified Data.Text.Encoding     as TE

import Pinch.Internal.Builder (Builder)
import Pinch.Internal.Message
import Pinch.Internal.TType
import Pinch.Internal.Value
import Pinch.Protocol         (Protocol (..))

import qualified Pinch.Internal.Builder  as BB
import qualified Pinch.Internal.FoldList as FL


-- | Provides an implementation of the Thrift Binary Protocol.
binaryProtocol :: Protocol
binaryProtocol :: Protocol
binaryProtocol = Protocol :: (forall a. IsTType a => Value a -> Builder)
-> (Message -> Builder)
-> (forall a. IsTType a => Get (Value a))
-> Get Message
-> Protocol
Protocol
    { serializeValue :: forall a. IsTType a => Value a -> Builder
serializeValue     = forall a. IsTType a => Value a -> Builder
binarySerialize
    , deserializeValue' :: forall a. IsTType a => Get (Value a)
deserializeValue'  = TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
forall a. IsTType a => TType a
ttype
    , serializeMessage :: Message -> Builder
serializeMessage   = Message -> Builder
binarySerializeMessage
    , deserializeMessage' :: Get Message
deserializeMessage' = Get Message
binaryDeserializeMessage
    }

------------------------------------------------------------------------------

binarySerializeMessage :: Message -> Builder
binarySerializeMessage :: Message -> Builder
binarySerializeMessage Message
msg =
    Word8 -> Builder
BB.word8 Word8
0x80 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Word8 -> Builder
BB.word8 Word8
0x01 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Word8 -> Builder
BB.word8 Word8
0x00 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Int8 -> Builder
BB.int8 (MessageType -> Int8
messageCode (MessageType -> Int8) -> MessageType -> Int8
forall a b. (a -> b) -> a -> b
$ Message -> MessageType
messageType Message
msg) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
string (Text -> ByteString
TE.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ Message -> Text
messageName Message
msg) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Int32 -> Builder
BB.int32BE (Message -> Int32
messageId Message
msg) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
    Value TStruct -> Builder
forall a. IsTType a => Value a -> Builder
binarySerialize (Message -> Value TStruct
messagePayload Message
msg)

binaryDeserializeMessage :: G.Get Message
binaryDeserializeMessage :: Get Message
binaryDeserializeMessage = do
    Int32
size <- Get Int32
G.getInt32be
    if Int32
size Int32 -> Int32 -> Bool
forall a. Ord a => a -> a -> Bool
< Int32
0
        then Int32 -> Get Message
forall a. (Integral a, Bits a, Show a) => a -> Get Message
parseStrict Int32
size
        else Int32 -> Get Message
forall a. Integral a => a -> Get Message
parseNonStrict Int32
size
  where
    -- versionAndType:4 name~4 seqid:4 payload
    -- versionAndType = version:2 0x00 type:1
    parseStrict :: a -> Get Message
parseStrict a
versionAndType = do
        Bool -> Get () -> Get ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (a
version a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
1) (Get () -> Get ()) -> Get () -> Get ()
forall a b. (a -> b) -> a -> b
$
            String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$ String
"Unsupported version: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ a -> String
forall a. Show a => a -> String
show a
version
        Text -> MessageType -> Int32 -> Value TStruct -> Message
Message
            (Text -> MessageType -> Int32 -> Value TStruct -> Message)
-> (ByteString -> Text)
-> ByteString
-> MessageType
-> Int32
-> Value TStruct
-> Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Text
TE.decodeUtf8 (ByteString -> MessageType -> Int32 -> Value TStruct -> Message)
-> Get ByteString
-> Get (MessageType -> Int32 -> Value TStruct -> Message)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int32
G.getInt32be Get Int32 -> (Int32 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
G.getBytes (Int -> Get ByteString)
-> (Int32 -> Int) -> Int32 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)
            Get (MessageType -> Int32 -> Value TStruct -> Message)
-> Get MessageType -> Get (Int32 -> Value TStruct -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get MessageType
typ
            Get (Int32 -> Value TStruct -> Message)
-> Get Int32 -> Get (Value TStruct -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int32
G.getInt32be
            Get (Value TStruct -> Message)
-> Get (Value TStruct) -> Get Message
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TType TStruct -> Get (Value TStruct)
forall a. TType a -> Get (Value a)
binaryDeserialize TType TStruct
forall a. IsTType a => TType a
ttype
      where
        version :: a
version = (a
0x7fff0000 a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
versionAndType) a -> Int -> a
forall a. Bits a => a -> Int -> a
`shiftR` Int
16

        code :: Int8
code = a -> Int8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (a -> Int8) -> a -> Int8
forall a b. (a -> b) -> a -> b
$ a
0x00ff a -> a -> a
forall a. Bits a => a -> a -> a
.&. a
versionAndType
        typ :: Get MessageType
typ = case Int8 -> Maybe MessageType
fromMessageCode Int8
code of
            Maybe MessageType
Nothing -> String -> Get MessageType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get MessageType) -> String -> Get MessageType
forall a b. (a -> b) -> a -> b
$ String
"Unknown message type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int8 -> String
forall a. Show a => a -> String
show Int8
code
            Just MessageType
t -> MessageType -> Get MessageType
forall (m :: * -> *) a. Monad m => a -> m a
return MessageType
t

    -- name~4 type:1 seqid:4 payload
    parseNonStrict :: a -> Get Message
parseNonStrict a
nameLength =
        Text -> MessageType -> Int32 -> Value TStruct -> Message
Message
            (Text -> MessageType -> Int32 -> Value TStruct -> Message)
-> (ByteString -> Text)
-> ByteString
-> MessageType
-> Int32
-> Value TStruct
-> Message
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Text
TE.decodeUtf8 (ByteString -> MessageType -> Int32 -> Value TStruct -> Message)
-> Get ByteString
-> Get (MessageType -> Int32 -> Value TStruct -> Message)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getBytes (a -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
nameLength)
            Get (MessageType -> Int32 -> Value TStruct -> Message)
-> Get MessageType -> Get (Int32 -> Value TStruct -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get MessageType
parseMessageType
            Get (Int32 -> Value TStruct -> Message)
-> Get Int32 -> Get (Value TStruct -> Message)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Int32
G.getInt32be
            Get (Value TStruct -> Message)
-> Get (Value TStruct) -> Get Message
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TType TStruct -> Get (Value TStruct)
forall a. TType a -> Get (Value a)
binaryDeserialize TType TStruct
forall a. IsTType a => TType a
ttype


parseMessageType :: G.Get MessageType
parseMessageType :: Get MessageType
parseMessageType = Get Int8
G.getInt8 Get Int8 -> (Int8 -> Get MessageType) -> Get MessageType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int8
code -> case Int8 -> Maybe MessageType
fromMessageCode Int8
code of
    Maybe MessageType
Nothing -> String -> Get MessageType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get MessageType) -> String -> Get MessageType
forall a b. (a -> b) -> a -> b
$ String
"Unknown message type: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int8 -> String
forall a. Show a => a -> String
show Int8
code
    Just MessageType
t -> MessageType -> Get MessageType
forall (m :: * -> *) a. Monad m => a -> m a
return MessageType
t

------------------------------------------------------------------------------

binaryDeserialize :: TType a -> G.Get (Value a)
binaryDeserialize :: TType a -> Get (Value a)
binaryDeserialize TType a
typ = case TType a
typ of
  TType a
TBool   -> Get (Value a)
Get (Value TBool)
parseBool
  TType a
TByte   -> Get (Value a)
Get (Value TByte)
parseByte
  TType a
TDouble -> Get (Value a)
Get (Value TDouble)
parseDouble
  TType a
TInt16  -> Get (Value a)
Get (Value TInt16)
parseInt16
  TType a
TInt32  -> Get (Value a)
Get (Value TInt32)
parseInt32
  TType a
TInt64  -> Get (Value a)
Get (Value TInt64)
parseInt64
  TType a
TBinary -> Get (Value a)
Get (Value TBinary)
parseBinary
  TType a
TStruct -> Get (Value a)
Get (Value TStruct)
parseStruct
  TType a
TMap    -> Get (Value a)
Get (Value TMap)
parseMap
  TType a
TSet    -> Get (Value a)
Get (Value TSet)
parseSet
  TType a
TList   -> Get (Value a)
Get (Value TList)
parseList

getTType :: Int8 -> G.Get SomeTType
getTType :: Int8 -> Get SomeTType
getTType Int8
code =
    Get SomeTType
-> (SomeTType -> Get SomeTType) -> Maybe SomeTType -> Get SomeTType
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Get SomeTType
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get SomeTType) -> String -> Get SomeTType
forall a b. (a -> b) -> a -> b
$ String
"Unknown TType: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int8 -> String
forall a. Show a => a -> String
show Int8
code) SomeTType -> Get SomeTType
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SomeTType -> Get SomeTType)
-> Maybe SomeTType -> Get SomeTType
forall a b. (a -> b) -> a -> b
$ Int8 -> Maybe SomeTType
fromTypeCode Int8
code

parseTType :: G.Get SomeTType
parseTType :: Get SomeTType
parseTType = Get Int8
G.getInt8 Get Int8 -> (Int8 -> Get SomeTType) -> Get SomeTType
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int8 -> Get SomeTType
getTType

parseBool :: G.Get (Value TBool)
parseBool :: Get (Value TBool)
parseBool = Bool -> Value TBool
VBool (Bool -> Value TBool) -> (Int8 -> Bool) -> Int8 -> Value TBool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int8 -> Int8 -> Bool
forall a. Eq a => a -> a -> Bool
== Int8
1) (Int8 -> Value TBool) -> Get Int8 -> Get (Value TBool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
G.getInt8

parseByte :: G.Get (Value TByte)
parseByte :: Get (Value TByte)
parseByte = Int8 -> Value TByte
VByte (Int8 -> Value TByte) -> Get Int8 -> Get (Value TByte)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int8
G.getInt8

parseDouble :: G.Get (Value TDouble)
parseDouble :: Get (Value TDouble)
parseDouble = Double -> Value TDouble
VDouble (Double -> Value TDouble) -> Get Double -> Get (Value TDouble)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
G.getFloat64be

parseInt16 :: G.Get (Value TInt16)
parseInt16 :: Get (Value TInt16)
parseInt16 = Int16 -> Value TInt16
VInt16 (Int16 -> Value TInt16) -> Get Int16 -> Get (Value TInt16)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int16
G.getInt16be

parseInt32 :: G.Get (Value TInt32)
parseInt32 :: Get (Value TInt32)
parseInt32 = Int32 -> Value TInt32
VInt32 (Int32 -> Value TInt32) -> Get Int32 -> Get (Value TInt32)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int32
G.getInt32be

parseInt64 :: G.Get (Value TInt64)
parseInt64 :: Get (Value TInt64)
parseInt64 = Int64 -> Value TInt64
VInt64 (Int64 -> Value TInt64) -> Get Int64 -> Get (Value TInt64)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
G.getInt64be

parseBinary :: G.Get (Value TBinary)
parseBinary :: Get (Value TBinary)
parseBinary = ByteString -> Value TBinary
VBinary (ByteString -> Value TBinary)
-> Get ByteString -> Get (Value TBinary)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int32
G.getInt32be Get Int32 -> (Int32 -> Get ByteString) -> Get ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
G.getBytes (Int -> Get ByteString)
-> (Int32 -> Int) -> Int32 -> Get ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)


parseMap :: G.Get (Value TMap)
parseMap :: Get (Value TMap)
parseMap = do
    SomeTType
ktype' <- Get SomeTType
parseTType
    SomeTType
vtype' <- Get SomeTType
parseTType
    Int32
count <- Get Int32
G.getInt32be

    case (SomeTType
ktype', SomeTType
vtype') of
      (SomeTType TType a
ktype, SomeTType TType a
vtype) -> do
        FoldList (MapItem a a)
items <- Int -> Get (MapItem a a) -> Get (FoldList (MapItem a a))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (FoldList a)
FL.replicateM (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
count) (Get (MapItem a a) -> Get (FoldList (MapItem a a)))
-> Get (MapItem a a) -> Get (FoldList (MapItem a a))
forall a b. (a -> b) -> a -> b
$
            Value a -> Value a -> MapItem a a
forall k v. Value k -> Value v -> MapItem k v
MapItem (Value a -> Value a -> MapItem a a)
-> Get (Value a) -> Get (Value a -> MapItem a a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
ktype
                    Get (Value a -> MapItem a a) -> Get (Value a) -> Get (MapItem a a)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
vtype
        Value TMap -> Get (Value TMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value TMap -> Get (Value TMap)) -> Value TMap -> Get (Value TMap)
forall a b. (a -> b) -> a -> b
$ FoldList (MapItem a a) -> Value TMap
forall k a.
(IsTType k, IsTType a) =>
FoldList (MapItem k a) -> Value TMap
VMap FoldList (MapItem a a)
items


parseSet :: G.Get (Value TSet)
parseSet :: Get (Value TSet)
parseSet = do
    SomeTType
vtype' <- Get SomeTType
parseTType
    Int32
count <- Get Int32
G.getInt32be

    case SomeTType
vtype' of
      SomeTType TType a
vtype ->
          FoldList (Value a) -> Value TSet
forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet (FoldList (Value a) -> Value TSet)
-> Get (FoldList (Value a)) -> Get (Value TSet)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get (Value a) -> Get (FoldList (Value a))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (FoldList a)
FL.replicateM (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
count) (TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
vtype)


parseList :: G.Get (Value TList)
parseList :: Get (Value TList)
parseList = do
    SomeTType
vtype' <- Get SomeTType
parseTType
    Int32
count <- Get Int32
G.getInt32be

    case SomeTType
vtype' of
      SomeTType TType a
vtype ->
        FoldList (Value a) -> Value TList
forall a. IsTType a => FoldList (Value a) -> Value TList
VList (FoldList (Value a) -> Value TList)
-> Get (FoldList (Value a)) -> Get (Value TList)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get (Value a) -> Get (FoldList (Value a))
forall (m :: * -> *) a. Monad m => Int -> m a -> m (FoldList a)
FL.replicateM (Int32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
count) (TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
vtype)


parseStruct :: G.Get (Value TStruct)
parseStruct :: Get (Value TStruct)
parseStruct = Get Int8
G.getInt8 Get Int8 -> (Int8 -> Get (Value TStruct)) -> Get (Value TStruct)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HashMap Int16 SomeValue -> Int8 -> Get (Value TStruct)
loop HashMap Int16 SomeValue
forall k v. HashMap k v
M.empty
  where
    loop :: HashMap Int16 SomeValue -> Int8 -> G.Get (Value TStruct)
    loop :: HashMap Int16 SomeValue -> Int8 -> Get (Value TStruct)
loop HashMap Int16 SomeValue
fields    Int8
0 = Value TStruct -> Get (Value TStruct)
forall (m :: * -> *) a. Monad m => a -> m a
return (Value TStruct -> Get (Value TStruct))
-> Value TStruct -> Get (Value TStruct)
forall a b. (a -> b) -> a -> b
$ HashMap Int16 SomeValue -> Value TStruct
VStruct HashMap Int16 SomeValue
fields
    loop HashMap Int16 SomeValue
fields Int8
code = do
        SomeTType
vtype' <- Int8 -> Get SomeTType
getTType Int8
code
        Int16
fieldId <- Get Int16
G.getInt16be
        case SomeTType
vtype' of
          SomeTType TType a
vtype -> do
            SomeValue
value <- Value a -> SomeValue
forall a. IsTType a => Value a -> SomeValue
SomeValue (Value a -> SomeValue) -> Get (Value a) -> Get SomeValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TType a -> Get (Value a)
forall a. TType a -> Get (Value a)
binaryDeserialize TType a
vtype
            HashMap Int16 SomeValue -> Int8 -> Get (Value TStruct)
loop (Int16
-> SomeValue -> HashMap Int16 SomeValue -> HashMap Int16 SomeValue
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
M.insert Int16
fieldId SomeValue
value HashMap Int16 SomeValue
fields) (Int8 -> Get (Value TStruct)) -> Get Int8 -> Get (Value TStruct)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Get Int8
G.getInt8


------------------------------------------------------------------------------

binarySerialize :: forall a. IsTType a => Value a -> Builder
binarySerialize :: Value a -> Builder
binarySerialize = case (TType a
forall a. IsTType a => TType a
ttype :: TType a) of
  TType a
TBinary  -> Value a -> Builder
Value TBinary -> Builder
serializeBinary
  TType a
TBool    -> Value a -> Builder
Value TBool -> Builder
serializeBool
  TType a
TByte    -> Value a -> Builder
Value TByte -> Builder
serializeByte
  TType a
TDouble  -> Value a -> Builder
Value TDouble -> Builder
serializeDouble
  TType a
TInt16   -> Value a -> Builder
Value TInt16 -> Builder
serializeInt16
  TType a
TInt32   -> Value a -> Builder
Value TInt32 -> Builder
serializeInt32
  TType a
TInt64   -> Value a -> Builder
Value TInt64 -> Builder
serializeInt64
  TType a
TStruct  -> Value a -> Builder
Value TStruct -> Builder
serializeStruct
  TType a
TList    -> Value a -> Builder
Value TList -> Builder
serializeList
  TType a
TMap     -> Value a -> Builder
Value TMap -> Builder
serializeMap
  TType a
TSet     -> Value a -> Builder
Value TSet -> Builder
serializeSet
{-# INLINE binarySerialize #-}

serializeBinary :: Value TBinary -> Builder
serializeBinary :: Value TBinary -> Builder
serializeBinary (VBinary ByteString
x) = ByteString -> Builder
string ByteString
x
{-# INLINE serializeBinary #-}

serializeBool :: Value TBool -> Builder
serializeBool :: Value TBool -> Builder
serializeBool (VBool Bool
x) = Int8 -> Builder
BB.int8 (Int8 -> Builder) -> Int8 -> Builder
forall a b. (a -> b) -> a -> b
$ if Bool
x then Int8
1 else Int8
0
{-# INLINE serializeBool #-}

serializeByte :: Value TByte -> Builder
serializeByte :: Value TByte -> Builder
serializeByte (VByte Int8
x) = Int8 -> Builder
BB.int8 Int8
x
{-# INLINE serializeByte #-}

serializeDouble :: Value TDouble -> Builder
serializeDouble :: Value TDouble -> Builder
serializeDouble (VDouble Double
x) = Double -> Builder
BB.doubleBE Double
x
{-# INLINE serializeDouble #-}

serializeInt16 :: Value TInt16 -> Builder
serializeInt16 :: Value TInt16 -> Builder
serializeInt16 (VInt16 Int16
x) = Int16 -> Builder
BB.int16BE Int16
x
{-# INLINE serializeInt16 #-}

serializeInt32 :: Value TInt32 -> Builder
serializeInt32 :: Value TInt32 -> Builder
serializeInt32 (VInt32 Int32
x) = Int32 -> Builder
BB.int32BE Int32
x
{-# INLINE serializeInt32 #-}

serializeInt64 :: Value TInt64 -> Builder
serializeInt64 :: Value TInt64 -> Builder
serializeInt64 (VInt64 Int64
x) = Int64 -> Builder
BB.int64BE Int64
x
{-# INLINE serializeInt64 #-}

serializeList :: Value TList -> Builder
serializeList :: Value TList -> Builder
serializeList (VList FoldList (Value a)
xs) = TType a -> FoldList (Value a) -> Builder
forall a. IsTType a => TType a -> FoldList (Value a) -> Builder
serializeCollection TType a
forall a. IsTType a => TType a
ttype FoldList (Value a)
xs
{-# INLINE serializeList #-}

serializeSet :: Value TSet -> Builder
serializeSet :: Value TSet -> Builder
serializeSet (VSet FoldList (Value a)
xs) = TType a -> FoldList (Value a) -> Builder
forall a. IsTType a => TType a -> FoldList (Value a) -> Builder
serializeCollection TType a
forall a. IsTType a => TType a
ttype FoldList (Value a)
xs
{-# INLINE serializeSet #-}

serializeStruct :: Value TStruct -> Builder
serializeStruct :: Value TStruct -> Builder
serializeStruct (VStruct HashMap Int16 SomeValue
fields) =
    (Builder -> Int16 -> SomeValue -> Builder)
-> Builder -> HashMap Int16 SomeValue -> Builder
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
M.foldlWithKey'
        (\Builder
rest Int16
fid (SomeValue Value a
val) -> Builder
rest Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> TType a -> Value a -> Builder
forall a. IsTType a => Int16 -> TType a -> Value a -> Builder
writeField Int16
fid TType a
forall a. IsTType a => TType a
ttype Value a
val)
        Builder
forall a. Monoid a => a
mempty HashMap Int16 SomeValue
fields
    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int8 -> Builder
BB.int8 Int8
0
  where
    writeField :: IsTType a => Int16 -> TType a -> Value a -> Builder
    writeField :: Int16 -> TType a -> Value a -> Builder
writeField Int16
fieldId TType a
fieldType Value a
fieldValue =
        TType a -> Builder
forall a. TType a -> Builder
typeCode TType a
fieldType Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int16 -> Builder
BB.int16BE Int16
fieldId Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value a -> Builder
forall a. IsTType a => Value a -> Builder
binarySerialize Value a
fieldValue
    {-# INLINE writeField #-}
{-# INLINE serializeStruct #-}

serializeMap :: Value TMap -> Builder
serializeMap :: Value TMap -> Builder
serializeMap Value TMap
VNullMap = String -> Builder
forall a. HasCallStack => String -> a
error String
"serializeMap: VNullMap"
serializeMap (VMap FoldList (MapItem k v)
items) = TType k -> TType v -> FoldList (MapItem k v) -> Builder
forall k v.
(IsTType k, IsTType v) =>
TType k -> TType v -> FoldList (MapItem k v) -> Builder
serialize TType k
forall a. IsTType a => TType a
ttype TType v
forall a. IsTType a => TType a
ttype FoldList (MapItem k v)
items
  where
    serialize
        :: (IsTType k, IsTType v)
        => TType k -> TType v -> FL.FoldList (MapItem k v) -> Builder
    serialize :: TType k -> TType v -> FoldList (MapItem k v) -> Builder
serialize TType k
kt TType v
vt FoldList (MapItem k v)
xs =
        TType k -> Builder
forall a. TType a -> Builder
typeCode TType k
kt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> TType v -> Builder
forall a. TType a -> Builder
typeCode TType v
vt Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
BB.int32BE Int32
size Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body
      where
        (Builder
body, Int32
size) = ((Builder, Int32) -> MapItem k v -> (Builder, Int32))
-> (Builder, Int32) -> FoldList (MapItem k v) -> (Builder, Int32)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (Builder, Int32) -> MapItem k v -> (Builder, Int32)
forall a a b.
(IsTType a, IsTType a, Num b) =>
(Builder, b) -> MapItem a a -> (Builder, b)
go (Builder
forall a. Monoid a => a
mempty, Int32
0 :: Int32) FoldList (MapItem k v)
xs
        go :: (Builder, b) -> MapItem a a -> (Builder, b)
go (Builder
prev, !b
c) (MapItem Value a
k Value a
v) =
            ( Builder
prev Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value a -> Builder
forall a. IsTType a => Value a -> Builder
binarySerialize Value a
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value a -> Builder
forall a. IsTType a => Value a -> Builder
binarySerialize Value a
v
            , b
c b -> b -> b
forall a. Num a => a -> a -> a
+ b
1
            )
{-# INLINE serializeMap #-}

serializeCollection
    :: IsTType a
    => TType a -> FL.FoldList (Value a) -> Builder
serializeCollection :: TType a -> FoldList (Value a) -> Builder
serializeCollection TType a
vtype FoldList (Value a)
xs =
    let go :: (Builder, b) -> Value a -> (Builder, b)
go (Builder
prev, !b
c) Value a
item = (Builder
prev Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value a -> Builder
forall a. IsTType a => Value a -> Builder
binarySerialize Value a
item, b
c b -> b -> b
forall a. Num a => a -> a -> a
+ b
1)
        (Builder
body, Int32
size) = ((Builder, Int32) -> Value a -> (Builder, Int32))
-> (Builder, Int32) -> FoldList (Value a) -> (Builder, Int32)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' (Builder, Int32) -> Value a -> (Builder, Int32)
forall a b.
(IsTType a, Num b) =>
(Builder, b) -> Value a -> (Builder, b)
go (Builder
forall a. Monoid a => a
mempty, Int32
0 :: Int32) FoldList (Value a)
xs
    in TType a -> Builder
forall a. TType a -> Builder
typeCode TType a
vtype Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int32 -> Builder
BB.int32BE Int32
size Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
body
{-# INLINE serializeCollection #-}

------------------------------------------------------------------------------


messageCode :: MessageType -> Int8
messageCode :: MessageType -> Int8
messageCode MessageType
Call      = Int8
1
messageCode MessageType
Reply     = Int8
2
messageCode MessageType
Exception = Int8
3
messageCode MessageType
Oneway    = Int8
4
{-# INLINE messageCode #-}


fromMessageCode :: Int8 -> Maybe MessageType
fromMessageCode :: Int8 -> Maybe MessageType
fromMessageCode Int8
1 = MessageType -> Maybe MessageType
forall a. a -> Maybe a
Just MessageType
Call
fromMessageCode Int8
2 = MessageType -> Maybe MessageType
forall a. a -> Maybe a
Just MessageType
Reply
fromMessageCode Int8
3 = MessageType -> Maybe MessageType
forall a. a -> Maybe a
Just MessageType
Exception
fromMessageCode Int8
4 = MessageType -> Maybe MessageType
forall a. a -> Maybe a
Just MessageType
Oneway
fromMessageCode Int8
_ = Maybe MessageType
forall a. Maybe a
Nothing
{-# INLINE fromMessageCode #-}


-- | Map a TType to its type code.
toTypeCode :: TType a -> Int8
toTypeCode :: TType a -> Int8
toTypeCode TType a
TBool   = Int8
2
toTypeCode TType a
TByte   = Int8
3
toTypeCode TType a
TDouble = Int8
4
toTypeCode TType a
TInt16  = Int8
6
toTypeCode TType a
TInt32  = Int8
8
toTypeCode TType a
TInt64  = Int8
10
toTypeCode TType a
TBinary = Int8
11
toTypeCode TType a
TStruct = Int8
12
toTypeCode TType a
TMap    = Int8
13
toTypeCode TType a
TSet    = Int8
14
toTypeCode TType a
TList   = Int8
15
{-# INLINE toTypeCode #-}


-- | Map a type code to the corresponding TType.
fromTypeCode :: Int8 -> Maybe SomeTType
fromTypeCode :: Int8 -> Maybe SomeTType
fromTypeCode Int8
2  = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TBool -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TBool
TBool
fromTypeCode Int8
3  = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TByte -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TByte
TByte
fromTypeCode Int8
4  = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TDouble -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TDouble
TDouble
fromTypeCode Int8
6  = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TInt16 -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TInt16
TInt16
fromTypeCode Int8
8  = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TInt32 -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TInt32
TInt32
fromTypeCode Int8
10 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TInt64 -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TInt64
TInt64
fromTypeCode Int8
11 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TBinary -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TBinary
TBinary
fromTypeCode Int8
12 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TStruct -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TStruct
TStruct
fromTypeCode Int8
13 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TMap -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TMap
TMap
fromTypeCode Int8
14 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TSet -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TSet
TSet
fromTypeCode Int8
15 = SomeTType -> Maybe SomeTType
forall a. a -> Maybe a
Just (SomeTType -> Maybe SomeTType) -> SomeTType -> Maybe SomeTType
forall a b. (a -> b) -> a -> b
$ TType TList -> SomeTType
forall a. IsTType a => TType a -> SomeTType
SomeTType TType TList
TList
fromTypeCode Int8
_  = Maybe SomeTType
forall a. Maybe a
Nothing
{-# INLINE fromTypeCode #-}

------------------------------------------------------------------------------


string :: ByteString -> Builder
string :: ByteString -> Builder
string ByteString
b = Int32 -> Builder
BB.int32BE (Int -> Int32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Int32) -> Int -> Int32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
b) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BB.byteString ByteString
b
{-# INLINE string #-}

typeCode :: TType a -> Builder
typeCode :: TType a -> Builder
typeCode = Int8 -> Builder
BB.int8 (Int8 -> Builder) -> (TType a -> Int8) -> TType a -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TType a -> Int8
forall a. TType a -> Int8
toTypeCode
{-# INLINE typeCode #-}