diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,11 @@ +# 0.1.0.0 + +- Factor out `io-streams`-independent code to `lzma` package. + +- `CompressParams` and `DecompressParams` constructors aren't exported anymore + +- Add support for flush-operation on `OutputStream ByteString` + +# 0.0.0.0 + +Initial version diff --git a/cbits/lzma_wrapper.c b/cbits/lzma_wrapper.c deleted file mode 100644 --- a/cbits/lzma_wrapper.c +++ /dev/null @@ -1,65 +0,0 @@ -/* - * FFI wrappers for `lzma-streams` - * - * Copyright (c) 2014, Herbert Valerio Riedel - * - * This code is BSD3 licensed, see ../LICENSE file for details - * - */ - -#include -#include -#include -#include - -HsInt -hs_lzma_init_decoder(lzma_stream *ls, HsBool autolzma, uint64_t memlimit, uint32_t flags) -{ - /* recommended super-portable initialization */ - const lzma_stream ls_init = LZMA_STREAM_INIT; - *ls = ls_init; - - const lzma_ret ret = (autolzma ? lzma_auto_decoder : lzma_stream_decoder)(ls, memlimit, flags); - - return ret; -} - -HsInt -hs_lzma_init_encoder(lzma_stream *ls, uint32_t preset, HsInt check) -{ - /* recommended super-portable initialization */ - const lzma_stream ls_init = LZMA_STREAM_INIT; - *ls = ls_init; - - const lzma_ret ret = lzma_easy_encoder(ls, preset, check); - - return ret; -} - -void -hs_lzma_done(lzma_stream *ls) -{ - lzma_end(ls); -} - -HsInt -hs_lzma_run(lzma_stream *const ls, const HsInt action, - const uint8_t ibuf[], const HsInt ibuf_len, - uint8_t obuf[], const HsInt obuf_len) -{ - ls->next_in = ibuf; - ls->avail_in = ibuf_len; - ls->next_out = obuf; - ls->avail_out = obuf_len; - - // paranoia - memset(obuf, 0, obuf_len); - - const lzma_ret ret = lzma_code(ls, action); - - // paranoia - ls->next_in = NULL; - ls->next_out = NULL; - - return ret; -} diff --git a/lzma-streams.cabal b/lzma-streams.cabal --- a/lzma-streams.cabal +++ b/lzma-streams.cabal @@ -1,5 +1,5 @@ name: lzma-streams -version: 0.0.0.0 +version: 0.1.0.0 synopsis: IO-Streams interface for lzma/xz compression homepage: https://github.com/hvr/lzma-streams bug-reports: https://github.com/hvr/lzma-streams/issues @@ -12,6 +12,8 @@ category: Codec, Compression, IO-Streams build-type: Simple cabal-version: >=1.10 +tested-with: GHC ==7.4.2, GHC ==7.6.3, GHC ==7.8.4, GHC ==7.10.1 + description: This package provides an IO-Streams interface for the LZMA compression algorithm used in the @.xz@ file format. @@ -21,6 +23,8 @@ . See also the XZ Utils home page: +extra-source-files: CHANGELOG.md + source-repository head type: git location: https://github.com/hvr/lzma-streams.git @@ -32,15 +36,11 @@ hs-source-dirs: src exposed-modules: System.IO.Streams.Lzma - other-modules: LibLzma - includes: lzma.h - extra-libraries: lzma - c-sources: cbits/lzma_wrapper.c - build-depends: base >=4.5 && <4.9, bytestring >=0.9.2 && <0.11, - io-streams >=1.3 && <1.4 + io-streams >=1.3 && <1.4, + lzma ==0.0.* ghc-options: -Wall diff --git a/src-tests/lzma-streams-test.hs b/src-tests/lzma-streams-test.hs --- a/src-tests/lzma-streams-test.hs +++ b/src-tests/lzma-streams-test.hs @@ -11,7 +11,7 @@ main :: IO () main = defaultMain [ testGroup "System.IO.Streams.Lzma" tests ] where - tests = [ test0, test1, prop1, prop2 ] + tests = [ test0, test1, test2, prop1, prop2 ] test0 :: Test test0 = testCase "empty" $ (decode . encode) BS.empty @?= BS.empty @@ -20,6 +20,11 @@ test1 = testCase "hello" $ (decode . encode) bs @?= bs where bs = BS.pack [104,101,108,108,111] + +test2 :: Test +test2 = testCase "10MiB" $ (decode . encode) bs @?= bs + where + bs = BS.replicate (10*1024*1024) 0xaa prop1 :: Test prop1 = testProperty "random" go diff --git a/src/LibLzma.hsc b/src/LibLzma.hsc deleted file mode 100644 --- a/src/LibLzma.hsc +++ /dev/null @@ -1,282 +0,0 @@ -{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} - --- Copyright (c) 2014, Herbert Valerio Riedel --- --- This code is BSD3 licensed, see ../LICENSE file for details --- - --- | Internal low-level binding to liblzma --- --- TODO: Polish, generalise, and factor out into streaming-API --- agnostic package w/ minimal build-deps. --- Something in the style of the incremental API in --- "Codec.Compression.Zlib.Internal" would be nice --- -module LibLzma - ( LzmaStream - , LzmaRet(..) - , IntegrityCheck(..) - , CompressionLevel(..) - - , newDecodeLzmaStream - , DecompressParams(..) - , defaultDecompressParams - - , newEncodeLzmaStream - , CompressParams(..) - , defaultCompressParams - - , runLzmaStream - - , CompressStream(..) - , compressIO - ) where - -import Control.Applicative -import Control.Exception -import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString.Internal as BS -import qualified Data.ByteString.Unsafe as BS -import qualified Data.ByteString as BS -import Data.Typeable -import Foreign -import Prelude - -#include - -newtype LzmaStream = LS (ForeignPtr LzmaStream) - -data LzmaRet = LzmaRetOK - | LzmaRetStreamEnd - | LzmaRetUnsupportedCheck - | LzmaRetGetCheck - | LzmaRetMemError - | LzmaRetMemlimitError - | LzmaRetFormatError - | LzmaRetOptionsError - | LzmaRetDataError - | LzmaRetBufError - | LzmaRetProgError - deriving (Eq,Ord,Show,Typeable) - -instance Exception LzmaRet - -toLzmaRet :: Int -> Maybe LzmaRet -toLzmaRet i = case i of - (#const LZMA_OK ) -> Just LzmaRetOK - (#const LZMA_STREAM_END ) -> Just LzmaRetStreamEnd - (#const LZMA_UNSUPPORTED_CHECK) -> Just LzmaRetUnsupportedCheck - (#const LZMA_GET_CHECK ) -> Just LzmaRetGetCheck - (#const LZMA_MEM_ERROR ) -> Just LzmaRetMemError - (#const LZMA_MEMLIMIT_ERROR ) -> Just LzmaRetMemlimitError - (#const LZMA_FORMAT_ERROR ) -> Just LzmaRetFormatError - (#const LZMA_OPTIONS_ERROR ) -> Just LzmaRetOptionsError - (#const LZMA_DATA_ERROR ) -> Just LzmaRetDataError - (#const LZMA_BUF_ERROR ) -> Just LzmaRetBufError - (#const LZMA_PROG_ERROR ) -> Just LzmaRetProgError - _ -> Nothing - --- | Integrity check type (only supported when compressing @.xz@ files) -data IntegrityCheck = IntegrityCheckNone -- ^ disable integrity check (not recommended) - | IntegrityCheckCrc32 -- ^ CRC32 using the polynomial from IEEE-802.3 - | IntegrityCheckCrc64 -- ^ CRC64 using the polynomial from ECMA-182 - | IntegrityCheckSha256 -- ^ SHA-256 - deriving (Eq,Ord,Show) - --- | Compression level presets that define the tradeoff between --- computational complexity and compression ratio --- --- 'CompressionLevel0' has the lowest compression ratio as well as the --- lowest memory requirements, whereas 'CompressionLevel9' has the --- highest compression ratio and can require over 600MiB during --- compression (and over 60MiB during decompression). The --- --- contains more detailed information with tables describing the --- properties of all compression level presets. --- --- 'CompressionLevel6' is the default setting in --- 'defaultCompressParams' as it provides a good trade-off and --- matches the default of the @xz(1)@ tool. - -data CompressionLevel = CompressionLevel0 - | CompressionLevel1 - | CompressionLevel2 - | CompressionLevel3 - | CompressionLevel4 - | CompressionLevel5 - | CompressionLevel6 - | CompressionLevel7 - | CompressionLevel8 - | CompressionLevel9 - deriving (Eq,Ord,Show,Enum) - -fromIntegrityCheck :: IntegrityCheck -> Int -fromIntegrityCheck lc = case lc of - IntegrityCheckNone -> #const LZMA_CHECK_NONE - IntegrityCheckCrc32 -> #const LZMA_CHECK_CRC32 - IntegrityCheckCrc64 -> #const LZMA_CHECK_CRC64 - IntegrityCheckSha256 -> #const LZMA_CHECK_SHA256 - --- | Set of parameters for decompression. The defaults are 'defaultDecompressParams'. -data DecompressParams = DecompressParams - { decompressTellNoCheck :: !Bool - , decompressTellUnsupportedCheck :: !Bool - , decompressTellAnyCheck :: !Bool - , decompressConcatenated :: !Bool - , decompressAutoDecoder :: !Bool - , decompressMemLimit :: !Word64 -- ^ Set to 'maxBound' to disable memory limit - } deriving (Eq,Show) - --- | The default set of parameters for decompression. This is typically used with the decompressWith function with specific parameters overridden. -defaultDecompressParams :: DecompressParams -defaultDecompressParams = DecompressParams {..} - where - decompressTellNoCheck = False - decompressTellUnsupportedCheck = False - decompressTellAnyCheck = False - decompressConcatenated = True - decompressAutoDecoder = False - decompressMemLimit = maxBound -- disables limit-check - --- | Set of parameters for compression. The defaults are 'defaultCompressParams'. -data CompressParams = CompressParams - { compressIntegrityCheck :: !IntegrityCheck -- ^ Specify type of integrity check - , compressLevel :: !CompressionLevel -- ^ See documentation of 'CompressionLevel' - , compressLevelExtreme :: !Bool -- ^ Enable slower variant of the - -- 'lzmaCompLevel' preset, see @xz(1)@ - -- man-page for details. - } deriving (Eq,Show) - --- | The default set of parameters for compression. This is typically used with the compressWith function with specific parameters overridden. -defaultCompressParams :: CompressParams -defaultCompressParams = CompressParams {..} - where - compressIntegrityCheck = IntegrityCheckCrc64 - compressLevel = CompressionLevel6 - compressLevelExtreme = False - -newDecodeLzmaStream :: DecompressParams -> IO (Either LzmaRet LzmaStream) -newDecodeLzmaStream (DecompressParams {..}) = do - fp <- mallocForeignPtrBytes (#size lzma_stream) - addForeignPtrFinalizer c_hs_lzma_done_funptr fp - rc <- withForeignPtr fp (\ptr -> c_hs_lzma_init_decoder ptr decompressAutoDecoder decompressMemLimit flags') - rc' <- maybe (fail "newDecodeLzmaStream: invalid return code") pure $ toLzmaRet rc - - return $ case rc' of - LzmaRetOK -> Right (LS fp) - _ -> Left rc' - where - flags' = - (if decompressTellNoCheck then (#const LZMA_TELL_NO_CHECK) else 0) .|. - (if decompressTellUnsupportedCheck then (#const LZMA_TELL_UNSUPPORTED_CHECK) else 0) .|. - (if decompressTellAnyCheck then (#const LZMA_TELL_ANY_CHECK) else 0) .|. - (if decompressConcatenated then (#const LZMA_CONCATENATED) else 0) - -newEncodeLzmaStream :: CompressParams -> IO (Either LzmaRet LzmaStream) -newEncodeLzmaStream (CompressParams {..}) = do - fp <- mallocForeignPtrBytes (#size lzma_stream) - addForeignPtrFinalizer c_hs_lzma_done_funptr fp - rc <- withForeignPtr fp (\ptr -> c_hs_lzma_init_encoder ptr preset check) - rc' <- maybe (fail "newDecodeLzmaStream: invalid return code") pure $ toLzmaRet rc - - return $ case rc' of - LzmaRetOK -> Right (LS fp) - _ -> Left rc' - - where - preset = fromIntegral (fromEnum compressLevel) .|. - (if compressLevelExtreme then (#const LZMA_PRESET_EXTREME) else 0) - check = fromIntegrityCheck compressIntegrityCheck - -runLzmaStream :: LzmaStream -> ByteString -> Bool -> Int -> IO (LzmaRet,Int,ByteString) -runLzmaStream (LS ls) ibs finish buflen - | buflen <= 0 = fail "runLzmaStream: invalid buflen argument" - | otherwise = withForeignPtr ls $ \lsptr -> do - BS.unsafeUseAsCStringLen ibs $ \(ibsptr, ibslen) -> do - (obuf,rc) <- BS.createAndTrim' buflen $ \bufptr -> do - rc' <- c_hs_lzma_run lsptr action (castPtr ibsptr) ibslen bufptr buflen - rc'' <- maybe (fail "runLzmaStream: invalid return code") pure $ toLzmaRet rc' - - availOut <- (#peek lzma_stream, avail_out) lsptr - unless (buflen >= availOut && availOut >= 0) (fail "runLzmaStream: invalid avail_out") - let produced = buflen - availOut - - return (0, produced, rc'') - - availIn <- (#peek lzma_stream, avail_in) lsptr - unless (ibslen >= availIn && availIn >= 0) (fail "runLzmaStream: invalid avail_in") - let consumed = ibslen - availIn - - return (rc, fromIntegral consumed, obuf) - where - action = if finish then (#const LZMA_FINISH) else (#const LZMA_RUN) - ----------------------------------------------------------------------------- --- trivial helper wrappers defined in ../cbits/lzma_wrapper.c - -foreign import ccall "hs_lzma_init_decoder" - c_hs_lzma_init_decoder :: Ptr LzmaStream -> Bool -> Word64 -> Word32 -> IO Int - -foreign import ccall "hs_lzma_init_encoder" - c_hs_lzma_init_encoder :: Ptr LzmaStream -> Word32 -> Int -> IO Int - -foreign import ccall "hs_lzma_run" - c_hs_lzma_run :: Ptr LzmaStream -> Int -> Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Int - -foreign import ccall "&hs_lzma_done" - c_hs_lzma_done_funptr :: FunPtr (Ptr LzmaStream -> IO ()) - ----------------------------------------------------------------------------- - --- type stolen from 'zlib', we may actually just depend on zlib at some point in the future - -data CompressStream m = - CompressInputRequired (ByteString -> m (CompressStream m)) - | CompressOutputAvailable !ByteString (m (CompressStream m)) - | CompressStreamEnd - -compressIO :: CompressParams -> IO (CompressStream IO) -compressIO parms = newEncodeLzmaStream parms >>= either throwIO go - where - bUFSIZ = 32752 - - go :: LzmaStream -> IO (CompressStream IO) - go ls = return $ CompressInputRequired goInput - where - goInput :: ByteString -> IO (CompressStream IO) - goInput chunk - | BS.null chunk = goFinish - | otherwise = do - (rc, used, obuf) <- runLzmaStream ls chunk False bUFSIZ - - unless (used > 0) $ fail "compressIO: input chunk not consumed" - - let chunk' = BS.drop used chunk - - case rc of - LzmaRetOK - | BS.null obuf -> if BS.null chunk' - then return (CompressInputRequired goInput) - else goInput chunk' - - | otherwise -> return (CompressOutputAvailable obuf - (if BS.null chunk' - then return (CompressInputRequired goInput) - else goInput chunk')) - - _ -> throwIO rc - - goFinish :: IO (CompressStream IO) - goFinish = do - (rc, 0, obuf) <- runLzmaStream ls BS.empty True bUFSIZ - - case rc of - LzmaRetOK - | BS.null obuf -> fail "compressIO: empty output chunk" - | otherwise -> return (CompressOutputAvailable obuf goFinish) - LzmaRetStreamEnd - | BS.null obuf -> return CompressStreamEnd - | otherwise -> return (CompressOutputAvailable obuf (return CompressStreamEnd)) - - _ -> throwIO rc diff --git a/src/System/IO/Streams/Lzma.hs b/src/System/IO/Streams/Lzma.hs --- a/src/System/IO/Streams/Lzma.hs +++ b/src/System/IO/Streams/Lzma.hs @@ -14,87 +14,81 @@ ( -- * 'ByteString' decompression decompress , decompressWith - , defaultDecompressParams - , DecompressParams(..) + , Lzma.defaultDecompressParams + , Lzma.DecompressParams + , Lzma.compressIntegrityCheck + , Lzma.compressLevel + , Lzma.compressLevelExtreme -- * 'ByteString' compression , compress , compressWith - , defaultCompressParams - , CompressParams(..) - , IntegrityCheck(..) - , CompressionLevel(..) + , Lzma.defaultCompressParams + , Lzma.CompressParams + , Lzma.decompressTellNoCheck + , Lzma.decompressTellUnsupportedCheck + , Lzma.decompressTellAnyCheck + , Lzma.decompressConcatenated + , Lzma.decompressAutoDecoder + , Lzma.decompressMemLimit + , Lzma.IntegrityCheck(..) + , Lzma.CompressionLevel(..) ) where +import Codec.Compression.Lzma (DecompressStream(..), CompressStream(..)) +import qualified Codec.Compression.Lzma as Lzma + import Control.Exception import Control.Monad -import Data.ByteString (ByteString) -import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.IORef -import LibLzma -import System.IO.Streams (InputStream, OutputStream, makeInputStream, - makeOutputStream) -import qualified System.IO.Streams as Streams +import Data.Maybe +import System.IO.Streams (InputStream, OutputStream, + makeInputStream, makeOutputStream) +import qualified System.IO.Streams as Streams -- | Decompress an 'InputStream' of strict 'ByteString's from the @.xz@ format decompress :: InputStream ByteString -> IO (InputStream ByteString) -decompress = decompressWith defaultDecompressParams +decompress = decompressWith Lzma.defaultDecompressParams -- | Like 'decompress' but with the ability to specify various decompression -- parameters. Typical usage: -- -- > decompressWith defaultDecompressParams { decompress... = ... } -decompressWith :: DecompressParams -> InputStream ByteString -> IO (InputStream ByteString) -decompressWith flags ibs - = newDecodeLzmaStream flags >>= either throwIO (wrapLzmaInStream ibs) - --- TODO: figure out sensible buffer-size & refactor into generic --- incremental API in the style of zlib's incremental API -wrapLzmaInStream :: InputStream ByteString -> LzmaStream -> IO (InputStream ByteString) -wrapLzmaInStream ibs ls0 = do - st <- newIORef (Right ls0) +decompressWith :: Lzma.DecompressParams -> InputStream ByteString -> IO (InputStream ByteString) +decompressWith parms ibs = do + st <- newIORef =<< Lzma.decompressIO parms makeInputStream (go st) where - go st = readIORef st >>= either goLeft goRight - where - goRight ls = do - ibuf <- getChunk - - (rc, _, obuf) <- case ibuf of - Nothing -> runLzmaStream ls BS.empty True bUFSIZ - Just bs -> do - retval@(_, consumed, _) <- runLzmaStream ls bs False bUFSIZ - when (consumed < BS.length bs) $ do - Streams.unRead (BS.drop consumed bs) ibs - return retval - - unless (rc == LzmaRetOK) $ do - writeIORef st (Left rc) - unless (rc == LzmaRetStreamEnd) $ - throwIO rc - - case rc of - LzmaRetOK -> if (BS.null obuf) - then goRight ls -- feed de/encoder some more - else return (Just obuf) + go stref = do + st' <- goFeed =<< readIORef stref + case st' of + DecompressInputRequired _ -> do + writeIORef stref st' + fail "the impossible happened" - LzmaRetStreamEnd -> do - writeIORef st (Left rc) - if BS.null obuf - then return Nothing - else return (Just obuf) + DecompressOutputAvailable outb next -> do + writeIORef stref =<< next + return (Just outb) - _ -> writeIORef st (Left rc) >> throwIO rc + DecompressStreamEnd leftover -> do + unless (BS.null leftover) $ do + Streams.unRead leftover ibs + writeIORef stref (DecompressStreamEnd BS.empty) + return Nothing - goLeft err = case err of - LzmaRetStreamEnd -> return Nothing - _ -> throwIO err + DecompressStreamError rc -> do + writeIORef stref st' + throwIO rc - bUFSIZ = 32752 + -- feed engine + goFeed (DecompressInputRequired supply) = + goFeed =<< supply . fromMaybe BS.empty =<< getChunk + goFeed s = return s -- wrapper around 'read ibs' to retry until a non-empty ByteString or Nothing is returned - -- TODO: consider implementing flush semantics getChunk = do mbs <- Streams.read ibs case mbs of @@ -108,47 +102,48 @@ -- (in the @.xz@ format) into an 'OutputStream' that consumes -- uncompressed 'ByteString's compress :: OutputStream ByteString -> IO (OutputStream ByteString) -compress = compressWith defaultCompressParams +compress = compressWith Lzma.defaultCompressParams -- | Like 'compress' but with the ability to specify various compression -- parameters. Typical usage: -- -- > compressWith defaultCompressParams { compress... = ... } -compressWith :: CompressParams -> OutputStream ByteString -> IO (OutputStream ByteString) +compressWith :: Lzma.CompressParams -> OutputStream ByteString -> IO (OutputStream ByteString) compressWith parms obs = do - st <- newIORef =<< compressIO parms + st <- newIORef =<< Lzma.compressIO parms makeOutputStream (go st) where - go stref (Just chunk) - | BS.null chunk = return () -- we don't support flushing yet - | otherwise = do - st <- readIORef stref - st' <- case st of - CompressInputRequired supply -> goOutput =<< supply chunk - _ -> fail "compressWith: unexpected state" - writeIORef stref st' - - case st' of - CompressInputRequired _ -> return () - _ -> fail "compressWith: unexpected state" - + go stref (Just chunk) = do + st <- readIORef stref + st' <- case st of + CompressInputRequired flush supply + | BS.null chunk -> goOutput True =<< flush + | otherwise -> goOutput False =<< supply chunk + _ -> fail "compressWith: unexpected state" + writeIORef stref st' + case st' of + CompressInputRequired _ _ -> return () + _ -> fail "compressWith: unexpected state" -- EOF go stref Nothing = do st <- readIORef stref st' <- case st of - CompressInputRequired supply -> goOutput =<< supply BS.empty + CompressInputRequired _ supply -> goOutput False =<< supply BS.empty _ -> fail "compressWith[EOF]: unexpected state" writeIORef stref st' case st' of CompressStreamEnd -> return () _ -> fail "compressWith[EOF]: unexpected state" - goOutput st@(CompressInputRequired _) = do + -- Drain output from CompressStream + goOutput flush st@(CompressInputRequired _ _) = do + when flush $ + Streams.write (Just BS.empty) obs return st - goOutput (CompressOutputAvailable obuf next) = do + goOutput flush (CompressOutputAvailable obuf next) = do Streams.write (Just obuf) obs - goOutput =<< next - goOutput st@CompressStreamEnd = do + goOutput flush =<< next + goOutput _ st@CompressStreamEnd = do Streams.write Nothing obs return st