warp 3.4.14 → 3.4.15
raw patch · 21 files changed
+620/−358 lines, 21 filesdep +http-semanticsdep −arraydep ~asyncdep ~bsb-http-chunkeddep ~http-typesPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: http-semantics
Dependencies removed: array
Dependency ranges changed: async, bsb-http-chunked, http-types, http2, iproute, simple-sendfile, wai
API changes (from Hackage documentation)
- Network.Wai.Handler.Warp.Internal: requestMaxIndex :: Int
+ Network.Wai.Handler.Warp.Internal: defaultIndexRequestHeader :: IndexedRequestHeader
- Network.Wai.Handler.Warp.Internal: recvRequest :: FirstRequest -> Settings -> Connection -> InternalInfo -> Handle -> SockAddr -> Source -> Transport -> IO (Request, Maybe (IORef Int), IndexedHeader, IO ByteString)
+ Network.Wai.Handler.Warp.Internal: recvRequest :: FirstRequest -> Settings -> Connection -> InternalInfo -> Handle -> SockAddr -> Source -> Transport -> IO (Request, Maybe (IORef Int), IndexedRequestHeader, IO ByteString)
- Network.Wai.Handler.Warp.Internal: sendResponse :: Settings -> Connection -> InternalInfo -> Handle -> Request -> IndexedHeader -> IO ByteString -> Response -> IO Bool
+ Network.Wai.Handler.Warp.Internal: sendResponse :: Settings -> Connection -> InternalInfo -> Handle -> Request -> IndexedRequestHeader -> IO ByteString -> Response -> IO Bool
- Network.Wai.Handler.Warp.Internal: type IndexedHeader = Array Int Maybe HeaderValue
+ Network.Wai.Handler.Warp.Internal: type IndexedHeader = IndexedRequestHeader
Files
- ChangeLog.md +28/−0
- Network/Wai/Handler/Warp/File.hs +42/−30
- Network/Wai/Handler/Warp/HTTP1.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2.hs +16/−2
- Network/Wai/Handler/Warp/HTTP2/Request.hs +7/−7
- Network/Wai/Handler/Warp/Header.hs +101/−101
- Network/Wai/Handler/Warp/IO.hs +2/−1
- Network/Wai/Handler/Warp/Internal.hs +13/−1
- Network/Wai/Handler/Warp/Request.hs +10/−10
- Network/Wai/Handler/Warp/Response.hs +164/−106
- Network/Wai/Handler/Warp/ResponseHeader.hs +2/−2
- Network/Wai/Handler/Warp/Settings.hs +6/−0
- bench/Parser.hs +16/−0
- test/BufferSpec.hs +38/−0
- test/ConnectionSpec.hs +61/−54
- test/EarlyHintsSpec.hs +72/−0
- test/ResponseSpec.hs +8/−28
- test/RunSpec.hs +3/−3
- test/ServerStateSpec.hs +1/−1
- test/WithApplicationSpec.hs +9/−3
- warp.cabal +20/−8
ChangeLog.md view
@@ -1,5 +1,33 @@ # ChangeLog for warp +## 3.4.15++* Support `103 Early Hints` over HTTP/2: the HTTP/2 handler installs+ `requestSendEarlyHints`, so a WAI application can emit informational responses+ ahead of the final response.+ [#1085](https://github.com/yesodweb/wai/pull/1085).+* Rework keep alive logic for HTTP/1.X so connections won't be automatically+ closed on HEAD requests anymore. Should conform more to spec in general.+ Should also reliably close connection when user created `Response` headers+ contain a `Connection: close` entry (HTTP/1.1).+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Replace multiline header value support with sanitizing newlines and NUL bytes+ with spaces. (as per RFC 9110 section 5.5)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Size for responses in `Maybe Integer` argument of `settingsLogger` now+ consistently and always gives amount of bytes of the sent raw __message body__.+ It will only be `Nothing` when using `responseRaw` (mostly used for websockets)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+ * `responseFile`: no change, gives size of file (part)+ * `responseBuilder/responseLBS`:+ * included the status and header lines, now fixed+ * large `ByteString` chunks would not get counted, now fixed+ * `responseStream`: now counts bytes of body sent+ * `responseRaw`: will always be `Nothing`+* Rework internal indexed headers to records for performance and to remove+ dependencies on `array`.+ [#1092](https://github.com/yesodweb/wai/pull/1092) [#1093](https://github.com/yesodweb/wai/pull/1093)+ ## 3.4.14 * Important bugfix to not deadlock on empty file descriptors if the cause of
Network/Wai/Handler/Warp/File.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.File (@@ -9,17 +8,19 @@ H.parseByteRanges, ) where -import Data.Array ((!)) import qualified Data.ByteString.Char8 as C8 (pack)-import Network.HTTP.Date+import Network.HTTP.Date (HTTPDate, parseHTTPDate) import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types.Header as H-import Network.Wai+import qualified Network.HTTP.Types.Header as Header+import Network.Wai (FilePart (..)) import qualified Network.Wai.Handler.Warp.FileInfoCache as I-import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ ) import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.PackInt+import Network.Wai.Handler.Warp.PackInt (packIntegral) ---------------------------------------------------------------- @@ -34,18 +35,16 @@ :: I.FileInfo -> H.ResponseHeaders -> H.Method- -> IndexedHeader- -- ^ Response- -> IndexedHeader- -- ^ Request+ -> ResponseHeaderPresence+ -> IndexedRequestHeader -> RspFileInfo conditionalRequest finfo hs0 method rspidx reqidx = case condition of nobody@(WithoutBody _) -> nobody WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size- !hs = case rspidx ! fromEnum ResLastModified of- Just _ -> hs1- Nothing -> (H.hLastModified, date) : hs1+ !hs+ | hasLastModified rspidx = hs1+ | otherwise = (H.hLastModified, date) : hs1 in WithBody s hs off len where !mtime = I.fileInfoTime finfo@@ -72,57 +71,67 @@ ---------------------------------------------------------------- -ifModifiedSince :: IndexedHeader -> Maybe HTTPDate-ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate+ifModifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifModifiedSince reqidx = reqidxIfModifiedSince reqidx >>= parseHTTPDate -ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate-ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate+ifUnmodifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifUnmodifiedSince reqidx = reqidxIfUnmodifiedSince reqidx >>= parseHTTPDate -ifRange :: IndexedHeader -> Maybe HTTPDate-ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate+ifRange :: IndexedRequestHeader -> Maybe HTTPDate+ifRange reqidx = reqidxIfRange reqidx >>= parseHTTPDate ---------------------------------------------------------------- -ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo+ifmodified+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Maybe RspFileInfo ifmodified reqidx mtime method = do date <- ifModifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Modified-Since if the request -- contains an If-None-Match header field; [...]"- guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch+ guard . isNothing $ reqidxIfNoneMatch reqidx -- "A recipient MUST ignore the If-Modified-Since header field -- if [...] the request method is neither GET nor HEAD." guard $ method == H.methodGet || method == H.methodHead guard $ date == mtime || date > mtime Just $ WithoutBody H.notModified304 -ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo+ifunmodified+ :: IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo ifunmodified reqidx mtime = do date <- ifUnmodifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Unmodified-Since if the request -- contains an If-Match header field; [...]"- guard . isNothing $ reqidx ! fromEnum ReqIfMatch+ guard . isNothing $ reqidxIfMatch reqidx guard $ date /= mtime && date < mtime Just $ WithoutBody H.preconditionFailed412 -- TODO: Should technically also strongly match on ETags.-ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo+ifrange+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Integer+ -> Maybe RspFileInfo ifrange reqidx mtime method size = do -- According to RFC 9110: -- "When the method is GET and both Range and If-Range are -- present, evaluate the If-Range precondition:" date <- ifRange reqidx- rng <- reqidx ! fromEnum ReqRange+ rng <- reqidxRange reqidx guard $ method == H.methodGet return $ if date == mtime then parseRange rng size else WithBody H.ok200 [] 0 size -unconditional :: IndexedHeader -> Integer -> RspFileInfo+unconditional :: IndexedRequestHeader -> Integer -> RspFileInfo unconditional reqidx =- case reqidx ! fromEnum ReqRange of+ case reqidxRange reqidx of Nothing -> WithBody H.ok200 [] 0 Just rng -> parseRange rng @@ -151,7 +160,7 @@ -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header-contentRangeHeader beg end total = (H.hContentRange, range)+contentRangeHeader beg end total = (Header.hContentRange, range) where range = C8.pack@@ -183,7 +192,10 @@ in ctrng : hs' where !lengthBS = packIntegral len- !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs+ !hs' =+ (Header.hContentLength, lengthBS)+ : (Header.hAcceptRanges, "bytes")+ : filter (\(h, _) -> h /= Header.hContentLength && h /= Header.hAcceptRanges) hs -- | --
Network/Wai/Handler/Warp/HTTP1.hs view
@@ -181,7 +181,7 @@ -> Source -> Request -> Maybe (IORef Int)- -> IndexedHeader+ -> IndexedRequestHeader -> IO ByteString -> IO ReuseConnection processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -29,6 +30,14 @@ import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types +-- Early Hints wiring needs both the http-semantics 'auxSendInformational' field+-- (0.4.1) and the http2 sender support that actually emits it (5.4.2).+#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))++#if HAS_EARLY_HINTS_SUPPORT+import qualified Network.HTTP.Types as H+#endif+ ---------------------------------------------------------------- http2@@ -89,7 +98,12 @@ http2server label settings ii transport addr app h2req0 aux0 response = do tid <- myThreadId labelThread tid (label ++ " http2server " ++ show addr)- req <- toWAIRequest h2req0 aux0+ req0 <- toWAIRequest h2req0 aux0+#if HAS_EARLY_HINTS_SUPPORT+ let req = req0{requestSendEarlyHints = H2.auxSendInformational aux0 (H.mkStatus 103 "Early Hints")}+#else+ let req = req0+#endif ref <- I.newIORef Nothing eResponseReceived <- E.try $ app req $ \rsp -> do (h2rsp, st, hasBody) <- fromResponse settings ii req rsp@@ -150,7 +164,7 @@ handler = throughAsync (return "") -- connClose must not be called here since Run:fork calls it-goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()+goaway :: Connection -> H2.ErrorCode -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream where einfo = H2.encodeInfo id 0
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -85,13 +85,13 @@ Nothing -> case mAuth of Just auth -> (tokenHost, auth) : reqths _ -> reqths- !mPath = getHeaderValue tokenPath reqvt -- SHOULD- !colonMethod = fromJust $ getHeaderValue tokenMethod reqvt -- MUST- !mAuth = getHeaderValue tokenAuthority reqvt -- SHOULD- !mHost = getHeaderValue tokenHost reqvt- !mRange = getHeaderValue tokenRange reqvt- !mReferer = getHeaderValue tokenReferer reqvt- !mUserAgent = getHeaderValue tokenUserAgent reqvt+ !mPath = getFieldValue tokenPath reqvt -- SHOULD+ !colonMethod = fromJust $ getFieldValue tokenMethod reqvt -- MUST+ !mAuth = getFieldValue tokenAuthority reqvt -- SHOULD+ !mHost = getFieldValue tokenHost reqvt+ !mRange = getFieldValue tokenRange reqvt+ !mReferer = getFieldValue tokenReferer reqvt+ !mUserAgent = getFieldValue tokenUserAgent reqvt -- CONNECT request will have ":path" omitted, use ":authority" as unparsed -- path instead so that it will have consistent behavior compare to HTTP 1.0 (unparsedPath, query) = C8.break (== '?') $ fromJust (mPath <|> mAuth)
Network/Wai/Handler/Warp/Header.hs view
@@ -1,122 +1,122 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Handler.Warp.Header where+module Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ indexRequestHeader,+ defaultIndexRequestHeader,+ indexResponseHeader,+) where -import Data.Array-import Data.Array.ST import qualified Data.ByteString as BS import Data.CaseInsensitive (foldedCase)+import Data.List as L (foldl') import Network.HTTP.Types import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- --- | Array for a set of HTTP headers.-type IndexedHeader = Array Int (Maybe HeaderValue)--------------------------------------------------------------------indexRequestHeader :: RequestHeaders -> IndexedHeader-indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex--data RequestHeaderIndex- = ReqContentLength- | ReqTransferEncoding- | ReqExpect- | ReqConnection- | ReqRange- | ReqHost- | ReqIfModifiedSince- | ReqIfUnmodifiedSince- | ReqIfRange- | ReqReferer- | ReqUserAgent- | ReqIfMatch- | ReqIfNoneMatch- deriving (Enum, Bounded)---- | The size for 'IndexedHeader' for HTTP Request.--- From 0 to this corresponds to:------ - \"Content-Length\"--- - \"Transfer-Encoding\"--- - \"Expect\"--- - \"Connection\"--- - \"Range\"--- - \"Host\"--- - \"If-Modified-Since\"--- - \"If-Unmodified-Since\"--- - \"If-Range\"--- - \"Referer\"--- - \"User-Agent\"--- - \"If-Match\"--- - \"If-None-Match\"-requestMaxIndex :: Int-requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)+-- | Strict record of the request headers that Warp inspects,+-- one field per header.+data IndexedRequestHeader = IndexedRequestHeader+ { reqidxContentLength :: Maybe HeaderValue+ , reqidxTransferEncoding :: Maybe HeaderValue+ , reqidxExpect :: Maybe HeaderValue+ , reqidxConnection :: Maybe HeaderValue+ , reqidxRange :: Maybe HeaderValue+ , reqidxHost :: Maybe HeaderValue+ , reqidxIfModifiedSince :: Maybe HeaderValue+ , reqidxIfUnmodifiedSince :: Maybe HeaderValue+ , reqidxIfRange :: Maybe HeaderValue+ , reqidxReferer :: Maybe HeaderValue+ , reqidxUserAgent :: Maybe HeaderValue+ , reqidxIfMatch :: Maybe HeaderValue+ , reqidxIfNoneMatch :: Maybe HeaderValue+ } -requestKeyIndex :: HeaderName -> Int-requestKeyIndex hn = case BS.length bs of- 4 | bs == "host" -> fromEnum ReqHost- 5 | bs == "range" -> fromEnum ReqRange- 6 | bs == "expect" -> fromEnum ReqExpect- 7 | bs == "referer" -> fromEnum ReqReferer- 8- | bs == "if-range" -> fromEnum ReqIfRange- | bs == "if-match" -> fromEnum ReqIfMatch- 10- | bs == "user-agent" -> fromEnum ReqUserAgent- | bs == "connection" -> fromEnum ReqConnection- 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch- 14 | bs == "content-length" -> fromEnum ReqContentLength- 17- | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding- | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince- 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince- _ -> -1+indexRequestHeader :: RequestHeaders -> IndexedRequestHeader+indexRequestHeader = L.foldl' insert defaultIndexRequestHeader where- bs = foldedCase hn+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "host" -> ix{reqidxHost = Just val}+ 5 | bs == "range" -> ix{reqidxRange = Just val}+ 6 | bs == "expect" -> ix{reqidxExpect = Just val}+ 7 | bs == "referer" -> ix{reqidxReferer = Just val}+ 8+ | bs == "if-range" -> ix{reqidxIfRange = Just val}+ | bs == "if-match" -> ix{reqidxIfMatch = Just val}+ 10+ | bs == "user-agent" -> ix{reqidxUserAgent = Just val}+ | bs == "connection" -> ix{reqidxConnection = Just val}+ 13 | bs == "if-none-match" -> ix{reqidxIfNoneMatch = Just val}+ 14 | bs == "content-length" -> ix{reqidxContentLength = Just val}+ 17+ | bs == "transfer-encoding" -> ix{reqidxTransferEncoding = Just val}+ | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val}+ 19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val}+ _ -> ix+ where+ bs = foldedCase key -defaultIndexRequestHeader :: IndexedHeader-defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]]+-- | 'IndexedRequestHeader' with no headers set.+defaultIndexRequestHeader :: IndexedRequestHeader+defaultIndexRequestHeader =+ IndexedRequestHeader+ { reqidxContentLength = Nothing+ , reqidxTransferEncoding = Nothing+ , reqidxExpect = Nothing+ , reqidxConnection = Nothing+ , reqidxRange = Nothing+ , reqidxHost = Nothing+ , reqidxIfModifiedSince = Nothing+ , reqidxIfUnmodifiedSince = Nothing+ , reqidxIfRange = Nothing+ , reqidxReferer = Nothing+ , reqidxUserAgent = Nothing+ , reqidxIfMatch = Nothing+ , reqidxIfNoneMatch = Nothing+ } ---------------------------------------------------------------- -indexResponseHeader :: ResponseHeaders -> IndexedHeader-indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex--data ResponseHeaderIndex- = ResContentLength- | ResServer- | ResDate- | ResLastModified- deriving (Enum, Bounded)---- | The size for 'IndexedHeader' for HTTP Response.-responseMaxIndex :: Int-responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)--responseKeyIndex :: HeaderName -> Int-responseKeyIndex hn = case BS.length bs of- 4 | bs == "date" -> fromEnum ResDate- 6 | bs == "server" -> fromEnum ResServer- 13 | bs == "last-modified" -> fromEnum ResLastModified- 14 | bs == "content-length" -> fromEnum ResContentLength- _ -> -1- where- bs = foldedCase hn------------------------------------------------------------------+-- | Presence of the response headers Warp itself consults.+-- Only these four headers are ever looked up on the response side, and+-- only their presence, never their value, so a flat record of strict+-- 'Bool's built in a single traversal beats a boxed array.+data ResponseHeaderPresence = ResponseHeaderPresence+ { hasContentLength :: Bool+ , hasServer :: Bool+ , hasDate :: Bool+ , hasLastModified :: Bool+ , hasTransferEncoding :: Maybe HeaderValue+ , hasConnection :: Maybe HeaderValue+ } -traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader-traverseHeader hdr maxidx getIndex = runSTArray $ do- arr <- newArray (0, maxidx) Nothing- mapM_ (insert arr) hdr- return arr+indexResponseHeader :: ResponseHeaders -> ResponseHeaderPresence+indexResponseHeader = go emptyResponseHeaderPresence where- insert arr (key, val)- | idx == -1 = return ()- | otherwise = writeArray arr idx (Just val)+ go ix [] = ix+ go ix (tup : rest) = go (insert ix tup) rest+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "date" -> ix{hasDate = True}+ 6 | bs == "server" -> ix{hasServer = True}+ 10 | bs == "connection" -> ix{hasConnection = Just val}+ 13 | bs == "last-modified" -> ix{hasLastModified = True}+ 14 | bs == "content-length" -> ix{hasContentLength = True}+ 17 | bs == "transfer-encoding" -> ix{hasTransferEncoding = Just val}+ _ -> ix where- idx = getIndex key+ bs = foldedCase key++emptyResponseHeaderPresence :: ResponseHeaderPresence+emptyResponseHeaderPresence =+ ResponseHeaderPresence+ { hasContentLength = False+ , hasServer = False+ , hasDate = False+ , hasLastModified = False+ , hasTransferEncoding = Nothing+ , hasConnection = Nothing+ }
Network/Wai/Handler/Warp/IO.hs view
@@ -1,6 +1,7 @@ module Network.Wai.Handler.Warp.IO where import Control.Exception (mask_)+import qualified Data.ByteString as B (length) import Data.ByteString.Builder (Builder) import Data.ByteString.Builder.Extra (Next (Chunk, Done, More), runBuilder) import Data.IORef (IORef, readIORef, writeIORef)@@ -47,4 +48,4 @@ | otherwise -> loop writeBuffer next totalBytesSent Chunk bs next -> do io bs- loop writeBuffer next totalBytesSent+ loop writeBuffer next $ totalBytesSent + fromIntegral (B.length bs)
Network/Wai/Handler/Warp/Internal.hs view
@@ -59,10 +59,20 @@ warpVersion, -- * Data types++ -- |+ --+ -- The internals of 'IndexedHeader' have changed since @3.4.15@, so we+ -- keep exporting it as a type synonym, but it is now a record instead of+ -- an array.+ -- As such there's no more 'requestMaxIndex', but we provide a blank+ -- 'defaultIndexRequestHeader'. InternalInfo (..), HeaderValue, IndexedHeader,- requestMaxIndex,+ -- I assume 'requestMaxIndex' was used in case anyone wanted to create+ -- an empty array, so we replace it with 'defaultIndexRequestHeader'.+ defaultIndexRequestHeader, -- * Time out manager @@ -129,3 +139,5 @@ import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Windows++type IndexedHeader = IndexedRequestHeader
Network/Wai/Handler/Warp/Request.hs view
@@ -15,7 +15,6 @@ ) where import qualified Control.Concurrent as Conc (yield)-import Data.Array ((!)) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI@@ -68,7 +67,7 @@ -> IO ( Request , Maybe (I.IORef Int)- , IndexedHeader+ , IndexedRequestHeader , IO ByteString ) -- ^@@ -81,7 +80,7 @@ (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr- expect = idxhdr ! fromEnum ReqExpect+ expect = reqidxExpect idxhdr handle100Continue = handleExpect conn httpversion expect (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr -- body producing function which will produce '100-continue', if needed@@ -110,10 +109,11 @@ , requestBody = rbody' , vault = vaultValue , requestBodyLength = bodyLength- , requestHeaderHost = idxhdr ! fromEnum ReqHost- , requestHeaderRange = idxhdr ! fromEnum ReqRange- , requestHeaderReferer = idxhdr ! fromEnum ReqReferer- , requestHeaderUserAgent = idxhdr ! fromEnum ReqUserAgent+ , requestHeaderHost = reqidxHost idxhdr+ , requestHeaderRange = reqidxRange idxhdr+ , requestHeaderReferer = reqidxReferer idxhdr+ , requestHeaderUserAgent = reqidxUserAgent idxhdr+ , requestSendEarlyHints = \_ -> pure () } return (req, remainingRef, idxhdr, rbodyFlush) @@ -157,7 +157,7 @@ bodyAndSource :: Source- -> IndexedHeader+ -> IndexedRequestHeader -> IO ( IO ByteString , Maybe (I.IORef Int)@@ -168,12 +168,12 @@ csrc <- mkCSource src return (readCSource csrc, Nothing, ChunkedBody) | otherwise = do- let len = toLength $ idxhdr ! fromEnum ReqContentLength+ let len = toLength $ reqidxContentLength idxhdr bodyLen = KnownLength $ fromIntegral len isrc@(ISource _ remaining) <- mkISource src len return (readISource isrc, Just remaining, bodyLen) where- chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding+ chunked = isChunked $ reqidxTransferEncoding idxhdr toLength :: Maybe HeaderValue -> Int toLength Nothing = 0
Network/Wai/Handler/Warp/Response.hs view
@@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.Response ( sendResponse, sanitizeHeaderValue, -- for testing+ containsRecoverableWhitespace, -- for benchmarking -- Provided here for backwards compatibility. warpVersion, hasBody,@@ -16,25 +17,25 @@ ) where import qualified Control.Exception as E-import Data.Array ((!)) import qualified Data.ByteString as S+import Data.ByteString.Internal (toForeignPtr, unsafeCreate) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.HTTP.Chunked ( chunkedTransferEncoding, chunkedTransferTerminator, )-import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI-import Data.Function (on)-import Data.List (deleteBy)+import Data.Foldable (for_)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Streaming.ByteString.Builder ( newByteStringBuilderRecv, reuseBufferStrategy, )-import Data.Word8 (_cr, _lf, _space, _tab)+import Data.Word8 (_cr, _lf, _nul, _space)+import Foreign (copyBytes, plusForeignPtr, pokeByteOff, withForeignPtr) import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types.Header as H+import qualified Network.HTTP.Types.Header as Header import Network.Wai import Network.Wai.Internal import qualified System.TimeManager as T@@ -111,7 +112,7 @@ -> T.Handle -> Request -- ^ HTTP request.- -> IndexedHeader+ -> IndexedRequestHeader -- ^ Indexed header of HTTP request. -> IO ByteString -- ^ source from client, for raw response@@ -120,17 +121,23 @@ -> IO Bool -- ^ Returing True if the connection is persistent. sendResponse settings conn ii th req reqidxhdr src response = do+ -- Decide connection persistence isShuttingDown <- case settingsServerState settings of Just serverState -> currentShuttingDownState serverState -- Should never be reached! -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure') Nothing -> pure False- let shouldPersist =- not isShuttingDown && if hasBody s then ret else isPersist+ let shouldPersist = not isShuttingDown && ret addConnection hs =- if shouldPersist then hs else (H.hConnection, "close") : hs+ if shouldPersist || responseWantsToClose+ then hs+ else (Header.hConnection, "close") : hs++ -- Adjust headers hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0++ -- Start response logic if hasBody s then do -- The response to HEAD does not have body.@@ -149,20 +156,33 @@ T.tickle th return shouldPersist where+ -- From Settings -- defServer = settingsServerName settings logger = settingsLogger settings maxRspBufSize = settingsMaxBuilderResponseBufferSize settings++ -- From Request --+ method = requestMethod req+ isHead = method == H.methodHead ver = httpVersion req+ isHttp11 = ver == H.http11+ reqSaysPersist = checkReqConnectionHeader isHttp11 reqidxhdr++ -- From Response -- s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0+ hasLength = hasContentLength rspidxhdr+ responseWantsToClose =+ case hasConnection rspidxhdr of+ Nothing -> False+ Just v -> CI.foldCase v == "close"+ isPersist = reqSaysPersist && not responseWantsToClose++ -- Other -- getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr- (isPersist, isChunked0) = infoFromRequest req reqidxhdr- isChunked = not isHead && isChunked0- (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked)- method = requestMethod req- isHead = method == H.methodHead+ needsChunked = isHttp11 && not hasLength rsp = case response of ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th) ResponseBuilder _ _ b@@ -172,43 +192,74 @@ | isHead -> RspNoBody | otherwise -> RspStream fb needsChunked ResponseRaw raw _ -> RspRaw raw src+ -- Should be False if (http10 && not hasLength), regardless of what+ -- the 'Connection' header says. (as long as the response should have a body)+ isKeepAlive =+ isPersist && (isHttp11 || hasLength || isHead || not (hasBody s)) -- Make sure we don't hang on to 'response' (avoid space leak) !ret = case response of+ -- Will get 'Content-Length' header later on using the+ -- 'addContentHeaders(ForFilePart)' functions, so if the+ -- 'Connection' header says we persist, we persist. ResponseFile{} -> isPersist ResponseBuilder{} -> isKeepAlive ResponseStream{} -> isKeepAlive+ -- Is already an ongoing open connection, so if it is done,+ -- the connection should be closed. ResponseRaw{} -> False ---------------------------------------------------------------- +-- | As per RFC 9110 we replace any newlines (\r\n) or \NUL with spaces+-- Values without CR/LF/NUL (the overwhelmingly common case) leave the+-- header list untouched; only a dirty value triggers a rebuild. sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders-sanitizeHeaders = map (sanitize <$>)+sanitizeHeaders hdrs+ -- slow path+ | any (containsRecoverableWhitespace . snd) hdrs = map (sanitize <$>) hdrs+ -- fast path+ | otherwise = hdrs where- sanitize v- | containsNewlines v = sanitizeHeaderValue v -- slow path- | otherwise = v -- fast path+ sanitize bs+ | containsRecoverableWhitespace bs = sanitizeHeaderValue bs+ | otherwise = bs -{-# INLINE containsNewlines #-}-containsNewlines :: ByteString -> Bool-containsNewlines = S.any (\w -> w == _cr || w == _lf)+-- Yes, this is quicker than @S.any (\w -> w == _lf || w == _cr || w == _nul)@+-- because of `bytestring`'s rewrite rules.+containsRecoverableWhitespace :: ByteString -> Bool+containsRecoverableWhitespace bs =+ S.any (_lf ==) bs || S.any (_cr ==) bs || S.any (_nul ==) bs -{-# INLINE sanitizeHeaderValue #-}+{-# INLINE isRecoverableWhitespace #-}+-- | CR, LF and NUL can safely be replaced with a SP according to RFC 9110+-- <https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5-5>+isRecoverableWhitespace :: Word8 -> Bool+isRecoverableWhitespace w = w == _cr || w == _lf || w == _nul+ sanitizeHeaderValue :: ByteString -> ByteString-sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of- [] -> ""- x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)+sanitizeHeaderValue v =+ case S.findIndices isRecoverableWhitespace v of+ -- Nothing to replace+ [] -> v+ -- Found CR, LF or NUL.+ ixs ->+ unsafeCreate len $ \dst -> do+ withForeignPtr fptr $ \src -> do+ -- copy the bytestring+ copyBytes dst src len+ -- and then replace the offending bytes+ for_ ixs $ \ix -> pokeByteOff dst ix _space where- addSpaceIfMissing line = case S.uncons line of- Nothing -> Nothing- Just (first, _)- | first == _space || first == _tab -> Just line- | otherwise -> Just $ _space `S.cons` line+ (fptr', offset, len) = toForeignPtr v+ -- We need to use the offset for backwards compatibility with+ -- "bytestring < 0.11"+ fptr = fptr' `plusForeignPtr` offset ---------------------------------------------------------------- data Rsp = RspNoBody- | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+ | RspFile FilePath (Maybe FilePart) IndexedRequestHeader (IO ()) | RspBuilder Builder Bool | RspStream StreamingBody Bool | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)@@ -222,7 +273,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader -- Response+ -> ResponseHeaderPresence -> Int -- maxBuilderResponseBufferSize -> H.Method -> Rsp@@ -233,12 +284,12 @@ -- Not adding Content-Length. -- User agents treats it as Content-Length: 0. composeHeader ver s hs >>= connSendAll conn- return (Just s, Nothing)+ return (Just s, Just 0) ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ maxRspBufSize _ (RspBuilder body needsChunked) = do- header <- composeHeaderBuilder ver s hs needsChunked+sendRsp conn _ th ver s hs rspidxhdr maxRspBufSize _ (RspBuilder body needsChunked) = do+ (header, hdrLen) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked let hdrBdy | needsChunked = header@@ -252,23 +303,30 @@ writeBufferRef (\bs -> connSendAll conn bs >> T.tickle th) hdrBdy- return (Just s, Just len)+ -- small adjustment to only count the body+ return (Just s, Just $ len - fromIntegral hdrLen) ---------------------------------------------------------------- -sendRsp conn _ th ver s hs _ _ _ (RspStream streamingBody needsChunked) = do- header <- composeHeaderBuilder ver s hs needsChunked+sendRsp conn _ th ver s hs rspidxhdr _ _ (RspStream streamingBody needsChunked) = do+ (header, hdrLen) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked (recv, finish) <- newByteStringBuilderRecv $ reuseBufferStrategy $ toBuilderBuffer $ connWriteBuffer conn+ -- We'll be counting how many bytes we send with this 'IORef'+ sizeCounter <- newIORef (0 :: Integer)+ let sendFragmentAndCount bs = do+ sendFragment conn th bs+ -- add amount of bytes to count+ S.length bs `addToCounter` sizeCounter let send builder = do popper <- recv builder let loop = do bs <- popper unless (S.null bs) $ do- sendFragment conn th bs+ sendFragmentAndCount bs loop loop sendChunk@@ -277,9 +335,16 @@ send header streamingBody sendChunk (sendChunk flush) when needsChunked $ send chunkedTransferTerminator- mbs <- finish- maybe (return ()) (sendFragment conn th) mbs- return (Just s, Nothing) -- fixme: can we tell the actual sent bytes?+ -- final flush+ finish >>= mapM_ sendFragmentAndCount+ finalSize <- readIORef sizeCounter+ -- small adjustment to only count the body+ return (Just s, Just $ finalSize - fromIntegral hdrLen)+ where+ addToCounter :: Int -> IORef Integer -> IO ()+ addToCounter bytes ref =+ atomicModifyIORef' ref $ \old ->+ (old + fromIntegral bytes, ()) ---------------------------------------------------------------- @@ -357,7 +422,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> FilePath@@ -367,6 +432,8 @@ -> IO (Maybe H.Status, Maybe Integer) sendRspFile2XX conn ii th ver s hs rspidxhdr maxRspBufSize method path beg len hook | method == H.methodHead =+ -- FIXME: We could check the size of the file and add a+ -- 'Content-Length' header to give the requester more information? sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody | otherwise = do lheader <- composeHeader ver s hs@@ -382,7 +449,7 @@ -> T.Handle -> H.HttpVersion -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> IO (Maybe H.Status, Maybe Integer)@@ -400,7 +467,7 @@ (RspBuilder body True) where s = H.notFound404- hs = replaceHeader H.hContentType "text/plain; charset=utf-8" hs0+ hs = replaceHeader Header.hContentType "text/plain; charset=utf-8" hs0 body = byteString "File not found" ----------------------------------------------------------------@@ -420,49 +487,23 @@ ---------------------------------------------------------------- -infoFromRequest- :: Request- -> IndexedHeader- -> ( Bool -- isPersist- , Bool -- isChunked- )-infoFromRequest req reqidxhdr = (checkPersist req reqidxhdr, checkChunk req)--checkPersist :: Request -> IndexedHeader -> Bool-checkPersist req reqidxhdr- | ver == H.http11 = checkPersist11 conn- | otherwise = checkPersist10 conn- where- ver = httpVersion req- conn = reqidxhdr ! fromEnum ReqConnection- checkPersist11 (Just x)- | CI.foldCase x == "close" = False- checkPersist11 _ = True- checkPersist10 (Just x)- | CI.foldCase x == "keep-alive" = True- checkPersist10 _ = False--checkChunk :: Request -> Bool-checkChunk req = httpVersion req == H.http11+-- | We infer from the request whether the connection should be persisted.+checkReqConnectionHeader :: Bool -> IndexedRequestHeader -> Bool+checkReqConnectionHeader isHttp11 reqidxhdr =+ case reqidxConnection reqidxhdr of+ -- If no "Connection" header, then default: HTTP/1.1 == persist+ Nothing -> isHttp11+ Just val ->+ let connValue = CI.foldCase val+ in if isHttp11+ then connValue /= "close"+ else connValue == "keep-alive" ---------------------------------------------------------------- --- Used for ResponseBuilder and ResponseSource.--- Don't use this for ResponseFile since this logic does not fit--- for ResponseFile. For instance, isKeepAlive should be True in some cases--- even if the response header does not have Content-Length.+-- | Only checks for status codes, NOT for methods. ----- Content-Length is specified by a reverse proxy.--- Note that CGI does not specify Content-Length.-infoFromResponse :: IndexedHeader -> (Bool, Bool) -> (Bool, Bool)-infoFromResponse rspidxhdr (isPersist, isChunked) = (isKeepAlive, needsChunked)- where- needsChunked = isChunked && not hasLength- isKeepAlive = isPersist && (isChunked || hasLength)- hasLength = isJust $ rspidxhdr ! fromEnum ResContentLength-------------------------------------------------------------------+-- This is by design and some handling relies on HEAD being a separate check. hasBody :: H.Status -> Bool hasBody s = sc /= 204@@ -473,28 +514,41 @@ ---------------------------------------------------------------- -addTransferEncoding :: H.ResponseHeaders -> H.ResponseHeaders-addTransferEncoding hdrs = (H.hTransferEncoding, "chunked") : hdrs+-- | We ASSUME there's no middleware that will chunk the transfer, so+-- we'll add it to the headers if there's no other encoding, or add it+-- to the end in case it is.+-- (e.g. if a 'Middleware' were to add "Transfer-Encoding: gzip")+addTransferEncoding :: ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders+addTransferEncoding rspidxhdr =+ case hasTransferEncoding rspidxhdr of+ Just value -> replaceHeader Header.hTransferEncoding (value <> ", chunked")+ Nothing -> ((Header.hTransferEncoding, "chunked") :) addDate- :: IO D.GMTDate -> IndexedHeader -> H.ResponseHeaders -> IO H.ResponseHeaders-addDate getdate rspidxhdr hdrs = case rspidxhdr ! fromEnum ResDate of- Nothing -> do+ :: IO D.GMTDate -> ResponseHeaderPresence -> H.ResponseHeaders -> IO H.ResponseHeaders+addDate getdate rspidxhdr hdrs+ | hasDate rspidxhdr = return hdrs+ | otherwise = do gmtdate <- getdate- return $ (H.hDate, gmtdate) : hdrs- Just _ -> return hdrs+ return $ (Header.hDate, gmtdate) : hdrs ---------------------------------------------------------------- {-# INLINE addServer #-} addServer- :: HeaderValue -> IndexedHeader -> H.ResponseHeaders -> H.ResponseHeaders-addServer "" rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of- Nothing -> hdrs- _ -> filter ((/= H.hServer) . fst) hdrs-addServer serverName rspidxhdr hdrs = case rspidxhdr ! fromEnum ResServer of- Nothing -> (H.hServer, serverName) : hdrs- _ -> hdrs+ :: HeaderValue -> ResponseHeaderPresence -> H.ResponseHeaders -> H.ResponseHeaders+addServer serverName rspidxhdr hdrs =+ case serverName of+ -- empty string means there shouldn't be a "Server" header+ ""+ | serverPresent -> filter ((/= Header.hServer) . fst) hdrs+ | otherwise -> hdrs+ -- Anything else should set the "Server" header if it isn't already set+ _+ | not serverPresent -> (Header.hServer, serverName) : hdrs+ | otherwise -> hdrs+ where+ serverPresent = hasServer rspidxhdr addAltSvc :: Settings -> H.ResponseHeaders -> H.ResponseHeaders addAltSvc settings hs = case settingsAltSvc settings of@@ -503,19 +557,23 @@ ---------------------------------------------------------------- --- |+-- | Replaces a header, instead of just adding it which might lead to+-- duplicate entries of the same header name. -- -- >>> replaceHeader "Content-Type" "new" [("content-type","old")] -- [("Content-Type","new")] replaceHeader :: H.HeaderName -> HeaderValue -> H.ResponseHeaders -> H.ResponseHeaders-replaceHeader k v hdrs = (k, v) : deleteBy ((==) `on` fst) (k, v) hdrs+replaceHeader k v hdrs = (k, v) : filter ((/= k) . fst) hdrs ---------------------------------------------------------------- composeHeaderBuilder- :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> Bool -> IO Builder-composeHeaderBuilder ver s hs True =- byteString <$> composeHeader ver s (addTransferEncoding hs)-composeHeaderBuilder ver s hs False =- byteString <$> composeHeader ver s hs+ :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> ResponseHeaderPresence -> Bool -> IO (Builder, Int)+composeHeaderBuilder ver s hs rspidxhdr shouldChunk = do+ bs <- composeHeader ver s finalHdrs+ pure (byteString bs, S.length bs)+ where+ finalHdrs+ | shouldChunk = addTransferEncoding rspidxhdr hs+ | otherwise = hs
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -6,7 +6,7 @@ import qualified Data.ByteString as S import Data.ByteString.Internal (create) import qualified Data.CaseInsensitive as CI-import Data.List (foldl')+import Data.List as List (foldl') import Data.Word8 import Foreign.Ptr import GHC.Storable@@ -23,7 +23,7 @@ ptr2 <- copyHeaders ptr1 responseHeaders void $ copyCRLF ptr2 where- !len = 17 + slen + foldl' fieldLength 0 responseHeaders+ !len = 17 + slen + List.foldl' fieldLength 0 responseHeaders fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4 !slen = S.length $ H.statusMessage status
Network/Wai/Handler/Warp/Settings.hs view
@@ -140,6 +140,12 @@ , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO () -- ^ A log function. Default: no action. --+ -- @settingsLogger req status mSentBytes@+ --+ -- /N.B. @Maybe Integer@ is the concrete bytes of the message body/+ -- /after all the headers have been sent. This is 'Nothing' when/+ -- /'responseRaw' is used. (e.g. when using websockets)/+ -- -- Since 3.1.10 , settingsServerPushLogger :: Request -> ByteString -> Integer -> IO () -- ^ A HTTP/2 server push log function. Default: no action.
bench/Parser.hs view
@@ -19,6 +19,7 @@ import Prelude hiding (lines) import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines)+import Network.Wai.Handler.Warp.Response (containsRecoverableWhitespace) import Network.Wai.Handler.Warp.Types import Criterion.Main@@ -54,6 +55,16 @@ , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25) , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100) ]+ , bgroup+ "containsRecoverableWhitespace"+ -- Clean values (no CR/LF/NUL) are the overwhelmingly common case and+ -- the one the fast path must stay cheap for; the dirty case is+ -- what forces a rebuild in 'sanitizeHeaders'.+ [ bench "clean short" $ whnf containsRecoverableWhitespace "Mighttpd/2.5.8"+ , bench "clean long" $ whnf containsRecoverableWhitespace cleanLong+ , bench "dirty" $+ whnf containsRecoverableWhitespace "text/html\r\nInjected: header"+ ] ] where testIt req = producer req >>= headerLines 800 FirstRequest@@ -241,6 +252,11 @@ in return $! (method, rpath, qstring, hv) else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s++-- A long, clean header value (no CR/LF): forces the memchr scan to walk the+-- whole value before deciding it is clean.+cleanLong :: S.ByteString+cleanLong = S.replicate 512 _A producer :: [ByteString] -> IO Source producer a = do
+ test/BufferSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module BufferSpec (main, spec) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Builder as BLD+import Data.IORef as I+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer)+import Network.Wai.Handler.Warp.IO (toBufIOWith)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (NonNegative (..))++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "toBufIOWith" $ do+ it "counts short bytestrings" $+ testBufIOWith 10+ -- This failed before fixing 'toBufIOWith'+ it "counts long bytestrings" $ do+ testBufIOWith 1000000+ modifyMaxSize (const 10000000) . prop "counts bytestrings of different sizes" $+ \(NonNegative i) -> testBufIOWith i++testBufIOWith :: Int -> Expectation+testBufIOWith bsLen = do+ len <- toBufIOWithBuilder $ BLD.byteString $ S.replicate bsLen 0+ len `shouldBe` fromIntegral bsLen++toBufIOWithBuilder :: BLD.Builder -> IO Integer+toBufIOWithBuilder bld = do+ countRef <- newIORef 0 :: IO (IORef Int)+ buf <- createWriteBuffer 16384+ bufRef <- newIORef buf+ let go bs = modifyIORef' countRef (+ S.length bs)+ toBufIOWith 1049000000 bufRef go bld
test/ConnectionSpec.hs view
@@ -2,73 +2,80 @@ module ConnectionSpec (spec) where +import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8 import Network.HTTP.Types import Network.Wai import Network.Wai.Handler.Warp-import RunSpec (withApp, withMySocket, msWrite, msRead)+import RunSpec (msRead, msWrite, withApp, withMySocket) import Test.Hspec-import Data.ByteString (ByteString)-import qualified Data.ByteString.Char8 as S8 spec :: Spec spec = describe "Connection header" $ do- it "sends Connection: close when response implies close (HTTP/1.0 Keep-Alive, no Content-Length)" $ do- let app _ f = f $ responseLBS status200 [] "foo"+ describe "HTTP/1.0 Connection: close behavior" $ do+ -- HTTP/1.0 defaults to close. We ask for Keep-Alive.+ -- But we provide no Content-Length in response.+ -- So Warp should decide to close (because it can't keep alive without length or chunking),+ -- and MUST send "Connection: close" to inform the client.+ -- (In HTTP/1.0 this requires closing the connection to delimit the+ -- response; or rather, lack of persistence info)+ testClose+ "when response implies close (HTTP/1.0 Keep-Alive, but no Content-Length)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n"+ testClose+ "sends \"Connection: close\" on regular HTTP/1.0 GET request"+ (responseBuilder status200 [] "foo")+ "GET / HTTP/1.0\r\nHost: localhost\r\n\r\n"++ describe "HTTP/1.1 Connection: close behavior" $ do+ -- Response has no Content-Length and is not chunked (HEAD implies no body).+ it "does NOT send \"Connection: close\" for HTTP/1.1 HEAD request" $ do+ let app _ f = f $ responseBuilder status200 [] "foo" withApp defaultSettings app $ withMySocket $ \ms -> do- -- HTTP/1.0 defaults to close. We ask for Keep-Alive.- -- But we provide no Content-Length in response.- -- So Warp should decide to close (because it can't keep alive without length or chunking),- -- and MUST send "Connection: close" to inform the client.- msWrite ms "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n"- - -- We expect the connection to be closed by the server, so reading a large amount + msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n"+ -- Should include the Connection header if present and also+ -- should be less then all headers when it's absent, so we+ -- don't wait for nothing.+ response <- msRead ms 73+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Nothing+ testClose+ "when GET request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when HEAD request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "HEAD / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (204 No Content)"+ (responseLBS status204 [] "")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (500 Internal Server Error)"+ (responseLBS status500 [] "error")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ where+ testClose name res input = do+ let prefix = "sends \"Connection: close\" "+ it (prefix <> name) $ do+ let app _ f = f res+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms input+ -- We expect the connection to be closed by the server, so reading a large amount -- should return whatever was sent and then finish. response <- msRead ms 4096- let headers = parseHeaders response lookup "Connection" headers `shouldBe` Just "close"- - describe "HTTP/1.1 Connection: close behavior" $ do- it "sends Connection: close for HEAD request without Content-Length" $ do- -- Response has no Content-Length and is not chunked (HEAD implies no body).- -- In HTTP/1.1 this requires closing the connection to delimit the response (or rather, lack of persistence info).- let app _ f = f $ responseBuilder status200 [] "foo"- withApp defaultSettings app $ withMySocket $ \ms -> do- msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n"- response <- msRead ms 4096- let headers = parseHeaders response- lookup "Connection" headers `shouldBe` Just "close"- - it "sends Connection: close when request has Connection: close (200 OK)" $ do- let app _ f = f $ responseLBS status200 [] "foo"- withApp defaultSettings app $ withMySocket $ \ms -> do- msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"- response <- msRead ms 4096- let headers = parseHeaders response- lookup "Connection" headers `shouldBe` Just "close"- - it "sends Connection: close when request has Connection: close (204 No Content)" $ do- let app _ f = f $ responseLBS status204 [] ""- withApp defaultSettings app $ withMySocket $ \ms -> do- msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"- response <- msRead ms 4096- let headers = parseHeaders response- lookup "Connection" headers `shouldBe` Just "close"- - it "sends Connection: close when request has Connection: close (500 Internal Server Error)" $ do- let app _ f = f $ responseLBS status500 [] "error"- withApp defaultSettings app $ withMySocket $ \ms -> do- msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"- response <- msRead ms 4096- let headers = parseHeaders response- lookup "Connection" headers `shouldBe` Just "close"+ parseHeaders :: ByteString -> [(ByteString, ByteString)]-parseHeaders bs = - let lines = S8.lines bs+parseHeaders bs =+ let allLines = S8.lines bs -- Drop status line- headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 lines- parseLine line = + headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 allLines+ parseLine line = let (k, v) = S8.break (== ':') line v' = S8.takeWhile (/= '\r') v- in (k, S8.dropWhile (== ' ') $ S8.drop 1 v')- in map parseLine headerLines+ in (k, S8.dropWhile (== ' ') $ S8.drop 1 v')+ in map parseLine headerLines
+ test/EarlyHintsSpec.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++module EarlyHintsSpec (spec) where++import Test.Hspec++#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))++#if HAS_EARLY_HINTS_SUPPORT+import Control.Exception (bracket)+import Data.ByteString (ByteString)+import Data.IORef+import Network.HPACK (TokenHeaderTable, getFieldValue)+import Network.HPACK.Token (toToken)+import Network.HTTP.Types (Status, methodGet, ok200, status200, status404)+import qualified Network.HTTP2.Client as C+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp (Port, testWithApplication)++spec :: Spec+spec = describe "HTTP/2 Early Hints" $+ it "delivers a WAI app's 103 Early Hints to the client before the final response (h2c)" $+ testWithApplication (pure app) $ \port -> do+ hintsRef <- newIORef []+ earlyHintsClient port hintsRef `shouldReturn` Just ok200+ hints <- readIORef hintsRef+ map (getFieldValue (toToken "link") . snd) hints+ `shouldBe` (Just <$> earlyResponses)++-- | The @Link@ header values delivered as Early Hints, in order.+earlyResponses :: [ByteString]+earlyResponses =+ [ "</style.css>; rel=preload; as=style"+ , "</app.js>; rel=preload; as=script"+ ]++-- | A WAI app that emits two Early Hints sections, then the final response.+app :: Application+app req respond+ | pathInfo req == ["early"] = do+ mapM_ (\link -> requestSendEarlyHints req [("link", link)]) earlyResponses+ respond $ responseLBS status200 [("content-type", "text/plain")] "Hello"+ | otherwise = respond $ responseLBS status404 [] ""++-- | Drive Warp over h2c with the HTTP/2 client, recording each 103 Early Hints+-- section via the client's informational handler, and return the final status.+earlyHintsClient :: Port -> IORef [TokenHeaderTable] -> IO (Maybe Status)+earlyHintsClient port hintsRef = withTCP "127.0.0.1" port $ \sock ->+ bracket (C.allocSimpleConfig sock 4096) C.freeSimpleConfig $ \conf ->+ C.run cliconf (conf{C.confOnInformational = onInformational}) $ \sendRequest _aux ->+ sendRequest (C.requestNoBody methodGet "/early" []) (return . C.responseStatus)+ where+ cliconf = C.defaultClientConfig{C.authority = "127.0.0.1"}+ onInformational _streamId tbl = modifyIORef' hintsRef (++ [tbl])++-- | Connect to a TCP server, run an action, and close the socket afterwards.+withTCP :: HostName -> Port -> (Socket -> IO a) -> IO a+withTCP host port = bracket open close+ where+ open = do+ addr : _ <- getAddrInfo (Just defaultHints{addrSocketType = Stream}) (Just host) (Just (show port))+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)+ connect sock (addrAddress addr)+ return sock+#else+spec :: Spec+spec = describe "HTTP/2 Early Hints" $+ it "delivers a WAI app's 103 Early Hints to the client before the final response (h2c)" $+ pendingWith "requires http2 >= 5.4.2 and http-semantics >= 0.4.1"+#endif
test/ResponseSpec.hs view
@@ -73,35 +73,15 @@ spec :: Spec spec = do- {- http-client does not support this.- describe "preventing response splitting attack" $ do- it "sanitizes header values" $ do- let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"- withApp defaultSettings app $ \port -> do- res <- sendGET $ "http://127.0.0.1:" ++ show port- getHeaderValue "foo" (responseHeaders res) `shouldBe`- Just "foo bar" -- HTTP inserts two spaces for \r\n.- -}- describe "sanitizeHeaderValue" $ do- it "doesn't alter valid multiline header values" $ do- sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar"-- it "adds missing spaces after \r\n" $ do- sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"-- it "discards empty lines" $ do- sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"-- context "when sanitizing single occurrences of \n" $ do- it "replaces \n with \r\n" $ do- sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"-- it "adds missing spaces after \n" $ do- sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"-- it "discards single occurrences of \r" $ do- sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"+ it "replaces multiline header value's [CR LF NUL] with SP" $ do+ sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\NULbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\rbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\NULbar" `shouldBe` "foo bar" describe "range requests" $ do testRange "2-3" "23" $ Just "2-3/16"
test/RunSpec.hs view
@@ -150,7 +150,7 @@ ( const $ do takeMVar baton -- use timeout to make sure we don't take too long- mres <- timeout (60 * 1000 * 1000) (f port)+ mres <- timeout (3 * 1000 * 1000) (f port) case mres of Nothing -> error "Timeout triggered, too slow!" Just a -> pure a@@ -392,7 +392,7 @@ `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ()))) liftIO $- threadDelay 4000000 `E.catch` \e -> do+ threadDelay 500000 `E.catch` \e -> do I.atomicModifyIORef ifront ( \front ->@@ -415,7 +415,7 @@ msWrite ms bs1 threadDelay 100000 msWrite ms bs2- threadDelay 5000000+ threadDelay 1000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs describe "raw body" $ do
test/ServerStateSpec.hs view
@@ -3,7 +3,7 @@ module ServerStateSpec where import Network.Wai.Handler.Warp (getServerState)-import Network.Wai.Handler.Warp.Counter (getCount, increase)+import Network.Wai.Handler.Warp.Counter (increase) import Network.Wai.Handler.Warp.Settings ( ServerState (..), currentOpenConnections,
test/WithApplicationSpec.hs view
@@ -9,6 +9,7 @@ import System.Process import Test.Hspec +import Network.Wai.Handler.Warp (defaultSettings, setOnException) import Network.Wai.Handler.Warp.WithApplication -- All these tests assume the "curl" process can be called directly.@@ -31,16 +32,21 @@ it "does not propagate exceptions from the server to the executing thread" $ do let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"- withApplication mkApp $ \port -> do+ withApplicationSettings silentSettings mkApp $ \port -> do output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldContain` "Something went wron"+ output `shouldContain` "Something went wrong" describe "testWithApplication" $ do it "propagates exceptions from the server to the executing thread" $ do let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"- testWithApplication+ testWithApplicationSettings+ silentSettings mkApp ( \port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "" ) `shouldThrow` (errorCall "foo")+ where+ -- So that we don't muddy the test result screen.+ -- (normally, 'defaultSettings' use 'defaultOnException', sending to 'stderr')+ silentSettings = setOnException (\_ _ -> pure ()) defaultSettings
warp.cabal view
@@ -1,6 +1,6 @@ cabal-version: >=1.10 name: warp-version: 3.4.14+version: 3.4.15 license: MIT license-file: LICENSE maintainer: michael@snoyman.com@@ -98,7 +98,6 @@ ghc-options: -Wall build-depends: base >=4.12 && <5,- array, auto-update >=0.2.2 && <0.3, async >= 2, bsb-http-chunked <0.1,@@ -107,7 +106,8 @@ containers, hashable, http-date,- http-types >=0.12,+ http-types >=0.12 && <1,+ http-semantics >=0.4 && <0.5, http2 >=5.4 && <5.5, iproute >=1.3.1, recv >=0.1.0 && <0.2.0,@@ -117,7 +117,7 @@ text, time-manager >=0.2 && <0.4, vault >=0.3,- wai >=3.2.4 && <3.3,+ wai >=3.2.5 && <3.3, word8 if flag(x509)@@ -179,8 +179,10 @@ build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test . other-modules:+ BufferSpec ConduitSpec ConnectionSpec+ EarlyHintsSpec ExceptionSpec FdCacheSpec FileSpec@@ -237,7 +239,6 @@ build-depends: base >=4.8 && <5, QuickCheck,- array, auto-update, async, bsb-http-chunked <0.1,@@ -250,6 +251,7 @@ http-client, http-date, http-types >=0.12,+ http-semantics >=0.4 && <0.5, http2 >=5.4 && <5.5, iproute >=1.3.1, network,@@ -261,7 +263,7 @@ text, time-manager, vault,- wai >=3.2.2.1 && <3.3,+ wai >=3.2.5 && <3.3, -- workaround: this should be unnecessary warp, word8@@ -295,19 +297,26 @@ main-is: Parser.hs hs-source-dirs: bench . other-modules:+ Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Conduit Network.Wai.Handler.Warp.Counter Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap+ Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown Network.Wai.Handler.Warp.Types if flag(include-warp-version)@@ -316,8 +325,9 @@ default-language: Haskell2010 build-depends: base >=4.8 && <5,- array,+ async, auto-update,+ bsb-http-chunked, bytestring, case-insensitive, containers,@@ -325,9 +335,11 @@ hashable, http-date, http-types,- network,+ http2,+ iproute, network, recv,+ simple-sendfile, stm, streaming-commons, text,