From f53c351fd28b3bea6a03416a54aff631499af65a Mon Sep 17 00:00:00 2001 From: Hideyuki Tanaka Date: Sun, 18 Apr 2010 02:17:49 +0900 Subject: [PATCH] haskell binding --- haskell/LICENSE | 24 + haskell/README | 0 haskell/Setup.lhs | 3 + haskell/cbits/msgpack.c | 137 ++++++ haskell/msgpack.cabal | 32 ++ haskell/src/Data/MessagePack.hs | 63 +++ haskell/src/Data/MessagePack/Base.hsc | 581 +++++++++++++++++++++++++ haskell/src/Data/MessagePack/Class.hs | 97 +++++ haskell/src/Data/MessagePack/Feed.hs | 59 +++ haskell/src/Data/MessagePack/Monad.hs | 153 +++++++ haskell/src/Data/MessagePack/Stream.hs | 84 ++++ haskell/test/Monad.hs | 16 + haskell/test/Stream.hs | 14 + haskell/test/Test.hs | 36 ++ 14 files changed, 1299 insertions(+) create mode 100644 haskell/LICENSE create mode 100644 haskell/README create mode 100644 haskell/Setup.lhs create mode 100644 haskell/cbits/msgpack.c create mode 100644 haskell/msgpack.cabal create mode 100644 haskell/src/Data/MessagePack.hs create mode 100644 haskell/src/Data/MessagePack/Base.hsc create mode 100644 haskell/src/Data/MessagePack/Class.hs create mode 100644 haskell/src/Data/MessagePack/Feed.hs create mode 100644 haskell/src/Data/MessagePack/Monad.hs create mode 100644 haskell/src/Data/MessagePack/Stream.hs create mode 100644 haskell/test/Monad.hs create mode 100644 haskell/test/Stream.hs create mode 100644 haskell/test/Test.hs diff --git a/haskell/LICENSE b/haskell/LICENSE new file mode 100644 index 00000000..2de30f66 --- /dev/null +++ b/haskell/LICENSE @@ -0,0 +1,24 @@ +Copyright (c) 2009, Hideyuki Tanaka +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + * Neither the name of the Hideyuki Tanaka nor the + names of its contributors may be used to endorse or promote products + derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY Hideyuki Tanaka ''AS IS'' AND ANY +EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL BE LIABLE FOR ANY +DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; +LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND +ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/haskell/README b/haskell/README new file mode 100644 index 00000000..e69de29b diff --git a/haskell/Setup.lhs b/haskell/Setup.lhs new file mode 100644 index 00000000..5bde0de9 --- /dev/null +++ b/haskell/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/haskell/cbits/msgpack.c b/haskell/cbits/msgpack.c new file mode 100644 index 00000000..be445925 --- /dev/null +++ b/haskell/cbits/msgpack.c @@ -0,0 +1,137 @@ +#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 new file mode 100644 index 00000000..505a2b98 --- /dev/null +++ b/haskell/msgpack.cabal @@ -0,0 +1,32 @@ +Name: msgpack +Version: 0.2.0 +License: BSD3 +License-File: LICENSE +Author: Hideyuki Tanaka +Maintainer: Hideyuki Tanaka +Category: Data +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 + + Exposed-modules: + Data.MessagePack + Data.MessagePack.Base + Data.MessagePack.Class + Data.MessagePack.Feed + Data.MessagePack.Monad + Data.MessagePack.Stream + + C-Sources: + cbits/msgpack.c diff --git a/haskell/src/Data/MessagePack.hs b/haskell/src/Data/MessagePack.hs new file mode 100644 index 00000000..2949e603 --- /dev/null +++ b/haskell/src/Data/MessagePack.hs @@ -0,0 +1,63 @@ +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack +-- Copyright : (c) Hideyuki Tanaka, 2009 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- Simple interface to pack and unpack MessagePack data. +-- +-------------------------------------------------------------------- + +module Data.MessagePack( + module Data.MessagePack.Base, + module Data.MessagePack.Class, + module Data.MessagePack.Feed, + module Data.MessagePack.Monad, + module Data.MessagePack.Stream, + + -- * Pack and Unpack + packb, + unpackb, + + -- * Pure version of Pack and Unpack + packb', + unpackb', + ) where + +import Data.ByteString (ByteString) +import System.IO.Unsafe + +import Data.MessagePack.Base +import Data.MessagePack.Class +import Data.MessagePack.Feed +import Data.MessagePack.Monad +import Data.MessagePack.Stream + +-- | 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 + +-- | 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 + +-- | Pure version of 'packb'. +packb' :: OBJECT a => a -> ByteString +packb' dat = unsafePerformIO $ packb dat + +-- | Pure version of 'unpackb'. +unpackb' :: OBJECT a => ByteString -> Result a +unpackb' bs = unsafePerformIO $ unpackb bs diff --git a/haskell/src/Data/MessagePack/Base.hsc b/haskell/src/Data/MessagePack/Base.hsc new file mode 100644 index 00000000..ad717120 --- /dev/null +++ b/haskell/src/Data/MessagePack/Base.hsc @@ -0,0 +1,581 @@ +{-# 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" + +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 + size <- (#peek msgpack_object, via.array.size) ptr + 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 + size <- (#peek msgpack_object, via.map.size) ptr + 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 + 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/Class.hs b/haskell/src/Data/MessagePack/Class.hs new file mode 100644 index 00000000..f50a4d82 --- /dev/null +++ b/haskell/src/Data/MessagePack/Class.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE IncoherentInstances #-} + +-------------------------------------------------------------------- +-- | +-- Module : Data.MessagePack.Class +-- Copyright : (c) Hideyuki Tanaka, 2009 +-- License : BSD3 +-- +-- Maintainer: tanaka.hideyuki@gmail.com +-- Stability : experimental +-- Portability: portable +-- +-- Serializing Haskell values to and from MessagePack Objects. +-- +-------------------------------------------------------------------- + +module Data.MessagePack.Class( + -- * Serialization to and from Object + OBJECT(..), + Result, + pack, + ) where + +import Control.Monad.Error +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as C8 +import Data.Either + +import Data.MessagePack.Base + +-- | The class of types serializable to and from MessagePack object +class OBJECT a where + toObject :: a -> Object + fromObject :: Object -> Result a + +-- | A type for parser results +type Result a = Either String a + +instance OBJECT Object where + toObject = id + fromObject = Right + +fromObjectError :: String +fromObjectError = "fromObject: cannot cast" + +instance OBJECT Int where + toObject = ObjectInteger + fromObject (ObjectInteger n) = Right n + fromObject _ = Left fromObjectError + +instance OBJECT Bool where + toObject = ObjectBool + fromObject (ObjectBool b) = Right b + fromObject _ = Left fromObjectError + +instance OBJECT Double where + toObject = ObjectDouble + fromObject (ObjectDouble d) = Right d + fromObject _ = Left fromObjectError + +instance OBJECT ByteString where + toObject = ObjectRAW + fromObject (ObjectRAW bs) = Right bs + fromObject _ = Left fromObjectError + +instance OBJECT String where + toObject = toObject . C8.pack + fromObject obj = liftM C8.unpack $ fromObject obj + +instance OBJECT a => OBJECT [a] where + toObject = ObjectArray . map toObject + fromObject (ObjectArray arr) = + mapM fromObject arr + fromObject _ = + Left fromObjectError + +instance (OBJECT a, OBJECT b) => OBJECT [(a, b)] where + toObject = + ObjectMap . map (\(a, b) -> (toObject a, toObject b)) + fromObject (ObjectMap mem) = do + mapM (\(a, b) -> liftM2 (,) (fromObject a) (fromObject b)) mem + fromObject _ = + Left fromObjectError + +instance OBJECT a => OBJECT (Maybe a) where + toObject (Just a) = toObject a + toObject Nothing = ObjectNil + + 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/Feed.hs b/haskell/src/Data/MessagePack/Feed.hs new file mode 100644 index 00000000..afd3f6c5 --- /dev/null +++ b/haskell/src/Data/MessagePack/Feed.hs @@ -0,0 +1,59 @@ +-------------------------------------------------------------------- +-- | +-- 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 Control.Monad +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.hGet h bufSize + if BS.length bs > 0 + then return $ Just bs + 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 new file mode 100644 index 00000000..bf1514fa --- /dev/null +++ b/haskell/src/Data/MessagePack/Monad.hs @@ -0,0 +1,153 @@ +-------------------------------------------------------------------- +-- | +-- 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 + +-- | Execcute 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 + resp <- unpackerExecute up + guard $ resp>=0 + when (resp==0) $ do + Just bs <- feed + unpackerFeed up bs + resp2 <- unpackerExecute up + guard $ resp2==1 + obj <- unpackerData up + freeZone =<< unpackerReleaseZone up + unpackerReset up + let Right r = fromObject obj + return r + +-- | 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/Stream.hs b/haskell/src/Data/MessagePack/Stream.hs new file mode 100644 index 00000000..bd17f467 --- /dev/null +++ b/haskell/src/Data/MessagePack/Stream.hs @@ -0,0 +1,84 @@ +-------------------------------------------------------------------- +-- | +-- 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 Control.Monad +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +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 new file mode 100644 index 00000000..4bee5c54 --- /dev/null +++ b/haskell/test/Monad.hs @@ -0,0 +1,16 @@ +import Control.Monad.Trans +import Data.MessagePack + +main = do + sb <- packToString $ do + put [1,2,3::Int] + put (3.14 :: Double) + put "Hoge" + + print sb + + unpackFromString sb $ do + arr <- get + dbl <- get + str <- get + liftIO $ print (arr :: [Int], dbl :: Double, str :: String) diff --git a/haskell/test/Stream.hs b/haskell/test/Stream.hs new file mode 100644 index 00000000..ce060dea --- /dev/null +++ b/haskell/test/Stream.hs @@ -0,0 +1,14 @@ +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 new file mode 100644 index 00000000..4e713ba6 --- /dev/null +++ b/haskell/test/Test.hs @@ -0,0 +1,36 @@ +import Control.Monad +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 + + let f = do + res <- unpackerExecute up + when (res==1) $ do + obj <- unpackerData up + print obj + f + + f + + return () +-} + +main = do + bs <- packb [(1,2),(2,3),(3::Int,4::Int)] + print bs + dat <- unpackb bs + print (dat :: Result [(Int, Int)])