|
Packit |
4cd534 |
{-# LANGUAGE CPP, RankNTypes, DeriveDataTypeable, BangPatterns #-}
|
|
Packit |
4cd534 |
#if __GLASGOW_HASKELL__ >= 702
|
|
Packit |
4cd534 |
{-# LANGUAGE Trustworthy #-}
|
|
Packit |
4cd534 |
#endif
|
|
Packit |
4cd534 |
-----------------------------------------------------------------------------
|
|
Packit |
4cd534 |
-- |
|
|
Packit |
4cd534 |
-- Copyright : (c) 2006-2015 Duncan Coutts
|
|
Packit |
4cd534 |
-- License : BSD-style
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- Maintainer : duncan@community.haskell.org
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- Pure and IO stream based interfaces to lower level zlib wrapper
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-----------------------------------------------------------------------------
|
|
Packit |
4cd534 |
module Codec.Compression.Zlib.Internal (
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- * Pure interface
|
|
Packit |
4cd534 |
compress,
|
|
Packit |
4cd534 |
decompress,
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- * Monadic incremental interface
|
|
Packit |
4cd534 |
-- $incremental-compression
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- ** Using incremental compression
|
|
Packit |
4cd534 |
-- $using-incremental-compression
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
CompressStream(..),
|
|
Packit |
4cd534 |
compressST,
|
|
Packit |
4cd534 |
compressIO,
|
|
Packit |
4cd534 |
foldCompressStream,
|
|
Packit |
4cd534 |
foldCompressStreamWithInput,
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- ** Using incremental decompression
|
|
Packit |
4cd534 |
-- $using-incremental-decompression
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
DecompressStream(..),
|
|
Packit |
4cd534 |
DecompressError(..),
|
|
Packit |
4cd534 |
decompressST,
|
|
Packit |
4cd534 |
decompressIO,
|
|
Packit |
4cd534 |
foldDecompressStream,
|
|
Packit |
4cd534 |
foldDecompressStreamWithInput,
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- * The compression parameter types
|
|
Packit |
4cd534 |
CompressParams(..),
|
|
Packit |
4cd534 |
defaultCompressParams,
|
|
Packit |
4cd534 |
DecompressParams(..),
|
|
Packit |
4cd534 |
defaultDecompressParams,
|
|
Packit |
4cd534 |
Stream.Format(..),
|
|
Packit |
4cd534 |
Stream.gzipFormat,
|
|
Packit |
4cd534 |
Stream.zlibFormat,
|
|
Packit |
4cd534 |
Stream.rawFormat,
|
|
Packit |
4cd534 |
Stream.gzipOrZlibFormat,
|
|
Packit |
4cd534 |
Stream.CompressionLevel(..),
|
|
Packit |
4cd534 |
Stream.defaultCompression,
|
|
Packit |
4cd534 |
Stream.noCompression,
|
|
Packit |
4cd534 |
Stream.bestSpeed,
|
|
Packit |
4cd534 |
Stream.bestCompression,
|
|
Packit |
4cd534 |
Stream.compressionLevel,
|
|
Packit |
4cd534 |
Stream.Method(..),
|
|
Packit |
4cd534 |
Stream.deflateMethod,
|
|
Packit |
4cd534 |
Stream.WindowBits(..),
|
|
Packit |
4cd534 |
Stream.defaultWindowBits,
|
|
Packit |
4cd534 |
Stream.windowBits,
|
|
Packit |
4cd534 |
Stream.MemoryLevel(..),
|
|
Packit |
4cd534 |
Stream.defaultMemoryLevel,
|
|
Packit |
4cd534 |
Stream.minMemoryLevel,
|
|
Packit |
4cd534 |
Stream.maxMemoryLevel,
|
|
Packit |
4cd534 |
Stream.memoryLevel,
|
|
Packit |
4cd534 |
Stream.CompressionStrategy(..),
|
|
Packit |
4cd534 |
Stream.defaultStrategy,
|
|
Packit |
4cd534 |
Stream.filteredStrategy,
|
|
Packit |
4cd534 |
Stream.huffmanOnlyStrategy,
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
) where
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
import Prelude hiding (length)
|
|
Packit |
4cd534 |
import Control.Monad (when)
|
|
Packit |
4cd534 |
import Control.Exception (Exception, throw, assert)
|
|
Packit |
4cd534 |
import Control.Monad.ST.Lazy hiding (stToIO)
|
|
Packit |
4cd534 |
import Control.Monad.ST.Strict (stToIO)
|
|
Packit |
4cd534 |
#if __GLASGOW_HASKELL__ >= 702
|
|
Packit |
4cd534 |
import qualified Control.Monad.ST.Unsafe as Unsafe (unsafeIOToST)
|
|
Packit |
4cd534 |
#else
|
|
Packit |
4cd534 |
import qualified Control.Monad.ST.Strict as Unsafe (unsafeIOToST)
|
|
Packit |
4cd534 |
#endif
|
|
Packit |
4cd534 |
import Data.Typeable (Typeable)
|
|
Packit |
4cd534 |
import qualified Data.ByteString.Lazy as L
|
|
Packit |
4cd534 |
import qualified Data.ByteString.Lazy.Internal as L
|
|
Packit |
4cd534 |
import qualified Data.ByteString as S
|
|
Packit |
4cd534 |
import qualified Data.ByteString.Internal as S
|
|
Packit |
4cd534 |
import Data.Word (Word8)
|
|
Packit |
4cd534 |
import GHC.IO (noDuplicate)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
import qualified Codec.Compression.Zlib.Stream as Stream
|
|
Packit |
4cd534 |
import Codec.Compression.Zlib.Stream (Stream)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The full set of parameters for compression. The defaults are
|
|
Packit |
4cd534 |
-- 'defaultCompressParams'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- The 'compressBufferSize' is the size of the first output buffer containing
|
|
Packit |
4cd534 |
-- the compressed data. If you know an approximate upper bound on the size of
|
|
Packit |
4cd534 |
-- the compressed data then setting this parameter can save memory. The default
|
|
Packit |
4cd534 |
-- compression output buffer size is @16k@. If your extimate is wrong it does
|
|
Packit |
4cd534 |
-- not matter too much, the default buffer size will be used for the remaining
|
|
Packit |
4cd534 |
-- chunks.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
data CompressParams = CompressParams {
|
|
Packit |
4cd534 |
compressLevel :: !Stream.CompressionLevel,
|
|
Packit |
4cd534 |
compressMethod :: !Stream.Method,
|
|
Packit |
4cd534 |
compressWindowBits :: !Stream.WindowBits,
|
|
Packit |
4cd534 |
compressMemoryLevel :: !Stream.MemoryLevel,
|
|
Packit |
4cd534 |
compressStrategy :: !Stream.CompressionStrategy,
|
|
Packit |
4cd534 |
compressBufferSize :: !Int,
|
|
Packit |
4cd534 |
compressDictionary :: Maybe S.ByteString
|
|
Packit |
4cd534 |
} deriving Show
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The full set of parameters for decompression. The defaults are
|
|
Packit |
4cd534 |
-- 'defaultDecompressParams'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- The 'decompressBufferSize' is the size of the first output buffer,
|
|
Packit |
4cd534 |
-- containing the uncompressed data. If you know an exact or approximate upper
|
|
Packit |
4cd534 |
-- bound on the size of the decompressed data then setting this parameter can
|
|
Packit |
4cd534 |
-- save memory. The default decompression output buffer size is @32k@. If your
|
|
Packit |
4cd534 |
-- extimate is wrong it does not matter too much, the default buffer size will
|
|
Packit |
4cd534 |
-- be used for the remaining chunks.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- One particular use case for setting the 'decompressBufferSize' is if you
|
|
Packit |
4cd534 |
-- know the exact size of the decompressed data and want to produce a strict
|
|
Packit |
4cd534 |
-- 'Data.ByteString.ByteString'. The compression and deccompression functions
|
|
Packit |
4cd534 |
-- use lazy 'Data.ByteString.Lazy.ByteString's but if you set the
|
|
Packit |
4cd534 |
-- 'decompressBufferSize' correctly then you can generate a lazy
|
|
Packit |
4cd534 |
-- 'Data.ByteString.Lazy.ByteString' with exactly one chunk, which can be
|
|
Packit |
4cd534 |
-- converted to a strict 'Data.ByteString.ByteString' in @O(1)@ time using
|
|
Packit |
4cd534 |
-- @'Data.ByteString.concat' . 'Data.ByteString.Lazy.toChunks'@.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
data DecompressParams = DecompressParams {
|
|
Packit |
4cd534 |
decompressWindowBits :: !Stream.WindowBits,
|
|
Packit |
4cd534 |
decompressBufferSize :: !Int,
|
|
Packit |
4cd534 |
decompressDictionary :: Maybe S.ByteString,
|
|
Packit |
4cd534 |
decompressAllMembers :: Bool
|
|
Packit |
4cd534 |
} deriving Show
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The default set of parameters for compression. This is typically used with
|
|
Packit |
4cd534 |
-- the @compressWith@ function with specific parameters overridden.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
defaultCompressParams :: CompressParams
|
|
Packit |
4cd534 |
defaultCompressParams = CompressParams {
|
|
Packit |
4cd534 |
compressLevel = Stream.defaultCompression,
|
|
Packit |
4cd534 |
compressMethod = Stream.deflateMethod,
|
|
Packit |
4cd534 |
compressWindowBits = Stream.defaultWindowBits,
|
|
Packit |
4cd534 |
compressMemoryLevel = Stream.defaultMemoryLevel,
|
|
Packit |
4cd534 |
compressStrategy = Stream.defaultStrategy,
|
|
Packit |
4cd534 |
compressBufferSize = defaultCompressBufferSize,
|
|
Packit |
4cd534 |
compressDictionary = Nothing
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The default set of parameters for decompression. This is typically used with
|
|
Packit |
4cd534 |
-- the @compressWith@ function with specific parameters overridden.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
defaultDecompressParams :: DecompressParams
|
|
Packit |
4cd534 |
defaultDecompressParams = DecompressParams {
|
|
Packit |
4cd534 |
decompressWindowBits = Stream.defaultWindowBits,
|
|
Packit |
4cd534 |
decompressBufferSize = defaultDecompressBufferSize,
|
|
Packit |
4cd534 |
decompressDictionary = Nothing,
|
|
Packit |
4cd534 |
decompressAllMembers = True
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The default chunk sizes for the output of compression and decompression
|
|
Packit |
4cd534 |
-- are 16k and 32k respectively (less a small accounting overhead).
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
defaultCompressBufferSize, defaultDecompressBufferSize :: Int
|
|
Packit |
4cd534 |
defaultCompressBufferSize = 16 * 1024 - L.chunkOverhead
|
|
Packit |
4cd534 |
defaultDecompressBufferSize = 32 * 1024 - L.chunkOverhead
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The unfolding of the decompression process, where you provide a sequence
|
|
Packit |
4cd534 |
-- of compressed data chunks as input and receive a sequence of uncompressed
|
|
Packit |
4cd534 |
-- data chunks as output. The process is incremental, in that the demand for
|
|
Packit |
4cd534 |
-- input and provision of output are interleaved.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- To indicate the end of the input supply an empty input chunk. Note that
|
|
Packit |
4cd534 |
-- for 'gzipFormat' with the default 'decompressAllMembers' @True@ you will
|
|
Packit |
4cd534 |
-- have to do this, as the decompressor will look for any following members.
|
|
Packit |
4cd534 |
-- With 'decompressAllMembers' @False@ the decompressor knows when the data
|
|
Packit |
4cd534 |
-- ends and will produce 'DecompressStreamEnd' without you having to supply an
|
|
Packit |
4cd534 |
-- empty chunk to indicate the end of the input.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
data DecompressStream m =
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
DecompressInputRequired {
|
|
Packit |
4cd534 |
decompressSupplyInput :: S.ByteString -> m (DecompressStream m)
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
| DecompressOutputAvailable {
|
|
Packit |
4cd534 |
decompressOutput :: !S.ByteString,
|
|
Packit |
4cd534 |
decompressNext :: m (DecompressStream m)
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Includes any trailing unconsumed /input/ data.
|
|
Packit |
4cd534 |
| DecompressStreamEnd {
|
|
Packit |
4cd534 |
decompressUnconsumedInput :: S.ByteString
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | An error code
|
|
Packit |
4cd534 |
| DecompressStreamError {
|
|
Packit |
4cd534 |
decompressStreamError :: DecompressError
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The possible error cases when decompressing a stream.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- This can be 'show'n to give a human readable error message.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
data DecompressError =
|
|
Packit |
4cd534 |
-- | The compressed data stream ended prematurely. This may happen if the
|
|
Packit |
4cd534 |
-- input data stream was truncated.
|
|
Packit |
4cd534 |
TruncatedInput
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | It is possible to do zlib compression with a custom dictionary. This
|
|
Packit |
4cd534 |
-- allows slightly higher compression ratios for short files. However such
|
|
Packit |
4cd534 |
-- compressed streams require the same dictionary when decompressing. This
|
|
Packit |
4cd534 |
-- error is for when we encounter a compressed stream that needs a
|
|
Packit |
4cd534 |
-- dictionary, and it's not provided.
|
|
Packit |
4cd534 |
| DictionaryRequired
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | If the stream requires a dictionary and you provide one with the
|
|
Packit |
4cd534 |
-- wrong 'DictionaryHash' then you will get this error.
|
|
Packit |
4cd534 |
| DictionaryMismatch
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | If the compressed data stream is corrupted in any way then you will
|
|
Packit |
4cd534 |
-- get this error, for example if the input data just isn't a compressed
|
|
Packit |
4cd534 |
-- zlib data stream. In particular if the data checksum turns out to be
|
|
Packit |
4cd534 |
-- wrong then you will get all the decompressed data but this error at the
|
|
Packit |
4cd534 |
-- end, instead of the normal sucessful 'StreamEnd'.
|
|
Packit |
4cd534 |
| DataFormatError String
|
|
Packit |
4cd534 |
deriving (Eq, Typeable)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
instance Show DecompressError where
|
|
Packit |
4cd534 |
show TruncatedInput = modprefix "premature end of compressed data stream"
|
|
Packit |
4cd534 |
show DictionaryRequired = modprefix "compressed data stream requires custom dictionary"
|
|
Packit |
4cd534 |
show DictionaryMismatch = modprefix "given dictionary does not match the expected one"
|
|
Packit |
4cd534 |
show (DataFormatError detail) = modprefix ("compressed data stream format error (" ++ detail ++ ")")
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
modprefix :: ShowS
|
|
Packit |
4cd534 |
modprefix = ("Codec.Compression.Zlib: " ++)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
instance Exception DecompressError
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | A fold over the 'DecompressStream' in the given monad.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- One way to look at this is that it runs the stream, using callback functions
|
|
Packit |
4cd534 |
-- for the four stream events.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
foldDecompressStream :: Monad m
|
|
Packit |
4cd534 |
=> ((S.ByteString -> m a) -> m a)
|
|
Packit |
4cd534 |
-> (S.ByteString -> m a -> m a)
|
|
Packit |
4cd534 |
-> (S.ByteString -> m a)
|
|
Packit |
4cd534 |
-> (DecompressError -> m a)
|
|
Packit |
4cd534 |
-> DecompressStream m -> m a
|
|
Packit |
4cd534 |
foldDecompressStream input output end err = fold
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
fold (DecompressInputRequired next) =
|
|
Packit |
4cd534 |
input (\x -> next x >>= fold)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressOutputAvailable outchunk next) =
|
|
Packit |
4cd534 |
output outchunk (next >>= fold)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressStreamEnd inchunk) = end inchunk
|
|
Packit |
4cd534 |
fold (DecompressStreamError derr) = err derr
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | A variant on 'foldCompressStream' that is pure rather than operating in a
|
|
Packit |
4cd534 |
-- monad and where the input is provided by a lazy 'L.ByteString'. So we only
|
|
Packit |
4cd534 |
-- have to deal with the output, end and error parts, making it like a foldr on
|
|
Packit |
4cd534 |
-- a list of output chunks.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- For example:
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- > toChunks = foldDecompressStreamWithInput (:) [] throw
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
foldDecompressStreamWithInput :: (S.ByteString -> a -> a)
|
|
Packit |
4cd534 |
-> (L.ByteString -> a)
|
|
Packit |
4cd534 |
-> (DecompressError -> a)
|
|
Packit |
4cd534 |
-> (forall s. DecompressStream (ST s))
|
|
Packit |
4cd534 |
-> L.ByteString
|
|
Packit |
4cd534 |
-> a
|
|
Packit |
4cd534 |
foldDecompressStreamWithInput chunk end err = \s lbs ->
|
|
Packit |
4cd534 |
runST (fold s (L.toChunks lbs))
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
fold (DecompressInputRequired next) [] =
|
|
Packit |
4cd534 |
next S.empty >>= \strm -> fold strm []
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressInputRequired next) (inchunk:inchunks) =
|
|
Packit |
4cd534 |
next inchunk >>= \s -> fold s inchunks
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressOutputAvailable outchunk next) inchunks = do
|
|
Packit |
4cd534 |
r <- next >>= \s -> fold s inchunks
|
|
Packit |
4cd534 |
return $ chunk outchunk r
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressStreamEnd inchunk) inchunks =
|
|
Packit |
4cd534 |
return $ end (L.fromChunks (inchunk:inchunks))
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (DecompressStreamError derr) _ =
|
|
Packit |
4cd534 |
return $ err derr
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- $incremental-compression
|
|
Packit |
4cd534 |
-- The pure 'compress' and 'decompress' functions are streaming in the sense
|
|
Packit |
4cd534 |
-- that they can produce output without demanding all input, however they need
|
|
Packit |
4cd534 |
-- the input data stream as a lazy 'L.ByteString'. Having the input data
|
|
Packit |
4cd534 |
-- stream as a lazy 'L.ByteString' often requires using lazy I\/O which is not
|
|
Packit |
4cd534 |
-- appropriate in all cicumstances.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- For these cases an incremental interface is more appropriate. This interface
|
|
Packit |
4cd534 |
-- allows both incremental input and output. Chunks of input data are supplied
|
|
Packit |
4cd534 |
-- one by one (e.g. as they are obtained from an input source like a file or
|
|
Packit |
4cd534 |
-- network source). Output is also produced chunk by chunk.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- The incremental input and output is managed via the 'CompressStream' and
|
|
Packit |
4cd534 |
-- 'DecompressStream' types. They represents the unfolding of the process of
|
|
Packit |
4cd534 |
-- compressing and decompressing. They operates in either the 'ST' or 'IO'
|
|
Packit |
4cd534 |
-- monads. They can be lifted into other incremental abstractions like pipes or
|
|
Packit |
4cd534 |
-- conduits, or they can be used directly in the following style.
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- $using-incremental-compression
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- In a loop:
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * Inspect the status of the stream
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * When it is 'CompressInputRequired' then you should call the action,
|
|
Packit |
4cd534 |
-- passing a chunk of input (or 'BS.empty' when no more input is available)
|
|
Packit |
4cd534 |
-- to get the next state of the stream and continue the loop.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * When it is 'CompressOutputAvailable' then do something with the given
|
|
Packit |
4cd534 |
-- chunk of output, and call the action to get the next state of the stream
|
|
Packit |
4cd534 |
-- and continue the loop.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * When it is 'CompressStreamEnd' then terminate the loop.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- Note that you cannot stop as soon as you have no more input, you need to
|
|
Packit |
4cd534 |
-- carry on until all the output has been collected, i.e. until you get to
|
|
Packit |
4cd534 |
-- 'CompressStreamEnd'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- Here is an example where we get input from one file handle and send the
|
|
Packit |
4cd534 |
-- compressed output to another file handle.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- > go :: Handle -> Handle -> CompressStream IO -> IO ()
|
|
Packit |
4cd534 |
-- > go inh outh (CompressInputRequired next) = do
|
|
Packit |
4cd534 |
-- > inchunk <- BS.hGet inh 4096
|
|
Packit |
4cd534 |
-- > go inh outh =<< next inchunk
|
|
Packit |
4cd534 |
-- > go inh outh (CompressOutputAvailable outchunk next) =
|
|
Packit |
4cd534 |
-- > BS.hPut outh outchunk
|
|
Packit |
4cd534 |
-- > go inh outh =<< next
|
|
Packit |
4cd534 |
-- > go _ _ CompressStreamEnd = return ()
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- The same can be achieved with 'foldCompressStream':
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- > foldCompressStream
|
|
Packit |
4cd534 |
-- > (\next -> do inchunk <- BS.hGet inh 4096; next inchunk)
|
|
Packit |
4cd534 |
-- > (\outchunk next -> do BS.hPut outh outchunk; next)
|
|
Packit |
4cd534 |
-- > (return ())
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- $using-incremental-decompression
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- The use of 'DecompressStream' is very similar to 'CompressStream' but with
|
|
Packit |
4cd534 |
-- a few differences:
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * There is the extra possibility of a 'DecompressStreamError'
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- * There can be extra trailing data after a compressed stream, and the
|
|
Packit |
4cd534 |
-- 'DecompressStreamEnd' includes that.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- Otherwise the same loop style applies, and there are fold functions.
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | The unfolding of the compression process, where you provide a sequence
|
|
Packit |
4cd534 |
-- of uncompressed data chunks as input and receive a sequence of compressed
|
|
Packit |
4cd534 |
-- data chunks as output. The process is incremental, in that the demand for
|
|
Packit |
4cd534 |
-- input and provision of output are interleaved.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
data CompressStream m =
|
|
Packit |
4cd534 |
CompressInputRequired {
|
|
Packit |
4cd534 |
compressSupplyInput :: S.ByteString -> m (CompressStream m)
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
| CompressOutputAvailable {
|
|
Packit |
4cd534 |
compressOutput :: !S.ByteString,
|
|
Packit |
4cd534 |
compressNext :: m (CompressStream m)
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
| CompressStreamEnd
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | A fold over the 'CompressStream' in the given monad.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- One way to look at this is that it runs the stream, using callback functions
|
|
Packit |
4cd534 |
-- for the three stream events.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
foldCompressStream :: Monad m
|
|
Packit |
4cd534 |
=> ((S.ByteString -> m a) -> m a)
|
|
Packit |
4cd534 |
-> (S.ByteString -> m a -> m a)
|
|
Packit |
4cd534 |
-> m a
|
|
Packit |
4cd534 |
-> CompressStream m -> m a
|
|
Packit |
4cd534 |
foldCompressStream input output end = fold
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
fold (CompressInputRequired next) =
|
|
Packit |
4cd534 |
input (\x -> next x >>= fold)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (CompressOutputAvailable outchunk next) =
|
|
Packit |
4cd534 |
output outchunk (next >>= fold)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold CompressStreamEnd =
|
|
Packit |
4cd534 |
end
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | A variant on 'foldCompressStream' that is pure rather than operating in a
|
|
Packit |
4cd534 |
-- monad and where the input is provided by a lazy 'L.ByteString'. So we only
|
|
Packit |
4cd534 |
-- have to deal with the output and end parts, making it just like a foldr on a
|
|
Packit |
4cd534 |
-- list of output chunks.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- For example:
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- > toChunks = foldCompressStreamWithInput (:) []
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
foldCompressStreamWithInput :: (S.ByteString -> a -> a)
|
|
Packit |
4cd534 |
-> a
|
|
Packit |
4cd534 |
-> (forall s. CompressStream (ST s))
|
|
Packit |
4cd534 |
-> L.ByteString
|
|
Packit |
4cd534 |
-> a
|
|
Packit |
4cd534 |
foldCompressStreamWithInput chunk end = \s lbs ->
|
|
Packit |
4cd534 |
runST (fold s (L.toChunks lbs))
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
fold (CompressInputRequired next) [] =
|
|
Packit |
4cd534 |
next S.empty >>= \strm -> fold strm []
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (CompressInputRequired next) (inchunk:inchunks) =
|
|
Packit |
4cd534 |
next inchunk >>= \s -> fold s inchunks
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold (CompressOutputAvailable outchunk next) inchunks = do
|
|
Packit |
4cd534 |
r <- next >>= \s -> fold s inchunks
|
|
Packit |
4cd534 |
return $ chunk outchunk r
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fold CompressStreamEnd _inchunks =
|
|
Packit |
4cd534 |
return end
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Compress a data stream provided as a lazy 'L.ByteString'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- There are no expected error conditions. All input data streams are valid. It
|
|
Packit |
4cd534 |
-- is possible for unexpected errors to occur, such as running out of memory,
|
|
Packit |
4cd534 |
-- or finding the wrong version of the zlib C library, these are thrown as
|
|
Packit |
4cd534 |
-- exceptions.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
compress :: Stream.Format -> CompressParams -> L.ByteString -> L.ByteString
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Incremental compression in the 'ST' monad. Using 'ST' makes it possible
|
|
Packit |
4cd534 |
-- to write pure /lazy/ functions while making use of incremental compression.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
compressST :: Stream.Format -> CompressParams -> CompressStream (ST s)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Incremental compression in the 'IO' monad.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
compressIO :: Stream.Format -> CompressParams -> CompressStream IO
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
compress format params = foldCompressStreamWithInput
|
|
Packit |
4cd534 |
L.Chunk L.Empty
|
|
Packit |
4cd534 |
(compressStreamST format params)
|
|
Packit |
4cd534 |
compressST format params = compressStreamST format params
|
|
Packit |
4cd534 |
compressIO format params = compressStreamIO format params
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
compressStream :: Stream.Format -> CompressParams -> S.ByteString
|
|
Packit |
4cd534 |
-> Stream (CompressStream Stream)
|
|
Packit |
4cd534 |
compressStream format (CompressParams compLevel method bits memLevel
|
|
Packit |
4cd534 |
strategy initChunkSize mdict) =
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
\chunk -> do
|
|
Packit |
4cd534 |
Stream.deflateInit format compLevel method bits memLevel strategy
|
|
Packit |
4cd534 |
setDictionary mdict
|
|
Packit |
4cd534 |
case chunk of
|
|
Packit |
4cd534 |
_ | S.null chunk ->
|
|
Packit |
4cd534 |
fillBuffers 20 --gzip header is 20 bytes, others even smaller
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
S.PS inFPtr offset length -> do
|
|
Packit |
4cd534 |
Stream.pushInputBuffer inFPtr offset length
|
|
Packit |
4cd534 |
fillBuffers initChunkSize
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
-- we flick between two states:
|
|
Packit |
4cd534 |
-- * where one or other buffer is empty
|
|
Packit |
4cd534 |
-- - in which case we refill one or both
|
|
Packit |
4cd534 |
-- * where both buffers are non-empty
|
|
Packit |
4cd534 |
-- - in which case we compress until a buffer is empty
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fillBuffers :: Int -> Stream (CompressStream Stream)
|
|
Packit |
4cd534 |
fillBuffers outChunkSize = do
|
|
Packit |
4cd534 |
#ifdef DEBUG
|
|
Packit |
4cd534 |
Stream.consistencyCheck
|
|
Packit |
4cd534 |
#endif
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- in this state there are two possabilities:
|
|
Packit |
4cd534 |
-- * no outbut buffer space is available
|
|
Packit |
4cd534 |
-- - in which case we must make more available
|
|
Packit |
4cd534 |
-- * no input buffer is available
|
|
Packit |
4cd534 |
-- - in which case we must supply more
|
|
Packit |
4cd534 |
inputBufferEmpty <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
outputBufferFull <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
assert (inputBufferEmpty || outputBufferFull) $ return ()
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
when outputBufferFull $ do
|
|
Packit |
4cd534 |
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
|
|
Packit |
4cd534 |
Stream.pushOutputBuffer outFPtr 0 outChunkSize
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
if inputBufferEmpty
|
|
Packit |
4cd534 |
then return $ CompressInputRequired $ \chunk ->
|
|
Packit |
4cd534 |
case chunk of
|
|
Packit |
4cd534 |
_ | S.null chunk -> drainBuffers True
|
|
Packit |
4cd534 |
S.PS inFPtr offset length -> do
|
|
Packit |
4cd534 |
Stream.pushInputBuffer inFPtr offset length
|
|
Packit |
4cd534 |
drainBuffers False
|
|
Packit |
4cd534 |
else drainBuffers False
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
drainBuffers :: Bool -> Stream (CompressStream Stream)
|
|
Packit |
4cd534 |
drainBuffers lastChunk = do
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
inputBufferEmpty' <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
outputBufferFull' <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
assert(not outputBufferFull'
|
|
Packit |
4cd534 |
&& (lastChunk || not inputBufferEmpty')) $ return ()
|
|
Packit |
4cd534 |
-- this invariant guarantees we can always make forward progress
|
|
Packit |
4cd534 |
-- and that therefore a BufferError is impossible
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
let flush = if lastChunk then Stream.Finish else Stream.NoFlush
|
|
Packit |
4cd534 |
status <- Stream.deflate flush
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
case status of
|
|
Packit |
4cd534 |
Stream.Ok -> do
|
|
Packit |
4cd534 |
outputBufferFull <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
if outputBufferFull
|
|
Packit |
4cd534 |
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
|
|
Packit |
4cd534 |
let chunk = S.PS outFPtr offset length
|
|
Packit |
4cd534 |
return $ CompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
fillBuffers defaultCompressBufferSize
|
|
Packit |
4cd534 |
else do fillBuffers defaultCompressBufferSize
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
Stream.StreamEnd -> do
|
|
Packit |
4cd534 |
inputBufferEmpty <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
assert inputBufferEmpty $ return ()
|
|
Packit |
4cd534 |
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
|
|
Packit |
4cd534 |
if outputBufferBytesAvailable > 0
|
|
Packit |
4cd534 |
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
|
|
Packit |
4cd534 |
let chunk = S.PS outFPtr offset length
|
|
Packit |
4cd534 |
Stream.finalise
|
|
Packit |
4cd534 |
return $ CompressOutputAvailable chunk (return CompressStreamEnd)
|
|
Packit |
4cd534 |
else do Stream.finalise
|
|
Packit |
4cd534 |
return CompressStreamEnd
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
Stream.Error code msg -> case code of
|
|
Packit |
4cd534 |
Stream.BufferError -> fail "BufferError should be impossible!"
|
|
Packit |
4cd534 |
Stream.NeedDict _ -> fail "NeedDict is impossible!"
|
|
Packit |
4cd534 |
_ -> fail msg
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- Set the custom dictionary, if we were provided with one
|
|
Packit |
4cd534 |
-- and if the format supports it (zlib and raw, not gzip).
|
|
Packit |
4cd534 |
setDictionary :: Maybe S.ByteString -> Stream ()
|
|
Packit |
4cd534 |
setDictionary (Just dict)
|
|
Packit |
4cd534 |
| Stream.formatSupportsDictionary format = do
|
|
Packit |
4cd534 |
status <- Stream.deflateSetDictionary dict
|
|
Packit |
4cd534 |
case status of
|
|
Packit |
4cd534 |
Stream.Ok -> return ()
|
|
Packit |
4cd534 |
Stream.Error _ msg -> fail msg
|
|
Packit |
4cd534 |
_ -> fail "error when setting deflate dictionary"
|
|
Packit |
4cd534 |
setDictionary _ = return ()
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Decompress a data stream provided as a lazy 'L.ByteString'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
-- It will throw an exception if any error is encountered in the input data.
|
|
Packit |
4cd534 |
-- If you need more control over error handling then use one the incremental
|
|
Packit |
4cd534 |
-- versions, 'decompressST' or 'decompressIO'.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
decompress :: Stream.Format -> DecompressParams -> L.ByteString -> L.ByteString
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Incremental decompression in the 'ST' monad. Using 'ST' makes it possible
|
|
Packit |
4cd534 |
-- to write pure /lazy/ functions while making use of incremental decompression.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
decompressST :: Stream.Format -> DecompressParams -> DecompressStream (ST s)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- | Incremental decompression in the 'IO' monad.
|
|
Packit |
4cd534 |
--
|
|
Packit |
4cd534 |
decompressIO :: Stream.Format -> DecompressParams -> DecompressStream IO
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
decompress format params = foldDecompressStreamWithInput
|
|
Packit |
4cd534 |
L.Chunk (const L.Empty) throw
|
|
Packit |
4cd534 |
(decompressStreamST format params)
|
|
Packit |
4cd534 |
decompressST format params = decompressStreamST format params
|
|
Packit |
4cd534 |
decompressIO format params = decompressStreamIO format params
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
decompressStream :: Stream.Format -> DecompressParams
|
|
Packit |
4cd534 |
-> Bool -> S.ByteString
|
|
Packit |
4cd534 |
-> Stream (DecompressStream Stream)
|
|
Packit |
4cd534 |
decompressStream format (DecompressParams bits initChunkSize mdict allMembers)
|
|
Packit |
4cd534 |
resume =
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
\chunk -> do
|
|
Packit |
4cd534 |
inputBufferEmpty <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
outputBufferFull <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
assert inputBufferEmpty $
|
|
Packit |
4cd534 |
if resume then assert (format == Stream.gzipFormat && allMembers) $
|
|
Packit |
4cd534 |
Stream.inflateReset
|
|
Packit |
4cd534 |
else assert outputBufferFull $
|
|
Packit |
4cd534 |
Stream.inflateInit format bits
|
|
Packit |
4cd534 |
case chunk of
|
|
Packit |
4cd534 |
_ | S.null chunk -> do
|
|
Packit |
4cd534 |
-- special case to avoid demanding more input again
|
|
Packit |
4cd534 |
-- always an error anyway
|
|
Packit |
4cd534 |
when outputBufferFull $ do
|
|
Packit |
4cd534 |
let outChunkSize = 1
|
|
Packit |
4cd534 |
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
|
|
Packit |
4cd534 |
Stream.pushOutputBuffer outFPtr 0 outChunkSize
|
|
Packit |
4cd534 |
drainBuffers True
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
S.PS inFPtr offset length -> do
|
|
Packit |
4cd534 |
Stream.pushInputBuffer inFPtr offset length
|
|
Packit |
4cd534 |
-- Normally we start with no output buffer (so counts as full) but
|
|
Packit |
4cd534 |
-- if we're resuming then we'll usually still have output buffer
|
|
Packit |
4cd534 |
-- space available
|
|
Packit |
4cd534 |
assert (if not resume then outputBufferFull else True) $ return ()
|
|
Packit |
4cd534 |
if outputBufferFull
|
|
Packit |
4cd534 |
then fillBuffers initChunkSize
|
|
Packit |
4cd534 |
else drainBuffers False
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
-- we flick between two states:
|
|
Packit |
4cd534 |
-- * where one or other buffer is empty
|
|
Packit |
4cd534 |
-- - in which case we refill one or both
|
|
Packit |
4cd534 |
-- * where both buffers are non-empty
|
|
Packit |
4cd534 |
-- - in which case we compress until a buffer is empty
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
fillBuffers :: Int
|
|
Packit |
4cd534 |
-> Stream (DecompressStream Stream)
|
|
Packit |
4cd534 |
fillBuffers outChunkSize = do
|
|
Packit |
4cd534 |
#ifdef DEBUG
|
|
Packit |
4cd534 |
Stream.consistencyCheck
|
|
Packit |
4cd534 |
#endif
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- in this state there are two possabilities:
|
|
Packit |
4cd534 |
-- * no outbut buffer space is available
|
|
Packit |
4cd534 |
-- - in which case we must make more available
|
|
Packit |
4cd534 |
-- * no input buffer is available
|
|
Packit |
4cd534 |
-- - in which case we must supply more
|
|
Packit |
4cd534 |
inputBufferEmpty <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
outputBufferFull <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
assert (inputBufferEmpty || outputBufferFull) $ return ()
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
when outputBufferFull $ do
|
|
Packit |
4cd534 |
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
|
|
Packit |
4cd534 |
Stream.pushOutputBuffer outFPtr 0 outChunkSize
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
if inputBufferEmpty
|
|
Packit |
4cd534 |
then return $ DecompressInputRequired $ \chunk ->
|
|
Packit |
4cd534 |
case chunk of
|
|
Packit |
4cd534 |
_ | S.null chunk -> drainBuffers True
|
|
Packit |
4cd534 |
S.PS inFPtr offset length -> do
|
|
Packit |
4cd534 |
Stream.pushInputBuffer inFPtr offset length
|
|
Packit |
4cd534 |
drainBuffers False
|
|
Packit |
4cd534 |
else drainBuffers False
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
drainBuffers :: Bool -> Stream (DecompressStream Stream)
|
|
Packit |
4cd534 |
drainBuffers lastChunk = do
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
inputBufferEmpty' <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
outputBufferFull' <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
assert(not outputBufferFull'
|
|
Packit |
4cd534 |
&& (lastChunk || not inputBufferEmpty')) $ return ()
|
|
Packit |
4cd534 |
-- this invariant guarantees we can always make forward progress or at
|
|
Packit |
4cd534 |
-- least if a BufferError does occur that it must be due to a premature EOF
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
status <- Stream.inflate Stream.NoFlush
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
case status of
|
|
Packit |
4cd534 |
Stream.Ok -> do
|
|
Packit |
4cd534 |
outputBufferFull <- Stream.outputBufferFull
|
|
Packit |
4cd534 |
if outputBufferFull
|
|
Packit |
4cd534 |
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
|
|
Packit |
4cd534 |
let chunk = S.PS outFPtr offset length
|
|
Packit |
4cd534 |
return $ DecompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
fillBuffers defaultDecompressBufferSize
|
|
Packit |
4cd534 |
else do fillBuffers defaultDecompressBufferSize
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
Stream.StreamEnd -> do
|
|
Packit |
4cd534 |
-- The decompressor tells us we're done.
|
|
Packit |
4cd534 |
-- Note that there may be input bytes still available if the stream is
|
|
Packit |
4cd534 |
-- embeded in some other data stream, so we return any trailing data.
|
|
Packit |
4cd534 |
inputBufferEmpty <- Stream.inputBufferEmpty
|
|
Packit |
4cd534 |
if inputBufferEmpty
|
|
Packit |
4cd534 |
then do finish (DecompressStreamEnd S.empty)
|
|
Packit |
4cd534 |
else do (inFPtr, offset, length) <- Stream.popRemainingInputBuffer
|
|
Packit |
4cd534 |
let inchunk = S.PS inFPtr offset length
|
|
Packit |
4cd534 |
finish (DecompressStreamEnd inchunk)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
Stream.Error code msg -> case code of
|
|
Packit |
4cd534 |
Stream.BufferError -> finish (DecompressStreamError TruncatedInput)
|
|
Packit |
4cd534 |
Stream.NeedDict adler -> do
|
|
Packit |
4cd534 |
err <- setDictionary adler mdict
|
|
Packit |
4cd534 |
case err of
|
|
Packit |
4cd534 |
Just streamErr -> finish streamErr
|
|
Packit |
4cd534 |
Nothing -> drainBuffers lastChunk
|
|
Packit |
4cd534 |
Stream.DataError -> finish (DecompressStreamError (DataFormatError msg))
|
|
Packit |
4cd534 |
_ -> fail msg
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
-- Note even if we end with an error we still try to flush the last chunk if
|
|
Packit |
4cd534 |
-- there is one. The user just has to decide what they want to trust.
|
|
Packit |
4cd534 |
finish end = do
|
|
Packit |
4cd534 |
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
|
|
Packit |
4cd534 |
if outputBufferBytesAvailable > 0
|
|
Packit |
4cd534 |
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
|
|
Packit |
4cd534 |
return (DecompressOutputAvailable (S.PS outFPtr offset length) (return end))
|
|
Packit |
4cd534 |
else return end
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
setDictionary :: Stream.DictionaryHash -> Maybe S.ByteString
|
|
Packit |
4cd534 |
-> Stream (Maybe (DecompressStream Stream))
|
|
Packit |
4cd534 |
setDictionary _adler Nothing =
|
|
Packit |
4cd534 |
return $ Just (DecompressStreamError DictionaryRequired)
|
|
Packit |
4cd534 |
setDictionary _adler (Just dict) = do
|
|
Packit |
4cd534 |
status <- Stream.inflateSetDictionary dict
|
|
Packit |
4cd534 |
case status of
|
|
Packit |
4cd534 |
Stream.Ok -> return Nothing
|
|
Packit |
4cd534 |
Stream.Error Stream.DataError _ ->
|
|
Packit |
4cd534 |
return $ Just (DecompressStreamError DictionaryMismatch)
|
|
Packit |
4cd534 |
_ -> fail "error when setting inflate dictionary"
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
------------------------------------------------------------------------------
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
mkStateST :: ST s (Stream.State s)
|
|
Packit |
4cd534 |
mkStateIO :: IO (Stream.State RealWorld)
|
|
Packit |
4cd534 |
mkStateST = strictToLazyST Stream.mkState
|
|
Packit |
4cd534 |
mkStateIO = stToIO Stream.mkState
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
runStreamST :: Stream a -> Stream.State s -> ST s (a, Stream.State s)
|
|
Packit |
4cd534 |
runStreamIO :: Stream a -> Stream.State RealWorld -> IO (a, Stream.State RealWorld)
|
|
Packit |
4cd534 |
runStreamST strm zstate = strictToLazyST (Unsafe.unsafeIOToST noDuplicate >> Stream.runStream strm zstate)
|
|
Packit |
4cd534 |
runStreamIO strm zstate = stToIO (Stream.runStream strm zstate)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
compressStreamIO :: Stream.Format -> CompressParams -> CompressStream IO
|
|
Packit |
4cd534 |
compressStreamIO format params =
|
|
Packit |
4cd534 |
CompressInputRequired {
|
|
Packit |
4cd534 |
compressSupplyInput = \chunk -> do
|
|
Packit |
4cd534 |
zstate <- mkStateIO
|
|
Packit |
4cd534 |
let next = compressStream format params
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO (next chunk) zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
go :: CompressStream Stream -> Stream.State RealWorld -> CompressStream IO
|
|
Packit |
4cd534 |
go (CompressInputRequired next) zstate =
|
|
Packit |
4cd534 |
CompressInputRequired {
|
|
Packit |
4cd534 |
compressSupplyInput = \chunk -> do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO (next chunk) zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (CompressOutputAvailable chunk next) zstate =
|
|
Packit |
4cd534 |
CompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO next zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go CompressStreamEnd _ = CompressStreamEnd
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
compressStreamST :: Stream.Format -> CompressParams -> CompressStream (ST s)
|
|
Packit |
4cd534 |
compressStreamST format params =
|
|
Packit |
4cd534 |
CompressInputRequired {
|
|
Packit |
4cd534 |
compressSupplyInput = \chunk -> do
|
|
Packit |
4cd534 |
zstate <- mkStateST
|
|
Packit |
4cd534 |
let next = compressStream format params
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST (next chunk) zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
go :: CompressStream Stream -> Stream.State s -> CompressStream (ST s)
|
|
Packit |
4cd534 |
go (CompressInputRequired next) zstate =
|
|
Packit |
4cd534 |
CompressInputRequired {
|
|
Packit |
4cd534 |
compressSupplyInput = \chunk -> do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST (next chunk) zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
}
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (CompressOutputAvailable chunk next) zstate =
|
|
Packit |
4cd534 |
CompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST next zstate
|
|
Packit |
4cd534 |
return (go strm' zstate')
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go CompressStreamEnd _ = CompressStreamEnd
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
decompressStreamIO :: Stream.Format -> DecompressParams -> DecompressStream IO
|
|
Packit |
4cd534 |
decompressStreamIO format params =
|
|
Packit |
4cd534 |
DecompressInputRequired $ \chunk -> do
|
|
Packit |
4cd534 |
zstate <- mkStateIO
|
|
Packit |
4cd534 |
let next = decompressStream format params False
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO (next chunk) zstate
|
|
Packit |
4cd534 |
go strm' zstate' (S.null chunk)
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
go :: DecompressStream Stream -> Stream.State RealWorld -> Bool
|
|
Packit |
4cd534 |
-> IO (DecompressStream IO)
|
|
Packit |
4cd534 |
go (DecompressInputRequired next) zstate !_ =
|
|
Packit |
4cd534 |
return $ DecompressInputRequired $ \chunk -> do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO (next chunk) zstate
|
|
Packit |
4cd534 |
go strm' zstate' (S.null chunk)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressOutputAvailable chunk next) zstate !eof =
|
|
Packit |
4cd534 |
return $ DecompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO next zstate
|
|
Packit |
4cd534 |
go strm' zstate' eof
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressStreamEnd unconsumed) zstate !eof
|
|
Packit |
4cd534 |
| format == Stream.gzipFormat
|
|
Packit |
4cd534 |
, decompressAllMembers params
|
|
Packit |
4cd534 |
, not eof = tryFollowingStream unconsumed zstate
|
|
Packit |
4cd534 |
| otherwise = finaliseStreamEnd unconsumed zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressStreamError err) zstate !_ = finaliseStreamError err zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
tryFollowingStream :: S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO)
|
|
Packit |
4cd534 |
tryFollowingStream chunk zstate = case S.length chunk of
|
|
Packit |
4cd534 |
0 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd S.empty zstate
|
|
Packit |
4cd534 |
1 | S.head chunk' /= 0x1f
|
|
Packit |
4cd534 |
-> finaliseStreamEnd chunk' zstate
|
|
Packit |
4cd534 |
1 -> return $ DecompressInputRequired $ \chunk'' -> case S.length chunk'' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd chunk' zstate
|
|
Packit |
4cd534 |
_ -> checkHeaderSplit (S.head chunk') chunk'' zstate
|
|
Packit |
4cd534 |
_ -> checkHeader chunk' zstate
|
|
Packit |
4cd534 |
1 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd chunk zstate
|
|
Packit |
4cd534 |
_ -> checkHeaderSplit (S.head chunk) chunk' zstate
|
|
Packit |
4cd534 |
_ -> checkHeader chunk zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
checkHeaderSplit :: Word8 -> S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO)
|
|
Packit |
4cd534 |
checkHeaderSplit 0x1f chunk zstate
|
|
Packit |
4cd534 |
| S.head chunk == 0x8b = do
|
|
Packit |
4cd534 |
let resume = decompressStream format params True (S.pack [0x1f, 0x8b])
|
|
Packit |
4cd534 |
if S.length chunk > 1
|
|
Packit |
4cd534 |
then do
|
|
Packit |
4cd534 |
-- have to handle the remaining data in this chunk
|
|
Packit |
4cd534 |
(DecompressInputRequired next, zstate') <- runStreamIO resume zstate
|
|
Packit |
4cd534 |
(strm', zstate'') <- runStreamIO (next (S.tail chunk)) zstate'
|
|
Packit |
4cd534 |
go strm' zstate'' False
|
|
Packit |
4cd534 |
else do
|
|
Packit |
4cd534 |
-- subtle special case when the chunk tail is empty
|
|
Packit |
4cd534 |
-- yay for QC tests
|
|
Packit |
4cd534 |
(strm, zstate') <- runStreamIO resume zstate
|
|
Packit |
4cd534 |
go strm zstate' False
|
|
Packit |
4cd534 |
checkHeaderSplit byte chunk zstate =
|
|
Packit |
4cd534 |
finaliseStreamEnd (S.cons byte chunk) zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
checkHeader :: S.ByteString -> Stream.State RealWorld -> IO (DecompressStream IO)
|
|
Packit |
4cd534 |
checkHeader chunk zstate
|
|
Packit |
4cd534 |
| S.index chunk 0 == 0x1f
|
|
Packit |
4cd534 |
, S.index chunk 1 == 0x8b = do
|
|
Packit |
4cd534 |
let resume = decompressStream format params True chunk
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamIO resume zstate
|
|
Packit |
4cd534 |
go strm' zstate' False
|
|
Packit |
4cd534 |
checkHeader chunk zstate = finaliseStreamEnd chunk zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
finaliseStreamEnd unconsumed zstate = do
|
|
Packit |
4cd534 |
_ <- runStreamIO Stream.finalise zstate
|
|
Packit |
4cd534 |
return (DecompressStreamEnd unconsumed)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
finaliseStreamError err zstate = do
|
|
Packit |
4cd534 |
_ <- runStreamIO Stream.finalise zstate
|
|
Packit |
4cd534 |
return (DecompressStreamError err)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
decompressStreamST :: Stream.Format -> DecompressParams -> DecompressStream (ST s)
|
|
Packit |
4cd534 |
decompressStreamST format params =
|
|
Packit |
4cd534 |
DecompressInputRequired $ \chunk -> do
|
|
Packit |
4cd534 |
zstate <- mkStateST
|
|
Packit |
4cd534 |
let next = decompressStream format params False
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST (next chunk) zstate
|
|
Packit |
4cd534 |
go strm' zstate' (S.null chunk)
|
|
Packit |
4cd534 |
where
|
|
Packit |
4cd534 |
go :: DecompressStream Stream -> Stream.State s -> Bool
|
|
Packit |
4cd534 |
-> ST s (DecompressStream (ST s))
|
|
Packit |
4cd534 |
go (DecompressInputRequired next) zstate !_ =
|
|
Packit |
4cd534 |
return $ DecompressInputRequired $ \chunk -> do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST (next chunk) zstate
|
|
Packit |
4cd534 |
go strm' zstate' (S.null chunk)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressOutputAvailable chunk next) zstate !eof =
|
|
Packit |
4cd534 |
return $ DecompressOutputAvailable chunk $ do
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST next zstate
|
|
Packit |
4cd534 |
go strm' zstate' eof
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressStreamEnd unconsumed) zstate !eof
|
|
Packit |
4cd534 |
| format == Stream.gzipFormat
|
|
Packit |
4cd534 |
, decompressAllMembers params
|
|
Packit |
4cd534 |
, not eof = tryFollowingStream unconsumed zstate
|
|
Packit |
4cd534 |
| otherwise = finaliseStreamEnd unconsumed zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
go (DecompressStreamError err) zstate !_ = finaliseStreamError err zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
tryFollowingStream :: S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s))
|
|
Packit |
4cd534 |
tryFollowingStream chunk zstate =
|
|
Packit |
4cd534 |
case S.length chunk of
|
|
Packit |
4cd534 |
0 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd S.empty zstate
|
|
Packit |
4cd534 |
1 | S.head chunk' /= 0x1f
|
|
Packit |
4cd534 |
-> finaliseStreamEnd chunk' zstate
|
|
Packit |
4cd534 |
1 -> return $ DecompressInputRequired $ \chunk'' -> case S.length chunk'' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd chunk' zstate
|
|
Packit |
4cd534 |
_ -> checkHeaderSplit (S.head chunk') chunk'' zstate
|
|
Packit |
4cd534 |
_ -> checkHeader chunk' zstate
|
|
Packit |
4cd534 |
1 -> return $ DecompressInputRequired $ \chunk' -> case S.length chunk' of
|
|
Packit |
4cd534 |
0 -> finaliseStreamEnd chunk zstate
|
|
Packit |
4cd534 |
_ -> checkHeaderSplit (S.head chunk) chunk' zstate
|
|
Packit |
4cd534 |
_ -> checkHeader chunk zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
checkHeaderSplit :: Word8 -> S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s))
|
|
Packit |
4cd534 |
checkHeaderSplit 0x1f chunk zstate
|
|
Packit |
4cd534 |
| S.head chunk == 0x8b = do
|
|
Packit |
4cd534 |
let resume = decompressStream format params True (S.pack [0x1f, 0x8b])
|
|
Packit |
4cd534 |
if S.length chunk > 1
|
|
Packit |
4cd534 |
then do
|
|
Packit |
4cd534 |
-- have to handle the remaining data in this chunk
|
|
Packit |
4cd534 |
(DecompressInputRequired next, zstate') <- runStreamST resume zstate
|
|
Packit |
4cd534 |
(strm', zstate'') <- runStreamST (next (S.tail chunk)) zstate'
|
|
Packit |
4cd534 |
go strm' zstate'' False
|
|
Packit |
4cd534 |
else do
|
|
Packit |
4cd534 |
-- subtle special case when the chunk tail is empty
|
|
Packit |
4cd534 |
-- yay for QC tests
|
|
Packit |
4cd534 |
(strm, zstate') <- runStreamST resume zstate
|
|
Packit |
4cd534 |
go strm zstate' False
|
|
Packit |
4cd534 |
checkHeaderSplit byte chunk zstate =
|
|
Packit |
4cd534 |
finaliseStreamEnd (S.cons byte chunk) zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
checkHeader :: S.ByteString -> Stream.State s -> ST s (DecompressStream (ST s))
|
|
Packit |
4cd534 |
checkHeader chunk zstate
|
|
Packit |
4cd534 |
| S.index chunk 0 == 0x1f
|
|
Packit |
4cd534 |
, S.index chunk 1 == 0x8b = do
|
|
Packit |
4cd534 |
let resume = decompressStream format params True chunk
|
|
Packit |
4cd534 |
(strm', zstate') <- runStreamST resume zstate
|
|
Packit |
4cd534 |
go strm' zstate' False
|
|
Packit |
4cd534 |
checkHeader chunk zstate = finaliseStreamEnd chunk zstate
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
finaliseStreamEnd unconsumed zstate = do
|
|
Packit |
4cd534 |
_ <- runStreamST Stream.finalise zstate
|
|
Packit |
4cd534 |
return (DecompressStreamEnd unconsumed)
|
|
Packit |
4cd534 |
|
|
Packit |
4cd534 |
finaliseStreamError err zstate = do
|
|
Packit |
4cd534 |
_ <- runStreamST Stream.finalise zstate
|
|
Packit |
4cd534 |
return (DecompressStreamError err)
|