warp 3.4.10 → 3.4.15
raw patch · 27 files changed
Files
- ChangeLog.md +67/−0
- Network/Wai/Handler/Warp.hs +47/−0
- Network/Wai/Handler/Warp/Counter.hs +25/−4
- 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 +35/−1
- Network/Wai/Handler/Warp/Request.hs +11/−13
- Network/Wai/Handler/Warp/Response.hs +174/−108
- Network/Wai/Handler/Warp/ResponseHeader.hs +2/−2
- Network/Wai/Handler/Warp/Run.hs +131/−31
- Network/Wai/Handler/Warp/Settings.hs +133/−2
- Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
- Network/Wai/Handler/Warp/Types.hs +10/−5
- bench/Parser.hs +16/−0
- test/BufferSpec.hs +38/−0
- test/ConnectionSpec.hs +81/−0
- test/EarlyHintsSpec.hs +72/−0
- test/GracefulShutdownSpec.hs +83/−0
- test/ResponseSpec.hs +8/−28
- test/RunSpec.hs +4/−4
- test/ServerStateSpec.hs +58/−0
- test/WithApplicationSpec.hs +9/−3
- warp.cabal +34/−15
ChangeLog.md view
@@ -1,5 +1,72 @@ # 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+ the file descriptor exhaustion is outside of the server's control.+ (i.e. the server does not have any running connections and can't use a file+ descriptor to create the next connection)+ [#1084](https://github.com/yesodweb/wai/pull/1084)++## 3.4.13.1++* Bugfix to fall back to "blocking `recv`" when on Windows systems and when+ using `network < 3.2.2`.+ [#1077](https://github.com/yesodweb/wai/pull/1077)++## 3.4.13++* Change graceful shutdown logic to stop accepting data from idle connections,+ but to wait for busy `Application`s, adding `Connection: close` headers to+ responses if the server is shutting down.+ This should make sure the server doesn't wait for idle keep-alive connections.+* Expose a broader way to access internal state like the open connection `Counter`+ and whether the server is currently `ShuttingDown` or not.+ Users can use `makeSettingsAndServerState` to get a `ServerState` while+ making `defaultSettings`.+ [#1071](https://github.com/yesodweb/wai/pull/1071)++## 3.4.12++* Respond with `Connection: close` header if connection is to be closed after a request.+ [#958](https://github.com/yesodweb/wai/pull/958)++## 3.4.11++* Expose a way to access the open connection `Counter` with `makeSettingsAndCounter`,+ and `getCount` to be able to monitor the current open connections.+* Added getter function to get the open connection counter from the `Settings` with+ `getOpenConnectionCounter`.+ [#1050](https://github.com/yesodweb/wai/pull/1050)+ ## 3.4.10 * Using newest dependencies
Network/Wai/Handler/Warp.hs view
@@ -89,7 +89,32 @@ getGracefulShutdownTimeout, getGracefulCloseTimeout1, getGracefulCloseTimeout2,+ getOpenConnectionCounter,+ getServerState, + -- ** Internal server state+ --+ -- Creating 'Settings' with insight into the internal state of the server.+ --+ -- When using 'makeSettingsAndServerState', you will receive the 'ServerState'+ -- that will be used by @warp@ so that you can query things like the+ -- 'currentOpenConnections', and 'currentShuttingDownState'.+ ServerState,+ makeSettingsAndServerState,+ currentOpenConnections,+ currentShuttingDownState,++ -- *** STM versions+ currentOpenConnectionsSTM,+ currentShuttingDownStateSTM,++ -- ** Connection counter+ --+ -- /Deprecated in favor of 'ServerState'/+ makeSettingsAndCounter,+ Counter,+ getCount,+ -- ** Exception handler defaultOnException, defaultShouldDisplayException,@@ -150,6 +175,7 @@ import Network.Wai (Request, Response, vault) import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.Request ( getHTTP2Data,@@ -563,6 +589,27 @@ -- Since 3.3.5 getGracefulCloseTimeout2 :: Settings -> Int getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2++-- | Get the connection counter, if one was configured.+-- Use 'getCount' on the returned 'Counter' to read the current value.+--+-- See 'makeSettingsAndCounter' to create settings with a counter.+--+-- /DEPRECATED in favor of 'getServerState'/+--+-- Since 3.4.11+getOpenConnectionCounter :: Settings -> Maybe Counter+getOpenConnectionCounter = settingsConnectionCounter++-- | Get the 'ServerState', if one was configured.+-- Use things like 'currentOpenConnections' and 'currentShuttingDownState' to+-- query information about the current state of the server.+--+-- See 'makeSettingsAndServerState' to create 'Settings' with a 'ServerState'.+--+-- Since 3.4.12+getServerState :: Settings -> Maybe ServerState+getServerState = settingsServerState #ifdef MIN_VERSION_crypton_x509 -- | Getting information of client certificate.
Network/Wai/Handler/Warp/Counter.hs view
@@ -3,10 +3,13 @@ module Network.Wai.Handler.Warp.Counter ( Counter, newCounter,+ HasDecreased (..), waitForZero, increase, decrease, waitForDecreased,+ getCount,+ getCountSTM, ) where import Control.Concurrent.STM@@ -23,15 +26,33 @@ x <- readTVar var when (x > 0) retry -waitForDecreased :: Counter -> IO ()+data HasDecreased = HasDecreased | NoConnections+ deriving (Eq, Show)++waitForDecreased :: Counter -> IO HasDecreased waitForDecreased (Counter var) = do n0 <- atomically $ readTVar var- atomically $ do- n <- readTVar var- check (n < n0)+ if n0 <= 0+ then pure NoConnections+ else atomically $ do+ n <- readTVar var+ check (n < n0)+ pure HasDecreased increase :: Counter -> IO () increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1 decrease :: Counter -> IO () decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1++-- | Get the current count of open connections.+--+-- Since 3.4.11+getCount :: Counter -> IO Int+getCount (Counter var) = readTVarIO var++-- | Get the current count in an 'STM' transaction.+--+-- Since 3.4.13+getCountSTM :: Counter -> STM Int+getCountSTM (Counter tvar) = readTVar tvar
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
@@ -1,10 +1,30 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} +-- |+-- __IMPORTANT NOTICE__+--+-- This module exports internals mainly to provide the @warp-tls@ package+-- with tools to implement what it needs to. This module\/API should /NOT/ be+-- expected to remain stable at all, even between minor releases.+--+-- If you see a use case for these functions or types for other purposes,+-- please create an issue in the repository so that we might add it to the+-- main 'Network.Wai.Handler.Warp' API. module Network.Wai.Handler.Warp.Internal ( -- * Settings Settings (..), ProxyProtocol (..),+ makeSettingsAndCounter,+ makeSettingsAndServerState, + -- ** Connection counter+ Counter,+ getCount,++ -- ** Server state+ ServerState,+ makeServerState,+ -- * Low level run functions runSettingsConnection, runSettingsConnectionMaker,@@ -17,6 +37,7 @@ -- ** Receive Recv,+ makeGracefulRecv, RecvBuf, -- ** Buffer@@ -38,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 @@ -94,6 +125,7 @@ import System.TimeManager import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache@@ -107,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
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -16,12 +15,10 @@ ) 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 import qualified Data.IORef as I-import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as Vault import Data.Word8 (_cr, _lf) #ifdef MIN_VERSION_crypton_x509@@ -70,7 +67,7 @@ -> IO ( Request , Maybe (I.IORef Int)- , IndexedHeader+ , IndexedRequestHeader , IO ByteString ) -- ^@@ -83,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@@ -112,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) @@ -136,7 +134,7 @@ else push maxTotalHeaderLength src (THStatus 0 0 id id) bs data NoKeepAliveRequest = NoKeepAliveRequest- deriving (Show, Typeable)+ deriving (Show) instance Exception NoKeepAliveRequest ----------------------------------------------------------------@@ -159,7 +157,7 @@ bodyAndSource :: Source- -> IndexedHeader+ -> IndexedRequestHeader -> IO ( IO ByteString , Maybe (I.IORef Int)@@ -170,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,7 +121,23 @@ -> IO Bool -- ^ Returing True if the connection is persistent. sendResponse settings conn ii th req reqidxhdr src response = do- hs <- addAltSvc settings <$> addServerAndDate hs0+ -- 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 && ret+ addConnection 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.@@ -133,28 +150,39 @@ case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen- T.tickle th- return ret else do _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody logger req s Nothing- T.tickle th- return isPersist+ 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@@ -164,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)@@ -214,7 +273,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader -- Response+ -> ResponseHeaderPresence -> Int -- maxBuilderResponseBufferSize -> H.Method -> Rsp@@ -225,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@@ -244,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@@ -269,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, ()) ---------------------------------------------------------------- @@ -349,7 +422,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> FilePath@@ -359,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@@ -374,7 +449,7 @@ -> T.Handle -> H.HttpVersion -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> IO (Maybe H.Status, Maybe Integer)@@ -392,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" ----------------------------------------------------------------@@ -412,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@@ -465,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@@ -495,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/Run.hs view
@@ -1,17 +1,27 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# LANGUAGE MultiWayIf #-} module Network.Wai.Handler.Warp.Run where import Control.Arrow (first)+import Control.Concurrent.STM (+ TVar,+ atomically,+ check,+ modifyTVar',+ newTVarIO,+ readTVar,+ ) import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.IORef (newIORef, readIORef)+import Data.Functor (($>))+import Data.IORef (newIORef, readIORef, IORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE) import GHC.Conc.Sync (labelThread, myThreadId)@@ -23,7 +33,10 @@ close, #if !WINDOWS fdSocket,+#if MIN_VERSION_network(3,2,2)+ waitReadSocketSTM, #endif+#endif getSocketName, setSocketOption, withSocketsDo,@@ -39,7 +52,7 @@ import qualified System.TimeManager as T import System.Timeout (timeout) -import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer) import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F@@ -48,22 +61,24 @@ import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Imports hiding (readInt)-import Network.Wai.Handler.Warp.SendFile+import Network.Wai.Handler.Warp.SendFile (sendFile) import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown) import Network.Wai.Handler.Warp.Types -- | Creating 'Connection' for plain HTTP based on a given socket.+--+-- (N.B. make sure the 'Settings' have an initialized 'ServerState' to guarantee+-- a graceful shutdown) socketConnection :: Settings -> Socket -> IO Connection-#if MIN_VERSION_network(3,1,1) socketConnection set s = do-#else-socketConnection _ s = do-#endif+ (ss, _) <- makeServerState set bufferPool <- newBufferPool 2048 16384 writeBuffer <- createWriteBuffer 16384 writeBufferRef <- newIORef writeBuffer isH2 <- newIORef False -- HTTP/1.x mysa <- getSocketName s+ appsInProgress <- newTVarIO 0 return Connection { connSendMany = Sock.sendMany s@@ -82,14 +97,16 @@ #else , connClose = close s #endif- , connRecv = receive' s bufferPool+ , connRecv = receive' bufferPool ss appsInProgress , connRecvBuf = \_ _ -> return True -- obsoleted , connWriteBuffer = writeBufferRef , connHTTP2 = isH2 , connMySockAddr = mysa+ , connAppsInProgress = appsInProgress } where- receive' sock pool = E.handle handler $ receive sock pool+ receive' bufferPool ss appsInProgress =+ E.handle handler $ makeGracefulRecv s bufferPool ss appsInProgress where handler :: E.IOException -> IO ByteString handler e@@ -121,6 +138,33 @@ E.throwIO $ Sock.sendAll sock bs +-- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make+-- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes+-- when the server is shutting down and there are no more 'Application's+-- actively using this 'Socket'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+ sockWait <-+#if !WINDOWS && MIN_VERSION_network(3,2,2)+ waitReadSocketSTM sock+#else+ -- FIXME: 'waitReadSocketSTM' doesn't work on WINDOWS, and actually+ -- blocks indefinitely, so we fall back to going straight to 'recv'.+ pure (pure ())+#endif+ isShuttingDown <- atomically $+ -- when shutting down+ (checkShutdown $> True)+ <|>+ -- else wait for socket readiness and do non-blocking read+ (sockWait $> False)+ if isShuttingDown then pure "" else recv+ where+ recv = receive sock pool+ checkShutdown = do+ check =<< currentShuttingDownStateSTM ss+ check . (<= 0) =<< readTVar appsInProgress+ -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()@@ -168,11 +212,12 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do- settingsInstallShutdownHandler set closeListenSocket- runSettingsConnection set getConn app+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+ settingsInstallShutdownHandler oldSettings closeListenSocket+ (_, newSettings) <- makeServerState oldSettings+ runSettingsConnection newSettings (getConn newSettings) app where- getConn = do+ getConn set = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX.@@ -218,10 +263,12 @@ -- Since 2.1.4 runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()-runSettingsConnectionMakerSecure set getConnMaker app = do- settingsBeforeMainLoop set- counter <- newCounter- withII set $ acceptConnection set getConnMaker app counter+runSettingsConnectionMakerSecure oldSettings getConnMaker app = do+ settingsBeforeMainLoop oldSettings+ (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings+ withII newSettings $ \ii ->+ initFdExhaustionRef >>=+ acceptConnection newSettings getConnMaker app serverConnectionCounter ii -- | Running an action with internal info. --@@ -265,8 +312,12 @@ -> Application -> Counter -> InternalInfo+ -> IORef FdExhaustion+ -- ^ This ref will be used to "debounce" the call to 'settingsOnException'+ -- when we hit an 'IOError' with 'eMFILE' in the case that Warp is not+ -- the reason the file descriptors are exhausted. -> IO ()-acceptConnection set getConnMaker app counter ii = do+acceptConnection set getConnMaker app counter ii fdRef = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose.@@ -299,19 +350,44 @@ acceptNewConnection = do ex <- E.try getConnMaker case ex of- Right x -> return $ Just x+ Right x -> do+ -- Important to mark the exhaustion issue to be resolved+ -- when we get connections again.+ resetFdExhaustion fdRef+ return $ Just x Left e -> do let getErrno (Errno cInt) = cInt isErrno err = ioe_errno e == Just (getErrno err)- if | isErrno eCONNABORTED -> acceptNewConnection+ if | isErrno eCONNABORTED -> do+ -- Important to mark the exhaustion issue to be resolved+ resetFdExhaustion fdRef+ acceptNewConnection+ -- Keep in mind to reset the ref when anything other+ -- than this branch runs | isErrno eMFILE -> do- settingsOnException set Nothing $ E.toException e- waitForDecreased counter- acceptNewConnection+ handleFdExhaustion e+ acceptNewConnection | otherwise -> do- settingsOnException set Nothing $ E.toException e- return Nothing+ -- Maybe not important to mark the exhaustion issue+ -- as resolved here, but just for completeness' sake.+ resetFdExhaustion fdRef+ settingsOnException set Nothing $ E.toException e+ return Nothing + handleFdExhaustion e = do+ fdExhaustion <- readIORef fdRef+ -- If file descriptors are exhausted while Warp has+ -- no current connections, 'settingsOnException' would+ -- get called an enormous amount of times per second.+ when (fdExhaustion /= FdExhausted) $+ settingsOnException set Nothing $ E.toException e+ hasDecreased <- waitForDecreased counter+ -- If we get 'NoConnections', that means the file+ -- descriptor exhaustion is outside of our control.+ -- We flag it so that 'settingsOnException' doesn't get+ -- called until the exhaustion issue is resolved.+ when (hasDecreased == NoConnections) $ setFdExhaustion fdRef+ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork@@ -389,13 +465,19 @@ if "PRI " `S.isPrefixOf` bs0 then return (True, bs0) else return (False, bs0)+ let appsInProgress = connAppsInProgress conn+ app' req rsp =+ E.bracket_+ (atomically $ modifyTVar' appsInProgress $ (+ 1))+ (atomically $ modifyTVar' appsInProgress $ \i -> (i - 1))+ $ app req rsp if settingsHTTP2Enabled settings && h2 then do labelThread tid ("Warp HTTP/2 " ++ show origAddr)- http2 settings ii conn transport app origAddr th bs+ http2 settings ii conn transport app' origAddr th bs else do labelThread tid ("Warp HTTP/1.1 " ++ show origAddr)- http1 settings ii conn transport app origAddr th bs+ http1 settings ii conn transport app' origAddr th bs where recv4 bs0 = do bs1 <- connRecv conn@@ -428,11 +510,29 @@ #endif gracefulShutdown :: Settings -> Counter -> IO ()-gracefulShutdown set counter =+gracefulShutdown set counter = do+ setShuttingDown case settingsGracefulShutdownTimeout set of Nothing -> waitForZero counter (Just seconds) -> void (timeout (seconds * microsPerSecond) (waitForZero counter))- where- microsPerSecond = 1000000+ where+ microsPerSecond = 1000000+ setShuttingDown =+ case settingsServerState set of+ Nothing -> pure ()+ Just ServerState{serverShuttingDown} ->+ writeShuttingDown serverShuttingDown True++data FdExhaustion = NoFdIssue | FdExhausted+ deriving (Eq, Show)++initFdExhaustionRef :: IO (IORef FdExhaustion)+initFdExhaustionRef = newIORef NoFdIssue++resetFdExhaustion :: IORef FdExhaustion -> IO ()+resetFdExhaustion = flip writeIORef NoFdIssue++setFdExhaustion :: IORef FdExhaustion -> IO ()+setFdExhaustion = flip writeIORef FdExhausted
Network/Wai/Handler/Warp/Settings.hs view
@@ -9,15 +9,16 @@ module Network.Wai.Handler.Warp.Settings where -import Control.Exception (SomeException(..), fromException, throw)+import Control.Concurrent.STM (STM)+import Control.Exception (SomeException (..), fromException, throw) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO+import GHC.Exts (fork#) import GHC.IO (IO (IO), unsafeUnmask) import GHC.IO.Exception (IOErrorType (..))-import GHC.Prim (fork#) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr, Socket, accept) import Network.Wai@@ -25,7 +26,14 @@ import System.IO.Error (ioeGetErrorType) import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount, newCounter, getCountSTM) import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ ) import Network.Wai.Handler.Warp.Types #if WINDOWS import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)@@ -132,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.@@ -178,6 +192,25 @@ -- Default: 1049_000_000 = 1 MiB. -- -- Since 3.3.22+ , settingsConnectionCounter :: Maybe Counter+ -- ^ A counter for tracking open connections.+ -- Use 'makeSettingsAndCounter' to create settings with a counter,+ -- then use 'getCount' on the returned 'Counter' to read the current value.+ --+ -- Default: 'Nothing' (warp creates an internal counter)+ --+ -- /DEPRECATED in favor of 'settingsServerState'/+ --+ -- Since 3.4.11+ , settingsServerState :: Maybe ServerState+ -- ^ Internal read-only server state.+ -- Use 'makeSettingsAndServerState' to gain access to the state of the server.+ -- Using functions like 'currentOpenConnections' or 'currentShuttingDownState'+ -- to gain insight into the current state of the server.+ --+ -- Default: 'Nothing' (warp creates its own internal state)+ --+ -- Since 3.4.13 } -- | Specify usage of the PROXY protocol.@@ -189,6 +222,83 @@ | -- | See @setProxyProtocolOptional@. ProxyProtocolOptional +-- | Internal read-only state of the server+--+-- Since 3.4.13+data ServerState = ServerState+ { serverConnectionCounter :: Counter+ , serverShuttingDown :: ShuttingDown+ }++-- | Takes 'Settings' and either returns the 'ServerState'+-- that was already in there, or creates a new 'ServerState'.+--+-- The returned 'Settings' will always contain a 'ServerState'.+--+-- This makes it idempotent if care is taken that the @oldSettings@+-- are not used after using this function.+--+-- Since 3.4.13+makeServerState :: Settings -> IO (ServerState, Settings)+makeServerState oldSettings =+ case settingsServerState oldSettings of+ Just serverState -> pure (serverState, oldSettings)+ Nothing -> do+ serverState <- newServerState+ let counter = serverConnectionCounter serverState+ pure+ ( serverState+ , oldSettings+ { settingsServerState = Just serverState+ , settingsConnectionCounter = Just counter+ }+ )++-- | Initialize a 'ServerState'+--+-- Since 3.4.13+newServerState :: IO ServerState+newServerState = do+ counter <- newCounter+ shuttingDown <- newShuttingDown+ pure+ ServerState+ { serverConnectionCounter = counter+ , serverShuttingDown = shuttingDown+ }++-- | Get the currently open connections of the server.+--+-- Since 3.4.13+currentOpenConnections :: ServerState -> IO Int+currentOpenConnections = getCount . serverConnectionCounter++-- | Get the currently open connections of the server in an 'STM' transaction.+--+-- Since 3.4.13+currentOpenConnectionsSTM :: ServerState -> STM Int+currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter++-- | Check if the server is currently shutting down.+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownState :: ServerState -> IO Bool+currentShuttingDownState = readShuttingDown . serverShuttingDown++-- | Check if the server is currently shutting down in an 'STM' transaction.+--+-- (This way you can have a thread wait for server shutdown with 'Control.Concurrent.STM.retry')+--+-- > False: Server is not shutting down+-- > True: Server is shutting down or has shut down.+--+-- Since 3.4.13+currentShuttingDownStateSTM :: ServerState -> STM Bool+currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown+ -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings@@ -222,7 +332,28 @@ , settingsMaxTotalHeaderLength = 50 * 1024 , settingsAltSvc = Nothing , settingsMaxBuilderResponseBufferSize = 1049000000+ , settingsConnectionCounter = Nothing+ , settingsServerState = Nothing }++-- | Create 'defaultSettings' with a connection counter.+-- Use 'getCount' on the returned 'Counter' to check open connections.+--+-- /DEPRECATED in favor of 'makeSettingsAndServerState'/+--+-- Since 3.4.11+makeSettingsAndCounter :: IO (Counter, Settings)+makeSettingsAndCounter = do+ (serverState, settings) <- makeSettingsAndServerState+ pure (serverConnectionCounter serverState, settings)++-- | Create 'defaultSettings' with a 'ServerState'.+-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState'+-- to gain insight into the state of the server.+--+-- Since 3.4.13+makeSettingsAndServerState :: IO (ServerState, Settings)+makeSettingsAndServerState = makeServerState defaultSettings -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur
+ Network/Wai/Handler/Warp/ShuttingDown.hs view
@@ -0,0 +1,34 @@+-- Most important is to not export the data constructor from this module+-- and to not expose 'writeShuttingDown' to the end user.+module Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ writeShuttingDown,+) where++import Control.Concurrent.STM (+ STM,+ TVar,+ atomically,+ newTVarIO,+ readTVar,+ readTVarIO,+ writeTVar,+ )++newtype ShuttingDown = ShuttingDown (TVar Bool)++newShuttingDown :: IO ShuttingDown+newShuttingDown = ShuttingDown <$> newTVarIO False++readShuttingDown :: ShuttingDown -> IO Bool+readShuttingDown (ShuttingDown var) = readTVarIO var++readShuttingDownSTM :: ShuttingDown -> STM Bool+readShuttingDownSTM (ShuttingDown var) = readTVar var++writeShuttingDown :: ShuttingDown -> Bool -> IO ()+writeShuttingDown (ShuttingDown var) b =+ atomically $ writeTVar var b
Network/Wai/Handler/Warp/Types.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Types where +import Control.Concurrent.STM (TVar)+import qualified Control.Exception as E import qualified Data.ByteString as S import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Typeable (Typeable)-import qualified Control.Exception as E #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -46,7 +45,7 @@ PayloadTooLarge | -- | Since 3.3.22 RequestHeaderFieldsTooLarge- deriving (Eq, Typeable)+ deriving (Eq) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs@@ -71,7 +70,7 @@ -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable. newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException- deriving (Show, Typeable)+ deriving (Show) instance E.Exception ExceptionInsideResponseBody @@ -130,6 +129,12 @@ , connHTTP2 :: IORef Bool -- ^ Is this connection HTTP/2? , connMySockAddr :: SockAddr+ , connAppsInProgress :: TVar Int+ -- ^ Amount of apps currently in progress on this connection.+ --+ -- /HTTP2 can handle more than one request concurrently/+ --+ -- @since 3.4.13 } getConnHTTP2 :: Connection -> IO Bool
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
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++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 (msRead, msWrite, withApp, withMySocket)+import Test.Hspec++spec :: Spec+spec = describe "Connection header" $ do+ 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+ 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"++parseHeaders :: ByteString -> [(ByteString, ByteString)]+parseHeaders bs =+ let allLines = S8.lines bs+ -- Drop status 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
+ 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/GracefulShutdownSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad (void)+import Network.HTTP.Client+import Network.HTTP.Types (ok200, status200)+import Network.Socket (close)+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = describe "graceful shutdown" $+ it "serves the request in flight, then closes keep-alive connections and exits" $ do+ shutdownSignal <- newEmptyMVar+ allowResponse <- newEmptyMVar+ receivedRequests <- newQSemN 0+ allowSecondRequest <- newEmptyMVar++ let installShutdownHandler closeListenSocket =+ void . forkIO $ do+ readMVar shutdownSignal+ closeListenSocket++ settings =+ setInstallShutdownHandler installShutdownHandler defaultSettings++ app _ respond = do+ -- signal 1 received request+ signalQSemN receivedRequests 1+ -- block until signaled+ readMVar allowResponse+ respond $ responseLBS status200 [("Content-Length", "0")] ""++ client sendRequest = do+ -- first request should return OK+ response <- sendRequest+ responseStatus response `shouldBe` ok200+ lookup "Connection" (responseHeaders response) `shouldBe` Just "close"+ -- wait with the second request+ void $ readMVar allowSecondRequest+ -- second request should end with connection refused+ sendRequest `shouldThrow` connectionRefused++ bracket openFreePort (close . snd) $ \(testPort, sock) ->+ withAsync (runSettingsSocket settings sock app) $ \server -> do+ manager <- newManager defaultManagerSettings+ request <- parseRequest ("http://127.0.0.1:" ++ show testPort)+ withAsync+ -- start all clients+ ( replicateConcurrently_ numClients $+ client (httpNoBody request manager)+ )+ $ \clients -> do+ -- wait for all clients to send requests+ waitQSemN receivedRequests numClients+ -- shutdown the server before serving requests+ putMVar shutdownSignal ()+ -- wait a little - otherwise some requests might not get+ -- Connection: close response header+ threadDelay 100_000+ -- let requests be handled+ putMVar allowResponse ()+ -- server should exit+ timeout 5_000_000 (wait server)+ >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure+ -- let clients proceed with the second request+ putMVar allowSecondRequest ()+ -- wait for all clients and propagate any exceptions+ wait clients+ where+ -- set number of clients to the number of keep-alive connections+ numClients = managerConnCount defaultManagerSettings+ connectionRefused = \case+ (HttpExceptionRequest _ (ConnectionFailure _)) -> True+ _ -> False
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
@@ -21,7 +21,7 @@ import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders)-import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp hiding (Counter) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec@@ -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
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module ServerStateSpec where++import Network.Wai.Handler.Warp (getServerState)+import Network.Wai.Handler.Warp.Counter (increase)+import Network.Wai.Handler.Warp.Settings (+ ServerState (..),+ currentOpenConnections,+ currentShuttingDownState,+ defaultSettings,+ makeServerState,+ newServerState,+ )+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "ServerState" $ do+ it "has the correct initialization" $ do+ ss <- newServerState+ currentOpenConnections ss `shouldReturn` 0+ currentShuttingDownState ss `shouldReturn` False+ describe "makeServerState" $ do+ it "has the same state in settings" $ do+ (outerSS, set) <- makeServerState defaultSettings+ case getServerState set of+ Nothing -> expectationFailure "'makeServerState' should set the 'ServerState'"+ Just innerSS -> do+ let bothCount i = do+ a <- currentOpenConnections outerSS+ b <- currentOpenConnections innerSS+ (a, b) `shouldBe` (i, i)+ increase $ serverConnectionCounter outerSS+ bothCount 1+ increase $ serverConnectionCounter innerSS+ bothCount 2+ let bothDown bool = do+ a <- currentShuttingDownState outerSS+ b <- currentShuttingDownState innerSS+ (a, b) `shouldBe` (bool, bool)+ writeShuttingDown (serverShuttingDown outerSS) True+ bothDown True+ writeShuttingDown (serverShuttingDown innerSS) False+ bothDown False+ it "is idempotent" $ do+ let incAndCheck ss i = do+ increase $ serverConnectionCounter ss+ currentOpenConnections ss `shouldReturn` i+ (ss1, set1) <- makeServerState defaultSettings+ incAndCheck ss1 1+ (ss2, _set2) <- makeServerState set1+ incAndCheck ss2 2+ incAndCheck ss1 3
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,19 +1,19 @@ cabal-version: >=1.10 name: warp-version: 3.4.10+version: 3.4.15 license: MIT license-file: LICENSE maintainer: michael@snoyman.com author: Michael Snoyman, Kazu Yamamoto, Matt Brown stability: Stable-homepage: http://github.com/yesodweb/wai+homepage: https://github.com/yesodweb/wai synopsis: A fast, light-weight web server for WAI applications. description: HTTP\/1.0, HTTP\/1.1 and HTTP\/2 are supported. For HTTP\/2, Warp supports direct and ALPN (in TLS) but not upgrade. API docs and the README are available at- <http://www.stackage.org/package/warp>.+ <https://www.stackage.org/package/warp>. category: Web, Yesod build-type: Simple@@ -26,7 +26,8 @@ source-repository head type: git- location: git://github.com/yesodweb/wai.git+ location: https://github.com/yesodweb/wai.git+ subdir: warp flag network-bytestring default: False@@ -85,6 +86,7 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication@@ -96,17 +98,16 @@ ghc-options: -Wall build-depends: base >=4.12 && <5,- array, auto-update >=0.2.2 && <0.3, async >= 2, bsb-http-chunked <0.1, bytestring >=0.9.1.4, case-insensitive >=0.2, containers,- ghc-prim, 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,@@ -114,9 +115,9 @@ stm >=2.3, streaming-commons >=0.1.10, text,- time-manager >=0.2 && <0.3,+ 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)@@ -178,10 +179,14 @@ build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test . other-modules:+ BufferSpec ConduitSpec+ ConnectionSpec+ EarlyHintsSpec ExceptionSpec FdCacheSpec FileSpec+ GracefulShutdownSpec HTTP PackIntSpec ReadIntSpec@@ -190,6 +195,7 @@ ResponseSpec RunSpec SendFileSpec+ ServerStateSpec WithApplicationSpec Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Internal@@ -220,6 +226,7 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication@@ -232,7 +239,6 @@ build-depends: base >=4.8 && <5, QuickCheck,- array, auto-update, async, bsb-http-chunked <0.1,@@ -240,12 +246,12 @@ case-insensitive >=0.2, containers, directory,- ghc-prim, hashable, hspec >=1.3, http-client, http-date, http-types >=0.12,+ http-semantics >=0.4 && <0.5, http2 >=5.4 && <5.5, iproute >=1.3.1, network,@@ -257,7 +263,9 @@ text, time-manager, vault,- wai >=3.2.2.1 && <3.3,+ wai >=3.2.5 && <3.3,+ -- workaround: this should be unnecessary+ warp, word8 if flag(x509)@@ -289,18 +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)@@ -309,19 +325,22 @@ default-language: Haskell2010 build-depends: base >=4.8 && <5,- array,+ async, auto-update,+ bsb-http-chunked, bytestring, case-insensitive, containers, criterion,- ghc-prim, hashable, http-date, http-types,- network,+ http2,+ iproute, network, recv,+ simple-sendfile,+ stm, streaming-commons, text, time-manager,