From b9707ea09e882164fc0823bdd38f15ee1b1eb7ae Mon Sep 17 00:00:00 2001
From: Paolo Capriotti <paolo@capriotti.io>
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 <paolo@capriotti.io>
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