cereal-conduit-0.8.0/Data/0000755000000000000000000000000012620000113013435 5ustar0000000000000000cereal-conduit-0.8.0/Data/Conduit/0000755000000000000000000000000013230046155015060 5ustar0000000000000000cereal-conduit-0.8.0/Data/Conduit/Cereal/0000755000000000000000000000000013230046155016253 5ustar0000000000000000cereal-conduit-0.8.0/Test/0000755000000000000000000000000013230046155013521 5ustar0000000000000000cereal-conduit-0.8.0/Data/Conduit/Cereal.hs0000644000000000000000000001143413230046155016612 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE RankNTypes #-} -- | Turn a 'Get' into a 'Sink' and a 'Put' into a 'Source' -- These functions are built upno the Data.Conduit.Cereal.Internal functions with default -- implementations of 'ErrorHandler' and 'TerminationHandler' -- -- The default 'ErrorHandler' and 'TerminationHandler' both throw a 'GetException'. module Data.Conduit.Cereal ( GetException , sinkGet , conduitGet , conduitGet2 , sourcePut , conduitPut ) where import Control.Exception.Base import Control.Monad.Trans.Resource (MonadThrow, throwM) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Conduit (ConduitT, leftover, await, yield) import qualified Data.Conduit.List as CL import Data.Serialize hiding (get, put) import Data.Typeable import Data.Conduit.Cereal.Internal data GetException = GetException String deriving (Show, Typeable) instance Exception GetException -- | Run a 'Get' repeatedly on the input stream, producing an output stream of whatever the 'Get' outputs. conduitGet :: MonadThrow m => Get o -> ConduitT BS.ByteString o m () conduitGet = mkConduitGet errorHandler where errorHandler msg = throwM $ GetException msg {-# DEPRECATED conduitGet "Please switch to conduitGet2, see comment on that function" #-} -- | Convert a 'Get' into a 'Sink'. The 'Get' will be streamed bytes until it returns 'Done' or 'Fail'. -- -- If 'Get' succeed it will return the data read and unconsumed part of the input stream. -- If the 'Get' fails due to deserialization error or early termination of the input stream it raise an error. sinkGet :: MonadThrow m => Get r -> ConduitT BS.ByteString o m r sinkGet = mkSinkGet errorHandler terminationHandler where errorHandler msg = throwM $ GetException msg terminationHandler f = case f BS.empty of Fail msg _ -> throwM $ GetException msg Done r lo -> leftover lo >> return r Partial _ -> throwM $ GetException "Failed reading: Internal error: unexpected Partial." -- | Convert a 'Put' into a 'Source'. Runs in constant memory. sourcePut :: Monad m => Put -> ConduitT i BS.ByteString m () sourcePut put = CL.sourceList $ LBS.toChunks $ runPutLazy put -- | Run a 'Putter' repeatedly on the input stream, producing a concatenated 'ByteString' stream. conduitPut :: Monad m => Putter a -> ConduitT a BS.ByteString m () conduitPut p = CL.map $ runPut . p -- | Reapply @Get o@ to a stream of bytes as long as more data is available, -- and yielding each new value downstream. This has a few differences from -- @conduitGet@: -- -- * If there is a parse failure, the bytes consumed so far by this will not be -- returned as leftovers. The reason for this is that the only way to guarantee -- the leftovers will be returned correctly is to hold onto all consumed -- @ByteString@s, which leads to non-constant memory usage. -- -- * This function will properly terminate a @Get@ function at end of stream, -- see https://github.com/snoyberg/conduit/issues/246. -- -- * @conduitGet@ will pass empty @ByteString@s from the stream directly to -- cereal, which will trigger cereal to think that the stream has been closed. -- This breaks the normal abstraction in conduit of ignoring how data is -- chunked. In @conduitGet2@, all empty @ByteString@s are filtered out and not -- passed to cereal. -- -- * After @conduitGet2@ successfully returns, we are guaranteed that there is -- no data left to be consumed in the stream. -- -- @since 0.7.3 conduitGet2 :: MonadThrow m => Get o -> ConduitT BS.ByteString o m () conduitGet2 get = awaitNE >>= start where -- Get the next chunk of data, only returning an empty ByteString at the -- end of the stream. awaitNE = loop where loop = await >>= maybe (return BS.empty) check check bs | BS.null bs = loop | otherwise = return bs start bs | BS.null bs = return () | otherwise = result (runGetPartial get bs) result (Fail msg _) = throwM (GetException msg) -- This will feed an empty ByteString into f at end of stream, which is how -- we indicate to cereal that there is no data left. If we wanted to be -- more pedantic, we could ensure that cereal only ever consumes a single -- ByteString to avoid a loop, but that is the contract that cereal is -- giving us anyway. result (Partial f) = awaitNE >>= result . f result (Done x rest) = do yield x if BS.null rest then awaitNE >>= start else start rest cereal-conduit-0.8.0/Data/Conduit/Cereal/Internal.hs0000644000000000000000000000533213230046155020366 0ustar0000000000000000{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Rank2Types #-} module Data.Conduit.Cereal.Internal ( ConduitErrorHandler , SinkErrorHandler , SinkTerminationHandler , mkConduitGet , mkSinkGet ) where import Control.Monad (forever, when) import qualified Data.ByteString as BS import Data.Conduit (ConduitT, await, leftover, yield) import Data.Serialize hiding (get, put) -- | What should we do if the Get fails? type ConduitErrorHandler m o = String -> ConduitT BS.ByteString o m () type SinkErrorHandler m r = forall o. String -> ConduitT BS.ByteString o m r -- | What should we do if the stream is done before the Get is done? type SinkTerminationHandler m r = forall o. (BS.ByteString -> Result r) -> ConduitT BS.ByteString o m r -- | Construct a conduitGet with the specified 'ErrorHandler' mkConduitGet :: Monad m => ConduitErrorHandler m o -> Get o -> ConduitT BS.ByteString o m () mkConduitGet errorHandler get = consume True (runGetPartial get) [] BS.empty where pull f b s | BS.null s = await >>= maybe (when (not $ null b) (leftover $ BS.concat $ reverse b)) (pull f b) | otherwise = consume False f b s consume initial f b s = case f s of Fail msg _ -> do when (not $ null b) (leftover $ BS.concat $ reverse consumed) errorHandler msg Partial p -> pull p consumed BS.empty Done a s' -> case initial of -- this only works because the Get will either _always_ consume no input, or _never_ consume no input. True -> forever $ yield a False -> yield a >> pull (runGetPartial get) [] s' -- False -> yield a >> leftover s' >> mkConduitGet errorHandler get where consumed = s : b -- | Construct a sinkGet with the specified 'ErrorHandler' and 'TerminationHandler' mkSinkGet :: Monad m => SinkErrorHandler m r -> SinkTerminationHandler m r -> Get r -> ConduitT BS.ByteString o m r mkSinkGet errorHandler terminationHandler get = consume (runGetPartial get) [] BS.empty where pull f b s | BS.null s = await >>= \ x -> case x of Nothing -> when (not $ null b) (leftover $ BS.concat $ reverse b) >> terminationHandler f Just a -> pull f b a | otherwise = consume f b s consume f b s = case f s of Fail msg _ -> do when (not $ null b) (leftover $ BS.concat $ reverse consumed) errorHandler msg Partial p -> pull p consumed BS.empty Done r s' -> when (not $ BS.null s') (leftover s') >> return r where consumed = s : b cereal-conduit-0.8.0/Test/Main.hs0000644000000000000000000002715113230046155014747 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- Due to usage of conduitGet below import Control.Applicative (many, optional) import Control.Exception.Base import Test.HUnit import Data.Conduit (ConduitT, (.|), runConduit, yield, await, runConduitPure) import qualified Data.Conduit.List as CL import Data.Serialize import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as S8 import qualified Data.List as L import Data.Word import System.Exit --import Test.Framework.Providers.HUnit import Data.Conduit.Cereal import Data.Conduit.Cereal.Internal -- For the sake of these tests, all SomeExceptions are equal {- instance Eq SomeException where _ == _ = True -} twoItemGet :: Get Word8 twoItemGet = do x <- getWord8 y <- getWord8 return $ x + y threeItemGet :: Get Word8 threeItemGet = do x <- getWord8 y <- getWord8 z <- getWord8 return $ x + y + z putter :: Putter Char putter c = put x >> put (x + 1) where x = (fromIntegral $ (fromEnum c) - (fromEnum 'a') :: Word8) sinktest1 :: Test sinktest1 = TestCase (assertEqual "Handles starting with empty bytestring" (Right 1) (showLeft (runConduit ((CL.sourceList [BS.pack [], BS.pack [1]]) .| (sinkGet getWord8))))) sinktest2 :: Test sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle" (Right [1, 3]) (showLeft (runConduit (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [3]] .| (sinkGet (do x <- getWord8 y <- getWord8 return [x, y])))))) sinktest3 :: Test sinktest3 = TestCase (assertBool "Handles no data" (case runConduit $ return () .| sinkGet getWord8 of Right _ -> False Left _ -> True)) sinktest4 :: Test sinktest4 = TestCase (assertEqual "Consumes no data" (Right ()) (showLeft $ runConduit (CL.sourceList [BS.pack [1]] .| (sinkGet $ return ())))) sinktest5 :: Test sinktest5 = TestCase (assertEqual "Empty list" (Right ()) (showLeft $ runConduit ((CL.sourceList []) .| (sinkGet $ return ())))) sinktest6 :: Test sinktest6 = TestCase (assertEqual "Leftover input works" (Right (1, BS.pack [2, 3, 4, 5])) (showLeft $ runConduit ((CL.sourceList [BS.pack [1, 2, 3], BS.pack [4, 5]]) .| (do output <- sinkGet getWord8 output' <- CL.consume return (output, BS.concat output'))))) -- Current sink implementation will terminate the pipe in case of error. -- One may need non-terminating version like one defined below to get access to Leftovers sinkGetMaybe :: Get Word8 -> ConduitT BS.ByteString o (Either SomeException) Word8 sinkGetMaybe = mkSinkGet errorHandler terminationHandler where errorHandler _ = return 34 terminationHandler _ = return 114 sinktest7 :: Test sinktest7 = TestCase (assertEqual "Leftover input with failure works" (Right (34, BS.pack [1, 2])) (showLeft $ runConduit ((CL.sourceList [BS.pack [1, 2]]) .| (do output <- sinkGetMaybe (getWord8 >> fail "" :: Get Word8) output' <- CL.consume return (output, BS.concat output'))))) sinktest8 :: Test sinktest8 = TestCase (assertEqual "Leftover with incomplete input works" (Right (114, BS.singleton 1)) (showLeft $ runConduit ((CL.sourceList [BS.singleton 1]) .| (do output <- sinkGetMaybe twoItemGet output' <- CL.consume return (output, BS.concat output'))))) sinktest9 :: Test sinktest9 = TestCase (assertEqual "Properly terminate Partials" (Right [0..255]) (showLeft (runConduit (mapM_ (yield . BS.singleton) [0..255] .| sinkGet (many getWord8))))) conduittest1 :: Test conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring" (Right []) (showLeft (runConduit ((CL.sourceList [BS.pack [], BS.pack [1]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest2 :: Test conduittest2 = TestCase (assertEqual "Works when the get is split across items" (Right [3]) (showLeft (runConduit ((CL.sourceList [BS.pack [1], BS.pack [2]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest3 :: Test conduittest3 = TestCase (assertEqual "Works when empty bytestring in middle of get" (Right [3]) (showLeft (runConduit ((CL.sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest4 :: Test conduittest4 = TestCase (assertEqual "Works when empty bytestring at end of get" (Right [3]) (showLeft (runConduit ((CL.sourceList [BS.pack [1, 2], BS.pack []]) .| conduitGet twoItemGet .| CL.consume)))) conduittest5 :: Test conduittest5 = TestCase (assertEqual "Works when multiple gets are in an item" (Right [3, 7]) (showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3, 4]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest6 :: Test conduittest6 = TestCase (assertEqual "Works with leftovers" (Right [3]) (showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest7 :: Test conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists" (Right $ L.replicate c ()) (showLeft (runConduit ((CL.sourceList [BS.pack [1, 2, 3]]) .| conduitGet (return ()) .| CL.take c)))) conduittest8 :: Test conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists" (Right $ L.replicate c ()) (showLeft (runConduit ((CL.sourceList []) .| conduitGet (return ()) .| CL.take c)))) conduittest9 :: Test conduittest9 = TestCase (assertEqual "Works with two well-placed items" (Right [3, 7]) (showLeft (runConduit ((CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet twoItemGet .| CL.consume)))) conduittest10 :: Test conduittest10 = TestCase (assertBool "Failure works" (case runConduit $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet (getWord8 >> fail "omfg") .| CL.consume of Left _ -> True Right _ -> False)) conduittest11 :: Test conduittest11 = TestCase (assertBool "Immediate failure works" (case runConduit $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) .| conduitGet (fail "omfg") .| CL.consume of Left _ -> True Right _ -> False)) conduittest12 :: Test conduittest12 = TestCase (assertBool "Immediate failure with empty input works" (case runConduit $ (CL.sourceList []) .| conduitGet (fail "omfg") .| CL.consume of Left _ -> True Right _ -> False)) conduittest13 :: Test conduittest13 = TestCase (assertEqual "Leftover success conduit input works" (Right [Right 12, Right 7, Left (BS.pack [5])]) (showLeft (runConduit ((CL.sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) .| fancyConduit .| CL.consume)))) where fancyConduit = do conduitGet twoItemGet .| CL.map (\ x -> Right x) recurse where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse) showLeft :: Either SomeException a -> Either String a showLeft (Left e) = Left (show e) showLeft (Right x) = Right x conduittest14 :: Test conduittest14 = TestCase (assertEqual "Leftover coercing works" (Right [Left (BS.pack [10, 2])]) (showLeft (runConduit ((CL.sourceList [BS.pack [10], BS.pack [2]]) .| fancyConduit .| CL.consume)))) where fancyConduit = do conduitGet threeItemGet .| CL.map (\ x -> Right x) recurse where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse) conduittest15 :: Test conduittest15 = TestCase (assertEqual "Leftover premature end conduit input works" (Right ([], BS.singleton 1)) (showLeft (runConduit ((CL.sourceList [BS.singleton 1]) .| (do output <- (conduitGet twoItemGet) .| (CL.take 1) output' <- CL.consume return (output, BS.concat output')))))) conduittest16 :: Test conduittest16 = TestCase (assertEqual "Leftover failure conduit input works" (Right [Left $ BS.pack [10, 11], Left $ BS.singleton 2] :: Either String [Either BS.ByteString Word8]) (showLeft (runConduit ((CL.sourceList [BS.pack [10, 11], BS.pack [2]]) .| fancyConduit .| CL.consume)))) where fancyConduit = do mkConduitGet (const $ return ()) (getWord8 >> fail "asdf" :: Get Word8) .| CL.map (\ x -> Right x) recurse where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse) conduittest17 :: Test conduittest17 = TestCase (assertEqual "Leftover failure conduit with broken input works" (Right [Left $ BS.pack [10, 11], Left $ BS.singleton 12] :: Either String [Either BS.ByteString Word8]) (runConduit ((CL.sourceList [BS.singleton 10, BS.singleton 11, BS.singleton 12]) .| fancyConduit .| CL.consume))) where fancyConduit = do mkConduitGet (const $ return ()) (twoItemGet >> fail "asdf" :: Get Word8) .| CL.map (\ x -> Right x) recurse where recurse = await >>= maybe (return ()) (\ x -> yield (Left x) >> recurse) -- see https://github.com/snoyberg/conduit/issues/246 conduittest18 :: Test conduittest18 = TestCase $ assertEqual "Deals with Get that consumes everything" (Right [S8.pack "hello"]) ( showLeft $ runConduit $ (yield "hello" .| conduitGet2 slurp .| CL.consume)) slurp :: Get BS.ByteString slurp = loop id where loop front = do x <- remaining if x == 0 then do mbs <- optional $ lookAhead $ getBytes 1 case mbs of Nothing -> do let bs = BS.concat $ front [] if BS.null bs then fail "no bytes remaining" else return bs Just _ -> loop front else do bs <- getBytes $ fromIntegral x loop (front . (bs:)) puttest1 :: Test puttest1 = TestCase (assertEqual "conduitPut works" [BS.pack [0, 1]] (runConduitPure $ (CL.sourceList ['a']) .| (conduitPut putter) .| CL.consume)) puttest2 :: Test puttest2 = TestCase (assertEqual "multiple input conduitPut works" [BS.pack [0, 1], BS.pack [1, 2], BS.pack [2, 3]] (runConduitPure $ (CL.sourceList ['a', 'b', 'c']) .| (conduitPut putter) .| CL.consume)) puttest3 :: Test puttest3 = TestCase (assertEqual "empty input conduitPut works" [] (runConduitPure ((CL.sourceList []) .| (conduitPut putter) .| CL.consume))) sinktests :: Test sinktests = TestList [ sinktest1 , sinktest2 , sinktest3 , sinktest4 , sinktest5 , sinktest6 , sinktest7 , sinktest8 , sinktest9 ] conduittests :: Test conduittests = TestList [ conduittest1 , conduittest2 , conduittest3 , conduittest4 , conduittest5 , conduittest6 , conduittest7 , conduittest8 , conduittest9 , conduittest10 , conduittest11 , conduittest12 , conduittest13 , conduittest14 , conduittest15 , conduittest16 , conduittest17 , conduittest18 ] puttests :: Test puttests = TestList [ puttest1 , puttest2 , puttest3 ] hunittests :: Test hunittests = TestList [sinktests, conduittests, puttests] --tests = hUnitTestToTests hunittests main :: IO () main = do counts' <- runTestTT hunittests if errors counts' == 0 && failures counts' == 0 then exitSuccess else exitFailure cereal-conduit-0.8.0/LICENSE0000644000000000000000000000253212620000113013573 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2012, Myles C. Maxfield. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. cereal-conduit-0.8.0/Setup.lhs0000644000000000000000000000011612620000113014372 0ustar0000000000000000#! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain cereal-conduit-0.8.0/cereal-conduit.cabal0000644000000000000000000000272513230046155016472 0ustar0000000000000000name: cereal-conduit version: 0.8.0 license: BSD3 license-file: LICENSE author: Myles C. Maxfield maintainer: Michael Snoyman synopsis: Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits description: Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits. category: Conduit stability: Experimental cabal-version: >= 1.8 build-type: Simple homepage: https://github.com/snoyberg/conduit bug-reports: https://github.com/snoyberg/conduit/issues extra-source-files: README.md ChangeLog.md library build-depends: base >= 4.9 && < 5 , conduit >= 1.0.0 && < 1.4 , resourcet >= 0.4 && < 1.3 , cereal >= 0.4.0.0 && < 0.6 , bytestring , transformers >= 0.2.0.0 exposed-modules: Data.Conduit.Cereal , Data.Conduit.Cereal.Internal ghc-options: -Wall Test-Suite test-cereal-conduit type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: Test build-depends: base , conduit , cereal , cereal-conduit , bytestring --, test-framework-hunit , HUnit , mtl , transformers source-repository head type: git location: git://github.com/snoyberg/conduit.git cereal-conduit-0.8.0/README.md0000644000000000000000000000013012640674226014065 0ustar0000000000000000## cereal-conduit Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits. cereal-conduit-0.8.0/ChangeLog.md0000644000000000000000000000021613230046155014752 0ustar0000000000000000## 0.8.0 * Upgrade to conduit 1.3.0 ## 0.7.3 * Provide `conduitGet2` ## 0.7.2.5 * Support cereal 0.5 ## 0.7 * Upgrade to conduit 1.0.0