diff --git a/Codec/Compression/Zlib/Internal.hs b/Codec/Compression/Zlib/Internal.hs --- a/Codec/Compression/Zlib/Internal.hs +++ b/Codec/Compression/Zlib/Internal.hs @@ -83,6 +83,7 @@ import qualified Data.ByteString.Lazy.Internal as L import qualified Data.ByteString as S import qualified Data.ByteString.Internal as S +import Data.Word (Word8) import qualified Codec.Compression.Zlib.Stream as Stream import Codec.Compression.Zlib.Stream (Stream) @@ -105,7 +106,7 @@ compressStrategy :: !Stream.CompressionStrategy, compressBufferSize :: !Int, compressDictionary :: Maybe S.ByteString -} +} deriving Show -- | The full set of parameters for decompression. The defaults are -- 'defaultDecompressParams'. @@ -129,8 +130,9 @@ data DecompressParams = DecompressParams { decompressWindowBits :: !Stream.WindowBits, decompressBufferSize :: !Int, - decompressDictionary :: Maybe S.ByteString -} + decompressDictionary :: Maybe S.ByteString, + decompressAllMembers :: Bool +} deriving Show -- | The default set of parameters for compression. This is typically used with -- the @compressWith@ function with specific parameters overridden. @@ -153,7 +155,8 @@ defaultDecompressParams = DecompressParams { decompressWindowBits = Stream.defaultWindowBits, decompressBufferSize = defaultDecompressBufferSize, - decompressDictionary = Nothing + decompressDictionary = Nothing, + decompressAllMembers = True } -- | The default chunk sizes for the output of compression and decompression @@ -168,13 +171,33 @@ -- data chunks as output. The process is incremental, in that the demand for -- input and provision of output are interleaved. -- -data DecompressStream m - = DecompressInputRequired (S.ByteString -> m (DecompressStream m)) - | DecompressOutputAvailable S.ByteString (m (DecompressStream m)) +-- To indicate the end of the input supply an empty input chunk. Note that +-- for 'gzipFormat' with the default 'decompressAllMembers' @True@ you will +-- have to do this, as the decompressor will look for any following members. +-- With 'decompressAllMembers' @False@ the decompressor knows when the data +-- ends and will produce 'DecompressStreamEnd' without you having to supply an +-- empty chunk to indicate the end of the input. +-- +data DecompressStream m = + + DecompressInputRequired { + decompressSupplyInput :: S.ByteString -> m (DecompressStream m) + } + + | DecompressOutputAvailable { + decompressOutput :: !S.ByteString, + decompressNext :: m (DecompressStream m) + } + -- | Includes any trailing unconsumed /input/ data. - | DecompressStreamEnd S.ByteString + | DecompressStreamEnd { + decompressUnconsumedInput :: S.ByteString + } + -- | An error code - | DecompressStreamError DecompressError + | DecompressStreamError { + decompressStreamError :: DecompressError + } -- | The possible error cases when decompressing a stream. -- @@ -280,9 +303,9 @@ -- appropriate in all cicumstances. -- -- For these cases an incremental interface is more appropriate. This interface --- allows both incremental input and output. Chunks of input data to be --- supplied one by one (e.g. as they are obtained from an input source like a --- file or network source). Output is also produced chunk by chunk. +-- allows both incremental input and output. Chunks of input data are supplied +-- one by one (e.g. as they are obtained from an input source like a file or +-- network source). Output is also produced chunk by chunk. -- -- The incremental input and output is managed via the 'CompressStream' and -- 'DecompressStream' types. They represents the unfolding of the process of @@ -346,9 +369,16 @@ -- data chunks as output. The process is incremental, in that the demand for -- input and provision of output are interleaved. -- -data CompressStream m - = CompressInputRequired (S.ByteString -> m (CompressStream m)) - | CompressOutputAvailable S.ByteString (m (CompressStream m)) +data CompressStream m = + CompressInputRequired { + compressSupplyInput :: S.ByteString -> m (CompressStream m) + } + + | CompressOutputAvailable { + compressOutput :: !S.ByteString, + compressNext :: m (CompressStream m) + } + | CompressStreamEnd -- | A fold over the 'CompressStream' in the given monad. @@ -421,15 +451,18 @@ -- compressIO :: Stream.Format -> CompressParams -> CompressStream IO -compress format params = compressStreamToLBS (compressStream format params) -compressST format params = compressStreamToST (compressStream format params) -compressIO format params = compressStreamToIO (compressStream format params) +compress format params = foldCompressStreamWithInput + L.Chunk L.Empty + (compressStreamST format params) +compressST format params = compressStreamST format params +compressIO format params = compressStreamIO format params -compressStream :: Stream.Format -> CompressParams -> CompressStream Stream +compressStream :: Stream.Format -> CompressParams -> S.ByteString + -> Stream (CompressStream Stream) compressStream format (CompressParams compLevel method bits memLevel strategy initChunkSize mdict) = - CompressInputRequired $ \chunk -> do + \chunk -> do Stream.deflateInit format compLevel method bits memLevel strategy setDictionary mdict case chunk of @@ -547,23 +580,46 @@ -- decompressIO :: Stream.Format -> DecompressParams -> DecompressStream IO -decompress format params = decompressStreamToLBS (decompressStream format params) -decompressST format params = decompressStreamToST (decompressStream format params) -decompressIO format params = decompressStreamToIO (decompressStream format params) +decompress format params = foldDecompressStreamWithInput + L.Chunk (const L.Empty) throw + (decompressStreamST format params) +decompressST format params = decompressStreamST format params +decompressIO format params = decompressStreamIO format params -decompressStream :: Stream.Format -> DecompressParams -> DecompressStream Stream -decompressStream format (DecompressParams bits initChunkSize mdict) = +decompressStream :: Stream.Format -> DecompressParams + -> Bool -> S.ByteString + -> Stream (DecompressStream Stream) +decompressStream format (DecompressParams bits initChunkSize mdict allMembers) + resume = - DecompressInputRequired $ \chunk -> do - Stream.inflateInit format bits + \chunk -> do + inputBufferEmpty <- Stream.inputBufferEmpty + outputBufferFull <- Stream.outputBufferFull + assert inputBufferEmpty $ + if resume then assert (format == Stream.gzipFormat && allMembers) $ + Stream.inflateReset + else assert outputBufferFull $ + Stream.inflateInit format bits case chunk of - _ | S.null chunk -> - fillBuffers 4 --always an error anyway + _ | S.null chunk -> do + -- special case to avoid demanding more input again + -- always an error anyway + when outputBufferFull $ do + let outChunkSize = 1 + outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize) + Stream.pushOutputBuffer outFPtr 0 outChunkSize + drainBuffers True S.PS inFPtr offset length -> do Stream.pushInputBuffer inFPtr offset length - fillBuffers initChunkSize + -- Normally we start with no output buffer (so counts as full) but + -- if we're resuming then we'll usually still have output buffer + -- space available + assert (if not resume then outputBufferFull else True) $ return () + if outputBufferFull + then fillBuffers initChunkSize + else drainBuffers False where -- we flick between two states: @@ -632,7 +688,7 @@ inputBufferEmpty <- Stream.inputBufferEmpty if inputBufferEmpty then do finish (DecompressStreamEnd S.empty) - else do (inFPtr, offset, length) <- Stream.remainingInputBuffer + else do (inFPtr, offset, length) <- Stream.popRemainingInputBuffer let inchunk = S.PS inFPtr offset length finish (DecompressStreamEnd inchunk) @@ -652,10 +708,8 @@ outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable if outputBufferBytesAvailable > 0 then do (outFPtr, offset, length) <- Stream.popOutputBuffer - Stream.finalise return (DecompressOutputAvailable (S.PS outFPtr offset length) (return end)) - else do Stream.finalise - return end + else return end setDictionary :: Stream.DictionaryHash -> Maybe S.ByteString -> Stream (Maybe (DecompressStream Stream)) @@ -670,138 +724,224 @@ _ -> fail "error when setting inflate dictionary" -compressStreamToLBS :: CompressStream Stream -> L.ByteString -> L.ByteString -compressStreamToLBS = \strm inchunks -> - runST (do zstate <- strictToLazyST $ Stream.mkState - go strm zstate inchunks) - where - go :: CompressStream Stream -> Stream.State s - -> L.ByteString -> ST s L.ByteString - go (CompressInputRequired next) zstate L.Empty = do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next S.empty) zstate - go strm' zstate' L.Empty - - go (CompressInputRequired next) zstate (L.Chunk inchunk inchunks') = do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next inchunk) zstate - go strm' zstate' inchunks' +------------------------------------------------------------------------------ - go (CompressOutputAvailable outchunk next) zstate inchunks = do - (strm', zstate') <- strictToLazyST $ Stream.runStream next zstate - outchunks <- go strm' zstate' inchunks - return (L.Chunk outchunk outchunks) +mkStateST :: ST s (Stream.State s) +mkStateIO :: IO (Stream.State RealWorld) +mkStateST = strictToLazyST Stream.mkState +mkStateIO = stToIO Stream.mkState - go CompressStreamEnd _ _ = return L.Empty +runStreamST :: Stream a -> Stream.State s -> ST s (a, Stream.State s) +runStreamIO :: Stream a -> Stream.State RealWorld -> IO (a, Stream.State RealWorld) +runStreamST strm zstate = strictToLazyST (Stream.runStream strm zstate) +runStreamIO strm zstate = stToIO (Stream.runStream strm zstate) -compressStreamToIO :: CompressStream Stream -> CompressStream IO -compressStreamToIO = - \(CompressInputRequired next) -> - CompressInputRequired $ \chunk -> do - zstate <- stToIO Stream.mkState - (strm', zstate') <- stToIO $ Stream.runStream (next chunk) zstate +compressStreamIO :: Stream.Format -> CompressParams -> CompressStream IO +compressStreamIO format params = + CompressInputRequired { + compressSupplyInput = \chunk -> do + zstate <- mkStateIO + let next = compressStream format params + (strm', zstate') <- runStreamIO (next chunk) zstate return (go strm' zstate') + } where go :: CompressStream Stream -> Stream.State RealWorld -> CompressStream IO go (CompressInputRequired next) zstate = - CompressInputRequired $ \chunk -> do - (strm', zstate') <- stToIO $ Stream.runStream (next chunk) zstate - return (go strm' zstate') + CompressInputRequired { + compressSupplyInput = \chunk -> do + (strm', zstate') <- runStreamIO (next chunk) zstate + return (go strm' zstate') + } go (CompressOutputAvailable chunk next) zstate = CompressOutputAvailable chunk $ do - (strm', zstate') <- stToIO $ Stream.runStream next zstate + (strm', zstate') <- runStreamIO next zstate return (go strm' zstate') go CompressStreamEnd _ = CompressStreamEnd -compressStreamToST :: CompressStream Stream -> CompressStream (ST s) -compressStreamToST = - \(CompressInputRequired next) -> - CompressInputRequired $ \chunk -> do - zstate <- strictToLazyST $ Stream.mkState - (strm', zstate') <- strictToLazyST $ Stream.runStream (next chunk) zstate +compressStreamST :: Stream.Format -> CompressParams -> CompressStream (ST s) +compressStreamST format params = + CompressInputRequired { + compressSupplyInput = \chunk -> do + zstate <- mkStateST + let next = compressStream format params + (strm', zstate') <- runStreamST (next chunk) zstate return (go strm' zstate') + } where go :: CompressStream Stream -> Stream.State s -> CompressStream (ST s) go (CompressInputRequired next) zstate = - CompressInputRequired $ \chunk -> do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next chunk) zstate - return (go strm' zstate') + CompressInputRequired { + compressSupplyInput = \chunk -> do + (strm', zstate') <- runStreamST (next chunk) zstate + return (go strm' zstate') + } go (CompressOutputAvailable chunk next) zstate = CompressOutputAvailable chunk $ do - (strm', zstate') <- strictToLazyST $ Stream.runStream next zstate + (strm', zstate') <- runStreamST next zstate return (go strm' zstate') go CompressStreamEnd _ = CompressStreamEnd -decompressStreamToLBS :: DecompressStream Stream -> L.ByteString -> L.ByteString -decompressStreamToLBS = \strm inchunks -> - runST (do zstate <- strictToLazyST Stream.mkState - go strm zstate inchunks) +decompressStreamIO :: Stream.Format -> DecompressParams -> DecompressStream IO +decompressStreamIO format params = + DecompressInputRequired $ \chunk -> do + zstate <- mkStateIO + let next = decompressStream format params False + (strm', zstate') <- runStreamIO (next chunk) zstate + go strm' zstate' (S.null chunk) where - go :: DecompressStream Stream -> Stream.State s - -> L.ByteString -> ST s L.ByteString - go (DecompressInputRequired next) zstate L.Empty = do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next S.empty) zstate - go strm' zstate' L.Empty + go :: DecompressStream Stream -> Stream.State RealWorld -> Bool + -> IO (DecompressStream IO) + go (DecompressInputRequired next) zstate !_ = + return $ DecompressInputRequired $ \chunk -> do + (strm', zstate') <- runStreamIO (next chunk) zstate + go strm' zstate' (S.null chunk) - go (DecompressInputRequired next) zstate (L.Chunk inchunk inchunks') = do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next inchunk) zstate - go strm' zstate' inchunks' + go (DecompressOutputAvailable chunk next) zstate !eof = + return $ DecompressOutputAvailable chunk $ do + (strm', zstate') <- runStreamIO next zstate + go strm' zstate' eof - go (DecompressOutputAvailable outchunk next) zstate inchunks = do - (strm', zstate') <- strictToLazyST $ Stream.runStream next zstate - outchunks <- go strm' zstate' inchunks - return (L.Chunk outchunk outchunks) + go (DecompressStreamEnd unconsumed) zstate !eof + | format == Stream.gzipFormat + , decompressAllMembers params + , not eof = tryFollowingStream unconsumed zstate + | otherwise = finaliseStreamEnd unconsumed zstate - -- the decompressor will actually never demand the tail of the input (in - -- the usual case where it's empty) because the zlib and gzip formats know - -- their own length. So we force the tail of the input here because this - -- can be important for closing file handles etc. - go (DecompressStreamEnd _) _ !_inchunks = return L.Empty - go (DecompressStreamError err) _ _ = throw err + go (DecompressStreamError err) zstate !_ = finaliseStreamError err zstate -decompressStreamToIO :: DecompressStream Stream -> DecompressStream IO -decompressStreamToIO = - \(DecompressInputRequired next) -> - DecompressInputRequired $ \chunk -> do - zstate <- stToIO Stream.mkState - (strm', zstate') <- stToIO $ Stream.runStream (next chunk) zstate - return (go strm' zstate') - where - go :: DecompressStream Stream -> Stream.State RealWorld -> DecompressStream IO - go (DecompressInputRequired next) zstate = - DecompressInputRequired $ \chunk -> do - (strm', zstate') <- stToIO $ Stream.runStream (next chunk) zstate - return (go strm' zstate') + tryFollowingStream :: S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO) + tryFollowingStream chunk zstate = case S.length chunk of + 0 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of + 0 -> finaliseStreamEnd S.empty zstate + 1 | S.head chunk' /= 0x1f + -> finaliseStreamEnd chunk' zstate + 1 -> return $ DecompressInputRequired $ \chunk'' -> case S.length chunk'' of + 0 -> finaliseStreamEnd chunk' zstate + _ -> checkHeaderSplit (S.head chunk') chunk'' zstate + _ -> checkHeader chunk' zstate + 1 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of + 0 -> finaliseStreamEnd chunk zstate + _ -> checkHeaderSplit (S.head chunk) chunk' zstate + _ -> checkHeader chunk zstate - go (DecompressOutputAvailable chunk next) zstate = - DecompressOutputAvailable chunk $ do - (strm', zstate') <- stToIO $ Stream.runStream next zstate - return (go strm' zstate') + checkHeaderSplit :: Word8 -> S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO) + checkHeaderSplit 0x1f chunk zstate + | S.head chunk == 0x8b = do + let resume = decompressStream format params True (S.pack [0x1f, 0x8b]) + if S.length chunk > 1 + then do + -- have to handle the remaining data in this chunk + (DecompressInputRequired next, zstate') <- runStreamIO resume zstate + (strm', zstate'') <- runStreamIO (next (S.tail chunk)) zstate' + go strm' zstate'' False + else do + -- subtle special case when the chunk tail is empty + -- yay for QC tests + (strm, zstate') <- runStreamIO resume zstate + go strm zstate' False + checkHeaderSplit byte chunk zstate = + finaliseStreamEnd (S.cons byte chunk) zstate - go (DecompressStreamEnd chunk) _ = DecompressStreamEnd chunk - go (DecompressStreamError err) _ = DecompressStreamError err + checkHeader :: S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO) + checkHeader chunk zstate + | S.index chunk 0 == 0x1f + , S.index chunk 1 == 0x8b = do + let resume = decompressStream format params True chunk + (strm', zstate') <- runStreamIO resume zstate + go strm' zstate' False + checkHeader chunk zstate = finaliseStreamEnd chunk zstate -decompressStreamToST :: DecompressStream Stream -> DecompressStream (ST s) -decompressStreamToST = - \(DecompressInputRequired next) -> + finaliseStreamEnd unconsumed zstate = do + _ <- runStreamIO Stream.finalise zstate + return (DecompressStreamEnd unconsumed) + + finaliseStreamError err zstate = do + _ <- runStreamIO Stream.finalise zstate + return (DecompressStreamError err) + + +decompressStreamST :: Stream.Format -> DecompressParams -> DecompressStream (ST s) +decompressStreamST format params = DecompressInputRequired $ \chunk -> do - zstate <- strictToLazyST Stream.mkState - (strm', zstate') <- strictToLazyST $ Stream.runStream (next chunk) zstate - return (go strm' zstate') + zstate <- mkStateST + let next = decompressStream format params False + (strm', zstate') <- runStreamST (next chunk) zstate + go strm' zstate' (S.null chunk) where - go :: DecompressStream Stream -> Stream.State s -> DecompressStream (ST s) - go (DecompressInputRequired next) zstate = - DecompressInputRequired $ \chunk -> do - (strm', zstate') <- strictToLazyST $ Stream.runStream (next chunk) zstate - return (go strm' zstate') + go :: DecompressStream Stream -> Stream.State s -> Bool + -> ST s (DecompressStream (ST s)) + go (DecompressInputRequired next) zstate !_ = + return $ DecompressInputRequired $ \chunk -> do + (strm', zstate') <- runStreamST (next chunk) zstate + go strm' zstate' (S.null chunk) - go (DecompressOutputAvailable chunk next) zstate = - DecompressOutputAvailable chunk $ do - (strm', zstate') <- strictToLazyST $ Stream.runStream next zstate - return (go strm' zstate') + go (DecompressOutputAvailable chunk next) zstate !eof = + return $ DecompressOutputAvailable chunk $ do + (strm', zstate') <- runStreamST next zstate + go strm' zstate' eof - go (DecompressStreamEnd chunk) _ = DecompressStreamEnd chunk - go (DecompressStreamError err) _ = DecompressStreamError err + go (DecompressStreamEnd unconsumed) zstate !eof + | format == Stream.gzipFormat + , decompressAllMembers params + , not eof = tryFollowingStream unconsumed zstate + | otherwise = finaliseStreamEnd unconsumed zstate + + go (DecompressStreamError err) zstate !_ = finaliseStreamError err zstate + + + tryFollowingStream :: S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s)) + tryFollowingStream chunk zstate = + case S.length chunk of + 0 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of + 0 -> finaliseStreamEnd S.empty zstate + 1 | S.head chunk' /= 0x1f + -> finaliseStreamEnd chunk' zstate + 1 -> return $ DecompressInputRequired $ \chunk'' -> case S.length chunk'' of + 0 -> finaliseStreamEnd chunk' zstate + _ -> checkHeaderSplit (S.head chunk') chunk'' zstate + _ -> checkHeader chunk' zstate + 1 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of + 0 -> finaliseStreamEnd chunk zstate + _ -> checkHeaderSplit (S.head chunk) chunk' zstate + _ -> checkHeader chunk zstate + + checkHeaderSplit :: Word8 -> S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s)) + checkHeaderSplit 0x1f chunk zstate + | S.head chunk == 0x8b = do + let resume = decompressStream format params True (S.pack [0x1f, 0x8b]) + if S.length chunk > 1 + then do + -- have to handle the remaining data in this chunk + (DecompressInputRequired next, zstate') <- runStreamST resume zstate + (strm', zstate'') <- runStreamST (next (S.tail chunk)) zstate' + go strm' zstate'' False + else do + -- subtle special case when the chunk tail is empty + -- yay for QC tests + (strm, zstate') <- runStreamST resume zstate + go strm zstate' False + checkHeaderSplit byte chunk zstate = + finaliseStreamEnd (S.cons byte chunk) zstate + + checkHeader :: S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s)) + checkHeader chunk zstate + | S.index chunk 0 == 0x1f + , S.index chunk 1 == 0x8b = do + let resume = decompressStream format params True chunk + (strm', zstate') <- runStreamST resume zstate + go strm' zstate' False + checkHeader chunk zstate = finaliseStreamEnd chunk zstate + + finaliseStreamEnd unconsumed zstate = do + _ <- runStreamST Stream.finalise zstate + return (DecompressStreamEnd unconsumed) + + finaliseStreamError err zstate = do + _ <- runStreamST Stream.finalise zstate + return (DecompressStreamError err) diff --git a/Codec/Compression/Zlib/Stream.hsc b/Codec/Compression/Zlib/Stream.hsc --- a/Codec/Compression/Zlib/Stream.hsc +++ b/Codec/Compression/Zlib/Stream.hsc @@ -60,12 +60,14 @@ Status(..), Flush(..), ErrorCode(..), + -- ** Special operations + inflateReset, -- * Buffer management -- ** Input buffer pushInputBuffer, inputBufferEmpty, - remainingInputBuffer, + popRemainingInputBuffer, -- ** Output buffer pushOutputBuffer, @@ -92,15 +94,11 @@ ) where --- Note we don't use the MIN_VERSION_* macros here for compatability with --- old Cabal versions that come with old GHC, that didn't provide these --- macros for .hsc files. So we use __GLASGOW_HASKELL__ as a proxy. - import Foreign ( Word8, Ptr, nullPtr, plusPtr, peekByteOff, pokeByteOff , ForeignPtr, FinalizerPtr, mallocForeignPtrBytes, addForeignPtrFinalizer , withForeignPtr, touchForeignPtr, minusPtr ) -#if __GLASGOW_HASKELL__ >= 702 +#if MIN_VERSION_base(4,4,0) import Foreign.ForeignPtr.Unsafe ( unsafeForeignPtrToPtr ) import System.IO.Unsafe ( unsafePerformIO ) #else @@ -114,12 +112,12 @@ import Data.ByteString.Internal (nullForeignPtr) import qualified Data.ByteString.Unsafe as B import Data.ByteString (ByteString) -#if !(__GLASGOW_HASKELL__ >= 710) +#if !(MIN_VERSION_base(4,8,0)) import Control.Applicative (Applicative(..)) #endif import Control.Monad (ap,liftM) -#if __GLASGOW_HASKELL__ >= 702 -#if __GLASGOW_HASKELL__ >= 708 +#if MIN_VERSION_base(4,4,0) +#if MIN_VERSION_base(4,7,0) import Control.Monad.ST.Strict #else import Control.Monad.ST.Strict hiding (unsafeIOToST) @@ -168,8 +166,8 @@ inputBufferEmpty = getInAvail >>= return . (==0) -remainingInputBuffer :: Stream (ForeignPtr Word8, Int, Int) -remainingInputBuffer = do +popRemainingInputBuffer :: Stream (ForeignPtr Word8, Int, Int) +popRemainingInputBuffer = do inBuf <- getInBuf inNext <- getInNext @@ -177,6 +175,7 @@ -- there really should be something to pop, otherwise it's silly assert (inAvail > 0) $ return () + setInAvail 0 return (inBuf, inNext `minusPtr` unsafeForeignPtrToPtr inBuf, inAvail) @@ -283,6 +282,23 @@ setOutAvail (outAvail + outExtra) return result + +inflateReset :: Stream () +inflateReset = do + + outAvail <- getOutAvail + inAvail <- getInAvail + -- At the point where this is used, all the output should have been consumed + -- and any trailing input should be extracted and resupplied explicitly, not + -- just left. + assert (outAvail == 0 && inAvail == 0) $ return () + + err <- withStreamState $ \zstream -> + c_inflateReset zstream + failIfError err + + + deflateSetDictionary :: ByteString -> Stream Status deflateSetDictionary dict = do err <- withStreamState $ \zstream -> @@ -698,10 +714,10 @@ data WindowBits = WindowBits Int | DefaultWindowBits -- This constructor must be last to make -- the Ord instance work. The Ord instance - -- is defined with and used by the tests. + -- is used by the tests. -- It makse sense because the default value -- is is also the max value at 15. - deriving (Eq, Show, Typeable + deriving (Eq, Ord, Show, Typeable #if __GLASGOW_HASKELL__ >= 702 , Generic #endif @@ -1002,6 +1018,8 @@ foreign import ccall unsafe "zlib.h &inflateEnd" c_inflateEnd :: FinalizerPtr StreamState +foreign import ccall unsafe "zlib.h inflateReset" + c_inflateReset :: StreamState -> IO CInt foreign import ccall unsafe "zlib.h deflateInit2_" c_deflateInit2_ :: StreamState diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,11 +1,3 @@ -0.6.1.1 Duncan Coutts April 2015 - - * Fixed building with GHC 7.0 and 7.2 - -0.6.0.2 Duncan Coutts April 2015 - - * Fixed building with GHC 7.0 and 7.2 - 0.6.1.0 Duncan Coutts April 2015 * Support for concatenated gzip files (multiple back-to-back streams) diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -28,7 +28,6 @@ #endif - main :: IO () main = defaultMain $ testGroup "zlib tests" [ @@ -36,6 +35,9 @@ testProperty "decompress . compress = id (standard)" prop_decompress_after_compress, testProperty "decompress . compress = id (Zlib -> GZipOrZLib)" prop_gziporzlib1, testProperty "decompress . compress = id (GZip -> GZipOrZlib)" prop_gziporzlib2, + testProperty "concatenated gzip members" prop_gzip_concat, + testProperty "multiple gzip members, boundaries (all 2-chunks)" prop_multiple_members_boundary2, + testProperty "multiple gzip members, boundaries (all 3-chunks)" prop_multiple_members_boundary3, testProperty "prefixes of valid stream detected as truncated" prop_truncated ], testGroup "unit tests" [ @@ -46,7 +48,9 @@ testCase "dectect inflate with wrong dict" test_wrong_dictionary, testCase "dectect inflate with right dict" test_right_dictionary, testCase "handle trailing data" test_trailing_data, + testCase "multiple gzip members" test_multiple_members, testCase "check small input chunks" test_small_chunks, + testCase "check empty input" test_empty, testCase "check exception raised" test_exception ] ] @@ -83,6 +87,42 @@ decompressBufferSize dp > 0 && compressBufferSize cp > 0 ==> liftM2 (==) (decompress gzipOrZlibFormat dp . compress gzipFormat cp) id +prop_gzip_concat :: CompressParams + -> DecompressParams + -> BL.ByteString + -> Property +prop_gzip_concat cp dp input = + decompressWindowBits dp >= compressWindowBits cp && + decompressBufferSize dp > 0 && compressBufferSize cp > 0 ==> + let catComp = BL.concat (replicate 5 (compress gzipFormat cp input)) + compCat = compress gzipFormat cp (BL.concat (replicate 5 input)) + + in decompress gzipFormat dp { decompressAllMembers = True } catComp + == decompress gzipFormat dp { decompressAllMembers = True } compCat + +prop_multiple_members_boundary2 :: Property +prop_multiple_members_boundary2 = + forAll shortStrings $ \bs -> + all (\c -> decomp c == BL.append bs bs) + (twoChunkSplits (comp bs `BL.append` comp bs)) + where + comp = compress gzipFormat defaultCompressParams + decomp = decompress gzipFormat defaultDecompressParams + + shortStrings = fmap BL.pack $ listOf arbitrary + +prop_multiple_members_boundary3 :: Property +prop_multiple_members_boundary3 = + forAll shortStrings $ \bs -> + all (\c -> decomp c == BL.append bs bs) + (threeChunkSplits (comp bs `BL.append` comp bs)) + where + comp = compress gzipFormat defaultCompressParams + decomp = decompress gzipFormat defaultDecompressParams + + shortStrings = sized $ \sz -> resize (sz `div` 10) $ + fmap BL.pack $ listOf arbitrary + prop_truncated :: Format -> Property prop_truncated format = forAll shortStrings $ \bs -> @@ -170,12 +210,27 @@ test_trailing_data :: Assertion test_trailing_data = withSampleData "two-files.gz" $ \hnd -> do - let decomp = decompressIO gzipFormat defaultDecompressParams + let decomp = decompressIO gzipFormat defaultDecompressParams { + decompressAllMembers = False + } chunks <- assertDecompressOkChunks hnd decomp case chunks of [chunk] -> chunk @?= BS.Char8.pack "Test 1" _ -> assertFailure "expected single chunk" +test_multiple_members :: Assertion +test_multiple_members = + withSampleData "two-files.gz" $ \hnd -> do + let decomp = decompressIO gzipFormat defaultDecompressParams { + decompressAllMembers = True + } + chunks <- assertDecompressOkChunks hnd decomp + case chunks of + [chunk1, + chunk2] -> do chunk1 @?= BS.Char8.pack "Test 1" + chunk2 @?= BS.Char8.pack "Test 2" + _ -> assertFailure "expected two chunks" + test_small_chunks :: Assertion test_small_chunks = do uncompressedFile <- readSampleData "not-gzip" @@ -190,10 +245,21 @@ compressedFile <- readSampleData "hello.gz" (GZip.decompress . smallChunks) compressedFile @?= GZip.decompress compressedFile - where - smallChunks :: BL.ByteString -> BL.ByteString - smallChunks = BL.fromChunks . map (\c -> BS.pack [c]) . BL.unpack +test_empty :: Assertion +test_empty = do + -- Regression test to make sure we only ask for input once in the case of + -- initially empty input. We previously asked for input twice before + -- returning the error. + let decomp = decompressIO zlibFormat defaultDecompressParams + case decomp of + DecompressInputRequired next -> do + decomp' <- next BS.empty + case decomp' of + DecompressStreamError TruncatedInput -> return () + _ -> assertFailure "expected truncated error" + _ -> assertFailure "expected input" + test_exception :: Assertion test_exception = (do @@ -211,6 +277,25 @@ #else toStrict = BS.concat . BL.toChunks #endif + +----------------------- +-- Chunk boundary utils + +smallChunks :: BL.ByteString -> BL.ByteString +smallChunks = BL.fromChunks . map (\c -> BS.pack [c]) . BL.unpack + +twoChunkSplits :: BL.ByteString -> [BL.ByteString] +twoChunkSplits bs = zipWith (\a b -> BL.fromChunks [a,b]) (BS.inits sbs) (BS.tails sbs) + where + sbs = toStrict bs + +threeChunkSplits :: BL.ByteString -> [BL.ByteString] +threeChunkSplits bs = + [ BL.fromChunks [a,b,c] + | (a,x) <- zip (BS.inits sbs) (BS.tails sbs) + , (b,c) <- zip (BS.inits x) (BS.tails x) ] + where + sbs = toStrict bs -------------- -- HUnit Utils diff --git a/test/Test/Codec/Compression/Zlib/Internal.hs b/test/Test/Codec/Compression/Zlib/Internal.hs --- a/test/Test/Codec/Compression/Zlib/Internal.hs +++ b/test/Test/Codec/Compression/Zlib/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Test code and properties for "Codec.Compression.Zlib.Internal" @@ -12,8 +11,6 @@ import Control.Monad (ap) -deriving instance Show CompressParams - instance Arbitrary CompressParams where arbitrary = return CompressParams `ap` arbitrary `ap` arbitrary `ap` arbitrary `ap` arbitrary @@ -27,10 +24,9 @@ [(1, return n) | n <- [131072..1048576]] -deriving instance Show DecompressParams - instance Arbitrary DecompressParams where arbitrary = return DecompressParams `ap` arbitrary `ap` arbitraryBufferSize `ap` return Nothing + `ap` arbitrary diff --git a/test/Test/Codec/Compression/Zlib/Stream.hs b/test/Test/Codec/Compression/Zlib/Stream.hs --- a/test/Test/Codec/Compression/Zlib/Stream.hs +++ b/test/Test/Codec/Compression/Zlib/Stream.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Test code and properties for "Codec.Compression.Zlib.Stream" @@ -24,7 +23,6 @@ ++ map compressionLevel [1..9] -deriving instance Ord WindowBits instance Arbitrary WindowBits where arbitrary = elements $ defaultWindowBits:map windowBits [8..15] diff --git a/zlib.cabal b/zlib.cabal --- a/zlib.cabal +++ b/zlib.cabal @@ -1,5 +1,5 @@ name: zlib -version: 0.6.0.2 +version: 0.6.1.0 copyright: (c) 2006-2015 Duncan Coutts license: BSD3 license-file: LICENSE @@ -42,6 +42,7 @@ other-modules: Codec.Compression.Zlib.Stream if impl(ghc < 7) default-language: Haskell98 + default-extensions: PatternGuards else default-language: Haskell2010 other-extensions: CPP, ForeignFunctionInterface, RankNTypes, BangPatterns,