warp 3.4.15 → 3.4.16

raw patch · 22 files changed

+764/−175 lines, 22 filesdep +arraydep ~auto-updatedep ~basedep ~bsb-http-chunkedPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: array

Dependency ranges changed: auto-update, base, bsb-http-chunked, bytestring, case-insensitive, http-types, network, recv, stm, streaming-commons, time-manager, vault, wai

API changes (from Hackage documentation)

Files

• ChangeLog.md +21/−0
• Network/Wai/Handler/Warp.hs +64/−38
• Network/Wai/Handler/Warp/Conduit.hs +8/−4
• Network/Wai/Handler/Warp/Counter.hs +2/−2
• Network/Wai/Handler/Warp/FdCache.hs +17/−13
• Network/Wai/Handler/Warp/HTTP2.hs +1/−1
• Network/Wai/Handler/Warp/HTTP2/File.hs +1/−1
• Network/Wai/Handler/Warp/HTTP2/Request.hs +12/−3
• Network/Wai/Handler/Warp/IO.hs +38/−9
• Network/Wai/Handler/Warp/Request.hs +7/−1
• Network/Wai/Handler/Warp/Response.hs +34/−14
• Network/Wai/Handler/Warp/ResponseHeader.hs +28/−6
• Network/Wai/Handler/Warp/Run.hs +57/−36
• Network/Wai/Handler/Warp/SendFile.hs +2/−2
• Network/Wai/Handler/Warp/Settings.hs +54/−36
• Network/Wai/Handler/Warp/Types.hs +12/−3
• bench/ResponseBench.hs +124/−0
• test/ConnectionExceptionSpec.hs +130/−0
• test/EarlyHintsSpec.hs +5/−0
• test/GracefulShutdownSpec.hs +60/−2
• test/RunSpec.hs +10/−0
• warp.cabal +77/−4

@@ -1,5 +1,26 @@ # ChangeLog for warp +## 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

@@ -52,6 +52,7 @@     setPort,     setHost,     setOnException,+    setOnConnectionException,     setOnExceptionResponse,     setOnOpen,     setOnClose,@@ -86,6 +87,7 @@     getOnOpen,     getOnClose,     getOnException,+    getOnConnectionException,     getGracefulShutdownTimeout,     getGracefulCloseTimeout1,     getGracefulCloseTimeout2,@@ -192,24 +194,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' --@@ -223,7 +240,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} @@ -231,13 +248,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} @@ -249,14 +266,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} @@ -272,7 +289,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} @@ -296,7 +313,7 @@ -- -- Default: do nothing. ----- Since 2.1.0+-- @since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings setBeforeMainLoop x y = y{settingsBeforeMainLoop = x} @@ -306,19 +323,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 @@ -334,9 +351,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 @@ -370,7 +396,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} @@ -379,7 +405,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} @@ -394,7 +420,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"@@ -407,7 +433,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'}@@ -419,13 +445,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} @@ -441,7 +467,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} @@ -457,25 +483,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@@ -501,7 +527,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@@ -510,7 +536,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@@ -519,13 +545,13 @@  -- | 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} @@ -534,7 +560,7 @@ -- 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 @@ -553,7 +579,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"))@@ -564,14 +590,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 @@ -579,14 +605,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 @@ -597,7 +623,7 @@ -- -- /DEPRECATED in favor of 'getServerState'/ ----- Since 3.4.11+-- @since 3.4.11 getOpenConnectionCounter :: Settings -> Maybe Counter getOpenConnectionCounter = settingsConnectionCounter @@ -607,14 +633,14 @@ -- -- See 'makeSettingsAndServerState' to create 'Settings' with a 'ServerState'. ----- Since 3.4.12+-- @since 3.4.12 getServerState :: Settings -> Maybe ServerState getServerState = settingsServerState  #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

