warp 3.4.12 → 3.4.13
raw patch · 12 files changed
+455/−47 lines, 12 filesdep +warpdep −ghc-primdep ~networkdep ~time-manager
Dependencies added: warp
Dependencies removed: ghc-prim
Dependency ranges changed: network, time-manager
Files
- ChangeLog.md +13/−1
- Network/Wai/Handler/Warp.hs +31/−0
- Network/Wai/Handler/Warp/Counter.hs +7/−0
- Network/Wai/Handler/Warp/Internal.hs +17/−1
- Network/Wai/Handler/Warp/Response.hs +12/−7
- Network/Wai/Handler/Warp/Run.hs +71/−24
- Network/Wai/Handler/Warp/Settings.hs +112/−6
- Network/Wai/Handler/Warp/ShuttingDown.hs +34/−0
- Network/Wai/Handler/Warp/Types.hs +6/−1
- test/GracefulShutdownSpec.hs +83/−0
- test/ServerStateSpec.hs +58/−0
- warp.cabal +11/−7
ChangeLog.md view
@@ -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
Network/Wai/Handler/Warp.hs view
@@ -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.
Network/Wai/Handler/Warp/Counter.hs view
@@ -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
Network/Wai/Handler/Warp/Internal.hs view
@@ -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
Network/Wai/Handler/Warp/Response.hs view
@@ -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
Network/Wai/Handler/Warp/Run.hs view
@@ -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
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,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
+ 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
@@ -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
+ test/GracefulShutdownSpec.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE OverloadedStrings #-}++module GracefulShutdownSpec (spec) where++import Control.Concurrent+import Control.Concurrent.Async+import Control.Exception (bracket)+import Control.Monad (void)+import Network.HTTP.Client+import Network.HTTP.Types (ok200, status200)+import Network.Socket (close)+import Network.Wai (responseLBS)+import Network.Wai.Handler.Warp+import System.Timeout (timeout)+import Test.Hspec++spec :: Spec+spec = describe "graceful shutdown" $+ it "serves the request in flight, then closes keep-alive connections and exits" $ do+ shutdownSignal <- newEmptyMVar+ allowResponse <- newEmptyMVar+ receivedRequests <- newQSemN 0+ allowSecondRequest <- newEmptyMVar++ let installShutdownHandler closeListenSocket =+ void . forkIO $ do+ readMVar shutdownSignal+ closeListenSocket++ settings =+ setInstallShutdownHandler installShutdownHandler defaultSettings++ app _ respond = do+ -- signal 1 received request+ signalQSemN receivedRequests 1+ -- block until signaled+ readMVar allowResponse+ respond $ responseLBS status200 [("Content-Length", "0")] ""++ client sendRequest = do+ -- first request should return OK+ response <- sendRequest+ responseStatus response `shouldBe` ok200+ lookup "Connection" (responseHeaders response) `shouldBe` Just "close"+ -- wait with the second request+ void $ readMVar allowSecondRequest+ -- second request should end with connection refused+ sendRequest `shouldThrow` connectionRefused++ bracket openFreePort (close . snd) $ \(testPort, sock) ->+ withAsync (runSettingsSocket settings sock app) $ \server -> do+ manager <- newManager defaultManagerSettings+ request <- parseRequest ("http://127.0.0.1:" ++ show testPort)+ withAsync+ -- start all clients+ ( replicateConcurrently_ numClients $+ client (httpNoBody request manager)+ )+ $ \clients -> do+ -- wait for all clients to send requests+ waitQSemN receivedRequests numClients+ -- shutdown the server before serving requests+ putMVar shutdownSignal ()+ -- wait a little - otherwise some requests might not get+ -- Connection: close response header+ threadDelay 100_000+ -- let requests be handled+ putMVar allowResponse ()+ -- server should exit+ timeout 5_000_000 (wait server)+ >>= maybe (expectationFailure "Timeout waiting for server shutdown") pure+ -- let clients proceed with the second request+ putMVar allowSecondRequest ()+ -- wait for all clients and propagate any exceptions+ wait clients+ where+ -- set number of clients to the number of keep-alive connections+ numClients = managerConnCount defaultManagerSettings+ connectionRefused = \case+ (HttpExceptionRequest _ (ConnectionFailure _)) -> True+ _ -> False
+ test/ServerStateSpec.hs view
@@ -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
warp.cabal view
@@ -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- <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@@ -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,