Flushing (#2)

Codec/Zlib.hs

@@ -25,12 +25,14 @@ module Codec.Zlib
     , initInflateWithDictionary
     , withInflateInput
     , finishInflate
+    , flushInflate
       -- * Deflate
     , Deflate
     , initDeflate
     , initDeflateWithDictionary
     , withDeflateInput
     , finishDeflate
+    , flushDeflate
       -- * Data types
     , WindowBits (WindowBits)
     , defaultWindowBits
@@ -214,7 +216,19 @@ finishInflate (Inflate ((fzstr, fbuff), _)) =
         withForeignPtr fbuff $ \buff -> do
             avail <- c_get_avail_out zstr
             let size = defaultChunkSize - fromIntegral avail
-            S.packCStringLen (buff, size)
+            bs <- S.packCStringLen (buff, size)
+            c_set_avail_out zstr buff
+                $ fromIntegral defaultChunkSize
+            return bs
+
+-- | Flush the inflation buffer. Useful for interactive application.
+--
+-- This is actually a synonym for 'finishInflate'. It is provided for its more
+-- semantic name.
+--
+-- Since 0.0.3
+flushInflate :: Inflate -> IO S.ByteString
+flushInflate = finishInflate
 
 -- | Feed the given 'S.ByteString' to the deflater. This function takes a
 -- function argument which takes a \"popper\". A popper is an IO action that
@@ -244,3 +258,12 @@ finishDeflate (Deflate (fzstr, fbuff)) f =
     withForeignPtr fzstr $ \zstr ->
         f $ drain fbuff zstr c_call_deflate_finish True
 
+-- | Flush the deflation buffer. Useful for interactive application.
+--
+-- Internally this passes Z_SYNC_FLUSH to the zlib library.
+--
+-- Since 0.0.3
+flushDeflate :: Deflate -> (IO (Maybe S.ByteString) -> IO a) -> IO a
+flushDeflate (Deflate (fzstr, fbuff)) f =
+    withForeignPtr fzstr $ \zstr ->
+        f $ drain fbuff zstr c_call_deflate_flush True

Codec/Zlib/Lowlevel.hs

@@ -16,6 +16,7 @@ module Codec.Zlib.Lowlevel
     , c_call_inflate_noflush
     , c_call_deflate_noflush
     , c_call_deflate_finish
+    , c_call_deflate_flush
     , c_call_deflate_set_dictionary
     , c_call_inflate_set_dictionary
     ) where
@@ -81,6 +82,9 @@ foreign import ccall unsafe "call_deflate_noflush"
 foreign import ccall unsafe "call_deflate_finish"
     c_call_deflate_finish :: ZStream' -> IO CInt
 
+foreign import ccall unsafe "call_deflate_flush"
+    c_call_deflate_flush :: ZStream' -> IO CInt
+
 foreign import ccall unsafe "deflate_set_dictionary"
     c_call_deflate_set_dictionary :: ZStream' -> Ptr CChar -> CUInt -> IO ()
 

c/helper.c

@@ -81,6 +81,11 @@ int call_deflate_noflush (z_stream *stream)
 	return deflate(stream, Z_NO_FLUSH);
 }
 
+int call_deflate_flush (z_stream *stream)
+{
+	return deflate(stream, Z_SYNC_FLUSH);
+}
+
 int call_deflate_finish (z_stream *stream)
 {
 	return deflate(stream, Z_FINISH);

test/main.hs

@@ -13,7 +13,7 @@ import qualified Codec.Compression.GZip as Gzip
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Char8 as S8
 import qualified Data.ByteString.Lazy as L
-import Control.Monad (foldM)
+import Control.Monad (foldM, forM_, forM)
 import System.IO.Unsafe (unsafePerformIO)
 
 decompress' :: L.ByteString -> L.ByteString
@@ -174,3 +174,34 @@ main = hspecX $ do
             deflated <- foldM (go' def) id $ L.toChunks lbs
             deflated' <- finishDeflate def $ go deflated
             return $ lbs == decompress (L.fromChunks (deflated' []))
+
+    describe "flushing" $ do
+        let helper wb = do
+                let bss0 = replicate 5000 "abc"
+                def <- initDeflate 9 wb
+                inf <- initInflate wb
+
+                let popList pop = do
+                        mx <- pop
+                        case mx of
+                            Nothing -> return []
+                            Just x -> do
+                                xs <- popList pop
+                                return $ x : xs
+
+                let callback name expected pop = do
+                        bssDeflated <- popList pop
+                        bsInflated <- fmap (S.concat . concat) $ forM bssDeflated $ \bs -> do
+                            x <- withInflateInput inf bs popList
+                            y <- flushInflate inf
+                            return $ x ++ [y]
+                        if bsInflated == expected
+                            then return ()
+                            else error $ "callback " ++ name ++ ", got: " ++ show bsInflated ++ ", expected: " ++ show expected
+
+                forM_ (zip [1..] bss0) $ \(i, bs) -> do
+                    withDeflateInput def bs $ callback ("loop" ++ show (i :: Int)) ""
+                    flushDeflate def $ callback ("loop" ++ show (i :: Int)) bs
+                finishDeflate def $ callback "finish" ""
+        it "zlib" $ helper defaultWindowBits
+        it "gzip" $ helper $ WindowBits 31

zlib-bindings.cabal

@@ -1,5 +1,5 @@
 name:            zlib-bindings
-version:         0.0.2
+version:         0.0.3
 license:         BSD3
 license-file:    LICENSE
 author:          Michael Snoyman <michael@snoyman.com>