diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,8 @@ +## 3.0.12 + +* Add Network.Wai.Header.contentLength to read the Content-Length header of a response +* The gzip middleware no longer zips responses smaller than 860 bytes + ## 3.0.11 * Add constructor for more detailed custom output formats for RequestLogger diff --git a/Network/Wai/Header.hs b/Network/Wai/Header.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Header.hs @@ -0,0 +1,18 @@ +-- | Some helpers for dealing with WAI 'Header's. + +module Network.Wai.Header + ( contentLength + ) where + +import qualified Data.ByteString.Char8 as S8 +import Network.HTTP.Types as H + +-- | More useful for a response. A Wai Request already has a requestBodyLength +contentLength :: [(HeaderName, S8.ByteString)] -> Maybe Integer +contentLength hdrs = lookup H.hContentLength hdrs >>= readInt + +readInt :: S8.ByteString -> Maybe Integer +readInt bs = + case S8.readInteger bs of + Just (i, "") -> Just i + _ -> Nothing 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 @@ -33,6 +33,7 @@ import Blaze.ByteString.Builder (fromByteString) import Control.Exception (try, SomeException) import qualified Data.Set as Set +import Network.Wai.Header import Network.Wai.Internal import qualified Data.Streaming.Blaze as B import qualified Data.Streaming.Zlib as Z @@ -79,7 +80,7 @@ case res of ResponseRaw{} -> sendResponse res ResponseFile{} | gzipFiles set == GzipIgnore -> sendResponse res - _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) + _ -> if "gzip" `elem` enc && not isMSIE6 && not (isEncoded res) && (bigEnough res) then case (res, gzipFiles set) of (ResponseFile s hs file Nothing, GzipCacheFolder cache) -> @@ -95,6 +96,16 @@ ua = fromMaybe "" $ lookup hUserAgent $ requestHeaders env isMSIE6 = "MSIE 6" `S.isInfixOf` ua isEncoded res = isJust $ lookup hContentEncoding $ responseHeaders res + + bigEnough rsp = case contentLength (responseHeaders rsp) of + Nothing -> True -- This could be a streaming case + Just len -> len >= minimumLength + + -- For a small enough response, gzipping will actually increase the size + -- Potentially for anything less than 860 bytes gzipping could be a net loss + -- The actual number is application specific though and may need to be adjusted + -- http://webmasters.stackexchange.com/questions/31750/what-is-recommended-minimum-object-size-for-gzip-performance-benefits + minimumLength = 860 compressFile :: Status -> [Header] -> FilePath -> FilePath -> (Response -> IO a) -> IO a compressFile s hs file cache sendResponse = do diff --git a/Network/Wai/Middleware/RequestLogger.hs b/Network/Wai/Middleware/RequestLogger.hs --- a/Network/Wai/Middleware/RequestLogger.hs +++ b/Network/Wai/Middleware/RequestLogger.hs @@ -24,7 +24,11 @@ import qualified Data.ByteString as BS import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO) -import Network.Wai (Request(..), Middleware, responseStatus, Response, responseHeaders) +import Network.Wai + ( Request(..), requestBodyLength, RequestBodyLength(..) + , Middleware + , Response, responseStatus, responseHeaders + ) import System.Log.FastLogger import Network.HTTP.Types as H import Data.Maybe (fromMaybe) @@ -41,6 +45,7 @@ import Data.Default.Class (Default (def)) import Network.Wai.Logger import Network.Wai.Middleware.RequestLogger.Internal +import Network.Wai.Header (contentLength) import Data.Text.Encoding (decodeUtf8') data OutputFormat = Apache IPAddrSource @@ -106,11 +111,7 @@ apacheMiddleware :: ApacheLoggerActions -> Middleware apacheMiddleware ala app req sendResponse = app req $ \res -> do - let msize = lookup H.hContentLength (responseHeaders res) >>= readInt' - readInt' bs = - case S8.readInteger bs of - Just (i, "") -> Just i - _ -> Nothing + let msize = contentLength (responseHeaders res) apacheLogger ala req (responseStatus res) msize sendResponse res @@ -246,11 +247,12 @@ -> (BS.ByteString -> BS.ByteString -> [BS.ByteString]) -> Middleware detailedMiddleware' cb ansiColor ansiMethod ansiStatusCode app req sendResponse = do - let mlen = lookup H.hContentLength (requestHeaders req) >>= readInt (req', body) <- - case mlen of + -- second tuple item should not be necessary, but a test runner might mess it up + case (requestBodyLength req, contentLength (requestHeaders req)) of -- log the request body if it is small - Just len | len <= 2048 -> getRequestBody req + (KnownLength len, _) | len <= 2048 -> getRequestBody req + (_, Just len) | len <= 2048 -> getRequestBody req _ -> return (req, []) let reqbodylog _ = if null body then [""] else ansiColor White " Request Body: " <> body <> ["\n"] @@ -308,10 +310,7 @@ collectPostParams (postParams, files) = postParams ++ map (\(k,v) -> (k, "FILE: " <> fileName v)) files - readInt bs = - case reads $ unpack bs of - (i, _):_ -> Just (i :: Int) - [] -> Nothing + statusBS :: Response -> BS.ByteString statusBS = pack . show . statusCode . responseStatus diff --git a/test/WaiExtraSpec.hs b/test/WaiExtraSpec.hs --- a/test/WaiExtraSpec.hs +++ b/test/WaiExtraSpec.hs @@ -341,10 +341,8 @@ } where params = [("foo", "bar"), ("baz", "bin")] - -- FIXME change back once we include post parameter output in logging - -- postOutput = T.pack $ "POST \nAccept: \n Params: " ++ (show params) -- the time cannot be known, so match around it - postOutput = ("POST /\n Accept: \n Status: 200 OK 0", "s\n") + postOutput = (T.pack $ "POST /\n Params: " ++ (show params), "s\n") getOutput params' = ("GET /location\n Params: " <> T.pack (show params') <> "\n Accept: \n Status: 200 OK 0", "s\n") debugApp (beginning, ending) req send = do 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.0.11.1 +Version: 3.0.12 Synopsis: Provides some basic WAI handlers and middleware. description: Provides basic WAI handler and middleware functionality: @@ -123,6 +123,7 @@ Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Handler.SCGI + Network.Wai.Header Network.Wai.Middleware.AcceptOverride Network.Wai.Middleware.AddHeaders Network.Wai.Middleware.Approot