lz4-frame-conduit 0.1.0.0 → 0.1.0.1
raw patch · 4 files changed
+58/−19 lines, 4 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- CHANGELOG.md +8/−0
- lz4-frame-conduit.cabal +2/−1
- src/Codec/Compression/LZ4/Conduit.hsc +20/−18
- test/Main.hs +28/−0
+ CHANGELOG.md view
@@ -0,0 +1,8 @@+# 0.1.0.1++* Fix incorrect compression logic (compressing input Bytes repeatedly).+ See the [commit](https://github.com/nh2/lz4-frame-conduit/commit/75ecc64c8f5450f377b79ae0352d074b3a3adec8) for details.++# 0.1.0.0++Initial release.
lz4-frame-conduit.cabal view
@@ -1,5 +1,5 @@ name: lz4-frame-conduit-version: 0.1.0.0+version: 0.1.0.1 synopsis: Conduit implementing the official LZ4 frame streaming format description: Conduit implementing the official LZ4 frame streaming format.@@ -16,6 +16,7 @@ cabal-version: >=1.10 extra-source-files: README.md+ CHANGELOG.md lz4/lib/lz4.c lz4/lib/lz4.h lz4/lib/lz4frame.c
src/Codec/Compression/LZ4/Conduit.hsc view
@@ -491,34 +491,36 @@ Just bs -> do let bss = bsChunksOf (fromIntegral bsInChunkSize) bs- newRemainingCapacity <- foldM (\cap subBs -> loopSingleBs cap subBs) remainingCapacity bss+ newRemainingCapacity <- foldM compressSingleBs remainingCapacity bss loop newRemainingCapacity - loopSingleBs :: CSize -> ByteString -> ConduitM i ByteString m CSize- loopSingleBs remainingCapacity bs+ compressSingleBs :: CSize -> ByteString -> ConduitM i ByteString m CSize+ compressSingleBs remainingCapacity bs | remainingCapacity < compressBound = do -- Not enough space in outBuf to guarantee that the next call -- to `lz4fCompressUpdate` will fit; so yield (a copy of) the -- current outBuf, then it's all free again.- outBs <- withOutBuf $ \buf -> packCStringLen (buf, fromIntegral (outBufferSize - remainingCapacity))- yield outBs- loopSingleBs outBufferSize bs+ yieldOutBuf (outBufferSize - remainingCapacity)+ compressSingleBsFitting outBufferSize bs | otherwise = do- written <- liftIO $ unsafeUseAsCStringLen bs $ \(bsPtr, bsLen) -> do- let bsLenSize = fromIntegral bsLen+ compressSingleBsFitting remainingCapacity bs - -- See note [Single call to LZ4F_compressUpdate() can create multiple blocks]- let offset = fromIntegral $ outBufferSize - remainingCapacity- withOutBuf $ \buf -> lz4fCompressUpdate ctx (buf `plusPtr` offset) remainingCapacity bsPtr bsLenSize+ compressSingleBsFitting :: CSize -> ByteString -> ConduitM i ByteString m CSize+ compressSingleBsFitting remainingCapacity bs = do+ when (remainingCapacity < compressBound) $ error "precondition violated" - let newRemainingCapacity = remainingCapacity - written- -- TODO assert newRemainingCapacity > 0- let writtenInt = fromIntegral written+ written <- liftIO $ unsafeUseAsCStringLen bs $ \(bsPtr, bsLen) -> do+ let bsLenSize = fromIntegral bsLen - if- | written == 0 -> return newRemainingCapacity- | writtenInt < BS.length bs -> loopSingleBs newRemainingCapacity (BS.drop writtenInt bs)- | otherwise -> return newRemainingCapacity+ -- See note [Single call to LZ4F_compressUpdate() can create multiple blocks]+ let offset = fromIntegral $ outBufferSize - remainingCapacity+ withOutBuf $ \buf -> lz4fCompressUpdate ctx (buf `plusPtr` offset) remainingCapacity bsPtr bsLenSize++ when (written > remainingCapacity) $ do -- sanity check+ error $ "lz4fCompressUpdate wrote past buffer: " ++ show (written, remainingCapacity)++ let newRemainingCapacity = remainingCapacity - written+ return newRemainingCapacity loop (outBufferSize - headerSize)
test/Main.hs view
@@ -3,6 +3,7 @@ module Main (main) where import Codec.Compression.LZ4.Conduit (compress, decompress, bsChunksOf)+import Control.Monad (when) import Control.Monad.IO.Unlift (MonadUnliftIO) import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Data.ByteString (ByteString)@@ -10,6 +11,7 @@ import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 import Data.Conduit+import Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import qualified Data.Conduit.Process as CP import Data.List (intersperse)@@ -33,6 +35,10 @@ main :: IO () main = do+ -- Big memory tests are disabled by default to be kind to packagers and CI.+ let skipBigmemTests = True+ skipBigmemTest = when skipBigmemTests $ pendingWith "skipped by default due to big RAM requirement"+ let prepare :: [BSL.ByteString] -> [ByteString] prepare strings = BSL.toChunks $ BSL.concat $ intersperse " " $ ["BEGIN"] ++ strings ++ ["END"] @@ -57,6 +63,17 @@ actual <- runCompressToLZ4 (CL.sourceList strings) actual `shouldBe` (BS.concat strings) + it "compresses 1MB ByteString" $ do+ let bs = BS.replicate 100000 42+ actual <- runCompressToLZ4 (CB.sourceLbs $ BSL.fromStrict bs)+ actual `shouldBe` bs++ it "compresses 5GiB ByteString" $ do -- more than 32-bit many Bytes+ skipBigmemTest+ let bs = BS.replicate (5 * 1024*1024*1024) 42+ actual <- runCompressToLZ4 (CB.sourceLbs $ BSL.fromStrict bs)+ actual `shouldBe` bs+ describe "Decompression" $ do it "decompresses simple string" $ do let string = "hellohellohellohello"@@ -72,6 +89,17 @@ let strings = prepare $ replicate 100000 "hello" actual <- runLZ4ToDecompress (CL.sourceList strings) actual `shouldBe` (BS.concat strings)++ it "decompresses 1MB ByteString" $ do+ let bs = BS.replicate 100000 42+ actual <- runLZ4ToDecompress (CB.sourceLbs $ BSL.fromStrict bs)+ actual `shouldBe` bs++ it "decompresses 5GiB ByteString" $ do -- more than 32-bit many Bytes+ skipBigmemTest+ let bs = BS.replicate (5 * 1024*1024*1024) 42+ actual <- runLZ4ToDecompress (CB.sourceLbs $ BSL.fromStrict bs)+ actual `shouldBe` bs describe "Identity" $ do modifyMaxSize (const 10000) $ it "compress and decompress arbitrary strings"$