cereal-conduit-0.7/000755 000765 000024 00000000000 12114057401 015245 5ustar00litherumstaff000000 000000 cereal-conduit-0.7/cereal-conduit.cabal000644 000765 000024 00000002665 12114057401 021140 0ustar00litherumstaff000000 000000 name: cereal-conduit version: 0.7 license: BSD3 license-file: LICENSE author: Myles C. Maxfield maintainer: Myles C. Maxfield synopsis: Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits description: Turn Data.Serialize Gets and Puts into Sources, Sinks, and Conduits. . [0.7] Upgrade to conduit 1.0.0 category: Conduit stability: Experimental cabal-version: >= 1.8 build-type: Simple homepage: https://github.com/litherum/cereal-conduit bug-reports: https://github.com/litherum/cereal-conduit/issues library build-depends: base >= 4 && < 5 , conduit >= 1.0.0 && < 1.1 , cereal >= 0.3.1.0 , 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: Test/Main.hs build-depends: base , conduit , cereal , bytestring --, test-framework-hunit , HUnit , resourcet , mtl , transformers source-repository head type: git location: git://github.com/litherum/cereal-conduit.git cereal-conduit-0.7/Data/000755 000765 000024 00000000000 12114057401 016116 5ustar00litherumstaff000000 000000 cereal-conduit-0.7/LICENSE000644 000765 000024 00000002532 12114057401 016254 0ustar00litherumstaff000000 000000 The 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.7/Setup.lhs000644 000765 000024 00000000116 12114057401 017053 0ustar00litherumstaff000000 000000 #! /usr/bin/env runhaskell > import Distribution.Simple > main = defaultMain cereal-conduit-0.7/Test/000755 000765 000024 00000000000 12114057401 016164 5ustar00litherumstaff000000 000000 cereal-conduit-0.7/Test/Main.hs000644 000765 000024 00000024455 12114057401 017416 0ustar00litherumstaff000000 000000 {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE Rank2Types #-} import Control.Exception.Base import Control.Monad.Identity import Control.Monad.Trans.Resource import Test.HUnit import qualified Data.Conduit as C import qualified Data.Conduit.List as CL import Data.Serialize import qualified Data.ByteString as BS 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 a == b = 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) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8))) sinktest2 :: Test sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle" (Right [1, 3]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [3]]) C.$$ (sinkGet (do x <- getWord8 y <- getWord8 return [x, y])))) sinktest3 :: Test sinktest3 = TestCase (assertBool "Handles no data" (case runIdentity $ runExceptionT $ (CL.sourceList []) C.$$ (sinkGet getWord8) of Right _ -> False Left _ -> True)) sinktest4 :: Test sinktest4 = TestCase (assertEqual "Consumes no data" (Right ()) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ()))) sinktest5 :: Test sinktest5 = TestCase (assertEqual "Empty list" (Right ()) (runIdentity $ runExceptionT $ (CL.sourceList []) C.$$ (sinkGet $ return ()))) sinktest6 :: Test sinktest6 = TestCase (assertEqual "Leftover input works" (Right (1, BS.pack [2, 3, 4, 5])) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3], BS.pack [4, 5]]) C.$$ (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 -> C.Consumer BS.ByteString (ExceptionT Identity) 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])) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2]]) C.$$ (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)) (runIdentity $ runExceptionT $ (CL.sourceList [BS.singleton 1]) C.$$ (do output <- sinkGetMaybe twoItemGet output' <- CL.consume return (output, BS.concat output')))) conduittest1 :: Test conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring" (Right []) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [], BS.pack [1]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest2 :: Test conduittest2 = TestCase (assertEqual "Works when the get is split across items" (Right [3]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest3 :: Test conduittest3 = TestCase (assertEqual "Works when empty bytestring in middle of get" (Right [3]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest4 :: Test conduittest4 = TestCase (assertEqual "Works when empty bytestring at end of get" (Right [3]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack []]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest5 :: Test conduittest5 = TestCase (assertEqual "Works when multiple gets are in an item" (Right [3, 7]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest6 :: Test conduittest6 = TestCase (assertEqual "Works with leftovers" (Right [3]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest7 :: Test conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists" (Right $ L.replicate c ()) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet (return ()) C.$$ CL.take c)) conduittest8 :: Test conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists" (Right $ L.replicate c ()) (runIdentity $ runExceptionT $ (CL.sourceList []) C.$= conduitGet (return ()) C.$$ CL.take c)) conduittest9 :: Test conduittest9 = let c = 10 in TestCase (assertEqual "Works with two well-placed items" (Right [3, 7]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest10 :: Test conduittest10 = TestCase (assertBool "Failure works" (case runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (getWord8 >> fail "omfg") C.$$ CL.consume of Left _ -> True Right _ -> False)) conduittest11 :: Test conduittest11 = TestCase (assertBool "Immediate failure works" (case runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [1, 2], BS.pack [3, 4]]) C.$= conduitGet (fail "omfg") C.$$ CL.consume of Left _ -> True Right _ -> False)) conduittest12 :: Test conduittest12 = TestCase (assertBool "Immediate failure with empty input works" (case runIdentity $ runExceptionT $ (CL.sourceList []) C.$= conduitGet (fail "omfg") C.$$ 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])]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) C.$= fancyConduit C.$$ CL.consume)) where fancyConduit = do conduitGet twoItemGet C.=$= CL.map (\ x -> Right x) recurse where recurse = C.await >>= maybe (return ()) (\ x -> C.yield (Left x) >> recurse) conduittest14 :: Test conduittest14 = TestCase (assertEqual "Leftover coercing works" (Right [Left (BS.pack [10, 2])]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [10], BS.pack [2]]) C.$= fancyConduit C.$$ CL.consume)) where fancyConduit = do conduitGet threeItemGet C.=$= CL.map (\ x -> Right x) recurse where recurse = C.await >>= maybe (return ()) (\ x -> C.yield (Left x) >> recurse) conduittest15 :: Test conduittest15 = TestCase (assertEqual "Leftover premature end conduit input works" (Right ([], BS.singleton 1)) (runIdentity $ runExceptionT $ (CL.sourceList [BS.singleton 1]) C.$$ (do output <- (conduitGet twoItemGet) C.=$ (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]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.pack [10, 11], BS.pack [2]]) C.$= fancyConduit C.$$ CL.consume)) where fancyConduit = do mkConduitGet (const $ return ()) (getWord8 >> fail "asdf" :: Get Word8) C.=$= CL.map (\ x -> Right x) recurse where recurse = C.await >>= maybe (return ()) (\ x -> C.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]) (runIdentity $ runExceptionT $ (CL.sourceList [BS.singleton 10, BS.singleton 11, BS.singleton 12]) C.$= fancyConduit C.$$ CL.consume)) where fancyConduit = do mkConduitGet (const $ return ()) (twoItemGet >> fail "asdf" :: Get Word8) C.=$= CL.map (\ x -> Right x) recurse where recurse = C.await >>= maybe (return ()) (\ x -> C.yield (Left x) >> recurse) puttest1 :: Test puttest1 = TestCase (assertEqual "conduitPut works" [BS.pack [0, 1]] (runIdentity $ (CL.sourceList ['a']) C.$= (conduitPut putter) C.$$ CL.consume)) puttest2 :: Test puttest2 = TestCase (assertEqual "multiple input conduitPut works" [BS.pack [0, 1], BS.pack [1, 2], BS.pack [2, 3]] (runIdentity $ (CL.sourceList ['a', 'b', 'c']) C.$= (conduitPut putter) C.$$ CL.consume)) puttest3 :: Test puttest3 = TestCase (assertEqual "empty input conduitPut works" [] (runIdentity $ (CL.sourceList []) C.$= (conduitPut putter) C.$$ CL.consume)) sinktests = TestList [ sinktest1 , sinktest2 , sinktest3 , sinktest4 , sinktest5 , sinktest6 , sinktest7 , sinktest8 ] conduittests = TestList [ conduittest1 , conduittest2 , conduittest3 , conduittest4 , conduittest5 , conduittest6 , conduittest7 , conduittest8 , conduittest9 , conduittest10 , conduittest11 , conduittest12 , conduittest13 , conduittest14 , conduittest15 , conduittest16 , conduittest17 ] puttests = TestList [ puttest1 , puttest2 , puttest3 ] hunittests = TestList [sinktests, conduittests, puttests] --tests = hUnitTestToTests hunittests main = do counts <- runTestTT hunittests if errors counts == 0 && failures counts == 0 then exitSuccess else exitFailure cereal-conduit-0.7/Data/Conduit/000755 000765 000024 00000000000 12114057401 017523 5ustar00litherumstaff000000 000000 cereal-conduit-0.7/Data/Conduit/Cereal/000755 000765 000024 00000000000 12114057401 020716 5ustar00litherumstaff000000 000000 cereal-conduit-0.7/Data/Conduit/Cereal.hs000644 000765 000024 00000004745 12114057401 021264 0ustar00litherumstaff000000 000000 {-# 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 , sourcePut , conduitPut ) where import Control.Exception.Base import Control.Monad.Trans.Class (MonadTrans, lift) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.Conduit as C 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 :: C.MonadThrow m => Get o -> C.Conduit BS.ByteString m o conduitGet = mkConduitGet errorHandler where errorHandler msg = pipeError $ GetException msg -- | 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 :: C.MonadThrow m => Get r -> C.Consumer BS.ByteString m r sinkGet = mkSinkGet errorHandler terminationHandler where errorHandler msg = pipeError $ GetException msg terminationHandler f = let Fail msg = f BS.empty in pipeError $ GetException msg pipeError :: (C.MonadThrow m, MonadTrans t, Exception e) => e -> t m a pipeError e = lift $ C.monadThrow e -- | Convert a 'Put' into a 'Source'. Runs in constant memory. sourcePut :: Monad m => Put -> C.Producer m BS.ByteString 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 -> C.Conduit a m BS.ByteString conduitPut p = CL.map $ runPut . p cereal-conduit-0.7/Data/Conduit/Cereal/Internal.hs000644 000765 000024 00000005270 12114057401 023032 0ustar00litherumstaff000000 000000 {-# 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 qualified Data.Conduit as C import Data.Serialize hiding (get, put) -- | What should we do if the Get fails? type ConduitErrorHandler m o = String -> C.Conduit BS.ByteString m o type SinkErrorHandler m r = String -> C.Consumer BS.ByteString m r -- | What should we do if the stream is done before the Get is done? type SinkTerminationHandler m r = (BS.ByteString -> Result r) -> C.Consumer BS.ByteString m r -- | Construct a conduitGet with the specified 'ErrorHandler' mkConduitGet :: Monad m => ConduitErrorHandler m o -> Get o -> C.Conduit BS.ByteString m o mkConduitGet errorHandler get = consume True (runGetPartial get) [] BS.empty where pull f b s | BS.null s = C.await >>= maybe (when (not $ null b) (C.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) (C.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 $ C.yield a False -> C.yield a >> pull (runGetPartial get) [] s' -- False -> C.yield a >> C.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 -> C.Consumer BS.ByteString m r mkSinkGet errorHandler terminationHandler get = consume (runGetPartial get) [] BS.empty where pull f b s | BS.null s = C.await >>= \ x -> case x of Nothing -> when (not $ null b) (C.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) (C.leftover $ BS.concat $ reverse consumed) errorHandler msg Partial p -> pull p consumed BS.empty Done r s' -> when (not $ BS.null s') (C.leftover s') >> return r where consumed = s : b