Merge pull request #524 from codedownio/103-early-hints-deeper

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 all HTTP 103 Early Hints headers received from the server.
+* Add `earlyHintHeadersReceived` callback to `Request`, which will be called on each HTTP 103 Early Hints header section 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
+    , earlyHintHeadersReceived
       -- ** Request body
     , RequestBody (..)
     , Popper
@@ -184,6 +185,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
@@ -14,20 +16,20 @@ import qualified Data.ByteString.Char8          as S8
 import qualified Data.CaseInsensitive           as CI
 import           Data.Maybe (mapMaybe)
 import           Data.Monoid
+import           Data.Word (Word8)
 import           Network.HTTP.Client.Connection
 import           Network.HTTP.Client.Types
-import           System.Timeout                 (timeout)
 import           Network.HTTP.Types
-import Data.Word (Word8)
+import           System.Timeout                 (timeout)
 
 charSpace, charColon, charPeriod :: Word8
 charSpace = 32
 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' onEarlyHintHeaders cont
     | Just k <- cont = getStatusExpectContinue k
     | otherwise      = getStatus
   where
@@ -45,11 +47,18 @@ 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 <- parseEarlyHintHeadersUntilFailure 0 id
+                 onEarlyHintHeaders earlyHeaders
+                 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 +91,35 @@ 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
 
+    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 ->
+                      parseEarlyHintHeadersUntilFailure (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 (\_ -> 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"
+        , earlyHintHeadersReceived = \_ -> 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 hs <- parseStatusHeaders mhl conn timeout' cont
+    StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl conn timeout' earlyHintHeadersReceived 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
@@ -634,6 +634,11 @@ data Request = Request
     -- ^ List of header values being redacted in case we show Request.
     --
     -- @since 0.7.13
+
+    , earlyHintHeadersReceived :: [Header] -> IO ()
+    -- ^ Called every time an HTTP 103 Early Hints header section is received from the server.
+    --
+    -- @since 0.7.16
     }
     deriving T.Typeable
 
@@ -715,6 +720,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/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,8 +23,8 @@ spec = describe "HeadersSpec" $ do
                 , "\nignored"
                 ]
         (connection, _, _) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders Nothing connection Nothing Nothing
-        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)
+        statusHeaders <- parseStatusHeaders Nothing connection Nothing (\_ -> return ()) Nothing
+        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty
             [ ("foo", "bar")
             , ("baz", "bin")
             ]
@@ -34,8 +37,8 @@ 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 <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody)
+        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ]
         out >>= (`shouldBe` ["data"])
 
     it "Expect: 100-continue (failure)" $ do
@@ -44,8 +47,8 @@ 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 <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody)
+        statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] []
         out >>= (`shouldBe` [])
 
     it "100 Continue without expectation is OK" $ do
@@ -56,7 +59,72 @@ spec = describe "HeadersSpec" $ do
                 , "result"
                 ]
         (conn, out, inp) <- dummyConnection input
-        statusHeaders <- parseStatusHeaders Nothing conn Nothing Nothing
-        statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]
+        statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) Nothing
+        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
+
+        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>")
+                  ]])
+
+    it "103 early hints (multiple sections)" $ 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 103 Early Hints\r\n"
+                , "Link: </baz.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
+
+        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>")
+            , ("Link", "</baz.js>")
+            ]
+            [("Content-Type", "text/html")
+            ]
+
+        inp >>= (`shouldBe` ["<div></div>"])
+
+        readMVar callbackResults
+          >>= (`shouldBe` Seq.fromList [
+                  [("Link", "</foo.js>")
+                  , ("Link", "</bar.js>")
+                  ]
+                  , [("Link", "</baz.js>")]
+                  ])

http-conduit/Network/HTTP/Conduit.hs

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