From a60abcd1959a4bd655c228ebb89e959ef847a4e2 Mon Sep 17 00:00:00 2001 From: Kazu Yamamoto Date: Fri, 10 Nov 2023 11:12:12 +0900 Subject: [PATCH] improving ClientConfig and ServerConfig --- Network/HTTP2/Arch.hs | 2 + Network/HTTP2/Arch/Context.hs | 12 +++--- Network/HTTP2/Arch/Receiver.hs | 19 ++++----- Network/HTTP2/Arch/Sender.hs | 1 + Network/HTTP2/Arch/Settings.hs | 73 ++++++++++++++++++++++++++++++++++ Network/HTTP2/Arch/Window.hs | 48 ---------------------- Network/HTTP2/Client.hs | 7 +++- Network/HTTP2/Client/Run.hs | 32 ++++++++++++--- Network/HTTP2/Server.hs | 9 ++++- Network/HTTP2/Server/Run.hs | 31 +++++++++------ http2.cabal | 1 + test/HTTP2/ClientSpec.hs | 2 +- test/HTTP2/ServerSpec.hs | 8 ++-- util/client.hs | 2 +- 14 files changed, 155 insertions(+), 92 deletions(-) create mode 100644 Network/HTTP2/Arch/Settings.hs diff --git a/Network/HTTP2/Arch.hs b/Network/HTTP2/Arch.hs index af33dedc..2c790ace 100644 --- a/Network/HTTP2/Arch.hs +++ b/Network/HTTP2/Arch.hs @@ -9,6 +9,7 @@ module Network.HTTP2.Arch ( module Network.HTTP2.Arch.ReadN, module Network.HTTP2.Arch.Receiver, module Network.HTTP2.Arch.Sender, + module Network.HTTP2.Arch.Settings, module Network.HTTP2.Arch.Status, module Network.HTTP2.Arch.Stream, module Network.HTTP2.Arch.StreamTable, @@ -26,6 +27,7 @@ import Network.HTTP2.Arch.Queue import Network.HTTP2.Arch.ReadN import Network.HTTP2.Arch.Receiver import Network.HTTP2.Arch.Sender +import Network.HTTP2.Arch.Settings import Network.HTTP2.Arch.Status import Network.HTTP2.Arch.Stream import Network.HTTP2.Arch.StreamTable diff --git a/Network/HTTP2/Arch/Context.hs b/Network/HTTP2/Arch/Context.hs index 226645c7..d4978ce6 100644 --- a/Network/HTTP2/Arch/Context.hs +++ b/Network/HTTP2/Arch/Context.hs @@ -54,8 +54,9 @@ data Context = Context { role :: Role , roleInfo :: RoleInfo , -- Settings - myFirstSettings :: IORef Bool - , myPendingAlist :: IORef (Maybe SettingsList) + mySettingAlist :: SettingsList -- to be myPendingAlist + , myFirstSettings :: IORef Bool + , myPendingAlist :: IORef (Maybe SettingsList) -- to be mySettings , mySettings :: IORef Settings , peerSettings :: IORef Settings , oddStreamTable :: TVar OddStreamTable @@ -88,9 +89,9 @@ data Context = Context ---------------------------------------------------------------- newContext - :: RoleInfo -> Int -> BufferSize -> SockAddr -> SockAddr -> IO Context -newContext rinfo cacheSiz siz mysa peersa = - Context rl rinfo + :: RoleInfo -> Int -> BufferSize -> SockAddr -> SockAddr -> SettingsList -> IO Context +newContext rinfo cacheSiz siz mysa peersa settingAlist = + Context rl rinfo settingAlist <$> newIORef False <*> newIORef Nothing <*> newIORef defaultSettings @@ -269,4 +270,3 @@ openEvenStreamWait ctx@Context{..} = do newstrm <- newEvenStream sid ws insertEven' evenStreamTable sid newstrm return (sid, newstrm) - diff --git a/Network/HTTP2/Arch/Receiver.hs b/Network/HTTP2/Arch/Receiver.hs index f5a85171..a9191a90 100644 --- a/Network/HTTP2/Arch/Receiver.hs +++ b/Network/HTTP2/Arch/Receiver.hs @@ -24,6 +24,7 @@ import Network.HTTP2.Arch.EncodeFrame import Network.HTTP2.Arch.HPACK import Network.HTTP2.Arch.Queue import Network.HTTP2.Arch.Rate +import Network.HTTP2.Arch.Settings import Network.HTTP2.Arch.Stream import Network.HTTP2.Arch.StreamTable import Network.HTTP2.Arch.Types @@ -125,10 +126,10 @@ processFrame ctx@Context{..} conf typhdr@(ftyp, header) = do ---------------------------------------------------------------- controlOrStream :: Context -> Config -> FrameType -> FrameHeader -> IO () -controlOrStream ctx@Context{..} conf@Config{..} ftyp header@FrameHeader{streamId, payloadLength} +controlOrStream ctx@Context{..} Config{..} ftyp header@FrameHeader{streamId, payloadLength} | isControl streamId = do bs <- confReadN payloadLength - control ftyp header bs ctx conf + control ftyp header bs ctx | ftyp == FramePushPromise = do bs <- confReadN payloadLength push header bs ctx @@ -285,8 +286,8 @@ getOddStream ctx ftyp streamId Nothing type Payload = ByteString -control :: FrameType -> FrameHeader -> Payload -> Context -> Config -> IO () -control FrameSettings header@FrameHeader{flags, streamId} bs ctx@Context{myFirstSettings, myPendingAlist, mySettings, controlQ, settingsRate} conf = do +control :: FrameType -> FrameHeader -> Payload -> Context -> IO () +control FrameSettings header@FrameHeader{flags, streamId} bs ctx@Context{myFirstSettings, myPendingAlist, mySettings, controlQ, settingsRate} = do SettingsFrame peerAlist <- guardIt $ decodeSettingsFrame header bs traverse_ E.throwIO $ checkSettingsList peerAlist if testAck flags @@ -314,10 +315,10 @@ control FrameSettings header@FrameHeader{flags, streamId} bs ctx@Context{myFirst enqueueControl controlQ setframe else do -- Server side only - frames <- updateMySettings conf ctx + frames <- pendingMySettings ctx let setframe = CFrames (Just peerAlist) (frames ++ [ack]) enqueueControl controlQ setframe -control FramePing FrameHeader{flags, streamId} bs Context{controlQ, pingRate} _ = +control FramePing FrameHeader{flags, streamId} bs Context{controlQ, pingRate} = unless (testAck flags) $ do -- Ping Flood - CVE-2019-9512 rate <- getRate pingRate @@ -326,15 +327,15 @@ control FramePing FrameHeader{flags, streamId} bs Context{controlQ, pingRate} _ else do let frame = pingFrame bs enqueueControl controlQ $ CFrames Nothing [frame] -control FrameGoAway header bs _ _ = do +control FrameGoAway header bs _ = do GoAwayFrame sid err msg <- guardIt $ decodeGoAwayFrame header bs if err == NoError then E.throwIO ConnectionIsClosed else E.throwIO $ ConnectionErrorIsReceived err sid $ Short.toShort msg -control FrameWindowUpdate header bs ctx _ = do +control FrameWindowUpdate header bs ctx = do WindowUpdateFrame n <- guardIt $ decodeWindowUpdateFrame header bs increaseConnectionWindowSize ctx n -control _ _ _ _ _ = +control _ _ _ _ = -- must not reach here return () diff --git a/Network/HTTP2/Arch/Sender.hs b/Network/HTTP2/Arch/Sender.hs index 59b1a2b2..9d333118 100644 --- a/Network/HTTP2/Arch/Sender.hs +++ b/Network/HTTP2/Arch/Sender.hs @@ -30,6 +30,7 @@ import Network.HTTP2.Arch.File import Network.HTTP2.Arch.HPACK import Network.HTTP2.Arch.Manager hiding (start) import Network.HTTP2.Arch.Queue +import Network.HTTP2.Arch.Settings import Network.HTTP2.Arch.Stream import Network.HTTP2.Arch.Types import Network.HTTP2.Arch.Window diff --git a/Network/HTTP2/Arch/Settings.hs b/Network/HTTP2/Arch/Settings.hs new file mode 100644 index 00000000..32091597 --- /dev/null +++ b/Network/HTTP2/Arch/Settings.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE RecordWildCards #-} + +module Network.HTTP2.Arch.Settings where + +import Data.IORef +import UnliftIO.STM + +import Imports +import Network.HTTP2.Arch.Config +import Network.HTTP2.Arch.Context +import Network.HTTP2.Arch.EncodeFrame +import Network.HTTP2.Arch.StreamTable +import Network.HTTP2.Arch.Types +import Network.HTTP2.Frame + +-- max: 2,147,483,647 (2^31-1) is too large. +-- def: 65,535 (2^16-1) it too small. +-- 1,048,575 (2^20-1) +properWindowSize :: WindowSize +properWindowSize = 1048575 + +properConcurrentStreams :: Int +properConcurrentStreams = 64 + +makeMySettingsList :: Config -> Int -> WindowSize -> [(SettingsKey, Int)] +makeMySettingsList Config{..} maxConc winSiz = myInitialAlist + where + -- confBufferSize is the size of the write buffer. + -- But we assume that the size of the read buffer is the same size. + -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE. + len = confBufferSize - frameHeaderLength + payloadLen = max defaultPayloadLength len + myInitialAlist = + [ (SettingsMaxFrameSize, payloadLen) + , (SettingsMaxConcurrentStreams, maxConc) + , (SettingsInitialWindowSize, winSiz) + ] + +---------------------------------------------------------------- + +pendingMySettings :: Context -> IO [ByteString] +pendingMySettings Context{mySettingAlist, myFirstSettings, myPendingAlist} = do + writeIORef myFirstSettings True + writeIORef myPendingAlist $ Just mySettingAlist + return frames' + where + frame1 = settingsFrame id mySettingAlist + -- Initial window update for connection + frames = case lookup SettingsInitialWindowSize mySettingAlist of + Nothing -> [] + Just winSiz -> [windowUpdateFrame 0 (winSiz - defaultWindowSize)] + frames' = frame1 : frames + +---------------------------------------------------------------- + +-- Peer SETTINGS_INITIAL_WINDOW_SIZE +-- Adjusting initial window size for streams +updatePeerSettings :: Context -> SettingsList -> IO () +updatePeerSettings Context{peerSettings, oddStreamTable} peerAlist = do + oldws <- initialWindowSize <$> readIORef peerSettings + modifyIORef' peerSettings $ \old -> updateSettings old peerAlist + newws <- initialWindowSize <$> readIORef peerSettings + let diff = newws - oldws + when (diff /= 0) $ updateAllOddStreamWindow (+ diff) oddStreamTable + +---------------------------------------------------------------- + +updateAllOddStreamWindow + :: (WindowSize -> WindowSize) -> TVar OddStreamTable -> IO () +updateAllOddStreamWindow adst var = do + strms <- getOddStreams var + forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst diff --git a/Network/HTTP2/Arch/Window.hs b/Network/HTTP2/Arch/Window.hs index 188b1ed3..b7553339 100644 --- a/Network/HTTP2/Arch/Window.hs +++ b/Network/HTTP2/Arch/Window.hs @@ -8,11 +8,9 @@ import qualified UnliftIO.Exception as E import UnliftIO.STM import Imports -import Network.HTTP2.Arch.Config import Network.HTTP2.Arch.Context import Network.HTTP2.Arch.EncodeFrame import Network.HTTP2.Arch.Queue -import Network.HTTP2.Arch.StreamTable import Network.HTTP2.Arch.Types import Network.HTTP2.Frame @@ -82,49 +80,3 @@ informWindowUpdate Context{controlQ, rxConnectionInc} Stream{streamNumber} strea where thresh = defaultWindowSize -- fixme w1 = w0 + len - ----------------------------------------------------------------- - --- max: 2,147,483,647 (2^31-1) is too large. --- def: 65,535 (2^16-1) it too small. --- 1,048,575 (2^20-1) -properWindowSize :: WindowSize -properWindowSize = 1048575 - -updateMySettings :: Config -> Context -> IO [ByteString] -updateMySettings Config{..} Context{myFirstSettings, myPendingAlist} = do - writeIORef myFirstSettings True - writeIORef myPendingAlist $ Just myInitialAlist - return frames - where - len = confBufferSize - frameHeaderLength - payloadLen = max defaultPayloadLength len - myInitialAlist = - -- confBufferSize is the size of the write buffer. - -- But we assume that the size of the read buffer is the same size. - -- So, the size is announced to via SETTINGS_MAX_FRAME_SIZE. - [ (SettingsMaxFrameSize, payloadLen) - , (SettingsMaxConcurrentStreams, recommendedConcurrency) - , -- Initial window size for streams - (SettingsInitialWindowSize, properWindowSize) - ] - frame1 = settingsFrame id myInitialAlist - -- Initial window update for connection - frame2 = windowUpdateFrame 0 (properWindowSize - defaultWindowSize) - frames = [frame1, frame2] - --- Peer SETTINGS_INITIAL_WINDOW_SIZE --- Adjusting initial window size for streams -updatePeerSettings :: Context -> SettingsList -> IO () -updatePeerSettings Context{peerSettings, oddStreamTable} peerAlist = do - oldws <- initialWindowSize <$> readIORef peerSettings - modifyIORef' peerSettings $ \old -> updateSettings old peerAlist - newws <- initialWindowSize <$> readIORef peerSettings - let diff = newws - oldws - when (diff /= 0) $ updateAllOddStreamWindow (+ diff) oddStreamTable - -updateAllOddStreamWindow - :: (WindowSize -> WindowSize) -> TVar OddStreamTable -> IO () -updateAllOddStreamWindow adst var = do - strms <- getOddStreams var - forM_ strms $ \strm -> atomically $ modifyTVar (streamWindow strm) adst diff --git a/Network/HTTP2/Client.hs b/Network/HTTP2/Client.hs index 50ef9141..64dfbec0 100644 --- a/Network/HTTP2/Client.hs +++ b/Network/HTTP2/Client.hs @@ -43,11 +43,14 @@ module Network.HTTP2.Client ( -- * Runner run, + + -- * Client configuration Scheme, Authority, - - -- * Runner arguments ClientConfig (..), + defaultClientConfig, + + -- * Common configuration Config (..), allocSimpleConfig, freeSimpleConfig, diff --git a/Network/HTTP2/Client/Run.hs b/Network/HTTP2/Client/Run.hs index b93d9006..576673b8 100644 --- a/Network/HTTP2/Client/Run.hs +++ b/Network/HTTP2/Client/Run.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} @@ -25,7 +26,25 @@ data ClientConfig = ClientConfig -- ^ Server name , cacheLimit :: Int -- ^ How many pushed responses are contained in the cache - } + , concurrentStreams :: Int + -- ^ The maximum number of incoming streams on the net + , windowSize :: WindowSize + -- ^ The window size of incoming streams + } deriving (Eq, Show) + +-- | The default client config. +-- +-- >>> defaultClientConfig +-- ClientConfig {scheme = "http", authority = "localhost", cacheLimit = 64, concurrentStreams = 64, windowSize = 1048575} +defaultClientConfig :: ClientConfig +defaultClientConfig = + ClientConfig + { scheme = "http" + , authority = "localhost" + , cacheLimit = 64 + , concurrentStreams = properConcurrentStreams + , windowSize = properWindowSize + } -- | Running HTTP/2 client. run :: ClientConfig -> Config -> Client a -> IO a @@ -60,10 +79,11 @@ runIO cconf@ClientConfig{..} conf@Config{..} action = do setup :: ClientConfig -> Config -> IO (Context, Manager) setup ClientConfig{..} conf@Config{..} = do let clientInfo = newClientInfo scheme authority + myAlist = makeMySettingsList conf concurrentStreams windowSize ctx <- - newContext clientInfo cacheLimit confBufferSize confMySockAddr confPeerSockAddr + newContext clientInfo cacheLimit confBufferSize confMySockAddr confPeerSockAddr myAlist mgr <- start confTimeoutManager - exchangeSettings conf ctx + exchangeSettings ctx return (ctx, mgr) runArch :: Config -> Context -> Manager -> IO a -> IO a @@ -157,9 +177,9 @@ sendStreaming Context{..} mgr req sid newstrm strmbdy = do writeTVar outputQStreamID (sid + 2) writeTQueue outputQ $ Output newstrm req OObj (Just tbq) (return ()) -exchangeSettings :: Config -> Context -> IO () -exchangeSettings conf ctx@Context{..} = do - frames <- updateMySettings conf ctx +exchangeSettings :: Context -> IO () +exchangeSettings ctx@Context{..} = do + frames <- pendingMySettings ctx let setframe = CFrames Nothing (connectionPreface : frames) enqueueControl controlQ setframe diff --git a/Network/HTTP2/Server.hs b/Network/HTTP2/Server.hs index a4351320..abae4d7c 100644 --- a/Network/HTTP2/Server.hs +++ b/Network/HTTP2/Server.hs @@ -28,8 +28,13 @@ module Network.HTTP2.Server ( -- * Runner run, + run', - -- * Runner arguments + -- * Client configuration + ServerConfig(..), + defaultServerConfig, + + -- * Common configuration Config (..), allocSimpleConfig, freeSimpleConfig, @@ -107,7 +112,7 @@ import Network.HPACK import Network.HPACK.Token import Network.HTTP2.Arch import Network.HTTP2.Frame.Types -import Network.HTTP2.Server.Run (run) +import Network.HTTP2.Server.Run (run, run', ServerConfig(..), defaultServerConfig) import Network.HTTP2.Server.Types ---------------------------------------------------------------- diff --git a/Network/HTTP2/Server/Run.hs b/Network/HTTP2/Server/Run.hs index f9f92f22..fd8a437b 100644 --- a/Network/HTTP2/Server/Run.hs +++ b/Network/HTTP2/Server/Run.hs @@ -7,30 +7,34 @@ module Network.HTTP2.Server.Run where import Control.Concurrent.STM import Control.Exception import Imports +import Network.Socket (SockAddr) +import UnliftIO.Async (concurrently_) + import Network.HTTP2.Arch import Network.HTTP2.Frame import Network.HTTP2.Server.Types import Network.HTTP2.Server.Worker -import Network.Socket (SockAddr) -import UnliftIO.Async (concurrently_) -- | Server configuration data ServerConfig = ServerConfig { numberOfworkers :: Int -- ^ The number of workers - , maxConcurrency :: Int - } + , concurrentStreams :: Int + -- ^ The maximum number of incoming streams on the net + , windowSize :: WindowSize + -- ^ The window size of incoming streams + } deriving (Eq, Show) --- | The number of workers is 3. --- This was carefully chosen based on a lot of benchmarks. --- If it is 1, we cannot avoid head-of-line blocking. --- If it is large, huge memory is consumed and many --- context switches happen. +-- | The default server config. +-- +-- >>> defaultServerConfig +-- ServerConfig {numberOfworkers = 8, concurrentStreams = 64, windowSize = 1048575} defaultServerConfig :: ServerConfig defaultServerConfig = ServerConfig - { numberOfworkers = 3 - , maxConcurrency = recommendedConcurrency + { numberOfworkers = 8 + , concurrentStreams = properConcurrentStreams + , windowSize = properWindowSize } ---------------------------------------------------------------- @@ -91,9 +95,10 @@ checkPreface conf@Config{..} = do else return True setup :: ServerConfig -> Config -> IO (Context, Manager) -setup _ Config{..} = do +setup ServerConfig{..} conf@Config{..} = do serverInfo <- newServerInfo - ctx <- newContext serverInfo 0 confBufferSize confMySockAddr confPeerSockAddr + let myAlist = makeMySettingsList conf concurrentStreams windowSize + ctx <- newContext serverInfo 0 confBufferSize confMySockAddr confPeerSockAddr myAlist -- Workers, worker manager and timer manager mgr <- start confTimeoutManager return (ctx, mgr) diff --git a/http2.cabal b/http2.cabal index 84693130..a4f93a68 100644 --- a/http2.cabal +++ b/http2.cabal @@ -98,6 +98,7 @@ library Network.HTTP2.Arch.ReadN Network.HTTP2.Arch.Receiver Network.HTTP2.Arch.Sender + Network.HTTP2.Arch.Settings Network.HTTP2.Arch.Status Network.HTTP2.Arch.Stream Network.HTTP2.Arch.StreamTable diff --git a/test/HTTP2/ClientSpec.hs b/test/HTTP2/ClientSpec.hs index 3a211bf6..7825eb5a 100644 --- a/test/HTTP2/ClientSpec.hs +++ b/test/HTTP2/ClientSpec.hs @@ -66,7 +66,7 @@ responseHello = S.responseBuilder ok200 header body runClient :: Scheme -> Authority -> RequestHeaders -> IO () runClient sc au hd = runTCPClient host port $ runHTTP2Client where - cliconf = ClientConfig sc au 20 + cliconf = defaultClientConfig { scheme = sc, authority = au } runHTTP2Client s = E.bracket (allocSimpleConfig s 4096) diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs index 459df89a..1cd1eb99 100644 --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -177,8 +177,8 @@ runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig = runTCPClient host port $ runHTTP2Client where - authority = C8.pack host - cliconf = C.ClientConfig "http" authority 20 + auth = C8.pack host + cliconf = C.defaultClientConfig { C.authority = auth } runHTTP2Client s = E.bracket (allocConfig s 4096) @@ -315,8 +315,8 @@ runAttack :: (C.ClientIO -> IO ()) -> IO () runAttack attack = runTCPClient host port $ runHTTP2Client where - authority = C8.pack host - cliconf = C.ClientConfig "http" authority 20 + auth = C8.pack host + cliconf = C.defaultClientConfig { C.authority = auth } runHTTP2Client s = E.bracket (allocSimpleConfig s 4096) diff --git a/util/client.hs b/util/client.hs index 6499d12f..07ab503c 100644 --- a/util/client.hs +++ b/util/client.hs @@ -26,7 +26,7 @@ main = do exitFailure runTCPClient serverName port $ runHTTP2Client host where - cliconf host = ClientConfig "http" (C8.pack host) 20 + cliconf host = defaultClientConfig { authority = C8.pack host } runHTTP2Client host s = E.bracket (allocSimpleConfig s 4096)