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

import Control.Monad
import Data.Bits           hiding (shift)
import Data.ByteString     (ByteString)
import Data.HashMap.Strict (HashMap)
import Data.Int            (Int16, Int32, Int64)
import Data.List           (sortBy)
import Data.Ord            (comparing)
import Data.Typeable       (Typeable)
import Data.Word           (Word64, Word8)

import qualified Data.ByteString        as B
import qualified Data.HashMap.Strict    as M
import qualified Data.Serialize.IEEE754 as G
import qualified Data.Serialize.Get     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 Compact Protocol.
compactProtocol :: Protocol
compactProtocol :: Protocol
compactProtocol = Protocol
    { serializeValue :: forall a. IsTType a => Value a -> Builder
serializeValue     = forall a. IsTType a => Value a -> Builder
compactSerialize
    , deserializeValue' :: forall a. IsTType a => Get (Value a)
deserializeValue'  = forall a. TType a -> Get (Value a)
compactDeserialize forall a. IsTType a => TType a
ttype
    , serializeMessage :: Message -> Builder
serializeMessage   = Message -> Builder
compactSerializeMessage
    , deserializeMessage' :: Get Message
deserializeMessage' = Get Message
compactDeserializeMessage
    }

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

protocolId, version :: Word8
protocolId :: Word8
protocolId = Word8
0x82
version :: Word8
version = Word8
0x01

compactSerializeMessage :: Message -> Builder
compactSerializeMessage :: Message -> Builder
compactSerializeMessage Message
msg =
    Word8 -> Builder
BB.word8 Word8
protocolId forall a. Semigroup a => a -> a -> a
<>
    Word8 -> Builder
BB.word8 ((Word8
version forall a. Bits a => a -> a -> a
.&. Word8
0x1f) forall a. Bits a => a -> a -> a
.|. (MessageType -> Word8
messageCode (Message -> MessageType
messageType Message
msg) forall a. Bits a => a -> Int -> a
`shiftL` Int
5)) forall a. Semigroup a => a -> a -> a
<>
    Int64 -> Builder
serializeVarint (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Message -> Int32
messageId Message
msg) forall a. Semigroup a => a -> a -> a
<>
    ByteString -> Builder
string (Text -> ByteString
TE.encodeUtf8 forall a b. (a -> b) -> a -> b
$ Message -> Text
messageName Message
msg) forall a. Semigroup a => a -> a -> a
<>
    forall a. IsTType a => Value a -> Builder
compactSerialize (Message -> Value TStruct
messagePayload Message
msg)

compactDeserializeMessage :: G.Get Message
compactDeserializeMessage :: Get Message
compactDeserializeMessage = do
    Word8
pid <- Get Word8
G.getWord8
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
pid forall a. Eq a => a -> a -> Bool
/= Word8
protocolId) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid protocol ID"
    Word8
w <- Get Word8
G.getWord8
    let ver :: Word8
ver = Word8
w forall a. Bits a => a -> a -> a
.&. Word8
0x1f
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
ver forall a. Eq a => a -> a -> Bool
/= Word8
version) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unsupported version: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
ver
    let code :: Word8
code = Word8
w forall a. Bits a => a -> Int -> a
`shiftR` Int
5
    Int64
msgId <- Get Int64
parseVarint
    Text
msgName <- ByteString -> Text
TE.decodeUtf8 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Get Int64
parseVarint forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Int -> Get ByteString
G.getBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral)
    Value TStruct
payload <- forall a. TType a -> Get (Value a)
compactDeserialize forall a. IsTType a => TType a
ttype
    MessageType
mtype <- case Word8 -> Maybe MessageType
fromMessageCode Word8
code of
        Maybe MessageType
Nothing -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"unknown message type: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
code
        Just MessageType
t -> forall (m :: * -> *) a. Monad m => a -> m a
return MessageType
t
    forall (m :: * -> *) a. Monad m => a -> m a
