diff --git a/snap-core.cabal b/snap-core.cabal --- a/snap-core.cabal +++ b/snap-core.cabal @@ -1,5 +1,5 @@ name: snap-core -version: 0.9.0 +version: 0.9.2 synopsis: Snap: A Haskell Web Framework (core interfaces and types) description: @@ -128,35 +128,31 @@ build-depends: - attoparsec >= 0.10 && < 0.11, - attoparsec-enumerator >= 0.3 && <0.4, - base >= 4 && < 5, - base16-bytestring <= 0.2, - blaze-builder >= 0.2.1.4 && <0.4, - blaze-builder-enumerator >= 0.2 && <0.3, - bytestring, - bytestring-nums, - case-insensitive >= 0.3 && < 0.5, - containers, - deepseq >= 1.1 && <1.4, - directory, - dlist >= 0.5 && < 0.6, - enumerator >= 0.4.15 && < 0.5, - filepath, - HUnit >= 1.2 && < 2, - MonadCatchIO-transformers >= 0.2.1 && < 0.4, - mtl >= 2.0 && < 2.2, - mwc-random >= 0.10 && <0.13, - old-locale, - old-time, - regex-posix <= 0.95.2, - text >= 0.11 && <0.12, - time >= 1.0 && < 1.5, - transformers >= 0.2 && < 0.4, - unix-compat >= 0.2 && <0.4, - unordered-containers >= 0.1.4.3 && <0.3, - vector >= 0.6 && <0.10, - zlib-enum >= 0.2.1 && <0.3 + attoparsec >= 0.10 && < 0.11, + attoparsec-enumerator >= 0.3 && < 0.4, + base >= 4 && < 5, + blaze-builder >= 0.2.1.4 && < 0.4, + blaze-builder-enumerator >= 0.2 && < 0.3, + bytestring >= 0.9 && < 0.11, + case-insensitive >= 0.3 && < 0.5, + containers >= 0.3 && < 1.0, + deepseq >= 1.1 && < 1.4, + directory >= 1 && < 2, + enumerator >= 0.4.15 && < 0.5, + filepath >= 1.1 && < 2.0, + HUnit >= 1.2 && < 2, + MonadCatchIO-transformers >= 0.2.1 && < 0.4, + mtl >= 2.0 && < 2.2, + old-locale >= 1 && < 2, + random >= 1 && < 2, + regex-posix >= 0.95 && < 1, + text >= 0.11 && < 0.12, + time >= 1.0 && < 1.5, + transformers >= 0.2 && < 0.4, + unix-compat >= 0.2 && < 0.4, + unordered-containers >= 0.1.4.3 && < 0.3, + vector >= 0.6 && < 0.10, + zlib-enum >= 0.2.1 && < 0.3 extensions: BangPatterns, diff --git a/src/Snap/Internal/Instances.hs b/src/Snap/Internal/Instances.hs --- a/src/Snap/Internal/Instances.hs +++ b/src/Snap/Internal/Instances.hs @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE PackageImports #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE PackageImports #-} module Snap.Internal.Instances where @@ -15,7 +16,9 @@ import qualified Control.Monad.State.Lazy as LState import Control.Monad.Writer.Strict hiding (pass) import qualified Control.Monad.Writer.Lazy as LWriter +#if !MIN_VERSION_base(4,6,0) import Prelude hiding (catch) +#endif ------------------------------------------------------------------------------ import Snap.Internal.Types diff --git a/src/Snap/Internal/Parsing.hs b/src/Snap/Internal/Parsing.hs --- a/src/Snap/Internal/Parsing.hs +++ b/src/Snap/Internal/Parsing.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} @@ -10,18 +11,14 @@ import Control.Arrow (first, second) import Control.Monad import Data.Attoparsec.Char8 -import Data.Attoparsec.Types (IResult(..)) import Data.Bits import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import Data.ByteString.Internal (c2w, w2c) import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Nums.Careless.Hex as Cvt import qualified Data.CaseInsensitive as CI import Data.CaseInsensitive (CI) import Data.Char hiding (isDigit, isSpace) -import Data.DList (DList) -import qualified Data.DList as DL import Data.Int import Data.List (intersperse) import Data.Map (Map) @@ -274,10 +271,12 @@ ------------------------------------------------------------------------------ +type DList a = [a] -> [a] + pUrlEscaped :: Parser ByteString pUrlEscaped = do - sq <- nextChunk DL.empty - return $! S.concat $ DL.toList sq + sq <- nextChunk id + return $! S.concat $ sq [] where -------------------------------------------------------------------------- @@ -296,21 +295,21 @@ when (S.length hx /= 2 || (not $ S.all isHexDigit hx)) $ fail "bad hex in url" - let code = w2c ((Cvt.hex hx) :: Word8) - nextChunk $ DL.snoc l (S.singleton code) + let code = w2c ((unsafeFromHex hx) :: Word8) + nextChunk $ l . ((S.singleton code) :) -------------------------------------------------------------------------- unEncoded :: Char -> DList ByteString -> Parser (DList ByteString) unEncoded !c !l' = do - let l = DL.snoc l' (S.singleton c) + let l = l' . ((S.singleton c) :) bs <- takeTill (flip elem "%+") if S.null bs then nextChunk l - else nextChunk $ DL.snoc l bs + else nextChunk $ l . (bs :) -------------------------------------------------------------------------- plusSpace :: DList ByteString -> Parser (DList ByteString) - plusSpace l = nextChunk (DL.snoc l (S.singleton ' ')) + plusSpace l = nextChunk (l . ((S.singleton ' ') :)) ------------------------------------------------------------------------------ @@ -464,3 +463,29 @@ ------------------------------------------------------------------------------ strictize :: L.ByteString -> ByteString strictize = S.concat . L.toChunks + +------------------------------------------------------------------------------ +unsafeFromHex :: (Enum a, Num a, Bits a) => ByteString -> a +unsafeFromHex = S.foldl' f 0 + where +#if MIN_VERSION_base(4,5,0) + sl = unsafeShiftL +#else + sl = shiftL +#endif + + f !cnt !i = sl cnt 4 .|. nybble i + + nybble c | c >= '0' && c <= '9' = toEnum $! fromEnum c - fromEnum '0' + | c >= 'a' && c <= 'f' = toEnum $! 10 + fromEnum c - fromEnum 'a' + | c >= 'A' && c <= 'F' = toEnum $! 10 + fromEnum c - fromEnum 'A' + | otherwise = error $ "bad hex digit: " ++ show c +{-# INLINE unsafeFromHex #-} + + +------------------------------------------------------------------------------ +unsafeFromInt :: (Enum a, Num a, Bits a) => ByteString -> a +unsafeFromInt = S.foldl' f 0 + where + f !cnt !i = cnt * 10 + toEnum (digitToInt i) +{-# INLINE unsafeFromInt #-} diff --git a/src/Snap/Internal/Test/RequestBuilder.hs b/src/Snap/Internal/Test/RequestBuilder.hs --- a/src/Snap/Internal/Test/RequestBuilder.hs +++ b/src/Snap/Internal/Test/RequestBuilder.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Rank2Types #-} @@ -37,16 +38,18 @@ import Blaze.ByteString.Builder.Char8 import Control.Monad.State hiding (get, put) import qualified Control.Monad.State as State -import qualified Data.ByteString.Base16 as B16 +import Data.Bits import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S +import qualified Data.ByteString as S8 import Data.CaseInsensitive (CI) import Data.IORef import qualified Data.Map as Map import Data.Monoid import Data.Word +import qualified Data.Vector as V import System.PosixCompat.Time -import System.Random.MWC +import System.Random ------------------------------------------------------------------------------ import Snap.Internal.Http.Types hiding (addHeader, setContentType, @@ -227,12 +230,32 @@ ------------------------------------------------------------------------------ makeBoundary :: MonadIO m => m ByteString makeBoundary = do - xs <- liftIO $ withSystemRandom $ \rng -> - replicateM 16 ((uniform rng) :: IO Word8) + xs <- liftIO $ replicateM 16 randomWord8 let x = S.pack $ map (toEnum . fromEnum) xs - return $ S.concat [ "snap-boundary-", B16.encode x ] + return $ S.concat [ "snap-boundary-", encode x ] + where + randomWord8 :: IO Word8 + randomWord8 = liftM (\c -> toEnum $ c .&. 0xff) randomIO + table = V.fromList [ '0', '1', '2', '3', '4', '5', '6', '7', '8', '9' + , 'a', 'b', 'c', 'd', 'e', 'f' ] + + encode = toByteString . S8.foldl' f mempty + +#if MIN_VERSION_base(4,5,0) + shR = unsafeShiftR +#else + shR = shiftR +#endif + + f m c = let low = c .&. 0xf + hi = (c .&. 0xf0) `shR` 4 + k = \i -> fromWord8 $! toEnum $! fromEnum $! + V.unsafeIndex table (fromEnum i) + in m `mappend` k hi `mappend` k low + + ------------------------------------------------------------------------------ multipartHeader :: ByteString -> ByteString -> Builder multipartHeader boundary name = @@ -521,6 +544,10 @@ -- | Given a web handler in the 'Snap' monad, and a 'RequestBuilder' defining -- a test request, runs the handler, producing an HTTP 'Response'. -- +-- This function will produce almost exactly the same output as running the +-- handler in a real server, except that chunked transfer encoding is not +-- applied, and the \"Transfer-Encoding\" header is not set (this makes it +-- easier to test response output). runHandler :: MonadIO m => RequestBuilder m () -- ^ a request builder -> Snap a -- ^ a web handler @@ -532,6 +559,7 @@ (const $ return $! ()) (const $ return $! ()) rq + return rsp @@ -551,8 +579,15 @@ runHandlerM rSnap rBuilder snap = do rq <- buildRequest rBuilder rsp <- rSnap rq snap + + -- simulate server logic t1 <- liftIO (epochTime >>= formatHttpTime) - return $ H.setHeader "Date" t1 rsp + return $ H.setHeader "Date" t1 + $ H.setHeader "Server" "Snap/test" + $ if rspContentLength rsp == Nothing && + rspHttpVersion rsp < (1,1) + then H.setHeader "Connection" "close" rsp + else rsp ------------------------------------------------------------------------------ diff --git a/src/Snap/Internal/Types.hs b/src/Snap/Internal/Types.hs --- a/src/Snap/Internal/Types.hs +++ b/src/Snap/Internal/Types.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleInstances #-} @@ -31,13 +32,20 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Typeable +#if MIN_VERSION_base(4,6,0) +import Prelude hiding (take) +#else import Prelude hiding (catch, take) +#endif +import System.PosixCompat.Files hiding (setFileSize) +import System.Posix.Types (FileOffset) ------------------------------------------------------------------------------ -import Snap.Internal.Http.Types import Snap.Internal.Exceptions +import Snap.Internal.Http.Types import Snap.Internal.Iteratee.Debug -import Snap.Util.Readable import Snap.Iteratee hiding (map) +import qualified Snap.Types.Headers as H +import Snap.Util.Readable ------------------------------------------------------------------------------ @@ -257,7 +265,11 @@ -- | The Typeable instance is here so Snap can be dynamically executed with -- Hint. snapTyCon :: TyCon +#if MIN_VERSION_base(4,4,0) +snapTyCon = mkTyCon3 "snap-core" "Snap.Core" "Snap" +#else snapTyCon = mkTyCon "Snap.Core.Snap" +#endif {-# NOINLINE snapTyCon #-} instance Typeable1 Snap where @@ -871,17 +883,24 @@ PassOnProcessing _ -> fourohfour EarlyTermination x -> x - return (_snapRequest ss', resp) + let req' = _snapRequest ss' + resp' <- liftIO $ fixupResponse req' resp + + return (req', resp') + where + -------------------------------------------------------------------------- fourohfour = do clearContentLength $ setResponseStatus 404 "Not Found" $ setResponseBody enum404 $ emptyResponse + -------------------------------------------------------------------------- enum404 = enumBuilder $ mconcat $ map fromByteString html + -------------------------------------------------------------------------- html = [ S.concat [ "\n" , "\n" , "\n" @@ -894,10 +913,68 @@ , "\"\n" ] + -------------------------------------------------------------------------- dresp = emptyResponse { rspHttpVersion = rqVersion req } + -------------------------------------------------------------------------- ss = SnapState req dresp logerr timeoutAction {-# INLINE runSnap #-} + + + +-------------------------------------------------------------------------- +-- | Post-process a finalized HTTP response: +-- +-- * fixup content-length header +-- * properly handle 204/304 responses +-- * if request was HEAD, remove response body +-- +-- Note that we do NOT deal with transfer-encoding: chunked or "connection: +-- close" here. +fixupResponse :: Request -> Response -> IO Response +fixupResponse req rsp = {-# SCC "fixupResponse" #-} do + let code = rspStatus rsp + let rsp' = if code == 204 || code == 304 + then handle304 rsp + else rsp + + rsp'' <- do + z <- case rspBody rsp' of + (Enum _) -> return rsp' + (SendFile f Nothing) -> setFileSize f rsp' + (SendFile _ (Just (s,e))) -> return $! + setContentLength (e-s) rsp' + + return $! + case rspContentLength z of + Nothing -> deleteHeader "Content-Length" z + (Just sz) -> setHeader "Content-Length" + (toByteString $ fromShow sz) + z + + -- HEAD requests cannot have bodies per RFC 2616 sec. 9.4 + if rqMethod req == HEAD + then return $! deleteHeader "Transfer-Encoding" $ + rsp'' { rspBody = Enum $ enumBuilder mempty } + else return $! rsp'' + + where + -------------------------------------------------------------------------- + setFileSize :: FilePath -> Response -> IO Response + setFileSize fp r = {-# SCC "setFileSize" #-} do + fs <- liftM fromIntegral $ getFileSize fp + return $! r { rspContentLength = Just fs } + + ------------------------------------------------------------------------------ + getFileSize :: FilePath -> IO FileOffset + getFileSize fp = liftM fileSize $ getFileStatus fp + + -------------------------------------------------------------------------- + handle304 :: Response -> Response + handle304 r = setResponseBody (enumBuilder mempty) $ + updateHeaders (H.delete "Transfer-Encoding") $ + setContentLength 0 r +{-# INLINE fixupResponse #-} ------------------------------------------------------------------------------ diff --git a/src/Snap/Iteratee.hs b/src/Snap/Iteratee.hs --- a/src/Snap/Iteratee.hs +++ b/src/Snap/Iteratee.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -127,7 +127,11 @@ import Foreign hiding (peek) import Foreign.C.Types import GHC.ForeignPtr +#if MIN_VERSION_base(4,6,0) +import Prelude hiding (drop, head, take) +#else import Prelude hiding (catch, drop, head, take) +#endif import System.IO #ifndef PORTABLE diff --git a/src/Snap/Util/FileServe.hs b/src/Snap/Util/FileServe.hs --- a/src/Snap/Util/FileServe.hs +++ b/src/Snap/Util/FileServe.hs @@ -44,7 +44,11 @@ import Data.Monoid import qualified Data.Text as T import qualified Data.Text.Encoding as T +#if MIN_VERSION_base(4,6,0) +import Prelude hiding (show, Show) +#else import Prelude hiding (catch, show, Show) +#endif import qualified Prelude import System.Directory import System.FilePath diff --git a/src/Snap/Util/FileUploads.hs b/src/Snap/Util/FileUploads.hs --- a/src/Snap/Util/FileUploads.hs +++ b/src/Snap/Util/FileUploads.hs @@ -80,7 +80,6 @@ import Data.ByteString.Char8 (ByteString) import Data.ByteString.Internal (c2w) import qualified Data.CaseInsensitive as CI -import qualified Data.DList as D import Data.Enumerator.Binary (iterHandle) import Data.IORef import Data.Int @@ -91,7 +90,11 @@ import Data.Text (Text) import qualified Data.Text.Encoding as TE import Data.Typeable +#if MIN_VERSION_base(4,6,0) +import Prelude hiding (getLine, takeWhile) +#else import Prelude hiding (catch, getLine, takeWhile) +#endif import System.Directory import System.IO hiding (isEOF) ------------------------------------------------------------------------------ @@ -796,7 +799,7 @@ -- list of the resulting values. processParts :: Iteratee ByteString IO a -> Iteratee MatchInfo IO [a] -processParts partIter = iterateeDebugWrapper "processParts" $ go D.empty +processParts partIter = iterateeDebugWrapper "processParts" $ go id where iter = {-# SCC "processParts/iter" #-} do isLast <- bParser @@ -811,7 +814,7 @@ b <- isEOF if b - then return $! D.toList soFar + then return $ soFar [] else do -- processPart $$ iter -- :: Iteratee MatchInfo m (Step ByteString m a) @@ -821,8 +824,8 @@ output <- lift $ run_ $ returnI innerStep case output of - Just x -> go (D.append soFar $ D.singleton x) - Nothing -> return $! D.toList soFar + Just x -> go (soFar . (x:)) + Nothing -> return $ soFar [] bParser = iterateeDebugWrapper "boundary debugger" $ iterParser $ pBoundaryEnd diff --git a/src/Snap/Util/GZip.hs b/src/Snap/Util/GZip.hs --- a/src/Snap/Util/GZip.hs +++ b/src/Snap/Util/GZip.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} @@ -24,7 +25,11 @@ import qualified Data.Set as Set import Data.Set (Set) import Data.Typeable +#if MIN_VERSION_base(4,6,0) +import Prelude hiding (takeWhile) +#else import Prelude hiding (catch, takeWhile) +#endif ---------------------------------------------------------------------------- @@ -38,12 +43,14 @@ ------------------------------------------------------------------------------ -- | Runs a 'Snap' web handler with compression if available. -- --- If the client has indicated support for @gzip@ or @compress@ in its +-- If the client has indicated support for @gzip@ or @deflate@ in its -- @Accept-Encoding@ header, and the @Content-Type@ in the response is one of -- the following types: -- -- * @application/x-javascript@ -- +-- * @application/json@ +-- -- * @text/css@ -- -- * @text/html@ @@ -113,12 +120,12 @@ chooseType types - chooseType [] = return $! () - chooseType ("gzip":_) = gzipCompression "gzip" - chooseType ("compress":_) = compressCompression "compress" - chooseType ("x-gzip":_) = gzipCompression "x-gzip" - chooseType ("x-compress":_) = compressCompression "x-compress" - chooseType (_:xs) = chooseType xs + chooseType [] = return $! () + chooseType ("gzip":_) = gzipCompression "gzip" + chooseType ("deflate":_) = compressCompression "deflate" + chooseType ("x-gzip":_) = gzipCompression "x-gzip" + chooseType ("x-deflate":_) = compressCompression "x-deflate" + chooseType (_:xs) = chooseType xs ------------------------------------------------------------------------------ diff --git a/src/Snap/Util/Readable.hs b/src/Snap/Util/Readable.hs --- a/src/Snap/Util/Readable.hs +++ b/src/Snap/Util/Readable.hs @@ -34,3 +34,4 @@ fromBS = either fail checkComplete . decimal . decodeUtf8 instance Readable Double where fromBS = either fail checkComplete . double . decodeUtf8 + diff --git a/test/snap-core-testsuite.cabal b/test/snap-core-testsuite.cabal --- a/test/snap-core-testsuite.cabal +++ b/test/snap-core-testsuite.cabal @@ -26,27 +26,23 @@ attoparsec >= 0.10 && <0.11, attoparsec-enumerator >= 0.3, base >= 4 && <5, - base16-bytestring >= 0.1 && <0.2, blaze-builder >= 0.2.1.4 && <0.4, blaze-builder-enumerator >= 0.2 && <0.3, bytestring, - bytestring-nums, case-insensitive >= 0.3 && <0.5, cereal >= 0.3 && <0.4, containers, deepseq >= 1.1 && <1.4, directory, - dlist >= 0.5 && <0.6, filepath, HUnit >= 1.2 && <2, enumerator >= 0.4.13.1 && <0.5, MonadCatchIO-transformers >= 0.2 && <0.4, mtl >= 2 && <3, - mwc-random >= 0.10 && <0.13, old-locale, - old-time, parallel >= 3 && <4, pureMD5 == 2.1.*, + random >= 1 && <2, regex-posix >= 0.94.4 && <0.96, test-framework >= 0.6 && <0.7, test-framework-hunit >= 0.2.7 && <0.3, diff --git a/test/suite/Snap/Iteratee/Tests.hs b/test/suite/Snap/Iteratee/Tests.hs --- a/test/suite/Snap/Iteratee/Tests.hs +++ b/test/suite/Snap/Iteratee/Tests.hs @@ -13,7 +13,6 @@ import Control.Monad.CatchIO import Control.Monad.Identity import Control.Monad.Trans -import qualified Data.ByteString.Base16 as B16 import Data.ByteString.Char8 (ByteString) import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L @@ -425,10 +424,7 @@ monadicIO $ forAllM arbitrary prop where prop :: (ByteString, [ByteString]) -> PropertyM IO () - prop (needle', haystack') = do - let needle = B16.encode needle' - let haystack = Prelude.map B16.encode haystack' - + prop (needle, haystack) = do let lneedle = L.fromChunks [needle] let lhaystack = L.fromChunks haystack diff --git a/test/suite/Snap/Util/GZip/Tests.hs b/test/suite/Snap/Util/GZip/Tests.hs --- a/test/suite/Snap/Util/GZip/Tests.hs +++ b/test/suite/Snap/Util/GZip/Tests.hs @@ -70,13 +70,13 @@ ------------------------------------------------------------------------------ -gzipHdrs, xGzipHdrs, badHdrs, compressHdrs, xCompressHdrs, emptyHdrs :: Headers +gzipHdrs, xGzipHdrs, badHdrs, deflateHdrs, xDeflateHdrs, emptyHdrs :: Headers emptyHdrs = H.empty gzipHdrs = setHeader "Accept-Encoding" "froz,gzip, x-gzip" emptyHdrs xGzipHdrs = setHeader "Accept-Encoding" "x-gzip;q=1.0" emptyHdrs badHdrs = setHeader "Accept-Encoding" "*&%^&^$%&%&*^\023" emptyHdrs -compressHdrs = setHeader "Accept-Encoding" "compress" emptyHdrs -xCompressHdrs = setHeader "Accept-Encoding" "x-compress" emptyHdrs +deflateHdrs = setHeader "Accept-Encoding" "deflate" emptyHdrs +xDeflateHdrs = setHeader "Accept-Encoding" "x-deflate" emptyHdrs @@ -109,20 +109,20 @@ ------------------------------------------------------------------------------ -mkCompressRq :: IO Request -mkCompressRq = do +mkDeflateRq :: IO Request +mkDeflateRq = do enum <- newIORef $ SomeEnumerator returnI - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False compressHdrs + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False deflateHdrs enum Nothing GET (1,1) [] "/" "/" "/" "" Map.empty Map.empty Map.empty -mkXCompressRq :: IO Request -mkXCompressRq = do +mkXDeflateRq :: IO Request +mkXDeflateRq = do enum <- newIORef $ SomeEnumerator returnI - return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xCompressHdrs + return $ Request "foo" 80 "foo" 999 "foo" 1000 "foo" False xDeflateHdrs enum Nothing GET (1,1) [] "/" "/" "/" "" Map.empty Map.empty Map.empty @@ -154,13 +154,13 @@ d = (const $ return ()) -goGZip, goCompress, goXGZip :: Snap a -> IO (Request,Response) -goNoHeaders, goXCompress, goBad :: Snap a -> IO (Request,Response) +goGZip, goDeflate, goXGZip :: Snap a -> IO (Request,Response) +goNoHeaders, goXDeflate, goBad :: Snap a -> IO (Request,Response) goGZip = goGeneric mkGzipRq -goCompress = goGeneric mkCompressRq +goDeflate = goGeneric mkDeflateRq goXGZip = goGeneric mkXGzipRq -goXCompress = goGeneric mkXCompressRq +goXDeflate = goGeneric mkXDeflateRq goBad = goGeneric mkBadRq goNoHeaders = goGeneric mkNoHeaders @@ -269,13 +269,14 @@ ------------------------------------------------------------------------------ testIdentity2 :: Test -testIdentity2 = testProperty "gzip/identity2" $ monadicIO $ forAllM arbitrary prop +testIdentity2 = testProperty "gzip/identity2" $ monadicIO $ + forAllM arbitrary prop where prop :: L.ByteString -> PropertyM IO () prop s = do - (!_,!rsp) <- liftQ $ goCompress (seqSnap $ withCompression $ textPlain s) + (!_,!rsp) <- liftQ $ goDeflate (seqSnap $ withCompression $ textPlain s) - assert $ getHeader "Content-Encoding" rsp == Just "compress" + assert $ getHeader "Content-Encoding" rsp == Just "deflate" assert $ getHeader "Vary" rsp == Just "Accept-Encoding" let body = rspBodyToEnum $ rspBody rsp @@ -324,9 +325,9 @@ where prop :: L.ByteString -> PropertyM IO () prop s = do - (!_,!rsp2) <- liftQ $ goXCompress (seqSnap $ withCompression $ textPlain s) + (!_,!rsp2) <- liftQ $ goXDeflate (seqSnap $ withCompression $ textPlain s) - assert $ getHeader "Content-Encoding" rsp2 == Just "x-compress" + assert $ getHeader "Content-Encoding" rsp2 == Just "x-deflate" let body2 = rspBodyToEnum $ rspBody rsp2 c2 <- liftQ $ @@ -404,7 +405,7 @@ let s1 = GZip.decompress c H.assertBool "streams equal" $ s == s1 - + -- in order to get incompressible text (so that we can test whether the -- gzip thread is streaming properly!) we'll iteratively md5 the source -- string