module Data.Conduit.Zlib (
compress, decompress, gzip, ungzip,
compressFlush, decompressFlush,
WindowBits (..), defaultWindowBits
) where
import Codec.Zlib
import Data.Conduit hiding (unsafeLiftIO)
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, liftM)
import Control.Monad.Trans.Class (lift, MonadTrans)
gzip :: (MonadThrow m, MonadUnsafeIO m) => Conduit ByteString m ByteString
gzip = compress 1 (WindowBits 31)
ungzip :: (MonadUnsafeIO m, MonadThrow m) => Conduit 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
-> Conduit ByteString m ByteString
decompress =
helperDecompress (liftM (fmap Chunk) await) yield'
where
yield' Flush = return ()
yield' (Chunk bs) = yield bs
decompressFlush
:: (MonadUnsafeIO m, MonadThrow m)
=> WindowBits
-> Conduit (Flush ByteString) m (Flush ByteString)
decompressFlush = helperDecompress await yield
helperDecompress :: (Monad (t m), MonadUnsafeIO m, MonadThrow m, MonadTrans t)
=> t m (Maybe (Flush ByteString))
-> (Flush ByteString -> t m ())
-> WindowBits
-> t m ()
helperDecompress await' yield' config =
await' >>= maybe (return ()) start
where
start input = do
inf <- lift $ unsafeLiftIO $ initInflate config
push inf input
continue inf = await' >>= maybe (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 = do
chunk <- lift $ unsafeLiftIO $ finishInflate inf
unless (S.null chunk) $ yield' $ Chunk chunk
compress
:: (MonadUnsafeIO m, MonadThrow m)
=> Int
-> WindowBits
-> Conduit ByteString m ByteString
compress =
helperCompress (liftM (fmap Chunk) await) yield'
where
yield' Flush = return ()
yield' (Chunk bs) = yield bs
compressFlush
:: (MonadUnsafeIO m, MonadThrow m)
=> Int
-> WindowBits
-> Conduit (Flush ByteString) m (Flush ByteString)
compressFlush = helperCompress await yield
helperCompress :: (Monad (t m), MonadUnsafeIO m, MonadThrow m, MonadTrans t)
=> t m (Maybe (Flush ByteString))
-> (Flush ByteString -> t m ())
-> Int
-> WindowBits
-> t m ()
helperCompress await' yield' level config =
await' >>= maybe (return ()) start
where
start input = do
def <- lift $ unsafeLiftIO $ initDeflate level config
push def input
continue def = await' >>= maybe (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 = do
mchunk <- lift $ unsafeLiftIO $ finishDeflate def
case mchunk of
Nothing -> return ()
Just chunk -> yield' (Chunk chunk) >> close def