Move early hints into responseEarlyHints field

http-client/Network/HTTP/Client.hs

@@ -184,6 +184,7 @@ module Network.HTTP.Client
     , responseBody
     , responseCookieJar
     , getOriginalRequest
+    , responseEarlyHints
     , throwErrorStatusCodes
       -- ** Response body
     , BodyReader

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

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
+               earlyHeaders <- parseHeadersUntilFailure 0 id
+               nextStatusHeaders >>= \case
+                   Nothing -> return Nothing
+                   Just (StatusHeaders s' v' earlyHeaders' reqHeaders) ->
+                       return $ Just $ StatusHeaders s' v' (earlyHeaders <> earlyHeaders') reqHeaders
+           | otherwise -> (Just <$>) $ StatusHeaders s v mempty A.<$> parseHeaders 0 id
 
     nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)
     nextStatusLine mhl = do
@@ -82,21 +90,34 @@ 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 ->
                         -- Unparseable header line; rather than throwing
                         -- 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

http-client/Network/HTTP/Client/Manager.hs

@@ -259,7 +259,7 @@ mkCreateConnection ms = do
                     , "\r\n"
                     ]
                 parse conn = do
-                    StatusHeaders status _ _ <- parseStatusHeaders (managerMaxHeaderLength ms) conn Nothing Nothing
+                    StatusHeaders status _ _ _ <- parseStatusHeaders (managerMaxHeaderLength ms) conn Nothing Nothing
                     unless (status == status200) $
                         throwHttp $ ProxyConnectException ultHost ultPort status
                 in tlsProxyConnection

http-client/Network/HTTP/Client/Response.hs

@@ -121,7 +121,7 @@ getResponse :: Maybe MaxHeaderLength
             -> IO (Response BodyReader)
 getResponse mhl timeout' req@(Request {..}) mconn cont = do
     let conn = managedResource mconn
-    StatusHeaders s version hs <- parseStatusHeaders mhl conn timeout' cont
+    StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl conn timeout' cont
     let mcl = lookup "content-length" hs >>= readPositiveInt . S8.unpack
         isChunked = ("transfer-encoding", CI.mk "chunked") `elem` map (second CI.mk) hs
 
@@ -162,6 +162,7 @@ getResponse mhl timeout' req@(Request {..}) mconn cont = do
         , responseCookieJar = Data.Monoid.mempty
         , responseClose' = ResponseClose (cleanup False)
         , responseOriginalRequest = req {requestBody = ""}
+        , responseEarlyHints = earlyHs
         }
 
 -- | Does this response have no body?

http-client/Network/HTTP/Client/Types.hs

@@ -90,7 +90,7 @@ data Connection = Connection
     }
     deriving T.Typeable
 
-data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders
+data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders RequestHeaders
     deriving (Show, Eq, Ord, T.Typeable)
 
 -- | A newtype wrapper which is not exported from this library but is an
@@ -715,6 +715,11 @@ data Response body = Response
     -- via @getOriginalRequest@ instead.
     --
     -- Since 0.7.8
+    , responseEarlyHints :: ResponseHeaders
+    -- ^ Early response headers sent by the server, as part of an HTTP
+    -- 103 Early Hints section.
+    --
+    -- Since 0.7.16
     }
     deriving (Show, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable)
 

http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs

@@ -21,7 +21,7 @@ spec = describe "HeadersSpec" $ do
                 ]
         (connection, _, _) <- dummyConnection input
         statusHeaders <- parseStatusHeaders Nothing connection Nothing Nothing
-        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)
+        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty
             [ ("foo", "bar")
             , ("baz", "bin")
             ]
@@ -35,7 +35,7 @@ spec = describe "HeadersSpec" $ do
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
         statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
-        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
+        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ]
         out >>= (`shouldBe` ["data"])
 
     it "Expect: 100-continue (failure)" $ do
@@ -45,7 +45,7 @@ spec = describe "HeadersSpec" $ do
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
         statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
-        statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) []
+        statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] []
         out >>= (`shouldBe` [])
 
     it "100 Continue without expectation is OK" $ do
@@ -57,6 +57,25 @@ spec = describe "HeadersSpec" $ do
                 ]
         (conn, out, inp) <- dummyConnection input
         statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
-        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
+        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>"])

http-conduit/Network/HTTP/Conduit.hs

@@ -179,6 +179,7 @@ module Network.HTTP.Conduit
     , responseHeaders
     , responseBody
     , responseCookieJar
+    , responseEarlyHints
       -- * Manager
     , Manager
     , newManager