lzma-conduit (empty) → 0.1.2

raw patch · 6 files changed

+440/−0 lines, 6 filesdep +basedep +bindings-DSLdep +bytestringsetup-changed

Dependencies added: base, bindings-DSL, bytestring, conduit, transformers

Files

LICENSE +26/−0
Setup.hs +2/−0
lzma-conduit.cabal +45/−0
src/Bindings/Lzma.hsc +97/−0
src/Data/Conduit/Lzma.hs +183/−0
tests/Main.hs +87/−0

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2012, Alpha Heavy Industries
+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 names of the copyright owners nor the names of the
+  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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ lzma-conduit.cabal view

@@ -0,0 +1,45 @@+name:                lzma-conduit+version:             0.1.2+synopsis:            Conduit interface for lzma/xz compression.+description:+  High level bindings to xz-utils.+  .+license:             BSD3+license-file:        LICENSE+author:              Nathan Howell <nhowell@alphaheavy.com>+maintainer:          Nathan Howell <nhowell@alphaheavy.com>+homepage:            http://github.com/alphaHeavy/lzma-conduit+bug-reports:         http://github.com/alphaHeavy/lzma-conduit/issues+category:            Codec, Compression, Enumerator++build-type:          Simple+cabal-version:       >= 1.10++extra-source-files:+  tests/Main.hs++library+  default-language:+    Haskell2010+  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.10,+    conduit      >= 0.2.2  && < 0.3,+    transformers == 0.2.*+  ghc-options:+    -Wall+  includes:+    lzma.h+  extra-libraries:+    lzma++source-repository head+  type:     git+  location: https://github.com/alphaHeavy/lzma-conduit.git+

+ src/Bindings/Lzma.hsc view

