lzma-enumerator (empty) → 0.1.1

raw patch · 6 files changed

+461/−0 lines, 6 filesdep +HUnitdep +QuickCheckdep +basesetup-changed

Dependencies added: HUnit, QuickCheck, base, bindings-DSL, bytestring, enumerator, lzma-enumerator, mtl, test-framework, test-framework-hunit, test-framework-quickcheck2

Files

LICENSE +26/−0
Setup.hs +2/−0
lzma-enumerator.cabal +67/−0
src/Bindings/Lzma.hsc +95/−0
src/Codec/Compression/Lzma/Enumerator.hs +184/−0
tests/Main.hs +87/−0

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright (c) 2011, 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-enumerator.cabal view

@@ -0,0 +1,67 @@+name:                lzma-enumerator+version:             0.1.1+synopsis:            Enumerator 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-enumerator+bug-reports:         http://github.com/alphaHeavy/lzma-enumerator/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+    Codec.Compression.Lzma.Enumerator+  build-depends:+    base         >= 3      && < 5,+    bindings-DSL >= 1.0    && < 1.1,+    bytestring   >= 0.9.1  && < 0.10,+    enumerator   >= 0.4.10 && < 0.5,+    mtl          >= 2      && < 3+  ghc-options:+    -Wall+  includes:+    lzma.h+  extra-libraries:+    lzma++test-suite lzma-test+  default-language:+    Haskell2010+  hs-source-dirs:+    tests+  type:+    exitcode-stdio-1.0+  main-is:+    Main.hs+  ghc-options:+    -threaded+  build-depends:+    lzma-enumerator,+    base                       >= 3      && < 5,+    bytestring                 >= 0.9.1  && < 0.10,+    enumerator                 >= 0.4.10 && < 0.5,+    test-framework             >= 0.4,+    test-framework-hunit       >= 0.2.6,+    test-framework-quickcheck2 >= 0.2.10,+    HUnit                      >= 1.2.2.3,+    QuickCheck                 >= 2.4.0.1++source-repository head+  type:     git+  location: https://github.com/alphaHeavy/lzma-enumerator.git+

+ src/Bindings/Lzma.hsc view

@@ -0,0 +1,95 @@+{-|+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 <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/Codec/Compression/Lzma/Enumerator.hs view

@@ -0,0 +1,184 @@+module Codec.Compression.Lzma.Enumerator+  ( compress+  , decompress+  ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import Control.Monad (forM_, liftM)+import Control.Monad.Trans+import qualified Data.Enumerator as E+import qualified Data.Enumerator.List as EL+import Foreign+import Foreign.C.Types (CSize)+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 :: Storable a => Ptr a -> Word8 -> IO ()+memset ptr val = memset' ptr undefined where+  memset' :: Storable a => Ptr a -> a -> IO ()+  memset' _ a = +    forM_ [0..sizeOf 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++-- | Compress a 'B.ByteString' 'E.Enumerator' into an xz container stream.+compress :: MonadIO m+         => Maybe Int -- ^ Compression level from [0..9], defaults to 6.+         -> E.Enumeratee B.ByteString B.ByteString m b+compress level step = do+  streamPtr <- E.tryIO $ initStream "lzma_easy_encoder" (easyEncoder level)+  codeEnum streamPtr step++-- | Decompress a 'B.ByteString' 'E.Enumerator' from an lzma or xz container stream.+decompress :: MonadIO m+           => Maybe Word64 -- ^ Memory limit, in bytes.+           -> E.Enumeratee B.ByteString B.ByteString m b+decompress memlimit step = do+  streamPtr <- E.tryIO $ initStream "lzma_auto_decoder" (autoDecoder memlimit)+  codeEnum streamPtr step++codeEnum :: MonadIO m+         => Ptr C'lzma_stream+         -> E.Enumeratee B.ByteString B.ByteString m b+codeEnum streamPtr (E.Continue k) = do+  availOut <- E.tryIO $ peekAvailOut streamPtr+  chunks <- if availOut < bufferSize+    -- always try to drain the output buffer before reading any data+    then E.tryIO $ buildChunk streamPtr availOut+    else do+      chunk <- EL.head+      E.tryIO $ case chunk of+        -- pin the bytestring and make sure it's been fully+        -- loaded into the native lzma_stream+        Just chunk' -> do+          chunks <- B.unsafeUseAsCStringLen chunk' $ \ (ptr, len) -> do+            pokeNextIn streamPtr ptr+            pokeAvailIn streamPtr $ fromIntegral len+            buildChunks streamPtr c'LZMA_RUN c'LZMA_OK+          -- sanity check, make sure it's actually been read+          availIn <- peekAvailIn streamPtr+          if availIn /= 0+            then fail $ "c'lzma_stream'avail_in == " ++ show availIn ++ ", should be 0" +            else return chunks+        -- once we're at the end of the enumerator flush the lzma_stream+        Nothing -> do+            pokeNextIn streamPtr nullPtr+            pokeAvailIn streamPtr 0+            buildChunks streamPtr c'LZMA_FINISH c'LZMA_OK+  step <- lift $ E.runIteratee (k chunks)+  codeEnum streamPtr step++codeEnum streamPtr step = do+  E.tryIO $ do+    free =<< peekNextOut streamPtr+    pokeNextOut streamPtr nullPtr+    c'lzma_end streamPtr+  return step++buildChunks :: Ptr C'lzma_stream+            -> C'lzma_action+            -> C'lzma_ret+            -> IO (E.Stream 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 (E.Stream 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 E.EOF++  -- the normal case, we have some results..+  | availOut < bufferSize = do+      x <- getChunk streamPtr availOut+      if availIn == 0 -- no more input, stop processing+        then return $ E.Chunks [x]+        else do+          -- run lzma_code forward just far enough to read all the input buffer+          xs <- buildChunks streamPtr action status+          case xs of+            E.Chunks xs' -> return $ E.Chunks (x:xs')+            E.EOF        -> return $ E.Chunks [x]++  -- 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 $ E.Chunks []++buildChunk :: Ptr C'lzma_stream+           -> CSize+           -> IO (E.Stream B.ByteString)+buildChunk streamPtr availOut =+  liftM E.Chunks $ if availOut < bufferSize+    then fmap (:[]) $ getChunk streamPtr availOut+    else 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)+