diff --git a/Codec/Zlib.hs b/Codec/Zlib.hs --- a/Codec/Zlib.hs +++ b/Codec/Zlib.hs @@ -23,20 +23,21 @@ Inflate , initInflate , initInflateWithDictionary - , withInflateInput + , feedInflate , finishInflate , flushInflate -- * Deflate , Deflate , initDeflate , initDeflateWithDictionary - , withDeflateInput + , feedDeflate , finishDeflate , flushDeflate -- * Data types , WindowBits (..) , defaultWindowBits , ZlibException (..) + , Popper ) where import Codec.Zlib.Lowlevel @@ -140,8 +141,8 @@ -- 'WindowBits'. -- Unlike initDeflate a dictionary for deflation is set. initDeflateWithDictionary :: Int -- ^ Compression level - -> S.ByteString -- ^ Deflate dictionary - -> WindowBits -> IO Deflate + -> S.ByteString -- ^ Deflate dictionary + -> WindowBits -> IO Deflate initDeflateWithDictionary level bs w = do zstr <- zstreamNew deflateInit2 zstr level w 8 StrategyDefault @@ -165,28 +166,40 @@ -- until that much decompressed data is available. After you have fed all of -- the compressed data to this function, you can extract your final chunk of -- decompressed data using 'finishInflate'. -withInflateInput - :: Inflate -> S.ByteString -> (IO (Maybe S.ByteString) -> IO a) - -> IO a -withInflateInput (Inflate ((fzstr, fbuff), inflateDictionary)) bs f = +feedInflate + :: Inflate + -> S.ByteString + -> IO Popper +feedInflate (Inflate ((fzstr, fbuff), inflateDictionary)) bs = do withForeignPtr fzstr $ \zstr -> - unsafeUseAsCStringLen bs $ \(cstr, len) -> do + unsafeUseAsCStringLen bs $ \(cstr, len) -> c_set_avail_in zstr cstr $ fromIntegral len - f $ drain fbuff zstr inflate False + return $ drain fbuff fzstr (Just bs) inflate False where inflate zstr = do - res <- c_call_inflate_noflush zstr - if (res == zNeedDict) - then maybe (throwIO $ ZlibException $ fromIntegral zNeedDict) -- no dictionary supplied so throw error - (\dict -> (unsafeUseAsCStringLen dict $ \(cstr, len) -> do - c_call_inflate_set_dictionary zstr cstr $ fromIntegral len - c_call_inflate_noflush zstr)) - inflateDictionary - else return res + res <- c_call_inflate_noflush zstr + if (res == zNeedDict) + then maybe (throwIO $ ZlibException $ fromIntegral zNeedDict) -- no dictionary supplied so throw error + (\dict -> (unsafeUseAsCStringLen dict $ \(cstr, len) -> do + c_call_inflate_set_dictionary zstr cstr $ fromIntegral len + c_call_inflate_noflush zstr)) + inflateDictionary + else return res -drain :: ForeignPtr CChar -> ZStream' -> (ZStream' -> IO CInt) -> Bool - -> IO (Maybe S.ByteString) -drain fbuff zstr func isFinish = do +type Popper = IO (Maybe S.ByteString) + +-- | Ensure that the given @ByteString@ is not deallocated. +keepAlive :: Maybe S.ByteString -> IO a -> IO a +keepAlive Nothing = id +keepAlive (Just bs) = unsafeUseAsCStringLen bs . const + +drain :: ForeignPtr CChar + -> ForeignPtr ZStreamStruct + -> Maybe S.ByteString + -> (ZStream' -> IO CInt) + -> Bool + -> Popper +drain fbuff fzstr mbs func isFinish = withForeignPtr fzstr $ \zstr -> keepAlive mbs $ do a <- c_get_avail_in zstr if a == 0 && not isFinish then return Nothing @@ -217,8 +230,7 @@ avail <- c_get_avail_out zstr let size = defaultChunkSize - fromIntegral avail bs <- S.packCStringLen (buff, size) - c_set_avail_out zstr buff - $ fromIntegral defaultChunkSize + c_set_avail_out zstr buff $ fromIntegral defaultChunkSize return bs -- | Flush the inflation buffer. Useful for interactive application. @@ -240,30 +252,27 @@ -- until that much compressed data is available. After you have fed all of the -- decompressed data to this function, you can extract your final chunks of -- compressed data using 'finishDeflate'. -withDeflateInput - :: Deflate -> S.ByteString -> (IO (Maybe S.ByteString) -> IO a) -> IO a -withDeflateInput (Deflate (fzstr, fbuff)) bs f = +feedDeflate :: Deflate -> S.ByteString -> IO Popper +feedDeflate (Deflate (fzstr, fbuff)) bs = do withForeignPtr fzstr $ \zstr -> unsafeUseAsCStringLen bs $ \(cstr, len) -> do c_set_avail_in zstr cstr $ fromIntegral len - f $ drain fbuff zstr c_call_deflate_noflush False + return $ drain fbuff fzstr (Just bs) c_call_deflate_noflush False -- | As explained in 'withDeflateInput', deflation buffers your compressed -- data. After you call 'withDeflateInput' with your last chunk of decompressed -- data, we need to flush the rest of the data waiting to be deflated. This -- function takes a function parameter which accepts a \"popper\", just like -- 'withDeflateInput'. -finishDeflate :: Deflate -> (IO (Maybe S.ByteString) -> IO a) -> IO a -finishDeflate (Deflate (fzstr, fbuff)) f = - withForeignPtr fzstr $ \zstr -> - f $ drain fbuff zstr c_call_deflate_finish True +finishDeflate :: Deflate -> Popper +finishDeflate (Deflate (fzstr, fbuff)) = + drain fbuff fzstr Nothing 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 +flushDeflate :: Deflate -> Popper +flushDeflate (Deflate (fzstr, fbuff)) = + drain fbuff fzstr Nothing c_call_deflate_flush True diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -23,7 +23,7 @@ final <- finishInflate inf return $ L.fromChunks $ ungziped [final] where - go' inf front bs = withInflateInput inf bs $ go front + go' inf front bs = feedInflate inf bs >>= go front go front x = do y <- x case y of @@ -39,10 +39,10 @@ compress' raw = unsafePerformIO $ do def <- initDeflate 7 defaultWindowBits gziped <- foldM (go' def) id $ L.toChunks raw - gziped' <- finishDeflate def $ go gziped + gziped' <- go gziped $ finishDeflate def return $ L.fromChunks $ gziped' [] where - go' def front bs = withDeflateInput def bs $ go front + go' def front bs = feedDeflate def bs >>= go front go front x = do y <- x case y of @@ -59,10 +59,10 @@ deflateWithDict dict raw = unsafePerformIO $ do def <- initDeflateWithDictionary 7 dict $ WindowBits 15 compressed <- foldM (go' def) id $ L.toChunks raw - compressed' <- finishDeflate def $ go compressed + compressed' <- go compressed $ finishDeflate def return $ L.fromChunks $ compressed' [] where - go' def front bs = withDeflateInput def bs $ go front + go' def front bs = feedDeflate def bs >>= go front go front x = do y <- x case y of @@ -76,7 +76,7 @@ final <- finishInflate inf return $ L.fromChunks $ decompressed [final] where - go' inf front bs = withInflateInput inf bs $ go front + go' inf front bs = feedInflate inf bs >>= go front go front x = do y <- x case y of @@ -106,8 +106,8 @@ Nothing -> return front Just z -> go (front . (:) z) x def <- initDeflate 8 $ WindowBits 31 - gziped <- withDeflateInput def license $ go id - gziped' <- finishDeflate def $ go gziped + gziped <- feedDeflate def license >>= go id + gziped' <- go gziped $ finishDeflate def let raw' = L.fromChunks [license] raw' @?= Gzip.decompress (L.fromChunks $ gziped' []) @@ -119,12 +119,13 @@ Just z -> go (front . (:) z) x gziped <- S.readFile "LICENSE.gz" inf <- initInflate $ WindowBits 31 - ungziped <- withInflateInput inf gziped $ go id + popper <- feedInflate inf gziped + ungziped <- go id popper final <- finishInflate inf license @?= (S.concat $ ungziped [final]) it "multi deflate" $ do - let go' inf front bs = withDeflateInput inf bs $ go front + let go' inf front bs = feedDeflate inf bs >>= go front go front x = do y <- x case y of @@ -132,12 +133,12 @@ Just z -> go (front . (:) z) x def <- initDeflate 5 $ WindowBits 31 gziped <- foldM (go' def) id $ map S.singleton $ S.unpack license - gziped' <- finishDeflate def $ go gziped + gziped' <- go gziped $ finishDeflate def let raw' = L.fromChunks [license] raw' @?= (Gzip.decompress $ L.fromChunks $ gziped' []) it "multi inflate" $ do - let go' inf front bs = withInflateInput inf bs $ go front + let go' inf front bs = feedInflate inf bs >>= go front go front x = do y <- x case y of @@ -153,7 +154,7 @@ describe "lbs zlib" $ do prop "inflate" $ \lbs -> unsafePerformIO $ do let glbs = compress lbs - go' inf front bs = withInflateInput inf bs $ go front + go' inf front bs = feedInflate inf bs >>= go front go front x = do y <- x case y of @@ -164,7 +165,7 @@ final <- finishInflate inf return $ lbs == L.fromChunks (inflated [final]) prop "deflate" $ \lbs -> unsafePerformIO $ do - let go' inf front bs = withDeflateInput inf bs $ go front + let go' inf front bs = feedDeflate inf bs >>= go front go front x = do y <- x case y of @@ -172,7 +173,7 @@ Just z -> go (front . (:) z) x def <- initDeflate 7 defaultWindowBits deflated <- foldM (go' def) id $ L.toChunks lbs - deflated' <- finishDeflate def $ go deflated + deflated' <- go deflated $ finishDeflate def return $ lbs == decompress (L.fromChunks (deflated' [])) describe "flushing" $ do @@ -192,7 +193,7 @@ let callback name expected pop = do bssDeflated <- popList pop bsInflated <- fmap (S.concat . concat) $ forM bssDeflated $ \bs -> do - x <- withInflateInput inf bs popList + x <- feedInflate inf bs >>= popList y <- flushInflate inf return $ x ++ [y] if bsInflated == expected @@ -200,8 +201,8 @@ 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" "" + feedDeflate def bs >>= callback ("loop" ++ show (i :: Int)) "" + callback ("loop" ++ show (i :: Int)) bs $ flushDeflate def + callback "finish" "" $ finishDeflate def it "zlib" $ helper defaultWindowBits it "gzip" $ helper $ WindowBits 31 diff --git a/zlib-bindings.cabal b/zlib-bindings.cabal --- a/zlib-bindings.cabal +++ b/zlib-bindings.cabal @@ -1,5 +1,5 @@ name: zlib-bindings -version: 0.0.3.2 +version: 0.1.0 license: BSD3 license-file: LICENSE author: Michael Snoyman