Move early hints into responseEarlyHints field

http-client/ChangeLog.md

@@ -1,5 +1,10 @@
 # Changelog for http-client
 
+## 0.7.16
+
+* Add `responseEarlyHints` field to `Response`, containing a list of HTTP 103 Early Hints headers received from the server.
+* Add `earlyHintHeaderReceived` callback to `Request`, which will be called on each HTTP 103 Early Hints header received.
+
 ## 0.7.15
 
 * Adds `shouldStripHeaderOnRedirectIfOnDifferentHostOnly` option to `Request` [#520](https://github.com/snoyberg/http-client/pull/520)

http-client/Network/HTTP/Client.hs

@@ -168,6 +168,7 @@ module Network.HTTP.Client
     , cookieJar
     , requestVersion
     , redactHeaders
+    , earlyHintHeaderReceived
       -- ** Request body
     , RequestBody (..)
     , Popper

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

@@ -28,8 +28,8 @@ charColon = 58
 charPeriod = 46
 
 
-parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders
-parseStatusHeaders mhl conn timeout' cont
+parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> (Header -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders
+parseStatusHeaders mhl conn timeout' onEarlyHintHeader cont
     | Just k <- cont = getStatusExpectContinue k
     | otherwise      = getStatus
   where
@@ -52,7 +52,7 @@ parseStatusHeaders mhl conn timeout' cont
         (s, v) <- nextStatusLine mhl
         if | statusCode s == 100 -> connectionDropTillBlankLine mhl conn >> return Nothing
            | statusCode s == 103 -> do
-               earlyHeaders <- parseHeadersUntilFailure 0 id
+               earlyHeaders <- parseEarlyHintHeadersUntilFailure 0 id
                nextStatusHeaders >>= \case
                    Nothing -> return Nothing
                    Just (StatusHeaders s' v' earlyHeaders' reqHeaders) ->
@@ -105,15 +105,17 @@ 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
+    parseEarlyHintHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header]
+    parseEarlyHintHeadersUntilFailure 100 _ = throwHttp OverlongHeaders
+    parseEarlyHintHeadersUntilFailure 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:)
+                    Just header -> do
+                      onEarlyHintHeader header
+                      parseEarlyHintHeadersUntilFailure (count + 1) $ front . (header:)
                     Nothing -> do
                       connectionUnreadLine conn line
                       return $ front []

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 (\_ -> return ()) Nothing
                     unless (status == status200) $
                         throwHttp $ ProxyConnectException ultHost ultPort status
                 in tlsProxyConnection

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

@@ -306,6 +306,7 @@ defaultRequest = Request
         , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False
         , proxySecureMode = ProxySecureWithConnect
         , redactHeaders = Set.singleton "Authorization"
+        , earlyHintHeaderReceived = \_ -> return ()
         }
 
 -- | Parses a URL via 'parseRequest_'

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 earlyHs hs <- parseStatusHeaders mhl conn timeout' cont
+    StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl conn timeout' earlyHintHeaderReceived cont
     let mcl = lookup "content-length" hs >>= readPositiveInt . S8.unpack
         isChunked = ("transfer-encoding", CI.mk "chunked") `elem` map (second CI.mk) hs
 

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

@@ -634,6 +634,11 @@ data Request = Request
     -- ^ List of header values being redacted in case we show Request.
     --
     -- @since 0.7.13
+
+    , earlyHintHeaderReceived :: Header -> IO ()
+    -- ^ Called every time an HTTP 103 Early Hints header is received from the server.
+    --
+    -- @since 0.7.16
     }
     deriving T.Typeable
 

http-client/http-client.cabal

@@ -1,5 +1,5 @@
 name:                http-client
-version:             0.7.15
+version:             0.7.16
 synopsis:            An HTTP client engine
 description:         Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>.
 homepage:            https://github.com/snoyberg/http-client

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

@@ -1,6 +1,9 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 module Network.HTTP.Client.HeadersSpec where
 
+import           Control.Concurrent.MVar
+import qualified Data.Sequence as Seq
 import           Network.HTTP.Client.Internal
 import           Network.HTTP.Types
 import           Test.Hspec
@@ -20,7 +23,7 @@ spec = describe "HeadersSpec" $ do
                 , "\nignored"
                 ]
         (connection, _, _) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders Nothing connection Nothing Nothing
+        statusHeaders <- parseStatusHeaders Nothing connection Nothing (\_ -> return ()) Nothing
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty
             [ ("foo", "bar")
             , ("baz", "bin")
@@ -34,7 +37,7 @@ spec = describe "HeadersSpec" $ do
                 ]
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
-        statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody)
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ]
         out >>= (`shouldBe` ["data"])
 
@@ -44,7 +47,7 @@ spec = describe "HeadersSpec" $ do
                 ]
         (conn, out, _) <- dummyConnection input
         let sendBody = connectionWrite conn "data"
-        statusHeaders <- parseStatusHeaders Nothing conn Nothing (Just sendBody)
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody)
         statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] []
         out >>= (`shouldBe` [])
 
@@ -56,7 +59,7 @@ spec = describe "HeadersSpec" $ do
                 , "result"
                 ]
         (conn, out, inp) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) Nothing
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ]
         out >>= (`shouldBe` [])
         inp >>= (`shouldBe` ["result"])
@@ -71,11 +74,24 @@ spec = describe "HeadersSpec" $ do
                 , "<div></div>"
                 ]
         (conn, _, inp) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
+
+        callbackResults :: MVar (Seq.Seq Header) <- newMVar mempty
+        let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h))
+
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing onEarlyHintHeader Nothing
         statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)
             [("Link", "</foo.js>")
             , ("Link", "</bar.js>")
             ]
             [("Content-Type", "text/html")
             ]
+
         inp >>= (`shouldBe` ["<div></div>"])
+
+        readMVar callbackResults
+          >>= ( `shouldBe`
+                  Seq.fromList
+                    [ ("Link", "</foo.js>"),
+                      ("Link", "</bar.js>")
+                    ]
+              )