From b9707ea09e882164fc0823bdd38f15ee1b1eb7ae Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 10 Dec 2021 15:41:41 +0100 Subject: [PATCH 1/2] Only ignore HTTPError in preface test --- test/HTTP2/ServerSpec.hs | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs index a0c3deb7..df8fb4e0 100644 --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -42,10 +42,14 @@ spec = do prefaceVar <- newEmptyMVar E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do threadDelay 10000 - (runClient allocSlowPrefaceConfig) + E.catch (runClient allocSlowPrefaceConfig) ignoreHTTP2Error + preface <- takeMVar prefaceVar preface `shouldBe` connectionPreface +ignoreHTTP2Error :: HTTP2Error -> IO () +ignoreHTTP2Error _ = pure () + runServer :: IO () runServer = runTCPServer (Just host) port runHTTP2Server where @@ -134,7 +138,7 @@ trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx' runClient :: (Socket -> BufferSize -> IO Config) -> IO () runClient allocConfig = - E.catch (runTCPClient host port $ runHTTP2Client) ignoreHTTP2Error + runTCPClient host port $ runHTTP2Client where authority = C8.pack host cliconf = C.ClientConfig "http" authority 20 @@ -143,8 +147,6 @@ runClient allocConfig = (\conf -> C.run cliconf conf client) client sendRequest = mapConcurrently_ ($ sendRequest) clients clients = [client0,client1,client2,client3,client4] - ignoreHTTP2Error :: HTTP2Error -> IO () - ignoreHTTP2Error _ = pure () -- delay sending preface to be able to test if it is always sent first allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config From 948035cd12a78c7d7c254ba6932502b34d0f42ac Mon Sep 17 00:00:00 2001 From: Paolo Capriotti Date: Fri, 10 Dec 2021 15:53:28 +0100 Subject: [PATCH 2/2] Avoid sending empty data frames This fixes an issue with the client when receiving a streaming response from the server. It can happen that too many empty data frames are sent, causing the client to terminate the connection (as a DoS protection). --- Network/HTTP2/Arch/Sender.hs | 6 ++++++ test/HTTP2/ServerSpec.hs | 24 ++++++++++++++++++++++-- 2 files changed, 28 insertions(+), 2 deletions(-) diff --git a/Network/HTTP2/Arch/Sender.hs b/Network/HTTP2/Arch/Sender.hs index 3e1cf322..8dcd098d 100644 --- a/Network/HTTP2/Arch/Sender.hs +++ b/Network/HTTP2/Arch/Sender.hs @@ -272,6 +272,12 @@ frameSender ctx@Context{outputQ,controlQ,connectionWindow,encodeDynamicTable} kvlen <- headerContinue streamNumber ths True off0 sendHeadersIfNecessary $ off0 + frameHeaderLength + kvlen + fillDataHeaderEnqueueNext _ + off 0 (Just next) tlrmkr _ out = do + let out' = out { outputType = ONext next tlrmkr } + enqueueOutput outputQ out' + return off + fillDataHeaderEnqueueNext Stream{streamWindow,streamNumber} off datPayloadLen (Just next) tlrmkr _ out = do let buf = confWriteBuffer `plusPtr` off diff --git a/test/HTTP2/ServerSpec.hs b/test/HTTP2/ServerSpec.hs index df8fb4e0..2a3a170e 100644 --- a/test/HTTP2/ServerSpec.hs +++ b/test/HTTP2/ServerSpec.hs @@ -10,7 +10,7 @@ import Control.Monad import Crypto.Hash (Context, SHA1) -- cryptonite import qualified Crypto.Hash as CH import qualified Data.ByteString as B -import Data.ByteString.Builder (byteString) +import Data.ByteString.Builder (byteString, Builder) import Data.ByteString.Char8 import qualified Data.ByteString.Char8 as C8 import Data.IORef @@ -82,6 +82,7 @@ server :: Server server req _aux sendResponse = case requestMethod req of Just "GET" -> case requestPath req of Just "/" -> sendResponse responseHello [] + Just "/stream" -> sendResponse responseInfinite [] Just "/push" -> do let pp = pushPromise "/push-pp" responsePP 0 sendResponse responseHello [pp] @@ -104,6 +105,15 @@ responsePP = responseBuilder ok200 header body ,("x-push", "True")] body = byteString "Push\n" +responseInfinite :: Response +responseInfinite = responseStreaming ok200 header body + where + header = [("Content-Type", "text/plain")] + body :: (Builder -> IO ()) -> IO () -> IO () + body write flush = do + let go n = write (byteString (C8.pack (show n)) `mappend` "\n") *> flush *> go (succ n) + go (0 :: Int) + response404 :: Response response404 = responseNoBody notFound404 [] @@ -146,7 +156,7 @@ runClient allocConfig = freeSimpleConfig (\conf -> C.run cliconf conf client) client sendRequest = mapConcurrently_ ($ sendRequest) clients - clients = [client0,client1,client2,client3,client4] + clients = [client0,client1,client2,client3,client4,client5] -- delay sending preface to be able to test if it is always sent first allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config @@ -202,5 +212,15 @@ client4 sendRequest = do sendRequest req1 $ \rsp -> do C.responseStatus rsp `shouldBe` Just ok200 +client5 :: C.Client () +client5 sendRequest = do + let req0 = C.requestNoBody methodGet "/stream" [] + sendRequest req0 $ \rsp -> do + C.responseStatus rsp `shouldBe` Just ok200 + let go n | n > 0 = do _ <- C.getResponseBodyChunk rsp + go (pred n) + | otherwise = pure () + go (100 :: Int) + firstTrailerValue :: HeaderTable -> HeaderValue firstTrailerValue = snd . Prelude.head . fst