@@ -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@@ -86,7 +90,7 @@     withLen len bs         | S.null bs = do             -- FIXME should this throw an exception if len > 0?-            I.writeIORef ref DoneChunking+            I.writeIORef ref DoneChunking -- [WRITE_IOREF_NOTE]             return S.empty         | otherwise =             case S.length bs `compare` fromIntegral len of@@ -98,7 +102,7 @@                     yield' x NeedLenNewline      yield' bs mlen = do-        I.writeIORef ref mlen+        I.writeIORef ref mlen -- [WRITE_IOREF_NOTE]         return bs      dropCRLF = do@@ -124,7 +128,7 @@     go (HaveLen 0) = do         -- Drop the final CRLF         dropCRLF-        I.writeIORef ref DoneChunking+        I.writeIORef ref DoneChunking -- [WRITE_IOREF_NOTE]         return S.empty     go (HaveLen len) = do         bs <- readSource src@@ -136,7 +140,7 @@         bs <- readSource src         if S.null bs             then do-                I.writeIORef ref $ assert False $ HaveLen 0+                I.writeIORef ref $ assert False $ HaveLen 0 -- [WRITE_IOREF_NOTE]                 return S.empty             else do                 (x, y) <-

@@ -47,12 +47,12 @@  -- | Get the current count of open connections. ----- Since 3.4.11+-- @since 3.4.11 getCount :: Counter -> IO Int getCount (Counter var) = readTVarIO var  -- | Get the current count in an 'STM' transaction. ----- Since 3.4.13+-- @since 3.4.13 getCountSTM :: Counter -> STM Int getCountSTM (Counter tvar) = readTVar tvar

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

@@ -86,7 +86,7 @@  -- | Converting WAI application to the server type of http2 library. ----- Since 3.3.11+-- @since 3.3.11 http2server     :: String     -> S.Settings

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

@@ -97,12 +97,21 @@     (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)

@@ -5,23 +5,47 @@ 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@@ -42,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 + fromIntegral (B.length bs)+                loop writeBuffer 0 next $+                    totalBytesSent + fromIntegral (B.length bs)

@@ -88,7 +88,9 @@     -- 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@@ -216,6 +218,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

@@ -44,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@@ -289,22 +289,42 @@ ----------------------------------------------------------------  sendRsp conn _ th ver s hs rspidxhdr maxRspBufSize _ (RspBuilder body needsChunked) = do-    (header, hdrLen) <- composeHeaderBuilder ver s hs rspidxhdr needsChunked-    let hdrBdy-            | needsChunked =-                header-                    <> chunkedTransferEncoding body-                    <> chunkedTransferTerminator-            | otherwise = header <> body-        writeBufferRef = connWriteBuffer conn+    writeBuffer <- readIORef writeBufferRef     len <--        toBufIOWith-            maxRspBufSize-            writeBufferRef-            (\bs -> connSendAll conn bs >> T.tickle th)-            hdrBdy+        -- 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  ---------------------------------------------------------------- 

@@ -1,7 +1,11 @@ {-# 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)@@ -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 + List.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 "

@@ -21,7 +21,7 @@ import qualified Control.Exception as E import qualified Data.ByteString as S import Data.Functor (($>))-import Data.IORef (newIORef, readIORef, IORef, writeIORef)+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE) import GHC.Conc.Sync (labelThread, myThreadId)@@ -63,7 +63,7 @@ import Network.Wai.Handler.Warp.Imports hiding (readInt) 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.ShuttingDown (readShuttingDown, writeShuttingDown) import Network.Wai.Handler.Warp.Types  -- | Creating 'Connection' for plain HTTP based on a given socket.@@ -91,7 +91,7 @@                         if h2                             then settingsGracefulCloseTimeout2 set                             else settingsGracefulCloseTimeout1 set-                if tm == 0+                if tm <= 0                     then close s                     else gracefulClose s tm `E.catch` throughAsync (return ()) #else@@ -126,9 +126,7 @@             hook             headers -    sendall = sendAll' s--    sendAll' sock bs =+    sendall bs =         E.handleJust             ( \e ->                 if ioeGetErrorType e == ResourceVanished@@ -136,7 +134,7 @@                     else Nothing             )             E.throwIO-            $ Sock.sendAll sock bs+            $ Sock.sendAll s bs  -- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make -- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes@@ -144,6 +142,18 @@ -- actively using this 'Socket'. makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv makeGracefulRecv sock pool ss appsInProgress = do+    tryFastPath <- not <$> readShuttingDown (serverShuttingDown ss)+    if tryFastPath then do+        mbs <- receiveNoWait sock pool+        case mbs of+          Just bs -> return bs+          Nothing -> slowPath+      else slowPath+  where+    slowPath = makeGracefulRecvSlow sock pool ss appsInProgress++makeGracefulRecvSlow :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecvSlow sock pool ss appsInProgress = do     sockWait <- #if !WINDOWS && MIN_VERSION_network(3,2,2)         waitReadSocketSTM sock@@ -174,7 +184,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"@@ -235,7 +245,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@@ -260,7 +270,7 @@ -- 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 oldSettings getConnMaker app = do@@ -272,7 +282,7 @@  -- | 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 ->@@ -398,29 +408,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 = do+    -- Count the connection here rather than in 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.+    increase counter+    settingsFork set $ \unmask -> runConnection unmask `E.finally` decrease counter   where+    runConnection 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 (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@@ -442,8 +460,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@@ -531,8 +549,11 @@ 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+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

