diff --git a/Blaze/ByteString/Builder/Char8.hs b/Blaze/ByteString/Builder/Char8.hs deleted file mode 100644 --- a/Blaze/ByteString/Builder/Char8.hs +++ /dev/null @@ -1,32 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Char8 --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- //Note:// This package is intended for low-level use like implementing --- protocols. If you need to //serialize// Unicode characters use one of the --- UTF encodings (e.g. 'Blaze.ByteString.Builder.Char.UTF-8'). --- --- 'Write's and 'Builder's for serializing the lower 8-bits of characters. --- --- This corresponds to what the 'bytestring' package offer in --- 'Data.ByteString.Char8'. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.Char8 - ( - -- * Writing Latin-1 (ISO 8859-1) encodable characters to a buffer - writeChar - ) where - -import Blaze.ByteString.Builder.Compat.Write ( Write, writePrimFixed ) -import qualified Data.ByteString.Builder.Prim as P - --- | Write the lower 8-bits of a character to a buffer. -writeChar :: Char -> Write -writeChar = writePrimFixed P.char8 -{-# INLINE writeChar #-} diff --git a/Blaze/ByteString/Builder/Compat/Write.hs b/Blaze/ByteString/Builder/Compat/Write.hs deleted file mode 100644 --- a/Blaze/ByteString/Builder/Compat/Write.hs +++ /dev/null @@ -1,23 +0,0 @@ ------------------------------------------------------------------------------- --- | --- Module: Blaze.ByteString.Builder.Compat.Write --- Copyright: (c) 2013 Leon P Smith --- License: BSD3 --- Maintainer: Leon P Smith --- Stability: experimental --- --- Conversions from the new Prims to the old Writes. --- ------------------------------------------------------------------------------- - -module Blaze.ByteString.Builder.Compat.Write - ( Write - , writePrimFixed - ) where - -import Data.ByteString.Builder.Prim.Internal (FixedPrim, runF, size) -import Blaze.ByteString.Builder.Internal.Write (Write, exactWrite) - -writePrimFixed :: FixedPrim a -> a -> Write -writePrimFixed fe a = exactWrite (size fe) (runF fe a) -{-# INLINE writePrimFixed #-} diff --git a/Blaze/ByteString/Builder/Internal/Write.hs b/Blaze/ByteString/Builder/Internal/Write.hs deleted file mode 100644 --- a/Blaze/ByteString/Builder/Internal/Write.hs +++ /dev/null @@ -1,168 +0,0 @@ -{-# LANGUAGE CPP, BangPatterns #-} - --- | --- Module : Blaze.ByteString.Builder.Internal.Poke --- Copyright : (c) 2010 Simon Meier --- (c) 2010 Jasper van der Jeugt --- License : BSD3-style (see LICENSE) --- --- Maintainer : Leon Smith --- Stability : experimental --- Portability : tested on GHC only --- --- A general and efficient write type that allows for the easy construction of --- builders for (smallish) bounded size writes to a buffer. --- --- FIXME: Improve documentation. --- -module Blaze.ByteString.Builder.Internal.Write ( - -- * Poking a buffer - Poke(..) - , pokeN - - -- * Writing to abuffer - , Write(..) - , getPoke - - , exactWrite - , boundedWrite - - -- * Constructing builders from writes - , fromWrite - - -- * Writing 'Storable's - ) where - -import Foreign - -import Control.Monad - -import Data.ByteString.Builder.Internal - -import Data.Monoid (Monoid(..)) -#if MIN_VERSION_base(4,9,0) -import Data.Semigroup -#endif - ------------------------------------------------------------------------------- --- Poking a buffer and writing to a buffer ------------------------------------------------------------------------------- - --- Sadly GHC is not smart enough: code where we branch and each branch should --- execute a few IO actions and then return a value cannot be taught to GHC. At --- least not such that it returns the value of the branches unpacked. --- --- Hmm.. at least he behaves much better for the Monoid instance of Write --- than the one for Poke. Serializing UTF-8 chars gets a slowdown of a --- factor 2 when 2 chars are composed. Perhaps I should try out the writeList --- instances also, as they may be more sensitive to to much work per Char. --- - --- | Changing a sequence of bytes starting from the given pointer. 'Poke's are --- the most primitive buffer manipulation. In most cases, you don't use the --- explicitely but as part of a 'Write', which also tells how many bytes will --- be changed at most. -newtype Poke = - Poke { runPoke :: Ptr Word8 -> IO (Ptr Word8) } - --- | A write of a bounded number of bytes. --- --- When defining a function @write :: a -> Write@ for some @a@, then it is --- important to ensure that the bound on the number of bytes written is --- data-independent. Formally, --- --- @ forall x y. getBound (write x) = getBound (write y) @ --- --- The idea is that this data-independent bound is specified such that the --- compiler can optimize the check, if there are enough free bytes in the buffer, --- to a single subtraction between the pointer to the next free byte and the --- pointer to the end of the buffer with this constant bound of the maximal --- number of bytes to be written. --- -data Write = Write {-# UNPACK #-} !Int Poke - --- | Extract the 'Poke' action of a write. -{-# INLINE getPoke #-} -getPoke :: Write -> Poke -getPoke (Write _ wio) = wio - -#if MIN_VERSION_base(4,9,0) -instance Semigroup Poke where - {-# INLINE (<>) #-} - (Poke po1) <> (Poke po2) = Poke $ po1 >=> po2 - - {-# INLINE sconcat #-} - sconcat = foldr (<>) mempty -#endif - -instance Monoid Poke where - {-# INLINE mempty #-} - mempty = Poke return - -#if !(MIN_VERSION_base(4,11,0)) - {-# INLINE mappend #-} - (Poke po1) `mappend` (Poke po2) = Poke $ po1 >=> po2 -#endif - - {-# INLINE mconcat #-} - mconcat = foldr mappend mempty - -#if MIN_VERSION_base(4,9,0) -instance Semigroup Write where - {-# INLINE (<>) #-} - (Write bound1 w1) <> (Write bound2 w2) = - Write (bound1 + bound2) (w1 <> w2) - - {-# INLINE sconcat #-} - sconcat = foldr (<>) mempty -#endif - -instance Monoid Write where - {-# INLINE mempty #-} - mempty = Write 0 mempty - -#if !(MIN_VERSION_base(4,11,0)) - {-# INLINE mappend #-} - (Write bound1 w1) `mappend` (Write bound2 w2) = - Write (bound1 + bound2) (w1 `mappend` w2) -#endif - - {-# INLINE mconcat #-} - mconcat = foldr mappend mempty - --- | @pokeN size io@ creates a write that denotes the writing of @size@ bytes --- to a buffer using the IO action @io@. Note that @io@ MUST write EXACTLY @size@ --- bytes to the buffer! -{-# INLINE pokeN #-} -pokeN :: Int - -> (Ptr Word8 -> IO ()) -> Poke -pokeN size io = Poke $ \op -> io op >> (return $! (op `plusPtr` size)) - - --- | @exactWrite size io@ creates a bounded write that can later be converted to --- a builder that writes exactly @size@ bytes. Note that @io@ MUST write --- EXACTLY @size@ bytes to the buffer! -{-# INLINE exactWrite #-} -exactWrite :: Int - -> (Ptr Word8 -> IO ()) - -> Write -exactWrite size io = Write size (pokeN size io) - --- | @boundedWrite size write@ creates a bounded write from a @write@ that does --- not write more than @size@ bytes. -{-# INLINE boundedWrite #-} -boundedWrite :: Int -> Poke -> Write -boundedWrite = Write - --- | Create a builder that execute a single 'Write'. -{-# INLINE fromWrite #-} -fromWrite :: Write -> Builder -fromWrite (Write maxSize wio) = - builder step - where - step k (BufferRange op ope) - | op `plusPtr` maxSize <= ope = do - op' <- runPoke wio op - let !br' = BufferRange op' ope - k br' - | otherwise = return $ bufferFull maxSize op (step k) diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for the `bsb-http-chunked` package +## [0.0.0.3] – 2018-09-01 + +- Compatibility with GHC-8.6 +- Documentation improvements + ## [0.0.0.2] – 2018-03-13 - A lot of unused code was removed @@ -18,6 +23,7 @@ The format of this changelog is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/) -[Unreleased]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.2...HEAD +[Unreleased]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.3...HEAD +[0.0.0.3]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.2...v0.0.0.3 [0.0.0.2]: https://github.com/sjakobi/bsb-http-chunked/compare/v0.0.0.1...v0.0.0.2 [0.0.0.1]: https://github.com/sjakobi/bsb-http-chunked/compare/v0...v0.0.0.1 diff --git a/Data/ByteString/Builder/HTTP/Chunked.hs b/Data/ByteString/Builder/HTTP/Chunked.hs --- a/Data/ByteString/Builder/HTTP/Chunked.hs +++ b/Data/ByteString/Builder/HTTP/Chunked.hs @@ -1,168 +1,165 @@ -{-# LANGUAGE BangPatterns, CPP, MagicHash, OverloadedStrings #-} --- | Chunked HTTP transfer encoding +{-# LANGUAGE BangPatterns, MagicHash, OverloadedStrings #-} +-- | HTTP/1.1 chunked transfer encoding as defined +-- in [RFC 7230 Section 4.1](https://tools.ietf.org/html/rfc7230#section-4.1) module Data.ByteString.Builder.HTTP.Chunked ( chunkedTransferEncoding , chunkedTransferTerminator ) where -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -#include "MachDeps.h" -#endif - -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -import GHC.Base -import GHC.Word (Word32(..)) -#else -import Data.Word -#endif - -import Foreign - -import qualified Data.ByteString as S -import Data.ByteString.Char8 () - -import Blaze.ByteString.Builder.Internal.Write -import Data.ByteString.Builder -import Data.ByteString.Builder.Internal - -import qualified Blaze.ByteString.Builder.Char8 as Char8 - -#if !MIN_VERSION_base(4,8,0) -import Data.Monoid -#endif - - -{-# INLINE shiftr_w32 #-} -shiftr_w32 :: Word32 -> Int -> Word32 +import Control.Applicative (pure) +import Control.Monad (void) +import Foreign (Ptr, Word8, (.&.)) +import qualified Foreign as F +import GHC.Base (Int(..), uncheckedShiftRL#) +import GHC.Word (Word32(..)) -#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) -shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) -#else -shiftr_w32 = shiftR -#endif +import qualified Data.ByteString as S +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder.Internal (BufferRange(..), BuildSignal) +import qualified Data.ByteString.Builder.Internal as B +import qualified Data.ByteString.Builder.Prim as P +import qualified Data.ByteString.Builder.Prim.Internal as P +import Data.ByteString.Char8 () -- For the IsString instance +------------------------------------------------------------------------------ +-- CRLF utils +------------------------------------------------------------------------------ --- | Write a CRLF sequence. -writeCRLF :: Write -writeCRLF = Char8.writeChar '\r' `mappend` Char8.writeChar '\n' {-# INLINE writeCRLF #-} - --- | Execute a write -{-# INLINE execWrite #-} -execWrite :: Write -> Ptr Word8 -> IO () -execWrite w op = do - _ <- runPoke (getPoke w) op - return () +writeCRLF :: Ptr Word8 -> IO (Ptr Word8) +writeCRLF op = do + P.runF (P.char8 P.>*< P.char8) ('\r', '\n') op + pure $! op `F.plusPtr` 2 +{-# INLINE crlfBuilder #-} +crlfBuilder :: Builder +crlfBuilder = P.primFixed (P.char8 P.>*< P.char8) ('\r', '\n') ------------------------------------------------------------------------------ -- Hex Encoding Infrastructure ------------------------------------------------------------------------------ -pokeWord32HexN :: Int -> Word32 -> Ptr Word8 -> IO () -pokeWord32HexN n0 w0 op0 = - go w0 (op0 `plusPtr` (n0 - 1)) +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +-- | @writeWord32Hex len w op@ writes the hex encoding of @w@ to @op@ and +-- returns @op `'F.plusPtr'` len@. +-- +-- If writing @w@ doesn't consume all @len@ bytes, leading zeros are added. +{-# INLINE writeWord32Hex #-} +writeWord32Hex :: Int -> Word32 -> Ptr Word8 -> IO (Ptr Word8) +writeWord32Hex len w0 op0 = do + go w0 (op0 `F.plusPtr` (len - 1)) + pure $! op0 `F.plusPtr` len where go !w !op - | op < op0 = return () + | op < op0 = pure () | otherwise = do let nibble :: Word8 nibble = fromIntegral w .&. 0xF hex | nibble < 10 = 48 + nibble | otherwise = 55 + nibble - poke op hex - go (w `shiftr_w32` 4) (op `plusPtr` (-1)) -{-# INLINE pokeWord32HexN #-} + F.poke op hex + go (w `shiftr_w32` 4) (op `F.plusPtr` (-1)) +{-# INLINE iterationsUntilZero #-} iterationsUntilZero :: Integral a => (a -> a) -> a -> Int iterationsUntilZero f = go 0 where go !count 0 = count go !count !x = go (count+1) (f x) -{-# INLINE iterationsUntilZero #-} -- | Length of the hex-string required to encode the given 'Word32'. +{-# INLINE word32HexLength #-} word32HexLength :: Word32 -> Int word32HexLength = max 1 . iterationsUntilZero (`shiftr_w32` 4) -{-# INLINE word32HexLength #-} -writeWord32Hex :: Word32 -> Write -writeWord32Hex w = - boundedWrite (2 * sizeOf w) (pokeN len $ pokeWord32HexN len w) - where - len = word32HexLength w -{-# INLINE writeWord32Hex #-} - - ------------------------------------------------------------------------------ -- Chunked transfer encoding ------------------------------------------------------------------------------ -- | Transform a builder such that it uses chunked HTTP transfer encoding. +-- +-- >>> :set -XOverloadedStrings +-- >>> import Data.ByteString.Builder as B +-- >>> let f = B.toLazyByteString . chunkedTransferEncoding . B.lazyByteString +-- >>> f "data" +-- "004\r\ndata\r\n" +-- +-- >>> f "" +-- "" +-- +-- /Note/: While for many inputs, the bytestring chunks that can be obtained from the output +-- via @'Data.ByteString.Lazy.toChunks' . 'Data.ByteString.Builder.toLazyByteString'@ +-- each form a chunk in the sense +-- of [RFC 7230 Section 4.1](https://tools.ietf.org/html/rfc7230#section-4.1), +-- this correspondence doesn't hold in general. chunkedTransferEncoding :: Builder -> Builder chunkedTransferEncoding innerBuilder = - builder transferEncodingStep + B.builder transferEncodingStep where transferEncodingStep k = - go (runBuilder innerBuilder) + go (B.runBuilder innerBuilder) where go innerStep (BufferRange op ope) -- FIXME: Assert that outRemaining < maxBound :: Word32 | outRemaining < minimalBufferSize = - return $ bufferFull minimalBufferSize op (go innerStep) + pure $ B.bufferFull minimalBufferSize op (go innerStep) | otherwise = do let !brInner@(BufferRange opInner _) = BufferRange - (op `plusPtr` (chunkSizeLength + 2)) -- leave space for chunk header - (ope `plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data + (op `F.plusPtr` (maxChunkSizeLength + 2)) -- leave space for chunk header + (ope `F.plusPtr` (-maxAfterBufferOverhead)) -- leave space at end of data -- wraps the chunk, if it is non-empty, and returns the -- signal constructed with the correct end-of-data pointer {-# INLINE wrapChunk #-} wrapChunk :: Ptr Word8 -> (Ptr Word8 -> IO (BuildSignal a)) -> IO (BuildSignal a) - wrapChunk !opInner' mkSignal - | opInner' == opInner = mkSignal op + wrapChunk !chunkDataEnd mkSignal + | chunkDataEnd == opInner = mkSignal op | otherwise = do - pokeWord32HexN chunkSizeLength - (fromIntegral $ opInner' `minusPtr` opInner) - op - execWrite writeCRLF (opInner `plusPtr` (-2)) - execWrite writeCRLF opInner' - mkSignal (opInner' `plusPtr` 2) + let chunkSize = fromIntegral $ chunkDataEnd `F.minusPtr` opInner + -- If the hex of chunkSize requires less space than + -- maxChunkSizeLength, we get leading zeros. + void $ writeWord32Hex maxChunkSizeLength chunkSize op + void $ writeCRLF (opInner `F.plusPtr` (-2)) + void $ writeCRLF chunkDataEnd + mkSignal (chunkDataEnd `F.plusPtr` 2) - -- prepare handlers doneH opInner' _ = wrapChunk opInner' $ \op' -> do let !br' = BufferRange op' ope k br' fullH opInner' minRequiredSize nextInnerStep = wrapChunk opInner' $ \op' -> - return $! bufferFull + pure $! B.bufferFull (minRequiredSize + maxEncodingOverhead) op' (go nextInnerStep) - + insertChunkH opInner' bs nextInnerStep | S.null bs = -- flush wrapChunk opInner' $ \op' -> - return $! insertChunk op' S.empty (go nextInnerStep) + pure $! B.insertChunk op' S.empty (go nextInnerStep) | otherwise = -- insert non-empty bytestring wrapChunk opInner' $ \op' -> do -- add header for inserted bytestring -- FIXME: assert(S.length bs < maxBound :: Word32) - !op'' <- (`runPoke` op') $ getPoke $ - writeWord32Hex (fromIntegral $ S.length bs) - `mappend` writeCRLF + let chunkSize = fromIntegral $ S.length bs + hexLength = word32HexLength chunkSize + !op'' <- writeWord32Hex hexLength chunkSize op' + !op''' <- writeCRLF op'' -- insert bytestring and write CRLF in next buildstep - return $! insertChunk - op'' bs - (runBuilderWith (fromWrite writeCRLF) $ go nextInnerStep) + pure $! B.insertChunk + op''' bs + (B.runBuilderWith crlfBuilder $ go nextInnerStep) -- execute inner builder with reduced boundaries - fillWithBuildStep innerStep doneH fullH insertChunkH brInner + B.fillWithBuildStep innerStep doneH fullH insertChunkH brInner where -- minimal size guaranteed for actual data no need to require more -- than 1 byte to guarantee progress the larger sizes will be @@ -171,20 +168,18 @@ minimalChunkSize = 1 -- overhead computation - maxBeforeBufferOverhead = sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header - maxAfterBufferOverhead = 2 + -- CRLF after data - sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header + maxBeforeBufferOverhead = F.sizeOf (undefined :: Int) + 2 -- max chunk size and CRLF after header + maxAfterBufferOverhead = 2 + -- CRLF after data + F.sizeOf (undefined :: Int) + 2 -- max bytestring size, CRLF after header maxEncodingOverhead = maxBeforeBufferOverhead + maxAfterBufferOverhead minimalBufferSize = minimalChunkSize + maxEncodingOverhead -- remaining and required space computation - outRemaining :: Int - outRemaining = ope `minusPtr` op - chunkSizeLength = word32HexLength $ fromIntegral outRemaining - + outRemaining = ope `F.minusPtr` op + maxChunkSizeLength = word32HexLength $ fromIntegral outRemaining --- | The zero-length chunk '0\r\n\r\n' signaling the termination of the data transfer. +-- | The zero-length chunk @0\\r\\n\\r\\n@ signaling the termination of the data transfer. chunkedTransferTerminator :: Builder -chunkedTransferTerminator = byteStringCopy "0\r\n\r\n" +chunkedTransferTerminator = B.byteStringCopy "0\r\n\r\n" diff --git a/bench/Bench.hs b/bench/Bench.hs new file mode 100644 --- /dev/null +++ b/bench/Bench.hs @@ -0,0 +1,69 @@ +{-# language DeriveAnyClass, DeriveGeneric, OverloadedStrings #-} +module Main where + +import Gauge + +import qualified Blaze.ByteString.Builder.HTTP as Blaze +import Data.ByteString.Builder.HTTP.Chunked + +import Control.DeepSeq +import qualified Data.ByteString as S +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import qualified Data.ByteString.Lazy as L +import Data.Semigroup +import GHC.Generics + +main :: IO () +main = defaultMain + [ benchEncode "clone village" + cloneVillage + (foldMap fromPerson) + , benchEncode "100 4kB chunks" + (S.replicate 4096 95) + (stimes (100 :: Int) . B.byteString) + , benchEncode "200kB strict bytestring" + (S.replicate (200 * 1000) 95) + B.byteString + , benchEncode "1000 small chunks" + "Hello" + (stimes (1000 :: Int) . B.byteString) + , benchEncode "1000 small chunks nocopy" + "Hello" + (stimes (1000 :: Int) . B.byteStringInsert) + ] + +-- Example adapted from +-- http://lambda-view.blogspot.de/2010/11/blaze-builder-library-faster.html + +data Person = Person { pName :: String, pAge :: Int } + deriving (Generic, NFData) + +people :: [Person] +people = zipWith Person ["Haskell 98", "Switzerland", "λ-bot"] [12, 719, 7] + +fromStringLen32le :: String -> B.Builder +fromStringLen32le cs = + B.int32LE (fromIntegral $ length cs) <> B.stringUtf8 cs + +fromPerson :: Person -> B.Builder +fromPerson p = + fromStringLen32le (pName p) <> B.int32LE (fromIntegral $ pAge p) + +cloneVillage :: [Person] +cloneVillage = take 10000 $ cycle $ people + +-- Utils + +benchEncode :: NFData input => String -> input -> (input -> B.Builder) -> Benchmark +benchEncode name input mkBuilder = + env (return input) $ \input' -> bgroup name + [ bench "bsbhc" $ nf (encode . mkBuilder) input' + , bench "Blaze" $ nf (encodeBlaze . mkBuilder) input' + ] + +encode :: B.Builder -> L.ByteString +encode = B.toLazyByteString . chunkedTransferEncoding + +encodeBlaze :: B.Builder -> L.ByteString +encodeBlaze = B.toLazyByteString . Blaze.chunkedTransferEncoding diff --git a/bsb-http-chunked.cabal b/bsb-http-chunked.cabal --- a/bsb-http-chunked.cabal +++ b/bsb-http-chunked.cabal @@ -1,5 +1,5 @@ Name: bsb-http-chunked -Version: 0.0.0.2 +Version: 0.0.0.3 Synopsis: Chunked HTTP transfer encoding for bytestring builders Description: This library contains functions for encoding [bytestring @@ -10,10 +10,11 @@ the [blaze-builder](http://hackage.haskell.org/package/blaze-builder) package. -Author: Jasper Van der Jeugt, Simon Meier, Leon P Smith +Author: Jasper Van der Jeugt, Simon Meier, Leon P Smith, Simon Jakobi Copyright: (c) 2010-2014 Simon Meier (c) 2010 Jasper Van der Jeugt (c) 2013-2015 Leon P Smith + (c) 2018 Simon Jakobi Maintainer: Simon Jakobi License: BSD3 @@ -34,14 +35,51 @@ Location: https://github.com/sjakobi/bsb-http-chunked.git Library - ghc-options: -Wall - exposed-modules: Data.ByteString.Builder.HTTP.Chunked - - other-modules: Blaze.ByteString.Builder.Char8 - Blaze.ByteString.Builder.Compat.Write - Blaze.ByteString.Builder.Internal.Write - - build-depends: base >= 4.3 && < 4.12, + build-depends: base >= 4.3 && < 4.13, bytestring >= 0.9 && < 0.11, bytestring-builder < 0.11 + ghc-options: -Wall -O2 + if impl(ghc >= 8.0) + ghc-options: -Wcompat + +test-suite tests + hs-source-dirs: tests + main-is: Tests.hs + build-depends: attoparsec + , base + , bsb-http-chunked + , blaze-builder >= 0.2.1.4 + , bytestring + , bytestring-builder + , hedgehog + , tasty + , tasty-hedgehog + , tasty-hunit + ghc-options: -Wall -rtsopts + if impl(ghc < 7.10) + buildable: False + type: exitcode-stdio-1.0 + +test-suite doctests + hs-source-dirs: tests + main-is: Doctests.hs + build-depends: base + , doctest >= 0.8 + ghc-options: -Wall + type: exitcode-stdio-1.0 + +benchmark bench + hs-source-dirs: bench + main-is: Bench.hs + build-depends: base + , blaze-builder + , bsb-http-chunked + , bytestring + , deepseq + , gauge + , semigroups + ghc-options: -O2 -Wall -rtsopts + if impl(ghc < 7.10) + buildable: False + type: exitcode-stdio-1.0 diff --git a/tests/Doctests.hs b/tests/Doctests.hs new file mode 100644 --- /dev/null +++ b/tests/Doctests.hs @@ -0,0 +1,6 @@ +import Test.DocTest + +main :: IO () +main = doctest ["-isrc", "Data/ByteString/Builder/HTTP/Chunked.hs"] + + diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,108 @@ +{-# language OverloadedStrings, MultiWayIf #-} +module Main where + +import qualified Data.ByteString.Builder as B + +import Control.Applicative +import Data.Attoparsec.ByteString.Char8 (Parser, ()) +import qualified Data.Attoparsec.ByteString.Char8 as A +import qualified Data.Attoparsec.ByteString.Lazy as AL +import qualified Blaze.ByteString.Builder.HTTP as Blaze +import Data.ByteString (ByteString) +import qualified Data.ByteString as S +import Data.ByteString.Builder.HTTP.Chunked +import qualified Data.ByteString.Lazy as L +import Data.Functor +import Data.Maybe + +import Hedgehog +import qualified Hedgehog.Gen as Gen +import qualified Hedgehog.Range as Range +import Test.Tasty +import Test.Tasty.Hedgehog +import Test.Tasty.HUnit (testCase, (@?=)) + +main :: IO () +main = defaultMain $ testGroup "Tests" [properties, unitTests] + +chunkedTransferEncodingL :: L.ByteString -> L.ByteString +chunkedTransferEncodingL = B.toLazyByteString . chunkedTransferEncoding . B.lazyByteString + +chunkedTransferEncodingLBlaze :: L.ByteString -> L.ByteString +chunkedTransferEncodingLBlaze = B.toLazyByteString . Blaze.chunkedTransferEncoding . B.lazyByteString + +properties :: TestTree +properties = testGroup "Properties" + [ p "Encoding and parsing roundtrips" $ do + lbs <- forAll genLS + tripping lbs + chunkedTransferEncodingL + parseTransferChunks + -- This is about detecting differences in output, + -- not about bug-to-bug compatibility. + , p "Identical output as Blaze" $ do + lbs <- forAll genLS + chunkedTransferEncodingL lbs === chunkedTransferEncodingLBlaze lbs + ] + where + p name = testProperty name . property + +genLS :: Gen L.ByteString +genLS = L.fromChunks <$> genSs + +genSs :: Gen [ByteString] +genSs = Gen.list (Range.linear 0 100) genSnippedS + +genSnippedS :: Gen ByteString +genSnippedS = do + d <- genOffSet + e <- genOffSet + S.drop d . dropEnd e <$> genPackedS + where + genOffSet = Gen.int (Range.linear 0 100) + dropEnd n bs = S.take m bs + where m = S.length bs - n + +genPackedS :: Gen ByteString +genPackedS = + S.replicate + <$> Gen.int (Range.linear 0 mAX_CHUNK_SIZE) + <*> Gen.word8 (Range.constantFrom 95 minBound maxBound) + +parseTransferChunks :: L.ByteString -> Either String L.ByteString +parseTransferChunks = AL.eitherResult . + fmap (L.fromChunks . catMaybes) . + AL.parse (many transferChunkParser) + +-- Adapted from snap-server +transferChunkParser :: Parser (Maybe ByteString) +transferChunkParser = parser "encodedChunkParser" + where + parser = do + hex <- A.hexadecimal "hexadecimal" + -- skipWhile (/= '\r') "skipToEOL" -- We don't add chunk extensions + void crlf "linefeed" + if | hex > mAX_CHUNK_SIZE + -> fail $ "Chunk of size " ++ show hex ++ + " is too long. Max chunk size is " ++ show mAX_CHUNK_SIZE + | hex < 0 + -> fail $ "Negative chunk size: " ++ show hex + | hex == 0 + -> (crlf >> return Nothing) "terminal crlf after 0 length" + | otherwise + -> do + x <- A.take hex "reading data chunk" + void crlf "linefeed after data chunk" + return $! Just x + + crlf = A.string "\r\n" + +-- Chunks larger than this may indicate denial-of-service attack. +mAX_CHUNK_SIZE :: Int +mAX_CHUNK_SIZE = 256 * 1024 - 1 + +unitTests :: TestTree +unitTests = testGroup "Unit tests" + [ testCase "Encoding an empty builder returns an empty builder" $ + chunkedTransferEncodingL "" @?= "" + ]