diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 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 name of Ben Gamari nor the names of other + 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/src-tests/test.hs b/src-tests/test.hs new file mode 100644 --- /dev/null +++ b/src-tests/test.hs @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Main(main) where + +import Streaming.Brotli + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Streaming as S +import qualified Streaming as S +import qualified Streaming.Prelude as PP + +import Test.QuickCheck (Arbitrary (arbitrary), Property, + counterexample, quickCheck, + withMaxSuccess) +import Test.QuickCheck.Monadic (assert, monadicIO, monitor, run) + +-- | roundtrip without trailing extra data +prop_roundTrip :: [BS.ByteString] -> Property +prop_roundTrip bss = monadicIO $ do + bss' <- run $ pipeline bss + monitor $ counterexample $ show bss' + assert (BS.concat bss' == BS.concat bss) + where + pipeline :: S.MonadIO m => [BS.ByteString] -> m [BS.ByteString] + pipeline = PP.toList_ . S.toChunks . decompress_ . compress . S.fromChunks . PP.each + +-- | roundtrip with trailing extra data +prop_roundTrip2 :: [BS.ByteString] -> [BS.ByteString] -> Property +prop_roundTrip2 bss trailer = monadicIO $ do + (bss',trailer') <- run $ pipeline (bss,trailer) + monitor $ counterexample $ show (bss',trailer') + assert ((BS.concat bss', BS.concat trailer') == (BS.concat bss, BS.concat trailer)) + where + pipeline :: S.MonadIO m => ([BS.ByteString],[BS.ByteString]) -> m ([BS.ByteString],[BS.ByteString]) + pipeline (ibs,itl) = do + let itls = S.fromChunks . PP.each $ itl + obs PP.:> tbss <- PP.toList . S.toChunks . decompress . (`S.append` itls) . compress . S.fromChunks . PP.each $ ibs + tbs <- PP.toList_ . S.toChunks $ tbss + pure (obs,tbs) + +main :: IO () +main = do + quickCheck (withMaxSuccess 10000 prop_roundTrip) + quickCheck (withMaxSuccess 10000 prop_roundTrip2) + +instance Arbitrary BS.ByteString where + arbitrary = BS.pack <$> arbitrary diff --git a/src/Streaming/Brotli.hs b/src/Streaming/Brotli.hs new file mode 100644 --- /dev/null +++ b/src/Streaming/Brotli.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE Trustworthy #-} + +-- | +-- Module : Streaming.Brotli +-- Copyright : © 2019 Herbert Valerio Riedel +-- +-- Maintainer : hvr@gnu.org +-- +-- Compression and decompression of data streams in the \"Brotli\" format () +-- +module Streaming.Brotli + ( -- * Simple interface + compress + , decompress + , 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.Exception (throwIO) +import qualified Data.ByteString as B +import Data.ByteString.Streaming (ByteString, chunk, effects, + nextChunk, null_) +import Streaming (MonadIO (liftIO), lift) + +-- | Decompress a compressed Brotli stream. +-- +-- The monadic return value is a stream representing the possibly +-- unconsumed leftover data from the input stream; see also 'decompress_'. +decompress :: MonadIO m + => ByteString m r -- ^ compressed stream + -> ByteString m (ByteString m r) -- ^ uncompressed stream +decompress = decompressWith Brotli.defaultDecompressParams + +-- | Convenience wrapper around 'decompress' which fails eagerly if +-- the compressed stream contains any trailing data +decompress_ :: MonadIO m + => ByteString m r -- ^ compressed stream + -> ByteString m r -- ^ uncompressed stream +decompress_ is = do + mr <- decompress is + lift $ do + noLeftovers <- null_ mr + if noLeftovers + then effects mr + else liftIO (throwIO (Brotli.BrotliException "extra trailing data")) + +-- | Like 'decompress' but with the ability to specify various decompression +-- parameters. Typical usage: +-- +-- > decompressWith defaultDecompressParams { decompress... = ... } +decompressWith :: MonadIO m + => Brotli.DecompressParams + -> ByteString m r -- ^ compressed stream + -> ByteString m (ByteString m r) -- ^ uncompressed stream +decompressWith params stream0 = + go stream0 =<< liftIO (Brotli.decompressIO params) + where + go stream enc@(Brotli.DecompressInputRequired cont) = do + lift (nextChunk stream) >>= \case + Right (ibs,stream') + | B.null ibs -> go stream' enc -- should not happen + | otherwise -> go stream' =<< liftIO (cont ibs) + Left r -> go (pure r) =<< liftIO (cont B.empty) + go stream (Brotli.DecompressOutputAvailable obs cont) = do + chunk obs + go stream =<< liftIO cont + go stream (Brotli.DecompressStreamEnd leftover) = + pure (chunk leftover >> stream) + go _stream (Brotli.DecompressStreamError ecode) = + liftIO (throwIO ecode) + +-- | Compress into a Brotli compressed stream. +compress :: MonadIO m + => ByteString m r -- ^ compressed stream + -> ByteString m r -- ^ uncompressed stream +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 + -> ByteString m r -- ^ uncompressed stream + -> ByteString m r -- ^ compressed stream +compressWith params stream0 = + go stream0 =<< liftIO (Brotli.compressIO params) + where + go stream enc@(Brotli.CompressInputRequired _flush cont) = do + lift (nextChunk stream) >>= \case + Right (x, stream') + | B.null x -> go stream' enc -- should not happen + | otherwise -> go stream' =<< liftIO (cont x) + Left r -> go (pure r) =<< liftIO (cont B.empty) + go stream (Brotli.CompressOutputAvailable obs cont) = do + chunk obs + go stream =<< liftIO cont + go stream Brotli.CompressStreamEnd = stream diff --git a/streaming-brotli.cabal b/streaming-brotli.cabal new file mode 100644 --- /dev/null +++ b/streaming-brotli.cabal @@ -0,0 +1,58 @@ +cabal-version: 1.12 +build-type: Simple +name: streaming-brotli +version: 0.0.0.0 + +synopsis: Streaming interface for Brotli (RFC7932) compression +homepage: https://github.com/hvr/streaming-brotli +bug-reports: https://github.com/hvr/streaming-brotli/issues +license: BSD3 +license-file: LICENSE +author: Herbert Valerio Riedel +maintainer: hvr@gnu.org +category: Codec, Compression, Streaming + +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 API for the Brotli compression algorithm. + . + +source-repository head + type: git + location: https://github.com/hvr/streaming-brotli.git + +library + default-language: Haskell2010 + other-extensions: Trustworthy LambdaCase + + hs-source-dirs: src + exposed-modules: Streaming.Brotli + + build-depends: base >= 4.8 && < 4.13 + , bytestring >= 0.10.6 && < 0.11 + , brotli == 0.0.* + , streaming-bytestring >= 0.1.6 && < 0.2 + , streaming == 0.2.* + + ghc-options: -Wall + +test-suite test + default-language: Haskell2010 + hs-source-dirs: src-tests + main-is: test.hs + type: exitcode-stdio-1.0 + + build-depends: base + , bytestring + , streaming + , streaming-brotli + , streaming-bytestring + + , HUnit == 1.6.* + , QuickCheck == 2.13.* + , test-framework == 0.8.* + , test-framework-hunit == 0.3.* + , test-framework-quickcheck2 == 0.3.* + + ghc-options: -Wall -threaded