@@ -0,0 +1,97 @@+{-|+For a high-level description of the C API, refer to the README file+included in the liblinear archive, available for download at+<http://www.csie.ntu.edu.tw/~cjlin/liblinear/>.+-}++#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_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

@@ -0,0 +1,183 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Data.Conduit.Lzma (compress, decompress) where++import Control.Monad (forM_, liftM2)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Trans.Resource+import Data.ByteString (ByteString)+import Data.Conduit+import Foreign+import Foreign.C.Types (CSize)+import System.IO.Unsafe (unsafeInterleaveIO)++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B++import Bindings.Lzma++prettyRet :: C'lzma_ret -> 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++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)+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+    else fail $ name ++ " failed: " ++ prettyRet ret++easyEncoder :: Maybe Int -> Ptr C'lzma_stream -> IO C'lzma_ret+easyEncoder level ptr = c'lzma_easy_encoder ptr (maybe c'LZMA_PRESET_DEFAULT fromIntegral 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) 0++-- | Decompress a 'ByteString' from a lzma or xz container stream.+decompress+  :: ResourceIO m+  => Maybe Word64 -- ^ Memory limit, in bytes.+  -> Conduit ByteString m ByteString+decompress memlimit = Conduit{conduitPush = initPush, conduitClose = return []} where+  initPush input = do+    (_, streamPtr) <- withIO+      (initStream "lzma_auto_decoder" (autoDecoder memlimit))+      (\ ptr -> c'lzma_end ptr >> free ptr)+    lzmaPush streamPtr input++-- | Compress a 'ByteString' into a xz container stream.+compress+  :: ResourceIO m+  => Maybe Int -- ^ Compression level from [0..9], defaults to 6.+  -> Conduit ByteString m ByteString+compress level = Conduit{conduitPush = initPush, conduitClose = return []} where+  initPush input = do+    (_, streamPtr) <- withIO+      (initStream "lzma_easy_encoder" (easyEncoder level))+      (\ ptr -> c'lzma_end ptr >> free ptr)+    lzmaPush streamPtr input++lzmaConduit+  :: ResourceIO m+  => Ptr C'lzma_stream+  -> Conduit ByteString m ByteString+lzmaConduit = liftM2 Conduit lzmaPush lzmaClose++lzmaPush+  :: ResourceIO m+  => Ptr C'lzma_stream+  -> ByteString+  -> ResourceT m (ConduitResult ByteString m ByteString)+lzmaPush streamPtr xs = do+  chunks <- liftIO $ codeEnum streamPtr xs+  return $ Producing (lzmaConduit streamPtr) chunks++lzmaClose+  :: Control.Monad.IO.Class.MonadIO m+  => Ptr C'lzma_stream+  -> m [ByteString]+lzmaClose streamPtr = liftIO $+  buildChunks streamPtr c'LZMA_FINISH c'LZMA_OK++codeEnum+  :: Ptr C'lzma_stream+  -> ByteString+  -> IO [ByteString]+codeEnum streamPtr chunk =+  B.unsafeUseAsCStringLen chunk $ \ (ptr, len) -> do+    pokeNextIn streamPtr ptr+    pokeAvailIn streamPtr $ fromIntegral len+    buildChunks streamPtr c'LZMA_RUN c'LZMA_OK++buildChunks+  :: Ptr C'lzma_stream+  -> C'lzma_action+  -> C'lzma_ret+  -> IO [B.ByteString]+buildChunks streamPtr action status = do+  availIn <- peekAvailIn streamPtr+  availOut <- peekAvailOut streamPtr+  codeStep streamPtr action status availIn availOut++codeStep+  :: Ptr C'lzma_stream+  -> C'lzma_action+  -> C'lzma_ret+  -> CSize+  -> CSize+  -> IO [B.ByteString]+codeStep streamPtr action status availIn availOut+  -- the inner enumerator has finished and we're done flushing the coder+  | availOut == bufferSize && status == c'LZMA_STREAM_END =+      return []++  -- the normal case, we have some results..+  | availOut < bufferSize = do+      x <- getChunk streamPtr availOut+      if availIn == 0 -- no more input, stop processing+        then return [x]+        else do+          -- run lzma_code forward just far enough to read all the input buffer+          xs <- unsafeInterleaveIO $ buildChunks streamPtr action status+          return $! x:xs++  -- 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 <- c'lzma_code streamPtr action+      if ret == c'LZMA_OK || ret == c'LZMA_STREAM_END+        then buildChunks streamPtr action ret+        else fail $ "lzma_code failed: " ++ prettyRet ret++  -- nothing to do here+  | otherwise = return []++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+

+ tests/Main.hs view

@@ -0,0 +1,87 @@+import Test.Framework (defaultMain, testGroup)+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2 (testProperty)+import Test.QuickCheck+import Test.QuickCheck.Monadic++import qualified Data.ByteString as B+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Data.List+import Data.Word+import Codec.Compression.Lzma.Enumerator++main = defaultMain tests++tests =+  [ testGroup "Compress" compressTests+  , testGroup "Decompress" decompressTests+  , testGroup "Chained" chainedTests+  ]++compressTests =+  [ testProperty "compressAndDiscard" prop_compressAndDiscard+  , testProperty "compressAndCheckLength" prop_compressAndCheckLength+  ]++decompressTests =+  [ testProperty "decompressRandom" prop_decompressRandom+  , testProperty "decompressCorrupt" prop_decompressCorrupt+  ]++chainedTests =+  [ testProperty "chain" prop_chain+  , testProperty "compressThenDecompress" prop_compressThenDecompress+  ]++someString :: Gen B.ByteString+someString = do+  val <- listOf $ elements [0..255::Word8] +  return $ B.pack val++someBigString :: Gen B.ByteString+someBigString = resize (8*1024) someString++dropAll :: Monad m => E.Iteratee a m ()+dropAll = EL.dropWhile (const True)++prop_compressAndDiscard :: Property+prop_compressAndDiscard = monadicIO $ forAllM someBigString $ \ str -> do+  run $ E.run_ $ E.enumList 2 [str] E.$$ E.joinI (compress Nothing E.$$ dropAll)++prop_compressAndCheckLength :: Property+prop_compressAndCheckLength = monadicIO $ forAllM someBigString $ \ str -> do+  len <- run $ E.run_ $ E.enumList 2 [str] E.$$ E.joinI (compress Nothing E.$$ EL.fold (\ acc el -> acc + B.length el) 0)+  assert (len - 32 > B.length str `div` 2) -- random strings don't compress very well++prop_chain :: Property+prop_chain = monadicIO $ forAllM someBigString $ \ str -> do+  str' <- run $ E.run_ $ E.enumList 2 [str] E.$$ E.joinI (compress Nothing E.$$ E.joinI (decompress Nothing E.$$ EL.consume))+  return $ str == B.concat str'++prop_compressThenDecompress :: Property+prop_compressThenDecompress = monadicIO $ forAllM someBigString $ \ str -> do+  blob <- run $ E.run_ $ E.enumList 2 [str] E.$$ E.joinI (compress Nothing E.$$ EL.consume)+  let blob' = B.concat blob+  randIdx <- pick $ elements [0..B.length blob'-1]+  let resplit = let (x,y) = B.splitAt randIdx blob' in [x,y]+  str' <- run $ E.run_ $ E.enumList 2 resplit E.$$ E.joinI (decompress Nothing E.$$ EL.consume)+  return $ str == B.concat str'++prop_decompressRandom :: Property+prop_decompressRandom = monadicIO $ forAllM someBigString $ \ str -> do+  header <- run $ E.run_ $ E.enumList 2 [] E.$$ E.joinI (compress Nothing E.$$ EL.consume)+  let blob = header ++ [str]+  run $ E.run_ $ E.enumList 2 blob E.$$ E.joinI (decompress Nothing E.$$ dropAll)++prop_decompressCorrupt :: Property+prop_decompressCorrupt = expectFailure $ monadicIO $ forAllM someBigString $ \ str -> do+  header <- run $ E.run_ $ E.enumList 2 [] E.$$ E.joinI (compress Nothing E.$$ EL.consume)+  let header' = B.concat header+  randVal <- pick $ elements [0..255::Word8]+  randIdx <- pick $ elements [0..B.length header'-1]+  let (left, right) = B.splitAt randIdx header'+      updated = left `B.append` (randVal `B.cons` B.tail right)+      blob = [updated, str]+  run $ E.run_ $ E.enumList 2 blob E.$$ E.joinI (decompress Nothing E.$$ dropAll)+