mirror of
https://github.com/msgpack/msgpack-c.git
synced 2025-03-19 13:02:13 +01:00
pure haskell implementation.
This commit is contained in:
Hideyuki Tanaka
parent
bf0cb40586
commit
80db9971b5
@ -1,4 +1,4 @@
|
||||
Copyright (c) 2009, Hideyuki Tanaka
|
||||
Copyright (c) 2009-2010, Hideyuki Tanaka
|
||||
All rights reserved.
|
||||
|
||||
Redistribution and use in source and binary forms, with or without
|
||||
|
||||
@ -1,137 +0,0 @@
|
||||
#include <msgpack.h>
|
||||
|
||||
void msgpack_sbuffer_init_wrap(msgpack_sbuffer* sbuf)
|
||||
{
|
||||
msgpack_sbuffer_init(sbuf);
|
||||
}
|
||||
|
||||
void msgpack_sbuffer_destroy_wrap(msgpack_sbuffer* sbuf)
|
||||
{
|
||||
msgpack_sbuffer_destroy(sbuf);
|
||||
}
|
||||
|
||||
int msgpack_sbuffer_write_wrap(void* data, const char* buf, unsigned int len)
|
||||
{
|
||||
return msgpack_sbuffer_write(data, buf, len);
|
||||
}
|
||||
|
||||
msgpack_packer* msgpack_packer_new_wrap(void *data, msgpack_packer_write callback)
|
||||
{
|
||||
return msgpack_packer_new(data, callback);
|
||||
}
|
||||
|
||||
void msgpack_packer_free_wrap(msgpack_packer* pk)
|
||||
{
|
||||
msgpack_packer_free(pk);
|
||||
}
|
||||
|
||||
int msgpack_pack_uint8_wrap(msgpack_packer* pk, uint8_t d)
|
||||
{
|
||||
return msgpack_pack_uint8(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_uint16_wrap(msgpack_packer* pk, uint16_t d)
|
||||
{
|
||||
return msgpack_pack_uint16(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_uint32_wrap(msgpack_packer* pk, uint32_t d)
|
||||
{
|
||||
return msgpack_pack_uint32(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_uint64_wrap(msgpack_packer* pk, uint64_t d)
|
||||
{
|
||||
return msgpack_pack_uint64(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_int8_wrap(msgpack_packer* pk, int8_t d)
|
||||
{
|
||||
return msgpack_pack_int8(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_int16_wrap(msgpack_packer* pk, int16_t d)
|
||||
{
|
||||
return msgpack_pack_int16(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_int32_wrap(msgpack_packer* pk, int32_t d)
|
||||
{
|
||||
return msgpack_pack_int32(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_int64_wrap(msgpack_packer* pk, int64_t d)
|
||||
{
|
||||
return msgpack_pack_int64(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_double_wrap(msgpack_packer* pk, double d)
|
||||
{
|
||||
return msgpack_pack_double(pk, d);
|
||||
}
|
||||
|
||||
int msgpack_pack_nil_wrap(msgpack_packer* pk)
|
||||
{
|
||||
return msgpack_pack_nil(pk);
|
||||
}
|
||||
|
||||
int msgpack_pack_true_wrap(msgpack_packer* pk)
|
||||
{
|
||||
return msgpack_pack_true(pk);
|
||||
}
|
||||
|
||||
int msgpack_pack_false_wrap(msgpack_packer* pk)
|
||||
{
|
||||
return msgpack_pack_false(pk);
|
||||
}
|
||||
|
||||
int msgpack_pack_array_wrap(msgpack_packer* pk, unsigned int n)
|
||||
{
|
||||
return msgpack_pack_array(pk, n);
|
||||
}
|
||||
|
||||
int msgpack_pack_map_wrap(msgpack_packer* pk, unsigned int n)
|
||||
{
|
||||
return msgpack_pack_map(pk, n);
|
||||
}
|
||||
|
||||
int msgpack_pack_raw_wrap(msgpack_packer* pk, size_t l)
|
||||
{
|
||||
return msgpack_pack_raw(pk, l);
|
||||
}
|
||||
|
||||
int msgpack_pack_raw_body_wrap(msgpack_packer* pk, const void *b, size_t l)
|
||||
{
|
||||
return msgpack_pack_raw_body(pk, b, l);
|
||||
}
|
||||
|
||||
bool msgpack_unpacker_reserve_buffer_wrap(msgpack_unpacker *mpac, size_t size)
|
||||
{
|
||||
return msgpack_unpacker_reserve_buffer(mpac, size);
|
||||
}
|
||||
|
||||
char *msgpack_unpacker_buffer_wrap(msgpack_unpacker *mpac)
|
||||
{
|
||||
return msgpack_unpacker_buffer(mpac);
|
||||
}
|
||||
|
||||
size_t msgpack_unpacker_buffer_capacity_wrap(const msgpack_unpacker *mpac)
|
||||
{
|
||||
return msgpack_unpacker_buffer_capacity(mpac);
|
||||
}
|
||||
|
||||
void msgpack_unpacker_buffer_consumed_wrap(msgpack_unpacker *mpac, size_t size)
|
||||
{
|
||||
msgpack_unpacker_buffer_consumed(mpac, size);
|
||||
}
|
||||
|
||||
void msgpack_unpacker_data_wrap(msgpack_unpacker *mpac, msgpack_object *obj)
|
||||
{
|
||||
*obj=msgpack_unpacker_data(mpac);
|
||||
}
|
||||
|
||||
size_t msgpack_unpacker_message_size_wrap(const msgpack_unpacker *mpac)
|
||||
{
|
||||
return msgpack_unpacker_message_size(mpac);
|
||||
}
|
||||
|
||||
@ -1,32 +1,35 @@
|
||||
Name: msgpack
|
||||
Version: 0.2.2
|
||||
License: BSD3
|
||||
License-File: LICENSE
|
||||
Author: Hideyuki Tanaka
|
||||
Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
|
||||
Category: Data
|
||||
Synopsis: A Haskell binding to MessagePack
|
||||
Name: msgpack
|
||||
Version: 0.3.0
|
||||
Synopsis: A Haskell binding to MessagePack
|
||||
Description:
|
||||
A Haskell binding to MessagePack <http://msgpack.sourceforge.jp/>
|
||||
Homepage: http://github.com/tanakh/hsmsgpack
|
||||
Stability: Experimental
|
||||
Tested-with: GHC==6.10.4
|
||||
Cabal-Version: >=1.2
|
||||
Build-Type: Simple
|
||||
|
||||
library
|
||||
build-depends: base>=4 && <5, mtl, bytestring
|
||||
ghc-options: -O2 -Wall
|
||||
hs-source-dirs: src
|
||||
extra-libraries: msgpackc
|
||||
License: BSD3
|
||||
License-File: LICENSE
|
||||
Category: Data
|
||||
Author: Hideyuki Tanaka
|
||||
Maintainer: Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
|
||||
Homepage: http://github.com/tanakh/hsmsgpack
|
||||
Stability: Experimental
|
||||
Tested-with: GHC == 6.12.3
|
||||
Cabal-Version: >= 1.2
|
||||
Build-Type: Simple
|
||||
|
||||
Library
|
||||
Build-depends: base >=4 && <5,
|
||||
transformers >= 0.2.1 && < 0.2.2,
|
||||
MonadCatchIO-transformers >= 0.2.2 && < 0.2.3,
|
||||
bytestring >= 0.9 && < 0.10,
|
||||
vector >= 0.6.0 && < 0.6.1,
|
||||
iteratee >= 0.4 && < 0.5,
|
||||
attoparsec >= 0.8.1 && < 0.8.2,
|
||||
binary >= 0.5.0 && < 0.5.1,
|
||||
data-binary-ieee754 >= 0.4 && < 0.5
|
||||
Ghc-options: -Wall -O2
|
||||
Hs-source-dirs: src
|
||||
|
||||
Exposed-modules:
|
||||
Data.MessagePack
|
||||
Data.MessagePack.Base
|
||||
Data.MessagePack.Class
|
||||
Data.MessagePack.Feed
|
||||
Data.MessagePack.Monad
|
||||
Data.MessagePack.Stream
|
||||
|
||||
C-Sources:
|
||||
cbits/msgpack.c
|
||||
Data.MessagePack.Object
|
||||
Data.MessagePack.Put
|
||||
Data.MessagePack.Parser
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
@ -13,51 +13,105 @@
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack(
|
||||
module Data.MessagePack.Base,
|
||||
module Data.MessagePack.Class,
|
||||
module Data.MessagePack.Feed,
|
||||
module Data.MessagePack.Monad,
|
||||
module Data.MessagePack.Stream,
|
||||
module Data.MessagePack.Object,
|
||||
module Data.MessagePack.Put,
|
||||
module Data.MessagePack.Parser,
|
||||
|
||||
-- * Pack and Unpack
|
||||
packb,
|
||||
unpackb,
|
||||
-- * Simple functions of Pack and Unpack
|
||||
pack,
|
||||
unpack,
|
||||
|
||||
-- * Pack functions
|
||||
packToString,
|
||||
packToHandle,
|
||||
packToFile,
|
||||
|
||||
-- * Unpack functions
|
||||
unpackFromString,
|
||||
unpackFromHandle,
|
||||
unpackFromFile,
|
||||
|
||||
-- * Pure version of Pack and Unpack
|
||||
packb',
|
||||
unpackb',
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import System.IO.Unsafe
|
||||
import qualified Control.Monad.CatchIO as CIO
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Attoparsec as A
|
||||
import Data.Binary.Put
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Lazy as L
|
||||
import Data.Functor.Identity
|
||||
import qualified Data.Iteratee as I
|
||||
import qualified Data.Iteratee.IO as I
|
||||
import System.IO
|
||||
|
||||
import Data.MessagePack.Base
|
||||
import Data.MessagePack.Class
|
||||
import Data.MessagePack.Feed
|
||||
import Data.MessagePack.Monad
|
||||
import Data.MessagePack.Stream
|
||||
import Data.MessagePack.Object
|
||||
import Data.MessagePack.Put
|
||||
import Data.MessagePack.Parser
|
||||
|
||||
bufferSize :: Int
|
||||
bufferSize = 4 * 1024
|
||||
|
||||
class IsByteString s where
|
||||
toBS :: s -> B.ByteString
|
||||
|
||||
instance IsByteString B.ByteString where
|
||||
toBS = id
|
||||
|
||||
instance IsByteString L.ByteString where
|
||||
toBS = B.concat . L.toChunks
|
||||
|
||||
-- | Pack Haskell data to MessagePack string.
|
||||
packb :: OBJECT a => a -> IO ByteString
|
||||
packb dat = do
|
||||
sb <- newSimpleBuffer
|
||||
pc <- newPacker sb
|
||||
pack pc dat
|
||||
simpleBufferData sb
|
||||
pack :: ObjectPut a => a -> L.ByteString
|
||||
pack = packToString . put
|
||||
|
||||
-- | Unpack MessagePack string to Haskell data.
|
||||
unpackb :: OBJECT a => ByteString -> IO (Result a)
|
||||
unpackb bs = do
|
||||
withZone $ \z -> do
|
||||
r <- unpackObject z bs
|
||||
return $ case r of
|
||||
Left err -> Left (show err)
|
||||
Right (_, dat) -> fromObject dat
|
||||
unpack :: (ObjectGet a, IsByteString s) => s -> a
|
||||
unpack bs =
|
||||
runIdentity $ I.run $ I.joinIM $ I.enumPure1Chunk (toBS bs) (parserToIteratee get)
|
||||
|
||||
-- | Pure version of 'packb'.
|
||||
packb' :: OBJECT a => a -> ByteString
|
||||
packb' dat = unsafePerformIO $ packb dat
|
||||
-- TODO: tryUnpack
|
||||
|
||||
-- | Pure version of 'unpackb'.
|
||||
unpackb' :: OBJECT a => ByteString -> Result a
|
||||
unpackb' bs = unsafePerformIO $ unpackb bs
|
||||
-- | Pack to ByteString.
|
||||
packToString :: Put -> L.ByteString
|
||||
packToString = runPut
|
||||
|
||||
-- | Pack to Handle
|
||||
packToHandle :: Handle -> Put -> IO ()
|
||||
packToHandle h = L.hPutStr h . packToString
|
||||
|
||||
-- | Pack to File
|
||||
packToFile :: FilePath -> Put -> IO ()
|
||||
packToFile path = L.writeFile path . packToString
|
||||
|
||||
-- | Unpack from ByteString
|
||||
unpackFromString :: (Monad m, IsByteString s) => s -> A.Parser a -> m a
|
||||
unpackFromString bs =
|
||||
I.run . I.joinIM . I.enumPure1Chunk (toBS bs) . parserToIteratee
|
||||
|
||||
-- | Unpack from Handle
|
||||
unpackFromHandle :: CIO.MonadCatchIO m => Handle -> A.Parser a -> m a
|
||||
unpackFromHandle h =
|
||||
I.run . I.joinIM . I.enumHandle bufferSize h . parserToIteratee
|
||||
|
||||
-- | Unpack from File
|
||||
unpackFromFile :: CIO.MonadCatchIO m => FilePath -> A.Parser a -> m a
|
||||
unpackFromFile path p =
|
||||
CIO.bracket
|
||||
(liftIO $ openBinaryFile path ReadMode)
|
||||
(liftIO . hClose)
|
||||
(flip unpackFromHandle p)
|
||||
|
||||
parserToIteratee :: Monad m => A.Parser a -> I.Iteratee B.ByteString m a
|
||||
parserToIteratee p = I.icont (itr (A.parse p)) Nothing
|
||||
where
|
||||
itr pcont s = case s of
|
||||
I.EOF _ ->
|
||||
I.throwErr (I.setEOF s)
|
||||
I.Chunk bs ->
|
||||
case pcont bs of
|
||||
A.Fail _ _ msg ->
|
||||
I.throwErr (I.iterStrExc msg)
|
||||
A.Partial cont ->
|
||||
I.icont (itr cont) Nothing
|
||||
A.Done remain ret ->
|
||||
I.idone ret (I.Chunk remain)
|
||||
|
||||
@ -1,584 +0,0 @@
|
||||
{-# LANGUAGE CPP #-}
|
||||
{-# LANGUAGE ForeignFunctionInterface #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Base
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- Low Level Interface to MessagePack C API
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Base(
|
||||
-- * Simple Buffer
|
||||
SimpleBuffer,
|
||||
newSimpleBuffer,
|
||||
simpleBufferData,
|
||||
|
||||
-- * Serializer
|
||||
Packer,
|
||||
newPacker,
|
||||
|
||||
packU8,
|
||||
packU16,
|
||||
packU32,
|
||||
packU64,
|
||||
packS8,
|
||||
packS16,
|
||||
packS32,
|
||||
packS64,
|
||||
|
||||
packTrue,
|
||||
packFalse,
|
||||
|
||||
packInt,
|
||||
packDouble,
|
||||
packNil,
|
||||
packBool,
|
||||
|
||||
packArray,
|
||||
packMap,
|
||||
packRAW,
|
||||
packRAWBody,
|
||||
packRAW',
|
||||
|
||||
-- * Stream Deserializer
|
||||
Unpacker,
|
||||
defaultInitialBufferSize,
|
||||
newUnpacker,
|
||||
unpackerReserveBuffer,
|
||||
unpackerBuffer,
|
||||
unpackerBufferCapacity,
|
||||
unpackerBufferConsumed,
|
||||
unpackerFeed,
|
||||
unpackerExecute,
|
||||
unpackerData,
|
||||
unpackerReleaseZone,
|
||||
unpackerResetZone,
|
||||
unpackerReset,
|
||||
unpackerMessageSize,
|
||||
|
||||
-- * MessagePack Object
|
||||
Object(..),
|
||||
packObject,
|
||||
|
||||
UnpackReturn(..),
|
||||
unpackObject,
|
||||
|
||||
-- * Memory Zone
|
||||
Zone,
|
||||
newZone,
|
||||
freeZone,
|
||||
withZone,
|
||||
) where
|
||||
|
||||
import Control.Exception
|
||||
import Control.Monad
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS hiding (pack, unpack)
|
||||
import Data.Int
|
||||
import Data.Word
|
||||
import Foreign.C
|
||||
import Foreign.Concurrent
|
||||
import Foreign.ForeignPtr hiding (newForeignPtr)
|
||||
import Foreign.Marshal.Alloc
|
||||
import Foreign.Marshal.Array
|
||||
import Foreign.Ptr
|
||||
import Foreign.Storable
|
||||
|
||||
#include <msgpack.h>
|
||||
|
||||
type SimpleBuffer = ForeignPtr ()
|
||||
|
||||
type WriteCallback = Ptr () -> CString -> CUInt -> IO CInt
|
||||
|
||||
-- | Create a new Simple Buffer. It will be deleted automatically.
|
||||
newSimpleBuffer :: IO SimpleBuffer
|
||||
newSimpleBuffer = do
|
||||
ptr <- mallocBytes (#size msgpack_sbuffer)
|
||||
fptr <- newForeignPtr ptr $ do
|
||||
msgpack_sbuffer_destroy ptr
|
||||
free ptr
|
||||
withForeignPtr fptr $ \p ->
|
||||
msgpack_sbuffer_init p
|
||||
return fptr
|
||||
|
||||
-- | Get data of Simple Buffer.
|
||||
simpleBufferData :: SimpleBuffer -> IO ByteString
|
||||
simpleBufferData sb =
|
||||
withForeignPtr sb $ \ptr -> do
|
||||
size <- (#peek msgpack_sbuffer, size) ptr
|
||||
dat <- (#peek msgpack_sbuffer, data) ptr
|
||||
BS.packCStringLen (dat, fromIntegral (size :: CSize))
|
||||
|
||||
foreign import ccall "msgpack_sbuffer_init_wrap" msgpack_sbuffer_init ::
|
||||
Ptr () -> IO ()
|
||||
|
||||
foreign import ccall "msgpack_sbuffer_destroy_wrap" msgpack_sbuffer_destroy ::
|
||||
Ptr () -> IO ()
|
||||
|
||||
foreign import ccall "msgpack_sbuffer_write_wrap" msgpack_sbuffer_write ::
|
||||
WriteCallback
|
||||
|
||||
type Packer = ForeignPtr ()
|
||||
|
||||
-- | Create new Packer. It will be deleted automatically.
|
||||
newPacker :: SimpleBuffer -> IO Packer
|
||||
newPacker sbuf = do
|
||||
cb <- wrap_callback msgpack_sbuffer_write
|
||||
ptr <- withForeignPtr sbuf $ \ptr ->
|
||||
msgpack_packer_new ptr cb
|
||||
fptr <- newForeignPtr ptr $ do
|
||||
msgpack_packer_free ptr
|
||||
return fptr
|
||||
|
||||
foreign import ccall "msgpack_packer_new_wrap" msgpack_packer_new ::
|
||||
Ptr () -> FunPtr WriteCallback -> IO (Ptr ())
|
||||
|
||||
foreign import ccall "msgpack_packer_free_wrap" msgpack_packer_free ::
|
||||
Ptr () -> IO ()
|
||||
|
||||
foreign import ccall "wrapper" wrap_callback ::
|
||||
WriteCallback -> IO (FunPtr WriteCallback)
|
||||
|
||||
packU8 :: Packer -> Word8 -> IO Int
|
||||
packU8 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_uint8 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_uint8_wrap" msgpack_pack_uint8 ::
|
||||
Ptr () -> Word8 -> IO CInt
|
||||
|
||||
packU16 :: Packer -> Word16 -> IO Int
|
||||
packU16 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_uint16 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_uint16_wrap" msgpack_pack_uint16 ::
|
||||
Ptr () -> Word16 -> IO CInt
|
||||
|
||||
packU32 :: Packer -> Word32 -> IO Int
|
||||
packU32 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_uint32 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_uint32_wrap" msgpack_pack_uint32 ::
|
||||
Ptr () -> Word32 -> IO CInt
|
||||
|
||||
packU64 :: Packer -> Word64 -> IO Int
|
||||
packU64 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_uint64 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_uint64_wrap" msgpack_pack_uint64 ::
|
||||
Ptr () -> Word64 -> IO CInt
|
||||
|
||||
packS8 :: Packer -> Int8 -> IO Int
|
||||
packS8 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_int8 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_int8_wrap" msgpack_pack_int8 ::
|
||||
Ptr () -> Int8 -> IO CInt
|
||||
|
||||
packS16 :: Packer -> Int16 -> IO Int
|
||||
packS16 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_int16 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_int16_wrap" msgpack_pack_int16 ::
|
||||
Ptr () -> Int16 -> IO CInt
|
||||
|
||||
packS32 :: Packer -> Int32 -> IO Int
|
||||
packS32 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_int32 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_int32_wrap" msgpack_pack_int32 ::
|
||||
Ptr () -> Int32 -> IO CInt
|
||||
|
||||
packS64 :: Packer -> Int64 -> IO Int
|
||||
packS64 pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_int64 ptr n
|
||||
|
||||
foreign import ccall "msgpack_pack_int64_wrap" msgpack_pack_int64 ::
|
||||
Ptr () -> Int64 -> IO CInt
|
||||
|
||||
-- | Pack an integral data.
|
||||
packInt :: Integral a => Packer -> a -> IO Int
|
||||
packInt pc n = packS64 pc $ fromIntegral n
|
||||
|
||||
-- | Pack a double data.
|
||||
packDouble :: Packer -> Double -> IO Int
|
||||
packDouble pc d =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_double ptr (realToFrac d)
|
||||
|
||||
foreign import ccall "msgpack_pack_double_wrap" msgpack_pack_double ::
|
||||
Ptr () -> CDouble -> IO CInt
|
||||
|
||||
-- | Pack a nil.
|
||||
packNil :: Packer -> IO Int
|
||||
packNil pc =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_nil ptr
|
||||
|
||||
foreign import ccall "msgpack_pack_nil_wrap" msgpack_pack_nil ::
|
||||
Ptr () -> IO CInt
|
||||
|
||||
packTrue :: Packer -> IO Int
|
||||
packTrue pc =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_true ptr
|
||||
|
||||
foreign import ccall "msgpack_pack_true_wrap" msgpack_pack_true ::
|
||||
Ptr () -> IO CInt
|
||||
|
||||
packFalse :: Packer -> IO Int
|
||||
packFalse pc =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_false ptr
|
||||
|
||||
foreign import ccall "msgpack_pack_false_wrap" msgpack_pack_false ::
|
||||
Ptr () -> IO CInt
|
||||
|
||||
-- | Pack a bool data.
|
||||
packBool :: Packer -> Bool -> IO Int
|
||||
packBool pc True = packTrue pc
|
||||
packBool pc False = packFalse pc
|
||||
|
||||
-- | 'packArray' @p n@ starts packing an array.
|
||||
-- Next @n@ data will consist this array.
|
||||
packArray :: Packer -> Int -> IO Int
|
||||
packArray pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_array ptr (fromIntegral n)
|
||||
|
||||
foreign import ccall "msgpack_pack_array_wrap" msgpack_pack_array ::
|
||||
Ptr () -> CUInt -> IO CInt
|
||||
|
||||
-- | 'packMap' @p n@ starts packing a map.
|
||||
-- Next @n@ pairs of data (2*n data) will consist this map.
|
||||
packMap :: Packer -> Int -> IO Int
|
||||
packMap pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_map ptr (fromIntegral n)
|
||||
|
||||
foreign import ccall "msgpack_pack_map_wrap" msgpack_pack_map ::
|
||||
Ptr () -> CUInt -> IO CInt
|
||||
|
||||
-- | 'packRAW' @p n@ starts packing a byte sequence.
|
||||
-- Next total @n@ bytes of 'packRAWBody' call will consist this sequence.
|
||||
packRAW :: Packer -> Int -> IO Int
|
||||
packRAW pc n =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
msgpack_pack_raw ptr (fromIntegral n)
|
||||
|
||||
foreign import ccall "msgpack_pack_raw_wrap" msgpack_pack_raw ::
|
||||
Ptr () -> CSize -> IO CInt
|
||||
|
||||
-- | Pack a byte sequence.
|
||||
packRAWBody :: Packer -> ByteString -> IO Int
|
||||
packRAWBody pc bs =
|
||||
liftM fromIntegral $ withForeignPtr pc $ \ptr ->
|
||||
BS.useAsCStringLen bs $ \(str, len) ->
|
||||
msgpack_pack_raw_body ptr (castPtr str) (fromIntegral len)
|
||||
|
||||
foreign import ccall "msgpack_pack_raw_body_wrap" msgpack_pack_raw_body ::
|
||||
Ptr () -> Ptr () -> CSize -> IO CInt
|
||||
|
||||
-- | Pack a single byte stream. It calls 'packRAW' and 'packRAWBody'.
|
||||
packRAW' :: Packer -> ByteString -> IO Int
|
||||
packRAW' pc bs = do
|
||||
_ <- packRAW pc (BS.length bs)
|
||||
packRAWBody pc bs
|
||||
|
||||
type Unpacker = ForeignPtr ()
|
||||
|
||||
defaultInitialBufferSize :: Int
|
||||
defaultInitialBufferSize = 32 * 1024 -- #const MSGPACK_UNPACKER_DEFAULT_INITIAL_BUFFER_SIZE
|
||||
|
||||
-- | 'newUnpacker' @initialBufferSize@ creates a new Unpacker. It will be deleted automatically.
|
||||
newUnpacker :: Int -> IO Unpacker
|
||||
newUnpacker initialBufferSize = do
|
||||
ptr <- msgpack_unpacker_new (fromIntegral initialBufferSize)
|
||||
fptr <- newForeignPtr ptr $ do
|
||||
msgpack_unpacker_free ptr
|
||||
return fptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_new" msgpack_unpacker_new ::
|
||||
CSize -> IO (Ptr ())
|
||||
|
||||
foreign import ccall "msgpack_unpacker_free" msgpack_unpacker_free ::
|
||||
Ptr() -> IO ()
|
||||
|
||||
-- | 'unpackerReserveBuffer' @up size@ reserves at least @size@ bytes of buffer.
|
||||
unpackerReserveBuffer :: Unpacker -> Int -> IO Bool
|
||||
unpackerReserveBuffer up size =
|
||||
withForeignPtr up $ \ptr ->
|
||||
liftM (/=0) $ msgpack_unpacker_reserve_buffer ptr (fromIntegral size)
|
||||
|
||||
foreign import ccall "msgpack_unpacker_reserve_buffer_wrap" msgpack_unpacker_reserve_buffer ::
|
||||
Ptr () -> CSize -> IO CChar
|
||||
|
||||
-- | Get a pointer of unpacker buffer.
|
||||
unpackerBuffer :: Unpacker -> IO (Ptr CChar)
|
||||
unpackerBuffer up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
msgpack_unpacker_buffer ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_buffer_wrap" msgpack_unpacker_buffer ::
|
||||
Ptr () -> IO (Ptr CChar)
|
||||
|
||||
-- | Get size of allocated buffer.
|
||||
unpackerBufferCapacity :: Unpacker -> IO Int
|
||||
unpackerBufferCapacity up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
liftM fromIntegral $ msgpack_unpacker_buffer_capacity ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_buffer_capacity_wrap" msgpack_unpacker_buffer_capacity ::
|
||||
Ptr () -> IO CSize
|
||||
|
||||
-- | 'unpackerBufferConsumed' @up size@ notices that writed @size@ bytes to buffer.
|
||||
unpackerBufferConsumed :: Unpacker -> Int -> IO ()
|
||||
unpackerBufferConsumed up size =
|
||||
withForeignPtr up $ \ptr ->
|
||||
msgpack_unpacker_buffer_consumed ptr (fromIntegral size)
|
||||
|
||||
foreign import ccall "msgpack_unpacker_buffer_consumed_wrap" msgpack_unpacker_buffer_consumed ::
|
||||
Ptr () -> CSize -> IO ()
|
||||
|
||||
-- | Write byte sequence to Unpacker. It is utility funciton, calls 'unpackerReserveBuffer', 'unpackerBuffer' and 'unpackerBufferConsumed'.
|
||||
unpackerFeed :: Unpacker -> ByteString -> IO ()
|
||||
unpackerFeed up bs =
|
||||
BS.useAsCStringLen bs $ \(str, len) -> do
|
||||
True <- unpackerReserveBuffer up len
|
||||
ptr <- unpackerBuffer up
|
||||
copyArray ptr str len
|
||||
unpackerBufferConsumed up len
|
||||
|
||||
-- | Execute deserializing. It returns 0 when buffer contains not enough bytes, returns 1 when succeeded, returns negative value when it failed.
|
||||
unpackerExecute :: Unpacker -> IO Int
|
||||
unpackerExecute up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
liftM fromIntegral $ msgpack_unpacker_execute ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_execute" msgpack_unpacker_execute ::
|
||||
Ptr () -> IO CInt
|
||||
|
||||
-- | Returns a deserialized object when 'unpackerExecute' returned 1.
|
||||
unpackerData :: Unpacker -> IO Object
|
||||
unpackerData up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
allocaBytes (#size msgpack_object) $ \pobj -> do
|
||||
msgpack_unpacker_data ptr pobj
|
||||
peekObject pobj
|
||||
|
||||
foreign import ccall "msgpack_unpacker_data_wrap" msgpack_unpacker_data ::
|
||||
Ptr () -> Ptr () -> IO ()
|
||||
|
||||
-- | Release memory zone. The returned zone must be freed by calling 'freeZone'.
|
||||
unpackerReleaseZone :: Unpacker -> IO Zone
|
||||
unpackerReleaseZone up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
msgpack_unpacker_release_zone ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_release_zone" msgpack_unpacker_release_zone ::
|
||||
Ptr () -> IO (Ptr ())
|
||||
|
||||
-- | Free memory zone used by Unapcker.
|
||||
unpackerResetZone :: Unpacker -> IO ()
|
||||
unpackerResetZone up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
msgpack_unpacker_reset_zone ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_reset_zone" msgpack_unpacker_reset_zone ::
|
||||
Ptr () -> IO ()
|
||||
|
||||
-- | Reset Unpacker state except memory zone.
|
||||
unpackerReset :: Unpacker -> IO ()
|
||||
unpackerReset up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
msgpack_unpacker_reset ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_reset" msgpack_unpacker_reset ::
|
||||
Ptr () -> IO ()
|
||||
|
||||
-- | Returns number of bytes of sequence of deserializing object.
|
||||
unpackerMessageSize :: Unpacker -> IO Int
|
||||
unpackerMessageSize up =
|
||||
withForeignPtr up $ \ptr ->
|
||||
liftM fromIntegral $ msgpack_unpacker_message_size ptr
|
||||
|
||||
foreign import ccall "msgpack_unpacker_message_size_wrap" msgpack_unpacker_message_size ::
|
||||
Ptr () -> IO CSize
|
||||
|
||||
type Zone = Ptr ()
|
||||
|
||||
-- | Create a new memory zone. It must be freed manually.
|
||||
newZone :: IO Zone
|
||||
newZone =
|
||||
msgpack_zone_new (#const MSGPACK_ZONE_CHUNK_SIZE)
|
||||
|
||||
-- | Free a memory zone.
|
||||
freeZone :: Zone -> IO ()
|
||||
freeZone z =
|
||||
msgpack_zone_free z
|
||||
|
||||
-- | Create a memory zone, then execute argument, then free memory zone.
|
||||
withZone :: (Zone -> IO a) -> IO a
|
||||
withZone z =
|
||||
bracket newZone freeZone z
|
||||
|
||||
foreign import ccall "msgpack_zone_new" msgpack_zone_new ::
|
||||
CSize -> IO Zone
|
||||
|
||||
foreign import ccall "msgpack_zone_free" msgpack_zone_free ::
|
||||
Zone -> IO ()
|
||||
|
||||
-- | Object Representation of MessagePack data.
|
||||
data Object =
|
||||
ObjectNil
|
||||
| ObjectBool Bool
|
||||
| ObjectInteger Int
|
||||
| ObjectDouble Double
|
||||
| ObjectRAW ByteString
|
||||
| ObjectArray [Object]
|
||||
| ObjectMap [(Object, Object)]
|
||||
deriving (Show)
|
||||
|
||||
peekObject :: Ptr a -> IO Object
|
||||
peekObject ptr = do
|
||||
typ <- (#peek msgpack_object, type) ptr
|
||||
case (typ :: CInt) of
|
||||
(#const MSGPACK_OBJECT_NIL) ->
|
||||
return ObjectNil
|
||||
(#const MSGPACK_OBJECT_BOOLEAN) ->
|
||||
peekObjectBool ptr
|
||||
(#const MSGPACK_OBJECT_POSITIVE_INTEGER) ->
|
||||
peekObjectPositiveInteger ptr
|
||||
(#const MSGPACK_OBJECT_NEGATIVE_INTEGER) ->
|
||||
peekObjectNegativeInteger ptr
|
||||
(#const MSGPACK_OBJECT_DOUBLE) ->
|
||||
peekObjectDouble ptr
|
||||
(#const MSGPACK_OBJECT_RAW) ->
|
||||
peekObjectRAW ptr
|
||||
(#const MSGPACK_OBJECT_ARRAY) ->
|
||||
peekObjectArray ptr
|
||||
(#const MSGPACK_OBJECT_MAP) ->
|
||||
peekObjectMap ptr
|
||||
_ ->
|
||||
fail $ "peekObject: unknown object type (" ++ show typ ++ ")"
|
||||
|
||||
peekObjectBool :: Ptr a -> IO Object
|
||||
peekObjectBool ptr = do
|
||||
b <- (#peek msgpack_object, via.boolean) ptr
|
||||
return $ ObjectBool $ (b :: CUChar) /= 0
|
||||
|
||||
peekObjectPositiveInteger :: Ptr a -> IO Object
|
||||
peekObjectPositiveInteger ptr = do
|
||||
n <- (#peek msgpack_object, via.u64) ptr
|
||||
return $ ObjectInteger $ fromIntegral (n :: Word64)
|
||||
|
||||
peekObjectNegativeInteger :: Ptr a -> IO Object
|
||||
peekObjectNegativeInteger ptr = do
|
||||
n <- (#peek msgpack_object, via.i64) ptr
|
||||
return $ ObjectInteger $ fromIntegral (n :: Int64)
|
||||
|
||||
peekObjectDouble :: Ptr a -> IO Object
|
||||
peekObjectDouble ptr = do
|
||||
d <- (#peek msgpack_object, via.dec) ptr
|
||||
return $ ObjectDouble $ realToFrac (d :: CDouble)
|
||||
|
||||
peekObjectRAW :: Ptr a -> IO Object
|
||||
peekObjectRAW ptr = do
|
||||
size <- (#peek msgpack_object, via.raw.size) ptr
|
||||
p <- (#peek msgpack_object, via.raw.ptr) ptr
|
||||
bs <- BS.packCStringLen (p, fromIntegral (size :: Word32))
|
||||
return $ ObjectRAW bs
|
||||
|
||||
peekObjectArray :: Ptr a -> IO Object
|
||||
peekObjectArray ptr = do
|
||||
csize <- (#peek msgpack_object, via.array.size) ptr
|
||||
let size = fromIntegral (csize :: Word32)
|
||||
p <- (#peek msgpack_object, via.array.ptr) ptr
|
||||
objs <- mapM (\i -> peekObject $ p `plusPtr`
|
||||
((#size msgpack_object) * i))
|
||||
[0..size-1]
|
||||
return $ ObjectArray objs
|
||||
|
||||
peekObjectMap :: Ptr a -> IO Object
|
||||
peekObjectMap ptr = do
|
||||
csize <- (#peek msgpack_object, via.map.size) ptr
|
||||
let size = fromIntegral (csize :: Word32)
|
||||
p <- (#peek msgpack_object, via.map.ptr) ptr
|
||||
dat <- mapM (\i -> peekObjectKV $ p `plusPtr`
|
||||
((#size msgpack_object_kv) * i))
|
||||
[0..size-1]
|
||||
return $ ObjectMap dat
|
||||
|
||||
peekObjectKV :: Ptr a -> IO (Object, Object)
|
||||
peekObjectKV ptr = do
|
||||
k <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, key)
|
||||
v <- peekObject $ ptr `plusPtr` (#offset msgpack_object_kv, val)
|
||||
return (k, v)
|
||||
|
||||
-- | Pack a Object.
|
||||
packObject :: Packer -> Object -> IO ()
|
||||
packObject pc ObjectNil = packNil pc >> return ()
|
||||
|
||||
packObject pc (ObjectBool b) = packBool pc b >> return ()
|
||||
|
||||
packObject pc (ObjectInteger n) = packInt pc n >> return ()
|
||||
|
||||
packObject pc (ObjectDouble d) = packDouble pc d >> return ()
|
||||
|
||||
packObject pc (ObjectRAW bs) = packRAW' pc bs >> return ()
|
||||
|
||||
packObject pc (ObjectArray ls) = do
|
||||
_ <- packArray pc (length ls)
|
||||
mapM_ (packObject pc) ls
|
||||
|
||||
packObject pc (ObjectMap ls) = do
|
||||
_ <- packMap pc (length ls)
|
||||
mapM_ (\(a, b) -> packObject pc a >> packObject pc b) ls
|
||||
|
||||
data UnpackReturn =
|
||||
UnpackContinue -- ^ not enough bytes to unpack object
|
||||
| UnpackParseError -- ^ got invalid bytes
|
||||
| UnpackError -- ^ other error
|
||||
deriving (Eq, Show)
|
||||
|
||||
-- | Unpack a single MessagePack object from byte sequence.
|
||||
unpackObject :: Zone -> ByteString -> IO (Either UnpackReturn (Int, Object))
|
||||
unpackObject z dat =
|
||||
allocaBytes (#size msgpack_object) $ \ptr ->
|
||||
BS.useAsCStringLen dat $ \(str, len) ->
|
||||
alloca $ \poff -> do
|
||||
poke poff 0
|
||||
ret <- msgpack_unpack str (fromIntegral len) poff z ptr
|
||||
case ret of
|
||||
(#const MSGPACK_UNPACK_SUCCESS) -> do
|
||||
off <- peek poff
|
||||
obj <- peekObject ptr
|
||||
return $ Right (fromIntegral off, obj)
|
||||
(#const MSGPACK_UNPACK_EXTRA_BYTES) -> do
|
||||
off <- peek poff
|
||||
obj <- peekObject ptr
|
||||
return $ Right (fromIntegral off, obj)
|
||||
(#const MSGPACK_UNPACK_CONTINUE) ->
|
||||
return $ Left UnpackContinue
|
||||
(#const MSGPACK_UNPACK_PARSE_ERROR) ->
|
||||
return $ Left UnpackParseError
|
||||
_ ->
|
||||
return $ Left UnpackError
|
||||
|
||||
foreign import ccall "msgpack_unpack" msgpack_unpack ::
|
||||
Ptr CChar -> CSize -> Ptr CSize -> Zone -> Ptr () -> IO CInt
|
||||
@ -1,62 +0,0 @@
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Feed
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- Feeders for Stream Deserializers
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Feed(
|
||||
-- * Feeder type
|
||||
Feeder,
|
||||
-- * Feeders
|
||||
feederFromHandle,
|
||||
feederFromFile,
|
||||
feederFromString,
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.IORef
|
||||
import System.IO
|
||||
|
||||
-- | Feeder returns Just ByteString when bytes remains, otherwise Nothing.
|
||||
type Feeder = IO (Maybe ByteString)
|
||||
|
||||
-- | Feeder from Handle
|
||||
feederFromHandle :: Handle -> IO Feeder
|
||||
feederFromHandle h = return $ do
|
||||
bs <- BS.hGetNonBlocking h bufSize
|
||||
if BS.length bs > 0
|
||||
then do return $ Just bs
|
||||
else do
|
||||
c <- BS.hGet h 1
|
||||
if BS.length c > 0
|
||||
then do return $ Just c
|
||||
else do
|
||||
hClose h
|
||||
return Nothing
|
||||
where
|
||||
bufSize = 4096
|
||||
|
||||
-- | Feeder from File
|
||||
feederFromFile :: FilePath -> IO Feeder
|
||||
feederFromFile path =
|
||||
openFile path ReadMode >>= feederFromHandle
|
||||
|
||||
-- | Feeder from ByteString
|
||||
feederFromString :: ByteString -> IO Feeder
|
||||
feederFromString bs = do
|
||||
r <- newIORef (Just bs)
|
||||
return $ f r
|
||||
where
|
||||
f r = do
|
||||
mb <- readIORef r
|
||||
writeIORef r Nothing
|
||||
return mb
|
||||
@ -1,156 +0,0 @@
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Monad
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- Monadic Stream Serializers and Deserializers
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Monad(
|
||||
-- * Classes
|
||||
MonadPacker(..),
|
||||
MonadUnpacker(..),
|
||||
|
||||
-- * Packer and Unpacker type
|
||||
PackerT(..),
|
||||
UnpackerT(..),
|
||||
|
||||
-- * Packers
|
||||
packToString,
|
||||
packToHandle,
|
||||
packToFile,
|
||||
|
||||
-- * Unpackers
|
||||
unpackFrom,
|
||||
unpackFromString,
|
||||
unpackFromHandle,
|
||||
unpackFromFile,
|
||||
) where
|
||||
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString as BS
|
||||
import System.IO
|
||||
|
||||
import Data.MessagePack.Base hiding (Unpacker)
|
||||
import qualified Data.MessagePack.Base as Base
|
||||
import Data.MessagePack.Class
|
||||
import Data.MessagePack.Feed
|
||||
|
||||
class Monad m => MonadPacker m where
|
||||
-- | Serialize a object
|
||||
put :: OBJECT a => a -> m ()
|
||||
|
||||
class Monad m => MonadUnpacker m where
|
||||
-- | Deserialize a object
|
||||
get :: OBJECT a => m a
|
||||
|
||||
-- | Serializer Type
|
||||
newtype PackerT m r = PackerT { runPackerT :: Base.Packer -> m r }
|
||||
|
||||
instance Monad m => Monad (PackerT m) where
|
||||
a >>= b =
|
||||
PackerT $ \pc -> do
|
||||
r <- runPackerT a pc
|
||||
runPackerT (b r) pc
|
||||
|
||||
return r =
|
||||
PackerT $ \_ -> return r
|
||||
|
||||
instance MonadTrans PackerT where
|
||||
lift m = PackerT $ \_ -> m
|
||||
|
||||
instance MonadIO m => MonadIO (PackerT m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance MonadIO m => MonadPacker (PackerT m) where
|
||||
put v = PackerT $ \pc -> liftIO $ do
|
||||
pack pc v
|
||||
|
||||
-- | Execute given serializer and returns byte sequence.
|
||||
packToString :: MonadIO m => PackerT m r -> m ByteString
|
||||
packToString m = do
|
||||
sb <- liftIO $ newSimpleBuffer
|
||||
pc <- liftIO $ newPacker sb
|
||||
_ <- runPackerT m pc
|
||||
liftIO $ simpleBufferData sb
|
||||
|
||||
-- | Execute given serializer and write byte sequence to Handle.
|
||||
packToHandle :: MonadIO m => Handle -> PackerT m r -> m ()
|
||||
packToHandle h m = do
|
||||
sb <- packToString m
|
||||
liftIO $ BS.hPut h sb
|
||||
liftIO $ hFlush h
|
||||
|
||||
-- | Execute given serializer and write byte sequence to file.
|
||||
packToFile :: MonadIO m => FilePath -> PackerT m r -> m ()
|
||||
packToFile p m = do
|
||||
sb <- packToString m
|
||||
liftIO $ BS.writeFile p sb
|
||||
|
||||
-- | Deserializer type
|
||||
newtype UnpackerT m r = UnpackerT { runUnpackerT :: Base.Unpacker -> Feeder -> m r }
|
||||
|
||||
instance Monad m => Monad (UnpackerT m) where
|
||||
a >>= b =
|
||||
UnpackerT $ \up feed -> do
|
||||
r <- runUnpackerT a up feed
|
||||
runUnpackerT (b r) up feed
|
||||
|
||||
return r =
|
||||
UnpackerT $ \_ _ -> return r
|
||||
|
||||
instance MonadTrans UnpackerT where
|
||||
lift m = UnpackerT $ \_ _ -> m
|
||||
|
||||
instance MonadIO m => MonadIO (UnpackerT m) where
|
||||
liftIO = lift . liftIO
|
||||
|
||||
instance MonadIO m => MonadUnpacker (UnpackerT m) where
|
||||
get = UnpackerT $ \up feed -> liftIO $ do
|
||||
executeOne up feed
|
||||
obj <- unpackerData up
|
||||
freeZone =<< unpackerReleaseZone up
|
||||
unpackerReset up
|
||||
let Right r = fromObject obj
|
||||
return r
|
||||
|
||||
where
|
||||
executeOne up feed = do
|
||||
resp <- unpackerExecute up
|
||||
guard $ resp>=0
|
||||
when (resp==0) $ do
|
||||
Just bs <- feed
|
||||
unpackerFeed up bs
|
||||
executeOne up feed
|
||||
|
||||
-- | Execute deserializer using given feeder.
|
||||
unpackFrom :: MonadIO m => Feeder -> UnpackerT m r -> m r
|
||||
unpackFrom f m = do
|
||||
up <- liftIO $ newUnpacker defaultInitialBufferSize
|
||||
runUnpackerT m up f
|
||||
|
||||
-- | Execute deserializer using given handle.
|
||||
unpackFromHandle :: MonadIO m => Handle -> UnpackerT m r -> m r
|
||||
unpackFromHandle h m =
|
||||
flip unpackFrom m =<< liftIO (feederFromHandle h)
|
||||
|
||||
-- | Execute deserializer using given file content.
|
||||
unpackFromFile :: MonadIO m => FilePath -> UnpackerT m r -> m r
|
||||
unpackFromFile p m = do
|
||||
h <- liftIO $ openFile p ReadMode
|
||||
r <- flip unpackFrom m =<< liftIO (feederFromHandle h)
|
||||
liftIO $ hClose h
|
||||
return r
|
||||
|
||||
-- | Execute deserializer from given byte sequence.
|
||||
unpackFromString :: MonadIO m => ByteString -> UnpackerT m r -> m r
|
||||
unpackFromString bs m = do
|
||||
flip unpackFrom m =<< liftIO (feederFromString bs)
|
||||
@ -1,38 +1,50 @@
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE OverlappingInstances #-}
|
||||
{-# LANGUAGE IncoherentInstances #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Class
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- Module : Data.MessagePack.Object
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- Serializing Haskell values to and from MessagePack Objects.
|
||||
-- MessagePack object definition
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Class(
|
||||
module Data.MessagePack.Object(
|
||||
-- * MessagePack Object
|
||||
Object(..),
|
||||
|
||||
-- * Serialization to and from Object
|
||||
OBJECT(..),
|
||||
Result,
|
||||
pack,
|
||||
) where
|
||||
|
||||
import Control.Monad.Error
|
||||
import Data.ByteString.Char8 (ByteString)
|
||||
import Control.Monad
|
||||
import Control.Monad.Trans.Error ()
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.ByteString.Char8 as C8
|
||||
|
||||
import Data.MessagePack.Base
|
||||
-- | Object Representation of MessagePack data.
|
||||
data Object =
|
||||
ObjectNil
|
||||
| ObjectBool Bool
|
||||
| ObjectInteger Int
|
||||
| ObjectDouble Double
|
||||
| ObjectRAW B.ByteString
|
||||
| ObjectArray [Object]
|
||||
| ObjectMap [(Object, Object)]
|
||||
deriving (Show)
|
||||
|
||||
-- | The class of types serializable to and from MessagePack object
|
||||
class OBJECT a where
|
||||
-- | Encode a value to MessagePack object
|
||||
toObject :: a -> Object
|
||||
-- | Decode a value from MessagePack object
|
||||
fromObject :: Object -> Result a
|
||||
|
||||
-- | A type for parser results
|
||||
@ -65,7 +77,7 @@ instance OBJECT Double where
|
||||
fromObject (ObjectDouble d) = Right d
|
||||
fromObject _ = Left fromObjectError
|
||||
|
||||
instance OBJECT ByteString where
|
||||
instance OBJECT B.ByteString where
|
||||
toObject = ObjectRAW
|
||||
fromObject (ObjectRAW bs) = Right bs
|
||||
fromObject _ = Left fromObjectError
|
||||
@ -95,7 +107,3 @@ instance OBJECT a => OBJECT (Maybe a) where
|
||||
|
||||
fromObject ObjectNil = return Nothing
|
||||
fromObject obj = liftM Just $ fromObject obj
|
||||
|
||||
-- | Pack a serializable Haskell value.
|
||||
pack :: OBJECT a => Packer -> a -> IO ()
|
||||
pack pc = packObject pc . toObject
|
||||
147
haskell/src/Data/MessagePack/Packer.hs
Normal file
147
haskell/src/Data/MessagePack/Packer.hs
Normal file
@ -0,0 +1,147 @@
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language OverlappingInstances #-}
|
||||
|
||||
module Data.MessagePack.Packer(
|
||||
ObjectPut(..),
|
||||
) where
|
||||
|
||||
import Data.Binary.Put
|
||||
import Data.Binary.IEEE754
|
||||
import Data.Bits
|
||||
import qualified Data.ByteString as B
|
||||
|
||||
import Data.MessagePack.Object
|
||||
|
||||
class ObjectPut a where
|
||||
put :: a -> Put
|
||||
|
||||
instance ObjectPut Object where
|
||||
put = putObject
|
||||
|
||||
instance ObjectPut Int where
|
||||
put = putInteger
|
||||
|
||||
instance ObjectPut () where
|
||||
put _ = putNil
|
||||
|
||||
instance ObjectPut Bool where
|
||||
put = putBool
|
||||
|
||||
instance ObjectPut Double where
|
||||
put = putDouble
|
||||
|
||||
instance ObjectPut B.ByteString where
|
||||
put = putRAW
|
||||
|
||||
instance ObjectPut a => ObjectPut [a] where
|
||||
put = putArray
|
||||
|
||||
instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
|
||||
put = putMap
|
||||
|
||||
putObject :: Object -> Put
|
||||
putObject obj =
|
||||
case obj of
|
||||
ObjectInteger n ->
|
||||
putInteger n
|
||||
ObjectNil ->
|
||||
putNil
|
||||
ObjectBool b ->
|
||||
putBool b
|
||||
ObjectDouble d ->
|
||||
putDouble d
|
||||
ObjectRAW raw ->
|
||||
putRAW raw
|
||||
ObjectArray arr ->
|
||||
putArray arr
|
||||
ObjectMap m ->
|
||||
putMap m
|
||||
|
||||
putInteger :: Int -> Put
|
||||
putInteger n =
|
||||
case n of
|
||||
_ | n >= 0 && n <= 127 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -32 && n <= -1 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100 -> do
|
||||
putWord8 0xCC
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x10000 -> do
|
||||
putWord8 0xCD
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100000000 -> do
|
||||
putWord8 0xCE
|
||||
putWord32be $ fromIntegral n
|
||||
_ | n >= 0 -> do
|
||||
putWord8 0xCF
|
||||
putWord64be $ fromIntegral n
|
||||
_ | n >= -0x100 -> do
|
||||
putWord8 0xD0
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -0x10000 -> do
|
||||
putWord8 0xD1
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= -0x100000000 -> do
|
||||
putWord8 0xD2
|
||||
putWord32be $ fromIntegral n
|
||||
_ -> do
|
||||
putWord8 0xD3
|
||||
putWord64be $ fromIntegral n
|
||||
|
||||
putNil :: Put
|
||||
putNil = putWord8 0xC0
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool True = putWord8 0xC3
|
||||
putBool False = putWord8 0xC2
|
||||
|
||||
putDouble :: Double -> Put
|
||||
putDouble d = do
|
||||
putWord8 0xCB
|
||||
putFloat64be d
|
||||
|
||||
putRAW :: B.ByteString -> Put
|
||||
putRAW bs = do
|
||||
case len of
|
||||
_ | len <= 31 -> do
|
||||
putWord8 $ 0xA0 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDA
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDB
|
||||
putWord32be $ fromIntegral len
|
||||
putByteString bs
|
||||
where
|
||||
len = B.length bs
|
||||
|
||||
putArray :: ObjectPut a => [a] -> Put
|
||||
putArray arr = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
mapM_ put arr
|
||||
where
|
||||
len = length arr
|
||||
|
||||
putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
|
||||
putMap m = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x80 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDE
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDF
|
||||
putWord16be $ fromIntegral len
|
||||
mapM_ (\(k, v) -> put k >> put v) m
|
||||
where
|
||||
len = length m
|
||||
202
haskell/src/Data/MessagePack/Put.hs
Normal file
202
haskell/src/Data/MessagePack/Put.hs
Normal file
@ -0,0 +1,202 @@
|
||||
{-# Language FlexibleInstances #-}
|
||||
{-# Language IncoherentInstances #-}
|
||||
{-# Language OverlappingInstances #-}
|
||||
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Put
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009-2010
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- MessagePack Serializer using @Data.Binary.Put@
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Put(
|
||||
-- * Serializable class
|
||||
ObjectPut(..),
|
||||
) where
|
||||
|
||||
import Data.Binary.Put
|
||||
import Data.Binary.IEEE754
|
||||
import Data.Bits
|
||||
import qualified Data.ByteString as B
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Data.MessagePack.Object
|
||||
|
||||
-- | Serializable class
|
||||
class ObjectPut a where
|
||||
-- | Serialize a value
|
||||
put :: a -> Put
|
||||
|
||||
instance ObjectPut Object where
|
||||
put = putObject
|
||||
|
||||
instance ObjectPut Int where
|
||||
put = putInteger
|
||||
|
||||
instance ObjectPut () where
|
||||
put _ = putNil
|
||||
|
||||
instance ObjectPut Bool where
|
||||
put = putBool
|
||||
|
||||
instance ObjectPut Double where
|
||||
put = putDouble
|
||||
|
||||
instance ObjectPut B.ByteString where
|
||||
put = putRAW
|
||||
|
||||
instance ObjectPut a => ObjectPut [a] where
|
||||
put = putArray
|
||||
|
||||
instance ObjectPut a => ObjectPut (V.Vector a) where
|
||||
put = putArrayVector
|
||||
|
||||
instance (ObjectPut k, ObjectPut v) => ObjectPut [(k, v)] where
|
||||
put = putMap
|
||||
|
||||
instance (ObjectPut k, ObjectPut v) => ObjectPut (V.Vector (k, v)) where
|
||||
put = putMapVector
|
||||
|
||||
putObject :: Object -> Put
|
||||
putObject obj =
|
||||
case obj of
|
||||
ObjectInteger n ->
|
||||
putInteger n
|
||||
ObjectNil ->
|
||||
putNil
|
||||
ObjectBool b ->
|
||||
putBool b
|
||||
ObjectDouble d ->
|
||||
putDouble d
|
||||
ObjectRAW raw ->
|
||||
putRAW raw
|
||||
ObjectArray arr ->
|
||||
putArray arr
|
||||
ObjectMap m ->
|
||||
putMap m
|
||||
|
||||
putInteger :: Int -> Put
|
||||
putInteger n =
|
||||
case n of
|
||||
_ | n >= 0 && n <= 127 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -32 && n <= -1 ->
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100 -> do
|
||||
putWord8 0xCC
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x10000 -> do
|
||||
putWord8 0xCD
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= 0 && n < 0x100000000 -> do
|
||||
putWord8 0xCE
|
||||
putWord32be $ fromIntegral n
|
||||
_ | n >= 0 -> do
|
||||
putWord8 0xCF
|
||||
putWord64be $ fromIntegral n
|
||||
_ | n >= -0x80 -> do
|
||||
putWord8 0xD0
|
||||
putWord8 $ fromIntegral n
|
||||
_ | n >= -0x8000 -> do
|
||||
putWord8 0xD1
|
||||
putWord16be $ fromIntegral n
|
||||
_ | n >= -0x80000000 -> do
|
||||
putWord8 0xD2
|
||||
putWord32be $ fromIntegral n
|
||||
_ -> do
|
||||
putWord8 0xD3
|
||||
putWord64be $ fromIntegral n
|
||||
|
||||
putNil :: Put
|
||||
putNil = putWord8 0xC0
|
||||
|
||||
putBool :: Bool -> Put
|
||||
putBool True = putWord8 0xC3
|
||||
putBool False = putWord8 0xC2
|
||||
|
||||
putDouble :: Double -> Put
|
||||
putDouble d = do
|
||||
putWord8 0xCB
|
||||
putFloat64be d
|
||||
|
||||
putRAW :: B.ByteString -> Put
|
||||
putRAW bs = do
|
||||
case len of
|
||||
_ | len <= 31 -> do
|
||||
putWord8 $ 0xA0 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDA
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDB
|
||||
putWord32be $ fromIntegral len
|
||||
putByteString bs
|
||||
where
|
||||
len = B.length bs
|
||||
|
||||
putArray :: ObjectPut a => [a] -> Put
|
||||
putArray arr = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
mapM_ put arr
|
||||
where
|
||||
len = length arr
|
||||
|
||||
putArrayVector :: ObjectPut a => V.Vector a -> Put
|
||||
putArrayVector arr = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x90 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDC
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDD
|
||||
putWord32be $ fromIntegral len
|
||||
V.mapM_ put arr
|
||||
where
|
||||
len = V.length arr
|
||||
|
||||
putMap :: (ObjectPut k, ObjectPut v) => [(k, v)] -> Put
|
||||
putMap m = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x80 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDE
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDF
|
||||
putWord32be $ fromIntegral len
|
||||
mapM_ (\(k, v) -> put k >> put v) m
|
||||
where
|
||||
len = length m
|
||||
|
||||
putMapVector :: (ObjectPut k, ObjectPut v) => V.Vector (k, v) -> Put
|
||||
putMapVector m = do
|
||||
case len of
|
||||
_ | len <= 15 ->
|
||||
putWord8 $ 0x80 .|. fromIntegral len
|
||||
_ | len < 0x10000 -> do
|
||||
putWord8 0xDE
|
||||
putWord16be $ fromIntegral len
|
||||
_ -> do
|
||||
putWord8 0xDF
|
||||
putWord32be $ fromIntegral len
|
||||
V.mapM_ (\(k, v) -> put k >> put v) m
|
||||
where
|
||||
len = V.length m
|
||||
@ -1,82 +0,0 @@
|
||||
--------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Data.MessagePack.Stream
|
||||
-- Copyright : (c) Hideyuki Tanaka, 2009
|
||||
-- License : BSD3
|
||||
--
|
||||
-- Maintainer: tanaka.hideyuki@gmail.com
|
||||
-- Stability : experimental
|
||||
-- Portability: portable
|
||||
--
|
||||
-- Lazy Stream Serializers and Deserializers
|
||||
--
|
||||
--------------------------------------------------------------------
|
||||
|
||||
module Data.MessagePack.Stream(
|
||||
unpackObjects,
|
||||
unpackObjectsFromFile,
|
||||
unpackObjectsFromHandle,
|
||||
unpackObjectsFromString,
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import System.IO
|
||||
import System.IO.Unsafe
|
||||
|
||||
import Data.MessagePack.Base
|
||||
import Data.MessagePack.Feed
|
||||
|
||||
-- | Unpack objects using given feeder.
|
||||
unpackObjects :: Feeder -> IO [Object]
|
||||
unpackObjects feeder = do
|
||||
up <- newUnpacker defaultInitialBufferSize
|
||||
f up
|
||||
where
|
||||
f up = unsafeInterleaveIO $ do
|
||||
mbo <- unpackOnce up
|
||||
case mbo of
|
||||
Just o -> do
|
||||
os <- f up
|
||||
return $ o:os
|
||||
Nothing ->
|
||||
return []
|
||||
|
||||
unpackOnce up = do
|
||||
resp <- unpackerExecute up
|
||||
case resp of
|
||||
0 -> do
|
||||
r <- feedOnce up
|
||||
if r
|
||||
then unpackOnce up
|
||||
else return Nothing
|
||||
1 -> do
|
||||
obj <- unpackerData up
|
||||
freeZone =<< unpackerReleaseZone up
|
||||
unpackerReset up
|
||||
return $ Just obj
|
||||
_ ->
|
||||
error $ "unpackerExecute fails: " ++ show resp
|
||||
|
||||
feedOnce up = do
|
||||
dat <- feeder
|
||||
case dat of
|
||||
Nothing ->
|
||||
return False
|
||||
Just bs -> do
|
||||
unpackerFeed up bs
|
||||
return True
|
||||
|
||||
-- | Unpack objects from file.
|
||||
unpackObjectsFromFile :: FilePath -> IO [Object]
|
||||
unpackObjectsFromFile fname =
|
||||
unpackObjects =<< feederFromFile fname
|
||||
|
||||
-- | Unpack objects from handle.
|
||||
unpackObjectsFromHandle :: Handle -> IO [Object]
|
||||
unpackObjectsFromHandle h =
|
||||
unpackObjects =<< feederFromHandle h
|
||||
|
||||
-- | Unpack oobjects from given byte sequence.
|
||||
unpackObjectsFromString :: ByteString -> IO [Object]
|
||||
unpackObjectsFromString bs =
|
||||
unpackObjects =<< feederFromString bs
|
||||
@ -1,16 +1,21 @@
|
||||
import Control.Monad.Trans
|
||||
{-# Language OverloadedStrings #-}
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.ByteString as B
|
||||
import Data.MessagePack
|
||||
|
||||
main = do
|
||||
sb <- packToString $ do
|
||||
sb <- return $ packToString $ do
|
||||
put [1,2,3::Int]
|
||||
put (3.14 :: Double)
|
||||
put "Hoge"
|
||||
put ("Hoge" :: B.ByteString)
|
||||
|
||||
print sb
|
||||
|
||||
unpackFromString sb $ do
|
||||
r <- unpackFromString sb $ do
|
||||
arr <- get
|
||||
dbl <- get
|
||||
str <- get
|
||||
liftIO $ print (arr :: [Int], dbl :: Double, str :: String)
|
||||
return (arr :: [Int], dbl :: Double, str :: B.ByteString)
|
||||
|
||||
print r
|
||||
|
||||
@ -1,14 +0,0 @@
|
||||
import Control.Applicative
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.MessagePack
|
||||
|
||||
main = do
|
||||
sb <- newSimpleBuffer
|
||||
pc <- newPacker sb
|
||||
pack pc [1,2,3::Int]
|
||||
pack pc True
|
||||
pack pc "hoge"
|
||||
bs <- simpleBufferData sb
|
||||
|
||||
os <- unpackObjectsFromString bs
|
||||
mapM_ print os
|
||||
@ -1,36 +1,45 @@
|
||||
import Test.Framework
|
||||
import Test.Framework.Providers.QuickCheck2
|
||||
import Test.QuickCheck
|
||||
|
||||
import Control.Monad
|
||||
import qualified Data.ByteString.Char8 as B
|
||||
import Data.MessagePack
|
||||
|
||||
{-
|
||||
main = do
|
||||
sb <- newSimpleBuffer
|
||||
pc <- newPacker sb
|
||||
|
||||
pack pc [(1,2),(2,3),(3::Int,4::Int)]
|
||||
pack pc [4,5,6::Int]
|
||||
pack pc "hoge"
|
||||
|
||||
bs <- simpleBufferData sb
|
||||
print bs
|
||||
|
||||
up <- newUnpacker defaultInitialBufferSize
|
||||
|
||||
unpackerFeed up bs
|
||||
mid :: (ObjectGet a, ObjectPut a) => a -> a
|
||||
mid = unpack . pack
|
||||
|
||||
let f = do
|
||||
res <- unpackerExecute up
|
||||
when (res==1) $ do
|
||||
obj <- unpackerData up
|
||||
print obj
|
||||
f
|
||||
|
||||
f
|
||||
prop_mid_int a = a == mid a
|
||||
where types = a :: Int
|
||||
prop_mid_nil a = a == mid a
|
||||
where types = a :: ()
|
||||
prop_mid_bool a = a == mid a
|
||||
where types = a :: Bool
|
||||
prop_mid_double a = a == mid a
|
||||
where types = a :: Double
|
||||
prop_mid_string a = a == B.unpack (mid (B.pack a))
|
||||
where types = a :: String
|
||||
prop_mid_array_int a = a == mid a
|
||||
where types = a :: [Int]
|
||||
prop_mid_array_string a = a == map B.unpack (mid (map B.pack a))
|
||||
where types = a :: [String]
|
||||
prop_mid_map_int_double a = a == mid a
|
||||
where types = a :: [(Int, Double)]
|
||||
prop_mid_map_string_string a = a == map (\(x, y) -> (B.unpack x, B.unpack y)) (mid (map (\(x, y) -> (B.pack x, B.pack y)) a))
|
||||
where types = a :: [(String, String)]
|
||||
|
||||
return ()
|
||||
-}
|
||||
tests =
|
||||
[ testGroup "simple"
|
||||
[ testProperty "int" prop_mid_int
|
||||
, testProperty "nil" prop_mid_nil
|
||||
, testProperty "bool" prop_mid_bool
|
||||
, testProperty "double" prop_mid_double
|
||||
, testProperty "string" prop_mid_string
|
||||
, testProperty "[int]" prop_mid_array_int
|
||||
, testProperty "[string]" prop_mid_array_string
|
||||
, testProperty "[(int, double)]" prop_mid_map_int_double
|
||||
, testProperty "[(string, string)]" prop_mid_map_string_string
|
||||
]
|
||||
]
|
||||
|
||||
main = do
|
||||
bs <- packb [(1,2),(2,3),(3::Int,4::Int)]
|
||||
print bs
|
||||
dat <- unpackb bs
|
||||
print (dat :: Result [(Int, Int)])
|
||||
main = defaultMain tests
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user