return Message { messageType :: MessageType
messageType = MessageType
mtype
                   , messageId :: Int32
messageId = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
msgId
                   , messageName :: Text
messageName = Text
msgName
                   , messagePayload :: Value TStruct
messagePayload = Value TStruct
payload
                   }


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

compactDeserialize :: TType a -> G.Get (Value a)
compactDeserialize :: forall a. TType a -> Get (Value a)
compactDeserialize TType a
typ = case TType a
typ of
  TType a
TBool      -> do
      Int8
n <- Get Int8
G.getInt8
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Value TBool
VBool (Int8
n forall a. Eq a => a -> a -> Bool
== Int8
1)
  TType a
TByte      -> Get (Value TByte)
parseByte
  TType a
TDouble    -> Get (Value TDouble)
parseDouble
  TType a
TInt16     -> Get (Value TInt16)
parseInt16
  TType a
TInt32     -> Get (Value TInt32)
parseInt32
  TType a
TInt64     -> Get (Value TInt64)
parseInt64
  TType a
TBinary    -> Get (Value TBinary)
parseBinary
  TType a
TStruct    -> Get (Value TStruct)
parseStruct
  TType a
TMap       -> Get (Value TMap)
parseMap
  TType a
TSet       -> Get (Value TSet)
parseSet
  TType a
TList      -> Get (Value TList)
parseList

intToZigZag :: Int64 -> Int64
intToZigZag :: Int64 -> Int64
intToZigZag Int64
n =
    (Int64
n forall a. Bits a => a -> Int -> a
`shiftL` Int
1) forall a. Bits a => a -> a -> a
`xor` (Int64
n forall a. Bits a => a -> Int -> a
`shiftR` Int
63)

zigZagToInt :: Int64 -> Int64
zigZagToInt :: Int64 -> Int64
zigZagToInt Int64
n =
    forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
n' forall a. Bits a => a -> Int -> a
`shiftR` Int
1) forall a. Bits a => a -> a -> a
`xor` (-(Int64
n forall a. Bits a => a -> a -> a
.&. Int64
1))
  where
    n' :: Word64
n' = forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n :: Word64
    -- ensure no sign extension

parseVarint :: G.Get Int64
parseVarint :: Get Int64
parseVarint = forall {b}. (Bits b, Num b) => b -> Int -> Get b
go Int64
0 Int
0
  where
    go :: b -> Int -> Get b
go !b
val !Int
shift = do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
shift forall a. Ord a => a -> a -> Bool
>= Int
64) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"parseVarint: too wide"
        Word8
n <- Get Word8
G.getWord8
        let val' :: b
val' = b
val forall a. Bits a => a -> a -> a
.|. ((forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n forall a. Bits a => a -> a -> a
.&. b
0x7f) forall a. Bits a => a -> Int -> a
`shiftL` Int
shift)
        if forall a. Bits a => a -> Int -> Bool
testBit Word8
n Int
7
          then b -> Int -> Get b
go b
val' (Int
shift forall a. Num a => a -> a -> a
+ Int
7)
          else forall (m :: * -> *) a. Monad m => a -> m a
return b
val'

getCType :: Word8 -> G.Get SomeCType
getCType :: Word8 -> Get SomeCType
getCType Word8
code =
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unknown CType: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Word8
code) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Word8 -> Maybe SomeCType
fromCompactCode Word8
code

parseByte :: G.Get (Value TByte)
parseByte :: Get (Value TByte)
parseByte = Int8 -> Value TByte
VByte 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Double
G.getFloat64le

parseInt16 :: G.Get (Value TInt16)
parseInt16 :: Get (Value TInt16)
parseInt16 = Int16 -> Value TInt16
VInt16 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
zigZagToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
parseVarint

parseInt32 :: G.Get (Value TInt32)
parseInt32 :: Get (Value TInt32)
parseInt32 = Int32 -> Value TInt32
VInt32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
zigZagToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
parseVarint

