module Data.Conduit.Zlib (
compress, decompress, gzip, ungzip,
compressFlush, decompressFlush,
WindowBits (..), defaultWindowBits
) where
import Codec.Zlib
import Data.Conduit hiding (unsafeLiftIO, Source, Sink, Conduit, Pipe)
import qualified Data.Conduit as C (unsafeLiftIO)
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
import Control.Exception (try)
import Control.Monad ((<=<), unless)
import Control.Monad.Trans.Class (lift)
gzip :: (MonadThrow m, MonadUnsafeIO m) => GInfConduit ByteString m ByteString
gzip = compress 1 (WindowBits 31)
ungzip :: (MonadUnsafeIO m, MonadThrow m) => GInfConduit ByteString m ByteString
ungzip = decompress (WindowBits 31)
unsafeLiftIO :: (MonadUnsafeIO m, MonadThrow m) => IO a -> m a
unsafeLiftIO =
either rethrow return <=< C.unsafeLiftIO . try
where
rethrow :: MonadThrow m => ZlibException -> m a
rethrow = monadThrow
decompress
:: (MonadUnsafeIO m, MonadThrow m)
=> WindowBits
-> GInfConduit ByteString m ByteString
decompress =
mapOutput unChunk . mapInput Chunk unChunk' . decompressFlush
where
unChunk Flush = S.empty
unChunk (Chunk bs) = bs
unChunk' Flush = Nothing
unChunk' (Chunk bs) = Just bs
decompressFlush
:: (MonadUnsafeIO m, MonadThrow m)
=> WindowBits
-> GInfConduit (Flush ByteString) m (Flush ByteString)
decompressFlush config =
awaitE >>= either return start
where
start input = do
inf <- lift $ unsafeLiftIO $ initInflate config
push inf input
continue inf = awaitE >>= either (close inf) (push inf)
goPopper popper = do
mbs <- lift $ unsafeLiftIO popper
case mbs of
Nothing -> return ()
Just bs -> yield (Chunk bs) >> goPopper popper
push inf (Chunk x) = do
popper <- lift $ unsafeLiftIO $ feedInflate inf x
goPopper popper
continue inf
push inf Flush = do
chunk <- lift $ unsafeLiftIO $ flushInflate inf
unless (S.null chunk) $ yield $ Chunk chunk
yield Flush
continue inf
close inf ret = do
chunk <- lift $ unsafeLiftIO $ finishInflate inf
unless (S.null chunk) $ yield $ Chunk chunk
return ret
compress
:: (MonadUnsafeIO m, MonadThrow m)
=> Int
-> WindowBits
-> GInfConduit ByteString m ByteString
compress level =
mapOutput unChunk . mapInput Chunk unChunk' . compressFlush level
where
unChunk Flush = S.empty
unChunk (Chunk bs) = bs
unChunk' Flush = Nothing
unChunk' (Chunk bs) = Just bs
compressFlush
:: (MonadUnsafeIO m, MonadThrow m)
=> Int
-> WindowBits
-> GInfConduit (Flush ByteString) m (Flush ByteString)
compressFlush level config =
awaitE >>= either return start
where
start input = do
def <- lift $ unsafeLiftIO $ initDeflate level config
push def input
continue def = awaitE >>= either (close def) (push def)
goPopper popper = do
mbs <- lift $ unsafeLiftIO popper
case mbs of
Nothing -> return ()
Just bs -> yield (Chunk bs) >> goPopper popper
push def (Chunk x) = do
popper <- lift $ unsafeLiftIO $ feedDeflate def x
goPopper popper
continue def
push def Flush = do
mchunk <- lift $ unsafeLiftIO $ flushDeflate def
maybe (return ()) (yield . Chunk) mchunk
yield Flush
continue def
close def ret = do
mchunk <- lift $ unsafeLiftIO $ finishDeflate def
case mchunk of
Nothing -> return ret
Just chunk -> yield (Chunk chunk) >> close def ret