diff --git a/Data/Conduit/Serialization/Binary.hs b/Data/Conduit/Serialization/Binary.hs --- a/Data/Conduit/Serialization/Binary.hs +++ b/Data/Conduit/Serialization/Binary.hs @@ -16,6 +16,7 @@ import Data.Binary.Get import Data.Binary.Put import Data.ByteString (ByteString) +import Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Conduit @@ -24,25 +25,29 @@ data ParseError = ParseError - { uncomsumed :: ByteString -- ^ uncomsumed data - , offset :: ByteOffset -- ^ current offset - , content :: String -- ^ error content + { unconsumed :: ByteString + -- ^ Data left unconsumed in single stream input value. + + , offset :: ByteOffset + -- ^ Number of bytes consumed from single stream input value. + + , content :: String -- ^ Error content. } deriving (Show, Typeable) instance Exception ParseError --- | Runs default 'Decoder' repeadetly on a input stream +-- | Runs default 'Decoder' repeatedly on a input stream. conduitDecode :: (Binary b, MonadThrow m) => Conduit ByteString m b conduitDecode = conduitGet get --- | Runs default encoder on a input stream +-- | Runs default encoder on a input stream. conduitEncode :: (Binary b, MonadThrow m) => Conduit b m ByteString conduitEncode = CL.map put =$= conduitPut --- | Runs getter repeadetelly on a input stream -conduitGet :: (Binary b, MonadThrow m) => Get b -> Conduit ByteString m b +-- | Runs getter repeatedly on a input stream. +conduitGet :: MonadThrow m => Get b -> Conduit ByteString m b conduitGet g = start - where + where start = do mx <- await case mx of Nothing -> return () @@ -50,25 +55,27 @@ conduit p = await >>= go . flip (maybe pushEndOfInput (flip pushChunk)) p where go (Done bs _ v) = do yield v - go (runGetIncremental get `pushChunk` bs) + if BS.null bs + then start + else go (runGetIncremental g `pushChunk` bs) go (Fail u o e) = monadThrow (ParseError u o e) - go (Partial _) = start + go (Partial n) = await >>= (go . n) --- | Runs putter repeadelty on a input stream +-- | Runs putter repeatedly on a input stream. conduitPut :: MonadThrow m => Conduit Put m ByteString -conduitPut = conduit - where +conduitPut = conduit + where conduit = do mx <- await case mx of Nothing -> return () Just x -> do sourcePut x $$ CL.mapM_ yield conduit --- | Create stream of strict bytestring from 'Put' value +-- | Create stream of strict bytestrings from 'Put' value. sourcePut :: (MonadThrow m) => Put -> Producer m ByteString sourcePut = CL.sourceList . LBS.toChunks . runPut --- | Decode message from input stream +-- | Decode message from input stream. sinkGet :: (Binary b, MonadThrow m) => Get b -> Consumer ByteString m b sinkGet f = sink (runGetIncremental f) where diff --git a/binary-conduit.cabal b/binary-conduit.cabal --- a/binary-conduit.cabal +++ b/binary-conduit.cabal @@ -1,5 +1,5 @@ name: binary-conduit -version: 1.0 +version: 1.1.0 synopsis: data serialization/deserialization conduit library description: The binary-conduit package. Allow binary serialization using iterative conduit interface. @@ -28,7 +28,7 @@ type: exitcode-stdio-1.0 main-is: Main.hs hs-source-dirs: test/ - build-depends: base, QuickCheck, quickcheck-assertions, conduit-binary, + build-depends: base, QuickCheck, quickcheck-assertions, binary-conduit, hspec, conduit, binary, bytestring source-repository head diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ +import Control.Monad (forM_, when) import Data.Binary import Data.Binary.Put -import Data.ByteString +import Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import Data.Conduit import qualified Data.Conduit.List as CL @@ -42,11 +43,59 @@ dec :: (Binary a, MonadThrow m) => a -> Conduit ByteString m a dec _ = conduitDecode -main = hspec $ describe "conduitEncode =$= conduitDecode == id" $ do - prop "int" $ (prop_eq :: [Int] -> Property) - prop "string" $ (prop_eq :: [String] -> Property) - prop "maybe int" $ (prop_eq :: [Maybe Int] -> Property) - prop "either int string" $ (prop_eq :: [Either Int String] -> Property) - prop "ab" $ (prop_sink :: (Int,Int) -> Property) - prop "ab" $ (prop_sink :: (String,String) -> Property) - +prop_part2 :: [Int] -> Property +prop_part2 xs = monadicIO $ do + let m = BS.concat . Prelude.concatMap (LBS.toChunks . runPut . put) $ xs + when (Prelude.length xs>0) $ do + forM_ [0..BS.length m] $ \l -> do + let (l1,l2) = BS.splitAt l m + ma <- runExceptionT $ CL.sourceList [l1,l2] + $= conduitDecode + $$ CL.consume + case ma of + Left _ -> fail "exception in conduit" + Right a -> stop (xs ?== a) + +prop_part3 :: [Int] -> Property +prop_part3 xs = monadicIO $ do + let m = BS.concat . Prelude.concatMap (LBS.toChunks . runPut . put) $ xs + when (Prelude.length xs>0) $ do + forM_ [1..BS.length m] $ \l -> do + let (l1,l2) = BS.splitAt l m + when (BS.length l2 > 0) $ do + forM_ [1..BS.length l2] $ \l' -> do + let (l2_1,l2_2) = BS.splitAt l' l2 + ma <- runExceptionT $ CL.sourceList [l1,l2_1,l2_2] + $= conduitDecode + $$ CL.consume + case ma of + Left _ -> fail "exception in conduit" + Right a -> stop $ xs ?== a + +main = hspec $ do + describe "QC properties: conduitEncode =$= conduitDecode == id" $ do + prop "int" $ (prop_eq :: [Int] -> Property) + prop "string" $ (prop_eq :: [String] -> Property) + prop "maybe int" $ (prop_eq :: [Maybe Int] -> Property) + prop "either int string" $ (prop_eq :: [Either Int String] -> Property) + prop "(Int,Int)" $ (prop_sink :: (Int,Int) -> Property) + prop "(String,String)" $ (prop_sink :: (String,String) -> Property) + describe "QC properties partial lists" $ do + prop "break data in 2 parts" $ (prop_part2) + prop "break data in 3 parts" $ (prop_part3) + describe "HUnit properties:" $ do + it "decodes message splitted to chunks" $ do + let i = -32 + l = runPut (put (i::Int)) + (l1,l2) = LBS.splitAt (LBS.length l `div` 2) l + t = BS.concat . LBS.toChunks + x <- CL.sourceList [t l1,t l2] $= conduitDecode $$ CL.consume + x `shouldBe` [i] + it "decodes message with list of values inside" $ do + let is = [-32,45::Int] + ls = BS.concat . Prelude.concatMap (LBS.toChunks .runPut . put) $ is + (ls1,ls2) = BS.splitAt ((BS.length ls `div` 2) +1) ls + x <- CL.sourceList [ls,ls] $= conduitDecode $$ CL.consume + x' <- CL.sourceList [ls1,ls2] $= conduitDecode $$ CL.consume + x `shouldBe` is++is + x' `shouldBe` is