diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Network/Wai/Handler/CGI.hs b/Network/Wai/Handler/CGI.hs --- a/Network/Wai/Handler/CGI.hs +++ b/Network/Wai/Handler/CGI.hs @@ -33,6 +33,7 @@ import Network.Wai.Internal import System.IO (Handle) import qualified System.IO + #if WINDOWS import System.Environment (getEnvironment) #else diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs --- a/Network/Wai/Header.hs +++ b/Network/Wai/Header.hs @@ -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 diff --git a/Network/Wai/Middleware/AcceptOverride.hs b/Network/Wai/Middleware/AcceptOverride.hs --- a/Network/Wai/Middleware/AcceptOverride.hs +++ b/Network/Wai/Middleware/AcceptOverride.hs @@ -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 + } diff --git a/Network/Wai/Middleware/Gzip.hs b/Network/Wai/Middleware/Gzip.hs --- a/Network/Wai/Middleware/Gzip.hs +++ b/Network/Wai/Middleware/Gzip.hs @@ -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 diff --git a/Network/Wai/Middleware/Jsonp.hs b/Network/Wai/Middleware/Jsonp.hs --- a/Network/Wai/Middleware/Jsonp.hs +++ b/Network/Wai/Middleware/Jsonp.hs @@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-} -{-# LANGUAGE RankNTypes #-} --------------------------------------------------------- -- | -- Module : Network.Wai.Middleware.Jsonp diff --git a/Network/Wai/Test.hs b/Network/Wai/Test.hs --- a/Network/Wai/Test.hs +++ b/Network/Wai/Test.hs @@ -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 diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -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 diff --git a/wai-extra.cabal b/wai-extra.cabal --- a/wai-extra.cabal +++ b/wai-extra.cabal @@ -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