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..95d246cf 100644 --- a/demo-server/Main.hs +++ b/demo-server/Main.hs @@ -58,8 +58,8 @@ main = do } runServerWithHandlers - serverConfig (serverParams cmdline) + serverConfig (fromServices $ services cmdline db) getRouteGuideDb :: IO [Proto Feature] 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..652655e7 100644 --- a/interop/Interop/Server.hs +++ b/interop/Interop/Server.hs @@ -66,7 +66,7 @@ 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 diff --git a/kvstore/KVStore/Server.hs b/kvstore/KVStore/Server.hs index 3223d6c3..ae91c081 100644 --- a/kvstore/KVStore/Server.hs +++ b/kvstore/KVStore/Server.hs @@ -29,7 +29,7 @@ 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 { 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.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 new file mode 100644 index 00000000..b08245c0 --- /dev/null +++ b/src/Network/GRPC/Common/HTTP2Settings.hs @@ -0,0 +1,91 @@ +-- | 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' for the server. + -- 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/Context.hs b/src/Network/GRPC/Server/Context.hs index e28a594f..b97faa2d 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' 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 + -- 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 d15bdbb6..ce7f7a6f 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(..)) @@ -90,7 +92,7 @@ data SecureConfig = SecureConfig { -- | Port number -- - -- See 'insecurePort' for additional discussion'. + -- See 'insecurePort' for additional discussion. , securePort :: PortNumber -- | TLS public certificate (X.509 format) @@ -121,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 @@ -166,18 +168,25 @@ data ServerTerminated = ServerTerminated deriving anyclass (Exception) -- | Start the server -forkServer :: ServerConfig -> HTTP2.Server -> (RunningServer -> IO a) -> IO a -forkServer ServerConfig{serverInsecure, serverSecure} 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 = case serverInsecure of - Nothing -> return () - Just cfg -> runInsecure cfg runningSocketInsecure server - secure = case serverSecure of - Nothing -> return () - Just cfg -> 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 -> @@ -275,22 +284,56 @@ getSocket serverAsync socketTMVar = do Insecure -------------------------------------------------------------------------------} -runInsecure :: InsecureConfig -> TMVar Socket -> HTTP2.Server -> IO () -runInsecure cfg socketTMVar server = +runInsecure :: + ServerParams + -> InsecureConfig + -> TMVar Socket + -> HTTP2.Server + -> IO () +runInsecure params cfg socketTMVar server = Run.runTCPServerWithSocket (openServerSocket socketTMVar) (insecureHost cfg) (show $ insecurePort cfg) $ \sock -> do bracket (allocConfigWithTimeout sock writeBufferSize disableTimeout) HTTP2.freeSimpleConfig $ \config -> - HTTP2.run HTTP2.defaultServerConfig config server + HTTP2.run serverConfig config server + where + ServerParams{ + serverOverrideNumberOfWorkers + , serverHTTP2Settings + } = params + + serverConfig :: HTTP2.ServerConfig + serverConfig = HTTP2.defaultServerConfig { + HTTP2.numberOfWorkers = + fromMaybe + (HTTP2.numberOfWorkers HTTP2.defaultServerConfig) + (fromIntegral <$> 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 :: + ServerParams + -> SecureConfig + -> TMVar Socket + -> HTTP2.Server + -> IO () +runSecure params cfg socketTMVar server = do cred :: TLS.Credential <- TLS.credentialLoadX509Chain (securePubCert cfg) @@ -309,6 +352,16 @@ runSecure cfg socketTMVar server = do openServerSocket socketTMVar , HTTP2.TLS.settingsTimeout = disableTimeout + , HTTP2.TLS.settingsNumberOfWorkers = + fromMaybe + (HTTP2.TLS.settingsNumberOfWorkers HTTP2.TLS.defaultSettings) + (fromIntegral <$> serverOverrideNumberOfWorkers) + , HTTP2.TLS.settingsConnectionWindowSize = + fromIntegral $ http2ConnectionWindowSize serverHTTP2Settings + , HTTP2.TLS.settingsStreamWindowSize = + fromIntegral $ http2StreamWindowSize serverHTTP2Settings + , HTTP2.TLS.settingsConcurrentStreams = + fromIntegral $ http2MaxConcurrentStreams serverHTTP2Settings } HTTP2.TLS.run @@ -317,6 +370,11 @@ runSecure cfg socketTMVar server = do (secureHost cfg) (securePort cfg) server + where + ServerParams{ + serverOverrideNumberOfWorkers + , serverHTTP2Settings + } = params data CouldNotLoadCredentials = -- | Failed to load server credentials 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..0b156174 100644 --- a/test-grapesy/Test/Driver/ClientServer.hs +++ b/test-grapesy/Test/Driver/ClientServer.hs @@ -491,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 @@ -528,7 +528,6 @@ runTestClient cfg firstTestFailure port clientRun = do connCompression = clientCompr cfg , connInitCompression = clientInitCompr cfg , connDefaultTimeout = Nothing - , connOverridePingRateLimit = Nothing -- Content-type , connContentType = @@ -544,6 +543,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..a57b79b6 100644 --- a/test-stress/Test/Stress/Server.hs +++ b/test-stress/Test/Stress/Server.hs @@ -14,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