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
| ObjectUInt Word64
| 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