http-client 0.7.15 → 0.7.16
raw patch · 10 files changed
+139/−23 lines, 10 files
Files
- ChangeLog.md +5/−0
- Network/HTTP/Client.hs +3/−1
- Network/HTTP/Client/Connection.hs +6/−0
- Network/HTTP/Client/Headers.hs +33/−10
- Network/HTTP/Client/Manager.hs +1/−1
- Network/HTTP/Client/Request.hs +1/−0
- Network/HTTP/Client/Response.hs +2/−1
- Network/HTTP/Client/Types.hs +11/−1
- http-client.cabal +1/−1
- test-nonet/Network/HTTP/Client/HeadersSpec.hs +76/−8
ChangeLog.md view
@@ -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)
Network/HTTP/Client.hs view
@@ -11,7 +11,7 @@ -- support for things like JSON request and response bodies. For most users, -- this will be an easier place to start. You can read the tutorial at: ----- https://haskell-lang.org/library/http-client+-- https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md -- -- = Lower-level API --@@ -168,6 +168,7 @@ , cookieJar , requestVersion , redactHeaders+ , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper@@ -184,6 +185,7 @@ , responseBody , responseCookieJar , getOriginalRequest+ , responseEarlyHints , throwErrorStatusCodes -- ** Response body , BodyReader
Network/HTTP/Client/Connection.hs view
@@ -5,6 +5,7 @@ ( connectionReadLine , connectionReadLineWith , connectionDropTillBlankLine+ , connectionUnreadLine , dummyConnection , openSocketConnection , openSocketConnectionSize@@ -59,6 +60,11 @@ (x, S.drop 1 -> y) -> do 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
Network/HTTP/Client/Headers.hs view
@@ -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.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 @@ 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 @@ 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,20 +91,34 @@ 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
Network/HTTP/Client/Manager.hs view
@@ -259,7 +259,7 @@ , "\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
Network/HTTP/Client/Request.hs view
@@ -306,6 +306,7 @@ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False , proxySecureMode = ProxySecureWithConnect , redactHeaders = Set.singleton "Authorization"+ , earlyHintHeadersReceived = \_ -> return () } -- | Parses a URL via 'parseRequest_'
Network/HTTP/Client/Response.hs view
@@ -121,7 +121,7 @@ -> 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 @@ , responseCookieJar = Data.Monoid.mempty , responseClose' = ResponseClose (cleanup False) , responseOriginalRequest = req {requestBody = ""}+ , responseEarlyHints = earlyHs } -- | Does this response have no body?
Network/HTTP/Client/Types.hs view
@@ -90,7 +90,7 @@ } 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 @@ -- ^ 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 @@ -- 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.cabal view
@@ -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
test-nonet/Network/HTTP/Client/HeadersSpec.hs view
@@ -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 @@ , "\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 @@ ] (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 @@ ] (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 @@ , "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>")]+ ])