diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,9 +1,21 @@ # ChangeLog for warp +## 3.4.13 + +* Change graceful shutdown logic to stop accepting data from idle connections, + but to wait for busy `Application`s, adding `Connection: close` headers to + responses if the server is shutting down. + This should make sure the server doesn't wait for idle keep-alive connections. +* Expose a broader way to access internal state like the open connection `Counter` + and whether the server is currently `ShuttingDown` or not. + Users can use `makeSettingsAndServerState` to get a `ServerState` while + making `defaultSettings`. + [#1071](https://github.com/yesodweb/wai/pull/1071) + ## 3.4.12 * Respond with `Connection: close` header if connection is to be closed after a request. - [#958](https://github.com/yesodweb/wai/pull/958) + [#958](https://github.com/yesodweb/wai/pull/958) ## 3.4.11 diff --git a/Network/Wai/Handler/Warp.hs b/Network/Wai/Handler/Warp.hs --- a/Network/Wai/Handler/Warp.hs +++ b/Network/Wai/Handler/Warp.hs @@ -90,8 +90,27 @@ 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, @@ -576,9 +595,21 @@ -- -- 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. diff --git a/Network/Wai/Handler/Warp/Counter.hs b/Network/Wai/Handler/Warp/Counter.hs --- a/Network/Wai/Handler/Warp/Counter.hs +++ b/Network/Wai/Handler/Warp/Counter.hs @@ -8,6 +8,7 @@ decrease, waitForDecreased, getCount, + getCountSTM, ) where import Control.Concurrent.STM @@ -42,3 +43,9 @@ -- 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 diff --git a/Network/Wai/Handler/Warp/Internal.hs b/Network/Wai/Handler/Warp/Internal.hs --- a/Network/Wai/Handler/Warp/Internal.hs +++ b/Network/Wai/Handler/Warp/Internal.hs @@ -1,15 +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 + -- ** Connection counter Counter, getCount, + -- ** Server state + ServerState, + makeServerState, + -- * Low level run functions runSettingsConnection, runSettingsConnectionMaker, @@ -22,6 +37,7 @@ -- ** Receive Recv, + makeGracefulRecv, RecvBuf, -- ** Buffer diff --git a/Network/Wai/Handler/Warp/Response.hs b/Network/Wai/Handler/Warp/Response.hs --- a/Network/Wai/Handler/Warp/Response.hs +++ b/Network/Wai/Handler/Warp/Response.hs @@ -120,6 +120,16 @@ -> IO Bool -- ^ Returing True if the connection is persistent. sendResponse settings conn ii th req reqidxhdr src response = do + isShuttingDown <- + case settingsServerState settings of + Just serverState -> currentShuttingDownState serverState + -- Should never be reached! + -- (cf. 'makeServerState' in 'runSettingsConnectionMakerSecure') + Nothing -> pure False + let shouldPersist = + not isShuttingDown && if hasBody s then ret else isPersist + addConnection hs = + if shouldPersist then hs else (H.hConnection, "close") : hs hs <- addConnection . addAltSvc settings <$> addServerAndDate hs0 if hasBody s then do @@ -133,13 +143,11 @@ 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 defServer = settingsServerName settings logger = settingsLogger settings @@ -148,9 +156,6 @@ s = responseStatus response hs0 = sanitizeHeaders $ responseHeaders response rspidxhdr = indexResponseHeader hs0 - addConnection hs = if (hasBody s && not ret) || (not (hasBody s) && not isPersist) - then (H.hConnection, "close") : hs - else hs getdate = getDate ii addServerAndDate = addDate getdate rspidxhdr . addServer defServer rspidxhdr (isPersist, isChunked0) = infoFromRequest req reqidxhdr diff --git a/Network/Wai/Handler/Warp/Run.hs b/Network/Wai/Handler/Warp/Run.hs --- a/Network/Wai/Handler/Warp/Run.hs +++ b/Network/Wai/Handler/Warp/Run.hs @@ -1,16 +1,26 @@ {-# 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.Functor (($>)) import Data.IORef (newIORef, readIORef) import Data.Streaming.Network (bindPortTCP) import Foreign.C.Error (Errno (..), eCONNABORTED, eMFILE) @@ -26,6 +36,7 @@ #endif getSocketName, setSocketOption, + waitReadSocketSTM, withSocketsDo, ) #if MIN_VERSION_network(3,1,1) @@ -39,7 +50,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 +59,24 @@ import Network.Wai.Handler.Warp.HTTP2 (http2) import Network.Wai.Handler.Warp.HTTP2.Types (isHTTP2) import Network.Wai.Handler.Warp.Imports hiding (readInt) -import Network.Wai.Handler.Warp.SendFile +import Network.Wai.Handler.Warp.SendFile (sendFile) import Network.Wai.Handler.Warp.Settings +import Network.Wai.Handler.Warp.ShuttingDown (writeShuttingDown) import Network.Wai.Handler.Warp.Types -- | Creating 'Connection' for plain HTTP based on a given socket. +-- +-- (N.B. make sure the 'Settings' have an initialized 'ServerState' to guarantee +-- a graceful shutdown) socketConnection :: Settings -> Socket -> IO Connection -#if MIN_VERSION_network(3,1,1) socketConnection set s = do -#else -socketConnection _ s = do -#endif + (ss, _) <- makeServerState set bufferPool <- newBufferPool 2048 16384 writeBuffer <- createWriteBuffer 16384 writeBufferRef <- newIORef writeBuffer isH2 <- newIORef False -- HTTP/1.x mysa <- getSocketName s + appsInProgress <- newTVarIO 0 return Connection { connSendMany = Sock.sendMany s @@ -82,14 +95,16 @@ #else , connClose = close s #endif - , connRecv = receive' s bufferPool + , connRecv = receive' bufferPool ss appsInProgress , connRecvBuf = \_ _ -> return True -- obsoleted , connWriteBuffer = writeBufferRef , connHTTP2 = isH2 , connMySockAddr = mysa + , connAppsInProgress = appsInProgress } where - receive' sock pool = E.handle handler $ receive sock pool + receive' bufferPool ss appsInProgress = + E.handle handler $ makeGracefulRecv s bufferPool ss appsInProgress where handler :: E.IOException -> IO ByteString handler e @@ -121,6 +136,26 @@ E.throwIO $ Sock.sendAll sock bs +-- | Create a 'Recv' using 'Network.Socket.BufferPool.Recv.receive', but make +-- it non-blocking with 'waitReadSocketSTM' /AND/ cut off receiving any bytes +-- when the server is shutting down and there are no more 'Application's +-- actively using this 'Socket'. +makeGracefulRecv :: Socket -> BufferPool -> ServerState -> TVar Int -> Recv +makeGracefulRecv sock pool ss appsInProgress = do + sockWait <- waitReadSocketSTM sock + isShuttingDown <- atomically $ + -- when shutting down + (checkShutdown $> True) + <|> + -- else wait for socket readiness and do non-blocking read + (sockWait $> False) + if isShuttingDown then pure "" else recv + where + recv = receive sock pool + checkShutdown = do + check =<< currentShuttingDownStateSTM ss + check . (<= 0) =<< readTVar appsInProgress + -- | Run an 'Application' on the given port. -- This calls 'runSettings' with 'defaultSettings'. run :: Port -> Application -> IO () @@ -168,11 +203,12 @@ -- Note that the 'settingsPort' will still be passed to 'Application's via the -- 'serverPort' record. runSettingsSocket :: Settings -> Socket -> Application -> IO () -runSettingsSocket set@Settings{settingsAccept = accept'} socket app = do - settingsInstallShutdownHandler set closeListenSocket - runSettingsConnection set getConn app +runSettingsSocket oldSettings@Settings{settingsAccept = accept'} socket app = do + settingsInstallShutdownHandler oldSettings closeListenSocket + (_, newSettings) <- makeServerState oldSettings + runSettingsConnection newSettings (getConn newSettings) app where - getConn = do + getConn set = do (s, sa) <- accept' socket setSocketCloseOnExec s -- NoDelay causes an error for AF_UNIX. @@ -218,12 +254,11 @@ -- Since 2.1.4 runSettingsConnectionMakerSecure :: Settings -> IO (IO (Connection, Transport), SockAddr) -> Application -> IO () -runSettingsConnectionMakerSecure set getConnMaker app = do - settingsBeforeMainLoop set - counter <- case settingsConnectionCounter set of - Just c -> pure c - Nothing -> newCounter - withII set $ acceptConnection set getConnMaker app counter +runSettingsConnectionMakerSecure oldSettings getConnMaker app = do + settingsBeforeMainLoop oldSettings + (ServerState{serverConnectionCounter}, newSettings) <- makeServerState oldSettings + withII newSettings $ + acceptConnection newSettings getConnMaker app serverConnectionCounter -- | Running an action with internal info. -- @@ -391,13 +426,19 @@ if "PRI " `S.isPrefixOf` bs0 then return (True, bs0) else return (False, bs0) + let appsInProgress = connAppsInProgress conn + app' req rsp = + E.bracket_ + (atomically $ modifyTVar' appsInProgress $ (+ 1)) + (atomically $ modifyTVar' appsInProgress $ \i -> (i - 1)) + $ app req rsp if settingsHTTP2Enabled settings && h2 then do labelThread tid ("Warp HTTP/2 " ++ show origAddr) - http2 settings ii conn transport app origAddr th bs + http2 settings ii conn transport app' origAddr th bs else do labelThread tid ("Warp HTTP/1.1 " ++ show origAddr) - http1 settings ii conn transport app origAddr th bs + http1 settings ii conn transport app' origAddr th bs where recv4 bs0 = do bs1 <- connRecv conn @@ -430,11 +471,17 @@ #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 diff --git a/Network/Wai/Handler/Warp/Settings.hs b/Network/Wai/Handler/Warp/Settings.hs --- a/Network/Wai/Handler/Warp/Settings.hs +++ b/Network/Wai/Handler/Warp/Settings.hs @@ -9,15 +9,16 @@ module Network.Wai.Handler.Warp.Settings where -import Control.Exception (SomeException(..), fromException, throw) +import Control.Concurrent.STM (STM) +import Control.Exception (SomeException (..), fromException, throw) import qualified Data.ByteString.Builder as Builder import qualified Data.ByteString.Char8 as C8 import Data.Streaming.Network (HostPreference) import qualified Data.Text as T import qualified Data.Text.IO as TIO +import GHC.Exts (fork#) import GHC.IO (IO (IO), unsafeUnmask) import GHC.IO.Exception (IOErrorType (..)) -import GHC.Prim (fork#) import qualified Network.HTTP.Types as H import Network.Socket (SockAddr, Socket, accept) import Network.Wai @@ -25,8 +26,14 @@ import System.IO.Error (ioeGetErrorType) import System.TimeManager -import Network.Wai.Handler.Warp.Counter (Counter, newCounter) +import Network.Wai.Handler.Warp.Counter (Counter, getCount, newCounter, getCountSTM) import Network.Wai.Handler.Warp.Imports +import Network.Wai.Handler.Warp.ShuttingDown ( + ShuttingDown, + newShuttingDown, + readShuttingDown, + readShuttingDownSTM, + ) import Network.Wai.Handler.Warp.Types #if WINDOWS import Network.Wai.Handler.Warp.Windows (windowsThreadBlockHack) @@ -186,7 +193,18 @@ -- -- 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. @@ -198,6 +216,83 @@ | -- | See @setProxyProtocolOptional@. ProxyProtocolOptional +-- | Internal read-only state of the server +-- +-- Since 3.4.13 +data ServerState = ServerState + { serverConnectionCounter :: Counter + , serverShuttingDown :: ShuttingDown + } + +-- | Takes 'Settings' and either returns the 'ServerState' +-- that was already in there, or creates a new 'ServerState'. +-- +-- The returned 'Settings' will always contain a 'ServerState'. +-- +-- This makes it idempotent if care is taken that the @oldSettings@ +-- are not used after using this function. +-- +-- Since 3.4.13 +makeServerState :: Settings -> IO (ServerState, Settings) +makeServerState oldSettings = + case settingsServerState oldSettings of + Just serverState -> pure (serverState, oldSettings) + Nothing -> do + serverState <- newServerState + let counter = serverConnectionCounter serverState + pure + ( serverState + , oldSettings + { settingsServerState = Just serverState + , settingsConnectionCounter = Just counter + } + ) + +-- | Initialize a 'ServerState' +-- +-- Since 3.4.13 +newServerState :: IO ServerState +newServerState = do + counter <- newCounter + shuttingDown <- newShuttingDown + pure + ServerState + { serverConnectionCounter = counter + , serverShuttingDown = shuttingDown + } + +-- | Get the currently open connections of the server. +-- +-- Since 3.4.13 +currentOpenConnections :: ServerState -> IO Int +currentOpenConnections = getCount . serverConnectionCounter + +-- | Get the currently open connections of the server in an 'STM' transaction. +-- +-- Since 3.4.13 +currentOpenConnectionsSTM :: ServerState -> STM Int +currentOpenConnectionsSTM = getCountSTM . serverConnectionCounter + +-- | Check if the server is currently shutting down. +-- +-- > False: Server is not shutting down +-- > True: Server is shutting down or has shut down. +-- +-- Since 3.4.13 +currentShuttingDownState :: ServerState -> IO Bool +currentShuttingDownState = readShuttingDown . serverShuttingDown + +-- | Check if the server is currently shutting down in an 'STM' transaction. +-- +-- (This way you can have a thread wait for server shutdown with 'Control.Concurrent.STM.retry') +-- +-- > False: Server is not shutting down +-- > True: Server is shutting down or has shut down. +-- +-- Since 3.4.13 +currentShuttingDownStateSTM :: ServerState -> STM Bool +currentShuttingDownStateSTM = readShuttingDownSTM . serverShuttingDown + -- | The default settings for the Warp server. See the individual settings for -- the default value. defaultSettings :: Settings @@ -232,16 +327,27 @@ , settingsAltSvc = Nothing , settingsMaxBuilderResponseBufferSize = 1049000000 , settingsConnectionCounter = Nothing + , settingsServerState = Nothing } --- | Create 'Settings' with a connection counter. +-- | 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 - counter <- newCounter - pure (counter, defaultSettings{settingsConnectionCounter = Just counter}) + (serverState, settings) <- makeSettingsAndServerState + pure (serverConnectionCounter serverState, settings) + +-- | Create 'defaultSettings' with a 'ServerState'. +-- Use functions like 'currentOpenConnections' and 'currentShuttingDownState' +-- to gain insight into the state of the server. +-- +-- Since 3.4.13 +makeSettingsAndServerState :: IO (ServerState, Settings) +makeSettingsAndServerState = makeServerState defaultSettings -- | Apply the logic provided by 'defaultOnException' to determine if an -- exception should be shown or not. The goal is to hide exceptions which occur diff --git a/Network/Wai/Handler/Warp/ShuttingDown.hs b/Network/Wai/Handler/Warp/ShuttingDown.hs new file mode 100644 --- /dev/null +++ b/Network/Wai/Handler/Warp/ShuttingDown.hs @@ -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 diff --git a/Network/Wai/Handler/Warp/Types.hs b/Network/Wai/Handler/Warp/Types.hs --- a/Network/Wai/Handler/Warp/Types.hs +++ b/Network/Wai/Handler/Warp/Types.hs @@ -4,10 +4,11 @@ module Network.Wai.Handler.Warp.Types where +import Control.Concurrent.STM (TVar) +import qualified Control.Exception as E import qualified Data.ByteString as S import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Typeable (Typeable) -import qualified Control.Exception as E #ifdef MIN_VERSION_crypton_x509 import Data.X509 #endif @@ -130,6 +131,10 @@ , 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/ } getConnHTTP2 :: Connection -> IO Bool diff --git a/test/GracefulShutdownSpec.hs b/test/GracefulShutdownSpec.hs new file mode 100644 --- /dev/null +++ b/test/GracefulShutdownSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NumericUnderscores #-} +{-# LANGUAGE OverloadedStrings #-} + +module GracefulShutdownSpec (spec) where + +import Control.Concurrent +import Control.Concurrent.Async +import Control.Exception (bracket) +import Control.Monad (void) +import Network.HTTP.Client +import Network.HTTP.Types (ok200, status200) +import Network.Socket (close) +import Network.Wai (responseLBS) +import Network.Wai.Handler.Warp +import System.Timeout (timeout) +import Test.Hspec + +spec :: Spec +spec = describe "graceful shutdown" $ + it "serves the request in flight, then closes keep-alive connections and exits" $ do + shutdownSignal <- newEmptyMVar + allowResponse <- newEmptyMVar + receivedRequests <- newQSemN 0 + allowSecondRequest <- newEmptyMVar + + let installShutdownHandler closeListenSocket = + void . forkIO $ do + readMVar shutdownSignal + closeListenSocket + + settings = + setInstallShutdownHandler installShutdownHandler defaultSettings + + app _ respond = do + -- signal 1 received request + signalQSemN receivedRequests 1 + -- block until signaled + readMVar allowResponse + respond $ responseLBS status200 [("Content-Length", "0")] "" + + client sendRequest = do + -- first request should return OK + response <- sendRequest + responseStatus response `shouldBe` ok200 + lookup "Connection" (responseHeaders response) `shouldBe` Just "close" + -- wait with the second request + void $ readMVar allowSecondRequest + -- second request should end with connection refused + sendRequest `shouldThrow` connectionRefused + + bracket openFreePort (close . snd) $ \(testPort, sock) -> + withAsync (runSettingsSocket settings sock app) $ \server -> do + manager <- newManager defaultManagerSettings + request <- parseRequest ("http://127.0.0.1:" ++ show testPort) + withAsync + -- start all clients + ( replicateConcurrently_ numClients $ + client (httpNoBody request manager) + ) + $ \clients -> do + -- wait for all clients to send requests + waitQSemN receivedRequests numClients + -- shutdown the server before serving requests + putMVar shutdownSignal () + -- wait a little - otherwise some requests might not get + -- Connection: close response header + threadDelay 100_000 + -- let requests be handled + putMVar allowResponse () + -- server should exit + timeout 5_000_000 (wait server) + >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure + -- let clients proceed with the second request + putMVar allowSecondRequest () + -- wait for all clients and propagate any exceptions + wait clients + where + -- set number of clients to the number of keep-alive connections + numClients = managerConnCount defaultManagerSettings + connectionRefused = \case + (HttpExceptionRequest _ (ConnectionFailure _)) -> True + _ -> False diff --git a/test/ServerStateSpec.hs b/test/ServerStateSpec.hs new file mode 100644 --- /dev/null +++ b/test/ServerStateSpec.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ServerStateSpec where + +import Network.Wai.Handler.Warp (getServerState) +import Network.Wai.Handler.Warp.Counter (getCount, 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 diff --git a/warp.cabal b/warp.cabal --- a/warp.cabal +++ b/warp.cabal @@ -1,19 +1,19 @@ cabal-version: >=1.10 name: warp -version: 3.4.12 +version: 3.4.13 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 - . + . 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 @@ -103,7 +105,6 @@ bytestring >=0.9.1.4, case-insensitive >=0.2, containers, - ghc-prim, hashable, http-date, http-types >=0.12, @@ -183,6 +184,7 @@ ExceptionSpec FdCacheSpec FileSpec + GracefulShutdownSpec HTTP PackIntSpec ReadIntSpec @@ -191,6 +193,7 @@ ResponseSpec RunSpec SendFileSpec + ServerStateSpec WithApplicationSpec Network.Wai.Handler.Warp Network.Wai.Handler.Warp.Internal @@ -221,6 +224,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 @@ -241,7 +245,6 @@ case-insensitive >=0.2, containers, directory, - ghc-prim, hashable, hspec >=1.3, http-client, @@ -259,6 +262,8 @@ time-manager, vault, wai >=3.2.2.1 && <3.3, + -- workaround: this should be unnecessary + warp, word8 if flag(x509) @@ -317,7 +322,6 @@ case-insensitive, containers, criterion, - ghc-prim, hashable, http-date, http-types,