diff --git a/haskell/LICENSE b/haskell/LICENSE index 2de30f66..3cb4d8c8 100644 --- a/haskell/LICENSE +++ b/haskell/LICENSE @@ -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 diff --git a/haskell/cbits/msgpack.c b/haskell/cbits/msgpack.c deleted file mode 100644 index be445925..00000000 --- a/haskell/cbits/msgpack.c +++ /dev/null @@ -1,137 +0,0 @@ -#include - -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); -} - diff --git a/haskell/msgpack.cabal b/haskell/msgpack.cabal index 82cdb525..8346c1f8 100644 --- a/haskell/msgpack.cabal +++ b/haskell/msgpack.cabal @@ -1,32 +1,35 @@ -Name: msgpack -Version: 0.2.2 -License: BSD3 -License-File: LICENSE -Author: Hideyuki Tanaka -Maintainer: Hideyuki Tanaka -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 -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 +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 diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs index 2949e603..010eaab0 100644 --- a/haskell/src/Data/MessagePack.hs +++ b/haskell/src/Data/MessagePack.hs @@ -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) diff --git a/haskell/src/Data/MessagePack/Base.hsc b/haskell/src/Data/MessagePack/Base.hsc deleted file mode 100644 index b6cdc287..00000000 --- a/haskell/src/Data/MessagePack/Base.hsc +++ /dev/null @@ -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 - -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 diff --git a/haskell/src/Data/MessagePack/Feed.hs b/haskell/src/Data/MessagePack/Feed.hs deleted file mode 100644 index 4b486396..00000000 --- a/haskell/src/Data/MessagePack/Feed.hs +++ /dev/null @@ -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 diff --git a/haskell/src/Data/MessagePack/Monad.hs b/haskell/src/Data/MessagePack/Monad.hs deleted file mode 100644 index 15f21fe0..00000000 --- a/haskell/src/Data/MessagePack/Monad.hs +++ /dev/null @@ -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) diff --git a/haskell/src/Data/MessagePack/Class.hs b/haskell/src/Data/MessagePack/Object.hs similarity index 77% rename from haskell/src/Data/MessagePack/Class.hs rename to haskell/src/Data/MessagePack/Object.hs index 365acc5f..19a3aeba 100644 --- a/haskell/src/Data/MessagePack/Class.hs +++ b/haskell/src/Data/MessagePack/Object.hs @@ -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 diff --git a/haskell/src/Data/MessagePack/Packer.hs b/haskell/src/Data/MessagePack/Packer.hs new file mode 100644 index 00000000..9c10f5ed --- /dev/null +++ b/haskell/src/Data/MessagePack/Packer.hs @@ -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 diff --git a/haskell/src/Data/MessagePack/Put.hs b/haskell/src/Data/MessagePack/Put.hs new file mode 100644 index 00000000..8d0af2b2 --- /dev/null +++ b/haskell/src/Data/MessagePack/Put.hs @@ -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 diff --git a/haskell/src/Data/MessagePack/Stream.hs b/haskell/src/Data/MessagePack/Stream.hs deleted file mode 100644 index c56fe8d4..00000000 --- a/haskell/src/Data/MessagePack/Stream.hs +++ /dev/null @@ -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 diff --git a/haskell/test/Monad.hs b/haskell/test/Monad.hs index 4bee5c54..2ec40938 100644 --- a/haskell/test/Monad.hs +++ b/haskell/test/Monad.hs @@ -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 diff --git a/haskell/test/Stream.hs b/haskell/test/Stream.hs deleted file mode 100644 index ce060dea..00000000 --- a/haskell/test/Stream.hs +++ /dev/null @@ -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 diff --git a/haskell/test/Test.hs b/haskell/test/Test.hs index 4e713ba6..1bb551c1 100644 --- a/haskell/test/Test.hs +++ b/haskell/test/Test.hs @@ -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