diff --git a/Data/Iteratee/ZLib.hsc b/Data/Iteratee/ZLib.hsc --- a/Data/Iteratee/ZLib.hsc +++ b/Data/Iteratee/ZLib.hsc @@ -3,19 +3,28 @@ {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE ScopedTypeVariables #-} module Data.Iteratee.ZLib - ( + ( + -- * Enumerators + enumInflate, + enumDeflate, + -- * Exceptions ZLibParamsException(..), ZLibException(..), + -- * Parameters CompressParams(..), + defaultCompressParams, DecompressParams(..), + defaultDecompressParams, Format(..), - enumInflate, - enumDeflate, + CompressionLevel(..), + Method(..), + WindowBits(..), + MemoryLevel(..), + CompressionStrategy(..), ) where #include -import Codec.Compression.Zlib.Internal hiding (StreamError, DataError) import Control.Applicative import Control.Exception import Control.Monad.Trans @@ -47,14 +56,14 @@ = NeedDictionary -- ^ Decompression requires user-supplied dictionary (not supported) | BufferError - -- ^ Buffer error - denotes the library error + -- ^ Buffer error - denotes a library error -- | File Error | StreamError -- ^ State of steam inconsistent | DataError -- ^ Input data corrupted | MemoryError - -- ^ Not enought memory + -- ^ Not enough memory | VersionError -- ^ Version error | Unexpected !CInt @@ -63,17 +72,45 @@ -- ^ Incorrect state - denotes error in library deriving (Eq,Typeable) +-- | Denotes the flush that can be sent to stream +data ZlibFlush + = SyncFlush + -- ^ All pending output is flushed and all input that is available is sent + -- to inner Iteratee. + | FullFlush + -- ^ Flush all pending output and reset the compression state. It allows to + -- restart from this point if compression was damaged but it can seriously + -- affect the compression rate. + -- + -- It may be only used during compression. + | Block + -- ^ If the iteratee is compressing it requests to stop when next block is + -- emmited. On the beginning it skips only header if and only if it exists. + deriving (Eq,Typeable) + +instance Show ZlibFlush where + show SyncFlush = "zlib: flush requested" + show FullFlush = "zlib: full flush requested" + show Block = "zlib: block flush requested" + +instance Exception ZlibFlush + +fromFlush :: ZlibFlush -> CInt +fromFlush SyncFlush = #{const Z_SYNC_FLUSH} +fromFlush FullFlush = #{const Z_FULL_FLUSH} +fromFlush Block = #{const Z_BLOCK} + instance Show ZLibParamsException where show (IncorrectCompressionLevel lvl) = "zlib: incorrect compression level " ++ show lvl show (IncorrectWindowBits lvl) = "zlib: incorrect window bits " ++ show lvl show (IncorrectMemoryLevel lvl) - = "zlib: incorrect memory lvele " ++ show lvl + = "zlib: incorrect memory level " ++ show lvl instance Show ZLibException where show NeedDictionary = "zlib: needs dictionary" - show BufferError = "zlib: no progress is possible (internall error)" + show BufferError = "zlib: no progress is possible (internal error)" -- show FileError = "zlib: file I/O error" show StreamError = "zlib: stream error" show DataError = "zlib: data error" @@ -95,6 +132,137 @@ -- Following code is copied from Duncan Coutts zlib haskell library version -- 0.5.2.0 ((c) 2006-2008 Duncan Coutts, published on BSD licence) and adapted +-- | Set of parameters for compression. For sane defaults use +-- 'defaultCompressParams' +data CompressParams = CompressParams { + compressLevel :: !CompressionLevel, + compressMethod :: !Method, + compressWindowBits :: !WindowBits, + compressMemoryLevel :: !MemoryLevel, + compressStrategy :: !CompressionStrategy, + -- | The size of output buffer. That is the size of 'Chunk's that will be + -- emitted to inner iterator (except the last 'Chunk'). + compressBufferSize :: !Int + } + +defaultCompressParams + = CompressParams DefaultCompression Deflated DefaultWindowBits + DefaultMemoryLevel DefaultStrategy (8*1024) + +-- | Set of parameters for decompression. For sane defaults see +-- 'defaultDecompressParams'. +data DecompressParams = DecompressParams { + -- | Window size - it have to be at least the size of + -- 'compressWindowBits' the stream was compressed with. + -- + -- Default in 'defaultDecompressParams' is the maximum window size - + -- please do not touch it unless you know what you are doing. + decompressWindowBits :: !WindowBits, + -- | The size of output buffer. That is the size of 'Chunk's that will be + -- emitted to inner iterator (except the last 'Chunk'). + decompressBufferSize :: !Int + } + +defaultDecompressParams = DecompressParams DefaultWindowBits (8*1024) + +-- | Specify the format for compression and decompression +data Format + = GZip + -- ^ The gzip format is widely used and uses a header with checksum and + -- some optional metadata about the compress file. + -- + -- It is intended primarily for compressing individual files but is also + -- used for network protocols such as HTTP. + -- + -- The format is described in RFC 1952 + -- . + | Zlib + -- ^ The zlib format uses a minimal header with a checksum but no other + -- metadata. It is designed for use in network protocols. + -- + -- The format is described in RFC 1950 + -- + | Raw + -- ^ The \'raw\' format is just the DEFLATE compressed data stream without + -- and additionl headers. + -- + -- Thr format is described in RFC 1951 + -- + | GZipOrZlib + -- ^ "Format" for decompressing a 'Zlib' or 'GZip' stream. + deriving (Eq) + +-- | The compression level specify the tradeoff between speed and compression. +data CompressionLevel + = DefaultCompression + -- ^ Default compression level set at 6. + | NoCompression + -- ^ No compression, just a block copy. + | BestSpeed + -- ^ The fastest compression method (however less compression) + | BestCompression + -- ^ The best compression method (however slowest) + | CompressionLevel Int + -- ^ Compression level set by number from 1 to 9 + +-- | Specify the compression method. +data Method + = Deflated + -- ^ \'Deflate\' is so far the only method supported. + +-- | This specify the size of compression level. Larger values result in better +-- compression at the expense of highier memory usage. +-- +-- The compression window size is 2 to the power of the value of the window +-- bits. +-- +-- The total memory used depends on windows bits and 'MemoryLevel'. +data WindowBits + = WindowBits Int + -- ^ The size of window bits. It have to be between @8@ (which corresponds + -- to 256b i.e. 32B) and @15@ (which corresponds to 32 kib i.e. 4kiB). + | DefaultWindowBits + -- ^ The default window size which is 4kiB + +-- | The 'MemoryLevel' specifies how much memory should be allocated for the +-- internal state. It is a tradeoff between memory usage, speed and +-- compression. +-- Using more memory allows faster and better compression. +-- +-- The memory used for interal state, excluding 'WindowBits', is 512 bits times +-- 2 to power of memory level. +-- +-- The total amount of memory use depends on the 'WindowBits' and +-- 'MemoryLevel'. +data MemoryLevel + = DefaultMemoryLevel + -- ^ Default memory level set to 8. + | MinMemoryLevel + -- ^ Use the small amount of memory (equivalent to memory level 1) - i.e. + -- 1024b or 256 B. + -- It slow and reduces the compresion ratio. + | MaxMemoryLevel + -- ^ Maximum memory level for optimal compression speed (equivalent to + -- memory level 9). + -- The internal state is 256kib or 32kiB. + | MemoryLevel Int + -- ^ A specific level. It have to be between 1 and 9. + +-- | Tunes the compress algorithm but does not affact the correctness. +data CompressionStrategy + = DefaultStrategy + -- ^ Default strategy + | Filtered + -- ^ Use the filtered compression strategy for data produced by a filter + -- (or predictor). Filtered data consists mostly of small values with a + -- somewhat random distribution. In this case, the compression algorithm + -- is tuned to compress them better. The effect of this strategy is to + -- force more Huffman coding and less string matching; it is somewhat + -- intermediate between 'DefaultStrategy' and 'HuffmanOnly'. + | HuffmanOnly + -- ^ Use the Huffman-only compression strategy to force Huffman encoding + -- only (no string match). + fromMethod :: Method -> CInt fromMethod Deflated = #{const Z_DEFLATED} @@ -158,22 +326,28 @@ r = Right in eit (\c_ -> eit (\b_ -> eit (\l_ -> r (c_, m', b_, l_, s')) l') b') c' -- --- In following code we go through 6 states. Some of the operations are +-- In following code we go through 7 states. Some of the operations are -- 'deterministic' like 'insertOut' and some of them depends on input ('fill') -- or library call. -- --- insertOut fill[1] --- (Initial) -------------> (EmptyIn) -----------> (Finishing) --- ^ ^ | | --- | run[2] | | | --- | run[1] | | | --- \------------------\ | | fill[0] | finish --- | | | | --- | | | | --- swapOut | | v v --- (FullOut) -------------> (Invalid) (Finished) --- <------------ --- run[0] +-- (Finished) +-- ^ +-- | +-- | +-- | finish +-- | +-- insertOut fill[1] | +--- (Initial) -------------> (EmptyIn) -----------> (Finishing) +-- ^ ^ | ^ | +-- | run[2] | | | \------------------\ +-- | | | | | +-- | | | \------------------\ | +-- | run[1] | | flush[0] | | +-- \------------------\ | | fill[0] | | fill[3] +-- | | | | | +-- | | | | | +-- swapOut | | v flush[1] | v +-- (FullOut) -------------> (Invalid) <----------- (Flushing) -- -- Initial: Initial state, both buffers are empty -- EmptyIn: Empty in buffer, out waits untill filled @@ -182,7 +356,10 @@ -- Finishing: There is no more in data and in buffer is empty. Waits till -- all outs was sent. -- Finished: Operation finished +-- Flushing: Flush requested -- +-- Please note that the decompressing can finish also on flush and finish. +-- -- [1] Named for 'historical' reasons newtype Initial = Initial ZStream @@ -190,6 +367,7 @@ data FullOut = FullOut !ZStream !ByteString data Invalid = Invalid !ZStream !ByteString !ByteString data Finishing = Finishing !ZStream !ByteString +data Flushing = Flushing !ZStream !ZlibFlush !ByteString withByteString :: ByteString -> (Ptr Word8 -> Int -> IO a) -> IO a withByteString (PS ptr off len) f @@ -280,7 +458,11 @@ | otherwise = fillI fill' (EOF Nothing) = joinIM $ finish size run (Finishing zstr BS.empty) iter - fill' (EOF (Just err)) = throwRecoverableErr err fill' + fill' (EOF (Just err)) + = case fromException err of + Just err' -> + joinIM $ flush size run (Flushing zstr err' _out) iter + Nothing -> throwRecoverableErr err fill' #ifdef DEBUG fillI = do liftIO $ IO.hPutStrLn stderr $ "About to insert in buffer" @@ -342,6 +524,35 @@ 0 -> fill size run (EmptyIn zstr _out) iter _ -> enumErr IncorrectState iter +flush :: MonadIO m + => Int + -> (ZStream -> CInt -> IO CInt) + -> Flushing + -> Enumerator ByteString m a +flush size run fin@(Flushing zstr _flush _out) iter = return $! do + status <- liftIO $ run zstr (fromFlush _flush) + case fromErrno status of + Left err -> joinIM $ enumErr err iter + Right False -> do -- Finished + out <- liftIO $ pullOutBuffer zstr _out + iter' <- lift $ enumPure1Chunk out iter + res <- lift $ tryRun iter' + case res of + Left err@(SomeException _) -> throwErr err + Right x -> idone x (Chunk BS.empty) + Right True -> do + (avail_in, avail_out) <- liftIO $ withZStream zstr $ \zptr -> do + avail_in <- liftIO $ #{peek z_stream, avail_in} zptr + avail_out <- liftIO $ #{peek z_stream, avail_out} zptr + return (avail_in, avail_out) :: IO (CInt, CInt) + case avail_out of + 0 -> do + out <- liftIO $ pullOutBuffer zstr _out + iter' <- lift $ enumPure1Chunk out iter + out' <- liftIO $ putOutBuffer size zstr + joinIM $ flush size run (Flushing zstr _flush out') iter' + _ -> joinIM $ insertOut size run (Initial zstr) iter + finish :: MonadIO m => Int -> (ZStream -> CInt -> IO CInt) @@ -426,8 +637,8 @@ zstr <- mallocForeignPtrBytes #{size z_stream} withForeignPtr zstr $ \zptr -> do memset (castPtr zptr) 0 #{size z_stream} - deflateInit2 zptr c m b l s - addForeignPtrFinalizer deflateEnd zstr + deflateInit2 zptr c m b l s `finally` + addForeignPtrFinalizer deflateEnd zstr return $! Right $! Initial $ ZStream zstr mkDecompress :: Format -> DecompressParams @@ -439,11 +650,11 @@ zstr <- mallocForeignPtrBytes #{size z_stream} withForeignPtr zstr $ \zptr -> do memset (castPtr zptr) 0 #{size z_stream} - inflateInit2 zptr wB' - addForeignPtrFinalizer inflateEnd zstr + inflateInit2 zptr wB' `finally` + addForeignPtrFinalizer inflateEnd zstr return $! Right $! Initial $ ZStream zstr --- User-releted code +-- User-related code -- | Compress the input and send to inner iteratee. enumDeflate :: MonadIO m diff --git a/iteratee-compress.cabal b/iteratee-compress.cabal --- a/iteratee-compress.cabal +++ b/iteratee-compress.cabal @@ -1,5 +1,5 @@ Name: iteratee-compress -Version: 0.1 +Version: 0.1.1 Synopsis: An enumerators for compressing and decompressing streams Description: An enumerators for compressing and decompressing streams License: BSD3 @@ -21,8 +21,7 @@ Build-depends: base >= 4 && < 5, bytestring >= 0.9 && < 0.10, iteratee >= 0.4 && < 5, - monads-fd >= 0.1 && < 0.2, - zlib >= 0.5 && < 6 + monads-fd >= 0.1 && < 0.2 Build-tools: c2hs Extensions: CPP, DeriveDataTypeable,