wai-extra 3.1.10 → 3.1.11
raw patch · 9 files changed
+567/−118 lines, 9 filesdep +temporarydep ~directory
Dependencies added: temporary
Dependency ranges changed: directory
Files
- ChangeLog.md +16/−0
- Network/Wai/Handler/CGI.hs +1/−0
- Network/Wai/Header.hs +72/−2
- Network/Wai/Middleware/AcceptOverride.hs +24/−12
- Network/Wai/Middleware/Gzip.hs +177/−44
- Network/Wai/Middleware/Jsonp.hs +0/−1
- Network/Wai/Test.hs +5/−0
- test/WaiExtraSpec.hs +266/−58
- wai-extra.cabal +6/−1
ChangeLog.md view
@@ -1,11 +1,27 @@ # Changelog for wai-extra +## 3.1.11++* Overhaul to `Network.Wai.Middleware.Gzip` [#880](https://github.com/yesodweb/wai/pull/880):+ * Don't fail if quality value parameters are present in the `Accept-Encoding` header+ * Add `Accept-Encoding` to the `Vary` response header, instead of overriding it+ * Add setting parameter to decide the compression threshold (`gzipSizeThreshold`)+ * Always skip compression on a `206 Partial Content` response+ * Only catch `IOException`s and `ZlibException`s when using `GzipCacheFolder`+ * Added documentation on the usage of `gzip` and its decision-making.++## 3.1.10.1++* Added documentation to `Accept Override` `Middleware` [#884](https://github.com/yesodweb/wai/pull/884)+ ## 3.1.10 +* Fixed import linting mistake introduced in `3.1.9` ([#875)](https://github.com/yesodweb/wai/pull/875)) where `Network.Wai.Handler.CGI` wouldn't compile on Windows. [#881](https://github.com/yesodweb/wai/pull/880) * Added `Select` to choose between `Middleware`s [#878](https://github.com/yesodweb/wai/pull/878) ## 3.1.9 +* Cleanup and linting of most of `wai-extra` and refactoring the `gzip` middleware to keep it more DRY and to skip compression earlier if possible [#875](https://github.com/yesodweb/wai/pull/875) * Added `HealthCheckEndpoint` `Middleware`s for health check [#877](https://github.com/yesodweb/wai/pull/877) ## 3.1.8
Network/Wai/Handler/CGI.hs view
@@ -33,6 +33,7 @@ import Network.Wai.Internal import System.IO (Handle) import qualified System.IO+ #if WINDOWS import System.Environment (getEnvironment) #else
Network/Wai/Header.hs view
@@ -1,11 +1,19 @@+{-# LANGUAGE CPP #-} -- | Some helpers for dealing with WAI 'Header's.- module Network.Wai.Header ( contentLength+ , parseQValueList+ , replaceHeader+ , splitCommas ) where +import Control.Monad (guard)+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8+import Data.ByteString.Internal (w2c)+import Data.Word8 (Word8, _0, _1, _comma, _period, _semicolon, _space) import Network.HTTP.Types as H+import Text.Read (readMaybe) -- | More useful for a response. A Wai Request already has a requestBodyLength contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer@@ -14,5 +22,67 @@ readInt :: S8.ByteString -> Maybe Integer readInt bs = case S8.readInteger bs of- Just (i, rest) | S8.null rest -> Just i+ -- 'S8.all' is also 'True' for an empty string+ Just (i, rest) | S8.all (== ' ') rest -> Just i _ -> Nothing++replaceHeader :: H.HeaderName -> S.ByteString -> [H.Header] -> [H.Header]+replaceHeader name val old =+ (name, val) : filter ((/= name) . fst) old++-- | Used to split a header value which is a comma separated list+splitCommas :: S.ByteString -> [S.ByteString]+splitCommas = map trimWS . S.split _comma++-- Trim whitespace+trimWS :: S.ByteString -> S.ByteString+trimWS = dropWhileEnd (== _space) . S.dropWhile (== _space)++-- | Dropping all 'Word8's from the end that satisfy the predicate.+dropWhileEnd :: (Word8 -> Bool) -> S.ByteString -> S.ByteString+#if MIN_VERSION_bytestring(0,10,12)+dropWhileEnd = S.dropWhileEnd+#else+dropWhileEnd p = fst . S.spanEnd p+#endif++-- | Only to be used on header's values which support quality value syntax+--+-- A few things to keep in mind when using this function:+-- * The resulting 'Int' will be anywhere from 1000 to 0 ("1" = 1000, "0.6" = 600, "0.025" = 25)+-- * The absence of a Q value will result in 'Just 1000'+-- * A bad parse of the Q value will result in a 'Nothing', e.g.+-- * Q value has more than 3 digits behind the dot+-- * Q value is missing+-- * Q value is higher than 1+-- * Q value is not a number+parseQValueList :: S8.ByteString -> [(S8.ByteString, Maybe Int)]+parseQValueList = fmap go . splitCommas+ where+ go = checkQ . S.break (== _semicolon)+ checkQ :: (S.ByteString, S.ByteString) -> (S.ByteString, Maybe Int)+ checkQ (val, "") = (val, Just 1000)+ checkQ (val, bs) =+ -- RFC 7231 says optional whitespace can be around the semicolon.+ -- So drop any before it , . and any behind it $ and drop the semicolon+ (dropWhileEnd (== _space) val, parseQval . S.dropWhile (== _space) $ S.drop 1 bs)+ where+ parseQval qVal = do+ q <- S.stripPrefix "q=" qVal+ (i, rest) <- S.uncons q+ guard $+ i `elem` [_0, _1]+ && S.length rest <= 4+ case S.uncons rest of+ Nothing+ -- q = "0" or "1"+ | i == _0 -> Just 0+ | i == _1 -> Just 1000+ | otherwise -> Nothing+ Just (dot, trail)+ | dot == _period && not (i == _1 && S.any (/= _0) trail) -> do+ let len = S.length trail+ extraZeroes = replicate (3 - len) '0'+ guard $ len > 0+ readMaybe $ w2c i : S8.unpack trail ++ extraZeroes+ | otherwise -> Nothing
Network/Wai/Middleware/AcceptOverride.hs view
@@ -1,11 +1,29 @@ module Network.Wai.Middleware.AcceptOverride- ( acceptOverride+ ( -- $howto+ acceptOverride ) where -import Control.Monad (join)-import Data.ByteString (ByteString) import Network.Wai+import Control.Monad (join) +import Network.Wai.Header (replaceHeader)++-- $howto+-- This 'Middleware' provides a way for the request itself to+-- tell the server to override the \"Accept\" header by looking+-- for the \"_accept\" query parameter in the query string and+-- inserting or replacing the \"Accept\" header with that string.+--+-- For example:+--+-- @+-- ?_accept=SomeValue+-- @+--+-- This will result in \"Accept: SomeValue\" being set in the+-- request as a header, and all other previous \"Accept\" headers+-- will be removed from the request.+ acceptOverride :: Middleware acceptOverride app req = app req'@@ -13,12 +31,6 @@ req' = case join $ lookup "_accept" $ queryString req of Nothing -> req- Just a -> req { requestHeaders = changeVal "Accept" a $ requestHeaders req}--changeVal :: Eq a- => a- -> ByteString- -> [(a, ByteString)]- -> [(a, ByteString)]-changeVal key val old = (key, val)- : filter (\(k, _) -> k /= key) old+ Just a -> req {+ requestHeaders = replaceHeader "Accept" a $ requestHeaders req+ }
Network/Wai/Middleware/Gzip.hs view
@@ -1,5 +1,3 @@-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE ScopedTypeVariables #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Gzip@@ -14,16 +12,30 @@ -- --------------------------------------------------------- module Network.Wai.Middleware.Gzip- ( gzip+ ( -- * How to use this module+ -- $howto++ -- ** The Middleware+ -- $gzip+ gzip++ -- ** The Settings+ -- $settings , GzipSettings , gzipFiles- , GzipFiles (..) , gzipCheckMime- , def+ , gzipSizeThreshold++ -- ** How to handle file responses+ , GzipFiles (..)++ -- ** Miscellaneous+ -- $miscellaneous , defaultCheckMime+ , def ) where -import Control.Exception (SomeException, throwIO, try)+import Control.Exception (IOException, SomeException, fromException, throwIO, try) import Control.Monad (unless) import qualified Data.ByteString as S import Data.ByteString.Builder (byteString)@@ -36,10 +48,10 @@ import qualified Data.Set as Set import qualified Data.Streaming.ByteString.Builder as B import qualified Data.Streaming.Zlib as Z-import Data.Word8 (_comma, _semicolon, _space)+import Data.Word8 as W8 (toLower, _semicolon) import Network.HTTP.Types ( Header,- Status,+ Status (statusCode), hContentEncoding, hContentLength, hContentType,@@ -51,30 +63,130 @@ import System.Directory (createDirectoryIfMissing, doesFileExist) import qualified System.IO as IO -import Network.Wai.Header (contentLength)+import Network.Wai.Header (contentLength, parseQValueList, replaceHeader, splitCommas) +-- $howto+--+-- This 'Middleware' adds @gzip encoding@ to an application.+-- Its use is pretty straightforward, but it's good to know+-- how and when it decides to encode the response body.+--+-- A few things to keep in mind when using this middleware:+--+-- * It is advised to put any 'Middleware's that change the+-- response behind this one, because it bases a lot of its+-- decisions on the returned response.+-- * Enabling compression may counteract zero-copy response+-- optimizations on some platforms.+-- * This middleware is applied to every response by default.+-- If it should only encode certain paths,+-- "Network.Wai.Middleware.Routed" might be helpful.++-- $gzip+--+-- There are a good amount of requirements that should be+-- fulfilled before a response will actually be @gzip encoded@+-- by this 'Middleware', so here's a short summary.+--+-- Request requirements:+--+-- * The request needs to accept \"gzip\" in the \"Accept-Encoding\" header.+-- * Requests from Internet Explorer 6 will not be encoded.+-- (i.e. if the request's \"User-Agent\" header contains \"MSIE 6\")+--+-- Response requirements:+--+-- * The response isn't already encoded. (i.e. shouldn't already+-- have a \"Content-Encoding\" header)+-- * The response isn't a @206 Partial Content@ (partial content+-- should never be compressed)+-- * If the response contains a \"Content-Length\" header, it+-- should be larger than the 'gzipSizeThreshold'.+-- * The \"Content-Type\" response header's value should+-- evaluate to 'True' when applied to 'gzipCheckMime'+-- (though 'GzipPreCompressed' will use the \".gz\" file regardless+-- of MIME type on any 'ResponseFile' response)+--+++-- $settings+--+-- If you would like to use the default settings, using just 'def' is enough.+-- The default settings don't compress file responses, only builder and stream+-- responses, and only if the response passes the MIME and length checks. (cf.+-- 'defaultCheckMime' and 'gzipSizeThreshold')+--+-- To customize your own settings, use the 'def' method and set the+-- fields you would like to change as follows:+--+-- @+-- myGzipSettings :: 'GzipSettings'+-- myGzipSettings =+-- 'def'+-- { 'gzipFiles' = 'GzipCompress'+-- , 'gzipCheckMime' = myMimeCheckFunction+-- , 'gzipSizeThreshold' = 860+-- }+-- @+ data GzipSettings = GzipSettings- { gzipFiles :: GzipFiles+ { -- | Gzip behavior for files+ --+ -- Only applies to 'ResponseFile' ('responseFile') responses.+ -- So any streamed data will be compressed based solely on the+ -- response headers having the right \"Content-Type\" and+ -- \"Content-Length\". (which are checked with 'gzipCheckMime'+ -- and 'gzipSizeThreshold', respectively)+ gzipFiles :: GzipFiles+ -- | Decide which files to compress based on MIME type+ --+ -- The 'S.ByteString' is the value of the \"Content-Type\" response+ -- header and will default to 'False' if the header is missing.+ --+ -- E.g. if you'd only want to compress @json@ data, you might+ -- define your own function as follows:+ --+ -- > myCheckMime mime = mime == "application/json" , gzipCheckMime :: S.ByteString -> Bool+ -- | Skip compression when the size of the response body is+ -- below this amount of bytes (default: 860.)+ --+ -- /Setting this option to less than 150 will actually increase/+ -- /the size of outgoing data if its original size is less than 150 bytes/.+ --+ -- This will only skip compression if the response includes a+ -- \"Content-Length\" header /AND/ the length is less than this+ -- threshold.+ , gzipSizeThreshold :: Integer } -- | Gzip behavior for files. data GzipFiles- = GzipIgnore -- ^ Do not compress file responses.- | GzipCompress -- ^ Compress files. Note that this may counteract- -- zero-copy response optimizations on some- -- platforms.- | GzipCacheFolder FilePath -- ^ Compress files, caching them in- -- some directory.- | GzipPreCompressed GzipFiles -- ^ If we use compression then try to use the filename with ".gz"- -- appended to it, if the file is missing then try next action- --- -- @since 3.0.17+ = -- | Do not compress file ('ResponseFile') responses.+ -- Any 'ResponseBuilder' or 'ResponseStream' might still be compressed.+ GzipIgnore+ | -- | Compress files. Note that this may counteract+ -- zero-copy response optimizations on some platforms.+ GzipCompress+ | -- | Compress files, caching the compressed version in the given directory.+ GzipCacheFolder FilePath+ | -- | If we use compression then try to use the filename with \".gz\"+ -- appended to it. If the file is missing then try next action.+ --+ -- @since 3.0.17+ GzipPreCompressed GzipFiles deriving (Show, Eq, Read) --- | Use default MIME settings; /do not/ compress files.+-- $miscellaneous+--+-- 'def' is re-exported for convenience sake, and 'defaultCheckMime'+-- is exported in case anyone wants to use it in defining their own+-- 'gzipCheckMime' function.++-- | Use default MIME settings; /do not/ compress files; skip+-- compression on data smaller than 860 bytes. instance Default GzipSettings where- def = GzipSettings GzipIgnore defaultCheckMime+ def = GzipSettings GzipIgnore defaultCheckMime minimumLength -- | MIME types that will be compressed by default: -- @text/@ @*@, @application/json@, @application/javascript@,@@ -92,14 +204,6 @@ ] -- | Use gzip to compress the body of the response.------ Analyzes the \"Accept-Encoding\" header from the client to determine--- if gzip is supported.------ File responses will be compressed according to the 'GzipFiles' setting.------ Will only be applied based on the 'gzipCheckMime' setting. For default--- behavior, see 'defaultCheckMime'. gzip :: GzipSettings -> Middleware gzip set app req sendResponse' | skipCompress = app req sendResponse@@ -126,8 +230,22 @@ where isCorrectMime = maybe False (gzipCheckMime set) . lookup hContentType- sendResponse = sendResponse' . mapResponseHeaders (vary:)- vary = (hVary, "Accept-Encoding")+ sendResponse = sendResponse' . mapResponseHeaders mAddVary+ acceptEncoding = "Accept-Encoding"+ acceptEncodingLC = "accept-encoding"+ -- Instead of just adding a header willy-nilly, we check if+ -- "Vary" is already present, and add to it if not already included.+ mAddVary [] = [(hVary, acceptEncoding)]+ mAddVary (h@(nm, val) : hs)+ | nm == hVary =+ let vals = splitCommas val+ lowercase = S.map W8.toLower+ -- Field names are case-insensitive, so we lowercase to match+ hasAccEnc = acceptEncodingLC `elem` fmap lowercase vals+ newH | hasAccEnc = h+ | otherwise = (hVary, acceptEncoding <> ", " <> val)+ in newH : hs+ | otherwise = h : mAddVary hs -- Can we skip from just looking at the 'Request'? skipCompress =@@ -135,23 +253,29 @@ where reqHdrs = requestHeaders req acceptsGZipEncoding =- maybe False (elem "gzip" . splitCommas) $ hAcceptEncoding `lookup` reqHdrs+ maybe False (any isGzip . parseQValueList) $ hAcceptEncoding `lookup` reqHdrs+ isGzip (bs, q) =+ -- We skip if 'q' = Nothing, because it is malformed,+ -- or if it is 0, because that is an explicit "DO NOT USE GZIP"+ bs == "gzip" && maybe False (/= 0) q isMSIE6 = maybe False ("MSIE 6" `S.isInfixOf`) $ hUserAgent `lookup` reqHdrs -- Can we skip just by looking at the current 'Response'? checkCompress :: (Response -> IO ResponseReceived) -> Response -> IO ResponseReceived- checkCompress f res =- if isEncodedAlready || notBigEnough+ checkCompress continue res =+ if isEncodedAlready || isPartial || tooSmall then sendResponse res- else f res+ else continue res where resHdrs = responseHeaders res+ -- Partial content should NEVER be compressed.+ isPartial = statusCode (responseStatus res) == 206 isEncodedAlready = isJust $ hContentEncoding `lookup` resHdrs- notBigEnough =+ tooSmall = maybe False -- This could be a streaming case- (< minimumLength)+ (< gzipSizeThreshold set) $ contentLength resHdrs -- For a small enough response, gzipping will actually increase the size@@ -189,11 +313,23 @@ Z.feedDeflate deflate bs >>= goPopper loop goPopper $ Z.finishDeflate deflate- either onErr (const onSucc) (x :: Either SomeException ()) -- FIXME bad! don't catch all exceptions like that!+ either onErr (const onSucc) (x :: Either SomeException ()) where onSucc = sendResponse $ responseFile s (fixHeaders hs) tmpfile Nothing+ reportError err =+ IO.hPutStrLn IO.stderr $+ "Network.Wai.Middleware.Gzip: compression failed: " <> err+ onErr e+ -- Catching IOExceptions for file system / hardware oopsies+ | Just ioe <- fromException e = do+ reportError $ show (ioe :: IOException)+ sendResponse $ responseFile s hs file Nothing+ -- Catching ZlibExceptions for compression oopsies+ | Just zlibe <- fromException e = do+ reportError $ show (zlibe :: Z.ZlibException)+ sendResponse $ responseFile s hs file Nothing+ | otherwise = throwIO e - onErr _ = sendResponse $ responseFile s hs file Nothing -- FIXME log the error message tmpfile = cache ++ '/' : map safe file safe c@@ -243,9 +379,6 @@ -- different length after gzip compression. fixHeaders :: [Header] -> [Header] fixHeaders =- ((hContentEncoding, "gzip") :) . filter notLength+ replaceHeader hContentEncoding "gzip" . filter notLength where notLength (x, _) = x /= hContentLength--splitCommas :: S.ByteString -> [S.ByteString]-splitCommas = map (S.dropWhile (== _space)) . S.split _comma
Network/Wai/Middleware/Jsonp.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp
Network/Wai/Test.hs view
@@ -5,6 +5,7 @@ ( -- * Session Session , runSession+ , withSession -- * Client Cookies , ClientCookies , getClientCookies@@ -92,6 +93,10 @@ -- | See also: 'runSessionWith'. runSession :: Session a -> Application -> IO a runSession session app = ST.evalStateT (runReaderT session app) initState++-- | Synonym for 'flip runSession'+withSession :: Application -> Session a -> IO a+withSession = flip runSession data SRequest = SRequest { simpleRequest :: Request
test/WaiExtraSpec.hs view
@@ -19,15 +19,28 @@ import qualified Data.Text as TS import qualified Data.Text.Encoding as TE import qualified Data.Text.Lazy as T-import Network.HTTP.Types (status200)+import Network.HTTP.Types (+ Header,+ RequestHeaders,+ ResponseHeaders,+ hContentEncoding,+ hContentLength,+ hContentType,+ partialContent206,+ status200,+ )+import Network.HTTP.Types.Header (hAcceptEncoding, hVary) import Network.Wai+import System.Directory (listDirectory)+import System.IO.Temp (withSystemTempDirectory) import System.Log.FastLogger (fromLogStr)-import Test.HUnit (Assertion, (@?=))+import Test.HUnit (Assertion, assertBool, assertEqual, (@?=)) import Test.Hspec +import Network.Wai.Header (parseQValueList) import Network.Wai.Middleware.AcceptOverride (acceptOverride) import Network.Wai.Middleware.Autohead (autohead)-import Network.Wai.Middleware.Gzip (def, defaultCheckMime, gzip)+import Network.Wai.Middleware.Gzip (GzipFiles (..), GzipSettings (..), def, defaultCheckMime, gzip) import Network.Wai.Middleware.Jsonp (jsonp) import Network.Wai.Middleware.MethodOverride (methodOverride) import Network.Wai.Middleware.MethodOverridePost (methodOverridePost)@@ -51,10 +64,15 @@ , it "takeLine" caseTakeLine -} it "jsonp" caseJsonp- it "gzip" caseGzip- it "gzip not for MSIE" caseGzipMSIE- it "gzip bypass when precompressed" caseGzipBypassPre- it "defaultCheckMime" caseDefaultCheckMime+ describe "gzip" $ do+ it "gzip" caseGzip+ it "more gzip" caseGzip2+ it "gzip not on partial content" caseGzipPartial+ it "gzip removes length header" caseGzipLength+ it "gzip not for MSIE" caseGzipMSIE+ it "gzip bypass when precompressed" caseGzipBypassPre+ it "defaultCheckMime" caseDefaultCheckMime+ it "gzip checking of files" caseGzipFiles it "vhost" caseVhost it "autohead" caseAutohead it "method override" caseMethodOverride@@ -65,6 +83,7 @@ it "stream LBS" caseStreamLBS it "can modify POST params before logging" caseModifyPostParamsInLogs it "can filter requests in logs" caseFilterRequestsInLogs+ it "can parse Q values" caseQValues toRequest :: S8.ByteString -> S8.ByteString -> SRequest toRequest ctype content = SRequest defaultRequest@@ -133,7 +152,7 @@ "{\"foo\":\"bar\"}" caseJsonp :: Assertion-caseJsonp = flip runSession jsonpApp $ do+caseJsonp = withSession jsonpApp $ do sres1 <- request defaultRequest { queryString = [("callback", Just "test")] , requestHeaders = [("Accept", "text/javascript")]@@ -156,34 +175,200 @@ assertBody "{\"foo\":\"bar\"}" sres3 gzipApp :: Application-gzipApp = gzip def $ \_ f -> f $ responseLBS status200- [("Content-Type", "text/plain")]- "test"+gzipApp = gzipApp' id --- Lie a little and don't compress the body. This way we test--- that the compression is skipped based on the presence of--- the Content-Encoding header.-gzipPrecompressedApp :: Application-gzipPrecompressedApp = gzip def $ \_ f -> f $ responseLBS status200- [("Content-Type", "text/plain"), ("Content-Encoding", "gzip")]- "test"+gzipApp' :: (Response -> Response) -> Application+gzipApp' changeRes =+ gzip def $ \_ f -> f . changeRes $ responseLBS status200+ [("Content-Type", "text/plain")]+ "test" +gzipAppWithHeaders :: ResponseHeaders -> Application+gzipAppWithHeaders hdrs = gzipApp' $ mapResponseHeaders $ (hdrs ++)++gzipFileApp :: GzipSettings -> Application+gzipFileApp = flip gzipFileApp' id++gzipJSONFile, gzipNoPreCompressFile :: FilePath+gzipJSONFile = "test/json"+gzipNoPreCompressFile = "test/noprecompress"++gzipJSONBody, gzipNocompressBody :: L.ByteString+#if WINDOWS+gzipJSONBody = "{\"data\":\"this is some data\"}\r\n"+gzipNocompressBody = "noprecompress\r\n"+#else+gzipJSONBody = "{\"data\":\"this is some data\"}\n"+gzipNocompressBody = "noprecompress\n"+#endif++-- | Use 'changeRes' to make r+gzipFileApp' :: GzipSettings -> (Response -> Response) -> Application+gzipFileApp' set changeRes =+ gzip set $ \_ f -> f . changeRes $+ responseFile status200 [(hContentType, "application/json")] gzipJSONFile Nothing++acceptGzip :: Header+acceptGzip = (hAcceptEncoding, "gzip")++doesEncodeGzip :: RequestHeaders -> Session SResponse+doesEncodeGzip = doesEncodeGzip' "test"++doesEncodeGzipJSON :: RequestHeaders -> Session SResponse+doesEncodeGzipJSON = doesEncodeGzip' gzipJSONBody++doesEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse+doesEncodeGzipNoPreCompress = doesEncodeGzip' gzipNocompressBody++doesEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse+doesEncodeGzip' body hdrs = do+ sres <- request defaultRequest+ { requestHeaders = hdrs+ }+ assertHeader hContentEncoding "gzip" sres+ assertHeader hVary "Accept-Encoding" sres+ liftIO $ decompress (simpleBody sres) @?= body+ pure sres++doesNotEncodeGzip :: RequestHeaders -> Session SResponse+doesNotEncodeGzip = doesNotEncodeGzip' "test"++doesNotEncodeGzipJSON :: RequestHeaders -> Session SResponse+doesNotEncodeGzipJSON = doesNotEncodeGzip' gzipJSONBody++doesNotEncodeGzipNoPreCompress :: RequestHeaders -> Session SResponse+doesNotEncodeGzipNoPreCompress = doesNotEncodeGzip' gzipNocompressBody++doesNotEncodeGzip' :: L.ByteString -> RequestHeaders -> Session SResponse+doesNotEncodeGzip' body hdrs = do+ sres <- request defaultRequest+ { requestHeaders = hdrs+ }+ assertNoHeader hContentEncoding sres+ assertHeader hVary "Accept-Encoding" sres+ assertBody body sres+ pure sres+ caseGzip :: Assertion-caseGzip = flip runSession gzipApp $ do- sres1 <- request defaultRequest- { requestHeaders = [("Accept-Encoding", "gzip")]- }- assertHeader "Content-Encoding" "gzip" sres1- assertHeader "Vary" "Accept-Encoding" sres1- liftIO $ decompress (simpleBody sres1) @?= "test"+caseGzip = do+ withSession gzipApp $ do+ _ <- doesEncodeGzip [acceptGzip]+ _ <- doesNotEncodeGzip []+ _ <- doesEncodeGzip [(hAcceptEncoding, "compress , gzip ; q=0.8")]+ pure () - sres2 <- request defaultRequest- { requestHeaders = []- }- assertNoHeader "Content-Encoding" sres2- assertHeader "Vary" "Accept-Encoding" sres2- assertBody "test" sres2+ withSession (gzipAppWithHeaders [(hContentLength, "200")]) $ do+ sres4 <- doesNotEncodeGzip [acceptGzip]+ assertHeader hContentLength "200" sres4 +caseGzipLength :: Assertion+caseGzipLength = do+ withSession (gzipAppWithHeaders [(hContentLength, "4000")]) $ do+ sres <- doesEncodeGzip [acceptGzip]+ assertNoHeader hContentLength sres++caseGzipPartial :: Assertion+caseGzipPartial =+ withSession partialApp $ do+ _ <- doesNotEncodeGzip [acceptGzip]+ pure ()+ where+ partialApp = gzipApp' $ mapResponseStatus $ const partialContent206++-- | Checking that it doesn't compress when already compressed AND+-- doesn't replace already set "Vary" header.+caseGzip2 :: Assertion+caseGzip2 =+ withSession gzipVariantApp $ do+ sres1 <- request defaultRequest+ { requestHeaders = [(hAcceptEncoding, "compress, gzip")] }+ assertHeader hContentEncoding "compress" sres1+ assertHeader hVary "Accept-Encoding, foobar" sres1+ where+ gzipVariantApp = gzipAppWithHeaders+ [ ("Content-Encoding", "compress")+ , ("Vary", "foobar")+ ]++-- | Testing of the GzipSettings's 'GzipFiles' setting+-- with 'ResponseFile' responses.+caseGzipFiles :: Assertion+caseGzipFiles = do+ -- Default GzipSettings ignore compressing files+ withSession (gzipFileApp def) $ do+ _ <- doesNotEncodeGzipJSON [acceptGzip]+ _ <- doesNotEncodeGzipJSON []+ pure ()++ -- Just compresses the file+ withSession (gzipFileApp def{gzipFiles = GzipCompress}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ _ <- doesNotEncodeGzipJSON []+ pure ()++ -- Checks for a "filename.gz" file in the same folder+ withSession (gzipFileApp def{gzipFiles = GzipPreCompressed GzipIgnore}) $ do+ sres <- request defaultRequest+ { requestHeaders = [acceptGzip] }+ assertHeader hContentEncoding "gzip" sres+ assertHeader hVary "Accept-Encoding" sres+ -- json.gz has body "test\n"+ assertBody+#if WINDOWS+ "test\r\n"+#else+ "test\n"+#endif+ sres++ doesNotEncodeGzipJSON [] >> pure ()++ -- If no "filename.gz" file is in the same folder, just ignore+ withSession (noPreCompressApp $ GzipPreCompressed GzipIgnore) $ do+ _ <- doesNotEncodeGzipNoPreCompress [acceptGzip]+ _ <- doesNotEncodeGzipNoPreCompress []+ pure ()++ -- If no "filename.gz" file is in the same folder, just compress+ withSession (noPreCompressApp $ GzipPreCompressed GzipCompress) $ do+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ _ <- doesNotEncodeGzipNoPreCompress []+ pure ()++ -- Using a caching directory+ withSystemTempDirectory "gziptest" $ \path -> do+ let checkTempDir n s = do+ fs <- listDirectory path+ assertBool s $ length fs == n+ checkTempDir 0 "temp directory should be empty"+ -- Respond with "test/json" file+ withSession (gzipFileApp def{gzipFiles = GzipCacheFolder path}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 1 "should have one file"+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 1 "should still have only one file"+ _ <- doesNotEncodeGzipJSON []+ liftIO $ checkTempDir 1 "should not have done anything"++ -- Respond with "test/noprecompress" file+ withSession (noPreCompressApp $ GzipCacheFolder path) $ do+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ liftIO $ checkTempDir 2 "should now have 2 files"+ _ <- doesEncodeGzipNoPreCompress [acceptGzip]+ liftIO $ checkTempDir 2 "should still only have 2 files"+ _ <- doesNotEncodeGzipNoPreCompress []+ liftIO $ checkTempDir 2 "again should not have done anything"++ -- try "test/json" again, just to make sure it isn't a weird Session bug+ withSession (gzipFileApp def{gzipFiles = GzipCacheFolder path}) $ do+ _ <- doesEncodeGzipJSON [acceptGzip]+ liftIO $ checkTempDir 2 "just to make sure it isn't a fluke"++ where+ noPreCompressApp set = gzipFileApp'+ def{gzipFiles = set}+ $ const $ responseFile status200 [(hContentType, "text/plain")] gzipNoPreCompressFile Nothing+ caseDefaultCheckMime :: Assertion caseDefaultCheckMime = do let go x y = (x, defaultCheckMime x) `shouldBe` (x, y)@@ -195,25 +380,23 @@ go "application/json; charset=utf-8" True caseGzipMSIE :: Assertion-caseGzipMSIE = flip runSession gzipApp $ do- sres1 <- request defaultRequest- { requestHeaders =- [ ("Accept-Encoding", "gzip")- , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")- ]- }- assertNoHeader "Content-Encoding" sres1+caseGzipMSIE = withSession gzipApp $ do+ sres1 <- doesNotEncodeGzip+ [ acceptGzip+ , ("User-Agent", "Mozilla/4.0 (Windows; MSIE 6.0; Windows NT 6.0)")+ ] assertHeader "Vary" "Accept-Encoding" sres1- liftIO $ simpleBody sres1 @?= "test" caseGzipBypassPre :: Assertion-caseGzipBypassPre = flip runSession gzipPrecompressedApp $ do- sres1 <- request defaultRequest- { requestHeaders = [("Accept-Encoding", "gzip")]- }- assertHeader "Content-Encoding" "gzip" sres1- assertHeader "Vary" "Accept-Encoding" sres1- assertBody "test" sres1 -- the body is not actually compressed+caseGzipBypassPre =+ -- Lie a little and don't compress the body. This way we test+ -- that the compression is skipped based on the presence of+ -- the Content-Encoding header.+ withSession (gzipAppWithHeaders [(hContentEncoding, "gzip")]) $ do+ sres1 <- request defaultRequest{ requestHeaders = [acceptGzip] }+ assertHeader "Content-Encoding" "gzip" sres1+ assertHeader "Vary" "Accept-Encoding" sres1+ assertBody "test" sres1 -- the body is not actually compressed vhostApp1, vhostApp2, vhostApp :: Application vhostApp1 _ f = f $ responseLBS status200 [] "app1"@@ -224,7 +407,7 @@ vhostApp2 caseVhost :: Assertion-caseVhost = flip runSession vhostApp $ do+caseVhost = withSession vhostApp $ do sres1 <- request defaultRequest { requestHeaders = [("Host", "foo.com")] }@@ -240,7 +423,7 @@ [("Foo", "Bar")] "body" caseAutohead :: Assertion-caseAutohead = flip runSession autoheadApp $ do+caseAutohead = withSession autoheadApp $ do sres1 <- request defaultRequest { requestMethod = "GET" }@@ -258,7 +441,7 @@ [("Method", requestMethod req)] "" caseMethodOverride :: Assertion-caseMethodOverride = flip runSession moApp $ do+caseMethodOverride = withSession moApp $ do sres1 <- request defaultRequest { requestMethod = "GET" , queryString = []@@ -281,7 +464,7 @@ mopApp = methodOverridePost $ \req f -> f $ responseLBS status200 [("Method", requestMethod req)] "" caseMethodOverridePost :: Assertion-caseMethodOverridePost = flip runSession mopApp $ do+caseMethodOverridePost = withSession mopApp $ do -- Get Request are unmodified sres1 <- let r = toRequest "application/x-www-form-urlencoded" "_method=PUT&foo=bar&baz=bin"@@ -308,7 +491,7 @@ [("Accept", fromMaybe "" $ lookup "Accept" $ requestHeaders req)] "" caseAcceptOverride :: Assertion-caseAcceptOverride = flip runSession aoApp $ do+caseAcceptOverride = withSession aoApp $ do sres1 <- request defaultRequest { queryString = [] , requestHeaders = [("Accept", "foo")]@@ -329,13 +512,13 @@ caseDebugRequestBody :: Assertion caseDebugRequestBody = do- flip runSession (debugApp postOutput) $ do+ withSession (debugApp postOutput) $ do let req = toRequest "application/x-www-form-urlencoded" "foo=bar&baz=bin" res <- srequest req assertStatus 200 res let qs = "?foo=bar&baz=bin"- flip runSession (debugApp $ getOutput params) $ do+ withSession (debugApp $ getOutput params) $ do assertStatus 200 =<< request defaultRequest { requestMethod = "GET" , queryString = map (\(k,v) -> (k, Just v)) params@@ -437,7 +620,7 @@ streamFileApp = streamFile $ \_ f -> f $ responseFile status200 [] testFile Nothing caseStreamFile :: Assertion-caseStreamFile = flip runSession streamFileApp $ do+caseStreamFile = withSession streamFileApp $ do sres <- request defaultRequest assertStatus 200 sres assertBodyContains "caseStreamFile" sres@@ -449,7 +632,7 @@ "test" caseStreamLBS :: Assertion-caseStreamLBS = flip runSession streamLBSApp $ do+caseStreamLBS = withSession streamLBSApp $ do sres <- request defaultRequest assertStatus 200 sres assertBody "test" sres@@ -466,7 +649,7 @@ testLogs formatRedacted outputRedacted where testLogs :: OutputFormat -> [(String, String)] -> Assertion- testLogs format output = flip runSession (debugApp format output) $ do+ testLogs format output = withSession (debugApp format output) $ do let req = toRequest "application/x-www-form-urlencoded" "username=some_user&password=dont_show_me" res <- srequest req assertStatus 200 res@@ -504,7 +687,7 @@ testLogs formatFiltered pathHidden False where testLogs :: OutputFormat -> S8.ByteString -> Bool -> Assertion- testLogs format rpath haslogs = flip runSession (debugApp format rpath haslogs) $ do+ testLogs format rpath haslogs = withSession (debugApp format rpath haslogs) $ do let req = flip SRequest "" $ setPath defaultRequest rpath res <- srequest req assertStatus 200 res@@ -527,3 +710,28 @@ actual `shouldBe` "" return res++-- | Unit test to make sure 'parseQValueList' works correctly+caseQValues :: Assertion+caseQValues = do+ let encodings = mconcat+ -- This has weird white space on purpose, because this+ -- should be acceptable according to RFC 7231+ [ "deflate, compress; q=0.813 ,gzip ; q=0.9, * ;q=0, "+ , "notq;charset=bar, "+ , "noq;q=, "+ , "toolong;q=0.0023, "+ , "toohigh ;q=1.1"+ ]+ qList = parseQValueList encodings+ expected =+ [ ("deflate", Just 1000)+ , ("compress", Just 813)+ , ("gzip", Just 900)+ , ("*", Just 0)+ , ("notq", Nothing)+ , ("noq", Nothing)+ , ("toolong", Nothing)+ , ("toohigh", Nothing)+ ]+ assertEqual "invalid Q values" expected qList
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 3.1.10+Version: 3.1.11 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality:@@ -219,8 +219,13 @@ , http2 , aeson , iproute+ , temporary+ , directory ghc-options: -Wall default-language: Haskell2010++ if os(windows)+ cpp-options: -DWINDOWS source-repository head type: git