Merge PR #34

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
@@ -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
@@ -78,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]
@@ -100,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 []
 
@@ -134,17 +148,15 @@ 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
     runHTTP2Client s = E.bracket (allocConfig s 4096)
                                  freeSimpleConfig
                                  (\conf -> C.run cliconf conf client)
     client sendRequest = mapConcurrently_ ($ sendRequest) clients
-    clients = [client0,client1,client2,client3,client4]
-    ignoreHTTP2Error :: HTTP2Error -> IO ()
-    ignoreHTTP2Error _ = pure ()
+    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
@@ -200,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