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

@@ -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

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