module Data.MessagePack.Monad(
MonadPacker(..),
MonadUnpacker(..),
PackerT(..),
UnpackerT(..),
packToString,
packToHandle,
packToFile,
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
put :: OBJECT a => a -> m ()
class Monad m => MonadUnpacker m where
get :: OBJECT a => m a
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
packToString :: MonadIO m => PackerT m r -> m ByteString
packToString m = do
sb <- liftIO $ newSimpleBuffer
pc <- liftIO $ newPacker sb
_ <- runPackerT m pc
liftIO $ simpleBufferData sb
packToHandle :: MonadIO m => Handle -> PackerT m r -> m ()
packToHandle h m = do
sb <- packToString m
liftIO $ BS.hPut h sb
liftIO $ hFlush h
packToFile :: MonadIO m => FilePath -> PackerT m r -> m ()
packToFile p m = do
sb <- packToString m
liftIO $ BS.writeFile p sb
newtype UnpackerT m r = UnpackerT { runUnpackerT :: Base.Unpacker -> Feeder -> m r }
instance Monad m => Monad (UnpackerT m) where
a >>= b =
UnpackerT $ \up feed -> do
r <- runUnpackerT a up feed
runUnpackerT (b r) up feed
return r =
UnpackerT $ \_ _ -> return r
instance MonadTrans UnpackerT where
lift m = UnpackerT $ \_ _ -> m
instance MonadIO m => MonadIO (UnpackerT m) where
liftIO = lift . liftIO
instance MonadIO m => MonadUnpacker (UnpackerT m) where
get = UnpackerT $ \up feed -> liftIO $ do
executeOne up feed
obj <- unpackerData up
freeZone =<< unpackerReleaseZone up
unpackerReset up
let Right r = fromObject obj
return r
where
executeOne up feed = do
resp <- unpackerExecute up
guard $ resp>=0
when (resp==0) $ do
Just bs <- feed
unpackerFeed up bs
executeOne up feed
unpackFrom :: MonadIO m => Feeder -> UnpackerT m r -> m r
unpackFrom f m = do
up <- liftIO $ newUnpacker defaultInitialBufferSize
runUnpackerT m up f
unpackFromHandle :: MonadIO m => Handle -> UnpackerT m r -> m r
unpackFromHandle h m =
flip unpackFrom m =<< liftIO (feederFromHandle h)
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
unpackFromString :: MonadIO m => ByteString -> UnpackerT m r -> m r
unpackFromString bs m = do
flip unpackFrom m =<< liftIO (feederFromString bs)