{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module System.IO.Streams.Zlib
(
gunzip
, decompress
, gzip
, compress
, gzipBuilder
, compressBuilder
, CompressionLevel(..)
, defaultCompressionLevel
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Data.IORef (newIORef, readIORef, writeIORef)
import Prelude hiding (read)
import Blaze.ByteString.Builder (fromByteString)
import Blaze.ByteString.Builder.Internal (Builder, defaultBufferSize, flush)
import Blaze.ByteString.Builder.Internal.Buffer (allocBuffer)
import Codec.Zlib (Deflate, Inflate, Popper, WindowBits (..), feedDeflate, feedInflate, finishDeflate, finishInflate, flushDeflate, flushInflate, initDeflate, initInflate)
import System.IO.Streams.Builder (unsafeBuilderStream)
import System.IO.Streams.Internal (InputStream, OutputStream, makeInputStream, makeOutputStream, read, write)
gzipBits :: WindowBits
gzipBits = WindowBits 31
compressBits :: WindowBits
compressBits = WindowBits 15
gunzip :: InputStream ByteString -> IO (InputStream ByteString)
gunzip input = initInflate gzipBits >>= inflate input
decompress :: InputStream ByteString -> IO (InputStream ByteString)
decompress input = initInflate compressBits >>= inflate input
data IS = Input
| Popper Popper
| Done
inflate :: InputStream ByteString -> Inflate -> IO (InputStream ByteString)
inflate input state = do
ref <- newIORef Input
makeInputStream $ stream ref
where
stream ref = go
where
go = readIORef ref >>= \st ->
case st of
Input -> read input >>= maybe eof chunk
Popper p -> pop p
Done -> return Nothing
eof = do
x <- finishInflate state
writeIORef ref Done
if (not $ S.null x)
then return $! Just x
else return Nothing
chunk s =
if S.null s
then do
out <- flushInflate state
return $! Just out
else feedInflate state s >>= \popper -> do
writeIORef ref $ Popper popper
pop popper
pop popper = popper >>= maybe backToInput (return . Just)
backToInput = writeIORef ref Input >> read input >>= maybe eof chunk
deflateBuilder :: OutputStream Builder
-> Deflate
-> IO (OutputStream Builder)
deflateBuilder stream state = do
zippedStr <- makeOutputStream bytestringStream >>=
\x -> deflate x state
unsafeBuilderStream (allocBuffer defaultBufferSize) zippedStr
where
bytestringStream x = write (fmap cvt x) stream
cvt s | S.null s = flush
| otherwise = fromByteString s
gzipBuilder :: CompressionLevel
-> OutputStream Builder
-> IO (OutputStream Builder)
gzipBuilder level output =
initDeflate (clamp level) gzipBits >>= deflateBuilder output
compressBuilder :: CompressionLevel
-> OutputStream Builder
-> IO (OutputStream Builder)
compressBuilder level output =
initDeflate (clamp level) compressBits >>= deflateBuilder output
deflate :: OutputStream ByteString
-> Deflate
-> IO (OutputStream ByteString)
deflate output state = makeOutputStream stream
where
stream Nothing = popAll (finishDeflate state) >> write Nothing output
stream (Just s) = do
if S.null s
then do
popAll (flushDeflate state)
write (Just S.empty) output
else feedDeflate state s >>= popAll
popAll popper = go
where
go = popper >>= maybe (return $! ()) (\s -> write (Just s) output >> go)
newtype CompressionLevel = CompressionLevel Int
deriving (Read, Eq, Show, Num)
defaultCompressionLevel :: CompressionLevel
defaultCompressionLevel = CompressionLevel 5
clamp :: CompressionLevel -> Int
clamp (CompressionLevel x) = min 9 (max x 0)
gzip :: CompressionLevel
-> OutputStream ByteString
-> IO (OutputStream ByteString)
gzip level output = initDeflate (clamp level) gzipBits >>= deflate output
compress :: CompressionLevel
-> OutputStream ByteString
-> IO (OutputStream ByteString)
compress level output = initDeflate (clamp level) compressBits >>=
deflate output