lzma-conduit 1.1.3.3 → 1.2.0
raw patch · 3 files changed
+88/−308 lines, 3 filesdep +lzmadep −bindings-DSLdep ~conduitdep ~resourcet
Dependencies added: lzma
Dependencies removed: bindings-DSL
Dependency ranges changed: conduit, resourcet
Files
- lzma-conduit.cabal +4/−9
- src/Bindings/Lzma.hsc +0/−97
- src/Data/Conduit/Lzma.hs +84/−202
lzma-conduit.cabal view
@@ -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:
− src/Bindings/Lzma.hsc
@@ -1,97 +0,0 @@-#include <stdio.h>-#include <string.h>-#include <bindings.dsl.h>-#include <lzma.h>--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 <lzma_stream>---- base.h-#ccall lzma_code , Ptr <lzma_stream> -> <lzma_action> -> IO <lzma_ret>-#ccall lzma_end , Ptr <lzma_stream> -> IO ()-#ccall lzma_memusage , Ptr <lzma_stream> -> IO CULong-#ccall lzma_memlimit_get , Ptr <lzma_stream> -> IO CULong-#ccall lzma_memlimit_set , Ptr <lzma_stream> -> CULong -> IO <lzma_ret>---- container.h-#ccall lzma_easy_encoder_memusage , CInt -> IO CULong-#ccall lzma_easy_decoder_memusage , CInt -> IO CULong-#ccall lzma_easy_encoder , Ptr <lzma_stream> -> CInt -> <lzma_check> -> IO <lzma_ret>-#ccall lzma_auto_decoder , Ptr <lzma_stream> -> CULong -> CUInt -> IO <lzma_ret>--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-
src/Data/Conduit/Lzma.hs view
@@ -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 ()