diff --git a/lzma-conduit.cabal b/lzma-conduit.cabal --- a/lzma-conduit.cabal +++ b/lzma-conduit.cabal @@ -1,5 +1,5 @@ name: lzma-conduit -version: 1.1.3.3 +version: 1.2.0 synopsis: Conduit interface for lzma/xz compression. description: High level bindings to xz-utils. @@ -25,21 +25,16 @@ hs-source-dirs: src exposed-modules: - Bindings.Lzma Data.Conduit.Lzma build-depends: base >= 3 && < 5, - bindings-DSL >= 1.0 && < 1.1, bytestring >= 0.9.1 && < 0.11, - conduit >= 0.4 && < 1.3, - resourcet >= 0.3 && < 1.2, + conduit >= 1.0 && < 1.3, + lzma >= 0.0.0.3 && < 0.1, + resourcet >= 0.4 && < 1.2, transformers >= 0.2 && < 0.6 ghc-options: -Wall - includes: - lzma.h - extra-libraries: - lzma test-suite lzma-test default-language: diff --git a/src/Bindings/Lzma.hsc b/src/Bindings/Lzma.hsc deleted file mode 100644 --- a/src/Bindings/Lzma.hsc +++ /dev/null @@ -1,97 +0,0 @@ -#include -#include -#include -#include - -module Bindings.Lzma where -#strict_import - --- lzma_ret -#integral_t lzma_ret -#num LZMA_OK -#num LZMA_STREAM_END -#num LZMA_NO_CHECK -#num LZMA_UNSUPPORTED_CHECK -#num LZMA_GET_CHECK -#num LZMA_MEM_ERROR -#num LZMA_MEMLIMIT_ERROR -#num LZMA_FORMAT_ERROR -#num LZMA_OPTIONS_ERROR -#num LZMA_DATA_ERROR -#num LZMA_BUF_ERROR -#num LZMA_PROG_ERROR - --- lzma_action -#integral_t lzma_action -#num LZMA_RUN -#num LZMA_SYNC_FLUSH -#num LZMA_FULL_FLUSH -#num LZMA_FINISH - --- lzma_flags -#num LZMA_TELL_NO_CHECK -#num LZMA_TELL_UNSUPPORTED_CHECK -#num LZMA_TELL_ANY_CHECK -#num LZMA_CONCATENATED - --- lzma_check -#integral_t lzma_check -#num LZMA_CHECK_NONE -#num LZMA_CHECK_CRC32 -#num LZMA_CHECK_CRC64 -#num LZMA_CHECK_SHA256 - -#num LZMA_PRESET_DEFAULT -#num LZMA_PRESET_LEVEL_MASK -#num LZMA_PRESET_EXTREME - --- lzma_stream -#starttype lzma_stream -#field next_in , Ptr CUChar -#field avail_in , CSize -#field total_in , CULong -#field next_out , Ptr CUChar -#field avail_out , CSize -#field total_out , CULong -#stoptype - --- figure out what to put here? --- #cinline LZMA_STREAM_INIT , IO - --- base.h -#ccall lzma_code , Ptr -> -> IO -#ccall lzma_end , Ptr -> IO () -#ccall lzma_memusage , Ptr -> IO CULong -#ccall lzma_memlimit_get , Ptr -> IO CULong -#ccall lzma_memlimit_set , Ptr -> CULong -> IO - --- container.h -#ccall lzma_easy_encoder_memusage , CInt -> IO CULong -#ccall lzma_easy_decoder_memusage , CInt -> IO CULong -#ccall lzma_easy_encoder , Ptr -> CInt -> -> IO -#ccall lzma_auto_decoder , Ptr -> CULong -> CUInt -> IO - -pokeNextIn :: Ptr C'lzma_stream -> Ptr a -> IO () -pokeNextIn = #poke lzma_stream, next_in - -pokeAvailIn :: Ptr C'lzma_stream -> CSize -> IO () -pokeAvailIn = #poke lzma_stream, avail_in - -pokeNextOut :: Ptr C'lzma_stream -> Ptr a -> IO () -pokeNextOut = #poke lzma_stream, next_out - -pokeAvailOut :: Ptr C'lzma_stream -> CSize -> IO () -pokeAvailOut = #poke lzma_stream, avail_out - -peekNextIn :: Ptr C'lzma_stream -> IO (Ptr a) -peekNextIn = #peek lzma_stream, next_in - -peekAvailIn :: Ptr C'lzma_stream -> IO CSize -peekAvailIn = #peek lzma_stream, avail_in - -peekNextOut :: Ptr C'lzma_stream -> IO (Ptr a) -peekNextOut = #peek lzma_stream, next_out - -peekAvailOut :: Ptr C'lzma_stream -> IO CSize -peekAvailOut = #peek lzma_stream, avail_out - diff --git a/src/Data/Conduit/Lzma.hs b/src/Data/Conduit/Lzma.hs --- a/src/Data/Conduit/Lzma.hs +++ b/src/Data/Conduit/Lzma.hs @@ -1,221 +1,103 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE ScopedTypeVariables #-} - module Data.Conduit.Lzma (compress, decompress) where -import Control.Monad (forM_) -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Resource -import Data.ByteString (ByteString) -import Data.ByteString.Internal (ByteString(PS)) -import Data.Conduit -import Data.Maybe (fromMaybe) -import Foreign -import Foreign.C.Types (CSize, CUChar) - -import qualified Data.ByteString as B -import qualified Data.ByteString.Unsafe as B - -import Bindings.Lzma +import qualified Codec.Compression.Lzma as Lzma +import Control.Applicative as App +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 - :: C'lzma_ret + :: Lzma.LzmaRet -> String -prettyRet r - | r == c'LZMA_OK = "Operation completed successfully" - | r == c'LZMA_STREAM_END = "End of stream was reached" - | r == c'LZMA_NO_CHECK = "Input stream has no integrity check" - | r == c'LZMA_UNSUPPORTED_CHECK = "Cannot calculate the integrity check" - | r == c'LZMA_GET_CHECK = "Integrity check type is now available" - | r == c'LZMA_MEM_ERROR = "Cannot allocate memory" - | r == c'LZMA_MEMLIMIT_ERROR = "Memory usage limit was reached" - | r == c'LZMA_FORMAT_ERROR = "File format not recognized" - | r == c'LZMA_OPTIONS_ERROR = "Invalid or unsupported options" - | r == c'LZMA_DATA_ERROR = "Data is corrupt" - | r == c'LZMA_BUF_ERROR = "No progress is possible" - | r == c'LZMA_PROG_ERROR = "Programming error" - | otherwise = "Unknown LZMA error: "++show r +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" -bufferSize - :: Num a => a -bufferSize = 4096 -memset - :: forall a . Storable a - => Ptr a - -> Word8 - -> IO () -memset ptr val = - forM_ [0..sizeOf (undefined :: a) - 1] $ \ i -> - pokeByteOff ptr i val - -initStream - :: String - -> (Ptr C'lzma_stream -> IO C'lzma_ret) - -> IO (Ptr C'lzma_stream, Ptr CUChar) -initStream name fun = do - buffer <- mallocBytes bufferSize - streamPtr <- malloc - memset streamPtr 0 - poke streamPtr C'lzma_stream - { c'lzma_stream'next_in = nullPtr - , c'lzma_stream'avail_in = 0 - , c'lzma_stream'total_in = 0 - , c'lzma_stream'next_out = buffer - , c'lzma_stream'avail_out = bufferSize - , c'lzma_stream'total_out = 0 } - ret <- fun streamPtr - if ret == c'LZMA_OK - then return (streamPtr, buffer) - else monadThrow $ userError $ name ++ " failed: " ++ prettyRet ret - -easyEncoder - :: Maybe Int - -> Ptr C'lzma_stream - -> IO C'lzma_ret -easyEncoder level ptr = - let level' = maybe c'LZMA_PRESET_DEFAULT fromIntegral level - in c'lzma_easy_encoder ptr level' c'LZMA_CHECK_CRC64 - -autoDecoder - :: Maybe Word64 - -> Ptr C'lzma_stream - -> IO C'lzma_ret -autoDecoder memlimit ptr = - c'lzma_auto_decoder ptr (maybe maxBound fromIntegral memlimit) c'LZMA_CONCATENATED - -- | Decompress a 'ByteString' from a lzma or xz container stream. decompress - :: (MonadResource m) + :: (MonadThrow m, MonadIO m) => Maybe Word64 -- ^ Memory limit, in bytes. -> Conduit ByteString m ByteString -decompress memlimit = do - mval <- await - case mval of - Just input -> do - (streamKey, (streamPtr, _)) <- lift $ allocate - (initStream "lzma_auto_decoder" (autoDecoder memlimit)) - (\ (streamPtr, buffer) -> c'lzma_end streamPtr >> free streamPtr >> free buffer) - codeEnum streamKey streamPtr input +decompress memlimit = + decompressWith Lzma.defaultDecompressParams + { Lzma.decompressMemLimit = fromMaybe maxBound memlimit + , Lzma.decompressAutoDecoder = True + , Lzma.decompressConcatenated = True + } - Nothing -> monadThrow $ userError $ "decompress: invalid empty input" +decompressWith + :: (MonadThrow m, MonadIO m) + => Lzma.DecompressParams + -> Conduit ByteString m ByteString +decompressWith parms = do + c <- peek + case c of + Nothing -> monadThrow $ 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) = do + if B.null rest + then App.pure () + else leftover rest + go (Lzma.DecompressStreamError err) = + monadThrow $ userError $ "Data.Conduit.Lzma.decompress: error: "++prettyRet err + -- | Compress a 'ByteString' into a xz container stream. compress - :: (MonadResource m) + :: (MonadIO m) => Maybe Int -- ^ Compression level from [0..9], defaults to 6. -> Conduit ByteString m ByteString -compress level = do - mval <- await - process $ fromMaybe B.empty mval - where process input = do - (streamKey, (streamPtr, _)) <- lift $ allocate - (initStream "lzma_easy_encoder" (easyEncoder level)) - (\ (streamPtr, buffer) -> c'lzma_end streamPtr >> free streamPtr >> free buffer) - codeEnum streamKey streamPtr input - -lzmaConduit - :: (MonadResource m) - => ReleaseKey - -> Ptr C'lzma_stream - -> Conduit ByteString m ByteString -lzmaConduit streamKey streamPtr = do - mval <- await - case mval of - Just val -> codeEnum streamKey streamPtr val - Nothing -> lzmaClose streamKey streamPtr +compress level = + -- mval <- await + -- undefined $ fromMaybe B.empty mval + compressWith Lzma.defaultCompressParams { Lzma.compressLevel = level' } + where + level' = case level of + Nothing -> Lzma.CompressionLevel6 + Just n -> toEnum (max 0 (min 9 n)) -- clamp to [0..9] range -lzmaClose - :: (MonadResource m) - => ReleaseKey - -> Ptr C'lzma_stream +compressWith + :: MonadIO m + => Lzma.CompressParams -> Conduit ByteString m ByteString -lzmaClose streamKey streamPtr = do - inputKey <- lift . register $ return () - buildChunks streamKey inputKey streamPtr c'LZMA_FINISH c'LZMA_OK - -codeEnum - :: (MonadResource m) - => ReleaseKey - -> Ptr C'lzma_stream - -> ByteString - -> Conduit B.ByteString m B.ByteString -codeEnum streamKey streamPtr chunk@(PS fptr _ _) = do - liftIO $ do - -- let the bytestring library calculate the chunk length - (ptr, len) <- B.unsafeUseAsCStringLen chunk return - pokeNextIn streamPtr ptr - pokeAvailIn streamPtr $ fromIntegral len - - inputKey <- lift . register $ touchForeignPtr fptr - - buildChunks streamKey inputKey streamPtr c'LZMA_RUN c'LZMA_OK - -buildChunks - :: (MonadResource m) - => ReleaseKey - -> ReleaseKey - -> Ptr C'lzma_stream - -> C'lzma_action - -> C'lzma_ret - -> Conduit B.ByteString m B.ByteString -buildChunks streamKey inputKey streamPtr action status = do - availIn <- liftIO $ peekAvailIn streamPtr - availOut <- liftIO $ peekAvailOut streamPtr - codeStep streamKey inputKey streamPtr action status availIn availOut - -codeStep - :: (MonadResource m) - => ReleaseKey - -> ReleaseKey - -> Ptr C'lzma_stream - -> C'lzma_action - -> C'lzma_ret - -> CSize - -> CSize - -> Conduit B.ByteString m B.ByteString -codeStep streamKey inputKey streamPtr action status availIn availOut - -- the inner enumerator has finished and we're done flushing the coder - | availOut == bufferSize && status == c'LZMA_STREAM_END = do - lift $ do - release inputKey - release streamKey - return () - - -- the normal case, we have some results.. - | availOut < bufferSize = do - x <- liftIO $ getChunk streamPtr availOut - yield x - buildChunks streamKey inputKey streamPtr action status - - -- the input buffer points into a pinned bytestring, so we need to make sure it's been - -- fully loaded (availIn == 0) before returning - | availIn > 0 || action == c'LZMA_FINISH = do - ret <- liftIO $ c'lzma_code streamPtr action - if ret == c'LZMA_OK || ret == c'LZMA_STREAM_END - then buildChunks streamKey inputKey streamPtr action ret - else monadThrow $ userError $ "lzma_code failed: " ++ prettyRet ret - - -- nothing to do here - | otherwise = do - lift $ release inputKey - lzmaConduit streamKey streamPtr - -getChunk - :: Ptr C'lzma_stream - -> CSize - -> IO B.ByteString -getChunk streamPtr availOut - | availOut < bufferSize = do - nextOut <- peekNextOut streamPtr - let avail = bufferSize - fromIntegral availOut - baseBuffer = nextOut `plusPtr` (-avail) - bs <- B.packCStringLen (baseBuffer, avail) - pokeAvailOut streamPtr bufferSize - -- B.pack* copies the buffer, so reuse it - pokeNextOut streamPtr baseBuffer - return bs - - | otherwise = - return B.empty +compressWith parms = do + s <- liftIO (Lzma.compressIO parms) + go s + 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 = pure ()