diff --git a/grapesy.cabal b/grapesy.cabal index 90e52010..6c96af68 100644 --- a/grapesy.cabal +++ b/grapesy.cabal @@ -206,16 +206,16 @@ library , hashable >= 1.3 && < 1.5 , http-types >= 0.12 && < 0.13 , http2 >= 5.2.4 && < 5.3 - , http2-tls >= 0.2.11 && < 0.4 + , http2-tls >= 0.4 && < 0.5 , lens >= 5.0 && < 5.4 , mtl >= 2.2 && < 2.4 , network >= 3.1 && < 3.3 - , network-byte-order >= 0.1 && < 0.2 - , network-run >= 0.2.7 && < 0.4 + , network-run >= 0.4 && < 0.5 , proto-lens >= 0.7 && < 0.8 , proto-lens-runtime >= 0.7 && < 0.8 , random >= 1.2 && < 1.3 , record-hasfield >= 1.0 && < 1.1 + , recv >= 0.1 && < 0.2 , stm >= 2.5 && < 2.6 , text >= 1.2 && < 2.2 , time-manager >= 0.1 && < 0.2 @@ -576,6 +576,10 @@ benchmark grapesy-kvstore KVStore.Util.Store Proto.Kvstore + + Paths_grapesy + autogen-modules: + Paths_grapesy build-depends: grapesy build-depends: diff --git a/kvstore/KVStore/Client.hs b/kvstore/KVStore/Client.hs index 96cd6400..17c0df47 100644 --- a/kvstore/KVStore/Client.hs +++ b/kvstore/KVStore/Client.hs @@ -89,7 +89,12 @@ showStats Cmdline{cmdDuration} stats = unlines [ -- separate thread, and kill the thread after some amount of time. The number -- of RPC calls made can then be read off from the 'IORef'. client :: Cmdline -> IORef Stats -> IO () -client Cmdline{cmdJSON} statsVar = do +client Cmdline{ + cmdJSON + , cmdSecure + , cmdDisableTcpNoDelay + , cmdPingRateLimit + } statsVar = do knownKeys <- RandomAccessSet.new random <- RandomGen.new @@ -120,14 +125,31 @@ client Cmdline{cmdJSON} statsVar = do _ -> error "impossible" where params :: ConnParams - params = def + params = def { + connHTTP2Settings = def { + http2TcpNoDelay = not cmdDisableTcpNoDelay + , http2OverridePingRateLimit = cmdPingRateLimit + } + } server :: Server - server = ServerInsecure $ Address { - addressHost = "127.0.0.1" - , addressPort = defaultInsecurePort - , addressAuthority = Nothing - } + server + | cmdSecure + = ServerSecure + NoServerValidation + SslKeyLogNone -- Let the server write the log + Address { + addressHost = "127.0.0.1" + , addressPort = defaultSecurePort + , addressAuthority = Nothing + } + + | otherwise + = ServerInsecure $ Address { + addressHost = "127.0.0.1" + , addressPort = defaultInsecurePort + , addressAuthority = Nothing + } {------------------------------------------------------------------------------- Access the various server features diff --git a/kvstore/KVStore/Cmdline.hs b/kvstore/KVStore/Cmdline.hs index c6b127d7..55590753 100644 --- a/kvstore/KVStore/Cmdline.hs +++ b/kvstore/KVStore/Cmdline.hs @@ -13,10 +13,13 @@ import Options.Applicative qualified as Opt -------------------------------------------------------------------------------} data Cmdline = Cmdline { - cmdMode :: Mode - , cmdDuration :: Int - , cmdSimulateWork :: Bool - , cmdJSON :: Bool + cmdMode :: Mode + , cmdDuration :: Int + , cmdSimulateWork :: Bool + , cmdJSON :: Bool + , cmdSecure :: Bool + , cmdDisableTcpNoDelay :: Bool + , cmdPingRateLimit :: Maybe Int } data Mode = @@ -59,6 +62,21 @@ parseCmdline = Opt.long "json" , Opt.help "Use JSON instead of Protobuf" ]) + <*> (Opt.switch $ mconcat [ + Opt.long "secure" + , Opt.help "Enable TLS" + ]) + <*> (Opt.switch $ mconcat [ + Opt.long "disable-tcp-nodelay" + , Opt.help "Disable the TCP_NODELAY option" + ]) + <*> (Opt.optional $ + Opt.option Opt.auto $ mconcat [ + Opt.long "ping-rate-limit" + , Opt.metavar "PINGs/sec" + , Opt.help "Allow at most this many pings per second from the peer" + ] + ) parseMode :: Parser Mode parseMode = asum [ diff --git a/kvstore/KVStore/Server.hs b/kvstore/KVStore/Server.hs index ae91c081..9fbcd267 100644 --- a/kvstore/KVStore/Server.hs +++ b/kvstore/KVStore/Server.hs @@ -15,14 +15,42 @@ import KVStore.Cmdline import KVStore.Util.Store (Store) import KVStore.Util.Store qualified as Store +import Paths_grapesy + {------------------------------------------------------------------------------- Server proper -------------------------------------------------------------------------------} withKeyValueServer :: Cmdline -> (RunningServer -> IO ()) -> IO () -withKeyValueServer cmdline@Cmdline{cmdJSON} k = do +withKeyValueServer cmdline@Cmdline{ + cmdJSON + , cmdSecure + , cmdDisableTcpNoDelay + , cmdPingRateLimit + } k = do store <- Store.new + config :: ServerConfig <- + if cmdSecure then do + pub <- getDataFileName "grpc-demo.pem" + priv <- getDataFileName "grpc-demo.key" + return ServerConfig { + serverInsecure = Nothing + , serverSecure = Just $ SecureConfig { + secureHost = "0.0.0.0" + , securePort = defaultSecurePort + , securePubCert = pub + , secureChainCerts = [] + , securePrivKey = priv + , secureSslKeyLog = SslKeyLogFromEnv + } + } + else + return ServerConfig { + serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort + , serverSecure = Nothing + } + let rpcHandlers :: [SomeRpcHandler IO] rpcHandlers | cmdJSON = JSON.server $ handlers cmdline store @@ -31,19 +59,18 @@ withKeyValueServer cmdline@Cmdline{cmdJSON} k = do server <- mkGrpcServer params rpcHandlers forkServer params config server k where - config :: ServerConfig - config = ServerConfig { - serverInsecure = Just $ InsecureConfig Nothing defaultInsecurePort - , serverSecure = Nothing - } - params :: ServerParams params = def { + serverHTTP2Settings = def { + http2TcpNoDelay = not cmdDisableTcpNoDelay + , http2OverridePingRateLimit = cmdPingRateLimit + } + -- The Java benchmark does not use compression (unclear if the Java -- implementation supports compression at all; the compression Interop -- tests are also disabled for Java). For a fair comparison, we -- therefore disable compression here also. - serverCompression = Compr.none + , serverCompression = Compr.none } {------------------------------------------------------------------------------- diff --git a/src/Network/GRPC/Client/Connection.hs b/src/Network/GRPC/Client/Connection.hs index c8832375..1e1aff73 100644 --- a/src/Network/GRPC/Client/Connection.hs +++ b/src/Network/GRPC/Client/Connection.hs @@ -141,6 +141,7 @@ data ConnParams = ConnParams { -- messages sent by the client to the server. , connInitCompression :: Maybe Compression + -- | HTTP2 settings , connHTTP2Settings :: HTTP2Settings } @@ -512,8 +513,11 @@ stayConnected connParams server connStateVar connOutOfScope = -- | Insecure connection (no TLS) connectInsecure :: ConnParams -> Attempt -> Address -> IO () -connectInsecure connParams attempt addr = - runTCPClient addr $ \sock -> do +connectInsecure connParams attempt addr = do + Run.runTCPClientWithSettings + runSettings + (addressHost addr) + (show $ addressPort addr) $ \sock -> bracket (HTTP2.Client.allocSimpleConfig sock writeBufferSize) HTTP2.Client.freeSimpleConfig $ \conf -> HTTP2.Client.run clientConfig conf $ \sendRequest _aux -> do @@ -523,15 +527,23 @@ connectInsecure connParams attempt addr = ConnectionReady (attemptClosed attempt) conn takeMVar $ attemptOutOfScope attempt where + ConnParams{connHTTP2Settings} = connParams + + runSettings :: Run.Settings + runSettings = Run.defaultSettings { + Run.settingsOpenClientSocket = openClientSocket connHTTP2Settings + } + settings :: HTTP2.Client.Settings settings = HTTP2.Client.defaultSettings { HTTP2.Client.maxConcurrentStreams = Just . fromIntegral $ - http2MaxConcurrentStreams (connHTTP2Settings connParams) + http2MaxConcurrentStreams connHTTP2Settings , HTTP2.Client.initialWindowSize = fromIntegral $ - http2StreamWindowSize (connHTTP2Settings connParams) + http2StreamWindowSize connHTTP2Settings } + clientConfig :: HTTP2.Client.ClientConfig clientConfig = overridePingRateLimit connParams $ HTTP2.Client.defaultClientConfig { @@ -539,7 +551,7 @@ connectInsecure connParams attempt addr = , HTTP2.Client.settings = settings , HTTP2.Client.connectionWindowSize = fromIntegral $ - http2ConnectionWindowSize (connHTTP2Settings connParams) + http2ConnectionWindowSize connHTTP2Settings } -- | Secure connection (using TLS) @@ -560,19 +572,19 @@ connectSecure connParams attempt validation sslKeyLog addr = do case validation of ValidateServer _ -> True NoServerValidation -> False - , 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) + , HTTP2.TLS.Client.settingsCAStore = caStore + , HTTP2.TLS.Client.settingsKeyLogger = keyLogger + , HTTP2.TLS.Client.settingsAddrInfoFlags = [] + + , HTTP2.TLS.Client.settingsOpenClientSocket = + openClientSocket connHTTP2Settings + , HTTP2.TLS.Client.settingsConcurrentStreams = fromIntegral $ + http2MaxConcurrentStreams connHTTP2Settings + , HTTP2.TLS.Client.settingsStreamWindowSize = fromIntegral $ + http2StreamWindowSize connHTTP2Settings + , HTTP2.TLS.Client.settingsConnectionWindowSize = fromIntegral $ + http2ConnectionWindowSize connHTTP2Settings } clientConfig :: HTTP2.Client.ClientConfig @@ -592,6 +604,8 @@ connectSecure connParams attempt validation sslKeyLog addr = do writeTVar (attemptState attempt) $ ConnectionReady (attemptClosed attempt) conn takeMVar $ attemptOutOfScope attempt + where + ConnParams{connHTTP2Settings} = connParams -- | Authority -- @@ -624,9 +638,16 @@ overridePingRateLimit connParams clientConfig = clientConfig { Auxiliary http2 -------------------------------------------------------------------------------} -runTCPClient :: Address -> (Socket -> IO a) -> IO a -runTCPClient Address{addressHost, addressPort} = - Run.runTCPClient addressHost (show addressPort) +openClientSocket :: HTTP2Settings -> AddrInfo -> IO Socket +openClientSocket http2Settings = + Run.openClientSocketWithOptions socketOptions + where + socketOptions :: [(SocketOption, Int)] + socketOptions = concat [ + [ (NoDelay, 1) + | http2TcpNoDelay http2Settings + ] + ] -- | Write-buffer size -- diff --git a/src/Network/GRPC/Common/HTTP2Settings.hs b/src/Network/GRPC/Common/HTTP2Settings.hs index b08245c0..76e92119 100644 --- a/src/Network/GRPC/Common/HTTP2Settings.hs +++ b/src/Network/GRPC/Common/HTTP2Settings.hs @@ -56,6 +56,37 @@ data HTTP2Settings = HTTP2Settings { -- connecting to a peer that you trust, you can set this limit to -- 'maxBound' (effectively turning off protecting against ping flooding). , http2OverridePingRateLimit :: Maybe Int + + -- | Enable @TCP_NODELAY@ + -- + -- Send out TCP segments as soon as possible, even if there is only a + -- small amount of data. + -- + -- When @TCP_NODELAY@ is /NOT/ set, the TCP implementation will wait to + -- send a TCP segment to the receiving peer until either (1) there is + -- enough data to fill a certain minimum segment size or (2) we receive an + -- ACK from the receiving peer for data we sent previously. This adds a + -- network roundtrip delay to every RPC message we want to send (to + -- receive the ACK). If the peer uses TCP delayed acknowledgement, which + -- will typically be the case, then this delay will increase further + -- still; default for delayed acknowledgement is 40ms, thus resulting in a + -- theoretical maximum of 25 RPCs/sec. + -- + -- We therefore enable TCP_NODELAY by default, so that data is sent to the + -- peer as soon as we have an entire gRPC message serialized and ready to + -- send (we send the data to the TCP layer only once an entire message is + -- written, or the @http2@ write buffer is full). + -- + -- Turning this off /could/ improve throughput, as fewer TCP segments will + -- be needed, but you probably only want to do this if you send very few + -- very large RPC messages. In gRPC this is anyway discouraged, because + -- gRPC messages do not support incremental (de)serialization; if you need + -- to send large amounts of data, it is preferable to split these into + -- many, smaller, gRPC messages; this also gives the application the + -- possibility of reporting on data transmission progress. + -- + -- TL;DR: leave this at the default unless you know what you are doing. + , http2TcpNoDelay :: Bool } deriving (Show) @@ -82,6 +113,7 @@ defaultHTTP2Settings = HTTP2Settings { , http2StreamWindowSize = defInitialStreamWindowSize , http2ConnectionWindowSize = defMaxConcurrentStreams * defInitialStreamWindowSize , http2OverridePingRateLimit = Nothing + , http2TcpNoDelay = True } where defMaxConcurrentStreams = 128 diff --git a/src/Network/GRPC/Server/Run.hs b/src/Network/GRPC/Server/Run.hs index ce7f7a6f..1948ce4b 100644 --- a/src/Network/GRPC/Server/Run.hs +++ b/src/Network/GRPC/Server/Run.hs @@ -1,5 +1,4 @@ -{-# LANGUAGE CPP #-} -#include "MachDeps.h" +{-# LANGUAGE OverloadedStrings #-} -- | Convenience functions for running a HTTP2 server -- @@ -29,8 +28,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 Control.Monad import Network.HTTP2.Server qualified as HTTP2 import Network.HTTP2.TLS.Server qualified as HTTP2.TLS import Network.Run.TCP qualified as Run @@ -39,7 +37,7 @@ 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.HTTP2 import Network.GRPC.Util.TLS (SslKeyLog(..)) import Network.GRPC.Util.TLS qualified as Util.TLS @@ -290,14 +288,18 @@ runInsecure :: -> TMVar Socket -> HTTP2.Server -> IO () -runInsecure params cfg socketTMVar server = - Run.runTCPServerWithSocket - (openServerSocket socketTMVar) +runInsecure params cfg socketTMVar server = do + withServerSocket + serverHTTP2Settings + socketTMVar (insecureHost cfg) - (show $ insecurePort cfg) $ \sock -> do - bracket (allocConfigWithTimeout sock writeBufferSize disableTimeout) - HTTP2.freeSimpleConfig $ \config -> - HTTP2.run serverConfig config server + (insecurePort cfg) $ \listenSock -> do + Run.runTCPServerWithSocket listenSock $ \clientSock -> do + when (http2TcpNoDelay serverHTTP2Settings) $ + -- See description of 'withServerSocket' + setSockOpt clientSock NoDelay True + withConfigForInsecure clientSock $ \config -> + HTTP2.run serverConfig config server where ServerParams{ serverOverrideNumberOfWorkers @@ -305,23 +307,10 @@ runInsecure params cfg socketTMVar server = } = 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 - } - } + serverConfig = + mkServerConfig + serverHTTP2Settings + serverOverrideNumberOfWorkers {------------------------------------------------------------------------------- Secure (over TLS) @@ -344,32 +333,34 @@ runSecure params cfg socketTMVar server = do Right res -> return res keyLogger <- Util.TLS.keyLogger (secureSslKeyLog cfg) - let settings :: HTTP2.TLS.Settings - settings = HTTP2.TLS.defaultSettings { - HTTP2.TLS.settingsKeyLogger = - keyLogger - , HTTP2.TLS.settingsOpenServerSocket = - 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 - settings - (TLS.Credentials [cred]) - (secureHost cfg) - (securePort cfg) - server + let serverConfig :: HTTP2.ServerConfig + serverConfig = + mkServerConfig + serverHTTP2Settings + serverOverrideNumberOfWorkers + + tlsSettings :: HTTP2.TLS.Settings + tlsSettings = + mkTlsSettings + serverHTTP2Settings + serverOverrideNumberOfWorkers + keyLogger + + withServerSocket + serverHTTP2Settings + socketTMVar + (Just $ secureHost cfg) + (securePort cfg) $ \listenSock -> + HTTP2.TLS.runTLSWithSocket + tlsSettings + (TLS.Credentials [cred]) + listenSock + "h2" $ \mgr backend -> do + when (http2TcpNoDelay serverHTTP2Settings) $ + -- See description of 'withServerSocket' + setSockOpt (HTTP2.TLS.requestSock backend) NoDelay True + withConfigForSecure mgr backend $ \config -> + HTTP2.run serverConfig config server where ServerParams{ serverOverrideNumberOfWorkers @@ -386,33 +377,51 @@ data CouldNotLoadCredentials = Internal auxiliary -------------------------------------------------------------------------------} --- | Work around the fact that we cannot disable timeouts in http2/http2-tls +-- | Create server listen socket +-- +-- We set @TCP_NODELAY@ on the server listen socket, but there is no guarantee +-- that the option will be inherited by the sockets returned from @accept@ for +-- each client request. On Linux it seems to be, although I cannot find any +-- authoritative reference to say so; the best I could find is a section in Unix +-- Network Programming [1]. On FreeBSD on the other hand, the man page suggests +-- that @TCP_NODELAY@ is /not/ inherited [2]. +-- +-- Even the Linux man page for @accept@ is maddingly vague: +-- +-- > Portable programs should not rely on inheritance or non‐inheritance of file +-- > status flags and always explicitly set all required flags on the socket +-- > returned from accept(). +-- +-- Whether that /file status/ flags is significant (as opposed to other kinds of +-- flags?) is unclear, especially in the second half of this sentence. The Linux +-- man page on @tcp@ is even worse; this is the only mention of inheritance in +-- entire page: -- --- TODO: --- We need a proper solution for this. -disableTimeout :: Int -disableTimeout = -#if (WORD_SIZE_IN_BITS == 64) - -- Set a really high timeout to effectively disable timeouts - -- - -- We cannot use `maxBound` here, because this is value in - -- seconds which will be multiplied by 1_000_000 to get a value - -- in microseconds; `maxBound` would result in overflow. - 1000000000 -- roughly 30 years -#else -#warning "Timeout for RPC messages is set to 30 minutes on 32-bit systems." -#warning "See https://github.com/kazu-yamamoto/http2/issues/112" - -- Unfortunately, the same trick does not work on 32-bit - -- systems, where we simply don't have enough range. The - -- maximum timeout we can support here is 30 mins. - 30 * 60 -#endif - -openServerSocket :: TMVar Socket -> AddrInfo -> IO Socket -openServerSocket socketTMVar addr = do - sock <- Run.openServerSocket addr - atomically $ putTMVar socketTMVar sock - return sock - -writeBufferSize :: BufferSize -writeBufferSize = 4096 +-- > [TCP_USER_TIMEOUT], like many others, will be inherited by the socket +-- > returned by accept(2), if it was set on the listening socket. +-- +-- It is therefore best to explicitly set @TCP_NODELAY@ on the client request +-- socket. +-- +-- [1] +-- [2] +withServerSocket :: + HTTP2Settings + -> TMVar Socket + -> Maybe HostName + -> PortNumber + -> (Socket -> IO a) + -> IO a +withServerSocket http2Settings socketTMVar host port k = do + addr <- Run.resolve Stream host (show port) [AI_PASSIVE] + bracket (openServerSocket addr) close $ \sock -> do + atomically $ putTMVar socketTMVar sock + k sock + where + openServerSocket :: AddrInfo -> IO Socket + openServerSocket = Run.openTCPServerSocketWithOptions $ concat [ + [ (NoDelay, 1) + | http2TcpNoDelay http2Settings + ] + ] + diff --git a/util/Network/GRPC/Util/HTTP2.hs b/util/Network/GRPC/Util/HTTP2.hs index 22354006..7001aa7c 100644 --- a/util/Network/GRPC/Util/HTTP2.hs +++ b/util/Network/GRPC/Util/HTTP2.hs @@ -1,18 +1,38 @@ +{-# LANGUAGE CPP #-} + +#include "MachDeps.h" + module Network.GRPC.Util.HTTP2 ( -- * General auxiliary fromHeaderTable -- * Configuration - , allocConfigWithTimeout + , withConfigForInsecure + , withConfigForSecure + -- * Settings + , mkServerConfig + , mkTlsSettings ) where +import Control.Exception import Data.Bifunctor +import Data.ByteString qualified as Strict (ByteString) +import Data.Maybe (fromMaybe) +import Foreign (mallocBytes, free) import Network.HPACK (BufferSize) import Network.HPACK qualified as HPACK import Network.HPACK.Token qualified as HPACK import Network.HTTP.Types qualified as HTTP import Network.HTTP2.Server qualified as Server -import Network.Socket -import System.TimeManager qualified as TimeoutManager +import Network.HTTP2.TLS.Server qualified as Server.TLS +import Network.Socket (Socket, SockAddr) +import Network.Socket qualified as Socket +import Network.Socket.BufferPool (Recv) +import Network.Socket.BufferPool qualified as Recv +import Network.Socket.ByteString qualified as Socket +import System.TimeManager qualified as Time (Manager) +import System.TimeManager qualified as TimeManager + +import Network.GRPC.Common.HTTP2Settings {------------------------------------------------------------------------------- General auxiliary @@ -25,13 +45,169 @@ fromHeaderTable = map (first HPACK.tokenKey) . fst Configuration -------------------------------------------------------------------------------} --- | Adaptation of 'allocSimpleConfig' that allows to specify a timeout -allocConfigWithTimeout :: Socket -> BufferSize -> Int -> IO Server.Config -allocConfigWithTimeout sock confBufferSize timeout = do - -- Since 'allocSimpleConfig' calls some functions that are not exported, - -- we use it as-is, and then throw away the 'TimeManager' it created and - -- override it with our own. We can only do this because none of the other - -- values in this record depend on the time manager. - config <- Server.allocSimpleConfig sock confBufferSize - timeoutManager <- TimeoutManager.initialize $ timeout * 1_000_000 - return config{Server.confTimeoutManager = timeoutManager} +-- | Create config to be used with @http2@ (without TLS) +-- +-- We do not use @allocSimpleConfig@ from @http2:Network.HTTP2.Server@, but +-- instead create a config that is very similar to the config created by +-- 'allocConfigForSecure'. +withConfigForInsecure :: + Socket + -> (Server.Config -> IO a) + -> IO a +withConfigForInsecure sock k = + TimeManager.withManager (disableTimeout * 1_000_000) $ \mgr -> do + -- @recv@ does not provide a way to deallocate a buffer pool, and + -- @http2-tls@ (in @freeServerConfig@) does not attempt to deallocate it. + -- We follow suit here. + pool <- Recv.newBufferPool readBufferLowerLimit readBufferSize + mysa <- Socket.getSocketName sock + peersa <- Socket.getPeerName sock + withConfig + mgr + (Socket.sendAll sock) + (Recv.receive sock pool) + mysa + peersa + k + where + def :: Server.TLS.Settings + def = Server.TLS.defaultSettings + + -- Use the defaults from @http2-tls@ + readBufferLowerLimit, readBufferSize :: Int + readBufferLowerLimit = Server.TLS.settingsReadBufferLowerLimit def + readBufferSize = Server.TLS.settingsReadBufferSize def + +-- | Create config to be used with @http2-tls@ (with TLS) +-- +-- This is adapted from @allocConfigForServer@ in +-- @http2-tls:Network.HTTP2.TLS.Config@. +withConfigForSecure :: + Time.Manager + -> Server.TLS.IOBackend + -> (Server.Config -> IO a) + -> IO a +withConfigForSecure mgr backend = + withConfig + mgr + (Server.TLS.send backend) + (Server.TLS.recv backend) + (Server.TLS.mySockAddr backend) + (Server.TLS.peerSockAddr backend) + +-- | Internal generalization +withConfig :: + Time.Manager + -> (Strict.ByteString -> IO ()) + -> Recv + -> SockAddr + -> SockAddr + -> (Server.Config -> IO a) + -> IO a +withConfig mgr send recv mysa peersa k = + bracket (mallocBytes writeBufferSize) free $ \buf -> do + recvN <- Recv.makeRecvN mempty recv + k Server.Config { + confWriteBuffer = buf + , confBufferSize = writeBufferSize + , confSendAll = send + , confReadN = recvN + , confPositionReadMaker = Server.defaultPositionReadMaker + , confTimeoutManager = mgr + , confMySockAddr = mysa + , confPeerSockAddr = peersa + } + where + -- This is the default value for @settingsSendBufferSize@ in @http2-tls@ + -- and the default value given in the documentation in @http2@. + writeBufferSize :: BufferSize + writeBufferSize = 4096 + +{------------------------------------------------------------------------------- + Settings + + NOTE: If we want to override 'HTTP2.TLS.settingsReadBufferLowerLimit' or + 'HTTP2.TLS.settingsReadBufferSize', we should also modify + 'allocConfigForInsecure'. +-------------------------------------------------------------------------------} + +mkServerConfig :: + HTTP2Settings + -> Maybe Word -- ^ Override number of workers + -> Server.ServerConfig +mkServerConfig http2Settings numberOfWorkers = + Server.defaultServerConfig { + Server.numberOfWorkers = + fromMaybe + (Server.numberOfWorkers Server.defaultServerConfig) + (fromIntegral <$> numberOfWorkers) + , Server.connectionWindowSize = fromIntegral $ + http2ConnectionWindowSize http2Settings + , Server.settings = Server.defaultSettings { + Server.initialWindowSize = fromIntegral $ + http2StreamWindowSize http2Settings + , Server.maxConcurrentStreams = Just . fromIntegral $ + http2MaxConcurrentStreams http2Settings +-- , Server.pingRateLimit = +-- fromMaybe +-- (Server.pingRateLimit Server.defaultSettings) +-- (http2OverridePingRateLimit http2Settings) + } + } + +-- | Settings for secure server (with TLS) +-- +-- NOTE: This overlaps with the values in 'mkServerConfig', and I /think/ we don't +-- actually need this, because we don't use @runWithSocket@ from @http2-tls@ +-- (but rather @runTLSWithSocket@. However, we set them here anyway for +-- completeness and in case @http2-tls@ decides to use them elsewhere. +mkTlsSettings :: + HTTP2Settings + -> Maybe Word -- ^ Override number of workers + -> (String -> IO ()) -- ^ Key logger + -> Server.TLS.Settings +mkTlsSettings http2Settings numberOfWorkers keyLogger = + Server.TLS.defaultSettings { + Server.TLS.settingsKeyLogger = + keyLogger + , Server.TLS.settingsTimeout = + disableTimeout + , Server.TLS.settingsNumberOfWorkers = + fromMaybe + (Server.TLS.settingsNumberOfWorkers Server.TLS.defaultSettings) + (fromIntegral <$> numberOfWorkers) + , Server.TLS.settingsConnectionWindowSize = fromIntegral $ + http2ConnectionWindowSize http2Settings + , Server.TLS.settingsStreamWindowSize = fromIntegral $ + http2StreamWindowSize http2Settings + , Server.TLS.settingsConcurrentStreams = fromIntegral $ + http2MaxConcurrentStreams http2Settings + } + +{------------------------------------------------------------------------------- + Timeouts +-------------------------------------------------------------------------------} + +-- | Work around the fact that we cannot disable timeouts in http2/http2-tls +-- +-- TODO: +-- We need a proper solution for this. +disableTimeout :: Int +disableTimeout = +#if (WORD_SIZE_IN_BITS == 64) + -- Set a really high timeout to effectively disable timeouts (100 years) + -- + -- NOTE: We cannot use 'maxBound' here, because this value is multiplied + -- by @1_000_000@ in 'Network.Run.TCP.Timeout.runTCPServerWithSocket' + -- (in @network-run@). + 100 * 365 * 24 * 60 * 60 +#else +#warning "Timeout for RPC messages is set to 30 minutes on 32-bit systems." +#warning "See https://github.com/kazu-yamamoto/http2/issues/112" + -- Unfortunately, the same trick does not work on 32-bit systems, where we + -- simply don't have enough range. The maximum timeout we can support here + -- is roughly 35 mins. We set it to 30 minutes exactly, to at least provide + -- a clue if the timeout does hit (1_800_000_000 < 2_147_483_647). + 30 * 60 +#endif +