module Data.Conduit.Zlib (
compress, decompress, gzip, ungzip,
compressFlush, decompressFlush,
WindowBits (..), defaultWindowBits
) where
import Codec.Zlib
import Data.Conduit
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
gzip :: MonadUnsafeIO m => Conduit ByteString m ByteString
gzip = compress 1 (WindowBits 31)
ungzip :: MonadUnsafeIO m => Conduit ByteString m ByteString
ungzip = decompress (WindowBits 31)
decompress
:: MonadUnsafeIO m
=> WindowBits
-> Conduit ByteString m ByteString
decompress config = NeedInput
(\input -> ConduitM (do
inf <- unsafeLiftIO $ initInflate config
push inf input) (return ()))
Closed
where
push' inf x = ConduitM (push inf x) (return ())
push inf x = do
popper <- unsafeLiftIO $ feedInflate inf x
goPopper (push' inf) (close inf) id [] popper
close inf = flip SourceM (return ()) $ do
chunk <- unsafeLiftIO $ finishInflate inf
return $
if S.null chunk
then Closed
else Open Closed (return ()) chunk
decompressFlush
:: MonadUnsafeIO m
=> WindowBits
-> Conduit (Flush ByteString) m (Flush ByteString)
decompressFlush config = NeedInput
(\input -> flip ConduitM (return ()) $ do
inf <- unsafeLiftIO $ initInflate config
push inf input)
Closed
where
push' inf x = ConduitM (push inf x) (return ())
push inf (Chunk x) = do
popper <- unsafeLiftIO $ feedInflate inf x
goPopper (push' inf) (close inf) Chunk [] popper
push inf Flush = do
chunk <- unsafeLiftIO $ flushInflate inf
let next = HaveOutput
(NeedInput (push' inf) (close inf))
(return ())
Flush
return $
if S.null chunk
then next
else HaveOutput next (return ()) (Chunk chunk)
close inf = flip SourceM (return ()) $ do
chunk <- unsafeLiftIO $ finishInflate inf
return $
if S.null chunk
then Closed
else Open Closed (return ()) $ Chunk chunk
compress
:: MonadUnsafeIO m
=> Int
-> WindowBits
-> Conduit ByteString m ByteString
compress level config = NeedInput
(\input -> flip ConduitM (return ()) $ do
def <- unsafeLiftIO $ initDeflate level config
push def input) Closed
where
push' def input = ConduitM (push def input) (return ())
push def x = do
popper <- unsafeLiftIO $ feedDeflate def x
goPopper (push' def) (close def) id [] popper
close def = slurp $ unsafeLiftIO $ finishDeflate def
compressFlush
:: MonadUnsafeIO m
=> Int
-> WindowBits
-> Conduit (Flush ByteString) m (Flush ByteString)
compressFlush level config = NeedInput
(\input -> flip ConduitM (return ()) $ do
def <- unsafeLiftIO $ initDeflate level config
push def input) Closed
where
push' def input = ConduitM (push def input) (return ())
push def (Chunk x) = do
popper <- unsafeLiftIO $ feedDeflate def x
goPopper (push' def) (close def) Chunk [] popper
push def Flush = goPopper (push' def) (close def) Chunk [Flush] $ flushDeflate def
close def = flip SourceM (return ()) $ do
mchunk <- unsafeLiftIO $ finishDeflate def
return $ case mchunk of
Nothing -> Closed
Just chunk -> Open Closed (return ()) (Chunk chunk)
goPopper :: MonadUnsafeIO m
=> ConduitPush input m output
-> ConduitClose m output
-> (S.ByteString -> output)
-> [output]
-> Popper
-> m (Conduit input m output)
goPopper push close wrap final popper = do
mbs <- unsafeLiftIO popper
return $ case mbs of
Nothing ->
let go [] = NeedInput push close
go (x:xs) = HaveOutput (go xs) (return ()) x
in go final
Just bs -> HaveOutput (ConduitM (goPopper push close wrap final popper) (return ())) (return ()) (wrap bs)
slurp :: Monad m => m (Maybe a) -> Source m a
slurp pop = flip SourceM (return ()) $ do
x <- pop
return $ case x of
Nothing -> Closed
Just y -> Open (slurp pop) (return ()) y