warp 3.4.10 → 3.4.16
raw patch · 33 files changed
Files
- ChangeLog.md +88/−0
- Network/Wai/Handler/Warp.hs +109/−36
- Network/Wai/Handler/Warp/Conduit.hs +8/−4
- Network/Wai/Handler/Warp/Counter.hs +25/−4
- Network/Wai/Handler/Warp/FdCache.hs +17/−13
- Network/Wai/Handler/Warp/File.hs +42/−30
- Network/Wai/Handler/Warp/HTTP1.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2.hs +17/−3
- Network/Wai/Handler/Warp/HTTP2/File.hs +1/−1
- Network/Wai/Handler/Warp/HTTP2/Request.hs +19/−10
- Network/Wai/Handler/Warp/Header.hs +101/−101
- Network/Wai/Handler/Warp/IO.hs +39/−9
- Network/Wai/Handler/Warp/Internal.hs +35/−1
- Network/Wai/Handler/Warp/Request.hs +18/−14
- Network/Wai/Handler/Warp/Response.hs +207/−121
- Network/Wai/Handler/Warp/ResponseHeader.hs +29/−7
- Network/Wai/Handler/Warp/Run.hs +185/−64
- Network/Wai/Handler/Warp/SendFile.hs +2/−2
- Network/Wai/Handler/Warp/Settings.hs +176/−27
- Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
- Network/Wai/Handler/Warp/Types.hs +22/−8
- bench/Parser.hs +16/−0
- bench/ResponseBench.hs +124/−0
- test/BufferSpec.hs +38/−0
- test/ConnectionExceptionSpec.hs +130/−0
- test/ConnectionSpec.hs +81/−0
- test/EarlyHintsSpec.hs +77/−0
- test/GracefulShutdownSpec.hs +141/−0
- test/ResponseSpec.hs +8/−28
- test/RunSpec.hs +14/−4
- test/ServerStateSpec.hs +58/−0
- test/WithApplicationSpec.hs +9/−3
- warp.cabal +109/−17
ChangeLog.md view
@@ -1,5 +1,93 @@ # 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+ `requestSendEarlyHints`, so a WAI application can emit informational responses+ ahead of the final response.+ [#1085](https://github.com/yesodweb/wai/pull/1085).+* Rework keep alive logic for HTTP/1.X so connections won't be automatically+ closed on HEAD requests anymore. Should conform more to spec in general.+ Should also reliably close connection when user created `Response` headers+ contain a `Connection: close` entry (HTTP/1.1).+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Replace multiline header value support with sanitizing newlines and NUL bytes+ with spaces. (as per RFC 9110 section 5.5)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+* Size for responses in `Maybe Integer` argument of `settingsLogger` now+ consistently and always gives amount of bytes of the sent raw __message body__.+ It will only be `Nothing` when using `responseRaw` (mostly used for websockets)+ [#1086](https://github.com/yesodweb/wai/pull/1086)+ * `responseFile`: no change, gives size of file (part)+ * `responseBuilder/responseLBS`:+ * included the status and header lines, now fixed+ * large `ByteString` chunks would not get counted, now fixed+ * `responseStream`: now counts bytes of body sent+ * `responseRaw`: will always be `Nothing`+* Rework internal indexed headers to records for performance and to remove+ dependencies on `array`.+ [#1092](https://github.com/yesodweb/wai/pull/1092) [#1093](https://github.com/yesodweb/wai/pull/1093)++## 3.4.14++* Important bugfix to not deadlock on empty file descriptors if the cause of+ the file descriptor exhaustion is outside of the server's control.+ (i.e. the server does not have any running connections and can't use a file+ descriptor to create the next connection)+ [#1084](https://github.com/yesodweb/wai/pull/1084)++## 3.4.13.1++* Bugfix to fall back to "blocking `recv`" when on Windows systems and when+ using `network < 3.2.2`.+ [#1077](https://github.com/yesodweb/wai/pull/1077)++## 3.4.13++* Change graceful shutdown logic to stop accepting data from idle connections,+ but to wait for busy `Application`s, adding `Connection: close` headers to+ responses if the server is shutting down.+ This should make sure the server doesn't wait for idle keep-alive connections.+* Expose a broader way to access internal state like the open connection `Counter`+ and whether the server is currently `ShuttingDown` or not.+ Users can use `makeSettingsAndServerState` to get a `ServerState` while+ making `defaultSettings`.+ [#1071](https://github.com/yesodweb/wai/pull/1071)++## 3.4.12++* Respond with `Connection: close` header if connection is to be closed after a request.+ [#958](https://github.com/yesodweb/wai/pull/958)++## 3.4.11++* Expose a way to access the open connection `Counter` with `makeSettingsAndCounter`,+ and `getCount` to be able to monitor the current open connections.+* Added getter function to get the open connection counter from the `Settings` with+ `getOpenConnectionCounter`.+ [#1050](https://github.com/yesodweb/wai/pull/1050)+ ## 3.4.10 * Using newest dependencies
Network/Wai/Handler/Warp.hs view
@@ -52,6 +52,7 @@ setPort, setHost, setOnException,+ setOnConnectionException, setOnExceptionResponse, setOnOpen, setOnClose,@@ -86,10 +87,36 @@ getOnOpen, getOnClose, getOnException,+ getOnConnectionException, getGracefulShutdownTimeout, getGracefulCloseTimeout1, getGracefulCloseTimeout2,+ getOpenConnectionCounter,+ getServerState, + -- ** Internal server state+ --+ -- Creating 'Settings' with insight into the internal state of the server.+ --+ -- When using 'makeSettingsAndServerState', you will receive the 'ServerState'+ -- that will be used by @warp@ so that you can query things like the+ -- 'currentOpenConnections', and 'currentShuttingDownState'.+ ServerState,+ makeSettingsAndServerState,+ currentOpenConnections,+ currentShuttingDownState,++ -- *** STM versions+ currentOpenConnectionsSTM,+ currentShuttingDownStateSTM,++ -- ** Connection counter+ --+ -- /Deprecated in favor of 'ServerState'/+ makeSettingsAndCounter,+ Counter,+ getCount,+ -- ** Exception handler defaultOnException, defaultShouldDisplayException,@@ -150,6 +177,7 @@ import Network.Wai (Request, Response, vault) import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.FileInfoCache import Network.Wai.Handler.Warp.HTTP2.Request ( getHTTP2Data,@@ -166,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' --@@ -197,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} @@ -205,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} @@ -223,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} @@ -246,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} @@ -270,7 +313,7 @@ -- -- Default: do nothing. ----- Since 2.1.0+-- @since 2.1.0 setBeforeMainLoop :: IO () -> Settings -> Settings setBeforeMainLoop x y = y{settingsBeforeMainLoop = x} @@ -280,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 @@ -308,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 @@ -344,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} @@ -353,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} @@ -368,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"@@ -381,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'}@@ -393,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} @@ -415,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} @@ -431,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@@ -475,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@@ -484,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@@ -493,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} @@ -508,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 @@ -527,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"))@@ -538,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 @@ -553,21 +605,42 @@ -- 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 +-- | Get the connection counter, if one was configured.+-- Use 'getCount' on the returned 'Counter' to read the current value.+--+-- See 'makeSettingsAndCounter' to create settings with a counter.+--+-- /DEPRECATED in favor of 'getServerState'/+--+-- @since 3.4.11+getOpenConnectionCounter :: Settings -> Maybe Counter+getOpenConnectionCounter = settingsConnectionCounter++-- | Get the 'ServerState', if one was configured.+-- Use things like 'currentOpenConnections' and 'currentShuttingDownState' to+-- query information about the current state of the server.+--+-- See 'makeSettingsAndServerState' to create 'Settings' with a 'ServerState'.+--+-- @since 3.4.12+getServerState :: Settings -> Maybe ServerState+getServerState = settingsServerState+ #ifdef MIN_VERSION_crypton_x509 -- | Getting information of client certificate. ----- Since 3.3.5+-- @since 3.3.5 clientCertificate :: Request -> Maybe CertificateChain clientCertificate = join . Vault.lookup getClientCertificateKey . vault #endif
Network/Wai/Handler/Warp/Conduit.hs view
@@ -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) <-
Network/Wai/Handler/Warp/Counter.hs view
@@ -3,10 +3,13 @@ module Network.Wai.Handler.Warp.Counter ( Counter, newCounter,+ HasDecreased (..), waitForZero, increase, decrease, waitForDecreased,+ getCount,+ getCountSTM, ) where import Control.Concurrent.STM@@ -23,15 +26,33 @@ x <- readTVar var when (x > 0) retry -waitForDecreased :: Counter -> IO ()+data HasDecreased = HasDecreased | NoConnections+ deriving (Eq, Show)++waitForDecreased :: Counter -> IO HasDecreased waitForDecreased (Counter var) = do n0 <- atomically $ readTVar var- atomically $ do- n <- readTVar var- check (n < n0)+ if n0 <= 0+ then pure NoConnections+ else atomically $ do+ n <- readTVar var+ check (n < n0)+ pure HasDecreased increase :: Counter -> IO () increase (Counter var) = atomically $ modifyTVar' var $ \x -> x + 1 decrease :: Counter -> IO () decrease (Counter var) = atomically $ modifyTVar' var $ \x -> x - 1++-- | Get the current count of open connections.+--+-- @since 3.4.11+getCount :: Counter -> IO Int+getCount (Counter var) = readTVarIO var++-- | Get the current count in an 'STM' transaction.+--+-- @since 3.4.13+getCountSTM :: Counter -> STM Int+getCountSTM (Counter tvar) = readTVar tvar
Network/Wai/Handler/Warp/FdCache.hs view
@@ -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
Network/Wai/Handler/Warp/File.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE BangPatterns #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.File (@@ -9,17 +8,19 @@ H.parseByteRanges, ) where -import Data.Array ((!)) import qualified Data.ByteString.Char8 as C8 (pack)-import Network.HTTP.Date+import Network.HTTP.Date (HTTPDate, parseHTTPDate) import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types.Header as H-import Network.Wai+import qualified Network.HTTP.Types.Header as Header+import Network.Wai (FilePart (..)) import qualified Network.Wai.Handler.Warp.FileInfoCache as I-import Network.Wai.Handler.Warp.Header+import Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ ) import Network.Wai.Handler.Warp.Imports-import Network.Wai.Handler.Warp.PackInt+import Network.Wai.Handler.Warp.PackInt (packIntegral) ---------------------------------------------------------------- @@ -34,18 +35,16 @@ :: I.FileInfo -> H.ResponseHeaders -> H.Method- -> IndexedHeader- -- ^ Response- -> IndexedHeader- -- ^ Request+ -> ResponseHeaderPresence+ -> IndexedRequestHeader -> RspFileInfo conditionalRequest finfo hs0 method rspidx reqidx = case condition of nobody@(WithoutBody _) -> nobody WithBody s _ off len -> let !hs1 = addContentHeaders hs0 off len size- !hs = case rspidx ! fromEnum ResLastModified of- Just _ -> hs1- Nothing -> (H.hLastModified, date) : hs1+ !hs+ | hasLastModified rspidx = hs1+ | otherwise = (H.hLastModified, date) : hs1 in WithBody s hs off len where !mtime = I.fileInfoTime finfo@@ -72,57 +71,67 @@ ---------------------------------------------------------------- -ifModifiedSince :: IndexedHeader -> Maybe HTTPDate-ifModifiedSince reqidx = reqidx ! fromEnum ReqIfModifiedSince >>= parseHTTPDate+ifModifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifModifiedSince reqidx = reqidxIfModifiedSince reqidx >>= parseHTTPDate -ifUnmodifiedSince :: IndexedHeader -> Maybe HTTPDate-ifUnmodifiedSince reqidx = reqidx ! fromEnum ReqIfUnmodifiedSince >>= parseHTTPDate+ifUnmodifiedSince :: IndexedRequestHeader -> Maybe HTTPDate+ifUnmodifiedSince reqidx = reqidxIfUnmodifiedSince reqidx >>= parseHTTPDate -ifRange :: IndexedHeader -> Maybe HTTPDate-ifRange reqidx = reqidx ! fromEnum ReqIfRange >>= parseHTTPDate+ifRange :: IndexedRequestHeader -> Maybe HTTPDate+ifRange reqidx = reqidxIfRange reqidx >>= parseHTTPDate ---------------------------------------------------------------- -ifmodified :: IndexedHeader -> HTTPDate -> H.Method -> Maybe RspFileInfo+ifmodified+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Maybe RspFileInfo ifmodified reqidx mtime method = do date <- ifModifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Modified-Since if the request -- contains an If-None-Match header field; [...]"- guard . isNothing $ reqidx ! fromEnum ReqIfNoneMatch+ guard . isNothing $ reqidxIfNoneMatch reqidx -- "A recipient MUST ignore the If-Modified-Since header field -- if [...] the request method is neither GET nor HEAD." guard $ method == H.methodGet || method == H.methodHead guard $ date == mtime || date > mtime Just $ WithoutBody H.notModified304 -ifunmodified :: IndexedHeader -> HTTPDate -> Maybe RspFileInfo+ifunmodified+ :: IndexedRequestHeader -> HTTPDate -> Maybe RspFileInfo ifunmodified reqidx mtime = do date <- ifUnmodifiedSince reqidx -- According to RFC 9110: -- "A recipient MUST ignore If-Unmodified-Since if the request -- contains an If-Match header field; [...]"- guard . isNothing $ reqidx ! fromEnum ReqIfMatch+ guard . isNothing $ reqidxIfMatch reqidx guard $ date /= mtime && date < mtime Just $ WithoutBody H.preconditionFailed412 -- TODO: Should technically also strongly match on ETags.-ifrange :: IndexedHeader -> HTTPDate -> H.Method -> Integer -> Maybe RspFileInfo+ifrange+ :: IndexedRequestHeader+ -> HTTPDate+ -> H.Method+ -> Integer+ -> Maybe RspFileInfo ifrange reqidx mtime method size = do -- According to RFC 9110: -- "When the method is GET and both Range and If-Range are -- present, evaluate the If-Range precondition:" date <- ifRange reqidx- rng <- reqidx ! fromEnum ReqRange+ rng <- reqidxRange reqidx guard $ method == H.methodGet return $ if date == mtime then parseRange rng size else WithBody H.ok200 [] 0 size -unconditional :: IndexedHeader -> Integer -> RspFileInfo+unconditional :: IndexedRequestHeader -> Integer -> RspFileInfo unconditional reqidx =- case reqidx ! fromEnum ReqRange of+ case reqidxRange reqidx of Nothing -> WithBody H.ok200 [] 0 Just rng -> parseRange rng @@ -151,7 +160,7 @@ -- | @contentRangeHeader beg end total@ constructs a Content-Range 'H.Header' -- for the range specified. contentRangeHeader :: Integer -> Integer -> Integer -> H.Header-contentRangeHeader beg end total = (H.hContentRange, range)+contentRangeHeader beg end total = (Header.hContentRange, range) where range = C8.pack@@ -183,7 +192,10 @@ in ctrng : hs' where !lengthBS = packIntegral len- !hs' = (H.hContentLength, lengthBS) : (H.hAcceptRanges, "bytes") : hs+ !hs' =+ (Header.hContentLength, lengthBS)+ : (Header.hAcceptRanges, "bytes")+ : filter (\(h, _) -> h /= Header.hContentLength && h /= Header.hAcceptRanges) hs -- | --
Network/Wai/Handler/Warp/HTTP1.hs view
@@ -181,7 +181,7 @@ -> Source -> Request -> Maybe (IORef Int)- -> IndexedHeader+ -> IndexedRequestHeader -> IO ByteString -> IO ReuseConnection processRequest settings ii conn app th istatus src req mremainingRef idxhdr nextBodyFlush = do
Network/Wai/Handler/Warp/HTTP2.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}@@ -29,6 +30,14 @@ import qualified Network.Wai.Handler.Warp.Settings as S import Network.Wai.Handler.Warp.Types +-- Early Hints wiring needs both the http-semantics 'auxSendInformational' field+-- (0.4.1) and the http2 sender support that actually emits it (5.4.2).+#define HAS_EARLY_HINTS_SUPPORT (MIN_VERSION_http_semantics(0,4,1) && MIN_VERSION_http2(5,4,2))++#if HAS_EARLY_HINTS_SUPPORT+import qualified Network.HTTP.Types as H+#endif+ ---------------------------------------------------------------- http2@@ -77,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@@ -89,7 +98,12 @@ http2server label settings ii transport addr app h2req0 aux0 response = do tid <- myThreadId labelThread tid (label ++ " http2server " ++ show addr)- req <- toWAIRequest h2req0 aux0+ req0 <- toWAIRequest h2req0 aux0+#if HAS_EARLY_HINTS_SUPPORT+ let req = req0{requestSendEarlyHints = H2.auxSendInformational aux0 (H.mkStatus 103 "Early Hints")}+#else+ let req = req0+#endif ref <- I.newIORef Nothing eResponseReceived <- E.try $ app req $ \rsp -> do (h2rsp, st, hasBody) <- fromResponse settings ii req rsp@@ -150,7 +164,7 @@ handler = throughAsync (return "") -- connClose must not be called here since Run:fork calls it-goaway :: Connection -> H2.ErrorCodeId -> ByteString -> IO ()+goaway :: Connection -> H2.ErrorCode -> ByteString -> IO () goaway Connection{..} etype debugmsg = connSendAll bytestream where einfo = H2.encodeInfo id 0
Network/Wai/Handler/Warp/HTTP2/File.hs view
@@ -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
Network/Wai/Handler/Warp/HTTP2/Request.hs view
@@ -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)
Network/Wai/Handler/Warp/Header.hs view
@@ -1,122 +1,122 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module Network.Wai.Handler.Warp.Header where+module Network.Wai.Handler.Warp.Header (+ IndexedRequestHeader (..),+ ResponseHeaderPresence (..),+ indexRequestHeader,+ defaultIndexRequestHeader,+ indexResponseHeader,+) where -import Data.Array-import Data.Array.ST import qualified Data.ByteString as BS import Data.CaseInsensitive (foldedCase)+import Data.List as L (foldl') import Network.HTTP.Types import Network.Wai.Handler.Warp.Types ---------------------------------------------------------------- --- | Array for a set of HTTP headers.-type IndexedHeader = Array Int (Maybe HeaderValue)--------------------------------------------------------------------indexRequestHeader :: RequestHeaders -> IndexedHeader-indexRequestHeader hdr = traverseHeader hdr requestMaxIndex requestKeyIndex--data RequestHeaderIndex- = ReqContentLength- | ReqTransferEncoding- | ReqExpect- | ReqConnection- | ReqRange- | ReqHost- | ReqIfModifiedSince- | ReqIfUnmodifiedSince- | ReqIfRange- | ReqReferer- | ReqUserAgent- | ReqIfMatch- | ReqIfNoneMatch- deriving (Enum, Bounded)---- | The size for 'IndexedHeader' for HTTP Request.--- From 0 to this corresponds to:------ - \"Content-Length\"--- - \"Transfer-Encoding\"--- - \"Expect\"--- - \"Connection\"--- - \"Range\"--- - \"Host\"--- - \"If-Modified-Since\"--- - \"If-Unmodified-Since\"--- - \"If-Range\"--- - \"Referer\"--- - \"User-Agent\"--- - \"If-Match\"--- - \"If-None-Match\"-requestMaxIndex :: Int-requestMaxIndex = fromEnum (maxBound :: RequestHeaderIndex)+-- | Strict record of the request headers that Warp inspects,+-- one field per header.+data IndexedRequestHeader = IndexedRequestHeader+ { reqidxContentLength :: Maybe HeaderValue+ , reqidxTransferEncoding :: Maybe HeaderValue+ , reqidxExpect :: Maybe HeaderValue+ , reqidxConnection :: Maybe HeaderValue+ , reqidxRange :: Maybe HeaderValue+ , reqidxHost :: Maybe HeaderValue+ , reqidxIfModifiedSince :: Maybe HeaderValue+ , reqidxIfUnmodifiedSince :: Maybe HeaderValue+ , reqidxIfRange :: Maybe HeaderValue+ , reqidxReferer :: Maybe HeaderValue+ , reqidxUserAgent :: Maybe HeaderValue+ , reqidxIfMatch :: Maybe HeaderValue+ , reqidxIfNoneMatch :: Maybe HeaderValue+ } -requestKeyIndex :: HeaderName -> Int-requestKeyIndex hn = case BS.length bs of- 4 | bs == "host" -> fromEnum ReqHost- 5 | bs == "range" -> fromEnum ReqRange- 6 | bs == "expect" -> fromEnum ReqExpect- 7 | bs == "referer" -> fromEnum ReqReferer- 8- | bs == "if-range" -> fromEnum ReqIfRange- | bs == "if-match" -> fromEnum ReqIfMatch- 10- | bs == "user-agent" -> fromEnum ReqUserAgent- | bs == "connection" -> fromEnum ReqConnection- 13 | bs == "if-none-match" -> fromEnum ReqIfNoneMatch- 14 | bs == "content-length" -> fromEnum ReqContentLength- 17- | bs == "transfer-encoding" -> fromEnum ReqTransferEncoding- | bs == "if-modified-since" -> fromEnum ReqIfModifiedSince- 19 | bs == "if-unmodified-since" -> fromEnum ReqIfUnmodifiedSince- _ -> -1+indexRequestHeader :: RequestHeaders -> IndexedRequestHeader+indexRequestHeader = L.foldl' insert defaultIndexRequestHeader where- bs = foldedCase hn+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "host" -> ix{reqidxHost = Just val}+ 5 | bs == "range" -> ix{reqidxRange = Just val}+ 6 | bs == "expect" -> ix{reqidxExpect = Just val}+ 7 | bs == "referer" -> ix{reqidxReferer = Just val}+ 8+ | bs == "if-range" -> ix{reqidxIfRange = Just val}+ | bs == "if-match" -> ix{reqidxIfMatch = Just val}+ 10+ | bs == "user-agent" -> ix{reqidxUserAgent = Just val}+ | bs == "connection" -> ix{reqidxConnection = Just val}+ 13 | bs == "if-none-match" -> ix{reqidxIfNoneMatch = Just val}+ 14 | bs == "content-length" -> ix{reqidxContentLength = Just val}+ 17+ | bs == "transfer-encoding" -> ix{reqidxTransferEncoding = Just val}+ | bs == "if-modified-since" -> ix{reqidxIfModifiedSince = Just val}+ 19 | bs == "if-unmodified-since" -> ix{reqidxIfUnmodifiedSince = Just val}+ _ -> ix+ where+ bs = foldedCase key -defaultIndexRequestHeader :: IndexedHeader-defaultIndexRequestHeader = array (0, requestMaxIndex) [(i, Nothing) | i <- [0 .. requestMaxIndex]]+-- | 'IndexedRequestHeader' with no headers set.+defaultIndexRequestHeader :: IndexedRequestHeader+defaultIndexRequestHeader =+ IndexedRequestHeader+ { reqidxContentLength = Nothing+ , reqidxTransferEncoding = Nothing+ , reqidxExpect = Nothing+ , reqidxConnection = Nothing+ , reqidxRange = Nothing+ , reqidxHost = Nothing+ , reqidxIfModifiedSince = Nothing+ , reqidxIfUnmodifiedSince = Nothing+ , reqidxIfRange = Nothing+ , reqidxReferer = Nothing+ , reqidxUserAgent = Nothing+ , reqidxIfMatch = Nothing+ , reqidxIfNoneMatch = Nothing+ } ---------------------------------------------------------------- -indexResponseHeader :: ResponseHeaders -> IndexedHeader-indexResponseHeader hdr = traverseHeader hdr responseMaxIndex responseKeyIndex--data ResponseHeaderIndex- = ResContentLength- | ResServer- | ResDate- | ResLastModified- deriving (Enum, Bounded)---- | The size for 'IndexedHeader' for HTTP Response.-responseMaxIndex :: Int-responseMaxIndex = fromEnum (maxBound :: ResponseHeaderIndex)--responseKeyIndex :: HeaderName -> Int-responseKeyIndex hn = case BS.length bs of- 4 | bs == "date" -> fromEnum ResDate- 6 | bs == "server" -> fromEnum ResServer- 13 | bs == "last-modified" -> fromEnum ResLastModified- 14 | bs == "content-length" -> fromEnum ResContentLength- _ -> -1- where- bs = foldedCase hn------------------------------------------------------------------+-- | Presence of the response headers Warp itself consults.+-- Only these four headers are ever looked up on the response side, and+-- only their presence, never their value, so a flat record of strict+-- 'Bool's built in a single traversal beats a boxed array.+data ResponseHeaderPresence = ResponseHeaderPresence+ { hasContentLength :: Bool+ , hasServer :: Bool+ , hasDate :: Bool+ , hasLastModified :: Bool+ , hasTransferEncoding :: Maybe HeaderValue+ , hasConnection :: Maybe HeaderValue+ } -traverseHeader :: [Header] -> Int -> (HeaderName -> Int) -> IndexedHeader-traverseHeader hdr maxidx getIndex = runSTArray $ do- arr <- newArray (0, maxidx) Nothing- mapM_ (insert arr) hdr- return arr+indexResponseHeader :: ResponseHeaders -> ResponseHeaderPresence+indexResponseHeader = go emptyResponseHeaderPresence where- insert arr (key, val)- | idx == -1 = return ()- | otherwise = writeArray arr idx (Just val)+ go ix [] = ix+ go ix (tup : rest) = go (insert ix tup) rest+ insert ix (key, val) = case BS.length bs of+ 4 | bs == "date" -> ix{hasDate = True}+ 6 | bs == "server" -> ix{hasServer = True}+ 10 | bs == "connection" -> ix{hasConnection = Just val}+ 13 | bs == "last-modified" -> ix{hasLastModified = True}+ 14 | bs == "content-length" -> ix{hasContentLength = True}+ 17 | bs == "transfer-encoding" -> ix{hasTransferEncoding = Just val}+ _ -> ix where- idx = getIndex key+ bs = foldedCase key++emptyResponseHeaderPresence :: ResponseHeaderPresence+emptyResponseHeaderPresence =+ ResponseHeaderPresence+ { hasContentLength = False+ , hasServer = False+ , hasDate = False+ , hasLastModified = False+ , hasTransferEncoding = Nothing+ , hasConnection = Nothing+ }
Network/Wai/Handler/Warp/IO.hs view
@@ -1,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)
Network/Wai/Handler/Warp/Internal.hs view
@@ -1,10 +1,30 @@ {-# OPTIONS_GHC -fno-warn-deprecations #-} +-- |+-- __IMPORTANT NOTICE__+--+-- This module exports internals mainly to provide the @warp-tls@ package+-- with tools to implement what it needs to. This module\/API should /NOT/ be+-- expected to remain stable at all, even between minor releases.+--+-- If you see a use case for these functions or types for other purposes,+-- please create an issue in the repository so that we might add it to the+-- main 'Network.Wai.Handler.Warp' API. module Network.Wai.Handler.Warp.Internal ( -- * Settings Settings (..), ProxyProtocol (..),+ makeSettingsAndCounter,+ makeSettingsAndServerState, + -- ** Connection counter+ Counter,+ getCount,++ -- ** Server state+ ServerState,+ makeServerState,+ -- * Low level run functions runSettingsConnection, runSettingsConnectionMaker,@@ -17,6 +37,7 @@ -- ** Receive Recv,+ makeGracefulRecv, RecvBuf, -- ** Buffer@@ -38,10 +59,20 @@ warpVersion, -- * Data types++ -- |+ --+ -- The internals of 'IndexedHeader' have changed since @3.4.15@, so we+ -- keep exporting it as a type synonym, but it is now a record instead of+ -- an array.+ -- As such there's no more 'requestMaxIndex', but we provide a blank+ -- 'defaultIndexRequestHeader'. InternalInfo (..), HeaderValue, IndexedHeader,- requestMaxIndex,+ -- I assume 'requestMaxIndex' was used in case anyone wanted to create+ -- an empty array, so we replace it with 'defaultIndexRequestHeader'.+ defaultIndexRequestHeader, -- * Time out manager @@ -94,6 +125,7 @@ import System.TimeManager import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Counter (Counter, getCount) import Network.Wai.Handler.Warp.Date import Network.Wai.Handler.Warp.FdCache import Network.Wai.Handler.Warp.FileInfoCache@@ -107,3 +139,5 @@ import Network.Wai.Handler.Warp.Settings import Network.Wai.Handler.Warp.Types import Network.Wai.Handler.Warp.Windows++type IndexedHeader = IndexedRequestHeader
Network/Wai/Handler/Warp/Request.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-deprecations #-} @@ -16,12 +15,10 @@ ) where import qualified Control.Concurrent as Conc (yield)-import Data.Array ((!)) import qualified Data.ByteString as S import qualified Data.ByteString.Unsafe as SU import qualified Data.CaseInsensitive as CI import qualified Data.IORef as I-import Data.Typeable (Typeable) import qualified Data.Vault.Lazy as Vault import Data.Word8 (_cr, _lf) #ifdef MIN_VERSION_crypton_x509@@ -70,7 +67,7 @@ -> IO ( Request , Maybe (I.IORef Int)- , IndexedHeader+ , IndexedRequestHeader , IO ByteString ) -- ^@@ -83,7 +80,7 @@ (method, unparsedPath, path, query, httpversion, hdr) <- parseHeaderLines hdrlines let idxhdr = indexRequestHeader hdr- expect = idxhdr ! fromEnum ReqExpect+ expect = reqidxExpect idxhdr handle100Continue = handleExpect conn httpversion expect (rbody, remainingRef, bodyLength) <- bodyAndSource src idxhdr -- body producing function which will produce '100-continue', if needed@@ -91,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@@ -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,7 +136,7 @@ else push maxTotalHeaderLength src (THStatus 0 0 id id) bs data NoKeepAliveRequest = NoKeepAliveRequest- deriving (Show, Typeable)+ deriving (Show) instance Exception NoKeepAliveRequest ----------------------------------------------------------------@@ -159,7 +159,7 @@ bodyAndSource :: Source- -> IndexedHeader+ -> IndexedRequestHeader -> IO ( IO ByteString , Maybe (I.IORef Int)@@ -170,12 +170,12 @@ csrc <- mkCSource src return (readCSource csrc, Nothing, ChunkedBody) | otherwise = do- let len = toLength $ idxhdr ! fromEnum ReqContentLength+ let len = toLength $ reqidxContentLength idxhdr bodyLen = KnownLength $ fromIntegral len isrc@(ISource _ remaining) <- mkISource src len return (readISource isrc, Just remaining, bodyLen) where- chunked = isChunked $ idxhdr ! fromEnum ReqTransferEncoding+ chunked = isChunked $ reqidxTransferEncoding idxhdr toLength :: Maybe HeaderValue -> Int toLength Nothing = 0@@ -218,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
Network/Wai/Handler/Warp/Response.hs view
@@ -7,6 +7,7 @@ module Network.Wai.Handler.Warp.Response ( sendResponse, sanitizeHeaderValue, -- for testing+ containsRecoverableWhitespace, -- for benchmarking -- Provided here for backwards compatibility. warpVersion, hasBody,@@ -16,25 +17,25 @@ ) where import qualified Control.Exception as E-import Data.Array ((!)) import qualified Data.ByteString as S+import Data.ByteString.Internal (toForeignPtr, unsafeCreate) import Data.ByteString.Builder (Builder, byteString) import Data.ByteString.Builder.Extra (flush) import Data.ByteString.Builder.HTTP.Chunked ( chunkedTransferEncoding, chunkedTransferTerminator, )-import qualified Data.ByteString.Char8 as C8 import qualified Data.CaseInsensitive as CI-import Data.Function (on)-import Data.List (deleteBy)+import Data.Foldable (for_)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Streaming.ByteString.Builder ( newByteStringBuilderRecv, reuseBufferStrategy, )-import Data.Word8 (_cr, _lf, _space, _tab)+import Data.Word8 (_cr, _lf, _nul, _space)+import Foreign (copyBytes, plusForeignPtr, pokeByteOff, withForeignPtr) import qualified Network.HTTP.Types as H-import qualified Network.HTTP.Types.Header as H+import qualified Network.HTTP.Types.Header as Header import Network.Wai import Network.Wai.Internal import qualified System.TimeManager as T@@ -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- hs <- addAltSvc settings <$> addServerAndDate hs0+ -- Decide connection persistence+ isShuttingDown <-+ case settingsServerState settings of+ Just serverState -> currentShuttingDownState serverState+ -- Should never be reached!+ -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure')+ Nothing -> pure False+ let shouldPersist = not isShuttingDown && ret+ addConnection hs =+ if shouldPersist || responseWantsToClose+ then hs+ else (Header.hConnection, "close") : hs++ -- Adjust headers+ hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0++ -- Start response logic if hasBody s then do -- The response to HEAD does not have body.@@ -133,28 +150,39 @@ case ms of Nothing -> return () Just realStatus -> logger req realStatus mlen- T.tickle th- return ret else do _ <- sendRsp conn ii th ver s hs rspidxhdr maxRspBufSize method RspNoBody logger req s Nothing- T.tickle th- return isPersist+ T.tickle th+ return shouldPersist where+ -- From Settings -- defServer = settingsServerName settings logger = settingsLogger settings maxRspBufSize = settingsMaxBuilderResponseBufferSize settings++ -- From Request --+ method = requestMethod req+ isHead = method == H.methodHead ver = httpVersion req+ isHttp11 = ver == H.http11+ reqSaysPersist = checkReqConnectionHeader isHttp11 reqidxhdr++ -- From Response -- s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0+ hasLength = hasContentLength rspidxhdr+ responseWantsToClose =+ case hasConnection rspidxhdr of+ Nothing -> False+ Just v -> CI.foldCase v == "close"+ isPersist = reqSaysPersist && not responseWantsToClose++ -- Other -- getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr- (isPersist, isChunked0) = infoFromRequest req reqidxhdr- isChunked = not isHead && isChunked0- (isKeepAlive, needsChunked) = infoFromResponse rspidxhdr (isPersist, isChunked)- method = requestMethod req- isHead = method == H.methodHead+ needsChunked = isHttp11 && not hasLength rsp = case response of ResponseFile _ _ path mPart -> RspFile path mPart reqidxhdr (T.tickle th) ResponseBuilder _ _ b@@ -164,43 +192,74 @@ | isHead -> RspNoBody | otherwise -> RspStream fb needsChunked ResponseRaw raw _ -> RspRaw raw src+ -- Should be False if (http10 && not hasLength), regardless of what+ -- the 'Connection' header says. (as long as the response should have a body)+ isKeepAlive =+ isPersist && (isHttp11 || hasLength || isHead || not (hasBody s)) -- Make sure we don't hang on to 'response' (avoid space leak) !ret = case response of+ -- Will get 'Content-Length' header later on using the+ -- 'addContentHeaders(ForFilePart)' functions, so if the+ -- 'Connection' header says we persist, we persist. ResponseFile{} -> isPersist ResponseBuilder{} -> isKeepAlive ResponseStream{} -> isKeepAlive+ -- Is already an ongoing open connection, so if it is done,+ -- the connection should be closed. ResponseRaw{} -> False ---------------------------------------------------------------- +-- | As per RFC 9110 we replace any newlines (\r\n) or \NUL with spaces+-- Values without CR/LF/NUL (the overwhelmingly common case) leave the+-- header list untouched; only a dirty value triggers a rebuild. sanitizeHeaders :: H.ResponseHeaders -> H.ResponseHeaders-sanitizeHeaders = map (sanitize <$>)+sanitizeHeaders hdrs+ -- slow path+ | any (containsRecoverableWhitespace . snd) hdrs = map (sanitize <$>) hdrs+ -- fast path+ | otherwise = hdrs where- sanitize v- | containsNewlines v = sanitizeHeaderValue v -- slow path- | otherwise = v -- fast path+ sanitize bs+ | containsRecoverableWhitespace bs = sanitizeHeaderValue bs+ | otherwise = bs -{-# INLINE containsNewlines #-}-containsNewlines :: ByteString -> Bool-containsNewlines = S.any (\w -> w == _cr || w == _lf)+-- Yes, this is quicker than @S.any (\w -> w == _lf || w == _cr || w == _nul)@+-- because of `bytestring`'s rewrite rules.+containsRecoverableWhitespace :: ByteString -> Bool+containsRecoverableWhitespace bs =+ S.any (_lf ==) bs || S.any (_cr ==) bs || S.any (_nul ==) bs -{-# INLINE sanitizeHeaderValue #-}+{-# INLINE isRecoverableWhitespace #-}+-- | CR, LF and NUL can safely be replaced with a SP according to RFC 9110+-- <https://www.rfc-editor.org/rfc/rfc9110.html#section-5.5-5>+isRecoverableWhitespace :: Word8 -> Bool+isRecoverableWhitespace w = w == _cr || w == _lf || w == _nul+ sanitizeHeaderValue :: ByteString -> ByteString-sanitizeHeaderValue v = case C8.lines $ S.filter (/= _cr) v of- [] -> ""- x : xs -> C8.intercalate "\r\n" (x : mapMaybe addSpaceIfMissing xs)+sanitizeHeaderValue v =+ case S.findIndices isRecoverableWhitespace v of+ -- Nothing to replace+ [] -> v+ -- Found CR, LF or NUL.+ ixs ->+ unsafeCreate len $ \dst -> do+ withForeignPtr fptr $ \src -> do+ -- copy the bytestring+ copyBytes dst src len+ -- and then replace the offending bytes+ for_ ixs $ \ix -> pokeByteOff dst ix _space where- addSpaceIfMissing line = case S.uncons line of- Nothing -> Nothing- Just (first, _)- | first == _space || first == _tab -> Just line- | otherwise -> Just $ _space `S.cons` line+ (fptr', offset, len) = toForeignPtr v+ -- We need to use the offset for backwards compatibility with+ -- "bytestring < 0.11"+ fptr = fptr' `plusForeignPtr` offset ---------------------------------------------------------------- data Rsp = RspNoBody- | RspFile FilePath (Maybe FilePart) IndexedHeader (IO ())+ | RspFile FilePath (Maybe FilePart) IndexedRequestHeader (IO ()) | RspBuilder Builder Bool | RspStream StreamingBody Bool | RspRaw (IO ByteString -> (ByteString -> IO ()) -> IO ()) (IO ByteString)@@ -214,7 +273,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader -- Response+ -> ResponseHeaderPresence -> Int -- maxBuilderResponseBufferSize -> H.Method -> Rsp@@ -225,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@@ -269,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, ()) ---------------------------------------------------------------- @@ -349,7 +442,7 @@ -> H.HttpVersion -> H.Status -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> FilePath@@ -359,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@@ -374,7 +469,7 @@ -> T.Handle -> H.HttpVersion -> H.ResponseHeaders- -> IndexedHeader+ -> ResponseHeaderPresence -> Int -> H.Method -> IO (Maybe H.Status, Maybe Integer)@@ -392,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" ----------------------------------------------------------------@@ -412,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@@ -465,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@@ -495,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
Network/Wai/Handler/Warp/ResponseHeader.hs view
@@ -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 "
Network/Wai/Handler/Warp/Run.hs view
@@ -1,17 +1,27 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# OPTIONS_GHC -fno-warn-deprecations #-}-{-# LANGUAGE MultiWayIf #-} module Network.Wai.Handler.Warp.Run where import Control.Arrow (first)+import Control.Concurrent.STM (+ TVar,+ atomically,+ check,+ modifyTVar',+ newTVarIO,+ readTVar,+ ) import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.IORef (newIORef, readIORef)+import Data.Functor (($>))+import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE) import GHC.Conc.Sync (labelThread, myThreadId)@@ -23,7 +33,10 @@ close, #if !WINDOWS fdSocket,+#if MIN_VERSION_network(3,2,2)+ waitReadSocketSTM, #endif+#endif getSocketName, setSocketOption, withSocketsDo,@@ -39,7 +52,7 @@ import qualified System.TimeManager as T import System.Timeout (timeout) -import Network.Wai.Handler.Warp.Buffer+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer) import Network.Wai.Handler.Warp.Counter import qualified Network.Wai.Handler.Warp.Date as D import qualified Network.Wai.Handler.Warp.FdCache as F@@ -48,22 +61,24 @@ import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Imports hiding (readInt)-import Network.Wai.Handler.Warp.SendFile+import Network.Wai.Handler.Warp.SendFile (sendFile) import Network.Wai.Handler.Warp.Settings+import Network.Wai.Handler.Warp.ShuttingDown (readShuttingDown, 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 +91,22 @@ 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 , 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 +126,7 @@ hook headers - sendall = sendAll' s-- sendAll' sock bs =+ sendall bs = E.handleJust ( \e -> if ioeGetErrorType e == ResourceVanished@@ -119,8 +134,47 @@ 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+-- when the server is shutting down and there are no more 'Application's+-- actively using this 'Socket'.+makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv+makeGracefulRecv sock pool ss appsInProgress = do+ 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+#else+ -- FIXME: 'waitReadSocketSTM' doesn't work on WINDOWS, and actually+ -- blocks indefinitely, so we fall back to going straight to 'recv'.+ pure (pure ())+#endif+ isShuttingDown <- atomically $+ -- when shutting down+ (checkShutdown $> True)+ <|>+ -- else wait for socket readiness and do non-blocking read+ (sockWait $> False)+ if isShuttingDown then pure "" else recv+ where+ recv = receive sock pool+ checkShutdown = do+ check =<< currentShuttingDownStateSTM ss+ check . (<= 0) =<< readTVar appsInProgress+ -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO ()@@ -130,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"@@ -168,11 +222,12 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO ()-runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do- settingsInstallShutdownHandler set closeListenSocket- runSettingsConnection set getConn app+runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do+ settingsInstallShutdownHandler oldSettings closeListenSocket+ (_, newSettings) <- makeServerState oldSettings+ runSettingsConnection newSettings (getConn newSettings) app where- getConn = do+ getConn set = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX.@@ -190,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@@ -215,17 +270,19 @@ -- 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 <- newCounter- withII set $ acceptConnection set getConnMaker app counter+runSettingsConnectionMakerSecure oldSettings getConnMaker app = do+ settingsBeforeMainLoop oldSettings+ (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings+ withII newSettings $ \ii ->+ initFdExhaustionRef >>=+ acceptConnection newSettings getConnMaker app serverConnectionCounter ii -- | Running an action with internal info. ----- Since 3.3.11+-- @since 3.3.11 withII :: Settings -> (InternalInfo -> IO a) -> IO a withII set action = withTimeoutManager $ \tm ->@@ -265,8 +322,12 @@ -> Application -> Counter -> InternalInfo+ -> IORef FdExhaustion+ -- ^ This ref will be used to "debounce" the call to 'settingsOnException'+ -- when we hit an 'IOError' with 'eMFILE' in the case that Warp is not+ -- the reason the file descriptors are exhausted. -> IO ()-acceptConnection set getConnMaker app counter ii = do+acceptConnection set getConnMaker app counter ii fdRef = do -- First mask all exceptions in acceptLoop. This is necessary to -- ensure that no async exception is throw between the call to -- acceptNewConnection and the registering of connClose.@@ -299,19 +360,44 @@ acceptNewConnection = do ex <- E.try getConnMaker case ex of- Right x -> return $ Just x+ Right x -> do+ -- Important to mark the exhaustion issue to be resolved+ -- when we get connections again.+ resetFdExhaustion fdRef+ return $ Just x Left e -> do let getErrno (Errno cInt) = cInt isErrno err = ioe_errno e == Just (getErrno err)- if | isErrno eCONNABORTED -> acceptNewConnection+ if | isErrno eCONNABORTED -> do+ -- Important to mark the exhaustion issue to be resolved+ resetFdExhaustion fdRef+ acceptNewConnection+ -- Keep in mind to reset the ref when anything other+ -- than this branch runs | isErrno eMFILE -> do- settingsOnException set Nothing $ E.toException e- waitForDecreased counter- acceptNewConnection+ handleFdExhaustion e+ acceptNewConnection | otherwise -> do- settingsOnException set Nothing $ E.toException e- return Nothing+ -- Maybe not important to mark the exhaustion issue+ -- as resolved here, but just for completeness' sake.+ resetFdExhaustion fdRef+ settingsOnException set Nothing $ E.toException e+ return Nothing + handleFdExhaustion e = do+ fdExhaustion <- readIORef fdRef+ -- If file descriptors are exhausted while Warp has+ -- no current connections, 'settingsOnException' would+ -- get called an enormous amount of times per second.+ when (fdExhaustion /= FdExhausted) $+ settingsOnException set Nothing $ E.toException e+ hasDecreased <- waitForDecreased counter+ -- If we get 'NoConnections', that means the file+ -- descriptor exhaustion is outside of our control.+ -- We flag it so that 'settingsOnException' doesn't get+ -- called until the exhaustion issue is resolved.+ when (hasDecreased == NoConnections) $ setFdExhaustion fdRef+ -- Fork a new worker thread for this connection maker, and ask for a -- function to unmask (i.e., allow async exceptions to be thrown). fork@@ -322,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@@ -366,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@@ -389,13 +483,19 @@ if "PRI " `S.isPrefixOf` bs0 then return (True, bs0) else return (False, bs0)+ let appsInProgress = connAppsInProgress conn+ app' req rsp =+ E.bracket_+ (atomically $ modifyTVar' appsInProgress $ (+ 1))+ (atomically $ modifyTVar' appsInProgress $ \i -> (i - 1))+ $ app req rsp if settingsHTTP2Enabled settings && h2 then do labelThread tid ("Warp HTTP/2 " ++ show origAddr)- http2 settings ii conn transport app origAddr th bs+ http2 settings ii conn transport app' origAddr th bs else do labelThread tid ("Warp HTTP/1.1 " ++ show origAddr)- http1 settings ii conn transport app origAddr th bs+ http1 settings ii conn transport app' origAddr th bs where recv4 bs0 = do bs1 <- connRecv conn@@ -428,11 +528,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]
Network/Wai/Handler/Warp/SendFile.hs view
@@ -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
Network/Wai/Handler/Warp/Settings.hs view
@@ -9,15 +9,16 @@ module Network.Wai.Handler.Warp.Settings where -import Control.Exception (SomeException(..), fromException, throw)+import Control.Concurrent.STM (STM)+import Control.Exception (SomeException (..), fromException, throw) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO+import GHC.Exts (fork#) import GHC.IO (IO (IO), unsafeUnmask) import GHC.IO.Exception (IOErrorType (..))-import GHC.Prim (fork#) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr, Socket, accept) import Network.Wai@@ -25,7 +26,14 @@ import System.IO.Error (ioeGetErrorType) import System.TimeManager +import Network.Wai.Handler.Warp.Counter (Counter, getCount, newCounter, getCountSTM) import Network.Wai.Handler.Warp.Imports+import Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ ) import Network.Wai.Handler.Warp.Types #if WINDOWS import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack)@@ -36,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'@@ -49,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 ()@@ -74,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. --@@ -83,7 +104,7 @@ -- -- Default: 'defaultFork' --- -- Since 3.0.4+ -- @since 3.0.4 , settingsAccept :: Socket -> IO (Socket, SockAddr) -- ^ Code to accept a new connection. --@@ -92,7 +113,7 @@ -- -- Default: 'defaultAccept' --- -- Since 3.3.24+ -- @since 3.3.24 , settingsNoParsePath :: Bool -- ^ Perform no parsing on the rawPathInfo. --@@ -100,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.@@ -108,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`).@@ -177,7 +204,26 @@ -- -- 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,+ -- then use 'getCount' on the returned 'Counter' to read the current value.+ --+ -- Default: 'Nothing' (warp creates an internal counter)+ --+ -- /DEPRECATED in favor of 'settingsServerState'/+ --+ -- @since 3.4.11+ , settingsServerState :: Maybe ServerState+ -- ^ Internal read-only server state.+ -- Use 'makeSettingsAndServerState' to gain access to the state of the server.+ -- Using functions like 'currentOpenConnections' or 'currentShuttingDownState'+ -- to gain insight into the current state of the server.+ --+ -- Default: 'Nothing' (warp creates its own internal state)+ --+ -- @since 3.4.13 } -- | Specify usage of the PROXY protocol.@@ -189,6 +235,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@@ -197,6 +324,7 @@ { settingsPort = 3000 , settingsHost = "*4" , settingsOnException = defaultOnException+ , settingsOnConnectionException = Nothing , settingsOnExceptionResponse = defaultOnExceptionResponse , settingsOnOpen = const $ return True , settingsOnClose = const $ return ()@@ -222,13 +350,34 @@ , settingsMaxTotalHeaderLength = 50 * 1024 , settingsAltSvc = Nothing , settingsMaxBuilderResponseBufferSize = 1049000000+ , settingsConnectionCounter = Nothing+ , settingsServerState = Nothing } +-- | Create 'defaultSettings' with a connection counter.+-- Use 'getCount' on the returned 'Counter' to check open connections.+--+-- /DEPRECATED in favor of 'makeSettingsAndServerState'/+--+-- @since 3.4.11+makeSettingsAndCounter :: IO (Counter, Settings)+makeSettingsAndCounter = do+ (serverState, settings) <- makeSettingsAndServerState+ pure (serverConnectionCounter serverState, settings)++-- | Create 'defaultSettings' with a 'ServerState'.+-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState'+-- to gain insight into the state of the server.+--+-- @since 3.4.13+makeSettingsAndServerState :: IO (ServerState, Settings)+makeSettingsAndServerState = makeServerState defaultSettings+ -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur -- 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@@ -241,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) $@@ -251,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@@ -282,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@@ -292,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.
+ Network/Wai/Handler/Warp/ShuttingDown.hs view
@@ -0,0 +1,34 @@+-- Most important is to not export the data constructor from this module+-- and to not expose 'writeShuttingDown' to the end user.+module Network.Wai.Handler.Warp.ShuttingDown (+ ShuttingDown,+ newShuttingDown,+ readShuttingDown,+ readShuttingDownSTM,+ writeShuttingDown,+) where++import Control.Concurrent.STM (+ STM,+ TVar,+ atomically,+ newTVarIO,+ readTVar,+ readTVarIO,+ writeTVar,+ )++newtype ShuttingDown = ShuttingDown (TVar Bool)++newShuttingDown :: IO ShuttingDown+newShuttingDown = ShuttingDown <$> newTVarIO False++readShuttingDown :: ShuttingDown -> IO Bool+readShuttingDown (ShuttingDown var) = readTVarIO var++readShuttingDownSTM :: ShuttingDown -> STM Bool+readShuttingDownSTM (ShuttingDown var) = readTVar var++writeShuttingDown :: ShuttingDown -> Bool -> IO ()+writeShuttingDown (ShuttingDown var) b =+ atomically $ writeTVar var b
Network/Wai/Handler/Warp/Types.hs view
@@ -1,13 +1,12 @@ {-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.Warp.Types where -import 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,7 @@ PayloadTooLarge | -- | Since 3.3.22 RequestHeaderFieldsTooLarge- deriving (Eq, Typeable)+ deriving (Eq) instance Show InvalidRequest where show (NotEnoughLines xs) = "Warp: Incomplete request headers, received: " ++ show xs@@ -71,7 +70,7 @@ -- Used to determine whether keeping the HTTP1.1 connection / HTTP2 stream alive is safe -- or irrecoverable. newtype ExceptionInsideResponseBody = ExceptionInsideResponseBody E.SomeException- deriving (Show, Typeable)+ deriving (Show) instance E.Exception ExceptionInsideResponseBody @@ -81,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@@ -89,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@@ -130,11 +129,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 +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@@ -157,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@@ -167,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
bench/Parser.hs view
@@ -19,6 +19,7 @@ import Prelude hiding (lines) import Network.Wai.Handler.Warp.Request (FirstRequest (..), headerLines)+import Network.Wai.Handler.Warp.Response (containsRecoverableWhitespace) import Network.Wai.Handler.Warp.Types import Criterion.Main@@ -54,6 +55,16 @@ , bench "new parsing 25" $ whnfAppIO testIt (chunkRequest 25) , bench "new parsing 100" $ whnfAppIO testIt (chunkRequest 100) ]+ , bgroup+ "containsRecoverableWhitespace"+ -- Clean values (no CR/LF/NUL) are the overwhelmingly common case and+ -- the one the fast path must stay cheap for; the dirty case is+ -- what forces a rebuild in 'sanitizeHeaders'.+ [ bench "clean short" $ whnf containsRecoverableWhitespace "Mighttpd/2.5.8"+ , bench "clean long" $ whnf containsRecoverableWhitespace cleanLong+ , bench "dirty" $+ whnf containsRecoverableWhitespace "text/html\r\nInjected: header"+ ] ] where testIt req = producer req >>= headerLines 800 FirstRequest@@ -241,6 +252,11 @@ in return $! (method, rpath, qstring, hv) else throwIO NonHttp _ -> throwIO $ BadFirstLine $ B.unpack s++-- A long, clean header value (no CR/LF): forces the memchr scan to walk the+-- whole value before deciding it is clean.+cleanLong :: S.ByteString+cleanLong = S.replicate 512 _A producer :: [ByteString] -> IO Source producer a = do
+ bench/ResponseBench.hs view
@@ -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")+ ]
+ test/BufferSpec.hs view
@@ -0,0 +1,38 @@+{-# LANGUAGE OverloadedStrings #-}++module BufferSpec (main, spec) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Builder as BLD+import Data.IORef as I+import Network.Wai.Handler.Warp.Buffer (createWriteBuffer)+import Network.Wai.Handler.Warp.IO (toBufIOWith)+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (NonNegative (..))++main :: IO ()+main = hspec spec++spec :: Spec+spec = describe "toBufIOWith" $ do+ it "counts short bytestrings" $+ testBufIOWith 10+ -- This failed before fixing 'toBufIOWith'+ it "counts long bytestrings" $ do+ testBufIOWith 1000000+ modifyMaxSize (const 10000000) . prop "counts bytestrings of different sizes" $+ \(NonNegative i) -> testBufIOWith i++testBufIOWith :: Int -> Expectation+testBufIOWith bsLen = do+ len <- toBufIOWithBuilder $ BLD.byteString $ S.replicate bsLen 0+ len `shouldBe` fromIntegral bsLen++toBufIOWithBuilder :: BLD.Builder -> IO Integer+toBufIOWithBuilder bld = do+ countRef <- newIORef 0 :: IO (IORef Int)+ buf <- createWriteBuffer 16384+ bufRef <- newIORef buf+ let go bs = modifyIORef' countRef (+ S.length bs)+ toBufIOWith 1049000000 bufRef go bld
+ test/ConnectionExceptionSpec.hs view
@@ -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))
+ test/ConnectionSpec.hs view
@@ -0,0 +1,81 @@+{-# LANGUAGE OverloadedStrings #-}++module ConnectionSpec (spec) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S8+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import RunSpec (msRead, msWrite, withApp, withMySocket)+import Test.Hspec++spec :: Spec+spec = describe "Connection header" $ do+ describe "HTTP/1.0 Connection: close behavior" $ do+ -- HTTP/1.0 defaults to close. We ask for Keep-Alive.+ -- But we provide no Content-Length in response.+ -- So Warp should decide to close (because it can't keep alive without length or chunking),+ -- and MUST send "Connection: close" to inform the client.+ -- (In HTTP/1.0 this requires closing the connection to delimit the+ -- response; or rather, lack of persistence info)+ testClose+ "when response implies close (HTTP/1.0 Keep-Alive, but no Content-Length)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.0\r\nConnection: Keep-Alive\r\n\r\n"+ testClose+ "sends \"Connection: close\" on regular HTTP/1.0 GET request"+ (responseBuilder status200 [] "foo")+ "GET / HTTP/1.0\r\nHost: localhost\r\n\r\n"++ describe "HTTP/1.1 Connection: close behavior" $ do+ -- Response has no Content-Length and is not chunked (HEAD implies no body).+ it "does NOT send \"Connection: close\" for HTTP/1.1 HEAD request" $ do+ let app _ f = f $ responseBuilder status200 [] "foo"+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms "HEAD / HTTP/1.1\r\nHost: localhost\r\n\r\n"+ -- Should include the Connection header if present and also+ -- should be less then all headers when it's absent, so we+ -- don't wait for nothing.+ response <- msRead ms 73+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Nothing+ testClose+ "when GET request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when HEAD request has \"Connection: close\" (200 OK)"+ (responseLBS status200 [] "foo")+ "HEAD / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (204 No Content)"+ (responseLBS status204 [] "")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ testClose+ "when request has \"Connection: close\" (500 Internal Server Error)"+ (responseLBS status500 [] "error")+ "GET / HTTP/1.1\r\nHost: localhost\r\nConnection: close\r\n\r\n"+ where+ testClose name res input = do+ let prefix = "sends \"Connection: close\" "+ it (prefix <> name) $ do+ let app _ f = f res+ withApp defaultSettings app $ withMySocket $ \ms -> do+ msWrite ms input+ -- We expect the connection to be closed by the server, so reading a large amount+ -- should return whatever was sent and then finish.+ response <- msRead ms 4096+ let headers = parseHeaders response+ lookup "Connection" headers `shouldBe` Just "close"++parseHeaders :: ByteString -> [(ByteString, ByteString)]+parseHeaders bs =+ let allLines = S8.lines bs+ -- Drop status line+ headerLines = takeWhile (not . S8.null . S8.filter (/= '\r')) $ drop 1 allLines+ parseLine line =+ let (k, v) = S8.break (== ':') line+ v' = S8.takeWhile (/= '\r') v+ in (k, S8.dropWhile (== ' ') $ S8.drop 1 v')+ in map parseLine headerLines
+ test/EarlyHintsSpec.hs view
@@ -0,0 +1,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
+ test/GracefulShutdownSpec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+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+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+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+ 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
test/ResponseSpec.hs view
@@ -73,35 +73,15 @@ spec :: Spec spec = do- {- http-client does not support this.- describe "preventing response splitting attack" $ do- it "sanitizes header values" $ do- let app _ respond = respond $ responseLBS status200 [("foo", "foo\r\nbar")] "Hello"- withApp defaultSettings app $ \port -> do- res <- sendGET $ "http://127.0.0.1:" ++ show port- getHeaderValue "foo" (responseHeaders res) `shouldBe`- Just "foo bar" -- HTTP inserts two spaces for \r\n.- -}- describe "sanitizeHeaderValue" $ do- it "doesn't alter valid multiline header values" $ do- sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo\r\n bar"-- it "adds missing spaces after \r\n" $ do- sanitizeHeaderValue "foo\r\nbar" `shouldBe` "foo\r\n bar"-- it "discards empty lines" $ do- sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo\r\n bar"-- context "when sanitizing single occurrences of \n" $ do- it "replaces \n with \r\n" $ do- sanitizeHeaderValue "foo\n bar" `shouldBe` "foo\r\n bar"-- it "adds missing spaces after \n" $ do- sanitizeHeaderValue "foo\nbar" `shouldBe` "foo\r\n bar"-- it "discards single occurrences of \r" $ do- sanitizeHeaderValue "foo\rbar" `shouldBe` "foobar"+ it "replaces multiline header value's [CR LF NUL] with SP" $ do+ sanitizeHeaderValue "foo\r\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\NULbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\r\n\r\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\n bar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\nbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\rbar" `shouldBe` "foo bar"+ sanitizeHeaderValue "foo\NULbar" `shouldBe` "foo bar" describe "range requests" $ do testRange "2-3" "23" $ Just "2-3/16"
test/RunSpec.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -21,7 +22,7 @@ import Network.Socket import Network.Socket.ByteString (sendAll) import Network.Wai hiding (responseHeaders)-import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp hiding (Counter) import System.IO.Unsafe (unsafePerformIO) import System.Timeout (timeout) import Test.Hspec@@ -150,7 +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@@ -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@@ -392,7 +402,7 @@ `onException` liftIO (I.atomicModifyIORef ifront (\front -> (front . ("consume interrupted" :), ()))) liftIO $- threadDelay 4000000 `E.catch` \e -> do+ threadDelay 500000 `E.catch` \e -> do I.atomicModifyIORef ifront ( \front ->@@ -415,7 +425,7 @@ msWrite ms bs1 threadDelay 100000 msWrite ms bs2- threadDelay 5000000+ threadDelay 1000000 front <- I.readIORef ifront S.concat (front []) `shouldBe` bs describe "raw body" $ do
+ test/ServerStateSpec.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE OverloadedStrings #-}++module ServerStateSpec where++import Network.Wai.Handler.Warp (getServerState)+import Network.Wai.Handler.Warp.Counter (increase)+import Network.Wai.Handler.Warp.Settings (+ ServerState (..),+ currentOpenConnections,+ currentShuttingDownState,+ defaultSettings,+ makeServerState,+ newServerState,+ )+import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown)+import Test.Hspec++main :: IO ()+main = hspec spec++spec :: Spec+spec = do+ describe "ServerState" $ do+ it "has the correct initialization" $ do+ ss <- newServerState+ currentOpenConnections ss `shouldReturn` 0+ currentShuttingDownState ss `shouldReturn` False+ describe "makeServerState" $ do+ it "has the same state in settings" $ do+ (outerSS, set) <- makeServerState defaultSettings+ case getServerState set of+ Nothing -> expectationFailure "'makeServerState' should set the 'ServerState'"+ Just innerSS -> do+ let bothCount i = do+ a <- currentOpenConnections outerSS+ b <- currentOpenConnections innerSS+ (a, b) `shouldBe` (i, i)+ increase $ serverConnectionCounter outerSS+ bothCount 1+ increase $ serverConnectionCounter innerSS+ bothCount 2+ let bothDown bool = do+ a <- currentShuttingDownState outerSS+ b <- currentShuttingDownState innerSS+ (a, b) `shouldBe` (bool, bool)+ writeShuttingDown (serverShuttingDown outerSS) True+ bothDown True+ writeShuttingDown (serverShuttingDown innerSS) False+ bothDown False+ it "is idempotent" $ do+ let incAndCheck ss i = do+ increase $ serverConnectionCounter ss+ currentOpenConnections ss `shouldReturn` i+ (ss1, set1) <- makeServerState defaultSettings+ incAndCheck ss1 1+ (ss2, _set2) <- makeServerState set1+ incAndCheck ss2 2+ incAndCheck ss1 3
test/WithApplicationSpec.hs view
@@ -9,6 +9,7 @@ import System.Process import Test.Hspec +import Network.Wai.Handler.Warp (defaultSettings, setOnException) import Network.Wai.Handler.Warp.WithApplication -- All these tests assume the "curl" process can be called directly.@@ -31,16 +32,21 @@ it "does not propagate exceptions from the server to the executing thread" $ do let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"- withApplication mkApp $ \port -> do+ withApplicationSettings silentSettings mkApp $ \port -> do output <- readProcess "curl" ["-s", "localhost:" ++ show port] ""- output `shouldContain` "Something went wron"+ output `shouldContain` "Something went wrong" describe "testWithApplication" $ do it "propagates exceptions from the server to the executing thread" $ do let mkApp = return $ \_request _respond -> throwIO $ ErrorCall "foo"- testWithApplication+ testWithApplicationSettings+ silentSettings mkApp ( \port -> do readProcess "curl" ["-s", "localhost:" ++ show port] "" ) `shouldThrow` (errorCall "foo")+ where+ -- So that we don't muddy the test result screen.+ -- (normally, 'defaultSettings' use 'defaultOnException', sending to 'stderr')+ silentSettings = setOnException (\_ _ -> pure ()) defaultSettings
warp.cabal view
@@ -1,19 +1,19 @@ cabal-version: >=1.10 name: warp-version: 3.4.10+version: 3.4.16 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.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.3,+ time-manager >=0.2 && <0.5, vault >=0.3,- wai >=3.2.4 && <3.3,+ wai >=3.2.5 && <3.3, word8 if flag(x509)@@ -178,10 +179,15 @@ build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: test . other-modules:+ BufferSpec ConduitSpec+ ConnectionSpec+ ConnectionExceptionSpec+ EarlyHintsSpec ExceptionSpec FdCacheSpec FileSpec+ GracefulShutdownSpec HTTP PackIntSpec ReadIntSpec@@ -190,6 +196,7 @@ ResponseSpec RunSpec SendFileSpec+ ServerStateSpec WithApplicationSpec Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Internal@@ -220,6 +227,7 @@ Network.Wai.Handler.Warp.Run Network.Wai.Handler.Warp.SendFile Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown Network.Wai.Handler.Warp.Types Network.Wai.Handler.Warp.Windows Network.Wai.Handler.Warp.WithApplication@@ -232,7 +240,6 @@ build-depends: base >=4.8 && <5, QuickCheck,- array, auto-update, async, bsb-http-chunked <0.1,@@ -240,24 +247,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.2 && <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)@@ -289,18 +298,26 @@ main-is: Parser.hs hs-source-dirs: bench . other-modules:+ Network.Wai.Handler.Warp.Buffer Network.Wai.Handler.Warp.Conduit+ Network.Wai.Handler.Warp.Counter Network.Wai.Handler.Warp.Date Network.Wai.Handler.Warp.FdCache+ Network.Wai.Handler.Warp.File Network.Wai.Handler.Warp.FileInfoCache Network.Wai.Handler.Warp.HashMap Network.Wai.Handler.Warp.Header+ Network.Wai.Handler.Warp.IO Network.Wai.Handler.Warp.Imports Network.Wai.Handler.Warp.MultiMap+ Network.Wai.Handler.Warp.PackInt Network.Wai.Handler.Warp.ReadInt Network.Wai.Handler.Warp.Request Network.Wai.Handler.Warp.RequestHeader+ Network.Wai.Handler.Warp.Response+ Network.Wai.Handler.Warp.ResponseHeader Network.Wai.Handler.Warp.Settings+ Network.Wai.Handler.Warp.ShuttingDown Network.Wai.Handler.Warp.Types if flag(include-warp-version)@@ -309,19 +326,22 @@ default-language: Haskell2010 build-depends: base >=4.8 && <5,- array,+ async, auto-update,+ bsb-http-chunked, bytestring, case-insensitive, containers, criterion,- ghc-prim, hashable, http-date, http-types,- network,+ http2,+ iproute, network, recv,+ simple-sendfile,+ stm, streaming-commons, text, time-manager,@@ -344,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