{-# LANGUAGE LambdaCase  #-}
{-# LANGUAGE Trustworthy #-}
--------------------------------------------------------------------
-- |
-- Module    : Data.MessagePack.Put
-- Copyright : (c) Hideyuki Tanaka, 2009-2015
-- License   : BSD3
--
-- Maintainer:  tanaka.hideyuki@gmail.com
-- Stability :  experimental
-- Portability: portable
--
-- MessagePack Serializer using @Data.Binary@
--
--------------------------------------------------------------------

module Data.MessagePack.Put
  ( putObject
  , putNil
  , putBool
  , putInt
  , putWord
  , putFloat
  , putDouble
  , putStr
  , putBin
  , putArray
  , putMap
  , putExt
  ) where

import           Data.Binary            (Put)
import           Data.Binary.IEEE754    (putFloat32be, putFloat64be)
import           Data.Binary.Put        (putByteString, putWord16be,
                                         putWord32be, putWord64be, putWord8,
                                         putWord8)
import           Data.Bits              ((.|.))
import qualified Data.ByteString        as S
import           Data.Int               (Int64)
import qualified Data.Text              as T
import qualified Data.Text.Encoding     as T
import qualified Data.Vector            as V
import           Data.Word              (Word64, Word8)

import           Prelude                hiding (putStr)

import           Data.MessagePack.Types (Object (..))


putObject :: Object -> Put
putObject :: Object -> Put
putObject = \case
  Object
ObjectNil      -> Put
putNil
  ObjectBool   Bool
b -> Bool -> Put
putBool Bool
b
  ObjectInt    Int64
n -> Int64 -> Put
putInt Int64
n
  ObjectWord   Word64
n -> Word64 -> Put
putWord Word64
n
  ObjectFloat  Float
f -> Float -> Put
putFloat Float
f
  ObjectDouble Double
d -> Double -> Put
putDouble Double
d
  ObjectStr    Text
t -> Text -> Put
putStr Text
t
  ObjectBin    ByteString
b -> ByteString -> Put
putBin ByteString
b
  ObjectArray  Vector Object
a -> (Object -> Put) -> Vector Object -> Put
forall a. (a -> Put) -> Vector a -> Put
putArray Object -> Put
putObject Vector Object
a
  ObjectMap    Vector (Object, Object)
m -> (Object -> Put)
-> (Object -> Put) -> Vector (Object, Object) -> Put
forall a b. (a -> Put) -> (b -> Put) -> Vector (a, b) -> Put
putMap Object -> Put
putObject Object -> Put
putObject Vector (Object, Object)
m
  ObjectExt  Word8
b ByteString
r -> Word8 -> ByteString -> Put
putExt Word8
b ByteString
r

putNil :: Put
putNil :: Put
putNil = Word8 -> Put
putWord8 Word8
0xC0

putBool :: Bool -> Put
putBool :: Bool -> Put
putBool Bool
False = Word8 -> Put
putWord8 Word8
0xC2
putBool Bool
True  = Word8 -> Put
putWord8 Word8
0xC3

putInt :: Int64 -> Put
putInt :: Int64 -> Put
putInt Int64
n
  | -Int64
0x20 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0x80 =
                     Word8 -> Put
putWord8    (Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | Int64
0     Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0x100 =
    Word8 -> Put
putWord8 Word8
0xCC Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | Int64
0     Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0x10000 =
    Word8 -> Put
putWord8 Word8
0xCD Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | Int64
0     Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n Bool -> Bool -> Bool
&& Int64
n Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< Int64
0x100000000 =
    Word8 -> Put
putWord8 Word8
0xCE Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | Int64
0     Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n =
    Word8 -> Put
putWord8 Word8
0xCF Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | -Int64
0x80 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n =
    Word8 -> Put
putWord8 Word8
0xD0 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | -Int64
0x8000 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n =
    Word8 -> Put
putWord8 Word8
0xD1 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | -Int64
0x80000000 Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
<= Int64
n =
    Word8 -> Put
putWord8 Word8
0xD2 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)
  | Bool
otherwise =
    Word8 -> Put
putWord8 Word8
0xD3 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be (Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
n)

putWord :: Word64 -> Put
putWord :: Word64 -> Put
putWord Word64
n
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x80 =
                     Word8 -> Put
putWord8    (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x100 =
    Word8 -> Put
putWord8 Word8
0xCC Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Word64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x10000 =
    Word8 -> Put
putWord8 Word8
0xCD Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  | Word64
n Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
0x100000000 =
    Word8 -> Put
putWord8 Word8
0xCE Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Word64 -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
n)
  | Bool
otherwise =
    Word8 -> Put
putWord8 Word8
0xCF Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word64 -> Put
putWord64be Word64
n

putFloat :: Float -> Put
putFloat :: Float -> Put
putFloat Float
f = do
  Word8 -> Put
putWord8 Word8
0xCA
  Float -> Put
putFloat32be Float
f

putDouble :: Double -> Put
putDouble :: Double -> Put
putDouble Double
d = do
  Word8 -> Put
putWord8 Word8
0xCB
  Double -> Put
putFloat64be Double
d

putStr :: T.Text -> Put
putStr :: Text -> Put
putStr Text
t = do
  let bs :: ByteString
bs = Text -> ByteString
T.encodeUtf8 Text
t
  case ByteString -> Int
S.length ByteString
bs of
    Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
31 ->
          Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word8
0xA0 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x100 ->
          Word8 -> Put
putWord8 Word8
0xD9 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 ->
          Word8 -> Put
putWord8 Word8
0xDA Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Bool
otherwise ->
          Word8 -> Put
putWord8 Word8
0xDB Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  ByteString -> Put
putByteString ByteString
bs

putBin :: S.ByteString -> Put
putBin :: ByteString -> Put
putBin ByteString
bs = do
  case ByteString -> Int
S.length ByteString
bs of
    Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x100 ->
          Word8 -> Put
putWord8 Word8
0xC4 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 ->
          Word8 -> Put
putWord8 Word8
0xC5 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Bool
otherwise ->
          Word8 -> Put
putWord8 Word8
0xC6 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  ByteString -> Put
putByteString ByteString
bs

putArray :: (a -> Put) -> V.Vector a -> Put
putArray :: (a -> Put) -> Vector a -> Put
putArray a -> Put
p Vector a
xs = do
  case Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
xs of
    Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
15 ->
          Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word8
0x90 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 ->
          Word8 -> Put
putWord8 Word8
0xDC Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Bool
otherwise ->
          Word8 -> Put
putWord8 Word8
0xDD Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  (a -> Put) -> Vector a -> Put
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ a -> Put
p Vector a
xs

putMap :: (a -> Put) -> (b -> Put) -> V.Vector (a, b) -> Put
putMap :: (a -> Put) -> (b -> Put) -> Vector (a, b) -> Put
putMap a -> Put
p b -> Put
q Vector (a, b)
xs = do
  case Vector (a, b) -> Int
forall a. Vector a -> Int
V.length Vector (a, b)
xs of
    Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
15 ->
          Word8 -> Put
putWord8 (Word8 -> Put) -> Word8 -> Put
forall a b. (a -> b) -> a -> b
$ Word8
0x80 Word8 -> Word8 -> Word8
forall a. Bits a => a -> a -> a
.|. Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 ->
          Word8 -> Put
putWord8 Word8
0xDE Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Bool
otherwise ->
          Word8 -> Put
putWord8 Word8
0xDF Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  ((a, b) -> Put) -> Vector (a, b) -> Put
forall (m :: * -> *) a b. Monad m => (a -> m b) -> Vector a -> m ()
V.mapM_ (\(a
a, b
b) -> a -> Put
p a
a Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> b -> Put
q b
b) Vector (a, b)
xs

putExt :: Word8 -> S.ByteString -> Put
putExt :: Word8 -> ByteString -> Put
putExt Word8
typ ByteString
dat = do
  case ByteString -> Int
S.length ByteString
dat of
    Int
1  -> Word8 -> Put
putWord8 Word8
0xD4
    Int
2  -> Word8 -> Put
putWord8 Word8
0xD5
    Int
4  -> Word8 -> Put
putWord8 Word8
0xD6
    Int
8  -> Word8 -> Put
putWord8 Word8
0xD7
    Int
16 -> Word8 -> Put
putWord8 Word8
0xD8
    Int
len | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x100   -> Word8 -> Put
putWord8 Word8
0xC7 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word8 -> Put
putWord8    (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0x10000 -> Word8 -> Put
putWord8 Word8
0xC8 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word16 -> Put
putWord16be (Int -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
        | Bool
otherwise     -> Word8 -> Put
putWord8 Word8
0xC9 Put -> Put -> Put
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Word32 -> Put
putWord32be (Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len)
  Word8 -> Put
putWord8 Word8
typ
  ByteString -> Put
putByteString ByteString
dat