diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,27 @@ +Copyright (c) 2012, Alpha Heavy Industries + 2019, 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 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. 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/brotli-conduit.cabal b/brotli-conduit.cabal new file mode 100644 --- /dev/null +++ b/brotli-conduit.cabal @@ -0,0 +1,59 @@ +cabal-version: 1.12 +build-type: Simple +name: brotli-conduit +version: 0.0.0.0 + +synopsis: Conduit interface for Brotli (RFC7932) compression. +description: + () is a generic-purpose lossless compression algorithm suitable for that compresses data using a combination of a modern variant of the LZ77 algorithm, Huffman coding and 2nd order context modeling. + . + This package provides an Conduit interface for the . + +license: BSD3 +license-file: LICENSE +author: Nathan Howell, Herbert Valerio Riedel +maintainer: hvr@gnu.org +homepage: http://github.com/hvr/brotli-conduit +bug-reports: http://github.com/hvr/brotli-conduit/issues +category: Codec, Compression, Conduit + +source-repository head + type: git + location: https://github.com/hvr/brotli-conduit.git + +library + default-language: Haskell2010 + other-extensions: Trustworthy + hs-source-dirs: src + exposed-modules: Data.Conduit.Brotli + build-depends: + base >= 4.5 && < 4.13, + bytestring >= 0.9.2 && < 0.11, + conduit >= 1.1.0 && < 1.4, + brotli >= 0.0.0.0 && < 0.1, + resourcet >= 1.1.0 && < 1.3, + transformers >= 0.3.0.0 && < 0.6 + + ghc-options: -Wall + +test-suite brotli-conduit-tests + default-language: Haskell2010 + hs-source-dirs: tests + type: exitcode-stdio-1.0 + main-is: Main.hs + + build-depends: + -- dependencies with version bounds inherited from the library stanza + base, + brotli-conduit, + bytestring, + conduit, + resourcet, + -- additional dependencies that require version bounds + test-framework == 0.8.*, + test-framework-hunit == 0.3.*, + test-framework-quickcheck2 == 0.3.*, + HUnit == 1.6.*, + QuickCheck == 2.13.* + + ghc-options: -threaded -fno-warn-deprecations diff --git a/src/Data/Conduit/Brotli.hs b/src/Data/Conduit/Brotli.hs new file mode 100644 --- /dev/null +++ b/src/Data/Conduit/Brotli.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Data.Conduit.Brotli +-- Copyright : © 2016 Herbert Valerio Riedel +-- +-- Maintainer : hvr@gnu.org +-- +-- Compression and decompression of data streams in the \"Brotli\" format () +-- +module Data.Conduit.Brotli + ( -- * Simple interface + compress + , decompress + + -- * Extended interface + -- ** Compression + , compressWith + + , Brotli.defaultCompressParams + , Brotli.CompressParams + , Brotli.compressLevel + , Brotli.compressWindowSize + , Brotli.compressMode + , Brotli.compressSizeHint + , Brotli.CompressionLevel(..) + , Brotli.CompressionWindowSize(..) + , Brotli.CompressionMode(..) + + -- ** Decompression + , decompressWith + + , Brotli.defaultDecompressParams + , Brotli.DecompressParams + , Brotli.decompressDisableRingBufferReallocation + + ) where + +import qualified Codec.Compression.Brotli as Brotli +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) + +-- | Decompress a 'ByteString' from a compressed Brotli stream. +decompress :: (MonadThrow m, MonadIO m) => ConduitM ByteString ByteString m () +decompress = decompressWith Brotli.defaultDecompressParams + +-- | Like 'decompress' but with the ability to specify various decompression +-- parameters. Typical usage: +-- +-- > decompressWith defaultDecompressParams { decompress... = ... } +decompressWith :: (MonadThrow m, MonadIO m) => Brotli.DecompressParams -> ConduitM ByteString ByteString m () +decompressWith parms = do + c <- peek + case c of + Nothing -> throwM $ userError $ "Data.Conduit.Brotli.decompress: invalid empty input" + Just _ -> liftIO (Brotli.decompressIO parms) >>= go + where + go s@(Brotli.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 (Brotli.DecompressOutputAvailable output cont) = do + yield output + liftIO cont >>= go + go (Brotli.DecompressStreamEnd rest) = do + if B.null rest + then App.pure () + else leftover rest + go (Brotli.DecompressStreamError ecode) = + throwM $ userError $ "Data.Conduit.Brotli.decompress: error (" ++ Brotli.showBrotliDecoderErrorCode ecode ++ ")" + + +-- | Compress a 'ByteString' into a Brotli container stream. +compress :: (MonadIO m) => ConduitM ByteString ByteString m () +compress = compressWith Brotli.defaultCompressParams + +-- | Like 'compress' but with the ability to specify various compression +-- parameters. Typical usage: +-- +-- > compressWith defaultCompressParams { compress... = ... } +compressWith :: MonadIO m => Brotli.CompressParams -> ConduitM ByteString ByteString m () +compressWith parms = do + s <- liftIO (Brotli.compressIO parms) + go s + where + go s@(Brotli.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 (Brotli.CompressOutputAvailable output cont) = do + yield output + liftIO cont >>= go + go Brotli.CompressStreamEnd = pure () diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -0,0 +1,105 @@ +import Test.Framework (defaultMain, testGroup) +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 (testProperty) +import Test.QuickCheck +import Test.QuickCheck.Monadic +import Control.Monad.Trans.Resource + +import qualified Data.ByteString as B +import qualified Data.Conduit as C +import qualified Data.Conduit.List as Cl +import Data.List +import Data.Word +import Data.Conduit.Brotli +import System.IO.Error (tryIOError) + + +main = defaultMain tests + +tests = + [ testGroup "Compress" compressTests + , testGroup "Decompress" decompressTests + , testGroup "Chained" chainedTests + ] + +compressTests = + [ testProperty "compressAndDiscard" prop_compressAndDiscard + , testProperty "compressAndCheckLength" prop_compressAndCheckLength + ] + +decompressTests = + [ testProperty "decompressEmpty" prop_decompressEmpty +-- TODO: redesign these tests +-- , 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 + +prop_compressAndDiscard :: Property +prop_compressAndDiscard = monadicIO . forAllM someBigString $ \ str -> do + run . runResourceT $ Cl.sourceList [str] C.$$ compress C.=$= Cl.sinkNull + +prop_compressAndCheckLength :: Property +prop_compressAndCheckLength = monadicIO . forAllM someBigString $ \ str -> do + len <- run . runResourceT $ Cl.sourceList [str] C.$$ compress C.=$= Cl.fold (\ acc el -> acc + B.length el) 0 + -- random strings don't compress very well + assert (len > B.length str `div` 2) + assert (len - 64 < B.length str * 2) + +prop_chain :: Property +prop_chain = monadicIO . forAllM someBigString $ \ str -> do + str' <- run . runResourceT $ Cl.sourceList [str] C.$$ compress C.=$= decompress C.=$= Cl.consume + return $ str == B.concat str' + +prop_compressThenDecompress :: Property +prop_compressThenDecompress = monadicIO . forAllM someBigString $ \ str -> do + blob <- run . runResourceT $ Cl.sourceList [str] C.$$ compress C.=$= Cl.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 . runResourceT $ Cl.sourceList resplit C.$$ decompress C.=$= Cl.consume + return $ str == B.concat str' + +prop_decompressRandom :: Property +prop_decompressRandom = monadicIO . forAllM someBigString $ \ str -> do + header <- run . runResourceT $ Cl.sourceList [] C.$$ compress C.=$= Cl.consume + let blob = header ++ [str] + ioErrorE <- run $ + tryIOError (runResourceT $ Cl.sourceList blob C.$$ decompress C.=$= Cl.sinkNull) + assert $ isLeft' ioErrorE + +prop_decompressCorrupt :: Property +prop_decompressCorrupt = monadicIO . forAllM someBigString $ \ str -> do + header <- run . runResourceT $ Cl.sourceList [] C.$$ compress C.=$= Cl.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] + ioErrorE <- run $ + tryIOError (runResourceT $ Cl.sourceList blob C.$$ decompress C.=$= Cl.sinkNull) + assert $ isLeft' ioErrorE + +prop_decompressEmpty :: Property +prop_decompressEmpty = monadicIO . forAllM someBigString $ \ str -> do + count <- pick $ elements [0..10] + let blob = replicate count B.empty + ioErrorE <- run $ + tryIOError (runResourceT $ Cl.sourceList blob C.$$ decompress C.=$= Cl.sinkNull) + assert $ isLeft' ioErrorE + + +isLeft' = either (const True) (const False)