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 -> PipeM (do
inf <- unsafeLiftIO $ initInflate config
push inf input) (return ()))
(Done Nothing ())
where
push' inf x = PipeM (push inf x) (return ())
push inf x = do
popper <- unsafeLiftIO $ feedInflate inf x
goPopper (push' inf) (close inf) id [] popper
close inf = flip PipeM (return ()) $ do
chunk <- unsafeLiftIO $ finishInflate inf
return $
if S.null chunk
then Done Nothing ()
else HaveOutput (Done Nothing ()) (return ()) chunk
decompressFlush
:: MonadUnsafeIO m
=> WindowBits
-> Conduit (Flush ByteString) m (Flush ByteString)
decompressFlush config = NeedInput
(\input -> flip PipeM (return ()) $ do
inf <- unsafeLiftIO $ initInflate config
push inf input)
(Done Nothing ())
where
push' inf x = PipeM (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 PipeM (return ()) $ do
chunk <- unsafeLiftIO $ finishInflate inf
return $
if S.null chunk
then Done Nothing ()
else HaveOutput (Done Nothing ()) (return ()) $ Chunk chunk
compress
:: MonadUnsafeIO m
=> Int
-> WindowBits
-> Conduit ByteString m ByteString
compress level config = NeedInput
(\input -> flip PipeM (return ()) $ do
def <- unsafeLiftIO $ initDeflate level config
push def input) (Done Nothing ())
where
push' def input = PipeM (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 PipeM (return ()) $ do
def <- unsafeLiftIO $ initDeflate level config
push def input) (Done Nothing ())
where
push' def input = PipeM (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 PipeM (return ()) $ do
mchunk <- unsafeLiftIO $ finishDeflate def
return $ case mchunk of
Nothing -> Done Nothing ()
Just chunk -> HaveOutput (Done Nothing ()) (return ()) (Chunk chunk)
goPopper :: MonadUnsafeIO m
=> (input -> Conduit input m output)
-> Conduit input 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 (PipeM (goPopper push close wrap final popper) (return ())) (return ()) (wrap bs)
slurp :: Monad m => m (Maybe a) -> Pipe i a m ()
slurp pop = flip PipeM (return ()) $ do
x <- pop
return $ case x of
Nothing -> Done Nothing ()
Just y -> HaveOutput (slurp pop) (return ()) y