diff --git a/http-client/ChangeLog.md b/http-client/ChangeLog.md index fc45385d..e29dcd5a 100644 --- a/http-client/ChangeLog.md +++ b/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) diff --git a/http-client/Network/HTTP/Client.hs b/http-client/Network/HTTP/Client.hs index 813c85ca..ab1b8c06 100644 --- a/http-client/Network/HTTP/Client.hs +++ b/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 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..fefe808c 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 @@ -14,11 +16,11 @@ 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 @@ -26,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' 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,14 +91,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 +106,20 @@ parseStatusHeaders mhl conn timeout' cont -- 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 diff --git a/http-client/Network/HTTP/Client/Manager.hs b/http-client/Network/HTTP/Client/Manager.hs index 57462f1e..fc21ac90 100644 --- a/http-client/Network/HTTP/Client/Manager.hs +++ b/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 diff --git a/http-client/Network/HTTP/Client/Request.hs b/http-client/Network/HTTP/Client/Request.hs index f6f3fad2..99f37edd 100644 --- a/http-client/Network/HTTP/Client/Request.hs +++ b/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_' diff --git a/http-client/Network/HTTP/Client/Response.hs b/http-client/Network/HTTP/Client/Response.hs index 242723fc..ceb878ef 100644 --- a/http-client/Network/HTTP/Client/Response.hs +++ b/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? diff --git a/http-client/Network/HTTP/Client/Types.hs b/http-client/Network/HTTP/Client/Types.hs index 7a142cfc..646dac79 100644 --- a/http-client/Network/HTTP/Client/Types.hs +++ b/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) diff --git a/http-client/http-client.cabal b/http-client/http-client.cabal index a6c6bbdb..f8d4f0d4 100644 --- a/http-client/http-client.cabal +++ b/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: . homepage: https://github.com/snoyberg/http-client diff --git a/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs index 08304b9f..0d242d44 100644 --- a/http-client/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/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: \r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "Content-Type: text/html\r\n\r\n" + , "
" + ] + (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", "") + , ("Link", "") + ] + [("Content-Type", "text/html") + ] + + inp >>= (`shouldBe` ["
"]) + + readMVar callbackResults + >>= (`shouldBe` Seq.fromList [ + [("Link", "") + , ("Link", "") + ]]) + + it "103 early hints (multiple sections)" $ do + let input = + [ "HTTP/1.1 103 Early Hints\r\n" + , "Link: \r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 103 Early Hints\r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "Content-Type: text/html\r\n\r\n" + , "
" + ] + (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", "") + , ("Link", "") + , ("Link", "") + ] + [("Content-Type", "text/html") + ] + + inp >>= (`shouldBe` ["
"]) + + readMVar callbackResults + >>= (`shouldBe` Seq.fromList [ + [("Link", "") + , ("Link", "") + ] + , [("Link", "")] + ]) diff --git a/http-conduit/Network/HTTP/Conduit.hs b/http-conduit/Network/HTTP/Conduit.hs index 5f0dc07f..ba6f88db 100644 --- a/http-conduit/Network/HTTP/Conduit.hs +++ b/http-conduit/Network/HTTP/Conduit.hs @@ -179,6 +179,7 @@ module Network.HTTP.Conduit , responseHeaders , responseBody , responseCookieJar + , responseEarlyHints -- * Manager , Manager , newManager