parseInt64 :: G.Get (Value TInt64)
parseInt64 :: Get (Value TInt64)
parseInt64 = Int64 -> Value TInt64
VInt64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
zigZagToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
parseVarint

parseBinary :: G.Get (Value TBinary)
parseBinary :: Get (Value TBinary)
parseBinary = do
    Int64
n <- Get Int64
parseVarint
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int64
n forall a. Ord a => a -> a -> Bool
< Int64
0) forall a b. (a -> b) -> a -> b
$
        forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"parseBinary: invalid length " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int64
n
    ByteString -> Value TBinary
VBinary forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Get ByteString
G.getBytes (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)


parseMap :: G.Get (Value TMap)
parseMap :: Get (Value TMap)
parseMap = do
    Int64
count <- Get Int64
parseVarint
    case Int64
count of
      Int64
0 -> forall (m :: * -> *) a. Monad m => a -> m a
return Value TMap
VNullMap
      Int64
_ -> do
          Word8
tys <- Get Word8
G.getWord8
          SomeCType CType a
kctype <- Word8 -> Get SomeCType
getCType (Word8
tys forall a. Bits a => a -> Int -> a
`shiftR` Int
4)
          SomeCType CType a
vctype <- Word8 -> Get SomeCType
getCType (Word8
tys forall a. Bits a => a -> a -> a
.&. Word8
0x0f)

          let ktype :: TType a
ktype = forall a. CType a -> TType a
cTypeToTType CType a
kctype
              vtype :: TType a
vtype = forall a. CType a -> TType a
cTypeToTType CType a
vctype

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


parseCollection
    :: (forall a. IsTType a => FL.FoldList (Value a) -> Value b)
    -> G.Get (Value b)
parseCollection :: forall b.
(forall a. IsTType a => FoldList (Value a) -> Value b)
-> Get (Value b)
parseCollection forall a. IsTType a => FoldList (Value a) -> Value b
buildValue = do
    Word8
sizeAndType <- Get Word8
G.getWord8
    SomeCType CType a
ctype <- Word8 -> Get SomeCType
getCType (Word8
sizeAndType forall a. Bits a => a -> a -> a
.&. Word8
0x0f)
    Int64
count <- case Word8
sizeAndType forall a. Bits a => a -> Int -> a
`shiftR` Int
4 of
                 Word8
0xf -> Get Int64
parseVarint
                 Word8
n   -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n
    let vtype :: TType a
vtype  = forall a. CType a -> TType a
cTypeToTType CType a
ctype
    forall a. IsTType a => FoldList (Value a) -> Value b
buildValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. Monad m => Int -> m a -> m (FoldList a)
FL.replicateM (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
count) (forall a. TType a -> Get (Value a)
compactDeserialize TType a
vtype)

parseSet :: G.Get (Value TSet)
parseSet :: Get (Value TSet)
parseSet = forall b.
(forall a. IsTType a => FoldList (Value a) -> Value b)
-> Get (Value b)
parseCollection forall a. IsTType a => FoldList (Value a) -> Value TSet
VSet

parseList :: G.Get (Value TList)
parseList :: Get (Value TList)
parseList = forall b.
(forall a. IsTType a => FoldList (Value a) -> Value b)
-> Get (Value b)
parseCollection forall a. IsTType a => FoldList (Value a) -> Value TList
VList

parseStruct :: G.Get (Value TStruct)
parseStruct :: Get (Value TStruct)
parseStruct = HashMap Int16 SomeValue -> Int16 -> Get (Value TStruct)
loop forall k v. HashMap k v
M.empty Int16
0
  where
    loop :: HashMap Int16 SomeValue -> Int16 -> G.Get (Value TStruct)
    loop :: HashMap Int16 SomeValue -> Int16 -> Get (Value TStruct)
