diff --git a/msgpack.cabal b/msgpack.cabal --- a/msgpack.cabal +++ b/msgpack.cabal @@ -1,12 +1,13 @@ Name: msgpack -Version: 0.1.0 +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 +Description: + A Haskell binding to MessagePack Homepage: http://github.com/tanakh/hsmsgpack Stability: Experimental Tested-with: GHC==6.10.4 @@ -23,6 +24,9 @@ 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/src/Data/MessagePack.hs b/src/Data/MessagePack.hs --- a/src/Data/MessagePack.hs +++ b/src/Data/MessagePack.hs @@ -15,6 +15,9 @@ 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, @@ -30,6 +33,9 @@ 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 diff --git a/src/Data/MessagePack/Base.hsc b/src/Data/MessagePack/Base.hsc --- a/src/Data/MessagePack/Base.hsc +++ b/src/Data/MessagePack/Base.hsc @@ -1,7 +1,5 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE IncoherentInstances #-} -------------------------------------------------------------------- -- | diff --git a/src/Data/MessagePack/Class.hs b/src/Data/MessagePack/Class.hs --- a/src/Data/MessagePack/Class.hs +++ b/src/Data/MessagePack/Class.hs @@ -1,6 +1,7 @@ {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverlappingInstances #-} +{-# LANGUAGE IncoherentInstances #-} -------------------------------------------------------------------- -- | diff --git a/src/Data/MessagePack/Feed.hs b/src/Data/MessagePack/Feed.hs new file mode 100644 --- /dev/null +++ b/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/src/Data/MessagePack/Monad.hs b/src/Data/MessagePack/Monad.hs new file mode 100644 --- /dev/null +++ b/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/src/Data/MessagePack/Stream.hs b/src/Data/MessagePack/Stream.hs new file mode 100644 --- /dev/null +++ b/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