diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,8 @@ +Version 0.0.14.0 2024-02-16 by luispedro + * Data.Conduit.Lzma2: Incorporate Data.Conduit.Lzma2 (adapted from + lzma-conduit) instead of using the external lzma-conduit package as that + is no longer maintained. + Version 0.0.13.0 2022-08-01 by luispedro * Support non-default values for compression level in more compression formats diff --git a/Data/Conduit/Algorithms/Async.hs b/Data/Conduit/Algorithms/Async.hs --- a/Data/Conduit/Algorithms/Async.hs +++ b/Data/Conduit/Algorithms/Async.hs @@ -47,7 +47,7 @@ import qualified Data.Conduit.TQueue as CA import qualified Data.Conduit.List as CL import qualified Data.Conduit.Zlib as CZ -import qualified Data.Conduit.Lzma as CX +import qualified Data.Conduit.Lzma2 as CX import qualified Data.Streaming.Zlib as SZ import qualified Data.Conduit.BZlib as CBZ import qualified Data.Conduit.Zstd as CZstd diff --git a/Data/Conduit/Lzma2.hs b/Data/Conduit/Lzma2.hs new file mode 100644 --- /dev/null +++ b/Data/Conduit/Lzma2.hs @@ -0,0 +1,105 @@ +{-- Originally from the lzma-conduit package + -- https://hackage.haskell.org/package/lzma-conduit + -- + -- Adapted & updated + -} +module Data.Conduit.Lzma2(compress, compressWith, decompress, decompressWith) where + +import qualified Codec.Compression.Lzma as Lzma +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Control.Monad.Trans.Resource +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.Conduit +import Data.Conduit.List (peek) +import Data.Maybe (fromMaybe) +import Data.Word + +prettyRet + :: Lzma.LzmaRet + -> String +prettyRet r = case r of + Lzma.LzmaRetOK -> "Operation completed successfully" + Lzma.LzmaRetStreamEnd -> "End of stream was reached" + Lzma.LzmaRetUnsupportedCheck -> "Cannot calculate the integrity check" + Lzma.LzmaRetGetCheck -> "Integrity check type is now available" + Lzma.LzmaRetMemError -> "Cannot allocate memory" + Lzma.LzmaRetMemlimitError -> "Memory usage limit was reached" + Lzma.LzmaRetFormatError -> "File format not recognized" + Lzma.LzmaRetOptionsError -> "Invalid or unsupported options" + Lzma.LzmaRetDataError -> "Data is corrupt" + Lzma.LzmaRetBufError -> "No progress is possible" + Lzma.LzmaRetProgError -> "Programming error" + + +-- | Decompress a 'ByteString' from a lzma or xz container stream. +decompress + :: (MonadThrow m, MonadIO m) + => Maybe Word64 -- ^ Memory limit, in bytes. + -> ConduitM ByteString ByteString m () +decompress memlimit = + decompressWith Lzma.defaultDecompressParams + { Lzma.decompressMemLimit = fromMaybe maxBound memlimit + , Lzma.decompressAutoDecoder = True + , Lzma.decompressConcatenated = True + } + +decompressWith + :: (MonadThrow m, MonadIO m) + => Lzma.DecompressParams + -> ConduitM ByteString ByteString m () +decompressWith parms = do + c <- peek + case c of + Nothing -> throwM $ userError "Data.Conduit.Lzma.decompress: invalid empty input" + Just _ -> liftIO (Lzma.decompressIO parms) >>= go + where + go s@(Lzma.DecompressInputRequired more) = do + mx <- await + case mx of + Just x + | B.null x -> go s -- ignore/skip empty bytestring chunks + | otherwise -> liftIO (more x) >>= go + Nothing -> liftIO (more B.empty) >>= go + go (Lzma.DecompressOutputAvailable output cont) = do + yield output + liftIO cont >>= go + go (Lzma.DecompressStreamEnd rest) + | B.null rest = return () + | otherwise = leftover rest + go (Lzma.DecompressStreamError err) = + throwM $ userError $ "Data.Conduit.Lzma.decompress: error: "++prettyRet err + + +-- | Compress a 'ByteString' into a xz container stream. +compress + :: (MonadIO m) + => Maybe Int -- ^ Compression level from [0..9], defaults to 6. + -> ConduitM ByteString ByteString m () +compress level = + compressWith Lzma.defaultCompressParams { Lzma.compressLevel = level' } + where + level' = case level of + Nothing -> Lzma.CompressionLevel6 + Just n -> let + n' = max minBound (min maxBound n) -- clamp to [minBound..maxBound] range + in toEnum n' + +compressWith + :: MonadIO m + => Lzma.CompressParams + -> ConduitM ByteString ByteString m () +compressWith parms = + liftIO (Lzma.compressIO parms) >>= go + where + go s@(Lzma.CompressInputRequired _flush more) = do + mx <- await + case mx of + Just x + | B.null x -> go s -- ignore/skip empty bytestring chunks + | otherwise -> liftIO (more x) >>= go + Nothing -> liftIO (more B.empty) >>= go + go (Lzma.CompressOutputAvailable output cont) = do + yield output + liftIO cont >>= go + go Lzma.CompressStreamEnd = return () diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -14,3 +14,5 @@ ## Author Luis Pedro Coelho | [Email](mailto:luis@luispedro.org) | [Twitter](https://twitter.com/luispedrocoelho) + +Since version `0.0.14.0`, this includes code originally in [lzma-conduit](https://github.com/alphaHeavy/lzma-conduit) from Alpha Heavy Industries diff --git a/conduit-algorithms.cabal b/conduit-algorithms.cabal --- a/conduit-algorithms.cabal +++ b/conduit-algorithms.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.36.0. -- -- see: https://github.com/sol/hpack --- --- hash: 92a9214b73c5e10d0b9b949f0ee1ff3be9366c137750238aa91f8b3ce28ba130 name: conduit-algorithms -version: 0.0.13.0 +version: 0.0.14.0 synopsis: Conduit-based algorithms description: Algorithms on Conduits, including higher level asynchronous processing and some other utilities. category: Conduit @@ -28,6 +26,7 @@ library exposed-modules: + Data.Conduit.Lzma2 Data.Conduit.Algorithms Data.Conduit.Algorithms.Utils Data.Conduit.Algorithms.Async @@ -52,7 +51,7 @@ , deepseq , exceptions , fingertree - , lzma-conduit + , lzma , monad-control , mtl , resourcet @@ -62,17 +61,18 @@ , transformers , unliftio-core , vector + default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS - default-language: Haskell2010 test-suite conduit-algorithms-test type: exitcode-stdio-1.0 main-is: Tests.hs other-modules: + TestLZMA Paths_conduit_algorithms hs-source-dirs: - ./tests + tests default-extensions: BangPatterns OverloadedStrings @@ -96,7 +96,7 @@ , directory , exceptions , fingertree - , lzma-conduit + , lzma , monad-control , mtl , resourcet @@ -110,9 +110,9 @@ , transformers , unliftio-core , vector + default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS - default-language: Haskell2010 benchmark conduit-algorithms-bench type: exitcode-stdio-1.0 @@ -140,7 +140,7 @@ , deepseq , exceptions , fingertree - , lzma-conduit + , lzma , monad-control , mtl , resourcet @@ -150,6 +150,6 @@ , transformers , unliftio-core , vector + default-language: Haskell2010 if os(windows) cpp-options: -DWINDOWS - default-language: Haskell2010 diff --git a/tests/TestLZMA.hs b/tests/TestLZMA.hs new file mode 100644 --- /dev/null +++ b/tests/TestLZMA.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE TemplateHaskell, QuasiQuotes #-} +module TestLZMA + ( tgroup_lzma + ) where +import Test.Tasty.TH +import Test.Tasty.HUnit (assertFailure, (@?=)) +import Test.Tasty.QuickCheck +import Test.QuickCheck.Monadic (monadicIO, run, pick, pre, assert) +import Control.Monad.Trans.Resource + +import qualified Data.ByteString as B +import qualified Data.Conduit as C +import qualified Data.Conduit.List as CL +import Conduit ((.|)) +import Data.Word +import Data.Conduit.Lzma2 +import System.IO.Error (tryIOError) + +tgroup_lzma = $(testGroupGenerator) + +assertLeft (Left _) = return () +assertLeft _ = run $ assertFailure "Expected Left, got Right" + +someString :: Gen B.ByteString +someString = do + val <- listOf $ elements [0..255::Word8] + return $ B.pack val + +runC :: MonadUnliftIO m => C.ConduitT () C.Void (ResourceT m) a -> m a +runC = runResourceT . C.runConduit + +newtype BigString = BigString B.ByteString + deriving (Eq, Show) + + +instance Arbitrary BigString where + arbitrary = BigString <$> resize (1024*16) someString + +prop_compressAndDiscard :: BigString -> Property +prop_compressAndDiscard (BigString str) = monadicIO $ do + run . runC $ + CL.sourceList [str] + .| compress Nothing + .| CL.sinkNull + +prop_compressAndCheckLength :: BigString -> Property +prop_compressAndCheckLength (BigString str) = monadicIO $ do + len <- run . runC $ + CL.sourceList [str] + .| compress Nothing + .| CL.fold (\ acc el -> acc + B.length el) 0 + -- random strings don't compress very well + assert $ len > B.length str `div` 2 + assert $ len - 64 < B.length str * 2 + +prop_chain :: BigString -> Property +prop_chain (BigString str) = monadicIO . run $ do + str' <- runC $ + CL.sourceList [str] + .| compress Nothing + .| decompress Nothing + .| CL.consume + str @?= B.concat str' + +prop_compressThenDecompress :: BigString -> Property +prop_compressThenDecompress (BigString str) = monadicIO $ do + blob <- run . runC $ CL.sourceList [str] .| compress Nothing .| CL.consume + let blob' = B.concat blob + randIdx <- pick $ elements [0..B.length blob'-1] + let resplit = let (x,y) = B.splitAt randIdx blob' in [x,y] + str' <- run . runC $ CL.sourceList resplit .| decompress Nothing .| CL.consume + run $ str @?= B.concat str' + + +prop_decompressRandom :: BigString -> Property +prop_decompressRandom (BigString str) = monadicIO $ do + -- The BigString is not necessarily big. It can even be the empty string + -- https://github.com/alphaHeavy/lzma-conduit/issues/19 + pre $ B.length str > 64 + header <- run . runC $ + CL.sourceList [] + .| compress Nothing + .| CL.consume + let blob = header ++ [str] + ioErrorE <- run $ + tryIOError (runC $ CL.sourceList blob .| decompress Nothing .| CL.sinkNull) + assertLeft ioErrorE + +prop_decompressCorrupt :: BigString -> Property +prop_decompressCorrupt (BigString str) = monadicIO $ do + header <- run . runC $ (CL.sourceList [] .| compress Nothing .| CL.consume) + let header' = B.concat header + randVal <- pick $ elements [0..255::Word8] + randIdx <- pick $ elements [0..B.length header'-1] + let (left, right) = B.splitAt randIdx header' + updated = left `B.append` (randVal `B.cons` B.tail right) + blob = [updated, str] + ioErrorE <- run $ + tryIOError (runC $ CL.sourceList blob .| decompress Nothing .| CL.sinkNull) + assertLeft ioErrorE + + +prop_decompressEmpty :: Property +prop_decompressEmpty = monadicIO $ do + count <- pick $ elements [0..10] + let blob = replicate count B.empty + ioErrorE <- run . tryIOError . runC $ CL.sourceList blob .| decompress Nothing .| CL.sinkNull + assertLeft ioErrorE diff --git a/tests/Tests.hs b/tests/Tests.hs --- a/tests/Tests.hs +++ b/tests/Tests.hs @@ -1,9 +1,10 @@ -{- Copyright 2017-2021 Luis Pedro Coelho +{- Copyright 2017-2024 Luis Pedro Coelho - License: MIT -} {-# LANGUAGE TemplateHaskell, CPP, QuasiQuotes, FlexibleContexts, OverloadedStrings #-} module Main where +import Test.Tasty import Test.Tasty.TH import Test.Tasty.HUnit @@ -31,8 +32,12 @@ import qualified Data.Conduit.Algorithms.Async as CAlg import qualified Data.Conduit.Algorithms.Async.ByteString as CAlg +import TestLZMA (tgroup_lzma) + main :: IO () -main = $(defaultMainGenerator) +main = defaultMain $ testGroup "All tests" [tgroup_lzma, maintests] + +maintests = $(testGroupGenerator) testingFileNameGZ :: FilePath testingFileNameGZ = "file_just_for_testing_delete_me_please.gz"