diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/lzma_wrapper.c b/cbits/lzma_wrapper.c new file mode 100644 --- /dev/null +++ b/cbits/lzma_wrapper.c @@ -0,0 +1,65 @@ +/* + * 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.cabal b/lzma.cabal new file mode 100644 --- /dev/null +++ b/lzma.cabal @@ -0,0 +1,68 @@ +name: lzma +version: 0.0.0.0 +synopsis: LZMA/XZ compression and decompression +homepage: https://github.com/hvr/lzma +bug-reports: https://github.com/hvr/lzma/issues +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +copyright: (c) 2015, Herbert Valerio Riedel +stability: experimental +category: Codec, Compression +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 a pure interface for compressing and + decompressing streams of data represented as lazy @ByteString@s. A + monadic incremental interface is provided as well. This package + relies on the @liblzma@ C library. + . + The following packages are based on this package and provide + API support for popular streaming frameworks: + . + * (for ) + . + +source-repository head + type: git + location: https://github.com/hvr/lzma.git + +library + default-language: Haskell2010 + other-extensions: RecordWildCards, DeriveDataTypeable + hs-source-dirs: src + + exposed-modules: Codec.Compression.Lzma + other-modules: LibLzma + + build-depends: base >=4.5 && <4.9 + , bytestring >=0.9.2 && <0.11 + + includes: lzma.h + extra-libraries: lzma + c-sources: cbits/lzma_wrapper.c + + 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: lzma + , base + , bytestring + -- additional dependencies that require version bounds + build-depends: HUnit >= 1.2 && <1.3 + , QuickCheck >= 2.8 && <2.9 + , tasty == 0.10.* + , tasty-hunit == 0.9.* + , tasty-quickcheck >= 0.8.3.2 && < 0.9 + + ghc-options: -Wall -threaded diff --git a/src-tests/lzma-tests.hs b/src-tests/lzma-tests.hs new file mode 100644 --- /dev/null +++ b/src-tests/lzma-tests.hs @@ -0,0 +1,98 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Main (main) where + +import Control.Applicative +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +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 "hello" @?= "hello" + , testCase "encode-hello2" $ codecompress (singletonChunked "hello") @?= "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 compress "" !! 50) !! 50) @?= "" + , 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 + ] + +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 " " $ replicate 11 "This sentence occurs multiple times.") diff --git a/src/Codec/Compression/Lzma.hs b/src/Codec/Compression/Lzma.hs new file mode 100644 --- /dev/null +++ b/src/Codec/Compression/Lzma.hs @@ -0,0 +1,372 @@ +-- | +-- 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: +module Codec.Compression.Lzma + ( -- * Simple (de)compression + compress + , decompress + + -- * Extended API with control over parameters + , compressWith + , decompressWith + + -- * Monadic incremental (de)compression API + -- + -- | See 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 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 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 = fail "Codec.Compression.Lzma.decompressWith: trailing data" + loop (BSL.Chunk _ _) (DecompressStreamEnd _) = + fail "Codec.Compression.Lzma.decompressWith: trailing data" + loop _ (DecompressStreamError e) = + fail ("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 = + fail "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 (return CompressStreamEnd) + + -- 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 + +-- | 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 $ runLzmaStream ls chunk LzmaRun bUFSIZ + + let chunk' = BS.drop used chunk + + case rc of + LzmaRetOK + | BS.null obuf -> do + unless (used > 0) $ + fail "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 (return CompressStreamEnd) + + -- drain encoder till LzmaRetStreamEnd is reported + goSync :: LzmaAction -> ST s (CompressStream (ST s)) -> ST s (CompressStream (ST s)) + goSync LzmaRun _ = fail "compressST: goSync called with invalid argument" + goSync action next = goSync' + where + goSync' = do + (rc, 0, obuf) <- strictToLazyST $ 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) + _ -> throw rc + +-------------------------------------------------------------------------------- + +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 -> return (DecompressStreamEnd chunk') + | otherwise -> return (DecompressOutputAvailable obuf + (return (DecompressStreamEnd 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 = return $ DecompressStreamEnd BS.empty + + +-- | 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 $ runLzmaStream ls chunk LzmaRun bUFSIZ + + let chunk' = BS.drop used chunk + + case rc of + LzmaRetOK + | BS.null obuf -> do + unless (used > 0) $ + fail "decompressST: input chunk not consumed" + withChunk (return inputRequired) goInput chunk' + | otherwise -> return (DecompressOutputAvailable obuf + (withChunk goDrain goInput chunk')) + + LzmaRetStreamEnd + | BS.null obuf -> return (DecompressStreamEnd chunk') + | otherwise -> return (DecompressOutputAvailable obuf + (return (DecompressStreamEnd 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, 0, obuf) <- strictToLazyST $ 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 = return $ DecompressStreamEnd BS.empty + + +-- | 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 diff --git a/src/LibLzma.hsc b/src/LibLzma.hsc new file mode 100644 --- /dev/null +++ b/src/LibLzma.hsc @@ -0,0 +1,243 @@ +{-# LANGUAGE RecordWildCards, DeriveDataTypeable #-} + +-- Copyright (c) 2014, Herbert Valerio Riedel +-- +-- This code is BSD3 licensed, see ../LICENSE file for details +-- + +-- | Internal low-level bindings to liblzma +-- +-- See @@ header file for documentation about primitives not +-- documented here +module LibLzma + ( LzmaStream + , LzmaRet(..) + , IntegrityCheck(..) + , CompressionLevel(..) + + , newDecodeLzmaStream + , DecompressParams(..) + , defaultDecompressParams + + , newEncodeLzmaStream + , CompressParams(..) + , defaultCompressParams + + , runLzmaStream + , 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 + +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 +-- +-- 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 + +---------------------------------------------------------------------------- +-- 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 ())