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 }