diff --git a/Codec/Zlib.hs b/Codec/Zlib.hs --- a/Codec/Zlib.hs +++ b/Codec/Zlib.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE ForeignFunctionInterface #-} -{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE DeriveDataTypeable #-} -- | This is a middle-level wrapper around the zlib C API. It allows you to -- work fully with bytestrings and not touch the FFI at all, but is still @@ -9,6 +7,17 @@ -- You'll probably need to reference the docs a bit to understand the -- WindowBits parameters below, but a basic rule of thumb is 15 is for zlib -- compression, and 31 for gzip compression. +-- +-- A simple streaming compressor in pseudo-code would look like: +-- +-- > def <- initDeflate ... +-- > withDeflateInput def rawContent1 sendCompressedData +-- > withDeflateInput def rawContent2 sendCompressedData +-- > ... +-- > finishDeflate def sendCompressedData +-- +-- You can see a more complete example is available in the included +-- file-test.hs. module Codec.Zlib ( -- * Inflate Inflate @@ -26,9 +35,9 @@ , ZlibException (..) ) where -import Foreign.C -import Foreign.Ptr +import Codec.Zlib.Lowlevel import Foreign.ForeignPtr +import Foreign.C.Types import Data.ByteString.Unsafe import Codec.Compression.Zlib (WindowBits (WindowBits), defaultWindowBits) import qualified Data.ByteString as S @@ -37,8 +46,6 @@ import Data.Typeable (Typeable) import Control.Exception (Exception, throwIO) -data ZStreamStruct -type ZStream' = Ptr ZStreamStruct type ZStreamPair = (ForeignPtr ZStreamStruct, ForeignPtr CChar) -- | The state of an inflation (eg, decompression) process. All allocated @@ -74,34 +81,19 @@ deriving (Show, Typeable) instance Exception ZlibException -foreign import ccall unsafe "create_z_stream_inflate" - c_create_z_stream_inflate :: CInt -> IO ZStream' - -foreign import ccall unsafe "&free_z_stream_inflate" - c_free_z_stream_inflate :: FunPtr (ZStream' -> IO ()) - -wbToInt :: WindowBits -> CInt -wbToInt (WindowBits i) = fromIntegral i -wbToInt _ = 15 - -- | Initialize an inflation process with the given 'WindowBits'. You will need -- to call 'withInflateInput' to feed compressed data to this and -- 'finishInflate' to extract the final chunk of decompressed data. initInflate :: WindowBits -> IO Inflate initInflate w = do - zstr <- c_create_z_stream_inflate $ wbToInt w + zstr <- zstreamNew + inflateInit2 zstr w fzstr <- newForeignPtr c_free_z_stream_inflate zstr fbuff <- mallocForeignPtrBytes defaultChunkSize withForeignPtr fbuff $ \buff -> c_set_avail_out zstr buff $ fromIntegral defaultChunkSize return $ Inflate (fzstr, fbuff) -foreign import ccall unsafe "create_z_stream_deflate" - c_create_z_stream_deflate :: CInt -> CInt -> IO ZStream' - -foreign import ccall unsafe "&free_z_stream_deflate" - c_free_z_stream_deflate :: FunPtr (ZStream' -> IO ()) - -- | Initialize a deflation process with the given compression level and -- 'WindowBits'. You will need to call 'withDeflateInput' to feed uncompressed -- data to this and 'finishDeflate' to extract the final chunks of compressed @@ -109,28 +101,14 @@ initDeflate :: Int -- ^ Compression level -> WindowBits -> IO Deflate initDeflate level w = do - zstr <- c_create_z_stream_deflate (fromIntegral level) $ wbToInt w + zstr <- zstreamNew + deflateInit2 zstr level w 8 StrategyDefault fzstr <- newForeignPtr c_free_z_stream_deflate zstr fbuff <- mallocForeignPtrBytes defaultChunkSize withForeignPtr fbuff $ \buff -> c_set_avail_out zstr buff $ fromIntegral defaultChunkSize return $ Deflate (fzstr, fbuff) -foreign import ccall unsafe "set_avail_in" - c_set_avail_in :: ZStream' -> Ptr CChar -> CUInt -> IO () - -foreign import ccall unsafe "set_avail_out" - c_set_avail_out :: ZStream' -> Ptr CChar -> CUInt -> IO () - -foreign import ccall unsafe "get_avail_out" - c_get_avail_out :: ZStream' -> IO CUInt - -foreign import ccall unsafe "get_avail_in" - c_get_avail_in :: ZStream' -> IO CUInt - -foreign import ccall unsafe "call_inflate_noflush" - c_call_inflate_noflush :: ZStream' -> IO CInt - -- | Feed the given 'S.ByteString' to the inflater. This function takes a -- function argument which takes a \"popper\". A popper is an IO action that -- will return the next bit of inflated data, returning 'Nothing' when there is @@ -183,9 +161,6 @@ let size = defaultChunkSize - fromIntegral avail S.packCStringLen (buff, size) -foreign import ccall unsafe "call_deflate_noflush" - c_call_deflate_noflush :: ZStream' -> IO CInt - -- | 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 -- will return the next bit of deflated data, returning 'Nothing' when there is @@ -203,9 +178,6 @@ unsafeUseAsCStringLen bs $ \(cstr, len) -> do c_set_avail_in zstr cstr $ fromIntegral len f $ drain fbuff zstr c_call_deflate_noflush False - -foreign import ccall unsafe "call_deflate_finish" - c_call_deflate_finish :: ZStream' -> IO CInt -- | As explained in 'withDeflateInput', deflation buffers your compressed -- data. After you call 'withDeflateInput' with your last chunk of decompressed diff --git a/Codec/Zlib/Lowlevel.hs b/Codec/Zlib/Lowlevel.hs new file mode 100644 --- /dev/null +++ b/Codec/Zlib/Lowlevel.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +module Codec.Zlib.Lowlevel + ( ZStreamStruct + , ZStream' + , zstreamNew + , Strategy(..) + , deflateInit2 + , inflateInit2 + , c_free_z_stream_inflate + , c_free_z_stream_deflate + , c_set_avail_in + , c_set_avail_out + , c_get_avail_out + , c_get_avail_in + , c_call_inflate_noflush + , c_call_deflate_noflush + , c_call_deflate_finish + ) where + +import Foreign.C +import Foreign.Ptr +import Codec.Compression.Zlib (WindowBits (WindowBits)) + +data ZStreamStruct +type ZStream' = Ptr ZStreamStruct + +data Strategy = + StrategyDefault + | StrategyFiltered + | StrategyHuffman + | StrategyRLE + | StrategyFixed + deriving (Show,Eq,Ord,Enum) + +foreign import ccall unsafe "create_z_stream" + zstreamNew :: IO ZStream' + +foreign import ccall unsafe "deflate_init2" + c_deflateInit2 :: ZStream' -> CInt -> CInt -> CInt -> CInt + -> IO () + +deflateInit2 :: ZStream' -> Int -> WindowBits -> Int -> Strategy -> IO () +deflateInit2 zstream level windowBits memlevel strategy = + c_deflateInit2 zstream (fromIntegral level) (wbToInt windowBits) + (fromIntegral memlevel) + (fromIntegral $ fromEnum strategy) + +foreign import ccall unsafe "inflate_init2" + c_inflateInit2 :: ZStream' -> CInt -> IO () + +inflateInit2 :: ZStream' -> WindowBits -> IO () +inflateInit2 zstream wb = c_inflateInit2 zstream (wbToInt wb) + +foreign import ccall unsafe "&free_z_stream_inflate" + c_free_z_stream_inflate :: FunPtr (ZStream' -> IO ()) + +foreign import ccall unsafe "&free_z_stream_deflate" + c_free_z_stream_deflate :: FunPtr (ZStream' -> IO ()) + +foreign import ccall unsafe "set_avail_in" + c_set_avail_in :: ZStream' -> Ptr CChar -> CUInt -> IO () + +foreign import ccall unsafe "set_avail_out" + c_set_avail_out :: ZStream' -> Ptr CChar -> CUInt -> IO () + +foreign import ccall unsafe "get_avail_out" + c_get_avail_out :: ZStream' -> IO CUInt + +foreign import ccall unsafe "get_avail_in" + c_get_avail_in :: ZStream' -> IO CUInt + +foreign import ccall unsafe "call_inflate_noflush" + c_call_inflate_noflush :: ZStream' -> IO CInt + +foreign import ccall unsafe "call_deflate_noflush" + c_call_deflate_noflush :: ZStream' -> IO CInt + +foreign import ccall unsafe "call_deflate_finish" + c_call_deflate_finish :: ZStream' -> IO CInt + +wbToInt :: WindowBits -> CInt +wbToInt (WindowBits i) = fromIntegral i +wbToInt _ = 15 + diff --git a/c/helper.c b/c/helper.c --- a/c/helper.c +++ b/c/helper.c @@ -1,21 +1,32 @@ #include #include -z_stream * create_z_stream_inflate (int window_bits) +z_stream * create_z_stream(void) { z_stream *ret = malloc(sizeof(z_stream)); - ret->zalloc = Z_NULL; - ret->zfree = Z_NULL; - ret->opaque = Z_NULL; - ret->next_in = NULL; - ret->avail_in = 0; + if (ret) { + ret->zalloc = Z_NULL; + ret->zfree = Z_NULL; + ret->opaque = Z_NULL; + ret->next_in = NULL; + ret->avail_in = 0; + ret->next_out = NULL; + ret->avail_out = 0; + } + return ret; +} - if (inflateInit2(ret, window_bits) != Z_OK) - return NULL; - else - return ret; +int inflate_init2(z_stream *stream, int window_bits) +{ + return inflateInit2(stream, window_bits); } +int deflate_init2(z_stream *stream, int level, int methodBits, + int memlevel, int strategy) +{ + return deflateInit2(stream, level, Z_DEFLATED, methodBits, memlevel, strategy); +} + void free_z_stream_inflate (z_stream *stream) { inflateEnd(stream); @@ -47,26 +58,6 @@ unsigned int get_avail_out (z_stream *stream) { return stream->avail_out; -} - -z_stream * create_z_stream_deflate (int level, int window_bits) -{ - z_stream *ret = malloc(sizeof(z_stream)); - ret->zalloc = Z_NULL; - ret->zfree = Z_NULL; - ret->opaque = Z_NULL; - ret->next_in = NULL; - ret->avail_in = 0; - - if (deflateInit2(ret, - level, - Z_DEFLATED, - window_bits, - 8, - Z_DEFAULT_STRATEGY) - != Z_OK) return NULL; - else - return ret; } void free_z_stream_deflate (z_stream *stream) diff --git a/file-test.hs b/file-test.hs new file mode 100644 --- /dev/null +++ b/file-test.hs @@ -0,0 +1,44 @@ +import Codec.Zlib +import System.Environment (getArgs) +import System.IO +import qualified Data.ByteString as S +import Control.Monad (unless) + +main = do + [action, inFile, outFile] <- getArgs + withFile inFile ReadMode $ \inH -> + withFile outFile WriteMode $ \outH -> + case action of + "inflate" -> inflate inH outH + "deflate" -> deflate inH outH + +inflate inH outH = do + inf <- initInflate $ WindowBits 31 + go inf + bs <- finishInflate inf + S.hPutStr outH bs + where + go inf = do + bs <- S.hGet inH 1024 + unless (S.null bs) $ do + withInflateInput inf bs $ writer outH + go inf + +deflate inH outH = do + def <- initDeflate 7 $ WindowBits 31 + go def + finishDeflate def $ writer outH + where + go def = do + bs <- S.hGet inH 1024 + unless (S.null bs) $ do + withDeflateInput def bs $ writer outH + go def + +writer outH pop = do + mbs <- pop + case mbs of + Nothing -> return () + Just bs -> do + S.hPutStr outH bs + writer outH pop diff --git a/test.hs b/test.hs --- a/test.hs +++ b/test.hs @@ -13,12 +13,46 @@ import Control.Monad (foldM) import System.IO.Unsafe (unsafePerformIO) +decompress' :: L.ByteString -> L.ByteString +decompress' gziped = unsafePerformIO $ do + inf <- initInflate defaultWindowBits + ungziped <- foldM (go' inf) id $ L.toChunks gziped + final <- finishInflate inf + return $ L.fromChunks $ ungziped [final] + where + go' inf front bs = withInflateInput inf bs $ go front + go front x = do + y <- x + case y of + Nothing -> return front + Just z -> go (front . (:) z) x + +prop_decompress' :: L.ByteString -> Bool +prop_decompress' lbs = lbs == decompress' (compress lbs) + +compress' :: L.ByteString -> L.ByteString +compress' raw = unsafePerformIO $ do + def <- initDeflate 7 defaultWindowBits + gziped <- foldM (go' def) id $ L.toChunks raw + gziped' <- finishDeflate def $ go gziped + return $ L.fromChunks $ gziped' [] + where + go' def front bs = withDeflateInput def bs $ go front + go front x = do + y <- x + case y of + Nothing -> return front + Just z -> go (front . (:) z) x + +prop_compress' :: L.ByteString -> Bool +prop_compress' lbs = lbs == decompress (compress' lbs) + license :: S.ByteString license = S8.filter (/= '\r') $ unsafePerformIO $ S.readFile "LICENSE" test_license_single_deflate :: Assertion test_license_single_deflate = do - def <- initDeflate $ WindowBits 31 + def <- initDeflate 8 $ WindowBits 31 gziped <- withDeflateInput def license $ go id gziped' <- finishDeflate def $ go gziped let raw' = L.fromChunks [license] @@ -46,7 +80,7 @@ test_license_multi_deflate :: Assertion test_license_multi_deflate = do - def <- initDeflate $ WindowBits 31 + def <- initDeflate 5 $ WindowBits 31 gziped <- foldM (go' def) id $ map S.singleton $ S.unpack license gziped' <- finishDeflate def $ go gziped let raw' = L.fromChunks [license] @@ -97,7 +131,7 @@ prop_lbs_zlib_deflate :: L.ByteString -> Bool prop_lbs_zlib_deflate lbs = unsafePerformIO $ do - def <- initDeflate defaultWindowBits + def <- initDeflate 7 defaultWindowBits deflated <- foldM (go' def) id $ L.toChunks lbs deflated' <- finishDeflate def $ go deflated return $ lbs == decompress (L.fromChunks (deflated' [])) @@ -109,7 +143,6 @@ Nothing -> return front Just z -> go (front . (:) z) x -main :: IO () main = do args <- getArgs runTestWithArgs args allHTFTests 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.0 +version: 0.0.1 license: BSD3 license-file: LICENSE author: Michael Snoyman @@ -24,6 +24,7 @@ , bytestring >= 0.9.1.4 && < 0.10 , zlib >= 0.5.2.0 && < 0.6 exposed-modules: Codec.Zlib + Codec.Zlib.Lowlevel ghc-options: -Wall c-sources: c/helper.c if os(windows) @@ -37,8 +38,20 @@ build-depends: base >= 4 && < 5 , bytestring >= 0.9.1.4 && < 0.10 , zlib >= 0.5.2.0 && < 0.6 - , HTF >= 0.5 && < 0.6 + , HTF >= 0.5 && < 0.8 , QuickCheck >= 2.1.2 + else + Buildable: False + ghc-options: -Wall + c-sources: c/helper.c + if os(windows) + include-dirs: cbits + install-includes: zlib.h zconf.h + +executable zlib-bindings-file-test + main-is: file-test.hs + if flag(test) + Buildable: True else Buildable: False ghc-options: -Wall