bz2 0.1.1.1 → 1.0.0.0

raw patch · 15 files changed

+349/−256 lines, 15 filesdep +deepseqdep +directorydep +temporarydep ~basedep ~filepathPVP ok

version bump matches the API change (PVP)

Dependencies added: deepseq, directory, temporary

Dependency ranges changed: base, filepath

API changes (from Hackage documentation)

Files

• CHANGELOG.md +10/−0
• Makefile +16/−0
• README.md +6/−0
• bench/Bench.hs +10/−1
• bz2.cabal +31/−8
• mem/Mem.hs +21/−0
• src/Codec/Compression/BZip.hs +5/−3
• src/Codec/Compression/BZip/Common.chs +1/−1
• src/Codec/Compression/BZip/Foreign.chs +0/−132
• src/Codec/Compression/BZip/Foreign/Common.chs +60/−0
• src/Codec/Compression/BZip/Foreign/Compress.chs +16/−0
• src/Codec/Compression/BZip/Foreign/Decompress.chs +16/−0
• src/Codec/Compression/BZip/Pack.chs +68/−51
• src/Codec/Compression/BZip/Unpack.chs +65/−59
• test/Spec.hs +24/−1

@@ -1,5 +1,15 @@ # bz2 +## 1.0.0.0++  * Remove `Codec.Compression.BZip.Foreign`+  * Use `ForeignPtr` under the hood+  * Lazier streaming; memory use should be sensible++## 0.1.1.2++  * Use `ForeignPtr`s under the hood in various places (over `bracket`)+ ## 0.1.1.1    * Haddock improvements

@@ -0,0 +1,16 @@+.PHONY: clean++SHELL := bash+MAKEFLAGS += --warn-undefined-variables --no-builtin-rules -j+.DELETE_ON_ERROR:++setup: valgrind-3.15.0.tar++clean:+	rm -rf .stack-work dist-newstyle dist *.tar* *.hp *.prof stack.yaml.lock tags *.svg++valgrind-3.15.0.tar.bz2:+	wget https://sourceware.org/pub/valgrind/valgrind-3.15.0.tar.bz2 -O $@++valgrind-3.15.0.tar: valgrind-3.15.0.tar.bz2+	bzip2 -d $< --keep

