warp 3.4.12 → 3.4.21

raw patch · 39 files changed

Files

• ChangeLog.md +161/−1
• Network/Wai/Handler/Warp.hs +111/−37
• Network/Wai/Handler/Warp/Conduit.hs +99/−64
• Network/Wai/Handler/Warp/Counter.hs +58/−22
• Network/Wai/Handler/Warp/FdCache.hs +17/−13
• Network/Wai/Handler/Warp/File.hs +58/−39
• Network/Wai/Handler/Warp/HTTP1.hs +1/−1
• Network/Wai/Handler/Warp/HTTP2.hs +59/−18
• Network/Wai/Handler/Warp/HTTP2/File.hs +1/−1
• Network/Wai/Handler/Warp/HTTP2/Request.hs +19/−10
• Network/Wai/Handler/Warp/Header.hs +119/−101
• Network/Wai/Handler/Warp/IO.hs +39/−9
• Network/Wai/Handler/Warp/Internal.hs +37/−2
• Network/Wai/Handler/Warp/PackInt.hs +14/−2
• Network/Wai/Handler/Warp/Request.hs +102/−30
• Network/Wai/Handler/Warp/RequestHeader.hs +64/−6
• Network/Wai/Handler/Warp/Response.hs +206/−123
• Network/Wai/Handler/Warp/ResponseHeader.hs +29/−7
• Network/Wai/Handler/Warp/Run.hs +288/−85
• Network/Wai/Handler/Warp/SendFile.hs +2/−2
• Network/Wai/Handler/Warp/Settings.hs +180/−33
• Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
• Network/Wai/Handler/Warp/Types.hs +48/−8
• bench/Parser.hs +16/−0
• bench/ResponseBench.hs +124/−0
• test/BufferSpec.hs +38/−0
• test/ConnectionExceptionSpec.hs +130/−0
• test/ConnectionSpec.hs +61/−54
• test/EarlyHintsSpec.hs +77/−0
• test/FileSpec.hs +26/−0
• test/GracefulShutdownSpec.hs +203/−0
• test/HTTP2Spec.hs +75/−0
• test/PackIntSpec.hs +6/−0
• test/ResponseSpec.hs +29/−29
• test/RunSpec.hs +338/−28
• test/SendFileSpec.hs +10/−8
• test/ServerStateSpec.hs +64/−0
• test/WithApplicationSpec.hs +9/−3
• warp.cabal +108/−18

@@ -1,9 +1,169 @@ # ChangeLog for warp +## 3.4.21++Requires network 3.2.12.++* `setUnsafeClose` closes connections with network's `unsafeClose` and+  `unsafeGracefulClose`.  Off by default, since a `responseRaw`+  application may leave threads on the socket.+* The listening socket is closed with `unsafeClose` once the accept loop+  has ended.+* Sends use network's `sendAllWith` on every platform, so the timeout+  reaches a send on Windows too.+* An HTTP/2 connection which ends normally is no longer reported to+  `settingsOnException` as http2's `ConnectionIsClosed`; the default+  printed it for every such connection.++## 3.4.20++* Building with GHC 9.0 again.+  [#1161](https://github.com/yesodweb/wai/issues/1161)++## 3.4.19++* Security: `Host` is validated.  A HTTP/1.1 request without one, and any+  request with more than one, is refused: a router reading the first and an+  application reading `requestHeaderHost` could disagree about which host a+  request was for.+  [#1152](https://github.com/yesodweb/wai/issues/1152)+* Security: a `Range` which does not begin inside the file is answered 416,+  rather than dropping the connection with no answer at all.+  [#1153](https://github.com/yesodweb/wai/issues/1153)+* Security: `packIntegral` counts its digits by division.  The `Double`+  logarithm it used was one short from 10^15 up, and the last digit was+  written before the buffer.+  [#1154](https://github.com/yesodweb/wai/issues/1154)+* Security: the HTTP/2 connection a GOAWAY for weak TLS ends is no longer+  served afterwards, and that GOAWAY now follows the SETTINGS frame which+  RFC 9113 has a server send first.+  [#1155](https://github.com/yesodweb/wai/issues/1155)+* Security: the HTTP/2 `response` continuation is not called a second time+  when an application throws after its response has gone out.+  [#1156](https://github.com/yesodweb/wai/issues/1156)+* `InvalidRequest` gains `BadHost`.+  [#1152](https://github.com/yesodweb/wai/issues/1152)+* Validate field names with a lookup table.+  [#1157](https://github.com/yesodweb/wai/issues/1157)++## 3.4.18++`Internal` gains `Listener (..)`, `noListener`, `makeListener`,+`AcceptStopped (..)` and `runSettingsConnectionMakerSecureWith`.  Requires+network 3.2.10, recv 0.1.3 and time-manager 0.5.++* Event poll for accept loop.+  [#1123](https://github.com/yesodweb/wai/pull/1123)+* Give up on the accept and the receive rather than interrupt them.+  [#1143](https://github.com/yesodweb/wai/pull/1143)+* recv: a receive the caller can give up on.+  [#1142](https://github.com/yesodweb/wai/pull/1142)+* warp: let the thread manager own the connections.+  [#1128](https://github.com/yesodweb/wai/pull/1128)++## 3.4.17++* Security: `Transfer-Encoding` is read as the comma separated list RFC 9112+  defines, and a framing warp and a proxy could read differently is refused.+  [#1147](https://github.com/yesodweb/wai/issues/1147)+* Security: a `Content-Length` must be digits which fit in an `Int` and+  repeated ones must agree.+  [#1148](https://github.com/yesodweb/wai/issues/1148)+* Security: a header field name must be a non-empty token, which also refuses+  obs-fold continuation lines.+  [#1149](https://github.com/yesodweb/wai/issues/1149)+* Security: a bare CR or a NUL in a header field line is refused.+  [#1151](https://github.com/yesodweb/wai/issues/1151)+* Security: the chunked body parser keeps to RFC 9112: chunk sizes, the CRLF+  after a chunk, size lines split over several reads, and the trailer section.+  [#1150](https://github.com/yesodweb/wai/issues/1150)+* warp: a chunked request body cut off mid-chunk reaches the application as+  complete.+  [#1129](https://github.com/yesodweb/wai/issues/1129)+* `InvalidRequest` gains `UnsupportedTransferEncoding`, `AmbiguousBodyLength`,+  `BadFieldName`, `BadHeaderLine` and `BadChunkedBody`, one for each of the+  five above.+* Allow time-manager 0.5.++## 3.4.16++* Graceful shutdown no longer stops while a connection it accepted is+  unserved. The connection counter it waits on is now raised when the accept+  loop accepts a connection rather than when the thread serving it is+  scheduled, closing a window in which an accepted connection was invisible+  to the shutdown.+  [#1104](https://github.com/yesodweb/wai/pull/1104).+* Slight performance increase by not blocking on receiving a request if the+  socket already has bytes waiting. (using `receiveNoWait` from `recv-0.1.2`)+  [#1107](https://github.com/yesodweb/wai/pull/1107).+* Reviewed when to introduce memory barriers when handling `IORef`s.+  Documented most usage and introduced memory barriers in situations that might+  possibly be used in more than one thread.+  [#1112](https://github.com/yesodweb/wai/pull/1112).+* Add `setOnConnectionException` and `getOnConnectionException` to expose the+  peer for exceptions escaping connection workers, including TLS setup failures+  before a request exists. The existing exception observer remains the default.+  [#1114](https://github.com/yesodweb/wai/pull/1114)+  (fixes [#1113](https://github.com/yesodweb/wai/issues/1113))++## 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)+  [#958](https://github.com/yesodweb/wai/pull/958)  ## 3.4.11 

@@ -52,6 +52,7 @@     setPort,     setHost,     setOnException,+    setOnConnectionException,     setOnExceptionResponse,     setOnOpen,     setOnClose,@@ -79,6 +80,7 @@     setMaxTotalHeaderLength,     setAltSvc,     setMaxBuilderResponseBufferSize,+    setUnsafeClose,      -- ** Getters     getPort,@@ -86,12 +88,33 @@     getOnOpen,     getOnClose,     getOnException,+    getOnConnectionException,     getGracefulShutdownTimeout,     getGracefulCloseTimeout1,     getGracefulCloseTimeout2,     getOpenConnectionCounter,+    getServerState,+    getUnsafeClose, +    -- ** 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,@@ -173,24 +196,39 @@  -- | Port to listen on. Default value: 3000 ----- Since 2.1.0+-- @since 2.1.0 setPort :: Port -> Settings -> Settings setPort x y = y{settingsPort = x}  -- | Interface to bind to. Default value: HostIPv4 ----- Since 2.1.0+-- @since 2.1.0 setHost :: HostPreference -> Settings -> Settings setHost x y = y{settingsHost = x}  -- | What to do with exceptions thrown by either the application or server. -- Default: 'defaultOnException' ----- Since 2.1.0+-- @since 2.1.0 setOnException     :: (Maybe Request -> SomeException -> IO ()) -> Settings -> Settings setOnException x y = y{settingsOnException = x} +-- | Handle exceptions escaping a connection worker, with the address supplied+-- by its connection source. This includes connection creation (such as a TLS+-- handshake) and cleanup failures, even when no 'Request' exists. For socket+-- listeners this is the accepted TCP peer, before any PROXY protocol rewriting.+--+-- When installed, this handler receives these exceptions instead of the+-- handler configured with 'setOnException'. Request-specific exceptions and+-- accept-loop failures still use that handler. By default, worker exceptions+-- go to that handler too, with 'Nothing' as its @Maybe Request@ argument+-- because no request context is available at this boundary.+--+-- @since 3.4.16+setOnConnectionException :: (SockAddr -> SomeException -> IO ()) -> Settings -> Settings+setOnConnectionException report settings = settings{settingsOnConnectionException = Just report}+ -- | A function to create a `Response` when an exception occurs. -- Default: 'defaultOnExceptionResponse' --@@ -204,7 +242,7 @@ -- > response500 :: Request -> SomeException -> Response -- > response500 req someEx = responseLBS status500 -- ... ----- Since 2.1.0+-- @since 2.1.0 setOnExceptionResponse :: (SomeException -> Response) -> Settings -> Settings setOnExceptionResponse x y = y{settingsOnExceptionResponse = x} @@ -212,13 +250,13 @@ -- connection is closed immediately. Otherwise, the connection is going on. -- Default: always returns 'True'. ----- Since 2.1.0+-- @since 2.1.0 setOnOpen :: (SockAddr -> IO Bool) -> Settings -> Settings setOnOpen x y = y{settingsOnOpen = x}  -- | What to do when a connection is closed. Default: do nothing. ----- Since 2.1.0+-- @since 2.1.0 setOnClose :: (SockAddr -> IO ()) -> Settings -> Settings setOnClose x y = y{settingsOnClose = x} @@ -230,14 +268,14 @@ -- -- Default value: 30 ----- Since 2.1.0+-- @since 2.1.0 setTimeout :: Int -> Settings -> Settings setTimeout x y = y{settingsTimeout = x}  -- | Use an existing timeout manager instead of spawning a new one. If used, -- 'settingsTimeout' is ignored. ----- Since 2.1.0+-- @since 2.1.0 setManager :: Manager -> Settings -> Settings setManager x y = y{settingsManager = Just x} @@ -253,7 +291,7 @@ -- -- Default value: 0, was previously 10 ----- Since 3.0.13+-- @since 3.0.13 setFdCacheDuration :: Int -> Settings -> Settings setFdCacheDuration x y = y{settingsFdCacheDuration = x} @@ -277,7 +315,7 @@ -- -- Default: do nothing. ----- Since 2.1.0+-- @since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings setBeforeMainLoop x y = y{settingsBeforeMainLoop = x} @@ -287,19 +325,19 @@ -- -- Default: False ----- Since 2.1.0+-- @since 2.1.0 setNoParsePath :: Bool -> Settings -> Settings setNoParsePath x y = y{settingsNoParsePath = x}  -- | Get the listening port. ----- Since 2.1.1+-- @since 2.1.1 getPort :: Settings -> Port getPort = settingsPort  -- | Get the interface to bind to. ----- Since 2.1.1+-- @since 2.1.1 getHost :: Settings -> HostPreference getHost = settingsHost @@ -315,9 +353,18 @@ getOnException :: Settings -> Maybe Request -> SomeException -> IO () getOnException = settingsOnException +-- | Get the handler installed with 'setOnConnectionException'.+-- If none was installed, the returned function ignores the peer address and+-- calls the handler configured with 'setOnException', passing 'Nothing' as+-- its @Maybe Request@ argument and forwarding the exception.+--+-- @since 3.4.16+getOnConnectionException :: Settings -> SockAddr -> SomeException -> IO ()+getOnConnectionException = onConnectionException+ -- | Get the graceful shutdown timeout ----- Since 3.2.8+-- @since 3.2.8 getGracefulShutdownTimeout :: Settings -> Maybe Int getGracefulShutdownTimeout = settingsGracefulShutdownTimeout @@ -351,7 +398,7 @@ -- -- Default: does not install any code. ----- Since 3.0.1+-- @since 3.0.1 setInstallShutdownHandler :: (IO () -> IO ()) -> Settings -> Settings setInstallShutdownHandler x y = y{settingsInstallShutdownHandler = x} @@ -360,7 +407,7 @@ --   If an empty string is set, the \"Server:\" header is not sent. --   This is true even if an application set one. ----- Since 3.0.2+-- @since 3.0.2 setServerName :: ByteString -> Settings -> Settings setServerName x y = y{settingsServerName = x} @@ -375,7 +422,7 @@ -- -- Default: 8192 bytes. ----- Since 3.0.3+-- @since 3.0.3 setMaximumBodyFlush :: Maybe Int -> Settings -> Settings setMaximumBodyFlush x y     | Just x' <- x, x' < 0 = error "setMaximumBodyFlush: must be positive"@@ -388,7 +435,7 @@ -- -- Default: void . forkIOWithUnmask ----- Since 3.0.4+-- @since 3.0.4 setFork     :: (((forall a. IO a -> IO a) -> IO ()) -> IO ()) -> Settings -> Settings setFork fork' s = s{settingsFork = fork'}@@ -400,13 +447,13 @@ -- -- Default: 'defaultAccept' ----- Since 3.3.24+-- @since 3.3.24 setAccept :: (Socket -> IO (Socket, SockAddr)) -> Settings -> Settings setAccept accept' s = s{settingsAccept = accept'}  -- | Do not use the PROXY protocol. ----- Since 3.0.5+-- @since 3.0.5 setProxyProtocolNone :: Settings -> Settings setProxyProtocolNone y = y{settingsProxyProtocol = ProxyProtocolNone} @@ -422,7 +469,7 @@ -- Only the human-readable header format (version 1) is supported. The binary -- header format (version 2) is /not/ supported. ----- Since 3.0.5+-- @since 3.0.5 setProxyProtocolRequired :: Settings -> Settings setProxyProtocolRequired y = y{settingsProxyProtocol = ProxyProtocolRequired} @@ -438,25 +485,25 @@ -- HTTP without the PROXY header, but proxied -- connections /do/ include the PROXY header. ----- Since 3.0.5+-- @since 3.0.5 setProxyProtocolOptional :: Settings -> Settings setProxyProtocolOptional y = y{settingsProxyProtocol = ProxyProtocolOptional}  -- | Size in bytes read to prevent Slowloris attacks. Default value: 2048 ----- Since 3.1.2+-- @since 3.1.2 setSlowlorisSize :: Int -> Settings -> Settings setSlowlorisSize x y = y{settingsSlowlorisSize = x}  -- | Disable HTTP2. ----- Since 3.1.7+-- @since 3.1.7 setHTTP2Disabled :: Settings -> Settings setHTTP2Disabled y = y{settingsHTTP2Enabled = False}  -- | Setting a log function. ----- Since 3.X.X+-- @since 3.X.X setLogger     :: (Request -> H.Status -> Maybe Integer -> IO ())     -- ^ request, status, maybe file-size@@ -482,7 +529,7 @@ -- 'setInstallShutdownHandler' for an example of how this could be done in -- response to a UNIX signal. ----- Since 3.2.8+-- @since 3.2.8 setGracefulShutdownTimeout     :: Maybe Int     -> Settings@@ -491,7 +538,7 @@  -- | Set the maximum header size that Warp will tolerate when using HTTP/1.x. ----- Since 3.3.8+-- @since 3.3.8 setMaxTotalHeaderLength :: Int -> Settings -> Settings setMaxTotalHeaderLength maxTotalHeaderLength settings =     settings@@ -500,22 +547,30 @@  -- | Setting the header value of Alternative Services (AltSvc:). ----- Since 3.3.11+-- @since 3.3.11 setAltSvc :: ByteString -> Settings -> Settings setAltSvc altsvc settings = settings{settingsAltSvc = Just altsvc}  -- | Set the maximum buffer size for sending `Builder` responses. ----- Since 3.3.22+-- @since 3.3.22 setMaxBuilderResponseBufferSize :: Int -> Settings -> Settings setMaxBuilderResponseBufferSize maxRspBufSize settings = settings{settingsMaxBuilderResponseBufferSize = maxRspBufSize} +-- | Close connections with network's 'unsafeClose' and+--   'unsafeGracefulClose'.  See 'settingsUnsafeClose' for when it is safe.+--   Default: 'False'.+--+-- @since 3.4.21+setUnsafeClose :: Bool -> Settings -> Settings+setUnsafeClose x y = y{settingsUnsafeClose = x}+ -- | Explicitly pause the slowloris timeout. -- -- This is useful for cases where you partially consume a request body. For -- more information, see <https://github.com/yesodweb/wai/issues/351> ----- Since 3.0.10+-- @since 3.0.10 pauseTimeout :: Request -> IO () pauseTimeout = fromMaybe (return ()) . Vault.lookup pauseTimeoutKey . vault @@ -534,7 +589,7 @@ --   If this function is used an a Request generated by a WAI --   backend besides Warp, it also throws an 'IO' exception. ----- Since 3.1.10+-- @since 3.1.10 getFileInfo :: Request -> FilePath -> IO FileInfo getFileInfo =     fromMaybe (\_ -> throwIO (userError "getFileInfo"))@@ -545,14 +600,14 @@ --   FIN for HTTP/1.x. 0 means uses immediate close. --   Default: 0. ----- Since 3.3.5+-- @since 3.3.5 setGracefulCloseTimeout1 :: Int -> Settings -> Settings setGracefulCloseTimeout1 x y = y{settingsGracefulCloseTimeout1 = x}  -- | A timeout to limit the time (in milliseconds) waiting for --   FIN for HTTP/1.x. 0 means uses immediate close. ----- Since 3.3.5+-- @since 3.3.5 getGracefulCloseTimeout1 :: Settings -> Int getGracefulCloseTimeout1 = settingsGracefulCloseTimeout1 @@ -560,14 +615,14 @@ --   FIN for HTTP/2. 0 means uses immediate close. --   Default: 2000. ----- Since 3.3.5+-- @since 3.3.5 setGracefulCloseTimeout2 :: Int -> Settings -> Settings setGracefulCloseTimeout2 x y = y{settingsGracefulCloseTimeout2 = x}  -- | A timeout to limit the time (in milliseconds) waiting for --   FIN for HTTP/2. 0 means uses immediate close. ----- Since 3.3.5+-- @since 3.3.5 getGracefulCloseTimeout2 :: Settings -> Int getGracefulCloseTimeout2 = settingsGracefulCloseTimeout2 @@ -576,14 +631,33 @@ -- -- See 'makeSettingsAndCounter' to create settings with a counter. ----- Since 3.4.11+-- /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++-- | Whether connections are closed with network's 'unsafeClose' and+--   'unsafeGracefulClose'.+--+-- @since 3.4.21+getUnsafeClose :: Settings -> Bool+getUnsafeClose = settingsUnsafeClose+ #ifdef MIN_VERSION_crypton_x509 -- | Getting information of client certificate. ----- Since 3.3.5+-- @since 3.3.5 clientCertificate :: Request -> Maybe CertificateChain clientCertificate = join . Vault.lookup getClientCertificateKey . vault #endif

