module Data.Conduit.Serialization.Binary
( conduitDecode
, conduitEncode
, conduitGet
, conduitPut
, sourcePut
, sinkGet
, ParseError(..)
)
where
import Control.Exception
import Data.Binary
import Data.Binary.Get
import Data.Binary.Put
import Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Typeable
data ParseError = ParseError
{ unconsumed :: ByteString
, offset :: ByteOffset
, content :: String
} deriving (Show, Typeable)
instance Exception ParseError
conduitDecode :: (Binary b, MonadThrow m) => Conduit ByteString m b
conduitDecode = conduitGet get
conduitEncode :: (Binary b, MonadThrow m) => Conduit b m ByteString
conduitEncode = CL.map put =$= conduitPut
conduitGet :: MonadThrow m => Get b -> Conduit ByteString m b
conduitGet g = start
where
start = do mx <- await
case mx of
Nothing -> return ()
Just x -> go (runGetIncremental g `pushChunk` x)
conduit p = await >>= go . flip (maybe pushEndOfInput (flip pushChunk)) p
go (Done bs _ v) = do yield v
if BS.null bs
then start
else go (runGetIncremental g `pushChunk` bs)
go (Fail u o e) = monadThrow (ParseError u o e)
go (Partial n) = await >>= (go . n)
conduitPut :: MonadThrow m => Conduit Put m ByteString
conduitPut = conduit
where
conduit = do mx <- await
case mx of
Nothing -> return ()
Just x -> do sourcePut x $$ CL.mapM_ yield
conduit
sourcePut :: (MonadThrow m) => Put -> Producer m ByteString
sourcePut = CL.sourceList . LBS.toChunks . runPut
sinkGet :: (Binary b, MonadThrow m) => Get b -> Consumer ByteString m b
sinkGet f = sink (runGetIncremental f)
where
sink (Done bs _ v) = leftover bs >> return v
sink (Fail u o e) = monadThrow (ParseError u o e)
sink (Partial next) = await >>= sink . next