cereal-conduit 0.0.5 → 0.0.6
raw patch · 3 files changed
+192/−82 lines, 3 filesdep +exception-transformersdep +transformersdep +voiddep ~base
Dependencies added: exception-transformers, transformers, void
Dependency ranges changed: base
Files
- Data/Conduit/Cereal.hs +45/−54
- Test/CerealConduit.hs +143/−27
- cereal-conduit.cabal +4/−1
Data/Conduit/Cereal.hs view
@@ -1,54 +1,45 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | Turn a 'Get' into a 'Sink' and a 'Put' into a 'Source'--module Data.Conduit.Cereal (sinkGet, conduitGet, sourcePut) where--import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Conduit as C-import Data.Conduit.List (sourceList)-import Data.Serialize hiding (get, put)-import Data.Typeable-import Control.Exception--data GetException = GetException String- deriving (Show, Typeable)--instance Exception GetException---- | 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 it will return message describing the error. -sinkGet :: Monad m => Get output -> C.Sink BS.ByteString m (Either String output)-sinkGet get = consume (runGetPartial get) BS.empty- where push f input- | BS.null input = C.NeedInput (push f) (close f)- | otherwise = consume f input- consume f s = case f s of- Fail msg -> C.Done (streamToMaybe s) (Left msg)- Partial f' -> C.NeedInput (push f') (close f')- Done r s' -> C.Done (streamToMaybe s') (Right r)- close f = let Fail r = f BS.empty in C.Done Nothing (Left r)---- | Run a 'Get' repeatedly on the input stream, producing an output stream of whatever the 'Get' outputs.-conduitGet :: Monad m => Get output -> C.Conduit BS.ByteString m output-conduitGet get = consume (runGetPartial get) BS.empty BS.empty- where push f b input- | BS.null input = C.NeedInput (push f b) (C.Done (streamToMaybe b) ())- | otherwise = consume f b input- consume f b s = case f s of- Fail msg -> throw $ GetException msg- Partial f' -> C.NeedInput (push f' consumed) $ C.Done (streamToMaybe consumed) ()- Done r s' -> C.HaveOutput (push (runGetPartial get) BS.empty s') (return ()) r- where consumed = BS.concat [b, s]--streamToMaybe :: BS.ByteString -> Maybe BS.ByteString-streamToMaybe s = if BS.null s- then Nothing- else Just s---- | Convert a 'Put' into a 'Source'. Runs in constant memory.-sourcePut :: Monad m => Put -> C.Source m BS.ByteString-sourcePut put = sourceList $ LBS.toChunks $ runPutLazy put+{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | 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) where + +import Control.Monad.Exception +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Conduit as C +import Data.Conduit.Cereal.Internal +import Data.Conduit.List (sourceList) +import Data.Serialize hiding (get, put) +import Data.Typeable + +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 :: MonadException m => Get output -> C.Conduit BS.ByteString m output +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 :: MonadException m => Get r -> C.Sink 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 :: (MonadException m, Exception e) => e -> C.Pipe i o m r +pipeError e = C.PipeM (throw e) undefined + +-- | Convert a 'Put' into a 'Source'. Runs in constant memory. +sourcePut :: Monad m => Put -> C.Source m BS.ByteString +sourcePut put = sourceList $ LBS.toChunks $ runPutLazy put
Test/CerealConduit.hs view
@@ -1,83 +1,199 @@-module Test.CerealConduit (tests) where+{-# LANGUAGE FlexibleContexts, RankNTypes #-} +module Test.CerealConduit where+ import Control.Monad.Identity+import Control.Monad.Exception+import Control.Monad.Error+import Control.Monad.Trans.Maybe import Test.HUnit import qualified Data.Conduit as C import Data.Conduit.Cereal-import Data.Conduit.List+import Data.Conduit.Cereal.Internal +import Data.Conduit.List as CL import Data.Serialize import qualified Data.ByteString as BS-import Test.Framework.Providers.HUnit+--import Test.Framework.Providers.HUnit import System.Exit import Data.Word+import qualified Data.List as L+import Prelude hiding (take) +-- 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+ sinktest1 :: Test sinktest1 = TestCase (assertEqual "Handles starting with empty bytestring" (Right 1)- (runIdentity $ (sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8)))+ (runIdentity $ runExceptionT $ (sourceList [BS.pack [], BS.pack [1]]) C.$$ (sinkGet getWord8))) sinktest2 :: Test sinktest2 = TestCase (assertEqual "Handles empty bytestring in middle" (Right [1, 3])- (runIdentity $ (sourceList [BS.pack [1], BS.pack [], BS.pack [3]]) C.$$ (sinkGet (do+ (runIdentity $ runExceptionT $ (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 $ (sourceList []) C.$$ (sinkGet getWord8)) of+ (case runIdentity $ runExceptionT $ (sourceList []) C.$$ (sinkGet getWord8) of Right _ -> False Left _ -> True)) sinktest4 :: Test sinktest4 = TestCase (assertEqual "Consumes no data" (Right ())- (runIdentity $ (sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ())))+ (runIdentity $ runExceptionT $ (sourceList [BS.pack [1]]) C.$$ (sinkGet $ return ()))) -twoItemGet :: Get Word8-twoItemGet = do- x <- getWord8- y <- getWord8- return $ x + y+sinktest5 :: Test+sinktest5 = TestCase (assertEqual "Empty list"+ (Right ())+ (runIdentity $ runExceptionT $ (sourceList []) C.$$ (sinkGet $ return ()))) +sinktest6 :: Test+sinktest6 = TestCase (assertEqual "Leftover input works"+ (Right (1, BS.pack [2, 3, 4, 5]))+ (runIdentity $ runExceptionT $ (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 :: Monad m => Get output -> C.Sink BS.ByteString m (Maybe output)+sinkGetMaybe = mkSinkGet errorHandler terminationHandler . fmap Just+ where errorHandler msg s = C.Done s Nothing+ terminationHandler f s = C.Done s Nothing++sinktest7 :: Test+sinktest7 = TestCase (assertBool "Leftover input with failure works"+ (case runIdentity $ do+ (sourceList [BS.pack [1, 2]]) C.$$ (do+ output <- sinkGetMaybe (getWord8 >> fail "" :: Get Word8)+ output' <- CL.consume+ return (output, BS.concat output')) of+ (Nothing, bs) -> bs == BS.pack [1, 2]+ otherwise -> False))+ conduittest1 :: Test conduittest1 = TestCase (assertEqual "Handles starting with empty bytestring"- []- (runIdentity $ (sourceList [BS.pack [], BS.pack [1]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [])+ (runIdentity $ runExceptionT $ (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"- [3]- (runIdentity $ (sourceList [BS.pack [1], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [3])+ (runIdentity $ runExceptionT $ (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"- [3]- (runIdentity $ (sourceList [BS.pack [1], BS.pack [], BS.pack [2]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [3])+ (runIdentity $ runExceptionT $ (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"- [3, 7]- (runIdentity $ (sourceList [BS.pack [1, 2], BS.pack [], BS.pack [3, 4]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [3])+ (runIdentity $ runExceptionT $ (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"- [3, 7]- (runIdentity $ (sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [3, 7])+ (runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3, 4]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) conduittest6 :: Test conduittest6 = TestCase (assertEqual "Works with leftovers"- [3]- (runIdentity $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ consume))+ (Right [3])+ (runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet twoItemGet C.$$ CL.consume)) -sinktests = TestList [sinktest1, sinktest2, sinktest3, sinktest4]+conduittest7 :: Test+conduittest7 = let c = 10 in TestCase (assertEqual "Works with infinite lists"+ (Right $ L.replicate c ())+ (runIdentity $ runExceptionT $ (sourceList [BS.pack [1, 2, 3]]) C.$= conduitGet (return ()) C.$$ take c)) -conduittests = TestList [conduittest1, conduittest2, conduittest3, conduittest4, conduittest5, conduittest6]+conduittest8 :: Test+conduittest8 = let c = 10 in TestCase (assertEqual "Works with empty source and infinite lists"+ (Right $ L.replicate c ())+ (runIdentity $ runExceptionT $ (sourceList []) C.$= conduitGet (return ()) C.$$ take c)) +conduittest9 :: Test+conduittest9 = let c = 10 in TestCase (assertEqual "Works with two well-placed items"+ (Right [3, 7])+ (runIdentity $ runExceptionT $ (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 $ (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 $ (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 $ (sourceList []) C.$= conduitGet (fail "omfg") C.$$ CL.consume of+ Left _ -> True+ Right _ -> False))++{-+-- This test CAN'T work because of the type of HaveOutput.+conduittest13 :: Test+conduittest13 = TestCase (assertEqual "Leftover success conduit input works"+ ([12], BS.pack [3, 4, 5])+ (runIdentity $ (sourceList [BS.pack [10, 2, 3], BS.pack [4, 5]]) C.$$ (do+ output <- (conduitGet twoItemGet) C.=$ (CL.take 1)+ output' <- CL.consume+ return (output, BS.concat output'))))+-}++conduittest14 :: Test+conduittest14 = TestCase (assertEqual "Leftover failure conduit input works"+ (Right ([], BS.singleton 1))+ (runIdentity $ runExceptionT $ (sourceList [BS.singleton 1]) C.$$ (do+ output <- (conduitGet twoItemGet) C.=$ (CL.take 1)+ output' <- CL.consume+ return (output, BS.concat output'))))++sinktests = TestList [ sinktest1+ , sinktest2+ , sinktest3+ , sinktest4+ , sinktest5+ , sinktest6+ , sinktest7+ ]++conduittests = TestList [ conduittest1+ , conduittest2+ , conduittest3+ , conduittest4+ , conduittest5+ , conduittest6+ , conduittest7+ , conduittest8+ , conduittest9+ , conduittest10+ , conduittest11+ , conduittest12+ --, conduittest13+ , conduittest14+ ]+ hunittests = TestList [sinktests, conduittests] -tests = hUnitTestToTests hunittests+--tests = hUnitTestToTests hunittests main = do counts <- runTestTT hunittests
cereal-conduit.cabal view
@@ -1,5 +1,5 @@ name: cereal-conduit-version: 0.0.5+version: 0.0.6 license: BSD3 license-file: LICENSE author: Myles C. Maxfield <myles.maxfield@gmail.com>@@ -18,6 +18,8 @@ , cereal >= 0.3.1.0 , mtl , bytestring+ , void+ , exception-transformers exposed-modules: Data.Conduit.Cereal ghc-options: -Wall @@ -31,6 +33,7 @@ , bytestring , test-framework-hunit , HUnit+ , transformers source-repository head type: git