@@ -5,7 +5,7 @@ import Control.Exception (assert, throwIO) import qualified Data.ByteString as S import qualified Data.IORef as I-import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf)+import Data.Word8 (_0, _9, _A, _F, _a, _cr, _f, _lf, _semicolon)  import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types@@ -41,6 +41,10 @@                 -- How many bytes will still remain to be sent downstream                 count' = count - toSend +            -- [WRITE_IOREF_NOTE]+            -- This doesn't need to be "atomic", since it is only used in+            -- 'recvRequest', which creates the 'Source' and doesn't fork it,+            -- so the 'IORef' is not shared outside of 'recvRequest'.             I.writeIORef ref count'              if count' > 0@@ -74,20 +78,40 @@     ref <- I.newIORef NeedLen     return $! CSource src ref +-- | A chunk-size line is a few bytes of hex, and chunk extensions are+--   all but unused; a trailer section is a handful of fields. Neither is+--   a reason to hold on to everything a client cares to send.+maxChunkLineLength :: Int+maxChunkLineLength = 1024++maxTrailerLength :: Int+maxTrailerLength = 8192+ readCSource :: CSource -> IO ByteString readCSource (CSource src ref) = do     mlen <- I.readIORef ref     go mlen   where-    withLen 0 bs = do-        leftoverSource src bs-        dropCRLF-        yield' S.empty DoneChunking+    go NeedLen = getLen+    go NeedLenNewline = dropCRLF >> getLen+    go (HaveLen len) = readSource src >>= withLen len+    go DoneChunking = return S.empty++    getLen = do+        len <- chunkSize =<< requireLine+        if len == 0+            then do+                -- Everything up to the empty line which ends the trailer+                -- section belongs to this request. Warp used to drop one+                -- CRLF and leave the trailers in the source, where they+                -- were read as the next request on the connection.+                dropTrailers 0+                yield' S.empty DoneChunking+            else readSource src >>= withLen len+     withLen len bs-        | S.null bs = do-            -- FIXME should this throw an exception if len > 0?-            I.writeIORef ref DoneChunking-            return S.empty+        -- The chunk promised more than the client went on to send.+        | S.null bs = throwIO ConnectionClosedByPeer         | otherwise =             case S.length bs `compare` fromIntegral len of                 EQ -> yield' bs NeedLenNewline@@ -98,67 +122,78 @@                     yield' x NeedLenNewline      yield' bs mlen = do-        I.writeIORef ref mlen+        I.writeIORef ref mlen -- [WRITE_IOREF_NOTE]         return bs -    dropCRLF = do-        bs <- readSource src-        case S.uncons bs of-            Nothing -> return ()-            Just (w8, bs')-                | w8 == _cr -> dropLF bs'-                | w8 == _lf -> leftoverSource src bs'-                | otherwise -> leftoverSource src bs+    -- A chunk size is 1*HEXDIG, with nothing after it but chunk+    -- extensions. Warp used to fold whatever hex digits it could find+    -- and take 0 for the rest, so a line which is no chunk size at all+    -- -- a request line, say -- ended the body and left the rest of it+    -- to be read as the next request.+    chunkSize line+        | S.null digits = throwIO BadChunkedBody+        | not (S.null ext), S.head ext /= _semicolon = throwIO BadChunkedBody+        | otherwise =+            maybe (throwIO BadChunkedBody) (return . fromIntegral) $+                S.foldl' accumulate (Just (0 :: Int)) digits+      where+        (digits, ext) = S.span isHexDigit line+        accumulate Nothing _ = Nothing+        -- A chunk warp cannot measure is a chunk warp cannot read.+        accumulate (Just n) w+            | n > (maxBound - d) `div` 16 = Nothing+            | otherwise = Just $! n * 16 + d+          where+            d = fromIntegral (hexToWord w) -    dropLF bs =-        case S.uncons bs of-            Nothing -> do-                bs2 <- readSource' src-                unless (S.null bs2) $ dropLF bs2-            Just (w8, bs') ->-                leftoverSource src $-                    if w8 == _lf then bs' else bs+    -- The CRLF which ends chunk-data. Warp used to put anything else+    -- back and read it as the next chunk size, so a chunk that was not+    -- closed off ended the body early.+    dropCRLF = do+        line <- requireLine+        unless (S.null line) $ throwIO BadChunkedBody -    go NeedLen = getLen-    go NeedLenNewline = dropCRLF >> getLen-    go (HaveLen 0) = do-        -- Drop the final CRLF-        dropCRLF-        I.writeIORef ref DoneChunking-        return S.empty-    go (HaveLen len) = do-        bs <- readSource src-        withLen len bs-    go DoneChunking = return S.empty+    dropTrailers total = do+        mline <- readLine+        case mline of+            -- A client which leaves out the last CRLF and closes has+            -- nothing left to hide behind it.+            Nothing -> return ()+            Just line -> unless (S.null line) $ do+                let total' = total + S.length line+                when (total' > maxTrailerLength) $ throwIO OverLargeHeader+                dropTrailers total' -    -- Get the length from the source, and then pass off control to withLen-    getLen = do-        bs <- readSource src-        if S.null bs-            then do-                I.writeIORef ref $ assert False $ HaveLen 0-                return S.empty-            else do-                (x, y) <--                    case S.break (== _lf) bs of-                        (x, y)-                            | S.null y -> do-                                bs2 <- readSource' src-                                return $-                                    if S.null bs2-                                        then (x, y)-                                        else S.break (== _lf) $ bs `S.append` bs2-                            | otherwise -> return (x, y)-                let w =-                        S.foldl' (\i c -> i * 16 + fromIntegral (hexToWord c)) 0 $-                            S.takeWhile isHexDigit x+    requireLine = readLine >>= maybe (throwIO ConnectionClosedByPeer) return -                let y' = S.drop 1 y-                y'' <--                    if S.null y'-                        then readSource src-                        else return y'-                withLen w y''+    -- One line of the chunked framing: up to the next LF, without it or+    -- the CR before it, leaving the rest of what was read in the source.+    -- 'Nothing' when the connection ends where a line was to begin.+    -- Warp used to give up one read short of the LF, which mis-read+    -- every size line that arrived in more than two pieces.+    readLine = loop 0 id+      where+        loop total front = do+            bs <- readSource src+            if S.null bs+                then+                    if total == 0+                        then return Nothing+                        else throwIO ConnectionClosedByPeer+                else case S.elemIndex _lf bs of+                    Nothing -> do+                        let total' = total + S.length bs+                        when (total' > maxChunkLineLength) $ throwIO OverLargeHeader+                        loop total' (front . (bs :))+                    Just ix -> do+                        leftoverSource src $ S.drop (ix + 1) bs+                        let line = S.concat $ front [S.take ix bs]+                        when (S.length line > maxChunkLineLength) $+                            throwIO OverLargeHeader+                        return $ Just $ dropCR line+        dropCR bs = case S.unsnoc bs of+            Just (bs', w) | w == _cr -> bs'+            _ -> bs      hexToWord w         | w <= _9 = w - _0

@@ -1,44 +1,80 @@-{-# LANGUAGE CPP #-}+{-# LANGUAGE RankNTypes #-}  module Network.Wai.Handler.Warp.Counter (     Counter,     newCounter,+    HasDecreased (..),     waitForZero,-    increase,-    decrease,+    forkConnection,     waitForDecreased,     getCount,+    getCountSTM,+    threadManager, ) where  import Control.Concurrent.STM--import Network.Wai.Handler.Warp.Imports+import System.ThreadManager (+    ThreadManager,+    countManaged,+    forkManagedBy,+    newThreadManager,+    waitUntilAllGone,+ ) -newtype Counter = Counter (TVar Int)+-- | The connections of a server: how many there are, and which threads+--   are serving them.+--+--   Both come from the 'ThreadManager', which counts a connection from+--   when the accept loop keeps a place for it -- before the thread that+--   will serve it has been scheduled, which is too late for a graceful+--   shutdown to notice it.+newtype Counter = Counter ThreadManager  newCounter :: IO Counter-newCounter = Counter <$> newTVarIO 0+newCounter = Counter <$> newThreadManager +-- | The manager owning the connections, for supervising them.+threadManager :: Counter -> ThreadManager+threadManager (Counter tm) = tm+ waitForZero :: Counter -> IO ()-waitForZero (Counter var) = atomically $ do-    x <- readTVar var-    when (x > 0) retry+waitForZero (Counter tm) = waitUntilAllGone tm -waitForDecreased :: Counter -> IO ()-waitForDecreased (Counter var) = do-    n0 <- atomically $ readTVar var-    atomically $ do-        n <- readTVar var-        check (n < n0)+data HasDecreased = HasDecreased | NoConnections+    deriving (Eq, Show) -increase :: Counter -> IO ()-increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1+waitForDecreased :: Counter -> IO HasDecreased+waitForDecreased (Counter tm) = do+    n0 <- atomically $ countManaged tm+    if n0 <= 0+        then pure NoConnections+        else atomically $ do+            n <- countManaged tm+            check (n < n0)+            pure HasDecreased -decrease :: Counter -> IO ()-decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1+-- | Serving a connection on a thread made by the given fork.  The+--   connection is counted from here rather than from when that thread+--   starts: the accept loop does not wait for it, and a connection which+--   has been accepted must not look to 'waitForZero' like one that is+--   gone.+forkConnection+    :: Counter+    -> (((forall x. IO x -> IO x) -> IO ()) -> IO ())+    -- ^ The fork from the settings+    -> ((forall x. IO x -> IO x) -> IO ())+    -- ^ Serving the connection+    -> IO ()+forkConnection (Counter tm) fork io = forkManagedBy tm fork "Warp just forked" io  -- | Get the current count of open connections. ----- Since 3.4.11+-- @since 3.4.11 getCount :: Counter -> IO Int-getCount (Counter var) = readTVarIO var+getCount = atomically . getCountSTM++-- | Get the current count in an 'STM' transaction.+--+-- @since 3.4.13+getCountSTM :: Counter -> STM Int+getCountSTM (Counter tm) = countManaged tm

@@ -46,12 +46,13 @@ #ifdef WINDOWS withFdCache _ action = action getFdNothing #else-withFdCache 0 action = action getFdNothing-withFdCache duration action =-    bracket-        (initialize duration)-        terminate-        (action . getFd)+withFdCache duration action+    | duration <= 0 = action getFdNothing+    | otherwise =+        bracket+            (initialize duration)+            terminate+            (action . getFd)  ---------------------------------------------------------------- @@ -66,10 +67,10 @@ newActiveStatus = MutableStatus <$> newIORef Active  refresh :: MutableStatus -> Refresh-refresh (MutableStatus ref) = writeIORef ref Active+refresh (MutableStatus ref) = atomicWriteIORef ref Active  inactive :: MutableStatus -> IO ()-inactive (MutableStatus ref) = writeIORef ref Inactive+inactive (MutableStatus ref) = atomicWriteIORef ref Inactive  ---------------------------------------------------------------- @@ -146,13 +147,16 @@  -- | Getting 'Fd' and 'Refresh' from the mutable Fd cacher. getFd :: MutableFdCache -> FilePath -> IO (Maybe Fd, Refresh)-getFd mfc@(MutableFdCache reaper) path = look mfc path >>= get+getFd mfc@(MutableFdCache reaper) path = do+    mEnt <- look mfc path+    entryToResult <$> get mEnt   where+    entryToResult (FdEntry fd mst) = (Just fd, refresh mst)     get Nothing = do-        ent@(FdEntry fd mst) <- newFdEntry path+        ent <- newFdEntry path         reaperAdd reaper (path, ent)-        return (Just fd, refresh mst)-    get (Just (FdEntry fd mst)) = do+        pure ent+    get (Just ent@(FdEntry _ mst)) = do         refresh mst-        return (Just fd, refresh mst)+        pure ent #endif

@@ -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 @@ -130,28 +139,35 @@  parseRange :: ByteString -> Integer -> RspFileInfo parseRange rng size = case H.parseByteRanges rng of-    Nothing -> WithoutBody H.requestedRangeNotSatisfiable416-    Just [] -> WithoutBody H.requestedRangeNotSatisfiable416-    Just (r : _) ->-        let (!beg, !end) = checkRange r size-            !len = end - beg + 1+    Just (r : _) | Just (!beg, !end) <- checkRange r size ->+        let !len = end - beg + 1             s =                 if beg == 0 && end == size - 1                     then H.ok200                     else H.partialContent206          in WithBody s [] beg len+    _ -> WithoutBody H.requestedRangeNotSatisfiable416 -checkRange :: H.ByteRange -> Integer -> (Integer, Integer)-checkRange (H.ByteRangeFrom beg) size = (beg, size - 1)-checkRange (H.ByteRangeFromTo beg end) size = (beg, min (size - 1) end)-checkRange (H.ByteRangeSuffix count) size = (max 0 (size - count), size - 1)+-- | The first and last byte a range asks for, or 'Nothing' when it asks+--   for nothing the file holds, which RFC 9110 section 14.4 answers with+--   416.+checkRange :: H.ByteRange -> Integer -> Maybe (Integer, Integer)+checkRange (H.ByteRangeFrom beg) size+    | beg < 0 || beg >= size = Nothing+    | otherwise = Just (beg, size - 1)+checkRange (H.ByteRangeFromTo beg end) size+    | beg < 0 || beg > end || beg >= size = Nothing+    | otherwise = Just (beg, min (size - 1) end)+checkRange (H.ByteRangeSuffix count) size+    | count <= 0 || size <= 0 = Nothing+    | otherwise = Just (max 0 (size - count), size - 1)  ----------------------------------------------------------------  -- | @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 +199,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  -- | --

@@ -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

@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -13,6 +14,7 @@ import Data.IORef (readIORef) import qualified Data.IORef as I import GHC.Conc.Sync (labelThread, myThreadId)+import qualified Network.HTTP2.Client as H2C import qualified Network.HTTP2.Frame as H2 import qualified Network.HTTP2.Server as H2 import Network.Socket (SockAddr)@@ -29,6 +31,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@@ -65,19 +75,32 @@                 , H2.confPeerSockAddr = peersa                 , H2.confReadNTimeout = True                 }-    checkTLS+    ok <- checkTLS     setConnHTTP2 conn True-    H2.run H2.defaultServerConfig conf $-        http2server "Warp HTTP/2" settings ii transport peersa app+    when ok $+        endedNormally $+            H2.run H2.defaultServerConfig conf $+                http2server "Warp HTTP/2" settings ii transport peersa app   where+    -- http2 ends a connection which has run its course with+    -- 'ConnectionIsClosed', which is no exception to report.+    endedNormally = E.handle $ \e -> case e of+        H2C.ConnectionIsClosed -> return ()+        _ -> E.throwIO e+    -- A GOAWAY ends the connection, so there is nothing left to serve+    -- on it.     checkTLS = case transport of-        TCP -> return () -- direct-        tls -> unless (tls12orLater tls) $ goaway conn H2.InadequateSecurity "Weak TLS"+        TCP -> return True -- direct+        tls+            | tls12orLater tls -> return True+            | otherwise -> do+                goaway conn H2.InadequateSecurity "Weak TLS"+                return False     tls12orLater tls = tlsMajorVersion tls == 3 && tlsMinorVersion tls >= 3  -- | Converting WAI application to the server type of http2 library. ----- Since 3.3.11+-- @since 3.3.11 http2server     :: String     -> S.Settings@@ -89,7 +112,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@@ -97,22 +125,31 @@         I.writeIORef ref $ Just (h2rsp, pps, st)         _ <- response h2rsp pps         return ResponseReceived-    case eResponseReceived of-        Right ResponseReceived -> do-            Just (h2rsp, pps, st) <- I.readIORef ref+    msent <- I.readIORef ref+    let logSent (h2rsp, pps, st) = do             let msiz = fromIntegral <$> H2.responseBodySize h2rsp             logResponse req st msiz             mapM_ (logPushPromise req) pps+    case eResponseReceived of+        Right ResponseReceived -> case msent of+            Just sent -> logSent sent+            -- Reachable only through Network.Wai.Internal: the+            -- application said it had answered without answering.+            Nothing -> E.throwIO $ userError "no response from the application"         Left e             | isAsyncException e -> E.throwIO e             | otherwise -> do                 S.settingsOnException settings (Just req) e-                let ersp = S.settingsOnExceptionResponse settings e-                    st = responseStatus ersp-                (h2rsp', _, _) <- fromResponse settings ii req ersp-                let msiz = fromIntegral <$> H2.responseBodySize h2rsp'-                _ <- response h2rsp' []-                logResponse req st msiz+                case msent of+                    -- The response has gone out, so this exception+                    -- cannot replace it, which is what istatus keeps+                    -- HTTP/1 from doing.+                    Just sent -> logSent sent+                    Nothing -> do+                        let ersp = S.settingsOnExceptionResponse settings e+                        (h2rsp, _, _) <- fromResponse settings ii req ersp+                        _ <- response h2rsp []+                        logSent (h2rsp, [], responseStatus ersp)     return ()   where     toWAIRequest h2req aux = toRequest ii settings addr hdr bdylen bdy th transport@@ -150,9 +187,13 @@     handler = throughAsync (return "")  -- connClose must not be called here since Run:fork calls it-goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()-goaway Connection{..} etype debugmsg = connSendAll bytestream+--+-- The SETTINGS frame is this server's half of the connection preface,+-- which RFC 9113 has it send before anything else, GOAWAY included.+goaway :: Connection -> H2.ErrorCode -> ByteString -> IO ()+goaway Connection{..} etype debugmsg = connSendAll $ preface <> bytestream   where     einfo = H2.encodeInfo id 0+    preface = H2.encodeFrame einfo $ H2.SettingsFrame []     frame = H2.GoAwayFrame 0 etype debugmsg     bytestream = H2.encodeFrame einfo frame

@@ -15,7 +15,7 @@  -- | 'PositionReadMaker' based on file descriptor cache. ----- Since 3.3.13+-- @since 3.3.13 pReadMaker :: InternalInfo -> PositionReadMaker pReadMaker ii path = do     (mfd, refresh) <- getFd ii path

@@ -85,24 +85,33 @@             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)     !path = H.extractPath unparsedPath     !rawPath = if S.settingsNoParsePath settings then unparsedPath else path+    -- We use an "atomic" function here, because we can't influence when it+    -- will be used.+    modifyDataKey f = atomicModifyIORef' ref $ \mOldKey ->+        let !mNewKey = f mOldKey+         in (mNewKey, ())     -- fixme: pauseTimeout. th is not available here.-    !vaultValue =+    -- Lazy on purpose (~ defeats -XStrict): most handlers never touch+    -- 'vault', so don't pay for the inserts unless somebody looks.+    ~vaultValue =         Vault.insert getFileInfoKey (getFileInfo ii)             . Vault.insert getHTTP2DataKey (readIORef ref)-            . Vault.insert setHTTP2DataKey (writeIORef ref)-            . Vault.insert modifyHTTP2DataKey (modifyIORef' ref)+            -- We use 'atomicWriteIORef' here, because we don't expect it+            -- to be used often, and it's use is out of our control.+            . Vault.insert setHTTP2DataKey (atomicWriteIORef ref)+            . Vault.insert modifyHTTP2DataKey modifyDataKey             . Vault.insert pauseTimeoutKey (T.pause th) #ifdef MIN_VERSION_crypton_x509             . Vault.insert getClientCertificateKey (getTransportClientCertificate transport)

@@ -1,122 +1,140 @@ {-# 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 Data.Maybe (isJust) 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+    , reqidxHostRepeated :: Bool+    -- ^ Whether more than one @Host@ field line was sent.+    , 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+                    , reqidxHostRepeated = isJust (reqidxHost ix)+                    }+        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 = appendField (reqidxContentLength ix) val}+        17+            | bs == "transfer-encoding" ->+                ix{reqidxTransferEncoding = appendField (reqidxTransferEncoding ix) val}+            | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val}+        19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val}+        _ -> ix+      where+        bs = foldedCase key+        -- RFC 9112: repeated field lines are one comma separated list, so+        -- keep them all. Taking the last line alone would let a second+        -- Content-Length hide the length of the first, or a second+        -- Transfer-Encoding its chunked coding.+        appendField Nothing val' = Just val'+        appendField (Just prev) val' = Just $ prev <> "," <> val' -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+        , reqidxHostRepeated = False+        , 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+        }

@@ -1,26 +1,51 @@ 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)+import Foreign.Ptr (plusPtr) import Network.Wai.Handler.Warp.Buffer import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.Types  toBufIOWith     :: Int -> IORef WriteBuffer -> (ByteString -> IO ()) -> Builder -> IO Integer-toBufIOWith maxRspBufSize writeBufferRef io builder = do+toBufIOWith = unsafeToBufIOWithOffset 0++-- | Like 'toBufIOWith' but the first @offset@ bytes of the write buffer+-- are assumed to be already filled (e.g. with a response header composed+-- directly into the buffer). They are flushed together with the first+-- batch of builder output and included in the returned total.+--+-- === WARNING: @offset@ MUST NOT exceed the current buffer size!!!+--+-- This function performs NO bounds checking on @offset@. The builder is+-- handed the pointer @buffer + offset@ with @bufSize - offset@ bytes of+-- claimed free space, so an oversized @offset@ points past the end of the+-- allocation and advertises negative capacity, i.e. out-of-bounds writes+-- and memory corruption. Every caller MUST verify+-- @offset < bufSize@ of the current write buffer first (see the+-- @hdrLen@ check in 'Network.Wai.Handler.Warp.Response.sendRsp').+unsafeToBufIOWithOffset+    :: Int+    -> Int+    -> IORef WriteBuffer+    -> (ByteString -> IO ())+    -> Builder+    -> IO Integer+unsafeToBufIOWithOffset offset0 maxRspBufSize writeBufferRef io builder = do     writeBuffer <- readIORef writeBufferRef-    loop writeBuffer firstWriter 0+    loop writeBuffer offset0 firstWriter 0   where     firstWriter = runBuilder builder-    loop writeBuffer writer bytesSent = do+    loop writeBuffer offset writer bytesSent = do         let buf = bufBuffer writeBuffer             size = bufSize writeBuffer-        (len, signal) <- writer buf size-        bufferIO buf len io-        let totalBytesSent = toInteger len + bytesSent+        (len, signal) <- writer (buf `plusPtr` offset) (size - offset)+        bufferIO buf (offset + len) io+        let totalBytesSent = toInteger (offset + len) + bytesSent         case signal of             Done -> return totalBytesSent             More minSize next@@ -41,10 +66,15 @@                     biggerWriteBuffer <- mask_ $ do                         bufFree writeBuffer                         biggerWriteBuffer <- createWriteBuffer minSize+                        -- This doesn't need to be "atomic", since these two+                        -- functions are only used in 'sendResponse', which is+                        -- ultimately only used in 'serveConnection', which does+                        -- not share nor fork the created 'Connection'.                         writeIORef writeBufferRef biggerWriteBuffer                         return biggerWriteBuffer-                    loop biggerWriteBuffer next totalBytesSent-                | otherwise -> loop writeBuffer next totalBytesSent+                    loop biggerWriteBuffer 0 next totalBytesSent+                | otherwise -> loop writeBuffer 0 next totalBytesSent             Chunk bs next -> do                 io bs-                loop writeBuffer next totalBytesSent+                loop writeBuffer 0 next $+                    totalBytesSent + fromIntegral (B.length bs)

@@ -1,27 +1,50 @@ {-# 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+    -- ** Connection counter     Counter,     getCount, +    -- ** Server state+    ServerState,+    makeServerState,+     -- * Low level run functions     runSettingsConnection,     runSettingsConnectionMaker,     runSettingsConnectionMakerSecure,+    runSettingsConnectionMakerSecureWith,     Transport (..), +    -- ** Stopping the accept loop+    Listener (..),+    noListener,+    makeListener,+    AcceptStopped (..),+     -- * Connection     Connection (..),     socketConnection,      -- ** Receive     Recv,+    makeGracefulRecv,     RecvBuf,      -- ** Buffer@@ -43,10 +66,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 @@ -113,3 +146,5 @@ import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Windows++type IndexedHeader = IndexedRequestHeader

@@ -16,8 +16,10 @@ packIntegral n | n < 0 = error "packIntegral" packIntegral n = unsafeCreate len go0   where-    n' = fromIntegral n + 1 :: Double-    len = ceiling $ logBase 10 n'+    -- Counted by division: @ceiling (logBase 10 ...)@ in a 'Double' is+    -- one short from 10^15 up, and 'go' then writes its last digit+    -- before the buffer it was given.+    !len = numDigits n     go0 p = go n $ p `plusPtr` (len - 1)     go :: Integral a => a -> Ptr Word8 -> IO ()     go i p = do@@ -26,6 +28,16 @@         when (d /= 0) $ go d (p `plusPtr` (-1)) {-# SPECIALIZE packIntegral :: Int -> ByteString #-} {-# SPECIALIZE packIntegral :: Integer -> ByteString #-}++-- | How many digits a non-negative number is written with.+numDigits :: Integral a => a -> Int+numDigits = go 1+  where+    go !acc i = case i `quot` 10 of+        0 -> acc+        q -> go (acc + 1) q+{-# SPECIALIZE numDigits :: Int -> Int #-}+{-# SPECIALIZE numDigits :: Integer -> Int #-}  -- | --

@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -16,14 +15,12 @@ ) 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)+import Data.Word8 (_0, _comma, _cr, _lf, _space, _tab, isDigit) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -41,7 +38,6 @@ import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.Header import Network.Wai.Handler.Warp.Imports hiding (readInt)-import Network.Wai.Handler.Warp.ReadInt import Network.Wai.Handler.Warp.RequestHeader import Network.Wai.Handler.Warp.Settings (     Settings,@@ -70,7 +66,7 @@     -> IO         ( Request         , Maybe (I.IORef Int)-        , IndexedHeader+        , IndexedRequestHeader         , IO ByteString         )     -- ^@@ -83,15 +79,18 @@     (method, unparsedPath, path, query, httpversion, hdr) <-         parseHeaderLines hdrlines     let idxhdr = indexRequestHeader hdr-        expect = idxhdr ! fromEnum ReqExpect+        expect = reqidxExpect idxhdr         handle100Continue = handleExpect conn httpversion expect+    checkHost httpversion idxhdr     (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr     -- body producing function which will produce '100-continue', if needed     rbody' <- timeoutBody remainingRef th rbody handle100Continue     -- body producing function which will never produce 100-continue     rbodyFlush <- timeoutBody remainingRef th rbody (return ())     let rawPath = if settingsNoParsePath settings then unparsedPath else path-        vaultValue =+        -- Lazy on purpose (~ defeats -XStrict): most handlers never touch+        -- 'vault', so don't pay for the inserts unless somebody looks.+        ~vaultValue =             Vault.insert pauseTimeoutKey (Timeout.pause th)                 . Vault.insert getFileInfoKey (getFileInfo ii) #ifdef MIN_VERSION_crypton_x509@@ -112,10 +111,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,11 +136,24 @@         else push maxTotalHeaderLength src (THStatus 0 0 id id) bs  data NoKeepAliveRequest = NoKeepAliveRequest-    deriving (Show, Typeable)+    deriving (Show) instance Exception NoKeepAliveRequest  ---------------------------------------------------------------- +-- | Refusing a request whose @Host@ RFC 9112 section 3.2 refuses.+--+-- A proxy routes on the first @Host@ and an application reads+-- 'requestHeaderHost', the last of them: a repeated one is a way to+-- reach a virtual host the proxy would not have routed to.+checkHost :: H.HttpVersion -> IndexedRequestHeader -> IO ()+checkHost httpversion idxhdr+    | reqidxHostRepeated idxhdr = throwIO BadHost+    | httpversion >= H.http11, isNothing (reqidxHost idxhdr) = throwIO BadHost+    | otherwise = return ()++----------------------------------------------------------------+ handleExpect     :: Connection     -> H.HttpVersion@@ -159,32 +172,87 @@  bodyAndSource     :: Source-    -> IndexedHeader+    -> IndexedRequestHeader     -> IO         ( IO ByteString         , Maybe (I.IORef Int)         , RequestBodyLength         )-bodyAndSource src idxhdr-    | chunked = do-        csrc <- mkCSource src-        return (readCSource csrc, Nothing, ChunkedBody)-    | otherwise = do-        let len = toLength $ idxhdr ! fromEnum ReqContentLength-            bodyLen = KnownLength $ fromIntegral len-        isrc@(ISource _ remaining) <- mkISource src len-        return (readISource isrc, Just remaining, bodyLen)+bodyAndSource src idxhdr = do+    framing <- bodyFraming idxhdr+    case framing of+        FramedByChunks -> do+            csrc <- mkCSource src+            return (readCSource csrc, Nothing, ChunkedBody)+        FramedByLength len -> do+            isrc@(ISource _ remaining) <- mkISource src len+            return (readISource isrc, Just remaining, KnownLength $ fromIntegral len)++-- | How the end of the request body is found (RFC 9112, section 6).+data BodyFraming+    = FramedByChunks+    | FramedByLength Int++-- | Deciding how the request body is framed, or refusing the request.+--+-- Anything other than one framing this server and every intermediary+-- agree on is refused rather than read some way of warp's own: whoever+-- reads it the other way sees one request where warp sees two, which is+-- how a request is smuggled past a proxy.+bodyFraming :: IndexedRequestHeader -> IO BodyFraming+bodyFraming idxhdr = case reqidxTransferEncoding idxhdr of+    Nothing -> FramedByLength <$> contentLength (reqidxContentLength idxhdr)+    -- Transfer-Encoding wins over Content-Length, so sending both is a+    -- way of showing each reader the framing it prefers. Take neither.+    Just _ | isJust (reqidxContentLength idxhdr) -> throwIO AmbiguousBodyLength+    Just te -> case reverse $ codings te of+        -- The only coding warp implements, and the only one it can be+        -- sure an intermediary passed on undisturbed.+        ["chunked"] -> return FramedByChunks+        -- Chunked frames the body, but warp decodes no coding under it.+        "chunked" : _ -> throwIO UnsupportedTransferEncoding+        -- Without chunked last, the length cannot be determined at all.+        _ -> throwIO AmbiguousBodyLength   where-    chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding+    -- A comma separated list, each element allowed its own surrounding+    -- whitespace. RFC 9110 has a recipient ignore empty elements, so+    -- "chunked", " chunked" and "chunked," are each the one coding.+    codings =+        filter (not . S.null) . map (CI.foldCase . stripOWS) . S.split _comma -toLength :: Maybe HeaderValue -> Int-toLength Nothing = 0-toLength (Just bs) = readInt bs+-- | The length a Content-Length gives, or no body when there is none.+--+-- RFC 9112 asks for a value of nothing but digits, and for repeated+-- Content-Lengths to be refused unless every one of them says the same+-- thing. Warp used to read the leading digits and take 0 for the rest,+-- so "abc", a value too large for an 'Int', and a second Content-Length+-- hiding the first all became a request with no body at all -- and the+-- bytes that were the body became the next request on the connection.+contentLength :: Maybe HeaderValue -> IO Int+contentLength Nothing = return 0+contentLength (Just bs) = case map (readLength . stripOWS) $ S.split _comma bs of+    Just len : lens | all (== Just len) lens -> return len+    _ -> throwIO AmbiguousBodyLength+  where+    readLength v+        | S.null v || not (S.all isDigit v) = Nothing+        | otherwise = S.foldl' accumulate (Just 0) v+    accumulate Nothing _ = Nothing+    accumulate (Just n) w+        -- A length warp cannot hold is a length warp cannot enforce.+        | n > (maxBound - d) `div` 10 = Nothing+        | otherwise = Just $! n * 10 + d+      where+        d = fromIntegral (w - _0) -isChunked :: Maybe HeaderValue -> Bool-isChunked (Just bs) = CI.foldCase bs == "chunked"-isChunked _ = False+-- | Optional whitespace, which RFC 9112 allows around the elements of a+--   list and gives no meaning to.+stripOWS :: ByteString -> ByteString+stripOWS = fst . S.spanEnd isOWS . S.dropWhile isOWS +isOWS :: Word8 -> Bool+isOWS w = w == _space || w == _tab+ ----------------------------------------------------------------  timeoutBody@@ -218,6 +286,10 @@             -- headers. Now we need to resume it to avoid a slowloris             -- attack during request body sending.             Timeout.resume timeoutHandle+            -- This doesn't need to be "atomic", since this is only used in+            -- 'recvRequest' to create the 'requestBody' function. And getting+            -- chunks of the request in a concurrent setting is asking for+            -- trouble anyway.             I.writeIORef isFirstRef False          bs <- rbody

@@ -7,6 +7,7 @@ import Control.Exception (throwIO) import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as C8 (unpack)+import qualified Data.ByteString.Unsafe as SU import Data.ByteString.Internal (memchr) import qualified Data.CaseInsensitive as CI import Data.Word8@@ -37,7 +38,7 @@ parseHeaderLines (firstLine : otherLines) = do     (method, path', query, httpversion) <- parseRequestLine firstLine     let path = H.extractPath path'-        hdr = map parseHeader otherLines+    hdr <- mapM parseHeader otherLines     return (method, path', path, query, httpversion, hdr)  ----------------------------------------------------------------@@ -131,8 +132,65 @@ -- ("Host","example.com:8080") -- >>> parseHeader "NoSemiColon" -- ("NoSemiColon","")-parseHeader :: ByteString -> H.Header-parseHeader s =-    let (k, rest) = S.break (== _colon) s-        rest' = S.dropWhile (\c -> c == _space || c == _tab) $ S.drop 1 rest-     in (CI.mk k, rest')+-- >>> parseHeader "Content-Length : 47"+-- *** Exception: Warp: Invalid header field name: "Content-Length "+-- >>> parseHeader "X-Foo: a\rContent-Length: 47"+-- *** Exception: Warp: CR or NUL in a header field line+parseHeader :: ByteString -> IO H.Header+parseHeader s = do+    -- The line was ended by an LF, and the CR before it is already+    -- gone, so any CR left here is a bare one. RFC 9110 section 5.5+    -- asks for it to be refused or replaced: a recipient which takes a+    -- bare CR for a line terminator reads a field, and a framing field+    -- among them, where warp reads only data.+    when (hasControl s) $ throwIO BadHeaderLine+    -- RFC 9112 asks for 400 here, because a recipient which instead+    -- repairs the name reads a header where warp reads none: a+    -- Content-Length hidden that way is a request body warp does not+    -- know it is being sent.+    when (S.null k || not (S.all isTchar k)) $ throwIO $ BadFieldName k+    return (CI.mk k, rest')+  where+    (k, rest) = S.break (== _colon) s+    rest' = S.dropWhile isOWS $ S.drop 1 rest+    isOWS c = c == _space || c == _tab+    -- Two passes of memchr beat one pass of a lambda here by a wide+    -- margin, and 'S.elem' is the way to ask for memchr: measured over+    -- a browser's request headers, this takes a fifth of the time that+    -- @S.any (_cr ==)@ does and a fifteenth of the time that one+    -- @S.any@ with a two-way lambda does.+    hasControl bs = S.elem _cr bs || S.elem _nul bs++-- | Whether RFC 9110 allows the character in a header field name.+--+-- One lookup, where a chain of ranges and an 'elem' over fifteen bytes+-- used to be.+isTchar :: Word8 -> Bool+isTchar w = SU.unsafeIndex tchars (fromIntegral w) == 1++-- | 'isTchar' for every byte there is.+tchars :: ByteString+tchars = S.pack $ map tchar [minBound .. maxBound]+  where+    tchar w+        | isAsciiUpper w || isAsciiLower w || isDigit w = 1+        | w `elem` symbols = 1+        | otherwise = 0+    symbols =+        [ _exclam+        , _numbersign+        , _dollar+        , _percent+        , _ampersand+        , _quotesingle+        , _asterisk+        , _plus+        , _hyphen+        , _period+        , _circum+        , _underscore+        , _grave+        , _bar+        , _tilde+        ]+{-# NOINLINE tchars #-}

@@ -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@@ -43,7 +44,7 @@ import qualified Network.Wai.Handler.Warp.Date as D import Network.Wai.Handler.Warp.File import Network.Wai.Handler.Warp.Header-import Network.Wai.Handler.Warp.IO (toBufIOWith)+import Network.Wai.Handler.Warp.IO (toBufIOWith, unsafeToBufIOWithOffset) import Network.Wai.Handler.Warp.Imports import Network.Wai.Handler.Warp.ResponseHeader import Network.Wai.Handler.Warp.Settings@@ -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+    -- 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,31 +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-    addConnection hs = if (hasBody s && not ret) || (not (hasBody s) && not isPersist)-                       then (H.hConnection, "close") : hs-                       else hs+    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@@ -167,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)@@ -217,7 +273,7 @@     -> H.HttpVersion     -> H.Status     -> H.ResponseHeaders-    -> IndexedHeader -- Response+    -> ResponseHeaderPresence     -> Int -- maxBuilderResponseBufferSize     -> H.Method     -> Rsp@@ -228,42 +284,69 @@     -- 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-    let hdrBdy-            | needsChunked =-                header-                    <> chunkedTransferEncoding body-                    <> chunkedTransferTerminator-            | otherwise = header <> body-        writeBufferRef = connWriteBuffer conn+sendRsp conn _ th ver s hs rspidxhdr maxRspBufSize _ (RspBuilder body needsChunked) = do+    writeBuffer <- readIORef writeBufferRef     len <--        toBufIOWith-            maxRspBufSize-            writeBufferRef-            (\bs -> connSendAll conn bs >> T.tickle th)-            hdrBdy-    return (Just s, Just len)+        -- SAFETY: this check is what makes the unchecked writes below+        -- memory-safe, do not weaken it. composeHeaderPtr writes hdrLen+        -- bytes into the write buffer with no bounds checking of its own,+        -- and unsafeToBufIOWithOffset requires an offset within the+        -- buffer (it hands the builder buffer + offset with+        -- bufSize - offset bytes of claimed free space). If hdrLen could+        -- reach the buffer size, either write would run past the end of+        -- the allocation and corrupt memory, so oversized headers must+        -- take the composeHeaderBuilder fallback.+        if hdrLen < bufSize writeBuffer+            then do+                -- Compose the header directly into the connection write+                -- buffer and run the body builder right after it, saving+                -- a copy of the header bytes through an intermediate+                -- ByteString.+                _ <- composeHeaderPtr (bufBuffer writeBuffer) ver s hs'+                unsafeToBufIOWithOffset hdrLen maxRspBufSize writeBufferRef send bdy+            else do+                -- Huge headers: fall back to composing a separate header+                -- ByteString and letting the builder machinery copy it.+                (header, _) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked+                toBufIOWith maxRspBufSize writeBufferRef send (header <> bdy)+    --              small adjustment to only count the body+    return (Just s, Just $ len - fromIntegral hdrLen)+  where+    hs'+        | needsChunked = addTransferEncoding rspidxhdr hs+        | otherwise = hs+    hdrLen = composeHeaderLength s hs'+    bdy+        | needsChunked = chunkedTransferEncoding body <> chunkedTransferTerminator+        | otherwise = body+    writeBufferRef = connWriteBuffer conn+    send bs = connSendAll conn bs >> T.tickle th  ---------------------------------------------------------------- -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@@ -272,9 +355,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, ())  ---------------------------------------------------------------- @@ -352,7 +442,7 @@     -> H.HttpVersion     -> H.Status     -> H.ResponseHeaders-    -> IndexedHeader+    -> ResponseHeaderPresence     -> Int     -> H.Method     -> FilePath@@ -362,6 +452,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@@ -377,7 +469,7 @@     -> T.Handle     -> H.HttpVersion     -> H.ResponseHeaders-    -> IndexedHeader+    -> ResponseHeaderPresence     -> Int     -> H.Method     -> IO (Maybe H.Status, Maybe Integer)@@ -395,7 +487,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"  ----------------------------------------------------------------@@ -415,49 +507,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@@ -468,28 +534,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@@ -498,19 +577,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

@@ -1,12 +1,16 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Handler.Warp.ResponseHeader (composeHeader) where+module Network.Wai.Handler.Warp.ResponseHeader (+    composeHeader,+    composeHeaderPtr,+    composeHeaderLength,+) where  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@@ -18,14 +22,32 @@ ----------------------------------------------------------------  composeHeader :: H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO ByteString-composeHeader !httpversion !status !responseHeaders = create len $ \ptr -> do-    ptr1 <- copyStatus ptr httpversion status-    ptr2 <- copyHeaders ptr1 responseHeaders-    void $ copyCRLF ptr2+composeHeader !httpversion !status !responseHeaders =+    create len $ \ptr ->+        void $ composeHeaderPtr ptr httpversion status responseHeaders   where-    !len = 17 + slen + foldl' fieldLength 0 responseHeaders+    !len = composeHeaderLength status responseHeaders++-- | The exact number of bytes 'composeHeaderPtr' writes for this+-- status line and header list (including the final CRLF).+composeHeaderLength :: H.Status -> H.ResponseHeaders -> Int+composeHeaderLength !status !responseHeaders =+    17 + slen + List.foldl' fieldLength 0 responseHeaders+  where     fieldLength !l (!k, !v) = l + S.length (CI.original k) + S.length v + 4     !slen = S.length $ H.statusMessage status++-- | Compose the response header directly into the given buffer,+-- returning the number of bytes written. The buffer must have room+-- for at least 'composeHeaderLength' bytes.+composeHeaderPtr+    :: Ptr Word8 -> H.HttpVersion -> H.Status -> H.ResponseHeaders -> IO Int+{-# INLINE composeHeaderPtr #-}+composeHeaderPtr !ptr !httpversion !status !responseHeaders = do+    ptr1 <- copyStatus ptr httpversion status+    ptr2 <- copyHeaders ptr1 responseHeaders+    ptr3 <- copyCRLF ptr2+    return $! ptr3 `minusPtr` ptr  httpVer11 :: ByteString httpVer11 = "HTTP/1.1 "

@@ -1,19 +1,31 @@ {-# 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 (+    STM,+    retry,+    TVar,+    atomically,+    check,+    modifyTVar',+    newTVarIO,+    readTVar,+    writeTVar,+ ) import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.IORef (newIORef, readIORef)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP)-import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE)+import Foreign.C.Error (Errno (..), eMFILE) import GHC.Conc.Sync (labelThread, myThreadId) import GHC.IO.Exception (IOErrorType (..), IOException (..)) import Network.Socket (@@ -25,21 +37,26 @@     fdSocket, #endif     getSocketName,+    isClosedSocketError,+    isTransientAcceptError,+    unsafeClose,+    withReadable,     setSocketOption,     withSocketsDo,  ) #if MIN_VERSION_network(3,1,1)-import Network.Socket (gracefulClose)+import Network.Socket (gracefulClose, unsafeGracefulClose) #endif import Network.Socket.BufferPool import qualified Network.Socket.ByteString as Sock import Network.Wai import System.Environment (lookupEnv) import System.IO.Error (ioeGetErrorType)+import qualified System.ThreadManager as T 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 +65,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@@ -76,20 +95,25 @@                         if h2                             then settingsGracefulCloseTimeout2 set                             else settingsGracefulCloseTimeout1 set-                if tm == 0-                    then close s-                    else gracefulClose s tm `E.catch` throughAsync (return ())+                    (closer, gracefulCloser)+                        | settingsUnsafeClose set = (unsafeClose, unsafeGracefulClose)+                        | otherwise = (close, gracefulClose)+                if tm <= 0+                    then closer s+                    else gracefulCloser s tm `E.catch` throughAsync (return ()) #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@@ -109,9 +133,7 @@             hook             headers -    sendall = sendAll' s--    sendAll' sock bs =+    sendall bs =         E.handleJust             ( \e ->                 if ioeGetErrorType e == ResourceVanished@@ -119,8 +141,30 @@                     else Nothing             )             E.throwIO-            $ Sock.sendAll sock bs+            $ killableSendAll s bs +-- | 'Sock.sendAll' which the timeout can kill.  On Windows a plain send is+-- a foreign call no asynchronous exception reaches; this one waits in STM,+-- and is cancelled if the waiting thread is killed.+killableSendAll :: Socket -> ByteString -> IO ()+killableSendAll s bs = void $ Sock.sendAllWith s bs (retry :: STM ())++-- | Create a 'Recv' which stops receiving when the server is shutting down+-- and no 'Application' is still using this 'Socket'.+--+-- Nothing is closed and no thread is interrupted to make it return: the+-- read and the shutdown are waited for at once, inside 'receiveWith'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+    r <- receiveWith sock pool checkShutdown+    case r of+        Left () -> return ""+        Right bs -> return bs+  where+    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 ()@@ -130,7 +174,7 @@ -- environment variable. Uses the 'Port' given when the variable is unset. -- This calls 'runSettings' with 'defaultSettings'. ----- Since 3.0.9+-- @since 3.0.9 runEnv :: Port -> Application -> IO () runEnv p app = do     mp <- lookupEnv "PORT"@@ -156,32 +200,94 @@                 runSettingsSocket set socket app             ) --- | This installs a shutdown handler for the given socket and--- calls 'runSettingsConnection' with the default connection setup action--- which handles plain (non-cipher) HTTP.--- When the listen socket in the second argument is closed, all live--- connections are gracefully shut down.+-- | What the accept loop waits on at the top of each turn, and what it+--   leaves behind when it stops. --+-- A server used to be stopped by closing the listening socket under the+-- thread waiting in @accept@ on it.  That takes an IO manager that can wake+-- a thread out of a wait by closing the file descriptor under it, which is+-- what 'GHC.Conc.closeFdWith' is for, and the IO manager that provides it+-- is not the only one there will be.  So the loop waits for the socket and+-- for the shutdown at once and ends on whichever comes first; the socket is+-- closed after it, by which time nothing is waiting on it.+data Listener = Listener+    { acceptOrStop :: IO (Maybe (Socket, SockAddr))+    -- ^ Accepts a connection.  'Nothing' instead once the server has been+    -- asked to stop: giving up has to be composed with the accept itself,+    -- so the accept belongs here rather than beside it.+    , closeListener :: IO ()+    -- ^ Run once the accept loop has ended and before the connections are+    -- waited for: the port is a successor's to take, and a successor should+    -- not have to wait out someone else's drain for it.+    }++-- | For a caller that handed warp a connection maker and no socket.  There+--   is nothing here to accept and nothing to close, and such a server ends+--   the way it always did: by whatever its maker accepts on being closed.+noListener :: Listener+noListener = Listener{acceptOrStop = return Nothing, closeListener = return ()}++-- | Thrown by a connection maker which was told to stop rather than handed+--   a connection, and caught by the accept loop.  A maker has to return a+--   connection or throw, so this is how it says that there will not be one.+data AcceptStopped = AcceptStopped deriving (Show)++instance E.Exception AcceptStopped++makeListener :: Settings -> Socket -> IO Listener+makeListener set socket = do+    stopping <- newTVarIO False+    settingsInstallShutdownHandler set $ atomically $ writeTVar stopping True+    return+        Listener+            { acceptOrStop = closedAsStopped $ do+                r <- withReadable socket (told stopping) $ settingsAccept set socket+                return $ either (const Nothing) Just r+            , closeListener = unsafeClose socket+            }+  where+    told stopping = check =<< readTVar stopping+    -- Closing the listening socket is how a server was stopped before there+    -- was anything to tell, and callers that do it are still out there. It+    -- means the same thing the shutdown handler means: stop accepting.+    -- Ending the loop quietly is what happened before, and 'closeListener'+    -- closing an already-closed socket is no error.+    closedAsStopped = E.handle $ \e ->+        if isClosedSocketError e then return Nothing else E.throwIO e++-- | This installs a shutdown handler for the given socket and runs the+-- default connection setup action, which handles plain (non-cipher) HTTP.+-- Running the handler stops the server accepting, closes the listening+-- socket, and gracefully shuts the live connections down.+-- -- The supplied socket can be a Unix named socket, which -- can be used when reverse HTTP proxying into your application. -- -- 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 socket app = do+    listener <- makeListener oldSettings socket+    (_, newSettings) <- makeServerState oldSettings+    runSettingsConnectionMakerSecureWith+        newSettings+        listener+        (first ((,TCP) <$>) <$> getConnMaker listener newSettings)+        app   where-    getConn = do-        (s, sa) <- accept' socket+    getConnMaker listener set = do+        (conn, sa) <- getConn listener set+        return (return conn, sa)++    getConn listener set = do+        macc <- acceptOrStop listener+        (s, sa) <- maybe (E.throwIO AcceptStopped) return macc         setSocketCloseOnExec s         -- NoDelay causes an error for AF_UNIX.         setSocketOption s NoDelay 1 `E.catch` throughAsync (return ())         conn <- socketConnection set s         return (conn, sa) -    closeListenSocket = close socket- -- | The connection setup action would be expensive. A good example -- is initialization of TLS. -- So, this converts the connection setup action to the connection maker@@ -190,7 +296,7 @@ -- This allows the expensive computations to be performed -- in a separate worker thread instead of the main server loop. ----- Since 1.3.5+-- @since 1.3.5 runSettingsConnection     :: Settings -> IO (Connection, SockAddr) -> Application -> IO () runSettingsConnection set getConn app = runSettingsConnectionMaker set getConnMaker app@@ -215,19 +321,30 @@ -- The connection maker can return a connection of either plain HTTP -- or HTTP over TLS. ----- Since 2.1.4+-- @since 2.1.4 runSettingsConnectionMakerSecure     :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO ()-runSettingsConnectionMakerSecure set getConnMaker app = do-    settingsBeforeMainLoop set-    counter <- case settingsConnectionCounter set of-        Just c -> pure c-        Nothing -> newCounter-    withII set $ acceptConnection set getConnMaker app counter+runSettingsConnectionMakerSecure set = runSettingsConnectionMakerSecureWith set noListener +-- | 'runSettingsConnectionMakerSecure' for a caller that has the listening+--   socket, and so can say how the accept loop waits on it and what becomes+--   of it when the loop stops.+runSettingsConnectionMakerSecureWith+    :: Settings+    -> Listener+    -> IO (IO (Connection, Transport), SockAddr)+    -> Application+    -> IO ()+runSettingsConnectionMakerSecureWith oldSettings listener getConnMaker app = do+    settingsBeforeMainLoop oldSettings+    (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings+    withII newSettings $ \ii ->+        initFdExhaustionRef >>=+            acceptConnection newSettings listener getConnMaker app serverConnectionCounter ii+ -- | Running an action with internal info. ----- Since 3.3.11+-- @since 3.3.11 withII :: Settings -> (InternalInfo -> IO a) -> IO a withII set action =     withTimeoutManager $ \tm ->@@ -263,22 +380,38 @@ -- Our approach is explained in the comments below. acceptConnection     :: Settings+    -> Listener     -> IO (IO (Connection, Transport), SockAddr)     -> 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 listener 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.     ---    -- acceptLoop can be broken by closing the listening socket.-    void $ E.mask_ acceptLoop-    -- In some cases, we want to stop Warp here without graceful shutdown.-    -- So, async exceptions are allowed here.-    -- That's why `finally` is not used.-    gracefulShutdown set counter+    -- acceptLoop ends when the listener says the server has been asked+    -- to stop.+    -- Whatever ends the loop, the connections being served do not outlive+    -- it: 'stopAfter' kills what the manager still owns and rethrows.+    -- Warp forks a thread per connection and nothing else owns them, so+    -- without this they go on running after the caller of 'runSettings'+    -- has been handed its exception back.  See #1126.+    flip (T.stopAfter (threadManager counter)) (const $ return ()) $ do+        void $ E.mask_ acceptLoop+        -- Nothing is waiting on the listening socket any more, so it can be+        -- closed and the port left to a successor rather than held for as+        -- long as the connections below take to finish.+        closeListener listener+        -- In some cases, we want to stop Warp here without graceful+        -- shutdown.  So, async exceptions are allowed here.+        -- That's why `finally` is not used.+        gracefulShutdown set counter   where     acceptLoop = do         -- Allow async exceptions before receiving the next connection maker.@@ -298,22 +431,57 @@                 fork set mkConn addr app counter ii                 acceptLoop -    acceptNewConnection = do+    -- The maker throws this when the server has been asked to stop, which+    -- is not a failure to report.+    acceptNewConnection =+        acceptNewConnection' `E.catch` \AcceptStopped -> return Nothing++    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+                -- isTransientAcceptError is about one queued connection+                -- rather than about the listening socket, and says which+                -- errno those are. The connection has left the queue by+                -- then, so the retry blocks for a new one rather than+                -- spinning on the same failure.+                if | isTransientAcceptError e -> 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@@ -324,29 +492,37 @@     -> Counter     -> InternalInfo     -> IO ()-fork set mkConn addr app counter ii = settingsFork set $ \unmask -> do-    tid <- myThreadId-    labelThread tid "Warp just forked"-    -- Call the user-supplied on exception code if any-    -- exceptions are thrown.-    ---    -- Intentionally using Control.Exception.handle, since we want to-    -- catch all exceptions and avoid them from propagating, even-    -- async exceptions. See:-    -- https://github.com/yesodweb/wai/issues/850-    E.handle (settingsOnException set Nothing) $-        -- Run the connection maker to get a new connection, and ensure-        -- that the connection is closed. If the mkConn call throws an-        -- exception, we will leak the connection. If the mkConn call is-        -- vulnerable to attacks (e.g., Slowloris), we do nothing to-        -- protect the server. It is therefore vital that mkConn is well-        -- vetted.-        ---        -- We grab the connection before registering timeouts since the-        -- timeouts will be useless during connection creation, due to the-        -- fact that async exceptions are still masked.-        E.bracket mkConn cleanUp (serve unmask)+fork set mkConn addr app counter ii =+    -- The connection is counted from here rather than from the thread+    -- below.  The accept loop does not wait for that thread to be+    -- scheduled, so counting there leaves a window in which the connection+    -- is accepted and not counted, and 'gracefulShutdown' waits on this+    -- counter.+    -- Eta-expanded so that GHC 9.0, which lacks deep subsumption, accepts+    -- 'runConnection' at the rank-2 type.+    forkConnection counter (settingsFork set) (\unmask -> runConnection unmask)   where+    runConnection unmask =+        -- Call the user-supplied on exception code if any+        -- exceptions are thrown.+        --+        -- Intentionally using Control.Exception.handle, since we want to+        -- catch all exceptions and avoid them from propagating, even+        -- async exceptions. See:+        -- https://github.com/yesodweb/wai/issues/850+        E.handle (onConnectionException set addr) $+            -- Run the connection maker to get a new connection, and ensure+            -- that the connection is closed. If the mkConn call throws an+            -- exception, we will leak the connection. If the mkConn call is+            -- vulnerable to attacks (e.g., Slowloris), we do nothing to+            -- protect the server. It is therefore vital that mkConn is well+            -- vetted.+            --+            -- We grab the connection before registering timeouts since the+            -- timeouts will be useless during connection creation, due to the+            -- fact that async exceptions are still masked.+            E.bracket mkConn cleanUp (serve unmask)+     cleanUp (conn, _) =         connClose conn `E.finally` do             writeBuffer <- readIORef $ connWriteBuffer conn@@ -368,8 +544,8 @@                 -- above ensures the connection is closed.                 when goingon $ serveConnection conn ii th addr transport set app -    onOpen adr = increase counter >> settingsOnOpen set adr-    onClose adr _ = decrease counter >> settingsOnClose set adr+    onOpen adr = settingsOnOpen set adr+    onClose adr _ = settingsOnClose set adr  serveConnection     :: Connection@@ -391,13 +567,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@@ -430,11 +612,32 @@ #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++-- [FD_EXHAUSTION]+-- No need for "atomic" variants, since this is only used in a tight loop in+-- 'acceptConnection'.+resetFdExhaustion :: IORef FdExhaustion -> IO ()+resetFdExhaustion = flip writeIORef NoFdIssue++setFdExhaustion :: IORef FdExhaustion -> IO ()+setFdExhaustion = flip writeIORef FdExhausted -- [FD_EXHAUSTION]

@@ -38,7 +38,7 @@ --   This makes use of the file descriptor cache. --   For other OSes, this is identical to 'readSendFile'. ----- Since: 3.1.0+-- @since 3.1.0 sendFile :: Socket -> Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile #ifdef SENDFILEFD sendFile s _ _ _ fid off len act hdr = case mfid of@@ -88,7 +88,7 @@ --   This makes use of the file descriptor cache. --   For Windows, this is emulated by 'Handle'. ----- Since: 3.1.0+-- @since 3.1.0 #ifdef WINDOWS readSendFile :: Buffer -> BufSize -> (ByteString -> IO ()) -> SendFile readSendFile buf siz send fid off0 len0 hook headers = do

@@ -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,8 +26,14 @@ import System.IO.Error (ioeGetErrorType) import System.TimeManager -import Network.Wai.Handler.Warp.Counter (Counter, newCounter)+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)@@ -37,6 +44,16 @@ import qualified Paths_warp #endif +-- | Report a worker exception with the address captured for that connection.+-- An optional callback preserves the existing exception observer's meaning:+-- setting the ordinary observer later still changes the default fallback.+-- No shared peer state or synthetic Request is needed (#1113).+onConnectionException :: Settings -> SockAddr -> SomeException -> IO ()+onConnectionException settings address =+    case settingsOnConnectionException settings of+        Just report -> report address+        Nothing -> settingsOnException settings Nothing+ -- | Various Warp server settings. This is purposely kept as an abstract data -- type so that new settings can be added without breaking backwards -- compatibility. In order to create a 'Settings' value, use 'defaultSettings'@@ -50,12 +67,15 @@     -- ^ Default value: HostIPv4     , settingsOnException :: Maybe Request -> SomeException -> IO ()     -- ^ What to do with exceptions thrown by either the application or server. Default: ignore server-generated exceptions (see 'InvalidRequest') and print application-generated applications to stderr.+    , settingsOnConnectionException :: Maybe (SockAddr -> SomeException -> IO ())+    -- ^ Optional observer for exceptions escaping a connection worker. Nothing+    -- delegates to settingsOnException with no request, preserving its defaults.     , settingsOnExceptionResponse :: SomeException -> Response     -- ^ A function to create `Response` when an exception occurs.     --     -- Default: 500, text/plain, \"Something went wrong\"     ---    -- Since 2.0.3+    -- @since 2.0.3     , settingsOnOpen :: SockAddr -> IO Bool     -- ^ What to do when a connection is open. When 'False' is returned, the connection is closed immediately. Otherwise, the connection is going on. Default: always returns 'True'.     , settingsOnClose :: SockAddr -> IO ()@@ -75,7 +95,7 @@     --     -- Default: do nothing.     ---    -- Since 1.3.6+    -- @since 1.3.6     , settingsFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()     -- ^ Code to fork a new thread to accept a connection.     --@@ -84,7 +104,7 @@     --     -- Default: 'defaultFork'     ---    -- Since 3.0.4+    -- @since 3.0.4     , settingsAccept :: Socket -> IO (Socket, SockAddr)     -- ^ Code to accept a new connection.     --@@ -93,7 +113,7 @@     --     -- Default: 'defaultAccept'     ---    -- Since 3.3.24+    -- @since 3.3.24     , settingsNoParsePath :: Bool     -- ^ Perform no parsing on the rawPathInfo.     --@@ -101,7 +121,7 @@     --     -- Default: False     ---    -- Since 2.0.3+    -- @since 2.0.3     , settingsInstallShutdownHandler :: IO () -> IO ()     -- ^ An action to install a handler (e.g. Unix signal handler)     -- to close a listen socket.@@ -109,62 +129,68 @@     --     -- Default: no action     ---    -- Since 3.0.1+    -- @since 3.0.1     , settingsServerName :: ByteString     -- ^ Default server name if application does not set one.     ---    -- Since 3.0.2+    -- @since 3.0.2     , settingsMaximumBodyFlush :: Maybe Int     -- ^ See @setMaximumBodyFlush@.     ---    -- Since 3.0.3+    -- @since 3.0.3     , settingsProxyProtocol :: ProxyProtocol     -- ^ Specify usage of the PROXY protocol.     ---    -- Since 3.0.5+    -- @since 3.0.5     , settingsSlowlorisSize :: Int     -- ^ Size of bytes read to prevent Slowloris protection. Default value: 2048     ---    -- Since 3.1.2+    -- @since 3.1.2     , settingsHTTP2Enabled :: Bool     -- ^ Whether to enable HTTP2 ALPN/upgrades. Default: True     ---    -- Since 3.1.7+    -- @since 3.1.7     , settingsLogger :: Request -> H.Status -> Maybe Integer -> IO ()     -- ^ A log function. Default: no action.     ---    -- Since 3.1.10+    -- @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.     ---    -- Since 3.2.7+    -- @since 3.2.7     , settingsGracefulShutdownTimeout :: Maybe Int     -- ^ An optional timeout to limit the time (in seconds) waiting for     -- a graceful shutdown of the web server.     ---    -- Since 3.2.8+    -- @since 3.2.8     , settingsGracefulCloseTimeout1 :: Int     -- ^ A timeout to limit the time (in milliseconds) waiting for     -- FIN for HTTP/1.x. 0 means uses immediate close.     -- Default: 0.     ---    -- Since 3.3.5+    -- @since 3.3.5     , settingsGracefulCloseTimeout2 :: Int     -- ^ A timeout to limit the time (in milliseconds) waiting for     -- FIN for HTTP/2. 0 means uses immediate close.     -- Default: 2000.     ---    -- Since 3.3.5+    -- @since 3.3.5     , settingsMaxTotalHeaderLength :: Int     -- ^ Determines the maximum header size that Warp will tolerate when using HTTP/1.x.     ---    -- Since 3.3.8+    -- @since 3.3.8     , settingsAltSvc :: Maybe ByteString     -- ^ Specify the header value of Alternative Services (AltSvc:).     --     -- Default: Nothing     ---    -- Since 3.3.11+    -- @since 3.3.11     , settingsMaxBuilderResponseBufferSize :: Int     -- ^ Determines the maxium buffer size when sending `Builder` responses     -- (See `responseBuilder`).@@ -178,7 +204,7 @@     --     -- Default: 1049_000_000 = 1 MiB.     ---    -- Since 3.3.22+    -- @since 3.3.22     , settingsConnectionCounter :: Maybe Counter     -- ^ A counter for tracking open connections.     -- Use 'makeSettingsAndCounter' to create settings with a counter,@@ -186,7 +212,27 @@     --     -- Default: 'Nothing' (warp creates an internal counter)     ---    -- Since 3.4.11+    -- /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+    , settingsUnsafeClose :: Bool+    -- ^ Whether to close connections with network's 'unsafeClose' and+    -- 'unsafeGracefulClose', which skip the IO manager.  Use this only if+    -- no thread uses a connection's socket after warp closes it, which+    -- 'responseRaw' applications cannot always promise.+    --+    -- Default: 'False'.+    --+    -- @since 3.4.21     }  -- | Specify usage of the PROXY protocol.@@ -198,6 +244,87 @@     | -- | 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.+--+-- Connections are considered "open" the moment they are accepted by the socket.+--+-- @since 3.4.13+currentOpenConnections :: ServerState -> IO Int+currentOpenConnections = getCount . serverConnectionCounter++-- | Get the currently open connections of the server in an 'STM' transaction.+--+-- Connections are considered "open" the moment they are accepted by the socket.+--+-- @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@@ -206,6 +333,7 @@         { settingsPort = 3000         , settingsHost = "*4"         , settingsOnException = defaultOnException+        , settingsOnConnectionException = Nothing         , settingsOnExceptionResponse = defaultOnExceptionResponse         , settingsOnOpen = const $ return True         , settingsOnClose = const $ return ()@@ -232,22 +360,34 @@         , settingsAltSvc = Nothing         , settingsMaxBuilderResponseBufferSize = 1049000000         , settingsConnectionCounter = Nothing+        , settingsServerState = Nothing+        , settingsUnsafeClose = False         } --- | Create 'Settings' with a connection counter.+-- | Create 'defaultSettings' with a connection counter. -- Use 'getCount' on the returned 'Counter' to check open connections. ----- Since 3.4.11+-- /DEPRECATED in favor of 'makeSettingsAndServerState'/+--+-- @since 3.4.11 makeSettingsAndCounter :: IO (Counter, Settings) makeSettingsAndCounter = do-    counter <- newCounter-    pure (counter, defaultSettings{settingsConnectionCounter = Just counter})+    (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 -- under the normal course of the web server running. ----- Since 2.1.3+-- @since 2.1.3 defaultShouldDisplayException :: SomeException -> Bool defaultShouldDisplayException se     | Just (_ :: InvalidRequest) <- fromException se = False@@ -260,7 +400,7 @@ -- | Printing an exception to standard error --   if `defaultShouldDisplayException` returns `True`. ----- Since: 3.1.0+-- @since: 3.1.0 defaultOnException :: Maybe Request -> SomeException -> IO () defaultOnException _ e =     when (defaultShouldDisplayException e) $@@ -270,10 +410,12 @@  -- | Sending 400 for bad requests. --   Sending 500 for internal server errors.--- Since: 3.1.0+-- @since: 3.1.0 --   Sending 413 for too large payload. --   Sending 431 for too large headers.--- Since 3.2.27+-- @since 3.2.27+--   Sending 501 for an unsupported transfer coding.+-- @since 3.4.17 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e     | isAsyncException e = throw e@@ -287,6 +429,11 @@             H.status431             [(H.hContentType, "text/plain; charset=utf-8")]             "Request header fields too large"+    | Just UnsupportedTransferEncoding <- fromException e =+        responseLBS+            H.notImplemented501+            [(H.hContentType, "text/plain; charset=utf-8")]+            "Unsupported transfer coding"     | Just (_ :: InvalidRequest) <- fromException e =         responseLBS             H.badRequest400@@ -301,7 +448,7 @@ -- | Exception handler for the debugging purpose. --   500, text/plain, a showed exception. ----- Since: 2.0.3.2+-- @since: 2.0.3.2 exceptionResponseForDebug :: SomeException -> Response exceptionResponseForDebug e =     responseBuilder@@ -311,7 +458,7 @@  -- | Similar to @forkIOWithUnmask@, but does not set up the default exception handler. ----- Since Warp will always install its own exception handler in forked threads, this provides+-- @since Warp will always install its own exception handler in forked threads, this provides -- a minor optimization. -- -- For inspiration of this function, see @rawForkIO@ in the @async@ package.

@@ -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

@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}  module Network.Wai.Handler.Warp.Types where -import qualified Data.ByteString as S-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.Typeable (Typeable)+import Control.Concurrent.STM (TVar) import qualified Control.Exception as E+import qualified Data.ByteString as S+import Data.IORef (IORef, writeIORef, newIORef, readIORef) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -46,7 +45,27 @@       PayloadTooLarge     | -- | Since 3.3.22       RequestHeaderFieldsTooLarge-    deriving (Eq, Typeable)+    | -- | A transfer coding warp does not implement. Since 3.4.17+      UnsupportedTransferEncoding+    | -- | The length of the request body cannot be determined+      --   reliably, so no reading of it can be trusted. Since 3.4.17+      AmbiguousBodyLength+    | -- | CR or NUL inside a header field line, which one reader+      --   takes for a line terminator where another reads data.+      --   Since 3.4.17+      BadHeaderLine+    | -- | A header field name which is not a token, which hides the+      --   field from one reader but not another.+      --   Since 3.4.17+      BadFieldName ByteString+    | -- | A chunked request body that does not keep to the framing+      --   RFC 9112 gives it. Since 3.4.17+      BadChunkedBody+    | -- | No @Host@ in a HTTP\/1.1 request, or more than one, which+      --   a router and this server may read differently.+      --   Since 3.4.19+      BadHost+    deriving (Eq)  instance Show InvalidRequest where     show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs@@ -59,6 +78,12 @@     show (BadProxyHeader s) = "Warp: Invalid PROXY protocol header: " ++ show s     show RequestHeaderFieldsTooLarge = "Request header fields too large"     show PayloadTooLarge = "Payload too large"+    show UnsupportedTransferEncoding = "Warp: Unsupported transfer coding"+    show AmbiguousBodyLength = "Warp: Ambiguous request body length"+    show BadHeaderLine = "Warp: CR or NUL in a header field line"+    show (BadFieldName n) = "Warp: Invalid header field name: " ++ show n+    show BadChunkedBody = "Warp: Malformed chunked request body"+    show BadHost = "Warp: Missing or repeated Host"  instance E.Exception InvalidRequest @@ -71,7 +96,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 @@ -81,7 +106,7 @@ --   On Unix, a file descriptor would be specified to make use of --   the file descriptor cache. ----- Since: 3.1.0+-- @since 3.1.0 data FileId = FileId     { fileIdPath :: FilePath     , fileIdFd :: Maybe Fd@@ -89,7 +114,7 @@  -- |  fileid, offset, length, hook action, HTTP headers ----- Since: 3.1.0+-- @since 3.1.0 type SendFile = FileId -> Integer -> Integer -> IO () -> [ByteString] -> IO ()  -- | A write buffer of a specified size@@ -130,11 +155,20 @@     , 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     } +-- This function isn't used nor exported... getConnHTTP2 :: Connection -> IO Bool getConnHTTP2 = readIORef . connHTTP2 +-- This doesn't need to be "atomic", since it is only really used for+-- determining how long to wait before closing the socket in 'socketConnection'. setConnHTTP2 :: Connection -> Bool -> IO () setConnHTTP2 = writeIORef . connHTTP2 @@ -150,6 +184,8 @@ ----------------------------------------------------------------  -- | Type for input streaming.+--+-- /Caveat: a 'Source' is meant to be used in one thread only./ data Source = Source !(IORef ByteString) !(IO ByteString)  mkSource :: IO ByteString -> IO Source@@ -157,6 +193,7 @@     ref <- newIORef S.empty     return $! Source ref func +-- | Caveats from 'Source' apply. readSource :: Source -> IO ByteString readSource (Source ref func) = do     bs <- readIORef ref@@ -167,9 +204,12 @@             return bs  -- | Read from a Source, ignoring any leftovers.+--+-- /Caveats from 'Source' apply./ readSource' :: Source -> IO ByteString readSource' (Source _ func) = func +-- | Caveats from 'Source' apply. leftoverSource :: Source -> ByteString -> IO () leftoverSource (Source ref _) = writeIORef ref 

@@ -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

@@ -0,0 +1,124 @@+{-# LANGUAGE OverloadedStrings #-}++-- | End-to-end benchmark of the response path: everything 'sendResponse'+-- does per response except the actual socket write (the Connection is a+-- sink). Covers header sanitization, indexing, Server/Date insertion,+-- header composition, chunking, buffer management and timeout handling.+module Main (main) where++import Control.Concurrent.STM (newTVarIO)+import Control.Monad (replicateM_)+import Criterion.Main+import Data.ByteString.Builder (byteString)+import Data.IORef (newIORef)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as H+import Network.Socket (SockAddr (..))+import Network.Wai (defaultRequest)+import Network.Wai.Internal (Request (..), Response (..))+import qualified System.TimeManager as T++import Network.Wai.Handler.Warp.Buffer (createWriteBuffer)+import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Response (sendResponse)+import Network.Wai.Handler.Warp.ResponseHeader (composeHeader)+import Network.Wai.Handler.Warp.Settings (defaultSettings)+import Network.Wai.Handler.Warp.Types++main :: IO ()+main = do+    writeBuf <- createWriteBuffer 16384 >>= newIORef+    http2Ref <- newIORef False+    apps <- newTVarIO (0 :: Int)+    let conn =+            Connection+                { connSendMany = \_ -> return ()+                , connSendAll = \_ -> return ()+                , connSendFile = \_ _ _ _ _ -> return ()+                , connClose = return ()+                , connRecv = return ""+                , connRecvBuf = \_ _ -> return True+                , connWriteBuffer = writeBuf+                , connHTTP2 = http2Ref+                , connMySockAddr = SockAddrInet 0 0+                , connAppsInProgress = apps+                }+    mgr <- T.initialize 30000000+    th <- T.register mgr (return ())+    let ii =+            InternalInfo+                { timeoutManager = mgr+                , getDate = return "Fri, 18 Jul 2026 12:00:00 GMT"+                , getFd = \_ -> return (Nothing, return ())+                , getFileInfo = \_ -> ioError (userError "no file info in bench")+                }+        req = defaultRequest{httpVersion = H.http11, requestMethod = H.methodGet}+        reqidxhdr = indexRequestHeader reqHdrs+        send = sendResponse defaultSettings conn ii th req reqidxhdr (return "")+    defaultMain+        [ bgroup+            "sendResponse"+            [ bench "builder 4 headers content-length" $ whnfIO $ send (rspB hdrs4)+            , bench "builder 3 headers chunked" $ whnfIO $ send (rspB hdrs3NoCL)+            , bench "builder 20 headers content-length" $ whnfIO $ send (rspB hdrs20)+            , bench "no body 204" $ whnfIO $ send rsp204+            , bench "stream 64 fragments" $ whnfIO $ send (rspS 64)+            ]+        , bgroup+            "headers"+            [ bench "composeHeader 5 headers" $+                whnfIO $+                    composeHeader H.http11 H.status200 hdrs5+            , bench "indexRequestHeader" $ whnf indexRequestHeader reqHdrs+            , bench "indexResponseHeader" $ whnf indexResponseHeader hdrs5+            ]+        ]+  where+    body = byteString "Hello, World!"+    rspB hs = ResponseBuilder H.status200 hs body+    -- One fragment per write/flush pair, the shape an SSE-style body has.+    rspS n = ResponseStream H.status200 hdrs3NoCL $ \write flush ->+        replicateM_ n (write body >> flush)+    rsp204 = ResponseBuilder H.status204 [] mempty+    reqHdrs =+        [ (H.hHost, "127.0.0.1:3011")+        , (H.hUserAgent, "wrk/4.2.0")+        , (H.hAccept, "*/*")+        , ("Accept-Encoding", "gzip, deflate")+        , (H.hConnection, "keep-alive")+        ]+    hdrs4 =+        [ (H.hContentType, "text/plain; charset=utf-8")+        , (H.hContentLength, "13")+        , (H.hCacheControl, "no-cache")+        , ("X-Request-Id", "0123456789abcdef")+        ]+    hdrs3NoCL =+        [ (H.hContentType, "text/plain; charset=utf-8")+        , (H.hCacheControl, "no-cache")+        , ("X-Request-Id", "0123456789abcdef")+        ]+    -- what composeHeader sees after warp added Server and Date+    hdrs5 =+        (H.hServer, "Warp/3.4.15")+            : (H.hDate, "Fri, 18 Jul 2026 12:00:00 GMT")+            : hdrs3NoCL+    hdrs20 =+        hdrs4+            ++ [ (H.hCacheControl, "private, max-age=0")+               , ("ETag", "\"33a64df551425fcc55e4d42a148795d9f25f89d4\"")+               , (H.hLastModified, "Wed, 21 Oct 2015 07:28:00 GMT")+               , ("X-Frame-Options", "SAMEORIGIN")+               , ("X-Content-Type-Options", "nosniff")+               , ("X-XSS-Protection", "1; mode=block")+               , ("Strict-Transport-Security", "max-age=31536000; includeSubDomains")+               , ("Content-Security-Policy", "default-src 'self'")+               , ("Referrer-Policy", "strict-origin-when-cross-origin")+               , ("Access-Control-Allow-Origin", "*")+               , ("Vary", "Accept-Encoding")+               , ("Set-Cookie", "session=abc123; Path=/; HttpOnly; Secure")+               , ("X-Runtime", "0.012345")+               , ("X-Served-By", "cache-lhr-1234")+               , ("Age", "0")+               , ("Via", "1.1 varnish")+               ]

@@ -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

@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}++module ConnectionExceptionSpec (spec) where++import Control.Concurrent (Chan, newChan, readChan, writeChan, newEmptyMVar, putMVar, takeMVar, tryPutMVar)+import Control.Concurrent.Async (link, withAsync)+import Control.Exception (Exception, SomeException, bracket, finally, fromException, throwIO, toException)+import Control.Monad (forM_, replicateM, void)+import Data.IORef (newIORef, readIORef, writeIORef, modifyIORef')+import Data.Maybe (isJust)+import qualified Data.Streaming.Network as N+import Network.HTTP.Types (internalServerError500)+import Network.Socket (SockAddr (SockAddrInet), close, tupleToHostAddress)+import Network.Wai (remoteHost)+import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp.Internal (runSettingsConnectionMakerSecure)+import System.Timeout (timeout)+import Test.Hspec++import HTTP (responseStatus, sendGET)++-- Regression for https://github.com/yesodweb/wai/issues/1113. A connection+-- maker can fail before any Request exists, but Warp already owns its peer.+data ConnectionFailure = ConnectionFailure Int deriving (Show)+instance Exception ConnectionFailure++type Observation = (Int, Maybe SockAddr)++spec :: Spec+spec = describe "connection exception peer" $ do+    it "preserves the legacy observer when no peer observer is installed" $ do+        events <- newChan+        makers <- newChan+        let settings = setOnException (\request -> record events (remoteHost <$> request)) defaultSettings+        withAsync (runSettingsConnectionMakerSecure settings (readChan makers) unusedApplication) $ \server -> do+            link server+            writeChan makers (throwIO (ConnectionFailure 1), peer 100)+            timeout 2000000 (readChan events) `shouldReturn` Just (1, Nothing)++    it "gets the current legacy observer as the default connection observer" $ do+        events <- newChan+        let settings = setOnException (\request -> record events (remoteHost <$> request)) defaultSettings+        getOnConnectionException settings (peer 110) (toException (ConnectionFailure 2))+        timeout 2000000 (readChan events) `shouldReturn` Just (2, Nothing)++    it "uses only the connection observer regardless of setter order" $+        forM_ [False, True] $ \legacyLast -> do+            calls <- newIORef ([] :: [String])+            let legacy _ _ = modifyIORef' calls (++ ["legacy"])+                connection _ _ = modifyIORef' calls (++ ["connection"])+                settings = if legacyLast+                    then setOnException legacy $ setOnConnectionException connection defaultSettings+                    else setOnConnectionException connection $ setOnException legacy defaultSettings+            getOnConnectionException settings (peer 120) (toException (ConnectionFailure 3))+            readIORef calls `shouldReturn` ["connection"]++    it "keeps accept failures on the legacy observer because no peer was obtained" $ do+        calls <- newIORef ([] :: [(String, Bool)])+        let legacy request _ = modifyIORef' calls (++ [("legacy", isJust request)])+            connection _ _ = modifyIORef' calls (++ [("connection", False)])+            settings = setOnException legacy $ setOnConnectionException connection defaultSettings+        runSettingsConnectionMakerSecure settings (ioError (userError "accept failed")) unusedApplication+        readIORef calls `shouldReturn` [("legacy", False)]++    it "keeps application exceptions on the legacy observer with their request" $+        bracket (N.bindRandomPortTCP "127.0.0.1") (close . snd) $ \(port, listener) -> do+            events <- newChan+            connectionCalled <- newIORef False+            ready <- newEmptyMVar+            let legacy request exception = writeChan events (isJust request, show exception)+                connection _ _ = writeIORef connectionCalled True+                settings = setBeforeMainLoop (putMVar ready ())+                    $ setOnException legacy+                    $ setOnConnectionException connection defaultSettings+                application _ _ = throwIO (ConnectionFailure 4)+            withAsync (runSettingsSocket settings listener application) $ \server -> do+                link server+                timeout 2000000 (takeMVar ready) `shouldReturn` Just ()+                response <- sendGET ("http://127.0.0.1:" ++ show port ++ "/")+                responseStatus response `shouldBe` internalServerError500+                timeout 2000000 (readChan events) `shouldReturn` Just (True, "ConnectionFailure 4")+                readIORef connectionCalled `shouldReturn` False++    it "reports each sequential connection maker's own peer" $ do+        events <- newChan+        makers <- newChan+        let settings = observePeer (record events) defaultSettings+        withAsync (runSettingsConnectionMakerSecure settings (readChan makers) unusedApplication) $ \server -> do+            link server+            forM_ [(5, 130), (6, 140)] $ \(failureId, peerId) -> do+                writeChan makers (throwIO (ConnectionFailure failureId), peer peerId)+                timeout 2000000 (readChan events) `shouldReturn` Just (failureId, Just (peer peerId))++    it "reports peers when overlapping connection makers fail in reverse order" $ do+        events <- newChan+        makers <- newChan+        started <- newChan+        first <- newEmptyMVar+        second <- newEmptyMVar+        let settings = observePeer (record events) defaultSettings+            maker i gate = writeChan started i >> takeMVar gate >> throwIO (ConnectionFailure i)+        withAsync (runSettingsConnectionMakerSecure settings (readChan makers) unusedApplication) $ \server -> do+            link server+            writeChan makers (maker 7 first, peer 150)+            writeChan makers (maker 8 second, peer 160)+            -- Release both workers even when a readiness assertion fails.+            let release = forM_ [first, second] $ \gate -> void (tryPutMVar gate ())+            flip finally release $ do+                ready <- timeout 2000000 (replicateM 2 (readChan started))+                fmap length ready `shouldBe` Just 2+                putMVar second ()+                secondEvent <- timeout 2000000 (readChan events)+                putMVar first ()+                firstEvent <- timeout 2000000 (readChan events)+                (secondEvent, firstEvent) `shouldBe` (Just (8, Just (peer 160)), Just (7, Just (peer 150)))+  where+    unusedApplication _ _ = fail "connection maker must fail before the application"++-- Install the peer observer used by the regression assertions. The original+-- failing commit had to infer peers from Maybe Request.+observePeer :: (Maybe SockAddr -> SomeException -> IO ()) -> Settings -> Settings+observePeer report = setOnConnectionException (report . Just)++record :: Chan Observation -> Maybe SockAddr -> SomeException -> IO ()+record events address exception = case fromException exception of+    Just (ConnectionFailure i) -> writeChan events (i, address)+    Nothing -> throwIO exception++peer :: Int -> SockAddr+peer i = SockAddrInet (fromIntegral (40000 + i)) (tupleToHostAddress (127, 0, 0, fromIntegral i))

@@ -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

@@ -0,0 +1,77 @@+{-# 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)" $+#ifdef WINDOWS+        -- This test is failing on Windows (it hangs at @C.run@)+        pendingWith "requires more testing on a Windows machine"+#else+        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+#endif+#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

@@ -130,3 +130,29 @@             "gives the entire body and ignores the Range header if the condition isn't met"             [("If-Range", farPast), ("Range", "bytes=2-7")]             regularBody+        -- A range which asks for nothing the file holds.  The first+        -- of these used to be a negative length, which left the+        -- request answered with nothing at all.+        testFileRange+            "returns a 416 for a range which begins past the end"+            [("Range", "bytes=100-")]+            $ WithoutBody status416+        testFileRange+            "returns a 416 for a range which begins at the end"+            [("Range", "bytes=16-")]+            $ WithoutBody status416+        testFileRange+            "returns a 416 for a suffix of no bytes"+            [("Range", "bytes=-0")]+            $ WithoutBody status416+        -- RFC 9110, section 14.1.2: a suffix longer than the file asks+        -- for the whole of it, which is not a range at all and so is a+        -- 200 rather than a 206.+        testFileRange+            "gives the whole file for a suffix longer than it is"+            [("Range", "bytes=-100")]+            regularBody+        testFileRange+            "gives the whole file for a suffix exactly as long as it is"+            [("Range", "bytes=-16")]+            regularBody

@@ -0,0 +1,203 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import qualified Control.Exception as E+import Control.Monad (void)+import Data.IORef+import Network.HTTP.Client+import Network.HTTP.Types (ok200, status200)+import Network.Socket+import Network.Socket.ByteString (sendAll)+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.ThreadManager (KilledByThreadManager (..))+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = describe "graceful shutdown" $ do+    it "kills what it is still serving when it is killed itself (#1126)" $ do+        -- Warp forks a thread per connection, and nothing in the runtime+        -- makes those the children of the thread running the server.  An+        -- asynchronous exception to that thread used to leave them running.+        servingNow <- newEmptyMVar+        killed <- newEmptyMVar+        let app _ respond =+                ( do+                    putMVar servingNow ()+                    threadDelay 10_000_000+                    respond $ responseLBS status200 [] ""+                )+                    `E.catch` \e -> putMVar killed e >> E.throwIO e+        bracket openFreePort (close . snd) $ \(testPort, sock) -> do+            server <- forkIO $ runSettingsSocket defaultSettings sock app+            client <- openConnection testPort+            sendAll client "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"+            -- The application is in the middle of the request.+            timeout 2_000_000 (takeMVar servingNow) `shouldReturn` Just ()+            killThread server+            timeout 2_000_000 (byManager <$> takeMVar killed) `shouldReturn` Just True+            close client++    it "kills a connection forked but not yet scheduled (#1126)" $ do+        -- The thread records itself, so between the accept loop keeping a+        -- place for it and the thread being scheduled there is nothing to+        -- kill.  A 'settingsFork' which does not schedule at once -- what+        -- the reporter of #1126 sets -- makes the window wide.+        servingNow <- newEmptyMVar+        forked <- newEmptyMVar+        let app _ respond = do+                putMVar servingNow ()+                threadDelay 10_000_000+                respond $ responseLBS status200 [] ""+            set =+                setFork+                    ( \io -> void $ forkIOWithUnmask $ \unmask -> do+                        -- Forked, with its place kept and not yet taken.+                        putMVar forked ()+                        threadDelay 300_000+                        io unmask+                    )+                    defaultSettings+        bracket openFreePort (close . snd) $ \(testPort, sock) -> do+            server <- forkIO $ runSettingsSocket set sock app+            client <- openConnection testPort+            sendAll client "GET / HTTP/1.1\r\nHost: localhost\r\n\r\n"+            timeout 2_000_000 (takeMVar forked) `shouldReturn` Just ()+            killThread server+            timeout 2_000_000 (takeMVar servingNow) `shouldReturn` Nothing+            close client++    it "waits for a connection accepted just before it stopped accepting" $ do+        -- The window is between accepting a connection and the thread+        -- serving it being scheduled. Delaying the thread makes it wide+        -- enough to test; in a running server it is however long the RTS+        -- takes to get to the new thread.+        accepted <- newEmptyMVar+        stopSlot <- newEmptyMVar+        closed <- newIORef (0 :: Int)++        let slowFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()+            slowFork act = do+                -- A connection has been accepted.  Said here, where the+                -- accept loop still is, rather than in the thread below,+                -- which is the one being kept from running.+                void $ tryPutMVar accepted ()+                void $ forkIOWithUnmask $ \unmask -> do+                    threadDelay 200_000+                    act unmask++            settings =+                setFork slowFork $+                    setInstallShutdownHandler (putMVar stopSlot) $+                        setOnClose (\_ -> atomicModifyIORef' closed $ \n -> (n + 1, ())) $+                            setGracefulShutdownTimeout (Just 5) $+                                setOnException (\_ _ -> pure ()) defaultSettings++            app _ respond = respond $ responseLBS status200 [("Content-Length", "0")] ""++        bracket openFreePort (close . snd) $ \(testPort, sock) -> do+            -- Connect before the server exists. openFreePort has already put+            -- the socket in listen state, so this lands in its accept queue+            -- in the kernel and stays there: closing the client end sends a+            -- FIN but does not take it off the queue, and accept() still+            -- hands it over. Queueing it up front is what makes the accept+            -- loop's first accept() return immediately, rather than racing a+            -- client connecting alongside it, which on a loaded machine it+            -- can lose.+            bracket (openConnection testPort) close $ \_ -> pure ()++            withAsync (runSettingsSocket settings sock app) $ \server -> do+                stopAccepting <- takeMVar stopSlot+                -- The connection is accepted and the thread serving it is+                -- still parked, which is the window this is about.+                takeMVar accepted+                stopAccepting+                timeout 30_000_000 (wait server)+                    >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure+                -- Returning is what lets the process exit, so a connection+                -- still open here is one the client never hears back on.+                connectionsClosed <- readIORef closed+                connectionsClosed `shouldBe` 1++    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+    openConnection testPort = do+        client <- socket AF_INET Stream defaultProtocol+        connect client $+            SockAddrInet (fromIntegral testPort) (tupleToHostAddress (127, 0, 0, 1))+        pure client+    -- set number of clients to the number of keep-alive connections+    numClients = managerConnCount defaultManagerSettings+    connectionRefused = \case+        (HttpExceptionRequest _ (ConnectionFailure _)) -> True+        _ -> False++-- | Whether the exception is the one the thread manager kills a thread with.+byManager :: E.SomeException -> Bool+byManager e = case E.fromException e of+    Just (KilledByThreadManager _) -> True+    Nothing -> False

@@ -0,0 +1,75 @@+{-# LANGUAGE OverloadedStrings #-}++module HTTP2Spec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (bracket, throwIO)+import Data.ByteString (ByteString)+import Data.IORef+import Network.HTTP.Types (Status, ok200, status200)+import qualified Network.HTTP2.Client as C+import Network.Socket+import Network.Wai+import Network.Wai.Handler.Warp (+    Port,+    defaultSettings,+    setLogger,+    setOnException,+    withApplicationSettings,+ )+import Test.Hspec++spec :: Spec+spec = describe "http2server" $ do+    it "reports nothing for a connection the client closes" $ do+        excs <- newIORef []+        let settings = setOnException (\_ e -> modifyIORef' excs (show e :)) defaultSettings+        withApplicationSettings settings (pure hello) $ \port -> do+            get port `shouldReturn` (Just ok200, "hello")+            -- The connection ends once the client has closed it.+            threadDelay 100000+            -- http2's ConnectionIsClosed used to be reported here.+            readIORef excs `shouldReturn` []+    it "keeps the response of an application which throws after it" $ do+        excs <- newIORef (0 :: Int)+        logged <- newIORef []+        let settings =+                setLogger (\_ st _ -> modifyIORef' logged (st :)) $+                    setOnException (\_ _ -> modifyIORef' excs (+ 1)) defaultSettings+        withApplicationSettings settings (pure app) $ \port -> do+            get port `shouldReturn` (Just ok200, "hello")+            readIORef excs `shouldReturn` 1+            -- The second response used to go out and be logged, so the+            -- log said 500 where the client had been answered 200.+            readIORef logged `shouldReturn` [ok200]++hello :: Application+hello _ respond = respond $ responseLBS status200 [] "hello"++-- | Answers, then throws.  The response has gone out by then, so+--   nothing can replace it.+app :: Application+app _ respond = do+    _ <- respond $ responseLBS status200 [] "hello"+    throwIO $ userError "after the response"++-- | The status and body of one h2c request.+get :: Port -> IO (Maybe Status, ByteString)+get port = withTCP "127.0.0.1" port $ \sock ->+    bracket (C.allocSimpleConfig sock 4096) C.freeSimpleConfig $ \conf ->+        C.run cliconf conf $ \sendRequest _aux ->+            sendRequest (C.requestNoBody "GET" "/" []) $ \rsp -> do+                body <- C.getResponseBodyChunk rsp+                return (C.responseStatus rsp, body)+  where+    cliconf = C.defaultClientConfig{C.authority = "127.0.0.1"}++-- | 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

@@ -12,3 +12,9 @@     prop "" $ \(QC.Large n) ->         let n' = fromIntegral (abs n :: Int)          in packIntegral (n' :: Int) == C8.pack (show n')+    -- Every power of ten from 10^15 up used to be written into a buffer+    -- one byte too small for it.+    it "writes a number of any size" $+        let ns = [10 ^ e + d | e <- [0 .. 40 :: Int], d <- [-1, 0, 1 :: Integer]]+         in map packIntegral (filter (>= 0) ns)+                `shouldBe` map (C8.pack . show) (filter (>= 0) ns)

@@ -16,6 +16,22 @@ main :: IO () main = hspec spec +testUnsatisfiable+    :: S.ByteString+    -- ^ range value+    -> Spec+testUnsatisfiable range = it title $ withApp defaultSettings app $ withMySocket $ \ms -> do+    msWrite ms "GET / HTTP/1.0\r\n"+    msWrite ms "Range: bytes="+    msWrite ms range+    msWrite ms "\r\n\r\n"+    threadDelay 10000+    bss <- fmap (lines . filter (/= '\r') . S8.unpack) $ msRead ms 1024+    head bss `shouldContain` "416"+  where+    app _ = ($ responseFile status200 [] "attic/hex" Nothing)+    title = show range ++ " is not satisfiable"+ testRange     :: S.ByteString     -- ^ range value@@ -73,42 +89,26 @@  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"         testRange "5-" "56789abcdef" $ Just "5-15/16"         testRange "5-8" "5678" $ Just "5-8/16"         testRange "-3" "def" $ Just "13-15/16"-        testRange "16-" "" $ Just "*/16"+        -- A range which asks for nothing the file holds is 416, not a+        -- 206 of no bytes.  "bytes */16" is the 416 form of the header.+        testUnsatisfiable "16-"+        testUnsatisfiable "100-"+        testUnsatisfiable "-0"         testRange "-17" "0123456789abcdef" Nothing      describe "partial files" $ do

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -150,7 +151,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@@ -199,7 +200,7 @@ singleChunkedPostHello :: [ByteString] singleChunkedPostHello =     [ "POST /hello HTTP/1.1\r\nHost: localhost\r\nTransfer-Encoding: chunked\r\n\r\n"-    , "5\r\nHello\r\n0\r\n"+    , "5\r\nHello\r\n0\r\n\r\n"     ]  spec :: Spec@@ -281,34 +282,29 @@                         respond $ responseLBS status200 [] ""                 withApp defaultSettings app $ withMySocket $ f iheaders -        it "multiline headers" $ do+        it "refuses multiline headers" $ do             appWithSocket $ \iheaders ms -> do                 let input = "GET / HTTP/1.1\r\nfoo:    bar\r\n baz\r\n\tbin\r\n\r\n"                 msWrite ms input-                threadDelay 5000+                rsp <- msRead ms 17                 headers <- I.readIORef iheaders-                headers-                    `shouldBe` [ ("foo", "bar")-                               , (" baz", "")-                               , ("\tbin", "")-                               ]+                S8.unpack rsp `shouldContain` "400"+                headers `shouldBe` []         it "no space between colon and value" $ do             appWithSocket $ \iheaders ms -> do-                let input = "GET / HTTP/1.1\r\nfoo:bar\r\n\r\n"+                let input = "GET / HTTP/1.1\r\nHost: foo\r\nfoo:bar\r\n\r\n"                 msWrite ms input                 threadDelay 5000                 headers <- I.readIORef iheaders-                headers `shouldBe` [("foo", "bar")]-        it "does not recognize multiline headers" $ do+                headers `shouldBe` [("Host", "foo"), ("foo", "bar")]+        it "refuses multiline headers split across writes" $ do             appWithSocket $ \iheaders ms -> do                 msWrite ms "GET / HTTP/1.1\r\nfoo: and\r\n"                 msWrite ms " baz as well\r\n\r\n"-                threadDelay 5000+                rsp <- msRead ms 17                 headers <- I.readIORef iheaders-                headers-                    `shouldBe` [ ("foo", "and")-                               , (" baz as well", "")-                               ]+                S8.unpack rsp `shouldContain` "400"+                headers `shouldBe` []      describe "chunked bodies" $ do         it "works" $ do@@ -322,9 +318,9 @@             withApp defaultSettings app $ withMySocket $ \ms -> do                 let input =                         S.concat-                            [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+                            [ "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"                             , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"-                            , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+                            , "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"                             , "b\r\nHello World\r\n0\r\n\r\n"                             ]                 msWrite ms input@@ -348,7 +344,7 @@                 let input =                         concat $                             replicate 2 $-                                ["POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"]+                                ["POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"]                                     ++ replicate 50 "5\r\n12345\r\n"                                     ++ ["0\r\n\r\n"]                 mapM_ (msWrite ms) input@@ -357,8 +353,16 @@                     check $ count == 2                 front <- I.readIORef ifront                 front [] `shouldBe` replicate 2 (S.concat $ replicate 50 "12345")+#ifndef WINDOWS         -- For some reason, the following test on Windows causes the socket         -- to be killed prematurely. Worth investigating in the future if possible.+        --+        -- @+        --   test\RunSpec.hs:362:9:+        --   1) Run, chunked bodies, in chunks+        --        uncaught exception: IOException of type InvalidArgument+        --        Network.Socket.sendBuf: invalid argument (Invalid argument)+        -- @         it "in chunks" $ do             ifront <- I.newIORef id             countVar <- newTVarIO (0 :: Int)@@ -370,9 +374,9 @@             withApp defaultSettings app $ withMySocket $ \ms -> do                 let input =                         S.concat-                            [ "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"-                            , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n"-                            , "POST / HTTP/1.1\r\nTransfer-Encoding: Chunked\r\n\r\n"+                            [ "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"+                            , "c\r\nHello World\n\r\n3\r\nBye\r\n0\r\n\r\n"+                            , "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: Chunked\r\n\r\n"                             , "b\r\nHello World\r\n0\r\n\r\n"                             ]                 mapM_ (msWrite ms . S.singleton) $ S.unpack input@@ -384,6 +388,7 @@                     `shouldBe` [ "Hello World\nBye"                                , "Hello World"                                ]+#endif         it "timeout in request body" $ do             ifront <- I.newIORef id             let app req f = do@@ -392,7 +397,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 ->@@ -407,7 +412,7 @@                 let bs1 = S.replicate 2048 88                     bs2 = "This is short"                     bs = S.append bs1 bs2-                msWrite ms "POST / HTTP/1.1\r\n"+                msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\n"                 msWrite ms "content-length: "                 msWrite ms $ S8.pack $ show $ S.length bs                 msWrite ms "\r\n\r\n"@@ -415,9 +420,299 @@                 msWrite ms bs1                 threadDelay 100000                 msWrite ms bs2-                threadDelay 5000000+                threadDelay 1000000                 front <- I.readIORef ifront                 S.concat (front []) `shouldBe` bs++    describe "header field values" $ do+        let exchange hdrs = do+                ipaths <- I.newIORef id+                let app req f = do+                        I.atomicModifyIORef ipaths $ \front ->+                            (front . (rawPathInfo req :), ())+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms $+                        S.concat+                            [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                            , hdrs+                            , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+                            ]+                    rsp <- msRead ms 17+                    ipaths' <- I.readIORef ipaths+                    return (S8.unpack rsp, ipaths' [])+        it "refuses a bare CR" $ do+            -- A recipient which ends a line at the bare CR reads a+            -- Content-Length here, and so reads a body where warp would+            -- read the next request.+            (rsp, paths) <- exchange "X-Foo: a\rContent-Length: 36\r\n"+            rsp `shouldContain` "400"+            paths `shouldNotContain` ["/smuggled"]+        it "refuses a NUL" $ do+            (rsp, paths) <- exchange "X-Foo: a\NULb\r\n"+            rsp `shouldContain` "400"+            paths `shouldNotContain` ["/smuggled"]++    describe "Content-Length framing" $ do+        -- A Content-Length warp reads as no body at all, while whatever+        -- is in front of it reads a body, is a request smuggled onto the+        -- connection: the body is read here as the next request.+        let exchange hdrs = do+                ipaths <- I.newIORef id+                let app req f = do+                        I.atomicModifyIORef ipaths $ \front ->+                            (front . (rawPathInfo req :), ())+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms $+                        S.concat+                            [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                            , hdrs+                            , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+                            ]+                    rsp <- msRead ms 17+                    ipaths' <- I.readIORef ipaths+                    return (S8.unpack rsp, ipaths' [])+            refuses name hdrs = it name $ do+                (rsp, paths) <- exchange hdrs+                rsp `shouldContain` "400"+                paths `shouldNotContain` ["/smuggled"]+        refuses+            "refuses a Content-Length that is not a number"+            "Content-Length: abc\r\n"+        refuses+            "refuses a Content-Length that overflows"+            "Content-Length: 9223372036854775808\r\n"+        refuses+            "refuses Content-Lengths that disagree"+            "Content-Length: 0\r\nContent-Length: 36\r\n"+        it "accepts Content-Lengths that agree" $ do+            ifront <- I.newIORef id+            let app req f = do+                    bss <- consumeBody $ getRequestBodyChunk req+                    I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+                    f $ responseLBS status200 [] ""+            withApp defaultSettings app $ withMySocket $ \ms -> do+                msWrite ms $+                    S.concat+                        [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                        , "Content-Length: 5\r\nContent-Length: 05\r\n\r\n"+                        , "Hello"+                        ]+                _ <- msRead ms 17+                front <- I.readIORef ifront+                front [] `shouldBe` ["Hello"]++    describe "ambiguous body framing" $ do+        -- Each of these frames the body one way for warp and another way+        -- for anything in front of it. Whichever way warp reads them, the+        -- smuggled request must not reach the application.+        let exchange hdrs = do+                ipaths <- I.newIORef id+                let app req f = do+                        I.atomicModifyIORef ipaths $ \front ->+                            (front . (rawPathInfo req :), ())+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms $+                        S.concat+                            [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                            , hdrs+                            , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+                            ]+                    rsp <- msRead ms 17+                    ipaths' <- I.readIORef ipaths+                    return (S8.unpack rsp, ipaths' [])+            frames name hdrs = it name $ do+                (rsp, paths) <- exchange hdrs+                rsp `shouldContain` "200"+                paths `shouldNotContain` ["/smuggled"]+            refuses name hdrs status = it name $ do+                (rsp, paths) <- exchange hdrs+                rsp `shouldContain` status+                paths `shouldNotContain` ["/smuggled"]+        frames+            "reads a trailing space as part of the chunked coding"+            "Transfer-Encoding: chunked \r\n"+        frames+            "reads a trailing tab as part of the chunked coding"+            "Transfer-Encoding: chunked\t\r\n"+        frames+            "ignores an empty element after the chunked coding"+            "Transfer-Encoding: chunked,\r\n"+        frames+            "ignores an empty element before the chunked coding"+            "Transfer-Encoding: , chunked\r\n"+        refuses+            "refuses a Transfer-Encoding with no coding at all"+            "Transfer-Encoding: ,\r\n"+            "400"+        refuses+            "refuses a coding it cannot decode under chunked"+            "Transfer-Encoding: gzip, chunked\r\n"+            "501"+        refuses+            "refuses chunked that is not the final coding"+            "Transfer-Encoding: chunked, gzip\r\n"+            "400"+        refuses+            "refuses a transfer coding that is not chunked"+            "Transfer-Encoding: identity\r\n"+            "400"+        refuses+            "joins Transfer-Encoding field lines before reading them"+            "Transfer-Encoding: chunked\r\nTransfer-Encoding: identity\r\n"+            "400"+        refuses+            "refuses Content-Length together with Transfer-Encoding"+            "Content-Length: 0\r\nTransfer-Encoding: chunked\r\n"+            "400"+        it "still reads an ordinary chunked body" $ do+            ifront <- I.newIORef id+            let app req f = do+                    bss <- consumeBody $ getRequestBodyChunk req+                    I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+                    f $ responseLBS status200 [] ""+            withApp defaultSettings app $ withMySocket $ \ms -> do+                msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: chunked \r\n\r\n"+                msWrite ms "b\r\nHello World\r\n0\r\n\r\n"+                _ <- msRead ms 17+                front <- I.readIORef ifront+                front [] `shouldBe` ["Hello World"]++    describe "header field names" $ do+        -- Each of these is refused rather than repaired: a recipient+        -- which repairs it reads a body of 36 bytes, which warp would+        -- read as a request of its own.+        let refuses name hdrs = it name $ do+                ipaths <- I.newIORef id+                let app req f = do+                        I.atomicModifyIORef ipaths $ \front ->+                            (front . (rawPathInfo req :), ())+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms $+                        S.concat+                            [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                            , hdrs+                            , "\r\nGET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+                            ]+                    rsp <- msRead ms 17+                    paths <- I.readIORef ipaths+                    S8.unpack rsp `shouldContain` "400"+                    paths [] `shouldNotContain` ["/smuggled"]+        refuses+            "refuses whitespace between a field name and its colon"+            "Content-Length : 36\r\n"+        refuses+            "refuses a control character in a field name"+            "Content-Length\v: 36\r\n"+        refuses+            "refuses a continuation line"+            "X-Foo: bar\r\n Content-Length: 36\r\n"+        refuses+            "refuses an empty field name"+            ": 36\r\n"++    describe "Host" $ do+        -- A proxy routes on the first Host and the application reads the+        -- last, so a request they can read differently is refused rather+        -- than served to whichever host warp happens to pick.+        let send req = do+                ihosts <- I.newIORef id+                let app r f = do+                        I.atomicModifyIORef ihosts $ \front ->+                            (front . (requestHeaderHost r :), ())+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms req+                    rsp <- msRead ms 17+                    hosts <- I.readIORef ihosts+                    return (S8.unpack rsp, hosts [])+        it "refuses a HTTP/1.1 request without one" $ do+            (rsp, hosts) <- send "GET /nohost HTTP/1.1\r\n\r\n"+            rsp `shouldContain` "400"+            hosts `shouldBe` []+        it "refuses more than one" $ do+            (rsp, hosts) <- send "GET /dup HTTP/1.1\r\nHost: a\r\nHost: b\r\n\r\n"+            rsp `shouldContain` "400"+            hosts `shouldBe` []+        it "serves a HTTP/1.0 request without one" $ do+            (rsp, hosts) <- send "GET /nohost HTTP/1.0\r\n\r\n"+            rsp `shouldContain` "200"+            hosts `shouldBe` [Nothing]++    describe "malformed chunked bodies" $ do+        -- The body is what the client says it is up to the empty line+        -- which ends the trailer section. Each of these used to end the+        -- body early, leaving the rest of it to be read as the next+        -- request on the connection.+        let withChunked body = do+                ipaths <- I.newIORef id+                let app req f = do+                        I.atomicModifyIORef ipaths $ \front ->+                            (front . (rawPathInfo req :), ())+                        _ <- consumeBody $ getRequestBodyChunk req+                        f $ responseLBS status200 [] ""+                withApp defaultSettings app $ withMySocket $ \ms -> do+                    msWrite ms $+                        S.concat+                            [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                            , "Transfer-Encoding: chunked\r\n\r\n"+                            , body+                            ]+                    rsp <- msRead ms 17+                    ipaths' <- I.readIORef ipaths+                    return (S8.unpack rsp, ipaths' [])+            smuggled = "GET /smuggled HTTP/1.1\r\nHost: foo\r\n\r\n"+            refuses name body = it name $ do+                (rsp, paths) <- withChunked body+                rsp `shouldContain` "400"+                paths `shouldNotContain` ["/smuggled"]+        refuses "refuses a chunk size that is not a number" smuggled+        refuses+            "refuses a chunk that is not closed off by CRLF"+            (S.concat ["5\r\nHello", smuggled])+        refuses "refuses a chunk size that overflows" "ffffffffffffffffff\r\n"+        it "refuses a chunk cut short by the end of input" $ do+            -- A chunk promising a hundred bytes with ten sent and nothing+            -- more. The body ended there and the application was handed a+            -- short one as though it were whole: yesodweb/wai#1129.+            ref <- I.newIORef Nothing+            let onExc _ = I.writeIORef ref . Just+                app req f = do+                    _ <- consumeBody $ getRequestBodyChunk req+                    f $ responseLBS status200 [] ""+            withApp (setOnException onExc defaultSettings) app $ withMySocket $ \ms -> do+                msWrite ms $+                    S.concat+                        [ "POST / HTTP/1.1\r\nHost: foo\r\n"+                        , "Transfer-Encoding: chunked\r\n\r\n"+                        , "64\r\n"+                        , S8.pack (replicate 10 'A')+                        ]+                msClose ms+                threadDelay 100000+                res <- I.readIORef ref+                show res `shouldBe` show (Just ConnectionClosedByPeer)+        it "reads the trailer section to its end" $ do+            (rsp, paths) <- withChunked $ S.concat ["0\r\nX-Trailer: y\r\n", smuggled]+            rsp `shouldContain` "200"+            paths `shouldBe` ["/"]+        it "reads a chunk size split over several reads" $ do+            ifront <- I.newIORef id+            let app req f = do+                    bss <- consumeBody $ getRequestBodyChunk req+                    I.atomicModifyIORef ifront $ \front -> (front . (S.concat bss :), ())+                    f $ responseLBS status200 [] ""+            withApp defaultSettings app $ withMySocket $ \ms -> do+                msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\nTransfer-Encoding: chunked\r\n\r\n"+                forM_ ["1", "2", "\r\n", S.replicate 0x12 65, "\r\n0\r\n\r\n"] $+                    \piece -> threadDelay 50000 >> msWrite ms piece+                _ <- msRead ms 17+                front <- I.readIORef ifront+                front [] `shouldBe` [S.replicate 0x12 65]+     describe "raw body" $ do         it "works" $ do             let app _req f = do@@ -431,7 +726,7 @@                         loop                 doubleBS = S.concatMap $ \w -> S.pack [w, w]             withApp defaultSettings app $ withMySocket $ \ms -> do-                msWrite ms "POST / HTTP/1.1\r\n\r\n12345"+                msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\n\r\n12345"                 timeout 100000 (msRead ms 10) `shouldReturn` Just "1122334455"                 msWrite ms "67890"                 timeout 100000 (msRead ms 10) `shouldReturn` Just "6677889900"@@ -464,7 +759,7 @@                             loop                 loop         withApp defaultSettings app $ withMySocket $ \ms -> do-            msWrite ms "POST / HTTP/1.1\r\ntransfer-encoding: chunked\r\n\r\n"+            msWrite ms "POST / HTTP/1.1\r\nHost: foo\r\ntransfer-encoding: chunked\r\n\r\n"             threadDelay 10000             msWrite ms "5\r\nhello\r\n0\r\n\r\n"             atomically $ do@@ -479,6 +774,21 @@         withApp defaultSettings app $ \port -> do             res <- sendGET $ "http://127.0.0.1:" ++ show port             responseBody res `shouldBe` "HelloHelloHelloHello"++    describe "setUnsafeClose" $ do+        let app _ f = f $ responseLBS status200 [("content-length", "6")] "unsafe"+            readAll s = do+                bs <- safeRecv s 4096+                if S.null bs then return [] else (bs :) <$> readAll s+            closes tm =+                withApp (setGracefulCloseTimeout1 tm $ setUnsafeClose True defaultSettings) app $+                    withMySocket $ \ms -> do+                        msWrite ms "GET / HTTP/1.1\r\nHost: localhost\r\nconnection: close\r\n\r\n"+                        bs <- S.concat <$> readAll (msSocket ms)+                        S.takeWhile (/= 13) bs `shouldBe` "HTTP/1.1 200 OK"+                        snd (S.breakSubstring "\r\n\r\n" bs) `shouldBe` "\r\n\r\nunsafe"+        it "closes with unsafeClose" $ closes 0+        it "closes with unsafeGracefulClose" $ closes 1000      describe "head requests" $ do         let fp = "test/head-response"

@@ -10,9 +10,7 @@ import Network.Wai.Handler.Warp.SendFile import Network.Wai.Handler.Warp.Types import System.Directory-import System.Exit import qualified System.IO as IO-import System.Process (system) import Test.Hspec  main :: IO ()@@ -53,11 +51,11 @@      describe "readSendFile" $ do         it "sends a file correctly (1)" $-            tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` ExitSuccess+            tryReadSendFile 10 0 1474 ["foo"] `shouldReturn` True         it "sends a file correctly (2)" $-            tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` ExitSuccess+            tryReadSendFile 10 0 1474 ["012345678", "901234"] `shouldReturn` True         it "sends a file correctly (3)" $-            tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` ExitSuccess+            tryReadSendFile 10 20 100 ["012345678", "901234"] `shouldReturn` True  tryPackHeader :: Int -> [ByteString] -> IO Int tryPackHeader siz hdrs = bracket (allocateBuffer siz) freeBuffer $ \buf ->@@ -77,7 +75,7 @@     send = BS.appendFile outputFile     hook = return () -tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO ExitCode+tryReadSendFile :: Int -> Integer -> Integer -> [ByteString] -> IO Bool tryReadSendFile siz off len hdrs = bracket setup teardown $ \buf -> do     mapM_ (BS.appendFile expectedFile) hdrs     copyfile inputFile expectedFile off len@@ -105,8 +103,12 @@             return $ bs == bs'         else return $ bs == "" -compareFiles :: FilePath -> FilePath -> IO ExitCode-compareFiles file1 file2 = system $ "cmp -s " ++ file1 ++ " " ++ file2+-- | Whether two files hold the same bytes.+--+-- This used to shell out to @cmp@, which Windows does not have, so these+-- three were the only tests here that could not pass there.+compareFiles :: FilePath -> FilePath -> IO Bool+compareFiles file1 file2 = (==) <$> BS.readFile file1 <*> BS.readFile file2  copyfile :: FilePath -> FilePath -> Integer -> Integer -> IO () copyfile src dst off len =

@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module ServerStateSpec where++import Network.Wai.Handler.Warp (getServerState)+import Network.Wai.Handler.Warp.Counter (Counter, forkConnection)+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++-- | One more connection on the counter, through a fork which makes no+--   thread: the place is kept and never taken, which is all these tests+--   ask of the counter.+countOneMore :: Counter -> IO ()+countOneMore counter = forkConnection counter (\_ -> return ()) (\_ -> return ())++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)+                    countOneMore $ serverConnectionCounter outerSS+                    bothCount 1+                    countOneMore $ 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+                    countOneMore $ serverConnectionCounter ss+                    currentOpenConnections ss `shouldReturn` i+            (ss1, set1) <- makeServerState defaultSettings+            incAndCheck ss1 1+            (ss2, _set2) <- makeServerState set1+            incAndCheck ss2 2+            incAndCheck ss1 3

@@ -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

@@ -1,19 +1,19 @@ cabal-version:      >=1.10 name:               warp-version:            3.4.12+version:            3.4.21 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,27 +98,26 @@     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,+        recv >=0.1.3 && <0.2.0,         simple-sendfile >=0.2.7 && <0.3,         stm >=2.3,         streaming-commons >=0.1.10,         text,-        time-manager >=0.2 && <0.4,+        time-manager >=0.5 && <0.6,         vault >=0.3,-        wai >=3.2.4 && <3.3,+        wai >=3.2.5 && <3.3,         word8      if flag(x509)@@ -131,7 +132,7 @@             network-bytestring >=0.1.3 && <0.1.4      else-        build-depends: network >=2.3+        build-depends: network >=3.2.12      if flag(warp-debug)         cpp-options: -DWARP_DEBUG@@ -178,12 +179,17 @@     build-tool-depends: hspec-discover:hspec-discover     hs-source-dirs:     test .     other-modules:+        BufferSpec         ConduitSpec         ConnectionSpec+        ConnectionExceptionSpec+        EarlyHintsSpec         ExceptionSpec         FdCacheSpec         FileSpec+        GracefulShutdownSpec         HTTP+        HTTP2Spec         PackIntSpec         ReadIntSpec         RequestSpec@@ -191,6 +197,7 @@         ResponseSpec         RunSpec         SendFileSpec+        ServerStateSpec         WithApplicationSpec         Network.Wai.Handler.Warp         Network.Wai.Handler.Warp.Internal@@ -221,6 +228,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@@ -233,7 +241,6 @@     build-depends:         base >=4.8 && <5,         QuickCheck,-        array,         auto-update,         async,         bsb-http-chunked <0.1,@@ -241,24 +248,26 @@         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,         process,-        recv >=0.1.0 && <0.2.0,+        recv >=0.1.3 && <0.2.0,         simple-sendfile >=0.2.4 && <0.3,         stm >=2.3,         streaming-commons >=0.1.10,         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)@@ -290,19 +299,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)@@ -311,19 +327,21 @@     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,@@ -347,6 +365,78 @@         build-depends:             time,             unix-compat >=0.2++    if impl(ghc >=8)+        default-extensions: Strict StrictData++benchmark response+    type:             exitcode-stdio-1.0+    main-is:          ResponseBench.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.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)+        other-modules: Paths_warp++    default-language: Haskell2010+    ghc-options:      -threaded+    build-depends:+        base >=4.8 && <5,+        array,+        auto-update,+        bsb-http-chunked,+        bytestring,+        case-insensitive,+        containers,+        criterion,+        hashable,+        http-date,+        http-types,+        network,+        recv,+        stm,+        streaming-commons,+        text,+        time-manager,+        vault,+        wai,+        word8++    if flag(x509)+        build-depends: crypton-x509++    if (((os(linux) || os(freebsd)) || os(osx)) && flag(allow-sendfilefd))+        cpp-options:   -DSENDFILEFD+        build-depends: unix++    if os(windows)+        cpp-options:   -DWINDOWS+        build-depends:+            time,+            unix-compat >=0.2+    else+        other-modules: Network.Wai.Handler.Warp.MultiMap+        build-depends: unix      if impl(ghc >=8)         default-extensions: Strict StrictData