{-# 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.Persist@
--
--------------------------------------------------------------------

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

import           Data.Bits              ((.|.))
import qualified Data.ByteString        as S
import           Data.Int               (Int64)
import           Data.Persist           (put)
import qualified Data.Persist           as P
import qualified Data.Text              as T
import qualified Data.Text.Encoding     as T
import           Data.Word              (Word64, Word32, Word16, Word8)

import           Prelude                hiding (putStr)

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

type Put = P.Put ()

putWord8 :: Word8 -> Put
putWord8 :: Word8 -> Put
putWord8 = Word8 -> Put
forall t. Persist t => t -> Put
put

putWord16be :: Word16 -> Put
putWord16be :: Word16 -> Put
putWord16be = BigEndian Word16 -> Put
forall t. Persist t => t -> Put
put (BigEndian Word16 -> Put)
-> (Word16 -> BigEndian Word16) -> Word16 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word16 -> BigEndian Word16
forall a. a -> BigEndian a
P.BigEndian

putWord32be :: Word32 -> Put
putWord32be :: Word32 -> Put
putWord32be = BigEndian Word32 -> Put
forall t. Persist t => t -> Put
put (BigEndian Word32 -> Put)
-> (Word32 -> BigEndian Word32) -> Word32 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> BigEndian Word32
forall a. a -> BigEndian a
P.BigEndian

putWord64be :: Word64 -> Put
putWord64be :: Word64 -> Put
putWord64be = BigEndian Word64 -> Put
forall t. Persist t => t -> Put
put (BigEndian Word64 -> Put)
-> (Word64 -> BigEndian Word64) -> Word64 -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word64 -> BigEndian Word64
forall a. a -> BigEndian a
P.BigEndian

putFloat32be :: Float -> Put
putFloat32be :: Float -> Put
putFloat32be = BigEndian Float -> Put
forall t. Persist t => t -> Put
put (BigEndian Float -> Put)
-> (Float -> BigEndian Float) -> Float -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Float -> BigEndian Float
forall a. a -> BigEndian a
P.BigEndian

putFloat64be :: Double -> Put
putFloat64be :: Double -> Put
putFloat64be = BigEndian Double -> Put
forall t. Persist t => t -> Put
put (BigEndian Double -> Put)
-> (Double -> BigEndian Double) -> Double -> Put
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> BigEndian Double
forall a. a -> BigEndian a
P.BigEndian

putByteString :: S.ByteString -> Put
putByteString :: ByteString -> Put
putByteString = ByteString -> Put
P.putByteString

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  [Object]
a -> (Object -> Put) -> [Object] -> Put
forall a. (a -> Put) -> [a] -> Put
putArray Object -> Put
putObject [Object]
a
  ObjectMap    [(Object, Object)]
m -> (Object -> Put) -> (Object -> Put) -> [(Object, Object)] -> Put
forall a b. (a -> Put) -> (b -> Put) -> [(a, b)] -> Put
putMap Object -> Put
putObject Object -> Put
putObject [(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) -> [a] -> Put
putArray :: (a -> Put) -> [a] -> Put
putArray a -> Put
p [a]
xs = do
  case [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [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) -> [a] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ a -> Put
p [a]
xs

putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put
putMap :: (a -> Put) -> (b -> Put) -> [(a, b)] -> Put
putMap a -> Put
p b -> Put
q [(a, b)]
xs = do
  case [(a, b)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(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) -> [(a, b)] -> Put
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
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) [(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