module Data.MessagePack.Base(
SimpleBuffer,
newSimpleBuffer,
simpleBufferData,
Packer,
newPacker,
packU8,
packU16,
packU32,
packU64,
packS8,
packS16,
packS32,
packS64,
packTrue,
packFalse,
packInt,
packDouble,
packNil,
packBool,
packArray,
packMap,
packRAW,
packRAWBody,
packRAW',
Unpacker,
defaultInitialBufferSize,
newUnpacker,
unpackerReserveBuffer,
unpackerBuffer,
unpackerBufferCapacity,
unpackerBufferConsumed,
unpackerFeed,
unpackerExecute,
unpackerData,
unpackerReleaseZone,
unpackerResetZone,
unpackerReset,
unpackerMessageSize,
Object(..),
packObject,
UnpackReturn(..),
unpackObject,
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
type SimpleBuffer = ForeignPtr ()
type WriteCallback = Ptr () -> CString -> CUInt -> IO CInt
newSimpleBuffer :: IO SimpleBuffer
newSimpleBuffer = do
ptr <- mallocBytes ((24))
fptr <- newForeignPtr ptr $ do
msgpack_sbuffer_destroy ptr
free ptr
withForeignPtr fptr $ \p ->
msgpack_sbuffer_init p
return fptr
simpleBufferData :: SimpleBuffer -> IO ByteString
simpleBufferData sb =
withForeignPtr sb $ \ptr -> do
size <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
dat <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) 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 ()
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
packInt :: Integral a => Packer -> a -> IO Int
packInt pc n = packS64 pc $ fromIntegral n
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
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
packBool :: Packer -> Bool -> IO Int
packBool pc True = packTrue pc
packBool pc False = packFalse pc
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 :: 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 :: 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
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
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
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 :: 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
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)
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 :: 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 ()
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
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
unpackerData :: Unpacker -> IO Object
unpackerData up =
withForeignPtr up $ \ptr ->
allocaBytes ((24)) $ \pobj -> do
msgpack_unpacker_data ptr pobj
peekObject pobj
foreign import ccall "msgpack_unpacker_data_wrap" msgpack_unpacker_data ::
Ptr () -> Ptr () -> IO ()
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 ())
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 ()
unpackerReset :: Unpacker -> IO ()
unpackerReset up =
withForeignPtr up $ \ptr ->
msgpack_unpacker_reset ptr
foreign import ccall "msgpack_unpacker_reset" msgpack_unpacker_reset ::
Ptr () -> IO ()
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 ()
newZone :: IO Zone
newZone =
msgpack_zone_new (8192)
freeZone :: Zone -> IO ()
freeZone z =
msgpack_zone_free z
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 ()
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 <- ((\hsc_ptr -> peekByteOff hsc_ptr 0)) ptr
case (typ :: CInt) of
(0) ->
return ObjectNil
(1) ->
peekObjectBool ptr
(2) ->
peekObjectPositiveInteger ptr
(3) ->
peekObjectNegativeInteger ptr
(4) ->
peekObjectDouble ptr
(5) ->
peekObjectRAW ptr
(6) ->
peekObjectArray ptr
(7) ->
peekObjectMap ptr
_ ->
fail "peekObject: unknown object type"
peekObjectBool :: Ptr a -> IO Object
peekObjectBool ptr = do
b <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
return $ ObjectBool $ (b :: CUChar) /= 0
peekObjectPositiveInteger :: Ptr a -> IO Object
peekObjectPositiveInteger ptr = do
n <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
return $ ObjectInteger $ fromIntegral (n :: Word64)
peekObjectNegativeInteger :: Ptr a -> IO Object
peekObjectNegativeInteger ptr = do
n <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
return $ ObjectInteger $ fromIntegral (n :: Int64)
peekObjectDouble :: Ptr a -> IO Object
peekObjectDouble ptr = do
d <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
return $ ObjectDouble $ realToFrac (d :: CDouble)
peekObjectRAW :: Ptr a -> IO Object
peekObjectRAW ptr = do
size <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
p <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
bs <- BS.packCStringLen (p, fromIntegral (size :: Word32))
return $ ObjectRAW bs
peekObjectArray :: Ptr a -> IO Object
peekObjectArray ptr = do
size <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
p <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
objs <- mapM (\i -> peekObject $ p `plusPtr`
(((24)) * i))
[0..size1]
return $ ObjectArray objs
peekObjectMap :: Ptr a -> IO Object
peekObjectMap ptr = do
size <- ((\hsc_ptr -> peekByteOff hsc_ptr 8)) ptr
p <- ((\hsc_ptr -> peekByteOff hsc_ptr 16)) ptr
dat <- mapM (\i -> peekObjectKV $ p `plusPtr`
(((48)) * i))
[0..size1]
return $ ObjectMap dat
peekObjectKV :: Ptr a -> IO (Object, Object)
peekObjectKV ptr = do
k <- peekObject $ ptr `plusPtr` ((0))
v <- peekObject $ ptr `plusPtr` ((24))
return (k, v)
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
| UnpackParseError
| UnpackError
deriving (Eq, Show)
unpackObject :: Zone -> ByteString -> IO (Either UnpackReturn (Int, Object))
unpackObject z dat =
allocaBytes ((24)) $ \ptr ->
BS.useAsCStringLen dat $ \(str, len) ->
alloca $ \poff -> do
ret <- msgpack_unpack str (fromIntegral len) poff z ptr
case ret of
(2) -> do
off <- peek poff
obj <- peekObject ptr
return $ Right (fromIntegral off, obj)
(1) -> do
off <- peek poff
obj <- peekObject ptr
return $ Right (fromIntegral off, obj)
(0) ->
return $ Left UnpackContinue
(1) ->
return $ Left UnpackParseError
_ ->
return $ Left UnpackError
foreign import ccall "msgpack_unpack" msgpack_unpack ::
Ptr CChar -> CSize -> Ptr CSize -> Zone -> Ptr () -> IO CInt