loop HashMap Int16 SomeValue
fields Int16
lastFieldId = do
        Word8
sizeAndType <- Get Word8
G.getWord8
        SomeCType CType a
ctype <- Word8 -> Get SomeCType
getCType (Word8
sizeAndType forall a. Bits a => a -> a -> a
.&. Word8
0x0f)
        case CType a
ctype of
            CType a
CStop -> forall (m :: * -> *) a. Monad m => a -> m a
return (HashMap Int16 SomeValue -> Value TStruct
VStruct HashMap Int16 SomeValue
fields)
            CType a
_     -> do
                Int16
fieldId <- case Word8
sizeAndType forall a. Bits a => a -> Int -> a
`shiftR` Int
4 of
                               Word8
0x0 -> forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Int64
zigZagToInt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Int64
parseVarint
                               Word8
n   -> forall (m :: * -> *) a. Monad m => a -> m a
return (Int16
lastFieldId forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
n)
                SomeValue
value <- case CType a
ctype of
                  CType a
CBoolTrue  -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. IsTType a => Value a -> SomeValue
SomeValue forall a b. (a -> b) -> a -> b
$ Bool -> Value TBool
VBool Bool
True)
                  CType a
CBoolFalse -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. IsTType a => Value a -> SomeValue
SomeValue forall a b. (a -> b) -> a -> b
$ Bool -> Value TBool
VBool Bool
False)
                  CType a
_          ->
                    let vtype :: TType a
vtype = forall a. CType a -> TType a
cTypeToTType CType a
ctype
                     in forall a. IsTType a => Value a -> SomeValue
SomeValue forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TType a -> Get (Value a)
compactDeserialize TType a
vtype
                HashMap Int16 SomeValue -> Int16 -> Get (Value TStruct)
