From 82dc724d501541ee7e380c2cfc67cc3bcb11a3cc Mon Sep 17 00:00:00 2001 From: Finley McIlwaine Date: Tue, 2 Jul 2024 19:32:28 -0700 Subject: [PATCH 1/4] Add worker thread and other HTTP/2 setting params We now support setting the `SETTINGS_INITIAL_WINDOW_SIZE` and `SETTINGS_MAX_CONCURRENT_STREAMS` settings via `http2`. We also support setting the initial connection window size, and the number of server worker threads. The default values we set for these help us avoid the window size exhaustion deadlock that resulted in [#168](https://github.com/well-typed/grapesy/issues/168). --- .gitignore | 2 +- demo-server/Main.hs | 7 +- grapesy.cabal | 1 + interop/Interop/Server.hs | 13 ++- kvstore/KVStore/Server.hs | 7 +- src/Network/GRPC/Client/Connection.hs | 46 ++++++---- src/Network/GRPC/Common/HTTP2Settings.hs | 90 ++++++++++++++++++++ src/Network/GRPC/Server.hs | 2 - src/Network/GRPC/Server/Run.hs | 102 +++++++++++++++++------ src/Network/GRPC/Spec/Status.hs | 6 +- test-grapesy/Test/Driver/ClientServer.hs | 15 +++- test-stress/Test/Stress/Server.hs | 7 +- 12 files changed, 236 insertions(+), 62 deletions(-) create mode 100644 src/Network/GRPC/Common/HTTP2Settings.hs diff --git a/.gitignore b/.gitignore index 35e95b60..32ec18ac 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,7 @@ dist-newstyle .envrc *.swp *.pcapng -cabal.project.local +*.local *.eventlog *.eventlog.html *.hp diff --git a/demo-server/Main.hs b/demo-server/Main.hs index 7ce1df64..4ef1ea08 100644 --- a/demo-server/Main.hs +++ b/demo-server/Main.hs @@ -6,6 +6,7 @@ import Data.Aeson import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compression +import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Common.Protobuf import Network.GRPC.Server import Network.GRPC.Server.Protobuf @@ -53,8 +54,10 @@ main = do let serverConfig :: ServerConfig serverConfig = ServerConfig { - serverInsecure = cmdInsecure cmdline - , serverSecure = cmdSecure cmdline + serverInsecure = cmdInsecure cmdline + , serverSecure = cmdSecure cmdline + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } runServerWithHandlers diff --git a/grapesy.cabal b/grapesy.cabal index 163b9419..80a1f4d2 100644 --- a/grapesy.cabal +++ b/grapesy.cabal @@ -111,6 +111,7 @@ library Network.GRPC.Common.Protobuf Network.GRPC.Common.StreamElem Network.GRPC.Common.StreamType + Network.GRPC.Common.HTTP2Settings Network.GRPC.Internal.XIO Network.GRPC.Server Network.GRPC.Server.Binary diff --git a/interop/Interop/Server.hs b/interop/Interop/Server.hs index b7727c0f..02d71f73 100644 --- a/interop/Interop/Server.hs +++ b/interop/Interop/Server.hs @@ -7,6 +7,7 @@ import Control.Exception (SomeException) import Control.Monad.Catch (generalBracket, ExitCase(..)) import Network.GRPC.Common +import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Internal.XIO qualified as XIO import Network.GRPC.Server import Network.GRPC.Server.Protobuf @@ -72,8 +73,7 @@ withInteropServer cmdline k = do serverConfig | cmdUseTLS cmdline = ServerConfig { - serverInsecure = Nothing - , serverSecure = Just SecureConfig { + serverSecure = Just SecureConfig { secureHost = "0.0.0.0" , securePort = cmdPort cmdline , securePubCert = cmdPubCert cmdline @@ -81,15 +81,20 @@ withInteropServer cmdline k = do , securePrivKey = cmdPrivKey cmdline , secureSslKeyLog = cmdSslKeyLog cmdline } + , serverInsecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } | otherwise = ServerConfig { - serverSecure = Nothing - , serverInsecure = Just InsecureConfig { + serverInsecure = Just InsecureConfig { insecureHost = Nothing , insecurePort = cmdPort cmdline } + , serverSecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } serverParams :: ServerParams diff --git a/kvstore/KVStore/Server.hs b/kvstore/KVStore/Server.hs index 3223d6c3..d8c94b4b 100644 --- a/kvstore/KVStore/Server.hs +++ b/kvstore/KVStore/Server.hs @@ -5,6 +5,7 @@ import Control.Monad import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Server import Network.GRPC.Server.Run @@ -33,8 +34,10 @@ withKeyValueServer cmdline@Cmdline{cmdJSON} k = do where config :: ServerConfig config = ServerConfig { - serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort - , serverSecure = Nothing + serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort + , serverSecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } params :: ServerParams diff --git a/src/Network/GRPC/Client/Connection.hs b/src/Network/GRPC/Client/Connection.hs index 963a9228..c8832375 100644 --- a/src/Network/GRPC/Client/Connection.hs +++ b/src/Network/GRPC/Client/Connection.hs @@ -47,6 +47,7 @@ import Network.GRPC.Client.Meta qualified as Meta import Network.GRPC.Client.Session import Network.GRPC.Common.Compression qualified as Compr import Network.GRPC.Common.Compression qualified as Compression +import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Spec import Network.GRPC.Util.GHC import Network.GRPC.Util.HTTP2.Stream (ServerDisconnected(..)) @@ -140,21 +141,7 @@ data ConnParams = ConnParams { -- messages sent by the client to the server. , connInitCompression :: Maybe Compression - -- | Override ping rate limit - -- - -- The @http2@ library imposes a ping rate limit as a security measure - -- against - -- [CVE-2019-9512](https://www.cve.org/CVERecord?id=CVE-2019-9512). By - -- default (as of version 5.1.2) it sets this limit at 10 pings/second. If - -- you find yourself being disconnected from a gRPC peer because that peer - -- is sending too many pings (you will see an - -- [EnhanceYourCalm](https://hackage.haskell.org/package/http2-5.1.2/docs/Network-HTTP2-Client.html#t:ErrorCode) - -- exception, corresponding to the - -- [ENHANCE_YOUR_CALM](https://www.rfc-editor.org/rfc/rfc9113#ErrorCodes) - -- HTTP/2 error code), you may wish to increase this limit. If you are - -- connecting to a peer that you trust, you can set this limit to - -- 'maxBound' (effectively turning off protecting against ping flooding). - , connOverridePingRateLimit :: Maybe Int + , connHTTP2Settings :: HTTP2Settings } instance Default ConnParams where @@ -164,7 +151,7 @@ instance Default ConnParams where , connReconnectPolicy = def , connContentType = Just ContentTypeDefault , connInitCompression = Nothing - , connOverridePingRateLimit = Nothing + , connHTTP2Settings = def } {------------------------------------------------------------------------------- @@ -536,10 +523,23 @@ connectInsecure connParams attempt addr = ConnectionReady (attemptClosed attempt) conn takeMVar $ attemptOutOfScope attempt where + settings :: HTTP2.Client.Settings + settings = HTTP2.Client.defaultSettings { + HTTP2.Client.maxConcurrentStreams = + Just . fromIntegral $ + http2MaxConcurrentStreams (connHTTP2Settings connParams) + , HTTP2.Client.initialWindowSize = + fromIntegral $ + http2StreamWindowSize (connHTTP2Settings connParams) + } clientConfig :: HTTP2.Client.ClientConfig clientConfig = overridePingRateLimit connParams $ HTTP2.Client.defaultClientConfig { HTTP2.Client.authority = authority addr + , HTTP2.Client.settings = settings + , HTTP2.Client.connectionWindowSize = + fromIntegral $ + http2ConnectionWindowSize (connHTTP2Settings connParams) } -- | Secure connection (using TLS) @@ -563,6 +563,16 @@ connectSecure connParams attempt validation sslKeyLog addr = do , HTTP2.TLS.Client.settingsCAStore = caStore , HTTP2.TLS.Client.settingsKeyLogger = keyLogger , HTTP2.TLS.Client.settingsAddrInfoFlags = [] + + , HTTP2.TLS.Client.settingsConcurrentStreams = + fromIntegral $ + http2MaxConcurrentStreams (connHTTP2Settings connParams) + , HTTP2.TLS.Client.settingsStreamWindowSize = + fromIntegral $ + http2StreamWindowSize (connHTTP2Settings connParams) + , HTTP2.TLS.Client.settingsConnectionWindowSize = + fromIntegral $ + http2ConnectionWindowSize (connHTTP2Settings connParams) } clientConfig :: HTTP2.Client.ClientConfig @@ -601,7 +611,7 @@ overridePingRateLimit :: overridePingRateLimit connParams clientConfig = clientConfig { HTTP2.Client.settings = settings { HTTP2.Client.pingRateLimit = - case connOverridePingRateLimit connParams of + case http2OverridePingRateLimit (connHTTP2Settings connParams) of Nothing -> HTTP2.Client.pingRateLimit settings Just limit -> limit } @@ -623,6 +633,6 @@ runTCPClient Address{addressHost, addressPort} = -- See docs of 'confBufferSize', but importantly: "this value is announced -- via SETTINGS_MAX_FRAME_SIZE to the peer." -- --- Value of 4kB is taken from the example code. +-- Value of 4KB is taken from the example code. writeBufferSize :: HPACK.BufferSize writeBufferSize = 4096 diff --git a/src/Network/GRPC/Common/HTTP2Settings.hs b/src/Network/GRPC/Common/HTTP2Settings.hs new file mode 100644 index 00000000..6ead9e5b --- /dev/null +++ b/src/Network/GRPC/Common/HTTP2Settings.hs @@ -0,0 +1,90 @@ +-- | Settings and parameters pertaining to HTTP\/2 +-- +-- Intended for unqualified import. + +module Network.GRPC.Common.HTTP2Settings + ( HTTP2Settings(..) + , defaultHTTP2Settings + ) where + +import Data.Default +import Data.Word + +-- | HTTP\/2 settings +data HTTP2Settings = HTTP2Settings { + -- | Maximum number of concurrent active streams + -- + -- + http2MaxConcurrentStreams :: Word32 + + -- | Window size for streams + -- + -- + , http2StreamWindowSize :: Word32 + + -- | Connection window size + -- + -- This value is broadcast via a @WINDOW_UDPATE@ frame at the beginning of + -- a new connection. + -- + -- If the consumed window space of all streams exceeds this value, the + -- sender will stop sending data. Therefore, if this value is less than + -- @'http2MaxConcurrentStreams' * 'http2StreamWindowSize'@, there + -- is risk of a control flow deadlock, since the connection window space + -- may be used up by streams that we are not yet processing before we have + -- received all data on the streams that we /are/ processing. To reduce + -- this risk, increase 'Network.GRPC.Server.Run.serverOverrideNumberOfWorkers'. See + -- for more + -- information. + , http2ConnectionWindowSize :: Word32 + + -- | Ping rate limit + -- + -- This setting is specific to the [@http2@ + -- package's](https://hackage.haskell.org/package/http2) implementation of + -- the HTTP\/2 specification. In particular, the library imposes a ping + -- rate limit as a security measure against + -- [CVE-2019-9512](https://www.cve.org/CVERecord?id=CVE-2019-9512). By + -- default (as of version 5.1.2) it sets this limit at 10 pings/second. If + -- you find yourself being disconnected from a gRPC peer because that peer + -- is sending too many pings (you will see an + -- [EnhanceYourCalm](https://hackage.haskell.org/package/http2-5.1.2/docs/Network-HTTP2-Client.html#t:ErrorCode) + -- exception, corresponding to the + -- [ENHANCE_YOUR_CALM](https://www.rfc-editor.org/rfc/rfc9113#ErrorCodes) + -- HTTP\/2 error code), you may wish to increase this limit. If you are + -- connecting to a peer that you trust, you can set this limit to + -- 'maxBound' (effectively turning off protecting against ping flooding). + , http2OverridePingRateLimit :: Maybe Int + } + deriving (Show) + +-- | Default HTTP\/2 settings +-- +-- [Section 6.5.2 of the HTTP\/2 +-- specification](https://datatracker.ietf.org/doc/html/rfc7540#section-6.5.2) +-- recommends that the @SETTINGS_MAX_CONCURRENT_STREAMS@ parameter be no smaller +-- than 100 "so as not to unnecessarily limit parallelism", so we default to +-- 128. +-- +-- The default initial stream window size (corresponding to the +-- @SETTINGS_INITIAL_WINDOW_SIZE@ HTTP\/2 parameter) is 64KB. +-- +-- The default connection window size is 128 * 64KB to avoid the control flow +-- deadlock discussed at 'http2ConnectionWindowSize'. +-- +-- The ping rate limit imposed by the [@http2@ +-- package](https://hackage.haskell.org/package/http2) is not overridden by +-- default. +defaultHTTP2Settings :: HTTP2Settings +defaultHTTP2Settings = HTTP2Settings { + http2MaxConcurrentStreams = defMaxConcurrentStreams + , http2StreamWindowSize = defInitialStreamWindowSize + , http2ConnectionWindowSize = defMaxConcurrentStreams * defInitialStreamWindowSize + , http2OverridePingRateLimit = Nothing + } + where + defMaxConcurrentStreams = 128 + defInitialStreamWindowSize = 1024 * 64 + +instance Default HTTP2Settings where + def = defaultHTTP2Settings diff --git a/src/Network/GRPC/Server.hs b/src/Network/GRPC/Server.hs index 731f591d..80fe0aad 100644 --- a/src/Network/GRPC/Server.hs +++ b/src/Network/GRPC/Server.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} - module Network.GRPC.Server ( -- * Server proper mkGrpcServer diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs index d15bdbb6..546035da 100644 --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -29,6 +29,7 @@ module Network.GRPC.Server.Run ( import Control.Concurrent.Async import Control.Concurrent.STM import Control.Exception +import Data.Maybe (fromMaybe) import Network.ByteOrder (BufferSize) import Network.HTTP2.Server qualified as HTTP2 import Network.HTTP2.TLS.Server qualified as HTTP2.TLS @@ -36,6 +37,7 @@ import Network.Run.TCP qualified as Run import Network.Socket import Network.TLS qualified as TLS +import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Server import Network.GRPC.Util.HTTP2 (allocConfigWithTimeout) import Network.GRPC.Util.TLS (SslKeyLog(..)) @@ -60,6 +62,22 @@ data ServerConfig = ServerConfig { -- -- Set to 'Nothing' to disable. , serverSecure :: Maybe SecureConfig + + -- | Number of threads that will be spawned to process incoming frames + -- on the currently active HTTP\/2 streams + -- + -- This setting is specific to the + -- [http2](https://hackage.haskell.org/package/http2) package's + -- implementation of the HTTP\/2 specification for servers. Set to + -- 'Nothing' to use the default of 8 worker threads. + -- + -- __Note__: If a lower 'http2ConnectionWindowSize' is desired, the + -- number of workers should be increased to avoid a potential HTTP\/2 + -- control flow deadlock. + , serverOverrideNumberOfWorkers :: Maybe Word + + -- | HTTP\/2 settings + , serverHTTP2Settings :: HTTP2Settings } -- | Offer insecure connection (no TLS) @@ -90,7 +108,7 @@ data SecureConfig = SecureConfig { -- | Port number -- - -- See 'insecurePort' for additional discussion'. + -- See 'insecurePort' for additional discussion. , securePort :: PortNumber -- | TLS public certificate (X.509 format) @@ -167,17 +185,13 @@ data ServerTerminated = ServerTerminated -- | Start the server forkServer :: ServerConfig -> HTTP2.Server -> (RunningServer -> IO a) -> IO a -forkServer ServerConfig{serverInsecure, serverSecure} server k = do +forkServer cfg server k = do runningSocketInsecure <- newEmptyTMVarIO runningSocketSecure <- newEmptyTMVarIO let secure, insecure :: IO () - insecure = case serverInsecure of - Nothing -> return () - Just cfg -> runInsecure cfg runningSocketInsecure server - secure = case serverSecure of - Nothing -> return () - Just cfg -> runSecure cfg runningSocketSecure server + insecure = runInsecure cfg runningSocketInsecure server + secure = runSecure cfg runningSocketSecure server withAsync insecure $ \runningServerInsecure -> withAsync secure $ \runningServerSecure -> @@ -275,47 +289,87 @@ getSocket serverAsync socketTMVar = do Insecure -------------------------------------------------------------------------------} -runInsecure :: InsecureConfig -> TMVar Socket -> HTTP2.Server -> IO () -runInsecure cfg socketTMVar server = +runInsecure :: ServerConfig -> TMVar Socket -> HTTP2.Server -> IO () +runInsecure ServerConfig{serverInsecure = Nothing} _ _ = return () +runInsecure + ServerConfig { + serverInsecure = Just insecureCfg + , serverOverrideNumberOfWorkers + , serverHTTP2Settings + } + socketTMVar server + = Run.runTCPServerWithSocket (openServerSocket socketTMVar) - (insecureHost cfg) - (show $ insecurePort cfg) $ \sock -> do + (insecureHost insecureCfg) + (show $ insecurePort insecureCfg) $ \sock -> do bracket (allocConfigWithTimeout sock writeBufferSize disableTimeout) HTTP2.freeSimpleConfig $ \config -> - HTTP2.run HTTP2.defaultServerConfig config server + HTTP2.run serverConfig config server + where + serverConfig :: HTTP2.ServerConfig + serverConfig = HTTP2.defaultServerConfig { + HTTP2.numberOfWorkers = + fromIntegral $ fromMaybe 8 serverOverrideNumberOfWorkers + , HTTP2.connectionWindowSize = + fromIntegral $ http2ConnectionWindowSize serverHTTP2Settings + , HTTP2.settings = + HTTP2.defaultSettings { + HTTP2.initialWindowSize = + fromIntegral $ + http2StreamWindowSize serverHTTP2Settings + , HTTP2.maxConcurrentStreams = + Just . fromIntegral $ + http2MaxConcurrentStreams serverHTTP2Settings + } + } {------------------------------------------------------------------------------- Secure (over TLS) -------------------------------------------------------------------------------} -runSecure :: SecureConfig -> TMVar Socket -> HTTP2.Server -> IO () -runSecure cfg socketTMVar server = do +runSecure :: ServerConfig -> TMVar Socket -> HTTP2.Server -> IO () +runSecure ServerConfig{serverSecure = Nothing} _ _ = return () +runSecure + ServerConfig { + serverSecure = Just secureCfg + , serverOverrideNumberOfWorkers + , serverHTTP2Settings + } + socketTMVar server = do cred :: TLS.Credential <- TLS.credentialLoadX509Chain - (securePubCert cfg) - (secureChainCerts cfg) - (securePrivKey cfg) + (securePubCert secureCfg) + (secureChainCerts secureCfg) + (securePrivKey secureCfg) >>= \case Left err -> throwIO $ CouldNotLoadCredentials err Right res -> return res - keyLogger <- Util.TLS.keyLogger (secureSslKeyLog cfg) - let settings :: HTTP2.TLS.Settings - settings = HTTP2.TLS.defaultSettings { + keyLogger <- Util.TLS.keyLogger (secureSslKeyLog secureCfg) + let tlsSettings :: HTTP2.TLS.Settings + tlsSettings = HTTP2.TLS.defaultSettings { HTTP2.TLS.settingsKeyLogger = keyLogger , HTTP2.TLS.settingsOpenServerSocket = openServerSocket socketTMVar , HTTP2.TLS.settingsTimeout = disableTimeout + , HTTP2.TLS.settingsNumberOfWorkers = + fromIntegral $ fromMaybe 8 serverOverrideNumberOfWorkers + , HTTP2.TLS.settingsConnectionWindowSize = + fromIntegral $ http2ConnectionWindowSize serverHTTP2Settings + , HTTP2.TLS.settingsStreamWindowSize = + fromIntegral $ http2StreamWindowSize serverHTTP2Settings + , HTTP2.TLS.settingsConcurrentStreams = + fromIntegral $ http2MaxConcurrentStreams serverHTTP2Settings } HTTP2.TLS.run - settings + tlsSettings (TLS.Credentials [cred]) - (secureHost cfg) - (securePort cfg) + (secureHost secureCfg) + (securePort secureCfg) server data CouldNotLoadCredentials = diff --git a/src/Network/GRPC/Spec/Status.hs b/src/Network/GRPC/Spec/Status.hs index f102be7b..41e59a41 100644 --- a/src/Network/GRPC/Spec/Status.hs +++ b/src/Network/GRPC/Spec/Status.hs @@ -41,7 +41,7 @@ data GrpcError = -- | Invalid argument -- -- The client specified an invalid argument. Note that this differs from - -- 'GrpcFailedPrecondition': 'GrpcInvalidArgumen'` indicates arguments that + -- 'GrpcFailedPrecondition': 'GrpcInvalidArgument'` indicates arguments that -- are problematic regardless of the state of the system (e.g., a malformed -- file name). | GrpcInvalidArgument @@ -79,7 +79,7 @@ data GrpcError = -- * 'GrpcPermissionDenied' must not be used for rejections caused by -- exhausting some resource (use 'GrpcResourceExhausted' instead for those -- errors). - -- * 'GrpcPermissionDenoed' must not be used if the caller can not be + -- * 'GrpcPermissionDenied' must not be used if the caller can not be -- identified (use 'GrpcUnauthenticated' instead for those errors). -- -- This error code does not imply the request is valid or the requested @@ -99,7 +99,7 @@ data GrpcError = -- is non-empty, an rmdir operation is applied to a non-directory, etc. -- -- Service implementors can use the following guidelines to decide between - -- 'GrpcFailedPrecondition', 'GrpcAborted', and 'GrpcUnvailable': + -- 'GrpcFailedPrecondition', 'GrpcAborted', and 'GrpcUnavailable': -- -- (a) Use 'GrpcUnavailable' if the client can retry just the failing call. -- (b) Use 'GrpcAborted' if the client should retry at a higher level (e.g., diff --git a/test-grapesy/Test/Driver/ClientServer.hs b/test-grapesy/Test/Driver/ClientServer.hs index 714fae84..5f1581f7 100644 --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -39,6 +39,7 @@ import Test.Tasty.QuickCheck qualified as QuickCheck import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr +import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Internal.XIO (NeverThrows) import Network.GRPC.Internal.XIO qualified as XIO import Network.GRPC.Server qualified as Server @@ -452,18 +453,22 @@ withTestServer cfg firstTestFailure handlerLock serverHandlers k = do insecureHost = Nothing , insecurePort = serverPort cfg } - , serverSecure = Nothing + , serverSecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } Just (TlsFail TlsFailUnsupported) -> Server.ServerConfig { serverInsecure = Just Server.InsecureConfig { insecureHost = Nothing , insecurePort = serverPort cfg } - , serverSecure = Nothing + , serverSecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } Just _tlsSetup -> Server.ServerConfig { serverInsecure = Nothing - , serverSecure = Just $ Server.SecureConfig { + , serverSecure = Just $ Server.SecureConfig { secureHost = "127.0.0.1" , securePort = serverPort cfg , securePubCert = pubCert @@ -471,6 +476,8 @@ withTestServer cfg firstTestFailure handlerLock serverHandlers k = do , securePrivKey = privKey , secureSslKeyLog = SslKeyLogNone } + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } serverParams :: Server.ServerParams @@ -528,7 +535,6 @@ runTestClient cfg firstTestFailure port clientRun = do connCompression = clientCompr cfg , connInitCompression = clientInitCompr cfg , connDefaultTimeout = Nothing - , connOverridePingRateLimit = Nothing -- Content-type , connContentType = @@ -544,6 +550,7 @@ runTestClient cfg firstTestFailure port clientRun = do Client.ReconnectAfter $ do threadDelay 100_000 return Client.DontReconnect + , connHTTP2Settings = defaultHTTP2Settings } clientServer :: Client.Server diff --git a/test-stress/Test/Stress/Server.hs b/test-stress/Test/Stress/Server.hs index 96aa6c88..8c77acbd 100644 --- a/test-stress/Test/Stress/Server.hs +++ b/test-stress/Test/Stress/Server.hs @@ -1,6 +1,7 @@ module Test.Stress.Server (server) where import Network.GRPC.Common +import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Server.Run import Network.GRPC.Server.StreamType import Network.GRPC.Server.StreamType.Binary qualified as Binary @@ -22,6 +23,8 @@ server _cmdline = where config :: ServerConfig config = ServerConfig { - serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort - , serverSecure = Nothing + serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort + , serverSecure = Nothing + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = defaultHTTP2Settings } From 59a86508a6bbf87e32aedf8fba76efae9fb98975 Mon Sep 17 00:00:00 2001 From: Finley McIlwaine Date: Wed, 3 Jul 2024 11:52:19 -0700 Subject: [PATCH 2/4] Move new `ServerConfig` fields to `ServerParams` --- demo-server/Main.hs | 9 +-- interop/Interop/Server.hs | 15 ++--- kvstore/KVStore/Server.hs | 9 +-- src/Network/GRPC/Common.hs | 5 ++ src/Network/GRPC/Common/HTTP2Settings.hs | 11 +-- src/Network/GRPC/Server/Context.hs | 29 ++++++-- src/Network/GRPC/Server/Run.hs | 85 ++++++++---------------- test-grapesy/Test/Driver/ClientServer.hs | 15 ++--- test-stress/Test/Stress/Server.hs | 9 +-- 9 files changed, 82 insertions(+), 105 deletions(-) diff --git a/demo-server/Main.hs b/demo-server/Main.hs index 4ef1ea08..95d246cf 100644 --- a/demo-server/Main.hs +++ b/demo-server/Main.hs @@ -6,7 +6,6 @@ import Data.Aeson import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compression -import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Common.Protobuf import Network.GRPC.Server import Network.GRPC.Server.Protobuf @@ -54,15 +53,13 @@ main = do let serverConfig :: ServerConfig serverConfig = ServerConfig { - serverInsecure = cmdInsecure cmdline - , serverSecure = cmdSecure cmdline - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings + serverInsecure = cmdInsecure cmdline + , serverSecure = cmdSecure cmdline } runServerWithHandlers - serverConfig (serverParams cmdline) + serverConfig (fromServices $ services cmdline db) getRouteGuideDb :: IO [Proto Feature] diff --git a/interop/Interop/Server.hs b/interop/Interop/Server.hs index 02d71f73..652655e7 100644 --- a/interop/Interop/Server.hs +++ b/interop/Interop/Server.hs @@ -7,7 +7,6 @@ import Control.Exception (SomeException) import Control.Monad.Catch (generalBracket, ExitCase(..)) import Network.GRPC.Common -import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Internal.XIO qualified as XIO import Network.GRPC.Server import Network.GRPC.Server.Protobuf @@ -67,13 +66,14 @@ services = withInteropServer :: Cmdline -> (RunningServer -> IO a) -> IO a withInteropServer cmdline k = do server <- mkGrpcServer serverParams $ fromServices services - forkServer serverConfig server k + forkServer serverParams serverConfig server k where serverConfig :: ServerConfig serverConfig | cmdUseTLS cmdline = ServerConfig { - serverSecure = Just SecureConfig { + serverInsecure = Nothing + , serverSecure = Just SecureConfig { secureHost = "0.0.0.0" , securePort = cmdPort cmdline , securePubCert = cmdPubCert cmdline @@ -81,20 +81,15 @@ withInteropServer cmdline k = do , securePrivKey = cmdPrivKey cmdline , secureSslKeyLog = cmdSslKeyLog cmdline } - , serverInsecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings } | otherwise = ServerConfig { - serverInsecure = Just InsecureConfig { + serverSecure = Nothing + , serverInsecure = Just InsecureConfig { insecureHost = Nothing , insecurePort = cmdPort cmdline } - , serverSecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings } serverParams :: ServerParams diff --git a/kvstore/KVStore/Server.hs b/kvstore/KVStore/Server.hs index d8c94b4b..ae91c081 100644 --- a/kvstore/KVStore/Server.hs +++ b/kvstore/KVStore/Server.hs @@ -5,7 +5,6 @@ import Control.Monad import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr -import Network.GRPC.Common.HTTP2Settings (defaultHTTP2Settings) import Network.GRPC.Server import Network.GRPC.Server.Run @@ -30,14 +29,12 @@ withKeyValueServer cmdline@Cmdline{cmdJSON} k = do | otherwise = Protobuf.server $ handlers cmdline store server <- mkGrpcServer params rpcHandlers - forkServer config server k + forkServer params config server k where config :: ServerConfig config = ServerConfig { - serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort - , serverSecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings + serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort + , serverSecure = Nothing } params :: ServerParams diff --git a/src/Network/GRPC/Common.hs b/src/Network/GRPC/Common.hs index 5ebe1551..6402d385 100644 --- a/src/Network/GRPC/Common.hs +++ b/src/Network/GRPC/Common.hs @@ -41,9 +41,13 @@ module Network.GRPC.Common ( -- * Configuration , SslKeyLog(..) + -- * HTTP\/2 Settings + , HTTP2Settings(..) + -- * Defaults , defaultInsecurePort , defaultSecurePort + , defaultHTTP2Settings -- * Exceptions @@ -74,6 +78,7 @@ import Network.Socket (PortNumber) import Control.Exception +import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Common.NextElem (NextElem(..)) import Network.GRPC.Common.StreamElem (StreamElem(..)) import Network.GRPC.Spec diff --git a/src/Network/GRPC/Common/HTTP2Settings.hs b/src/Network/GRPC/Common/HTTP2Settings.hs index 6ead9e5b..b08245c0 100644 --- a/src/Network/GRPC/Common/HTTP2Settings.hs +++ b/src/Network/GRPC/Common/HTTP2Settings.hs @@ -29,12 +29,13 @@ data HTTP2Settings = HTTP2Settings { -- -- If the consumed window space of all streams exceeds this value, the -- sender will stop sending data. Therefore, if this value is less than - -- @'http2MaxConcurrentStreams' * 'http2StreamWindowSize'@, there - -- is risk of a control flow deadlock, since the connection window space - -- may be used up by streams that we are not yet processing before we have + -- @'http2MaxConcurrentStreams' * 'http2StreamWindowSize'@, there is risk + -- of a control flow deadlock, since the connection window space may be + -- used up by streams that we are not yet processing before we have -- received all data on the streams that we /are/ processing. To reduce - -- this risk, increase 'Network.GRPC.Server.Run.serverOverrideNumberOfWorkers'. See - -- for more + -- this risk, increase + -- 'Network.GRPC.Server.Run.serverOverrideNumberOfWorkers' for the server. + -- See for more -- information. , http2ConnectionWindowSize :: Word32 diff --git a/src/Network/GRPC/Server/Context.hs b/src/Network/GRPC/Server/Context.hs index e28a594f..919ada3b 100644 --- a/src/Network/GRPC/Server/Context.hs +++ b/src/Network/GRPC/Server/Context.hs @@ -15,6 +15,7 @@ import Control.Monad.XIO qualified as XIO import Data.Default import System.IO +import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr import Network.GRPC.Server.RequestHandler.API import Network.GRPC.Spec @@ -83,15 +84,33 @@ data ServerParams = ServerParams { -- headers are valid. By default we do /not/ do this, throwing an error -- only in scenarios where we really cannot continue. , serverVerifyHeaders :: Bool + + -- | Number of threads that will be spawned to process incoming frames + -- on the currently active HTTP\/2 streams + -- + -- This setting is specific to the + -- [http2](https://hackage.haskell.org/package/http2) package's + -- implementation of the HTTP\/2 specification for servers. Set to + -- 'Nothing' to use the default of 8 worker threads. + -- + -- __Note__: If a lower 'http2ConnectionWindowSize' is desired, the + -- number of workers should be increased to avoid a potential HTTP\/2 + -- control flow deadlock. + , serverOverrideNumberOfWorkers :: Maybe Word + + -- | HTTP\/2 settings + , serverHTTP2Settings :: HTTP2Settings } instance Default ServerParams where def = ServerParams { - serverCompression = def - , serverTopLevel = defaultServerTopLevel - , serverExceptionToClient = defaultServerExceptionToClient - , serverContentType = Just ContentTypeDefault - , serverVerifyHeaders = False + serverCompression = def + , serverTopLevel = defaultServerTopLevel + , serverExceptionToClient = defaultServerExceptionToClient + , serverContentType = Just ContentTypeDefault + , serverVerifyHeaders = False + , serverOverrideNumberOfWorkers = Nothing + , serverHTTP2Settings = def } defaultServerTopLevel :: diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs index 546035da..3b1527d7 100644 --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -62,22 +62,6 @@ data ServerConfig = ServerConfig { -- -- Set to 'Nothing' to disable. , serverSecure :: Maybe SecureConfig - - -- | Number of threads that will be spawned to process incoming frames - -- on the currently active HTTP\/2 streams - -- - -- This setting is specific to the - -- [http2](https://hackage.haskell.org/package/http2) package's - -- implementation of the HTTP\/2 specification for servers. Set to - -- 'Nothing' to use the default of 8 worker threads. - -- - -- __Note__: If a lower 'http2ConnectionWindowSize' is desired, the - -- number of workers should be increased to avoid a potential HTTP\/2 - -- control flow deadlock. - , serverOverrideNumberOfWorkers :: Maybe Word - - -- | HTTP\/2 settings - , serverHTTP2Settings :: HTTP2Settings } -- | Offer insecure connection (no TLS) @@ -139,18 +123,18 @@ data SecureConfig = SecureConfig { -- -- See also 'runServerWithHandlers', which handles the creation of the -- 'HTTP2.Server' for you. -runServer :: ServerConfig -> HTTP2.Server -> IO () -runServer cfg server = forkServer cfg server $ waitServer +runServer :: ServerParams -> ServerConfig -> HTTP2.Server -> IO () +runServer params cfg server = forkServer params cfg server $ waitServer -- | Convenience function that combines 'runServer' with 'mkGrpcServer' runServerWithHandlers :: - ServerConfig - -> ServerParams + ServerParams + -> ServerConfig -> [SomeRpcHandler IO] -> IO () -runServerWithHandlers config params handlers = do +runServerWithHandlers params config handlers = do server <- mkGrpcServer params handlers - runServer config server + runServer params config server {------------------------------------------------------------------------------- Full interface @@ -184,14 +168,18 @@ data ServerTerminated = ServerTerminated deriving anyclass (Exception) -- | Start the server -forkServer :: ServerConfig -> HTTP2.Server -> (RunningServer -> IO a) -> IO a -forkServer cfg server k = do +forkServer :: ServerParams -> ServerConfig -> HTTP2.Server -> (RunningServer -> IO a) -> IO a +forkServer params ServerConfig{serverInsecure, serverSecure} server k = do runningSocketInsecure <- newEmptyTMVarIO runningSocketSecure <- newEmptyTMVarIO let secure, insecure :: IO () - insecure = runInsecure cfg runningSocketInsecure server - secure = runSecure cfg runningSocketSecure server + insecure = case serverInsecure of + Nothing -> return () + Just cfg -> runInsecure params cfg runningSocketInsecure server + secure = case serverSecure of + Nothing -> return () + Just cfg -> runSecure params cfg runningSocketSecure server withAsync insecure $ \runningServerInsecure -> withAsync secure $ \runningServerSecure -> @@ -289,20 +277,12 @@ getSocket serverAsync socketTMVar = do Insecure -------------------------------------------------------------------------------} -runInsecure :: ServerConfig -> TMVar Socket -> HTTP2.Server -> IO () -runInsecure ServerConfig{serverInsecure = Nothing} _ _ = return () -runInsecure - ServerConfig { - serverInsecure = Just insecureCfg - , serverOverrideNumberOfWorkers - , serverHTTP2Settings - } - socketTMVar server - = +runInsecure :: ServerParams -> InsecureConfig -> TMVar Socket -> HTTP2.Server -> IO () +runInsecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg socketTMVar server = Run.runTCPServerWithSocket (openServerSocket socketTMVar) - (insecureHost insecureCfg) - (show $ insecurePort insecureCfg) $ \sock -> do + (insecureHost cfg) + (show $ insecurePort cfg) $ \sock -> do bracket (allocConfigWithTimeout sock writeBufferSize disableTimeout) HTTP2.freeSimpleConfig $ \config -> HTTP2.run serverConfig config server @@ -328,27 +308,20 @@ runInsecure Secure (over TLS) -------------------------------------------------------------------------------} -runSecure :: ServerConfig -> TMVar Socket -> HTTP2.Server -> IO () -runSecure ServerConfig{serverSecure = Nothing} _ _ = return () -runSecure - ServerConfig { - serverSecure = Just secureCfg - , serverOverrideNumberOfWorkers - , serverHTTP2Settings - } - socketTMVar server = do +runSecure :: ServerParams -> SecureConfig -> TMVar Socket -> HTTP2.Server -> IO () +runSecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg socketTMVar server = do cred :: TLS.Credential <- TLS.credentialLoadX509Chain - (securePubCert secureCfg) - (secureChainCerts secureCfg) - (securePrivKey secureCfg) + (securePubCert cfg) + (secureChainCerts cfg) + (securePrivKey cfg) >>= \case Left err -> throwIO $ CouldNotLoadCredentials err Right res -> return res - keyLogger <- Util.TLS.keyLogger (secureSslKeyLog secureCfg) - let tlsSettings :: HTTP2.TLS.Settings - tlsSettings = HTTP2.TLS.defaultSettings { + keyLogger <- Util.TLS.keyLogger (secureSslKeyLog cfg) + let settings :: HTTP2.TLS.Settings + settings = HTTP2.TLS.defaultSettings { HTTP2.TLS.settingsKeyLogger = keyLogger , HTTP2.TLS.settingsOpenServerSocket = @@ -366,10 +339,10 @@ runSecure } HTTP2.TLS.run - tlsSettings + settings (TLS.Credentials [cred]) - (secureHost secureCfg) - (securePort secureCfg) + (secureHost cfg) + (securePort cfg) server data CouldNotLoadCredentials = diff --git a/test-grapesy/Test/Driver/ClientServer.hs b/test-grapesy/Test/Driver/ClientServer.hs index 5f1581f7..0b156174 100644 --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -39,7 +39,6 @@ import Test.Tasty.QuickCheck qualified as QuickCheck import Network.GRPC.Client qualified as Client import Network.GRPC.Common import Network.GRPC.Common.Compression qualified as Compr -import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Internal.XIO (NeverThrows) import Network.GRPC.Internal.XIO qualified as XIO import Network.GRPC.Server qualified as Server @@ -453,22 +452,18 @@ withTestServer cfg firstTestFailure handlerLock serverHandlers k = do insecureHost = Nothing , insecurePort = serverPort cfg } - , serverSecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings + , serverSecure = Nothing } Just (TlsFail TlsFailUnsupported) -> Server.ServerConfig { serverInsecure = Just Server.InsecureConfig { insecureHost = Nothing , insecurePort = serverPort cfg } - , serverSecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings + , serverSecure = Nothing } Just _tlsSetup -> Server.ServerConfig { serverInsecure = Nothing - , serverSecure = Just $ Server.SecureConfig { + , serverSecure = Just $ Server.SecureConfig { secureHost = "127.0.0.1" , securePort = serverPort cfg , securePubCert = pubCert @@ -476,8 +471,6 @@ withTestServer cfg firstTestFailure handlerLock serverHandlers k = do , securePrivKey = privKey , secureSslKeyLog = SslKeyLogNone } - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings } serverParams :: Server.ServerParams @@ -498,7 +491,7 @@ withTestServer cfg firstTestFailure handlerLock serverHandlers k = do } server <- Server.mkGrpcServer serverParams serverHandlers - Server.forkServer serverConfig server k + Server.forkServer serverParams serverConfig server k {------------------------------------------------------------------------------- Client diff --git a/test-stress/Test/Stress/Server.hs b/test-stress/Test/Stress/Server.hs index 8c77acbd..a57b79b6 100644 --- a/test-stress/Test/Stress/Server.hs +++ b/test-stress/Test/Stress/Server.hs @@ -1,7 +1,6 @@ module Test.Stress.Server (server) where import Network.GRPC.Common -import Network.GRPC.Common.HTTP2Settings import Network.GRPC.Server.Run import Network.GRPC.Server.StreamType import Network.GRPC.Server.StreamType.Binary qualified as Binary @@ -15,7 +14,7 @@ import Test.Stress.Server.API server :: Cmdline -> IO () server _cmdline = - runServerWithHandlers config def [ + runServerWithHandlers def config [ fromMethod $ Binary.mkNonStreaming @ManyShortLived @Word $ return . succ @@ -23,8 +22,6 @@ server _cmdline = where config :: ServerConfig config = ServerConfig { - serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort - , serverSecure = Nothing - , serverOverrideNumberOfWorkers = Nothing - , serverHTTP2Settings = defaultHTTP2Settings + serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort + , serverSecure = Nothing } From 688c6ed6d3c74b12721af465ab54798404033571 Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 4 Jul 2024 09:04:55 +0200 Subject: [PATCH 3/4] Don't hardcode http2's default into grapesy --- src/Network/GRPC/Server/Context.hs | 2 +- src/Network/GRPC/Server/Run.hs | 8 ++++++-- 2 files changed, 7 insertions(+), 3 deletions(-) diff --git a/src/Network/GRPC/Server/Context.hs b/src/Network/GRPC/Server/Context.hs index 919ada3b..b97faa2d 100644 --- a/src/Network/GRPC/Server/Context.hs +++ b/src/Network/GRPC/Server/Context.hs @@ -91,7 +91,7 @@ data ServerParams = ServerParams { -- This setting is specific to the -- [http2](https://hackage.haskell.org/package/http2) package's -- implementation of the HTTP\/2 specification for servers. Set to - -- 'Nothing' to use the default of 8 worker threads. + -- 'Nothing' if you don't want to override the default. -- -- __Note__: If a lower 'http2ConnectionWindowSize' is desired, the -- number of workers should be increased to avoid a potential HTTP\/2 diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs index 3b1527d7..cc9e36db 100644 --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -290,7 +290,9 @@ runInsecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg serverConfig :: HTTP2.ServerConfig serverConfig = HTTP2.defaultServerConfig { HTTP2.numberOfWorkers = - fromIntegral $ fromMaybe 8 serverOverrideNumberOfWorkers + fromMaybe + (HTTP2.numberOfWorkers HTTP2.defaultServerConfig) + (fromIntegral <$> serverOverrideNumberOfWorkers) , HTTP2.connectionWindowSize = fromIntegral $ http2ConnectionWindowSize serverHTTP2Settings , HTTP2.settings = @@ -329,7 +331,9 @@ runSecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg s , HTTP2.TLS.settingsTimeout = disableTimeout , HTTP2.TLS.settingsNumberOfWorkers = - fromIntegral $ fromMaybe 8 serverOverrideNumberOfWorkers + fromMaybe + (HTTP2.TLS.settingsNumberOfWorkers HTTP2.TLS.defaultSettings) + (fromIntegral <$> serverOverrideNumberOfWorkers) , HTTP2.TLS.settingsConnectionWindowSize = fromIntegral $ http2ConnectionWindowSize serverHTTP2Settings , HTTP2.TLS.settingsStreamWindowSize = From d2ac53f05059a32d8a89828e56f691eacbab213c Mon Sep 17 00:00:00 2001 From: Edsko de Vries Date: Thu, 4 Jul 2024 09:07:19 +0200 Subject: [PATCH 4/4] Restore 80 character line limit This just changes code layout, nothing else. --- src/Network/GRPC/Server/Run.hs | 49 ++++++++++++++++++++++++++-------- 1 file changed, 38 insertions(+), 11 deletions(-) diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs index cc9e36db..ce7f7a6f 100644 --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -168,18 +168,25 @@ data ServerTerminated = ServerTerminated deriving anyclass (Exception) -- | Start the server -forkServer :: ServerParams -> ServerConfig -> HTTP2.Server -> (RunningServer -> IO a) -> IO a +forkServer :: + ServerParams + -> ServerConfig + -> HTTP2.Server + -> (RunningServer -> IO a) + -> IO a forkServer params ServerConfig{serverInsecure, serverSecure} server k = do runningSocketInsecure <- newEmptyTMVarIO runningSocketSecure <- newEmptyTMVarIO let secure, insecure :: IO () - insecure = case serverInsecure of - Nothing -> return () - Just cfg -> runInsecure params cfg runningSocketInsecure server - secure = case serverSecure of - Nothing -> return () - Just cfg -> runSecure params cfg runningSocketSecure server + insecure = + case serverInsecure of + Nothing -> return () + Just cfg -> runInsecure params cfg runningSocketInsecure server + secure = + case serverSecure of + Nothing -> return () + Just cfg -> runSecure params cfg runningSocketSecure server withAsync insecure $ \runningServerInsecure -> withAsync secure $ \runningServerSecure -> @@ -277,8 +284,13 @@ getSocket serverAsync socketTMVar = do Insecure -------------------------------------------------------------------------------} -runInsecure :: ServerParams -> InsecureConfig -> TMVar Socket -> HTTP2.Server -> IO () -runInsecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg socketTMVar server = +runInsecure :: + ServerParams + -> InsecureConfig + -> TMVar Socket + -> HTTP2.Server + -> IO () +runInsecure params cfg socketTMVar server = Run.runTCPServerWithSocket (openServerSocket socketTMVar) (insecureHost cfg) @@ -287,6 +299,11 @@ runInsecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg HTTP2.freeSimpleConfig $ \config -> HTTP2.run serverConfig config server where + ServerParams{ + serverOverrideNumberOfWorkers + , serverHTTP2Settings + } = params + serverConfig :: HTTP2.ServerConfig serverConfig = HTTP2.defaultServerConfig { HTTP2.numberOfWorkers = @@ -310,8 +327,13 @@ runInsecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg Secure (over TLS) -------------------------------------------------------------------------------} -runSecure :: ServerParams -> SecureConfig -> TMVar Socket -> HTTP2.Server -> IO () -runSecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg socketTMVar server = do +runSecure :: + ServerParams + -> SecureConfig + -> TMVar Socket + -> HTTP2.Server + -> IO () +runSecure params cfg socketTMVar server = do cred :: TLS.Credential <- TLS.credentialLoadX509Chain (securePubCert cfg) @@ -348,6 +370,11 @@ runSecure ServerParams{serverOverrideNumberOfWorkers, serverHTTP2Settings} cfg s (secureHost cfg) (securePort cfg) server + where + ServerParams{ + serverOverrideNumberOfWorkers + , serverHTTP2Settings + } = params data CouldNotLoadCredentials = -- | Failed to load server credentials