Make sure connection preface is always sent first

Network/HTTP2/Client/Run.hs

@@ -3,6 +3,7 @@
 
 module Network.HTTP2.Client.Run where
 
+import Control.Concurrent.Async
 import Control.Concurrent
 import qualified Control.Exception as E
 import Data.IORef (writeIORef)
@@ -24,15 +25,15 @@ run ClientConfig{..} conf@Config{..} client = do
     clientInfo <- newClientInfo scheme authority cacheLimit
     ctx <- newContext clientInfo
     mgr <- start confTimeoutManager
-    tid0 <- forkIO $ frameReceiver ctx confReadN
-    -- fixme: if frameSender is terminated but the main thread is alive,
-    --        what will happen?
-    tid1 <- forkIO $ frameSender ctx conf mgr
+    let runBackgroundThreads = do
+            race_
+                (frameReceiver ctx confReadN)
+                (frameSender ctx conf mgr)
+            E.throwIO (ConnectionError ProtocolError "connection terminated")
     exchangeSettings conf ctx
-    client (sendRequest ctx scheme authority) `E.finally` do
-        stop mgr
-        killThread tid0
-        killThread tid1
+    fmap (either id id) $
+        race runBackgroundThreads (client (sendRequest ctx scheme authority))
+            `E.finally` stop mgr
 
 sendRequest :: Context -> Scheme -> Authority -> Request -> (Response -> IO a) -> IO a
 sendRequest ctx@Context{..} scheme auth (Request req) processResponse = do

http2.cabal

@@ -119,6 +119,7 @@ Library
                         Network.HTTP2.Server.Worker
   Build-Depends:        base >= 4.9 && < 5
                       , array
+                      , async
                       , bytestring >= 0.10
                       , case-insensitive
                       , containers >= 0.5
@@ -169,6 +170,7 @@ Test-Suite spec
                       , hspec >= 1.3
                       , http-types
                       , http2
+                      , network
                       , network-run >= 0.1.0
                       , typed-process
   Default-Extensions:   Strict StrictData

test/HTTP2/ServerSpec.hs

@@ -13,13 +13,17 @@ import qualified Data.ByteString as B
 import Data.ByteString.Builder (byteString)
 import Data.ByteString.Char8
 import qualified Data.ByteString.Char8 as C8
+import Data.IORef
 import Network.HTTP.Types
 import Network.Run.TCP
+import Network.Socket
+import Network.Socket.ByteString
 import Test.Hspec
 
 import Network.HPACK
 import qualified Network.HTTP2.Client as C
 import Network.HTTP2.Server
+import Network.HTTP2.Frame
 
 port :: String
 port = "8080"
@@ -33,7 +37,14 @@ spec = do
         it "handles normal cases" $
             E.bracket (forkIO runServer) killThread $ \_ -> do
                 threadDelay 10000
-                runClient
+                (runClient allocSimpleConfig)
+        it "should always send the connection preface first" $ do
+            prefaceVar <- newEmptyMVar
+            E.bracket (forkIO (runFakeServer prefaceVar)) killThread $ \_ -> do
+                threadDelay 10000
+                (runClient allocSlowPrefaceConfig)
+            preface <- takeMVar prefaceVar
+            preface `shouldBe` connectionPreface
 
 runServer :: IO ()
 runServer = runTCPServer (Just host) port runHTTP2Server
@@ -42,6 +53,27 @@ runServer = runTCPServer (Just host) port runHTTP2Server
                                  freeSimpleConfig
                                  (`run` server)
 
+runFakeServer :: MVar ByteString -> IO ()
+runFakeServer prefaceVar = do
+  runTCPServer (Just host) port $ \s -> do
+    ref <- newIORef Nothing
+
+    -- send settings
+    sendAll s $ "\x00\x00\x12\x04\x00\x00\x00\x00\x00"
+      `mappend` "\x00\x03\x00\x00\x00\x80\x00\x04\x00"
+      `mappend` "\x01\x00\x00\x00\x05\x00\xff\xff\xff"
+
+    -- receive preface
+    value <- defaultReadN s ref (B.length connectionPreface)
+    putMVar prefaceVar value
+
+    -- send goaway frame
+    sendAll s "\x00\x00\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01"
+
+    -- wait for a few ms to make sure the client has a chance to close the
+    -- socket on its end
+    threadDelay 10000
+
 server :: Server
 server req _aux sendResponse = case requestMethod req of
   Just "GET"  -> case requestPath req of
@@ -100,16 +132,31 @@ trailersMaker ctx (Just bs) = return $ NextTrailersMaker $ trailersMaker ctx'
   where
     !ctx' = CH.hashUpdate ctx bs
 
-runClient :: IO ()
-runClient = runTCPClient host port $ runHTTP2Client
+runClient :: (Socket -> BufferSize -> IO Config) -> IO ()
+runClient allocConfig =
+  E.catch (runTCPClient host port $ runHTTP2Client) ignoreHTTP2Error
   where
     authority = C8.pack host
     cliconf = C.ClientConfig "http" authority 20
-    runHTTP2Client s = E.bracket (allocSimpleConfig s 4096)
+    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 ()
+
+-- delay sending preface to be able to test if it is always sent first
+allocSlowPrefaceConfig :: Socket -> BufferSize -> IO Config
+allocSlowPrefaceConfig s size = do
+  config <- allocSimpleConfig s size
+  pure config { confSendAll = slowPrefaceSend (confSendAll config) }
+  where
+    slowPrefaceSend :: (ByteString -> IO ()) -> ByteString -> IO ()
+    slowPrefaceSend orig chunk = do
+      when (C8.pack "PRI" `isPrefixOf` chunk) $ do
+        threadDelay 10000
+      orig chunk
 
 client0 :: C.Client ()
 client0 sendRequest = do