messagepack-0.5.4: Data/MessagePack.hs
{-# LANGUAGE DeriveGeneric #-}
{-|
Module : Data.MessagePack
Description : Object data type with Serialize instances for it
Copyright : (c) Rodrigo Setti, 2014
License : MIT
Maintainer : rodrigosetti@gmail.com
Stability : experimental
Portability : portable
@Object@ is a message pack object, and it have constructors for all message
pack types.
The @Serialize@ instances define how Object values may be serialized and
deserialized to message pack binary format, following the specification.
-}
module Data.MessagePack where
import Control.Applicative
import Control.DeepSeq (NFData)
import Control.Monad
import GHC.Generics (Generic)
import Data.Bits
import Data.Int
import Data.MessagePack.Spec
import Data.Serialize
import Data.Word
import qualified Data.ByteString as BS
import qualified Data.Map as M
data Object = ObjectNil
-- | Unsigned integers from the MsgPack protocol: uint 8, uint 16, uint 32, uint 64
| ObjectUInt Word64
-- | Signed integers and fixnums from the MsgPack protocol: positive fixnum, negative fixnum, int 8, int 16, int 32, int 64
| ObjectInt Int64
| ObjectBool Bool
| ObjectFloat Float
| ObjectDouble Double
| ObjectString BS.ByteString
| ObjectBinary BS.ByteString
| ObjectArray [Object]
| ObjectMap (M.Map Object Object )
| ObjectExt !Int8 BS.ByteString
deriving (Eq, Ord, Show, Generic)
instance NFData Object
instance Serialize Object where
put (ObjectUInt i)
| i >= 0 && i < 0x100 = putWord8 uint8 >> putWord8 (fromIntegral i)
| i >= 0 && i < 0x10000 = putWord8 uint16 >> putWord16be (fromIntegral i)
| i >= 0 && i < 0x100000000 = putWord8 uint32 >> putWord32be (fromIntegral i)
| otherwise = putWord8 uint64 >> putWord64be (fromIntegral i)
put (ObjectInt i)
| i >= 0 && i <= 127 = putWord8 $ fromIntegral i
| i >= -32 && i <= -1 = putWord8 $ fromIntegral i
| i >= -0x80 && i < 0x80 = putWord8 int8 >> putWord8 (fromIntegral i)
| i >= -0x8000 && i < 0x8000 = putWord8 int16 >> putWord16be (fromIntegral i)
| i >= -0x80000000 && i < 0x80000000 = putWord8 int32 >> putWord32be (fromIntegral i)
| otherwise = putWord8 int64 >> putWord64be (fromIntegral i)
put ObjectNil = putWord8 nil
put (ObjectBool b) = putWord8 $ if b then true else false
put (ObjectFloat f) = putWord8 float32 >> putFloat32be f
put (ObjectDouble d) = putWord8 float64 >> putFloat64be d
put (ObjectString t) =
header >> putByteString t
where
size = BS.length t
header
| size <= 31 = putWord8 $ fixstr .|. fromIntegral size
| size < 0x100 = putWord8 str8 >> putWord8 (fromIntegral size)
| size < 0x10000 = putWord8 str16 >> putWord16be (fromIntegral size)
| otherwise = putWord8 str32 >> putWord32be (fromIntegral size)
put (ObjectBinary bytes) =
header >> putByteString bytes
where
size = BS.length bytes
header
| size < 0x100 = putWord8 bin8 >> putWord8 (fromIntegral size)
| size < 0x10000 = putWord8 bin16 >> putWord16be (fromIntegral size)
| otherwise = putWord8 bin32 >> putWord32be (fromIntegral size)
put (ObjectArray a) =
buildArray >> mapM_ put a
where
size = length a
buildArray
| size <= 15 = putWord8 $ fixarray .|. fromIntegral size
| size < 0x10000 = putWord8 array16 >> putWord16be (fromIntegral size)
| otherwise = putWord8 array32 >> putWord32be (fromIntegral size)
put (ObjectMap m) =
buildMap >> mapM_ put (M.toList m)
where
size = M.size m
buildMap
| size <= 15 = putWord8 $ fixmap .|. fromIntegral size
| size < 0x10000 = putWord8 map16 >> putWord16be (fromIntegral size)
| otherwise = putWord8 map32 >> putWord32be (fromIntegral size)
put (ObjectExt t bytes) = header >> putWord8 (fromIntegral t) >> putByteString bytes
where
size = BS.length bytes
header
| size == 1 = putWord8 fixext1
| size == 2 = putWord8 fixext2
| size == 4 = putWord8 fixext4
| size == 8 = putWord8 fixext8
| size == 16 = putWord8 fixext16
| size < 0x100 = putWord8 ext8 >> putWord8 (fromIntegral size)
| size < 0x10000 = putWord8 ext16 >> putWord16be (fromIntegral size)
| otherwise = putWord8 ext32 >> putWord32be (fromIntegral size)
get =
getWord8 >>= getObject
where
getObject k
| k == nil = return ObjectNil
| k == false = return $ ObjectBool False
| k == true = return $ ObjectBool True
| k == bin8 = do n <- fromIntegral <$> getWord8
ObjectBinary <$> getByteString n
| k == bin16 = do n <- fromIntegral <$> getWord16be
ObjectBinary <$> getByteString n
| k == bin32 = do n <- fromIntegral <$> getWord32be
ObjectBinary <$> getByteString n
| k == float32 = ObjectFloat <$> getFloat32be
| k == float64 = ObjectDouble <$> getFloat64be
| k .&. posFixintMask == posFixint = return $ ObjectInt $ fromIntegral k
| k .&. negFixintMask == negFixint = return $ ObjectInt $ fromIntegral (fromIntegral k :: Int8)
| k == uint8 = ObjectUInt <$> fromIntegral <$> getWord8
| k == uint16 = ObjectUInt <$> fromIntegral <$> getWord16be
| k == uint32 = ObjectUInt <$> fromIntegral <$> getWord32be
| k == uint64 = ObjectUInt <$> getWord64be
| k == int8 = ObjectInt <$> fromIntegral <$> (get :: Get Int8)
| k == int16 = ObjectInt <$> fromIntegral <$> (get :: Get Int16)
| k == int32 = ObjectInt <$> fromIntegral <$> (get :: Get Int32)
| k == int64 = ObjectInt <$> fromIntegral <$> (get :: Get Int64)
| k .&. fixstrMask == fixstr = let n = fromIntegral $ k .&. complement fixstrMask
in ObjectString <$> getByteString n
| k == str8 = do n <- fromIntegral <$> getWord8
ObjectString <$> getByteString n
| k == str16 = do n <- fromIntegral <$> getWord16be
ObjectString <$> getByteString n
| k == str32 = do n <- fromIntegral <$> getWord32be
ObjectString <$> getByteString n
| k .&. fixarrayMask == fixarray = let n = fromIntegral $ k .&. complement fixarrayMask
in ObjectArray <$> replicateM n get
| k == array16 = do n <- fromIntegral <$> getWord16be
ObjectArray <$> replicateM n get
| k == array32 = do n <- fromIntegral <$> getWord32be
ObjectArray <$> replicateM n get
| k .&. fixmapMask == fixmap = let n = fromIntegral $ k .&. complement fixmapMask
in ObjectMap <$> M.fromList <$> replicateM n get
| k == map16 = do n <- fromIntegral <$> getWord16be
ObjectMap <$> M.fromList <$> replicateM n get
| k == map32 = do n <- fromIntegral <$> getWord32be
ObjectMap <$> M.fromList <$> replicateM n get
| k == ext8 = do n <- fromIntegral <$> getWord8
ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString n
| k == ext16 = do n <- fromIntegral <$> getWord16be
ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString n
| k == ext32 = do n <- fromIntegral <$> getWord32be
ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString n
| k == fixext1 = ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString 1
| k == fixext2 = ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString 2
| k == fixext4 = ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString 4
| k == fixext8 = ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString 8
| k == fixext16 = ObjectExt <$> (fromIntegral <$> getWord8)
<*> getByteString 16
| otherwise = fail $ "mark byte not supported: " ++ show k