loop (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) Int16
fieldId


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

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

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) = forall a. CType a -> Builder
compactCode forall a b. (a -> b) -> a -> b
$ if Bool
x then CType TBool
CBoolTrue else CType TBool
CBoolFalse
{-# 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.doubleLE Double
x
{-# INLINE serializeDouble #-}

serializeVarint :: Int64 -> Builder
serializeVarint :: Int64 -> Builder
serializeVarint = Word64 -> Builder
go forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral
  where
    -- Ensure we don't sign extend
    go :: Word64 -> Builder
    go :: Word64 -> Builder
go Word64
n
      | forall a. Bits a => a -> a
complement Word64
0x7f forall a. Bits a => a -> a -> a
.&. Word64
n forall a. Eq a => a -> a -> Bool
== Word64
0 =
        Word8 -> Builder
BB.word8 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n
      | Bool
otherwise =
        Word8 -> Builder
BB.word8 (Word8
0x80 forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n forall a. Bits a => a -> a -> a
.&. Word8
0x7f)) forall a. Semigroup a => a -> a -> a
<>
        Word64 -> Builder
go (Word64
n forall a. Bits a => a -> Int -> a
`shiftR` Int
7)

serializeInt16 :: Value TInt16 -> Builder
serializeInt16 :: Value TInt16 -> Builder
serializeInt16 (VInt16 Int16
x) = Int64 -> Builder
serializeVarint forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
intToZigZag forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int16
x
{-# INLINE serializeInt16 #-}

serializeInt32 :: Value TInt32 -> Builder
serializeInt32 :: Value TInt32 -> Builder
serializeInt32 (VInt32 Int32
x) = Int64 -> Builder
serializeVarint forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
intToZigZag forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
x
{-# INLINE serializeInt32 #-}

serializeInt64 :: Value TInt64 -> Builder
serializeInt64 :: Value TInt64 -> Builder
serializeInt64 (VInt64 Int64
x) = Int64 -> Builder
serializeVarint forall a b. (a -> b) -> a -> b
$ Int64 -> Int64
intToZigZag Int64
x
{-# INLINE serializeInt64 #-}

serializeList :: Value TList -> Builder
serializeList :: Value TList -> Builder
serializeList (VList FoldList (Value a)
xs) = forall a. IsTType a => TType a -> FoldList (Value a) -> Builder
serializeCollection 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) = forall a. IsTType a => TType a -> FoldList (Value a) -> Builder
serializeCollection 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) =
    forall {t}. Integral t => t -> [(t, SomeValue)] -> Builder
loop Int16
0 (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
M.toList HashMap Int16 SomeValue
fields)
  where
    loop :: t -> [(t, SomeValue)] -> Builder
loop t
_ [] = forall a. CType a -> Builder
compactCode CType TStop
CStop
    loop t
lastFieldId ((t
fieldId, SomeValue
val) : [(t, SomeValue)]
rest) =
        let x :: Builder
x = case SomeValue
val of
                  SomeValue (VBool Bool
True)  -> forall a. CType a -> Builder
writeFieldHeader CType TBool
CBoolTrue
                  SomeValue (VBool Bool
False) -> forall a. CType a -> Builder
writeFieldHeader CType TBool
CBoolFalse
                  SomeValue (Value a
v :: Value a) ->
                      forall a. CType a -> Builder
writeFieldHeader (forall a. TType a -> CType a
tTypeToCType (forall a. IsTType a => TType a
ttype :: TType a)) forall a. Semigroup a => a -> a -> a
<> forall a. IsTType a => Value a -> Builder
compactSerialize Value a
v
        in Builder
x forall a. Semigroup a => a -> a -> a
<> t -> [(t, SomeValue)] -> Builder
loop t
fieldId [(t, SomeValue)]
rest
      where
        writeFieldHeader :: CType a -> Builder
        writeFieldHeader :: forall a. CType a -> Builder
writeFieldHeader CType a
ccode
          | t
fieldId forall a. Ord a => a -> a -> Bool
> t
lastFieldId Bool -> Bool -> Bool
&& t
fieldId forall a. Num a => a -> a -> a
- t
lastFieldId forall a. Ord a => a -> a -> Bool
< t
16
          = forall a. CType a -> Word8 -> Builder
compactCode' CType a
ccode (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ t
fieldId forall a. Num a => a -> a -> a
- t
lastFieldId)
          | Bool
otherwise
          = forall a. CType a -> Builder
compactCode CType a
ccode forall a. Semigroup a => a -> a -> a
<> Int64 -> Builder
serializeVarint (Int64 -> Int64
intToZigZag forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral t
fieldId)
{-# INLINE serializeStruct #-}

serializeMap :: Value TMap -> Builder
serializeMap :: Value TMap -> Builder
serializeMap Value TMap
VNullMap = Int8 -> Builder
BB.int8 Int8
0
serializeMap (VMap FoldList (MapItem k v)
items) = forall k v.
(IsTType k, IsTType v) =>
TType k -> TType v -> FoldList (MapItem k v) -> Builder
serialize forall a. IsTType a => TType a
ttype 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 :: forall k v.
(IsTType k, IsTType v) =>
TType k -> TType v -> FoldList (MapItem k v) -> Builder
serialize TType k
kt TType v
vt FoldList (MapItem k v)
xs
        | Int32
size forall a. Eq a => a -> a -> Bool
== Int32
0 = Int8 -> Builder
BB.int8 Int8
0
        | Bool
otherwise =
            Int64 -> Builder
serializeVarint (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
size) forall a. Semigroup a => a -> a -> a
<> Word8 -> Builder
BB.word8 Word8
typeByte forall a. Semigroup a => a -> a -> a
<> Builder
body
      where
        code :: TType a -> Word8
code = forall a. CType a -> Word8
toCompactCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. TType a -> CType a
tTypeToCType
        typeByte :: Word8
typeByte = (forall {a}. TType a -> Word8
code TType k
kt forall a. Bits a => a -> Int -> a
`shiftL` Int
4) forall a. Bits a => a -> a -> a
.|. forall {a}. TType a -> Word8
code TType v
vt
        (Builder
body, Int32
size) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' forall {a} {a} {b}.
(IsTType a, IsTType a, Num b) =>
(Builder, b) -> MapItem a a -> (Builder, b)
go (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 forall a. Semigroup a => a -> a -> a
<> forall a. IsTType a => Value a -> Builder
compactSerialize Value a
k forall a. Semigroup a => a -> a -> a
<> forall a. IsTType a => Value a -> Builder
compactSerialize Value a
v
            , b
c forall a. Num a => a -> a -> a
+ b
1
            )
{-# INLINE serializeMap #-}

serializeCollection
    :: IsTType a
    => TType a -> FL.FoldList (Value a) -> Builder
serializeCollection :: forall a. IsTType a => 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 forall a. Semigroup a => a -> a -> a
<> forall a. IsTType a => Value a -> Builder
compactSerialize Value a
item, b
c forall a. Num a => a -> a -> a
+ b
1)
        (Builder
body, Int32
size) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
FL.foldl' forall {a} {b}.
(IsTType a, Num b) =>
(Builder, b) -> Value a -> (Builder, b)
go (forall a. Monoid a => a
mempty, Int32
0 :: Int32) FoldList (Value a)
xs
        type_and_size :: Builder
type_and_size
          | Int32
size forall a. Ord a => a -> a -> Bool
< Int32
15 = forall a. TType a -> Word8 -> Builder
typeCode' TType a
vtype (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
size)
          | Bool
otherwise = forall a. TType a -> Word8 -> Builder
typeCode' TType a
vtype Word8
0xf forall a. Semigroup a => a -> a -> a
<> Int64 -> Builder
serializeVarint (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int32
size)
    in Builder
type_and_size forall a. Semigroup a => a -> a -> a
<> Builder
body
{-# INLINE serializeCollection #-}

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


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


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


data TStop deriving (Typeable)

instance IsTType TStop where
    ttype :: TType TStop
ttype = forall a. HasCallStack => String -> a
error String
"ttype TStop"

-- | A compact message type.
data CType a where
    CStop      :: CType TStop
    CBoolTrue  :: CType TBool
    CBoolFalse :: CType TBool
    CByte      :: CType TByte
    CInt16     :: CType TInt16
    CInt32     :: CType TInt32
    CInt64     :: CType TInt64
    CDouble    :: CType TDouble
    CBinary    :: CType TBinary
    CList      :: CType TList
    CSet       :: CType TSet
    CMap       :: CType TMap
    CStruct    :: CType TStruct


data SomeCType where
    SomeCType :: forall a. IsTType a => CType a -> SomeCType


-- | Map a TType to its type code.
toCompactCode :: CType a -> Word8
toCompactCode :: forall a. CType a -> Word8
toCompactCode CType a
CStop      = Word8
0
toCompactCode CType a
CBoolTrue  = Word8
1
toCompactCode CType a
CBoolFalse = Word8
2
toCompactCode CType a
CByte      = Word8
3
toCompactCode CType a
CInt16     = Word8
4
toCompactCode CType a
CInt32     = Word8
5
toCompactCode CType a
CInt64     = Word8
6
toCompactCode CType a
CDouble    = Word8
7
toCompactCode CType a
CBinary    = Word8
8
toCompactCode CType a
CList      = Word8
9
toCompactCode CType a
CSet       = Word8
10
toCompactCode CType a
CMap       = Word8
11
toCompactCode CType a
CStruct    = Word8
12
{-# INLINE toCompactCode #-}


-- | Map a type code to the corresponding TType.
fromCompactCode :: Word8 -> Maybe SomeCType
fromCompactCode :: Word8 -> Maybe SomeCType
fromCompactCode Word8
0  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TStop
CStop
fromCompactCode Word8
1  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TBool
CBoolTrue
fromCompactCode Word8
2  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TBool
CBoolFalse
fromCompactCode Word8
3  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TByte
CByte
fromCompactCode Word8
4  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TInt16
CInt16
fromCompactCode Word8
5  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TInt32
CInt32
fromCompactCode Word8
6  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TInt64
CInt64
fromCompactCode Word8
7  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TDouble
CDouble
fromCompactCode Word8
8  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TBinary
CBinary
fromCompactCode Word8
9  = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TList
CList
fromCompactCode Word8
10 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TSet
CSet
fromCompactCode Word8
11 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TMap
CMap
fromCompactCode Word8
12 = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. IsTType a => CType a -> SomeCType
SomeCType CType TStruct
CStruct
fromCompactCode Word8
_  = forall a. Maybe a
Nothing
{-# INLINE fromCompactCode #-}

tTypeToCType :: TType a -> CType a
tTypeToCType :: forall a. TType a -> CType a
tTypeToCType TType a
TBool      = CType TBool
CBoolTrue
tTypeToCType TType a
TByte      = CType TByte
CByte
tTypeToCType TType a
TInt16     = CType TInt16
CInt16
tTypeToCType TType a
TInt32     = CType TInt32
CInt32
tTypeToCType TType a
TInt64     = CType TInt64
CInt64
tTypeToCType TType a
TDouble    = CType TDouble
CDouble
tTypeToCType TType a
TBinary    = CType TBinary
CBinary
tTypeToCType TType a
TList      = CType TList
CList
tTypeToCType TType a
TSet       = CType TSet
CSet
tTypeToCType TType a
TMap       = CType TMap
CMap
tTypeToCType TType a
TStruct    = CType TStruct
CStruct

cTypeToTType :: CType a -> TType a
cTypeToTType :: forall a. CType a -> TType a
cTypeToTType CType a
CStop      = forall a. HasCallStack => String -> a
error String
"cTypeToTType: CStop"
cTypeToTType CType a
CBoolTrue  = TType TBool
TBool
cTypeToTType CType a
CBoolFalse = TType TBool
TBool
cTypeToTType CType a
CByte      = TType TByte
TByte
cTypeToTType CType a
CInt16     = TType TInt16
TInt16
cTypeToTType CType a
CInt32     = TType TInt32
TInt32
cTypeToTType CType a
CInt64     = TType TInt64
TInt64
cTypeToTType CType a
CDouble    = TType TDouble
TDouble
cTypeToTType CType a
CBinary    = TType TBinary
TBinary
cTypeToTType CType a
CList      = TType TList
TList
cTypeToTType CType a
CSet       = TType TSet
TSet
cTypeToTType CType a
CMap       = TType TMap
TMap
cTypeToTType CType a
CStruct    = TType TStruct
TStruct

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


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

compactCode :: CType a -> Builder
compactCode :: forall a. CType a -> Builder
compactCode = Word8 -> Builder
BB.word8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CType a -> Word8
toCompactCode
{-# INLINE compactCode #-}

compactCode' :: CType a  -- ^ The compact type code
             -> Word8    -- ^ a four-bit (unshifted) payload
             -> Builder
compactCode' :: forall a. CType a -> Word8 -> Builder
compactCode' CType a
ty Word8
payload =
    Word8 -> Builder
BB.word8 (forall a. CType a -> Word8
toCompactCode CType a
ty forall a. Bits a => a -> a -> a
.|. (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
payload forall a. Bits a => a -> Int -> a
`shiftL` Int
4))
{-# INLINE compactCode' #-}

typeCode' :: TType a -> Word8 -> Builder
typeCode' :: forall a. TType a -> Word8 -> Builder
typeCode' TType a
ty = forall a. CType a -> Word8 -> Builder
compactCode' (forall a. TType a -> CType a
tTypeToCType TType a
ty)
{-# INLINE typeCode' #-}