module Codec.Compression.BZip.Internal (
compress,
CompressParams(..),
defaultCompressParams,
decompress,
DecompressParams(..),
defaultDecompressParams,
Stream.BlockSize(..),
Stream.WorkFactor(..),
Stream.MemoryLevel(..),
) where
import Prelude hiding (length)
import Control.Monad (when)
import Control.Exception (assert)
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Internal as L
import qualified Data.ByteString.Internal as S
import qualified Codec.Compression.BZip.Stream as Stream
import Codec.Compression.BZip.Stream (Stream)
data CompressParams = CompressParams {
compressBlockSize :: Stream.BlockSize,
compressWorkFactor :: Stream.WorkFactor,
compressBufferSize :: Int
}
data DecompressParams = DecompressParams {
decompressMemoryLevel :: Stream.MemoryLevel,
decompressBufferSize :: Int
}
defaultCompressParams :: CompressParams
defaultCompressParams = CompressParams {
compressBlockSize = Stream.DefaultBlockSize,
compressWorkFactor = Stream.DefaultWorkFactor,
compressBufferSize = defaultCompressBufferSize
}
defaultDecompressParams :: DecompressParams
defaultDecompressParams = DecompressParams {
decompressMemoryLevel = Stream.DefaultMemoryLevel,
decompressBufferSize = defaultDecompressBufferSize
}
defaultCompressBufferSize, defaultDecompressBufferSize :: Int
defaultCompressBufferSize = 16 * 1024 L.chunkOverhead
defaultDecompressBufferSize = 32 * 1024 L.chunkOverhead
compress
:: CompressParams
-> L.ByteString
-> L.ByteString
compress (CompressParams blockSize workFactor initChunkSize) input =
L.fromChunks $ Stream.run $ do
Stream.compressInit blockSize Stream.Silent workFactor
case L.toChunks input of
[] -> fillBuffers 14 []
S.PS inFPtr offset length : chunks -> do
Stream.pushInputBuffer inFPtr offset length
fillBuffers initChunkSize chunks
where
fillBuffers :: Int
-> [S.ByteString]
-> Stream [S.ByteString]
fillBuffers outChunkSize inChunks = do
Stream.consistencyCheck
inputBufferEmpty <- Stream.inputBufferEmpty
outputBufferFull <- Stream.outputBufferFull
assert (inputBufferEmpty || outputBufferFull) $ return ()
when outputBufferFull $ do
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
Stream.pushOutputBuffer outFPtr 0 outChunkSize
if inputBufferEmpty
then case inChunks of
[] -> drainBuffers []
S.PS inFPtr offset length : inChunks' -> do
Stream.pushInputBuffer inFPtr offset length
drainBuffers inChunks'
else drainBuffers inChunks
drainBuffers ::
[S.ByteString]
-> Stream [S.ByteString]
drainBuffers inChunks = do
inputBufferEmpty' <- Stream.inputBufferEmpty
outputBufferFull' <- Stream.outputBufferFull
assert(not outputBufferFull'
&& (null inChunks || not inputBufferEmpty')) $ return ()
let action = if null inChunks then Stream.Finish else Stream.Run
status <- Stream.compress action
case status of
Stream.Ok -> do
outputBufferFull <- Stream.outputBufferFull
if outputBufferFull
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
outChunks <- Stream.unsafeInterleave
(fillBuffers defaultCompressBufferSize inChunks)
return (S.PS outFPtr offset length : outChunks)
else do fillBuffers defaultCompressBufferSize inChunks
Stream.StreamEnd -> do
inputBufferEmpty <- Stream.inputBufferEmpty
assert inputBufferEmpty $ return ()
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
if outputBufferBytesAvailable > 0
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
Stream.finalise
return [S.PS outFPtr offset length]
else do Stream.finalise
return []
decompress
:: DecompressParams
-> L.ByteString
-> L.ByteString
decompress (DecompressParams memLevel initChunkSize) input =
L.fromChunks $ Stream.run $ do
Stream.decompressInit Stream.Silent memLevel
case L.toChunks input of
[] -> fillBuffers 4 []
S.PS inFPtr offset length : chunks -> do
Stream.pushInputBuffer inFPtr offset length
fillBuffers initChunkSize chunks
where
fillBuffers :: Int
-> [S.ByteString]
-> Stream [S.ByteString]
fillBuffers outChunkSize inChunks = do
inputBufferEmpty <- Stream.inputBufferEmpty
outputBufferFull <- Stream.outputBufferFull
assert (inputBufferEmpty || outputBufferFull) $ return ()
when outputBufferFull $ do
outFPtr <- Stream.unsafeLiftIO (S.mallocByteString outChunkSize)
Stream.pushOutputBuffer outFPtr 0 outChunkSize
if inputBufferEmpty
then case inChunks of
[] -> drainBuffers []
S.PS inFPtr offset length : inChunks' -> do
Stream.pushInputBuffer inFPtr offset length
drainBuffers inChunks'
else drainBuffers inChunks
drainBuffers ::
[S.ByteString]
-> Stream [S.ByteString]
drainBuffers inChunks = do
inputBufferEmpty' <- Stream.inputBufferEmpty
outputBufferFull' <- Stream.outputBufferFull
assert(not outputBufferFull'
&& (null inChunks || not inputBufferEmpty')) $ return ()
status <- Stream.decompress
case status of
Stream.Ok -> do
outputBufferFull <- Stream.outputBufferFull
if outputBufferFull
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
outChunks <- Stream.unsafeInterleave
(fillBuffers defaultDecompressBufferSize inChunks)
return (S.PS outFPtr offset length : outChunks)
else do
inputBufferEmpty <- Stream.inputBufferEmpty
if inputBufferEmpty && null inChunks
then fail "premature end of compressed stream"
else fillBuffers defaultDecompressBufferSize inChunks
Stream.StreamEnd -> do
outputBufferBytesAvailable <- Stream.outputBufferBytesAvailable
if outputBufferBytesAvailable > 0
then do (outFPtr, offset, length) <- Stream.popOutputBuffer
Stream.finalise
return [S.PS outFPtr offset length]
else do Stream.finalise
return []