{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE Rank2Types #-}
{-# LANGUAGE CPP #-}
module Data.Conduit.Serialization.Binary
( conduitDecode
, conduitEncode
, conduitMsgEncode
, conduitGet
, conduitPut
, conduitPutList
, conduitPutLBS
, conduitPutMany
, sourcePut
, sinkGet
, ParseError(..)
)
where
import Control.Exception
import Control.Monad (unless)
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.Foldable
import Data.Typeable
import qualified Data.Vector as V
import Control.Monad.Catch (MonadThrow(..))
data ParseError = ParseError
{ ParseError -> ByteString
unconsumed :: ByteString
, ParseError -> ByteOffset
offset :: ByteOffset
, ParseError -> String
content :: String
} deriving (Int -> ParseError -> ShowS
[ParseError] -> ShowS
ParseError -> String
(Int -> ParseError -> ShowS)
-> (ParseError -> String)
-> ([ParseError] -> ShowS)
-> Show ParseError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParseError -> ShowS
showsPrec :: Int -> ParseError -> ShowS
$cshow :: ParseError -> String
show :: ParseError -> String
$cshowList :: [ParseError] -> ShowS
showList :: [ParseError] -> ShowS
Show, Typeable)
instance Exception ParseError
conduitDecode :: (Binary b, MonadThrow m) => ConduitT ByteString b m ()
conduitDecode :: forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT ByteString b m ()
conduitDecode = Get b -> ConduitT ByteString b m ()
forall (m :: * -> *) b.
MonadThrow m =>
Get b -> ConduitT ByteString b m ()
conduitGet Get b
forall t. Binary t => Get t
get
conduitEncode :: (Binary b, MonadThrow m) => ConduitT b ByteString m ()
conduitEncode :: forall b (m :: * -> *).
(Binary b, MonadThrow m) =>
ConduitT b ByteString m ()
conduitEncode = (b -> Put) -> ConduitT b Put m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map b -> Put
forall t. Binary t => t -> Put
put ConduitT b Put m ()
-> ConduitT Put ByteString m () -> ConduitT b ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Put ByteString m ()
forall (m :: * -> *). Monad m => ConduitT Put ByteString m ()
conduitPut
conduitMsgEncode :: Monad m => (Binary b) => ConduitT b ByteString m ()
conduitMsgEncode :: forall (m :: * -> *) b.
(Monad m, Binary b) =>
ConduitT b ByteString m ()
conduitMsgEncode = (b -> Put) -> ConduitT b Put m ()
forall (m :: * -> *) a b. Monad m => (a -> b) -> ConduitT a b m ()
CL.map b -> Put
forall t. Binary t => t -> Put
put ConduitT b Put m ()
-> ConduitT Put ByteString m () -> ConduitT b ByteString m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitT a b m () -> ConduitT b c m r -> ConduitT a c m r
.| ConduitT Put ByteString m ()
forall (m :: * -> *). Monad m => ConduitT Put ByteString m ()
conduitMsg
conduitGet :: MonadThrow m => Get b -> ConduitT ByteString b m ()
conduitGet :: forall (m :: * -> *) b.
MonadThrow m =>
Get b -> ConduitT ByteString b m ()
conduitGet Get b
g = ConduitT ByteString b m ()
start
where
start :: ConduitT ByteString b m ()
start = do Maybe ByteString
mx <- ConduitT ByteString b m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await
case Maybe ByteString
mx of
Maybe ByteString
Nothing -> () -> ConduitT ByteString b m ()
forall a. a -> ConduitT ByteString b m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just ByteString
x -> Decoder b -> ConduitT ByteString b m ()
go (Get b -> Decoder b
forall a. Get a -> Decoder a
runGetIncremental Get b
g Decoder b -> ByteString -> Decoder b
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
x)
go :: Decoder b -> ConduitT ByteString b m ()
go (Done ByteString
bs ByteOffset
_ b
v) = do b -> ConduitT ByteString b m ()
forall (m :: * -> *) o i. Monad m => o -> ConduitT i o m ()
yield b
v
if ByteString -> Bool
BS.null ByteString
bs
then ConduitT ByteString b m ()
start
else Decoder b -> ConduitT ByteString b m ()
go (Get b -> Decoder b
forall a. Get a -> Decoder a
runGetIncremental Get b
g Decoder b -> ByteString -> Decoder b
forall a. Decoder a -> ByteString -> Decoder a
`pushChunk` ByteString
bs)
go (Fail ByteString
u ByteOffset
o String
e) = ParseError -> ConduitT ByteString b m ()
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT ByteString b m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ByteString -> ByteOffset -> String -> ParseError
ParseError ByteString
u ByteOffset
o String
e)
go (Partial Maybe ByteString -> Decoder b
n) = ConduitT ByteString b m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT ByteString b m (Maybe ByteString)
-> (Maybe ByteString -> ConduitT ByteString b m ())
-> ConduitT ByteString b m ()
forall a b.
ConduitT ByteString b m a
-> (a -> ConduitT ByteString b m b) -> ConduitT ByteString b m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (Decoder b -> ConduitT ByteString b m ()
go (Decoder b -> ConduitT ByteString b m ())
-> (Maybe ByteString -> Decoder b)
-> Maybe ByteString
-> ConduitT ByteString b m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Decoder b
n)
#define conduitPutGeneric(name,yi) \
name = conduit \
where \
conduit = do {mx <- await;\
case mx of;\
Nothing -> return ();\
Just x -> do { yi ; conduit}}
conduitPut :: Monad m => ConduitT Put ByteString m ()
conduitPutGeneric(conduitPut, (traverse_ yield (LBS.toChunks $ runPut x)))
conduitMsg :: Monad m => ConduitT Put ByteString m ()
conduitPutGeneric(conduitMsg, (yield (LBS.toStrict $ runPut x)))
conduitPutLBS :: Monad m => ConduitT Put LBS.ByteString m ()
conduitPutGeneric(conduitPutLBS, yield (runPut x))
conduitPutList :: Monad m => ConduitT Put [ByteString] m ()
conduitPutGeneric(conduitPutList, yield (LBS.toChunks (runPut x)))
conduitPutMany :: Monad m => ConduitT Put (V.Vector ByteString) m ()
conduitPutGeneric(conduitPutMany, yield (V.fromList (LBS.toChunks (runPut x))))
sourcePut :: Monad m => Put -> ConduitT z ByteString m ()
sourcePut :: forall (m :: * -> *) z.
Monad m =>
Put -> ConduitT z ByteString m ()
sourcePut = [ByteString] -> ConduitT z ByteString m ()
forall (m :: * -> *) a i. Monad m => [a] -> ConduitT i a m ()
CL.sourceList ([ByteString] -> ConduitT z ByteString m ())
-> (Put -> [ByteString]) -> Put -> ConduitT z ByteString m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.toChunks (ByteString -> [ByteString])
-> (Put -> ByteString) -> Put -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPut
sinkGet :: MonadThrow m => Get b -> ConduitT ByteString z m b
sinkGet :: forall (m :: * -> *) b z.
MonadThrow m =>
Get b -> ConduitT ByteString z m b
sinkGet Get b
f = Decoder b -> ConduitT ByteString z m b
forall {m :: * -> *} {b} {o}.
MonadThrow m =>
Decoder b -> ConduitT ByteString o m b
sink (Get b -> Decoder b
forall a. Get a -> Decoder a
runGetIncremental Get b
f)
where
sink :: Decoder b -> ConduitT ByteString o m b
sink (Done ByteString
bs ByteOffset
_ b
v) = do
Bool -> ConduitT ByteString o m () -> ConduitT ByteString o m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
BS.null ByteString
bs) (ConduitT ByteString o m () -> ConduitT ByteString o m ())
-> ConduitT ByteString o m () -> ConduitT ByteString o m ()
forall a b. (a -> b) -> a -> b
$
ByteString -> ConduitT ByteString o m ()
forall i o (m :: * -> *). i -> ConduitT i o m ()
leftover ByteString
bs
b -> ConduitT ByteString o m b
forall a. a -> ConduitT ByteString o m a
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
sink (Fail ByteString
u ByteOffset
o String
e) = ParseError -> ConduitT ByteString o m b
forall e a.
(HasCallStack, Exception e) =>
e -> ConduitT ByteString o m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (ByteString -> ByteOffset -> String -> ParseError
ParseError ByteString
u ByteOffset
o String
e)
sink (Partial Maybe ByteString -> Decoder b
next) = ConduitT ByteString o m (Maybe ByteString)
forall (m :: * -> *) i o. Monad m => ConduitT i o m (Maybe i)
await ConduitT ByteString o m (Maybe ByteString)
-> (Maybe ByteString -> ConduitT ByteString o m b)
-> ConduitT ByteString o m b
forall a b.
ConduitT ByteString o m a
-> (a -> ConduitT ByteString o m b) -> ConduitT ByteString o m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Decoder b -> ConduitT ByteString o m b
sink (Decoder b -> ConduitT ByteString o m b)
-> (Maybe ByteString -> Decoder b)
-> Maybe ByteString
-> ConduitT ByteString o m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe ByteString -> Decoder b
next