xz (empty) → 5.6.3
raw patch · 7 files changed
+956/−0 lines, 7 filesdep +HUnitdep +QuickCheckdep +base
Dependencies added: HUnit, QuickCheck, base, bytestring, tasty, tasty-hunit, tasty-quickcheck, xz, xz-clib
Files
- Changelog.md +32/−0
- LICENSE +30/−0
- cbits/lzma_wrapper.c +65/−0
- src-tests/lzma-tests.hs +98/−0
- src/Codec/Compression/Lzma.hs +402/−0
- src/LibLzma.hsc +251/−0
- xz.cabal +78/−0
+ Changelog.md view
@@ -0,0 +1,32 @@+## 5.6.3++* Fork cbits off and rename package+* Also allow to link to system lzma++## 5.2.5.5++* Support GHC 9.4++## 5.2.5.4++* Add Freebsd Aarch64 support++## 5.2.5.3++* Add darwin aarch64 support++## 5.2.5.2++* Add arm/aarch support++## 5.2.5.1++* Add FreeBSD support++## 5.2.5++* Fork the project++## 0.0.0.3++* Fix potential reentrancy issue also discovered in `zlib` ([#4](https://github.com/hvr/lzma/issues/4))
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2015, Herbert Valerio Riedel++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Herbert Valerio Riedel nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ cbits/lzma_wrapper.c view
@@ -0,0 +1,65 @@+/*+ * FFI wrappers for `lzma-streams`+ *+ * Copyright (c) 2014, Herbert Valerio Riedel <hvr@gnu.org>+ *+ * This code is BSD3 licensed, see ../LICENSE file for details+ *+ */++#include <stdio.h>+#include <string.h>+#include <lzma.h>+#include <HsFFI.h>++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;+}
+ src-tests/lzma-tests.hs view
@@ -0,0 +1,98 @@+module Main (main) where++import Control.Applicative+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Char8 as BL8+import Data.List+import Data.Monoid+import Prelude++import Test.Tasty+import Test.Tasty.QuickCheck as QC+import Test.Tasty.HUnit++import Codec.Compression.Lzma as Lzma++main :: IO ()+main = defaultMain tests++-- this is supposed to be equivalent to 'id'+codecompress :: BL.ByteString -> BL.ByteString+codecompress = decompress . compress++newtype ZeroBS = ZeroBS BL.ByteString++instance Show ZeroBS where+ show (ZeroBS s) | BL.length s > 0 = "ZeroBS (replicate " ++ show (BL.length s) ++ " " ++ show (BL.head s) ++ ")"+ | otherwise = "ZeroBS (empty)"++instance Arbitrary ZeroBS where+ arbitrary = do+ len <- choose (0, 1*1024*1024) -- up to 1MiB+ return $ (ZeroBS $ BL.replicate len 0)++-- shrink (ABS bs) = map ABS $ shrinks bs++randBS :: Int -> Gen BS.ByteString+randBS n = BS.pack `fmap` vectorOf n (choose (0, 255))++randBL :: Gen BL.ByteString+randBL = do+ ns <- arbitrary+ chunks <- mapM (randBS . (`mod` 10240)) ns+ return $ BL.fromChunks chunks++newtype RandBLSm = RandBLSm BL.ByteString+ deriving Show++newtype RandBL = RandBL BL.ByteString+ deriving Show++instance Arbitrary RandBL where+ arbitrary = RandBL <$> randBL++instance Arbitrary RandBLSm where+ arbitrary = do+ n <- choose (0,1024)+ RandBLSm . BL.fromChunks . (:[]) <$> randBS n++tests :: TestTree+tests = testGroup "ByteString API" [unitTests, properties]+ where+ unitTests = testGroup "testcases"+ [ testCase "decode-empty" $ decompress nullxz @?= BL.empty+ , testCase "encode-empty" $ codecompress BL.empty @?= BL.empty+ , testCase "encode-hello" $ codecompress (BL8.pack "hello") @?= BL8.pack "hello"+ , testCase "encode-hello2" $ codecompress (singletonChunked $ BL8.pack "hello") @?= BL8.pack "hello"+ , testCase "decode-sample" $ decompress samplexz @?= sampleref+ , testCase "decode-sample2" $ decompress (singletonChunked samplexz) @?= sampleref+ , testCase "encode-sample" $ codecompress sampleref @?= sampleref+ , testCase "encode-empty^50" $ (iterate decompress (iterate (compressWith lowProf) (BL8.pack "") !! 50) !! 50) @?= BL8.pack ""+ , testCase "encode-10MiB-zeros" $ let z = BL.replicate (10*1024*1024) 0 in codecompress z @?= z+ ]++ properties = testGroup "properties"+ [ QC.testProperty "decompress . compress === id (zeros)" $+ \(ZeroBS bs) -> codecompress bs == bs++ , QC.testProperty "decompress . compress === id (chunked)" $+ \(RandBL bs) -> codecompress bs == bs++ , QC.testProperty "decompress . (compress a <> compress b) === a <> b" $+ \(RandBLSm a) (RandBLSm b) -> decompress (compress a `mappend` compress b) == a `mappend` b+ ]++ lowProf = defaultCompressParams { compressLevel = CompressionLevel0 }++nullxz :: BL.ByteString+nullxz = BL.pack [253,55,122,88,90,0,0,4,230,214,180,70,0,0,0,0,28,223,68,33,31,182,243,125,1,0,0,0,0,4,89,90]++samplexz :: BL.ByteString+samplexz = BL.pack [253,55,122,88,90,0,0,4,230,214,180,70,2,0,33,1,16,0,0,0,168,112,142,134,224,1,149,0,44,93,0,42,26,9,39,100,25,234,181,131,189,58,102,36,15,228,64,252,88,41,53,203,78,255,4,93,168,153,174,39,186,76,120,56,49,148,191,144,96,136,20,247,240,0,0,0,157,204,158,16,53,174,37,20,0,1,72,150,3,0,0,0,130,33,173,108,177,196,103,251,2,0,0,0,0,4,89,90]++singletonChunked :: BL.ByteString -> BL.ByteString+singletonChunked = BL.fromChunks . map BS.singleton . BL.unpack++sampleref :: BL.ByteString+sampleref = BL.concat (intersperse (BL8.pack " ") $ replicate 11 $ BL8.pack "This sentence occurs multiple times.")
+ src/Codec/Compression/Lzma.hs view
@@ -0,0 +1,402 @@+{-# LANGUAGE BangPatterns #-}++-- |+-- Module : Codec.Compression.Lzma+-- Copyright : © 2015 Herbert Valerio Riedel+-- License : BSD3+--+-- Maintainer : hvr@gnu.org+-- Stability : experimental+--+-- Compression and decompression of data streams in the lzma/xz format+--+-- See also the XZ Utils home page: <http://tukaani.org/xz/>+module Codec.Compression.Lzma+ ( -- * Simple (de)compression+ compress+ , decompress++ -- * Extended API with control over parameters+ , compressWith+ , decompressWith++ -- * Monadic incremental (de)compression API+ --+ -- | See <http://hackage.haskell.org/package/zlib-0.6.1.1/docs/Codec-Compression-Zlib-Internal.html#g:2 zlib's incremental API documentation> for more information.++ -- ** Compression+ , CompressStream(..)+ , compressIO+ , compressST++ -- ** Decompression+ , DecompressStream(..)+ , decompressIO+ , decompressST+ , LzmaRet(..)++ -- * Parameters+ -- ** Compression parameters+ , defaultCompressParams++ , CompressParams+ , compressIntegrityCheck+ , compressLevel+ , compressLevelExtreme++ , IntegrityCheck(..)+ , CompressionLevel(..)++ -- ** Decompression parameters+ , defaultDecompressParams++ , DecompressParams+ , decompressTellNoCheck+ , decompressTellUnsupportedCheck+ , decompressTellAnyCheck+ , decompressConcatenated+ , decompressAutoDecoder+ , decompressMemLimit+ ) where++import Control.Exception+import Control.Monad+import Control.Monad.ST (stToIO)+import Control.Monad.ST.Lazy (ST, runST, strictToLazyST)+import qualified Control.Monad.ST.Strict as ST.Strict (ST)+import Control.Monad.ST.Unsafe (unsafeIOToST)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Lazy.Internal as BSL+import GHC.IO (noDuplicate)+import LibLzma++-- | Decompress lazy 'ByteString' from the @.xz@ format+decompress :: BSL.ByteString -> BSL.ByteString+decompress = decompressWith defaultDecompressParams++-- | Like 'decompress' but with the ability to specify various decompression+-- parameters. Typical usage:+--+-- > decompressWith defaultDecompressParams { decompress... = ... }+decompressWith :: DecompressParams -> BSL.ByteString -> BSL.ByteString+decompressWith parms input = runST (decompress' input)+ where+ decompress' :: BSL.ByteString -> ST s BSL.ByteString+ decompress' ibs0 = loop ibs0 =<< decompressST parms+ where+ loop BSL.Empty (DecompressStreamEnd rest)+ | BS.null rest = return BSL.Empty+ | otherwise = error "Codec.Compression.Lzma.decompressWith: trailing data"+ loop (BSL.Chunk _ _) (DecompressStreamEnd _) =+ error "Codec.Compression.Lzma.decompressWith: trailing data"+ loop _ (DecompressStreamError e) =+ error ("Codec.Compression.Lzma.decompressWith: decoding error " ++ show e)+ loop BSL.Empty (DecompressInputRequired supply) =+ loop BSL.Empty =<< supply BS.empty+ loop (BSL.Chunk c bs') (DecompressInputRequired supply) =+ loop bs' =<< supply c+ loop ibs (DecompressOutputAvailable oc next) = do+ obs <- loop ibs =<< next+ return (BSL.chunk oc obs)++{-# NOINLINE decompressWith #-}++----------------------------------------------------------------------------+----------------------------------------------------------------------------++-- | Compress lazy 'ByteString' into @.xz@ format using 'defaultCompressParams'.+compress :: BSL.ByteString -> BSL.ByteString+compress = compressWith defaultCompressParams++-- | Like 'compress' but with the ability to specify various compression+-- parameters. Typical usage:+--+-- > compressWith defaultCompressParams { compress... = ... }+compressWith :: CompressParams -> BSL.ByteString -> BSL.ByteString+compressWith parms input = runST (compress' input)+ where+ compress' :: BSL.ByteString -> ST s BSL.ByteString+ compress' ibs0 = loop ibs0 =<< compressST parms+ where+ loop BSL.Empty CompressStreamEnd =+ return BSL.Empty+ loop (BSL.Chunk _ _) CompressStreamEnd =+ error "Codec.Compression.Lzma.compressWith: the impossible happened"+ loop BSL.Empty (CompressInputRequired _ supply) =+ loop BSL.Empty =<< supply BS.empty+ loop (BSL.Chunk c bs') (CompressInputRequired _ supply) =+ loop bs' =<< supply c+ loop ibs (CompressOutputAvailable oc next) = do+ obs <- loop ibs =<< next+ return (BSL.chunk oc obs)+{-# NOINLINE compressWith #-}++--------------------------------------------------------------------------------+--------------------------------------------------------------------------------++-- Type derived from 'zlib' and augmented with flushing support++data CompressStream m =+ CompressInputRequired {- flush -} (m (CompressStream m))+ {- supply -} (ByteString -> m (CompressStream m))+ -- ^ Compression process requires input to proceed. You can+ -- either flush the stream (first field), supply an input chunk+ -- (second field), or signal the end of input (via empty+ -- chunk).+ | CompressOutputAvailable !ByteString (m (CompressStream m)) -- ^ Output chunk available.+ | CompressStreamEnd++-- | Incremental compression in the 'IO' monad.+compressIO :: CompressParams -> IO (CompressStream IO)+compressIO parms = (stToIO $ newEncodeLzmaStream parms) >>= either throwIO go+ where+ bUFSIZ = 32752++ go :: LzmaStream -> IO (CompressStream IO)+ go ls = return inputRequired+ where+ inputRequired = CompressInputRequired goFlush (withChunk goFinish goInput)++ goInput :: ByteString -> IO (CompressStream IO)+ goInput chunk = do+ (rc, used, obuf) <- stToIO $ runLzmaStream ls chunk LzmaRun bUFSIZ++ let chunk' = BS.drop used chunk++ case rc of+ LzmaRetOK+ | BS.null obuf -> do+ unless (used > 0) $+ fail "compressIO: input chunk not consumed"+ withChunk (return inputRequired) goInput chunk'+ | otherwise -> return (CompressOutputAvailable obuf+ (withChunk (return inputRequired) goInput chunk'))++ _ -> throwIO rc++ goFlush, goFinish :: IO (CompressStream IO)+ goFlush = goSync LzmaSyncFlush (return inputRequired)+ goFinish = goSync LzmaFinish retStreamEnd++ -- drain encoder till LzmaRetStreamEnd is reported+ goSync :: LzmaAction -> IO (CompressStream IO) -> IO (CompressStream IO)+ goSync LzmaRun _ = fail "goSync called with invalid argument"+ goSync action next = goSync'+ where+ goSync' = do+ (rc, 0, obuf) <- stToIO $ runLzmaStream ls BS.empty action bUFSIZ+ case rc of+ LzmaRetOK+ | BS.null obuf -> fail ("compressIO: empty output chunk during " ++ show action)+ | otherwise -> return (CompressOutputAvailable obuf goSync')+ LzmaRetStreamEnd+ | BS.null obuf -> next+ | otherwise -> return (CompressOutputAvailable obuf next)+ _ -> throwIO rc++ retStreamEnd = do+ !() <- stToIO (endLzmaStream ls)+ return CompressStreamEnd++-- | Incremental compression in the lazy 'ST' monad.+compressST :: CompressParams -> ST s (CompressStream (ST s))+compressST parms = strictToLazyST (newEncodeLzmaStream parms) >>=+ either throw go+ where+ bUFSIZ = 32752++ go ls = return inputRequired+ where+ inputRequired = CompressInputRequired goFlush (withChunk goFinish goInput)++ goInput :: ByteString -> ST s (CompressStream (ST s))+ goInput chunk = do+ (rc, used, obuf) <- strictToLazyST (noDuplicateST >>+ runLzmaStream ls chunk LzmaRun bUFSIZ)++ let chunk' = BS.drop used chunk++ case rc of+ LzmaRetOK+ | BS.null obuf -> do+ unless (used > 0) $+ error "compressST: input chunk not consumed"+ withChunk (return inputRequired) goInput chunk'+ | otherwise -> return (CompressOutputAvailable obuf+ (withChunk (return inputRequired) goInput chunk'))++ _ -> throw rc++ goFlush, goFinish :: ST s (CompressStream (ST s))+ goFlush = goSync LzmaSyncFlush (return inputRequired)+ goFinish = goSync LzmaFinish retStreamEnd++ -- drain encoder till LzmaRetStreamEnd is reported+ goSync :: LzmaAction -> ST s (CompressStream (ST s)) -> ST s (CompressStream (ST s))+ goSync LzmaRun _ = error "compressST: goSync called with invalid argument"+ goSync action next = goSync'+ where+ goSync' = do+ (rc, n, obuf) <- strictToLazyST (noDuplicateST >>+ runLzmaStream ls BS.empty action bUFSIZ)+ when (n /= 0) $ error "compressST: n was not zero"+ case rc of+ LzmaRetOK+ | BS.null obuf -> error ("compressIO: empty output chunk during " ++ show action)+ | otherwise -> return (CompressOutputAvailable obuf goSync')+ LzmaRetStreamEnd+ | BS.null obuf -> next+ | otherwise -> return (CompressOutputAvailable obuf next)+ _ -> throw rc++ retStreamEnd = do+ !() <- strictToLazyST (noDuplicateST >> endLzmaStream ls)+ return CompressStreamEnd++--------------------------------------------------------------------------------++data DecompressStream m =+ DecompressInputRequired (ByteString -> m (DecompressStream m)) -- ^ Decoding process requires input to proceed. An empty 'ByteString' chunk signals end of input.+ | DecompressOutputAvailable !ByteString (m (DecompressStream m)) -- ^ Decompressed output chunk available.+ | DecompressStreamEnd ByteString -- ^ Decoded stream is finished. Any unconsumed leftovers from the input stream are returned via the 'ByteString' field+ | DecompressStreamError !LzmaRet -- TODO define subset-enum of LzmaRet++-- | Incremental decompression in the 'IO' monad.+decompressIO :: DecompressParams -> IO (DecompressStream IO)+decompressIO parms = stToIO (newDecodeLzmaStream parms) >>= either (return . DecompressStreamError) go+ where+ bUFSIZ = 32752++ go :: LzmaStream -> IO (DecompressStream IO)+ go ls = return inputRequired+ where+ inputRequired = DecompressInputRequired goInput++ goInput :: ByteString -> IO (DecompressStream IO)+ goInput chunk+ | BS.null chunk = goFinish+ | otherwise = do+ (rc, used, obuf) <- stToIO $ runLzmaStream ls chunk LzmaRun bUFSIZ++ let chunk' = BS.drop used chunk++ case rc of+ LzmaRetOK+ | BS.null obuf -> do+ unless (used > 0) $+ fail "decompressIO: input chunk not consumed"+ withChunk (return inputRequired) goInput chunk'+ | otherwise -> return (DecompressOutputAvailable obuf+ (withChunk goDrain goInput chunk'))++ LzmaRetStreamEnd+ | BS.null obuf -> retStreamEnd chunk'+ | otherwise -> return (DecompressOutputAvailable obuf+ (retStreamEnd chunk'))++ _ -> return (DecompressStreamError rc)++ goDrain, goFinish :: IO (DecompressStream IO)+ goDrain = goSync LzmaRun (return inputRequired)+ goFinish = goSync LzmaFinish (return $ DecompressStreamError LzmaRetOK)++ goSync :: LzmaAction -> IO (DecompressStream IO) -> IO (DecompressStream IO)+ goSync action next = goSync'+ where+ goSync' = do+ (rc, 0, obuf) <- stToIO $ runLzmaStream ls BS.empty action bUFSIZ+ case rc of+ LzmaRetOK+ | BS.null obuf -> next+ | otherwise -> return (DecompressOutputAvailable obuf goSync')++ LzmaRetStreamEnd+ | BS.null obuf -> eof0+ | otherwise -> return (DecompressOutputAvailable obuf eof0)++ _ -> return (DecompressStreamError rc)++ eof0 = retStreamEnd BS.empty++ retStreamEnd chunk' = do+ !() <- stToIO (endLzmaStream ls)+ return (DecompressStreamEnd chunk')++-- | Incremental decompression in the lazy 'ST' monad.+decompressST :: DecompressParams -> ST s (DecompressStream (ST s))+decompressST parms = strictToLazyST (newDecodeLzmaStream parms) >>=+ either (return . DecompressStreamError) go+ where+ bUFSIZ = 32752++ go :: LzmaStream -> ST s (DecompressStream (ST s))+ go ls = return inputRequired+ where+ inputRequired = DecompressInputRequired goInput++ goInput :: ByteString -> ST s (DecompressStream (ST s))+ goInput chunk+ | BS.null chunk = goFinish+ | otherwise = do+ (rc, used, obuf) <- strictToLazyST (noDuplicateST >>+ runLzmaStream ls chunk LzmaRun bUFSIZ)++ let chunk' = BS.drop used chunk++ case rc of+ LzmaRetOK+ | BS.null obuf -> do+ unless (used > 0) $+ error "decompressST: input chunk not consumed"+ withChunk (return inputRequired) goInput chunk'+ | otherwise -> return (DecompressOutputAvailable obuf+ (withChunk goDrain goInput chunk'))++ LzmaRetStreamEnd+ | BS.null obuf -> retStreamEnd chunk'+ | otherwise -> return (DecompressOutputAvailable obuf+ (retStreamEnd chunk'))++ _ -> return (DecompressStreamError rc)+++ goDrain, goFinish :: ST s (DecompressStream (ST s))+ goDrain = goSync LzmaRun (return inputRequired)+ goFinish = goSync LzmaFinish (return $ DecompressStreamError LzmaRetOK)++ goSync :: LzmaAction -> ST s (DecompressStream (ST s)) -> ST s (DecompressStream (ST s))+ goSync action next = goSync'+ where+ goSync' = do+ (rc, n, obuf) <- strictToLazyST (noDuplicateST >>+ runLzmaStream ls BS.empty action bUFSIZ)+ when (n /= 0) $ error "decompressST: n was not zero"+ case rc of+ LzmaRetOK+ | BS.null obuf -> next+ | otherwise -> return (DecompressOutputAvailable obuf goSync')++ LzmaRetStreamEnd+ | BS.null obuf -> eof0+ | otherwise -> return (DecompressOutputAvailable obuf eof0)++ _ -> return (DecompressStreamError rc)++ eof0 = retStreamEnd BS.empty++ retStreamEnd chunk' = do+ !() <- strictToLazyST (noDuplicateST >> endLzmaStream ls)+ return (DecompressStreamEnd chunk')++-- | Small 'maybe'-ish helper distinguishing between empty and+-- non-empty 'ByteString's+withChunk :: t -> (ByteString -> t) -> ByteString -> t+withChunk emptyChunk nemptyChunk chunk+ | BS.null chunk = emptyChunk+ | otherwise = nemptyChunk chunk++-- | See <https://github.com/haskell/zlib/issues/7>+noDuplicateST :: ST.Strict.ST s ()+noDuplicateST = unsafeIOToST noDuplicate
+ src/LibLzma.hsc view
@@ -0,0 +1,251 @@+{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-}++-- Copyright (c) 2014, Herbert Valerio Riedel <hvr@gnu.org>+--+-- This code is BSD3 licensed, see ../LICENSE file for details+--++-- | Internal low-level bindings to liblzma+--+-- See @<lzma.h>@ header file for documentation about primitives not+-- documented here+module LibLzma+ ( LzmaStream+ , LzmaRet(..)+ , IntegrityCheck(..)+ , CompressionLevel(..)++ , newDecodeLzmaStream+ , DecompressParams(..)+ , defaultDecompressParams++ , newEncodeLzmaStream+ , CompressParams(..)+ , defaultCompressParams++ , runLzmaStream+ , endLzmaStream+ , LzmaAction(..)+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad+import Control.Monad.ST.Strict (ST)+import Control.Monad.ST.Unsafe (unsafeIOToST)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as BS+import qualified Data.ByteString.Unsafe as BS+import Data.Typeable+import Foreign+import Prelude++#include <lzma.h>++newtype LzmaStream = LS (ForeignPtr LzmaStream)++data LzmaRet = LzmaRetOK+ | LzmaRetStreamEnd+ | LzmaRetUnsupportedCheck+ | LzmaRetGetCheck+ | LzmaRetMemError+ | LzmaRetMemlimitError+ | LzmaRetFormatError+ | LzmaRetOptionsError+ | LzmaRetDataError+ | LzmaRetBufError+ | LzmaRetProgError+ deriving (Eq,Ord,Read,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,Read,Show,Typeable)++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++-- | 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+-- <https://www.freebsd.org/cgi/man.cgi?query=xz&sektion=1&manpath=FreeBSD+10.2-stable&arch=default&format=html man-page for xz(1)>+-- 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,Read,Show,Enum,Typeable)++-- | Set of parameters for decompression. The defaults are+-- 'defaultDecompressParams'.+data DecompressParams = DecompressParams+ { decompressTellNoCheck :: !Bool -- ^ 'DecompressParams' field: If set, abort if decoded stream has no integrity check.+ , decompressTellUnsupportedCheck :: !Bool -- ^ 'DecompressParams' field: If set, abort (via 'LzmaRetGetCheck') if decoded stream integrity check is unsupported.+ , decompressTellAnyCheck :: !Bool -- ^ 'DecompressParams' field: If set, abort (via 'LzmaRetGetCheck') as soon as the type of the integrity check has been detected.+ , decompressConcatenated :: !Bool -- ^ 'DecompressParams' field: If set, concatenated files as decoded seamless.+ , decompressAutoDecoder :: !Bool -- ^ 'DecompressParams' field: If set, legacy @.lzma@-encoded streams are allowed too.+ , decompressMemLimit :: !Word64 -- ^ 'DecompressParams' field: decompressor memory limit. 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 -- ^ 'CompressParams' field: Specify type of integrity check+ , compressLevel :: !CompressionLevel -- ^ 'CompressParams' field: See documentation of 'CompressionLevel'+ , compressLevelExtreme :: !Bool -- ^ 'CompressParams' field: 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 -> ST s (Either LzmaRet LzmaStream)+newDecodeLzmaStream (DecompressParams {..}) = unsafeIOToST $ 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 -> ST s (Either LzmaRet LzmaStream)+newEncodeLzmaStream (CompressParams {..}) = unsafeIOToST $ 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++data LzmaAction = LzmaRun+ | LzmaSyncFlush+ | LzmaFullFlush+ | LzmaFinish+ deriving (Eq,Show)++runLzmaStream :: LzmaStream -> ByteString -> LzmaAction -> Int -> ST s (LzmaRet,Int,ByteString)+runLzmaStream (LS ls) ibs action0 buflen+ | buflen <= 0 = return (LzmaRetOptionsError,0,BS.empty)+ | otherwise = unsafeIOToST $ withForeignPtr ls $ \lsptr ->+ 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+ -- print ("run", action0, BS.length ibs, buflen, rc, consumed, BS.length obuf)++ return (rc, fromIntegral consumed, obuf)+ where+ action = case action0 of+ LzmaRun -> #const LZMA_RUN+ LzmaSyncFlush -> #const LZMA_SYNC_FLUSH+ LzmaFullFlush -> #const LZMA_FULL_FLUSH+ LzmaFinish -> #const LZMA_FINISH+++-- | Force immediate finalization of 'ForeignPtr' associated with+-- 'LzmaStream'. This triggers a call to @lzma_end()@, therefore it's+-- a programming error to call 'runLzmaStream' afterwards.+endLzmaStream :: LzmaStream -> ST s ()+endLzmaStream (LS ls) = unsafeIOToST $ finalizeForeignPtr ls++----------------------------------------------------------------------------+-- 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 ())
+ xz.cabal view
@@ -0,0 +1,78 @@+cabal-version: 2.2+name: xz+version: 5.6.3++synopsis: LZMA/XZ compression and decompression+homepage: https://github.com/hasufell/lzma-static+bug-reports: https://github.com/hasufell/lzma-static/issues+license: BSD-3-Clause+license-file: LICENSE+author: Julian Ospald+maintainer: hasufell@posteo.de+copyright: (c) 2015, Herbert Valerio Riedel, (c) 2021 Julian Ospald+stability: experimental+category: Codec, Compression+build-type: Simple+tested-with: GHC==8.6.5, GHC==8.8.4, GHC==8.10.4+description:+ This package provides a pure interface for compressing and+ decompressing+ <https://en.wikipedia.org/wiki/LZMA LZMA (Lempel–Ziv–Markov chain algorithm)>+ streams of data represented as lazy @ByteString@s. A+ monadic incremental interface is provided as well. This package+ relies on the <http://tukaani.org/xz/ liblzma C library>.++extra-doc-files:+ Changelog.md++source-repository head+ type: git+ location: https://github.com/hasufell/lzma-static.git+ subdir: xz++flag system-xz+ description:+ Use xz found with pkg-config rather than the bundled sources++library+ default-language: Haskell2010+ other-extensions: BangPatterns, RecordWildCards, DeriveDataTypeable+ hs-source-dirs: src+ c-sources:+ cbits/lzma_wrapper.c++ exposed-modules: Codec.Compression.Lzma+ other-modules: LibLzma++ build-depends: base >=4.5 && <5+ , bytestring >=0.9.2 && <0.13++ if flag(system-xz)+ pkgconfig-depends: liblzma >=5.2.5+ else+ build-depends: xz-clib >=5.2.5++ cc-options: -std=gnu99 -DHAVE_CONFIG_H -DTUKLIB_SYMBOL_PREFIX=lzma_+ ghc-options: -Wall+++test-suite lzma-tests+ default-language: Haskell2010+ other-extensions: OverloadedStrings+ hs-source-dirs: src-tests+ type: exitcode-stdio-1.0+ main-is: lzma-tests.hs++ -- dependencies with version bounds inherited from the library stanza+ build-depends: xz+ , base+ , bytestring+ -- additional dependencies that require version bounds+ build-depends: HUnit >= 1.2 && <1.7+ , QuickCheck >= 2.8 && <2.15+ , tasty >= 0.10 && <1.4+ , tasty-hunit >= 0.9 && <0.11+ , tasty-quickcheck >= 0.8.3.2 && <0.11++ ghc-options: -Wall -threaded+