From fa9a3a0afba71852d9e18b01909b8981ef3d4496 Mon Sep 17 00:00:00 2001
From: Tom McLaughlin <tom@codedown.io>
Date: Tue, 19 Dec 2023 00:40:18 -0800
Subject: [PATCH] Handle HTTP 103 Early Hints

---
 http-client/Network/HTTP/Client/Connection.hs |  6 ++++
 http-client/Network/HTTP/Client/Headers.hs    | 33 +++++++++++++++----
 .../Network/HTTP/Client/HeadersSpec.hs        | 18 ++++++++++
 3 files changed, 51 insertions(+), 6 deletions(-)

diff --git a/http-client/Network/HTTP/Client/Connection.hs b/http-client/Network/HTTP/Client/Connection.hs
index f4c42df7..a57da553 100644
--- a/http-client/Network/HTTP/Client/Connection.hs
+++ b/http-client/Network/HTTP/Client/Connection.hs
@@ -5,6 +5,7 @@ module Network.HTTP.Client.Connection
     ( connectionReadLine
     , connectionReadLineWith
     , connectionDropTillBlankLine
+    , connectionUnreadLine
     , dummyConnection
     , openSocketConnection
     , openSocketConnectionSize
@@ -60,6 +61,11 @@ connectionReadLineWith mhl conn bs0 =
                 unless (S.null y) $! connectionUnread conn y
                 return $! killCR $! S.concat $! front [x]
 
+connectionUnreadLine :: Connection -> ByteString -> IO ()
+connectionUnreadLine conn line = do
+  connectionUnread conn (S.pack [charCR, charLF])
+  connectionUnread conn line
+
 charLF, charCR :: Word8
 charLF = 10
 charCR = 13
diff --git a/http-client/Network/HTTP/Client/Headers.hs b/http-client/Network/HTTP/Client/Headers.hs
index 087653d6..f11452f6 100644
--- a/http-client/Network/HTTP/Client/Headers.hs
+++ b/http-client/Network/HTTP/Client/Headers.hs
@@ -1,4 +1,6 @@
 {-# LANGUAGE DisambiguateRecordFields #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiWayIf #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
 module Network.HTTP.Client.Headers
@@ -45,11 +47,17 @@ parseStatusHeaders mhl conn timeout' cont
             Just  s -> return s
             Nothing -> sendBody >> getStatus
 
+    nextStatusHeaders :: IO (Maybe StatusHeaders)
     nextStatusHeaders = do
         (s, v) <- nextStatusLine mhl
-        if statusCode s == 100
-            then connectionDropTillBlankLine mhl conn >> return Nothing
-            else Just . StatusHeaders s v A.<$> parseHeaders (0 :: Int) id
+        if | statusCode s == 100 -> connectionDropTillBlankLine mhl conn >> return Nothing
+           | statusCode s == 103 -> do
+               linkHeaders <- parseHeadersUntilFailure 0 id
+               nextStatusHeaders >>= \case
+                   Nothing -> return Nothing
+                   Just (StatusHeaders s' v' reqHeaders) ->
+                       return $ Just $ StatusHeaders s' v' (linkHeaders <> reqHeaders)
+           | otherwise -> Just . StatusHeaders s v A.<$> parseHeaders 0 id
 
     nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
     nextStatusLine mhl = do
@@ -82,14 +90,14 @@ parseStatusHeaders mhl conn timeout' cont
             Just (i, "") -> Just i
             _ -> Nothing
 
+    parseHeaders :: Int -> ([Header] -> [Header]) -> IO [Header]
     parseHeaders 100 _ = throwHttp OverlongHeaders
     parseHeaders count front = do
         line <- connectionReadLine mhl conn
         if S.null line
             then return $ front []
-            else do
-                mheader <- parseHeader line
-                case mheader of
+            else
+                parseHeader line >>= \case
                     Just header ->
                         parseHeaders (count + 1) $ front . (header:)
                     Nothing ->
@@ -97,6 +105,19 @@ parseStatusHeaders mhl conn timeout' cont
                         -- an exception, ignore it for robustness.
                         parseHeaders count front
 
+    parseHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header]
+    parseHeadersUntilFailure 100 _ = throwHttp OverlongHeaders
+    parseHeadersUntilFailure count front = do
+        line <- connectionReadLine mhl conn
+        if S.null line
+            then return $ front []
+            else
+                parseHeader line >>= \case
+                    Just header -> parseHeadersUntilFailure (count + 1) $ front . (header:)
+                    Nothing -> do
+                      connectionUnreadLine conn line
+                      return $ front []
+
     parseHeader :: S.ByteString -> IO (Maybe Header)
     parseHeader bs = do
         let (key, bs2) = S.break (== charColon) bs
diff --git a/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs
index 08304b9f..a3284612 100644
--- a/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs
+++ b/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs
@@ -60,3 +60,21 @@ spec = describe "HeadersSpec" $ do
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
         out >>= (`shouldBe` [])
         inp >>= (`shouldBe` ["result"])
+
+    it "103 early hints" $ do
+        let input =
+                [ "HTTP/1.1 103 Early Hints\r\n"
+                , "Link: </foo.js>\r\n"
+                , "Link: </bar.js>\r\n\r\n"
+                , "HTTP/1.1 200 OK\r\n"
+                , "Content-Type: text/html\r\n\r\n"
+                , "<div></div>"
+                ]
+        (conn, _, inp) <- dummyConnection input
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
+        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [
+          ("Link", "</foo.js>")
+          , ("Link", "</bar.js>")
+          , ("Content-Type", "text/html")
+          ]
+        inp >>= (`shouldBe` ["<div></div>"])