@@ -44,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'@@ -57,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 ()@@ -82,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.     --@@ -91,7 +104,7 @@     --     -- Default: 'defaultFork'     ---    -- Since 3.0.4+    -- @since 3.0.4     , settingsAccept :: Socket -> IO (Socket, SockAddr)     -- ^ Code to accept a new connection.     --@@ -100,7 +113,7 @@     --     -- Default: 'defaultAccept'     ---    -- Since 3.3.24+    -- @since 3.3.24     , settingsNoParsePath :: Bool     -- ^ Perform no parsing on the rawPathInfo.     --@@ -108,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.@@ -116,27 +129,27 @@     --     -- 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.     --@@ -146,38 +159,38 @@     -- /after all the headers have been sent. This is 'Nothing' when/     -- /'responseRaw' is used. (e.g. when using websockets)/     ---    -- Since 3.1.10+    -- @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`).@@ -191,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,@@ -201,7 +214,7 @@     --     -- /DEPRECATED in favor of 'settingsServerState'/     ---    -- Since 3.4.11+    -- @since 3.4.11     , settingsServerState :: Maybe ServerState     -- ^ Internal read-only server state.     -- Use 'makeSettingsAndServerState' to gain access to the state of the server.@@ -210,7 +223,7 @@     --     -- Default: 'Nothing' (warp creates its own internal state)     ---    -- Since 3.4.13+    -- @since 3.4.13     }  -- | Specify usage of the PROXY protocol.@@ -224,7 +237,7 @@  -- | Internal read-only state of the server ----- Since 3.4.13+-- @since 3.4.13 data ServerState = ServerState     { serverConnectionCounter :: Counter     , serverShuttingDown :: ShuttingDown@@ -238,7 +251,7 @@ -- This makes it idempotent if care is taken that the @oldSettings@ -- are not used after using this function. ----- Since 3.4.13+-- @since 3.4.13 makeServerState :: Settings -> IO (ServerState, Settings) makeServerState oldSettings =     case settingsServerState oldSettings of@@ -256,7 +269,7 @@  -- | Initialize a 'ServerState' ----- Since 3.4.13+-- @since 3.4.13 newServerState :: IO ServerState newServerState = do     counter <- newCounter@@ -269,13 +282,17 @@  -- | Get the currently open connections of the server. ----- Since 3.4.13+-- 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. ----- Since 3.4.13+-- Connections are considered "open" the moment they are accepted by the socket.+--+-- @since 3.4.13 currentOpenConnectionsSTM :: ServerState -> STM Int currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter @@ -284,7 +301,7 @@ -- > False: Server is not shutting down -- > True:  Server is shutting down or has shut down. ----- Since 3.4.13+-- @since 3.4.13 currentShuttingDownState :: ServerState -> IO Bool currentShuttingDownState = readShuttingDown . serverShuttingDown @@ -295,7 +312,7 @@ -- > False: Server is not shutting down -- > True:  Server is shutting down or has shut down. ----- Since 3.4.13+-- @since 3.4.13 currentShuttingDownStateSTM :: ServerState -> STM Bool currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown @@ -307,6 +324,7 @@         { settingsPort = 3000         , settingsHost = "*4"         , settingsOnException = defaultOnException+        , settingsOnConnectionException = Nothing         , settingsOnExceptionResponse = defaultOnExceptionResponse         , settingsOnOpen = const $ return True         , settingsOnClose = const $ return ()@@ -341,7 +359,7 @@ -- -- /DEPRECATED in favor of 'makeSettingsAndServerState'/ ----- Since 3.4.11+-- @since 3.4.11 makeSettingsAndCounter :: IO (Counter, Settings) makeSettingsAndCounter = do     (serverState, settings) <- makeSettingsAndServerState@@ -351,7 +369,7 @@ -- Use functions like 'currentOpenConnections' and 'currentShuttingDownState' -- to gain insight into the state of the server. ----- Since 3.4.13+-- @since 3.4.13 makeSettingsAndServerState :: IO (ServerState, Settings) makeSettingsAndServerState = makeServerState defaultSettings @@ -359,7 +377,7 @@ -- 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@@ -372,7 +390,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) $@@ -382,10 +400,10 @@  -- | 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 defaultOnExceptionResponse :: SomeException -> Response defaultOnExceptionResponse e     | isAsyncException e = throw e@@ -413,7 +431,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@@ -423,7 +441,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.