@@ -11,3 +11,9 @@   * Uses [c2hs](https://github.com/haskell/c2hs) rather than     [hsc2hs](https://hackage.haskell.org/package/hsc2hs) and thus has a larger     dependency footprint++## Backpack Integration++`bz2` implements+[`bzip-signature`](http://hackage.haskell.org/package/bzip-signature), which+makes it interchangeable with `bzlib`.

@@ -3,7 +3,14 @@ import qualified Codec.Compression.BZip as BZ2 import           Criterion.Main import qualified Data.ByteString.Lazy   as BSL+import           System.FilePath        ((</>))+import           System.IO.Temp         (withSystemTempDirectory) +decompressDump :: IO ()+decompressDump = withSystemTempDirectory "bz2" $+    \fp -> BSL.writeFile (fp </> "valgrind-3.15.0.tar") =<<+        (BZ2.decompress <$> BSL.readFile "valgrind-3.15.0.tar.bz2")+ decompressFile :: FilePath -> IO BSL.ByteString decompressFile = fmap BZ2.decompress . BSL.readFile @@ -12,7 +19,9 @@  main :: IO () main =-    defaultMain [ bgroup "decompress"+    defaultMain [ bgroup "decompressDump"+                      [ bench "decompress + write to file" $ nfIO decompressDump ]+                , bgroup "decompress"                       [ bench "decompress file" $ nfIO (decompressFile "test/data/sample1.bz2")                       , bench "decompress file" $ nfIO (decompressFile "test/data/sample2.bz2")                       , bench "decompress file" $ nfIO (decompressFile "test/data/sample3.bz2")

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               bz2-version:            0.1.1.1+version:            1.0.0.0 license:            BSD3 license-file:       LICENSE copyright:          Copyright: (c) 2020 Vanessa McHale@@ -19,7 +19,10 @@     test/data/sample2.bz2     test/data/sample3.bz2 -extra-source-files: cbits/bzlib_private.h+extra-source-files:+    cbits/bzlib_private.h+    Makefile+ extra-doc-files:     README.md     CHANGELOG.md@@ -34,10 +37,7 @@     manual:      True  library-    exposed-modules:-        Codec.Compression.BZip-        Codec.Compression.BZip.Foreign-+    exposed-modules:  Codec.Compression.BZip     c-sources:         cbits/bzlib.c         cbits/randtable.c@@ -49,12 +49,15 @@      hs-source-dirs:   src     other-modules:+        Codec.Compression.BZip.Foreign.Common+        Codec.Compression.BZip.Foreign.Compress+        Codec.Compression.BZip.Foreign.Decompress         Codec.Compression.BZip.Common         Codec.Compression.BZip.Unpack         Codec.Compression.BZip.Pack      default-language: Haskell2010-    other-extensions: DeriveDataTypeable+    other-extensions: DeriveDataTypeable TupleSections     include-dirs:     cbits     install-includes: cbits/bzlib.h     ghc-options:      -Wall@@ -86,7 +89,9 @@         filepath >=1.4.0.0,         tasty -any,         tasty-golden -any,-        tasty-hunit -any+        tasty-hunit -any,+        deepseq -any,+        directory -any      if impl(ghc >=8.0)         ghc-options:@@ -109,6 +114,8 @@         base -any,         bz2 -any,         criterion -any,+        filepath -any,+        temporary -any,         bytestring -any      if impl(ghc >=8.0)@@ -121,3 +128,19 @@      if impl(ghc >=8.2)         ghc-options: -Wcpp-undef++benchmark bz2-mem+    type:             exitcode-stdio-1.0+    main-is:          Mem.hs+    hs-source-dirs:   mem+    default-language: Haskell2010+    ghc-options:      -Wall+    build-depends:+        base -any,+        bz2 -any,+        filepath -any,+        temporary -any,+        bytestring -any++    if impl(ghc >=8.0)+        ghc-options: -Wincomplete-uni-patterns -Wincomplete-record-updates

@@ -0,0 +1,21 @@+module Main (main) where++import           Codec.Compression.BZip (compress, decompress)+import qualified Data.ByteString.Lazy   as BSL+import           System.FilePath        ((</>))+import           System.IO.Temp         (withSystemTempDirectory)++main :: IO ()+main =+    compressDump *>+    decompressDump++decompressDump :: IO ()+decompressDump = withSystemTempDirectory "bz2" $+    \fp -> BSL.writeFile (fp </> "valgrind-3.15.0.tar") =<<+        (decompress <$> BSL.readFile "valgrind-3.15.0.tar.bz2")++compressDump :: IO ()+compressDump = withSystemTempDirectory "bz2" $+    \fp -> BSL.writeFile (fp </> "valgrind-3.15.0.tar.bz2") =<<+        (compress <$> BSL.readFile "valgrind-3.15.0.tar")

@@ -5,10 +5,12 @@                                 compress                               , compressWith                               , decompress-                              -- * Low-level bindings-                              , module Codec.Compression.BZip.Foreign+                              -- * Errors+                              , BZError (..)+                              -- * Miscellany+                              , bZ2BzlibVersion                               ) where -import           Codec.Compression.BZip.Foreign+import           Codec.Compression.BZip.Foreign.Common import           Codec.Compression.BZip.Pack import           Codec.Compression.BZip.Unpack

@@ -1,6 +1,6 @@ module Codec.Compression.BZip.Common ( bzStreamInit ) where -import Codec.Compression.BZip.Foreign (BzStream)+import Codec.Compression.BZip.Foreign.Common (BzStream) import Control.Applicative import Foreign.Ptr (nullFunPtr, nullPtr, Ptr) import Foreign.Marshal (mallocBytes)

@@ -1,132 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}---- | This module uses exceptions behind the scenes------ Consult the upstream [documentation](https://www.sourceware.org/bzip2/docs.html) for how to use this library.------ For struct accessors, I recommend using [c2hs](http://hackage.haskell.org/package/c2hs).-module Codec.Compression.BZip.Foreign ( -- * Types-                                        BZAction (..)-                                      , BZError (..)-                                      , BzStream-                                      , BzStreamPtr-                                      , BzFile-                                      , BzFilePtr-                                      , FilePtr-                                      -- * Low-level functions-                                      , bZ2BzCompressInit-                                      , bZ2BzCompress-                                      , bZ2BzCompressEnd-                                      , bZ2BzDecompressInit-                                      , bZ2BzDecompress-                                      , bZ2BzDecompressEnd-                                      -- * High-level functions-                                      , bZ2BzReadOpen-                                      , bZ2BzReadClose-                                      , bZ2BzReadGetUnused-                                      , bZ2BzRead-                                      , bZ2BzWriteOpen-                                      , bZ2BzWrite-                                      , bZ2BzWriteClose-                                      , bZ2BzWriteClose64-                                      -- * Macros-                                      , bZMaxUnused-                                      -- * Utility functions-                                      , bZ2BzBuffToBuffCompress-                                      , bZ2BzBuffToBuffDecompress-                                      -- * Contributed functions-                                      , bZ2BzlibVersion-                                      ) where--import Control.Applicative-import Control.Exception (Exception, throw)-import Control.Monad ((<=<))-import Data.Typeable (Typeable)-import Foreign.C.Types (CInt, CUInt)-import Foreign.Marshal (alloca)-import Foreign.Ptr (castPtr, Ptr)-import Foreign.Storable (peek)--#include <bzlib.h>--{# enum define BZAction { BZ_RUN as BzRun-                        , BZ_FLUSH as BzFlush-                        , BZ_FINISH as BzFinish-                        }-  #}--{# enum define BZError { BZ_OK as BzOk-                       , BZ_RUN_OK as BzRunOk-                       , BZ_FLUSH_OK as BzFlushOk-                       , BZ_FINISH_OK as BzFinishOk-                       , BZ_STREAM_END as BzStreamEnd-                       , BZ_SEQUENCE_ERROR as BzSequenceError-                       , BZ_PARAM_ERROR as BzParamError-                       , BZ_MEM_ERROR as BzMemError-                       , BZ_DATA_ERROR as BzDataError-                       , BZ_DATA_ERROR_MAGIC as BzDataErrorMagic-                       , BZ_IO_ERROR as BzIoError-                       , BZ_UNEXPECTED_EOF as BzUnexpectedEof-                       , BZ_OUTBUFF_FULL as BzOutbuffFull-                       , BZ_CONFIG_ERROR as BzConfigError-                       } deriving (Eq, Show, Typeable)-  #}--instance Exception BZError where---- | Abstract type-data BzStream---- | Abstract type-data BzFile--{#pointer *bz_stream as BzStreamPtr -> BzStream #}--- | @FILE*@ in C.-{#pointer *FILE as FilePtr newtype #}-{#pointer *BZFILE as BzFilePtr -> BzFile #}---- Low-level functions-{# fun BZ2_bzCompressInit as ^ { `BzStreamPtr', `CInt', `CInt', `CInt' } -> `()' bzWrap*- #}-{# fun BZ2_bzCompress as ^ { `BzStreamPtr', `BZAction' } -> `BZError' bzWrap* #}-{# fun BZ2_bzCompressEnd as ^ { `BzStreamPtr' } -> `()' bzWrap*- #}-{# fun BZ2_bzDecompressInit as ^ { `BzStreamPtr', `CInt', `Bool' } -> `()' bzWrap*- #}-{# fun BZ2_bzDecompress as ^ { `BzStreamPtr' } -> `BZError' bzWrap* #}-{# fun BZ2_bzDecompressEnd as ^ { `BzStreamPtr' } -> `()' bzWrap*- #}---- High-level functions-{# fun BZ2_bzReadOpen as ^ { alloca- `BZError' peekBZError*, `FilePtr', `CInt', `Bool', castPtr `Ptr a', `CInt' } -> `BzFilePtr' #}-{# fun BZ2_bzReadClose as ^ { alloca- `BZError' peekBZError*, `BzFilePtr' } -> `()' #}-{# fun BZ2_bzReadGetUnused as ^ { alloca- `BZError' peekBZError*, `BzFilePtr', alloca- `Ptr a' peekVoidPtr*, alloca- `CInt' peek* } -> `()' #}-{# fun BZ2_bzRead as ^ { alloca- `BZError' peekBZError*, `BzFilePtr', castPtr `Ptr a', `CInt' } -> `CInt' #}-{# fun BZ2_bzWriteOpen as ^ { alloca- `BZError' peekBZError*, `FilePtr', `CInt', `CInt', `CInt' } -> `BzFilePtr' #}-{# fun BZ2_bzWrite as ^ { alloca- `BZError' peekBZError*, `BzFilePtr', castPtr `Ptr a', `CInt' } -> `()' #}-{# fun BZ2_bzWriteClose as ^ { alloca- `BZError' peekBZError*, `BzFilePtr', `Bool', alloca- `CUInt' peek*, alloca- `CUInt' peek* } -> `()' #}-{# fun BZ2_bzWriteClose64 as ^ { alloca- `BZError' peekBZError*, `BzFilePtr', `Bool', alloca- `CUInt' peek*, alloca- `CUInt' peek*, alloca- `CUInt' peek*, alloca- `CUInt' peek* } -> `()' #}---- Macros-bZMaxUnused :: Integral a => a-bZMaxUnused = {# const BZ_MAX_UNUSED #}---- Utility functions-{# fun BZ2_bzBuffToBuffCompress as ^ { castPtr `Ptr a', alloca- `CUInt' peek*, castPtr `Ptr a', `CUInt', `CInt', `CInt', `CInt' } -> `()' bzWrap*- #}-{# fun BZ2_bzBuffToBuffDecompress as ^ { castPtr `Ptr a', alloca- `CUInt' peek*, castPtr `Ptr a', `CUInt', `Bool', `CInt' } -> `BZError' bzWrap* #}---- Contributed functions-{# fun pure BZ2_bzlibVersion as ^ { } -> `String' #}--peekVoidPtr :: Ptr (Ptr ()) -> IO (Ptr a)-peekVoidPtr = fmap castPtr . peek--peekBZError :: Ptr CInt -> IO BZError-peekBZError = bzWrap <=< peek--bzWrap :: CInt -> IO BZError-bzWrap err =-    let err' = toEnum (fromIntegral err) in-    case err' of-        BzOk        -> pure err'-        BzRunOk     -> pure err'-        BzFlushOk   -> pure err'-        BzFinishOk  -> pure err'-        BzStreamEnd -> pure err'-        x           -> throw x

@@ -0,0 +1,60 @@+{-# LANGUAGE DeriveDataTypeable #-}++module Codec.Compression.BZip.Foreign.Common ( -- * Types+                                               BZAction (..)+                                             , BZError (..)+                                             , BzStream+                                             -- * Helper+                                             , bzWrap+                                             -- * Contributed functions+                                             , bZ2BzlibVersion+                                             ) where++import Control.Applicative+import Control.Exception (Exception, throw)+import Data.Typeable (Typeable)+import Foreign.C.Types (CInt)++#include <bzlib.h>++{# enum define BZAction { BZ_RUN as BzRun+                        , BZ_FLUSH as BzFlush+                        , BZ_FINISH as BzFinish+                        }+  #}++{# enum define BZError { BZ_OK as BzOk+                       , BZ_RUN_OK as BzRunOk+                       , BZ_FLUSH_OK as BzFlushOk+                       , BZ_FINISH_OK as BzFinishOk+                       , BZ_STREAM_END as BzStreamEnd+                       , BZ_SEQUENCE_ERROR as BzSequenceError+                       , BZ_PARAM_ERROR as BzParamError+                       , BZ_MEM_ERROR as BzMemError+                       , BZ_DATA_ERROR as BzDataError+                       , BZ_DATA_ERROR_MAGIC as BzDataErrorMagic+                       , BZ_IO_ERROR as BzIoError+                       , BZ_UNEXPECTED_EOF as BzUnexpectedEof+                       , BZ_OUTBUFF_FULL as BzOutbuffFull+                       , BZ_CONFIG_ERROR as BzConfigError+                       } deriving (Eq, Show, Typeable)+  #}++instance Exception BZError where++-- | Abstract type+data BzStream++-- Contributed functions+{# fun pure BZ2_bzlibVersion as ^ { } -> `String' #}++bzWrap :: CInt -> IO BZError+bzWrap err =+    let err' = toEnum (fromIntegral err) in+    case err' of+        BzOk        -> pure err'+        BzRunOk     -> pure err'+        BzFlushOk   -> pure err'+        BzFinishOk  -> pure err'+        BzStreamEnd -> pure err'+        x           -> throw x

@@ -0,0 +1,16 @@+module Codec.Compression.BZip.Foreign.Compress ( bZ2BzCompressInit+                                               , bZ2BzCompress+                                               , bZ2BzCompressEnd+                                               , BzStreamPtr+                                               ) where++{# import Codec.Compression.BZip.Foreign.Common #}++import Foreign.C.Types (CInt)++#include <bzlib.h>++{#pointer *bz_stream as BzStreamPtr foreign finalizer BZ2_bzCompressEnd as ^ -> BzStream #}++{# fun BZ2_bzCompressInit as ^ { `BzStreamPtr', `CInt', `CInt', `CInt' } -> `()' bzWrap*- #}+{# fun BZ2_bzCompress as ^ { `BzStreamPtr', `BZAction' } -> `BZError' bzWrap* #}

@@ -0,0 +1,16 @@+module Codec.Compression.BZip.Foreign.Decompress ( bZ2BzDecompressInit+                                                 , bZ2BzDecompress+                                                 , bZ2BzDecompressEnd+                                                 , BzStreamPtr+                                                 ) where++{# import Codec.Compression.BZip.Foreign.Common #}++import Foreign.C.Types (CInt)++#include <bzlib.h>++{#pointer *bz_stream as BzStreamPtr foreign finalizer BZ2_bzDecompressEnd as ^ -> BzStream #}++{# fun BZ2_bzDecompressInit as ^ { `BzStreamPtr', `CInt', `Bool' } -> `()' bzWrap*- #}+{# fun BZ2_bzDecompress as ^ { `BzStreamPtr' } -> `BZError' bzWrap* #}

@@ -1,28 +1,30 @@+{-# LANGUAGE TupleSections #-}+ module Codec.Compression.BZip.Pack ( compress                                    , compressWith                                    ) where -import Codec.Compression.BZip.Foreign+import Codec.Compression.BZip.Foreign.Common+import Codec.Compression.BZip.Foreign.Compress import Codec.Compression.BZip.Common import Control.Applicative-import Control.Arrow (second)-import Control.Exception (bracket)+import Control.Monad.ST.Lazy as LazyST+import Control.Monad.ST.Lazy.Unsafe as LazyST import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Unsafe as BS import Foreign.C.Types (CInt)+import Foreign.ForeignPtr (castForeignPtr, ForeignPtr, newForeignPtr, mallocForeignPtrBytes, withForeignPtr) import Foreign.Ptr (Ptr, castPtr, nullPtr)-import Foreign.Marshal.Alloc (free, mallocBytes)-import System.IO.Unsafe (unsafeDupablePerformIO)  #include <bzlib.h> -{-# NOINLINE compress #-} -- | @since 0.1.1.0 compress :: BSL.ByteString -> BSL.ByteString compress = compressWith 9 30 -{-# NOINLINE compressWith #-}+type Step = Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])+ -- | See [bzlib manual](https://www.sourceware.org/bzip2/manual/manual.html#bzcompress-init) -- for information on compression parameters. --@@ -31,75 +33,90 @@              -> CInt -- ^ Work factor (@0-250@)              -> BSL.ByteString              -> BSL.ByteString-compressWith blkSize wf bsl = unsafeDupablePerformIO $+compressWith blkSize wf bsl =     let bss = BSL.toChunks bsl in-    BSL.fromChunks <$> bracket-        (do { p <- bzStreamInit ; bzCompressInit blkSize wf p ; pure p })-        bZ2BzCompressEnd-        (\p -> bzCompressChunks p bss)+    BSL.fromChunks $ LazyST.runST $ do+        (p, bufOut) <- LazyST.unsafeIOToST $ do+            ptr <- bzStreamInit+            p <- castForeignPtr <$> newForeignPtr bZ2BzCompressEnd (castPtr ptr)+            bzCompressInit blkSize wf p+            bufOut <- mallocForeignPtrBytes bufSz+            pure (p, bufOut) -bzCompressChunks :: Ptr BzStream -> [BS.ByteString] -> IO [BS.ByteString]-bzCompressChunks p bs =+        bzCompressChunks p bss bufOut -    bracket-        (mallocBytes bufSz)-        free-        (fmap snd . extractBuf bs)+bzCompressChunks :: ForeignPtr BzStream -> [BS.ByteString] -> ForeignPtr a -> LazyST.ST s [BS.ByteString]+bzCompressChunks ptr' bs bufO = do +    fillBuf ptr' Nothing bs pushBytes bufO+     where          -- corresponds to inner loop in zlib example-        fillBuf :: [BS.ByteString] -> BZAction -> Ptr a -> IO (BZError, [BS.ByteString])-        fillBuf bs' f bufOut = do+        fillBuf :: ForeignPtr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> Step -> ForeignPtr a -> LazyST.ST s [BS.ByteString]+        fillBuf pForeign passFwd bs' step bufOutForeign = do+            (ret, szOut, newBSAp, bs'', keepAlive) <- LazyST.unsafeIOToST $ do+                withForeignPtr pForeign $ \p ->+                    withForeignPtr bufOutForeign $ \bufOut -> do -            {# set bz_stream.avail_out #} p bufSz-            {# set bz_stream.next_out #} p (castPtr bufOut)+                        let act f = do -            ret <- bZ2BzCompress p f+                                {# set bz_stream.avail_out #} p bufSz+                                {# set bz_stream.next_out #} p (castPtr bufOut) -            szOut <- fromIntegral <$> {# get bz_stream->avail_out #} p+                                bZ2BzCompress ptr' f -            let bytesAvail = bufSz - szOut+                        (ret, keepAlive, bs'') <- step p passFwd bs' act -            newBSAp <- if bytesAvail /= 0-                then (:) <$> BS.packCStringLen (castPtr bufOut, bytesAvail)-                else pure id+                        szOut <- fromIntegral <$> {# get bz_stream->avail_out #} p +                        let bytesAvail = bufSz - szOut++                        newBSAp <- if bytesAvail /= 0+                            then (:) <$> BS.packCStringLen (castPtr bufOut, bytesAvail)+                            else pure id++                        pure (ret, szOut, newBSAp, bs'', keepAlive)++            let step' = if szOut == 0+                then keepBytesAlive+                else pushBytes+             if ret == BzStreamEnd-                then pure (ret, newBSAp [])-                else if szOut == 0-                    then second newBSAp <$> fillBuf bs' f bufOut-                    else second newBSAp <$> extractBuf bs' bufOut+                then pure (newBSAp [])+                else newBSAp <$> fillBuf pForeign keepAlive bs'' step' bufOutForeign -        -- corresponds to outer loop in zlib example-        extractBuf :: [BS.ByteString] -> Ptr a -> IO (BZError, [BS.ByteString])-        extractBuf [] bufOut = do+        keepBytesAlive :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])+        keepBytesAlive _ Nothing [] act = (, Nothing, []) <$> act BzFinish+        keepBytesAlive _ Nothing bs' act = (, Nothing, bs') <$> act BzRun+        keepBytesAlive _ passFwd@(Just b) [] act = do+            BS.unsafeUseAsCStringLen b $ \_ -> do -            (res, blocks) <- fillBuf [] BzFinish bufOut+                (, passFwd, []) <$> act BzFinish+        keepBytesAlive _ passFwd@(Just b) bs' act = do+            BS.unsafeUseAsCStringLen b $ \_ -> do -            if res == BzStreamEnd-                then pure (BzStreamEnd, blocks)-                else extractBuf [] bufOut+                (, passFwd, bs') <$> act BzRun -        extractBuf (b:bs') bufOut =+        pushBytes :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> (BZAction -> IO BZError) -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])+        pushBytes _ _ [] act = (, Nothing, []) <$> act BzFinish+        pushBytes p _ (b:bs') act =             BS.unsafeUseAsCStringLen b $ \(buf, sz) -> do                  {# set bz_stream.avail_in #} p (fromIntegral sz)                 {# set bz_stream.next_in #} p buf -                (res, blocks) <- fillBuf bs' BzRun bufOut+                (, Just b, bs') <$> act BzRun -                if res == BzStreamEnd-                    then pure (BzStreamEnd, blocks)-                    else extractBuf bs' bufOut+bufSz :: Integral a => a+bufSz = 32 * 1024 -        bufSz :: Integral a => a-        bufSz = 32 * 1024+bzCompressInit :: CInt -> CInt -> ForeignPtr BzStream -> IO ()+bzCompressInit blkSize wf ptr' = do -bzCompressInit :: CInt -> CInt -> Ptr BzStream -> IO ()-bzCompressInit blkSize wf p = do+    withForeignPtr ptr' $ \p -> do -    {# set bz_stream.next_in #} p nullPtr-    {# set bz_stream.avail_in #} p 0+        {# set bz_stream.next_in #} p nullPtr+        {# set bz_stream.avail_in #} p 0 -    bZ2BzCompressInit p blkSize 0 wf+    bZ2BzCompressInit ptr' blkSize 0 wf

@@ -1,99 +1,105 @@+{-# LANGUAGE TupleSections #-}+ module Codec.Compression.BZip.Unpack ( decompress                                      ) where -import Codec.Compression.BZip.Foreign+import Codec.Compression.BZip.Foreign.Common+import Codec.Compression.BZip.Foreign.Decompress import Codec.Compression.BZip.Common import Control.Applicative-import Control.Arrow (second)-import Control.Exception (bracket)+import Control.Monad.ST.Lazy as LazyST+import Control.Monad.ST.Lazy.Unsafe as LazyST import qualified Data.ByteString as BS-import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Unsafe as BS+import qualified Data.ByteString.Lazy as BSL+import Foreign.ForeignPtr (newForeignPtr, castForeignPtr, ForeignPtr, mallocForeignPtrBytes, withForeignPtr) import Foreign.Ptr (Ptr, castPtr, nullPtr)-import Foreign.Marshal.Alloc (free, mallocBytes)-import System.IO.Unsafe (unsafeDupablePerformIO)  #include <bzlib.h> -{-# NOINLINE decompress #-} -- | Don't use this on pathological input; it may not be secure -- -- @since 0.1.1.0 decompress :: BSL.ByteString -> BSL.ByteString-decompress bsl = unsafeDupablePerformIO $+decompress bsl =     let bss = BSL.toChunks bsl in-    BSL.fromChunks <$> bracket-        (do { p <- bzStreamInit ; bzDecompressInit p ; pure p })-        bZ2BzDecompressEnd-        (\p -> bzDecompressChunks p bss)+    BSL.fromChunks $ LazyST.runST $ do+        (p, bufOut) <- LazyST.unsafeIOToST $ do+            ptr <- bzStreamInit+            p <- castForeignPtr <$> newForeignPtr bZ2BzDecompressEnd (castPtr ptr)+            bzDecompressInit p+            bufOut <- mallocForeignPtrBytes bufSz+            pure (p, bufOut) -bzDecompressChunks :: Ptr BzStream -> [BS.ByteString] -> IO [BS.ByteString]-bzDecompressChunks p bs =+        bzDecompressChunks p bss bufOut -    bracket-        (mallocBytes bufSz)-        free-        (fmap snd . extractBuf bs)+type Step = Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> IO BZError -> IO (BZError, Maybe BS.ByteString, [BS.ByteString]) +bzDecompressChunks :: ForeignPtr BzStream -> [BS.ByteString] -> ForeignPtr a -> LazyST.ST s [BS.ByteString]+bzDecompressChunks ptr' bs bufO =++    fillBuf ptr' Nothing bs pushBytes bufO+     where-        -        -- thing-to-cons-to (cdr) -> backward-traveling state (?)-        -- ret value -> forward-traveling state!-        -- stuff "remaining" to be fed in could be forward-traveling state ?-        -- -> [BS.ByteString] Writer + BZError state :p -        -- corresponds to inner loop in zlib example-        fillBuf :: [BS.ByteString] -> Ptr a -> IO (BZError, [BS.ByteString])-        fillBuf bs' bufOut = do+        fillBuf :: ForeignPtr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> Step -> ForeignPtr a -> LazyST.ST s [BS.ByteString]+        fillBuf pForeign passFwd bs' step bufOutForeign = do+            (ret, szOut, newBSAp, bs'', keepAlive) <- LazyST.unsafeIOToST $ do+                withForeignPtr pForeign $ \p ->+                    withForeignPtr bufOutForeign $ \bufOut -> do -            {# set bz_stream.avail_out #} p bufSz-            {# set bz_stream.next_out #} p (castPtr bufOut)+                            let act = do -            ret <- bZ2BzDecompress p+                                    {# set bz_stream.avail_out #} p bufSz+                                    {# set bz_stream.next_out #} p (castPtr bufOut) -            szOut <- fromIntegral <$> {# get bz_stream->avail_out #} p+                                    bZ2BzDecompress ptr' -            let bytesAvail = bufSz - szOut+                            (ret, keepAlive, bs'') <- step p passFwd bs' act -            newBSAp <- if bytesAvail /= 0-                then (:) <$> BS.packCStringLen (castPtr bufOut, bytesAvail)-                else pure id+                            szOut <- fromIntegral <$> {# get bz_stream->avail_out #} p -            if ret == BzStreamEnd-                then pure (ret, newBSAp [])-                else if szOut == 0-                    then second newBSAp <$> fillBuf bs' bufOut-                    else second newBSAp <$> extractBuf bs' bufOut+                            let bytesAvail = bufSz - szOut -        -- corresponds to outer loop in zlib example-        extractBuf :: [BS.ByteString] -> Ptr a -> IO (BZError, [BS.ByteString])-        extractBuf [] bufOut = do+                            newBSAp <- if bytesAvail /= 0+                                then (:) <$> BS.packCStringLen (castPtr bufOut, bytesAvail)+                                else pure id -            (res, blocks) <- fillBuf [] bufOut+                            pure (ret, szOut, newBSAp, bs'', keepAlive) -            if res == BzStreamEnd-                then pure (BzStreamEnd, blocks)-                else extractBuf [] bufOut+            let step' = if szOut == 0+                then keepBytesAlive+                else pushBytes -        extractBuf (b:bs') bufOut =+            if ret == BzStreamEnd+                then pure (newBSAp [])+                else newBSAp <$> fillBuf pForeign keepAlive bs'' step' bufOutForeign++        keepBytesAlive :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> IO BZError -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])+        keepBytesAlive _ Nothing bs' act = (, Nothing, bs') <$> act+        keepBytesAlive _ passFwd@(Just b) bs' act = do+            BS.unsafeUseAsCStringLen b $ \_ -> do++                (, passFwd, bs') <$> act++        pushBytes :: Ptr BzStream -> Maybe BS.ByteString -> [BS.ByteString] -> IO BZError -> IO (BZError, Maybe BS.ByteString, [BS.ByteString])+        pushBytes _ _ [] act = (, Nothing, []) <$> act+        pushBytes p _ (b:bs') act =             BS.unsafeUseAsCStringLen b $ \(buf, sz) -> do                  {# set bz_stream.avail_in #} p (fromIntegral sz)                 {# set bz_stream.next_in #} p buf -                (res, blocks) <- fillBuf bs' bufOut--                if res == BzStreamEnd-                    then pure (BzStreamEnd, blocks)-                    else extractBuf bs' bufOut+                (, Just b, bs') <$> act -        bufSz :: Integral a => a-        bufSz = 32 * 1024+bufSz :: Integral a => a+bufSz = 32 * 1024 -bzDecompressInit :: Ptr BzStream -> IO ()-bzDecompressInit p = do+bzDecompressInit :: ForeignPtr BzStream -> IO ()+bzDecompressInit ptr' = do -    {# set bz_stream.next_in #} p nullPtr-    {# set bz_stream.avail_in #} p 0+    withForeignPtr ptr' $ \p -> do+        {# set bz_stream.next_in #} p nullPtr+        {# set bz_stream.avail_in #} p 0 -    bZ2BzDecompressInit p 0 False+    bZ2BzDecompressInit ptr' 0 False

@@ -1,7 +1,9 @@ module Main (main) where  import           Codec.Compression.BZip+import           Control.DeepSeq        (deepseq) import qualified Data.ByteString.Lazy   as BSL+import           System.Directory       (doesFileExist) import           System.FilePath        ((-<.>)) import           Test.Tasty import           Test.Tasty.Golden@@ -17,8 +19,29 @@     let actual = decompress (compress contents)     actual @?= contents +testValgrind :: TestTree+testValgrind = testCase "Unpack valgrind" $ do+    contents <- BSL.readFile "valgrind-3.15.0.tar.bz2"+    let actual = decompress contents+    assertBool "Unpacks w/o error" (actual `deepseq` True)++testValgrindPack :: TestTree+testValgrindPack = testCase "Pack valgrind" $ do+    contents <- BSL.readFile "valgrind-3.15.0.tar"+    let actual = compress contents+    assertBool "Packs w/o error" (actual `deepseq` True)+ main :: IO ()-main = defaultMain (testGroup "bz2" [testDecompression, testCompression])+main = do+    valgrind <- (&&) <$> doesFileExist "valgrind-3.15.0.tar.bz2" <*> doesFileExist "valgrind-3.15.0.tar"+    let go =+            if valgrind+                then (testValgrind:) . (testValgrindPack:)+                else id++    defaultMain $+        testGroup "bz2" (go [testDecompression, testCompression])+     where         testDecompression = testGroup "Decompress"             [ testDecompress "test/data/sample1.bz2"