haskell binding

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 <copyright holder> 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.

haskell/Setup.lhs

@@ -0,0 +1,3 @@
+#!/usr/bin/env runhaskell
+> import Distribution.Simple
+> main = defaultMain

haskell/cbits/msgpack.c

@@ -0,0 +1,137 @@
+#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);
+}
+

haskell/msgpack.cabal

@@ -0,0 +1,32 @@
+Name:                msgpack
+Version:             0.2.0
+License:             BSD3
+License-File:        LICENSE
+Author:              Hideyuki Tanaka
+Maintainer:          Hideyuki Tanaka <tanaka.hideyuki@gmail.com>
+Category:            Data
+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
+
+  Exposed-modules:
+    Data.MessagePack
+    Data.MessagePack.Base
+    Data.MessagePack.Class
+    Data.MessagePack.Feed
+    Data.MessagePack.Monad
+    Data.MessagePack.Stream
+
+  C-Sources:
+    cbits/msgpack.c

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

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 <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"
+
+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

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

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

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)

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

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)

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

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)])