@@ -6,7 +6,7 @@ import Control.Concurrent.STM (TVar) import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IORef (IORef, writeIORef, newIORef, readIORef) #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif@@ -80,7 +80,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@@ -88,7 +88,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@@ -137,9 +137,12 @@     -- @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 @@ -155,6 +158,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@@ -162,6 +167,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@@ -172,9 +178,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 

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

@@ -22,6 +22,10 @@ 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@@ -64,6 +68,7 @@         sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)         connect sock (addrAddress addr)         return sock+#endif #else spec :: Spec spec = describe "HTTP/2 Early Hints" $

@@ -1,6 +1,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NumericUnderscores #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}  module GracefulShutdownSpec (spec) where @@ -8,16 +9,68 @@ import Control.Concurrent.Async import Control.Exception (bracket) import Control.Monad (void)+import Data.IORef import Network.HTTP.Client import Network.HTTP.Types (ok200, status200)-import Network.Socket (close)+import Network.Socket import Network.Wai (responseLBS) import Network.Wai.Handler.Warp import System.Timeout (timeout) import Test.Hspec  spec :: Spec-spec = describe "graceful shutdown" $+spec = describe "graceful shutdown" $ do+    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 <- newIORef (0 :: Int)+        closed <- newIORef (0 :: Int)++        let slowFork :: ((forall a. IO a -> IO a) -> IO ()) -> IO ()+            slowFork act = void $ forkIOWithUnmask $ \unmask -> do+                threadDelay 200_000+                act unmask++            -- Take one connection, then stop accepting by closing the+            -- listening socket, which is what a graceful shutdown does. The+            -- close happens here rather than from another thread so that it+            -- cannot land while the accept loop is parked inside accept().+            acceptOnlyOne sock = do+                taken <- atomicModifyIORef' accepted $ \n -> (n + 1, n)+                if taken == 0+                    then accept sock+                    else close sock >> accept sock++            settings =+                setFork slowFork $+                    setAccept acceptOnlyOne $+                        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+                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@@ -76,6 +129,11 @@                         -- 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

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -357,8 +358,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)@@ -384,6 +393,7 @@                     `shouldBe` [ "Hello World\nBye"                                , "Hello World"                                ]+#endif         it "timeout in request body" $ do             ifront <- I.newIORef id             let app req f = do

@@ -1,6 +1,6 @@ cabal-version:      >=1.10 name:               warp-version:            3.4.15+version:            3.4.16 license:            MIT license-file:       LICENSE maintainer:         michael@snoyman.com@@ -110,12 +110,12 @@         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.2 && <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.2 && <0.5,         vault >=0.3,         wai >=3.2.5 && <3.3,         word8@@ -182,6 +182,7 @@         BufferSpec         ConduitSpec         ConnectionSpec+        ConnectionExceptionSpec         EarlyHintsSpec         ExceptionSpec         FdCacheSpec@@ -256,7 +257,7 @@         iproute >=1.3.1,         network,         process,-        recv >=0.1.0 && <0.2.0,+        recv >=0.1.2 && <0.2.0,         simple-sendfile >=0.2.4 && <0.3,         stm >=2.3,         streaming-commons >=0.1.10,@@ -363,6 +364,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