snap-core 0.9.0 → 0.9.2
raw patch · 13 files changed
+246/−98 lines, 13 filesdep +randomdep −base16-bytestringdep −bytestring-numsdep −dlistdep ~bytestringdep ~containersdep ~directory
Dependencies added: random
Dependencies removed: base16-bytestring, bytestring-nums, dlist, mwc-random, old-time
Dependency ranges changed: bytestring, containers, directory, filepath, old-locale, regex-posix
Files
- snap-core.cabal +26/−30
- src/Snap/Internal/Instances.hs +4/−1
- src/Snap/Internal/Parsing.hs +36/−11
- src/Snap/Internal/Test/RequestBuilder.hs +41/−6
- src/Snap/Internal/Types.hs +80/−3
- src/Snap/Iteratee.hs +10/−6
- src/Snap/Util/FileServe.hs +4/−0
- src/Snap/Util/FileUploads.hs +8/−5
- src/Snap/Util/GZip.hs +14/−7
- src/Snap/Util/Readable.hs +1/−0
- test/snap-core-testsuite.cabal +1/−5
- test/suite/Snap/Iteratee/Tests.hs +1/−5
- test/suite/Snap/Util/GZip/Tests.hs +20/−19
snap-core.cabal view
@@ -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,
src/Snap/Internal/Instances.hs view
@@ -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
src/Snap/Internal/Parsing.hs view
@@ -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 #-}
src/Snap/Internal/Test/RequestBuilder.hs view
@@ -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 ------------------------------------------------------------------------------
src/Snap/Internal/Types.hs view
@@ -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 [ "<!DOCTYPE html>\n" , "<html>\n" , "<head>\n"@@ -894,10 +913,68 @@ , "\"</code>\n</body></html>" ] + -------------------------------------------------------------------------- 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 #-} ------------------------------------------------------------------------------
src/Snap/Iteratee.hs view
@@ -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
src/Snap/Util/FileServe.hs view
@@ -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
src/Snap/Util/FileUploads.hs view
@@ -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
src/Snap/Util/GZip.hs view
@@ -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 ------------------------------------------------------------------------------
src/Snap/Util/Readable.hs view
@@ -34,3 +34,4 @@ fromBS = either fail checkComplete . decimal . decodeUtf8 instance Readable Double where fromBS = either fail checkComplete . double . decodeUtf8+
test/snap-core-testsuite.cabal view
@@ -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,
test/suite/Snap/Iteratee/Tests.hs view
@@ -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
test/suite/Snap/Util/GZip/Tests.hs view
@@ -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