From 772e25c9de518ec025d3904eb0fe4149c293dfd3 Mon Sep 17 00:00:00 2001 From: megh Date: Thu, 19 Oct 2023 13:43:53 -0600 Subject: [PATCH 1/4] Adds shouldStripHeaderOnRedirectIfOnDifferentHostOnly option on request --- .gitignore | 1 + http-client/Network/HTTP/Client.hs | 2 + http-client/Network/HTTP/Client/Core.hs | 2 +- http-client/Network/HTTP/Client/Request.hs | 1 + http-client/Network/HTTP/Client/Response.hs | 30 ++++++++++--- http-client/Network/HTTP/Client/Types.hs | 7 +++ .../test-nonet/Network/HTTP/ClientSpec.hs | 45 +++++++++++++++++++ 7 files changed, 80 insertions(+), 8 deletions(-) diff --git a/.gitignore b/.gitignore index 32a4d14c..f97d4a19 100644 --- a/.gitignore +++ b/.gitignore @@ -11,3 +11,4 @@ cabal.sandbox.config .stack-work/ tarballs/ *~ +dist-newstyle/ \ No newline at end of file diff --git a/http-client/Network/HTTP/Client.hs b/http-client/Network/HTTP/Client.hs index 37cefbfa..df59a390 100644 --- a/http-client/Network/HTTP/Client.hs +++ b/http-client/Network/HTTP/Client.hs @@ -162,6 +162,7 @@ module Network.HTTP.Client , decompress , redirectCount , shouldStripHeaderOnRedirect + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly , checkResponse , responseTimeout , cookieJar @@ -264,6 +265,7 @@ responseOpenHistory reqOrig man0 = handle (throwIO . toHttpException reqOrig) $ (responseBody res') } case getRedirectedRequest + req req' (responseHeaders res) (responseCookieJar res) diff --git a/http-client/Network/HTTP/Client/Core.hs b/http-client/Network/HTTP/Client/Core.hs index 4626d076..323f2f7d 100644 --- a/http-client/Network/HTTP/Client/Core.hs +++ b/http-client/Network/HTTP/Client/Core.hs @@ -220,7 +220,7 @@ responseOpen inputReq manager' = do (req'', res) <- httpRaw' modReq manager let mreq = if redirectCount modReq == 0 then Nothing - else getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) + else getRedirectedRequest modReq req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) return (res, fromMaybe req'' mreq, isJust mreq)) req' diff --git a/http-client/Network/HTTP/Client/Request.hs b/http-client/Network/HTTP/Client/Request.hs index 91f33749..f6f3fad2 100644 --- a/http-client/Network/HTTP/Client/Request.hs +++ b/http-client/Network/HTTP/Client/Request.hs @@ -303,6 +303,7 @@ defaultRequest = Request Nothing -> throwIO se , requestManagerOverride = Nothing , shouldStripHeaderOnRedirect = const False + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False , proxySecureMode = ProxySecureWithConnect , redactHeaders = Set.singleton "Authorization" } diff --git a/http-client/Network/HTTP/Client/Response.hs b/http-client/Network/HTTP/Client/Response.hs index fd2462c3..c82e21be 100644 --- a/http-client/Network/HTTP/Client/Response.hs +++ b/http-client/Network/HTTP/Client/Response.hs @@ -43,21 +43,17 @@ import Data.KeyedPool -- > (\req' -> do -- > res <- http req'{redirectCount=0} man -- > modify (\rqs -> req' : rqs) --- > return (res, getRedirectedRequest req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) +-- > return (res, getRedirectedRequest req req' (responseHeaders res) (responseCookieJar res) (W.statusCode (responseStatus res)) -- > ) -- > 'lift' -- > req -- > applyCheckStatus (checkStatus req) res -- > return redirectRequests -getRedirectedRequest :: Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request -getRedirectedRequest req hs cookie_jar code +getRedirectedRequest :: Request -> Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request +getRedirectedRequest prevReq req hs cookie_jar code | 300 <= code && code < 400 = do l' <- lookup "location" hs let l = escapeURIString isAllowedInURI (S8.unpack l') - stripHeaders r = - r{requestHeaders = - filter (not . shouldStripHeaderOnRedirect req . fst) $ - requestHeaders r} req' <- fmap stripHeaders <$> setUriRelative req =<< parseURIReference l return $ if code == 302 || code == 303 @@ -73,8 +69,28 @@ getRedirectedRequest req hs cookie_jar code else req' {cookieJar = cookie_jar'} | otherwise = Nothing where + cookie_jar' :: Maybe CookieJar cookie_jar' = fmap (const cookie_jar) $ cookieJar req + hostDiffer :: Bool + hostDiffer = host req /= host prevReq + + shouldStripOnlyIfHostDiffer :: Bool + shouldStripOnlyIfHostDiffer = shouldStripHeaderOnRedirectIfOnDifferentHostOnly req + + stripHeaders :: Request -> Request + stripHeaders r = + case (hostDiffer, shouldStripOnlyIfHostDiffer) of + (True, True) -> stripHeaders' r + (True, False) -> stripHeaders' r + (False, False) -> stripHeaders' r + (False, True) -> r + + stripHeaders' :: Request -> Request + stripHeaders' r = r{requestHeaders = + filter (not . shouldStripHeaderOnRedirect req . fst) $ + requestHeaders r} + -- | Convert a 'Response' that has a 'Source' body to one with a lazy -- 'L.ByteString' body. lbsResponse :: Response BodyReader -> IO (Response L.ByteString) diff --git a/http-client/Network/HTTP/Client/Types.hs b/http-client/Network/HTTP/Client/Types.hs index 3a219fac..ffb614f1 100644 --- a/http-client/Network/HTTP/Client/Types.hs +++ b/http-client/Network/HTTP/Client/Types.hs @@ -616,6 +616,13 @@ data Request = Request -- -- @since 0.6.2 + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly :: Bool + -- ^ Decide whether a header must be stripped from the request + -- when following a redirect, if host differs from previous request + -- in redirect chain. Default: false (always strip regardless of host change) + -- + -- @since 0.6.2 + , proxySecureMode :: ProxySecureMode -- ^ How to proxy an HTTPS request. -- diff --git a/http-client/test-nonet/Network/HTTP/ClientSpec.hs b/http-client/test-nonet/Network/HTTP/ClientSpec.hs index 65de3842..15bbc30d 100644 --- a/http-client/test-nonet/Network/HTTP/ClientSpec.hs +++ b/http-client/test-nonet/Network/HTTP/ClientSpec.hs @@ -39,6 +39,27 @@ silentIOError a = a `E.catch` \e -> do let _ = e :: IOError return () +redirectServerToDifferentHost :: Maybe Int -> (Int -> IO a) -> IO a +redirectServerToDifferentHost maxRedirects inner = bracket + (N.bindRandomPortTCP "*4") + (NS.close . snd) + $ \(port, lsocket) -> withAsync + (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) + (const $ inner port) + where + redirect ad = do + N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: http://example.com\r\ncontent-length: 5\r\n\r\n" + threadDelay 10000 + N.appWrite ad "hello\r\n" + threadDelay 10000 + app ad = Async.race_ + (silentIOError $ forever (N.appRead ad)) + (silentIOError $ case maxRedirects of + Nothing -> forever $ redirect ad + Just n -> + replicateM_ n (redirect ad) >> + N.appWrite ad "HTTP/1.1 200 OK\r\ncontent-length: 5\r\n\r\nhello\r\n") + redirectServer :: Maybe Int -- ^ If Just, stop redirecting after that many hops. -> (Int -> IO a) -> IO a @@ -177,6 +198,30 @@ spec = describe "Client" $ do print $ map (requestHeaders . fst) $ hrRedirects hr mapM_ (\r -> requestHeaders r `shouldBe` []) $ map fst $ tail $ hrRedirects hr + it "does strips header on redirect, if hosts are different and set to strip them if host differ" $ redirectServerToDifferentHost (Just 1) $ \port -> do + req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + let req = req' { requestHeaders = [(hAuthorization, "abguvatgbfrrurer")] + , redirectCount = 10 + , shouldStripHeaderOnRedirect = (== hAuthorization) + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = True + } + man <- newManager defaultManagerSettings + withResponseHistory req man $ \hr -> do + print $ map (requestHeaders . fst) $ hrRedirects hr + mapM_ (\r -> requestHeaders r `shouldBe` []) $ + map fst $ tail $ hrRedirects hr + it "does NOT strips header on redirect, if hosts are same and set to strip them if host differ" $ redirectServerToDifferentHost (Just 1) $ \port -> do + req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + let req = req' { requestHeaders = [(hAuthorization, "abguvatgbfrrurer")] + , redirectCount = 10 + , shouldStripHeaderOnRedirect = (== hAuthorization) + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = True + } + man <- newManager defaultManagerSettings + withResponseHistory req man $ \hr -> do + print $ map (requestHeaders . fst) $ hrRedirects hr + mapM_ (\r -> requestHeaders r `shouldBe` [("Authorization","abguvatgbfrrurer")]) $ + map fst $ tail $ hrRedirects hr it "redirecting #41" $ redirectServer Nothing $ \port -> do req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' { redirectCount = 1 } From bd72ac4f54349aedcbf19d0d1b48fa3eaf60b367 Mon Sep 17 00:00:00 2001 From: meghfossa Date: Sat, 28 Oct 2023 16:19:39 -0600 Subject: [PATCH 2/4] Address PR feedback, and ensure entire chain of host gets apt headers --- http-client/ChangeLog.md | 4 +++ http-client/Network/HTTP/Client/Core.hs | 2 +- http-client/Network/HTTP/Client/Response.hs | 27 +++++++++++++++------ http-client/Network/HTTP/Client/Types.hs | 4 +-- 4 files changed, 27 insertions(+), 10 deletions(-) diff --git a/http-client/ChangeLog.md b/http-client/ChangeLog.md index f3078cb8..fc45385d 100644 --- a/http-client/ChangeLog.md +++ b/http-client/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for http-client +## 0.7.15 + +* Adds `shouldStripHeaderOnRedirectIfOnDifferentHostOnly` option to `Request` [#520](https://github.com/snoyberg/http-client/pull/520) + ## 0.7.14 * Allow customizing max header length [#514](https://github.com/snoyberg/http-client/pull/514) diff --git a/http-client/Network/HTTP/Client/Core.hs b/http-client/Network/HTTP/Client/Core.hs index 323f2f7d..777384f7 100644 --- a/http-client/Network/HTTP/Client/Core.hs +++ b/http-client/Network/HTTP/Client/Core.hs @@ -220,7 +220,7 @@ responseOpen inputReq manager' = do (req'', res) <- httpRaw' modReq manager let mreq = if redirectCount modReq == 0 then Nothing - else getRedirectedRequest modReq req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) + else getRedirectedRequest req' req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) return (res, fromMaybe req'' mreq, isJust mreq)) req' diff --git a/http-client/Network/HTTP/Client/Response.hs b/http-client/Network/HTTP/Client/Response.hs index c82e21be..242723fc 100644 --- a/http-client/Network/HTTP/Client/Response.hs +++ b/http-client/Network/HTTP/Client/Response.hs @@ -14,6 +14,7 @@ import qualified Data.CaseInsensitive as CI import Control.Arrow (second) import Data.Monoid (mempty) +import Data.List (nubBy) import qualified Network.HTTP.Types as W import Network.URI (parseURIReference, escapeURIString, isAllowedInURI) @@ -50,7 +51,7 @@ import Data.KeyedPool -- > applyCheckStatus (checkStatus req) res -- > return redirectRequests getRedirectedRequest :: Request -> Request -> W.ResponseHeaders -> CookieJar -> Int -> Maybe Request -getRedirectedRequest prevReq req hs cookie_jar code +getRedirectedRequest origReq req hs cookie_jar code | 300 <= code && code < 400 = do l' <- lookup "location" hs let l = escapeURIString isAllowedInURI (S8.unpack l') @@ -72,20 +73,32 @@ getRedirectedRequest prevReq req hs cookie_jar code cookie_jar' :: Maybe CookieJar cookie_jar' = fmap (const cookie_jar) $ cookieJar req - hostDiffer :: Bool - hostDiffer = host req /= host prevReq + hostDiffer :: Request -> Bool + hostDiffer req = host origReq /= host req shouldStripOnlyIfHostDiffer :: Bool shouldStripOnlyIfHostDiffer = shouldStripHeaderOnRedirectIfOnDifferentHostOnly req + mergeHeaders :: W.RequestHeaders -> W.RequestHeaders -> W.RequestHeaders + mergeHeaders lhs rhs = nubBy (\(a, _) (a', _) -> a == a') (lhs ++ rhs) + stripHeaders :: Request -> Request - stripHeaders r = - case (hostDiffer, shouldStripOnlyIfHostDiffer) of + stripHeaders r = do + case (hostDiffer r, shouldStripOnlyIfHostDiffer) of (True, True) -> stripHeaders' r (True, False) -> stripHeaders' r (False, False) -> stripHeaders' r - (False, True) -> r - + (False, True) -> do + -- We need to check if we have omitted headers in previous + -- request chain. Consider request chain: + -- + -- 1. example-1.com + -- 2. example-2.com (we may have removed some headers here from 1) + -- 3. example-1.com (since we are back at same host as 1, we need re-add stripped headers) + -- + let strippedHeaders = filter (shouldStripHeaderOnRedirect r . fst) (requestHeaders origReq) + r{requestHeaders = mergeHeaders (requestHeaders r) strippedHeaders} + stripHeaders' :: Request -> Request stripHeaders' r = r{requestHeaders = filter (not . shouldStripHeaderOnRedirect req . fst) $ diff --git a/http-client/Network/HTTP/Client/Types.hs b/http-client/Network/HTTP/Client/Types.hs index ffb614f1..7a142cfc 100644 --- a/http-client/Network/HTTP/Client/Types.hs +++ b/http-client/Network/HTTP/Client/Types.hs @@ -620,8 +620,8 @@ data Request = Request -- ^ Decide whether a header must be stripped from the request -- when following a redirect, if host differs from previous request -- in redirect chain. Default: false (always strip regardless of host change) - -- - -- @since 0.6.2 + -- + -- @since 0.7.15 , proxySecureMode :: ProxySecureMode -- ^ How to proxy an HTTPS request. From 574214d0e7e6659049cd975644e1388ba36c1d66 Mon Sep 17 00:00:00 2001 From: meghfossa Date: Sat, 28 Oct 2023 16:23:28 -0600 Subject: [PATCH 3/4] bumps version in cabal file for http-client --- http-client/http-client.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/http-client/http-client.cabal b/http-client/http-client.cabal index a02149aa..a6c6bbdb 100644 --- a/http-client/http-client.cabal +++ b/http-client/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.7.14 +version: 0.7.15 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 From 4d1bb7d2b4d851a6633887ba42f48ba55dfe9463 Mon Sep 17 00:00:00 2001 From: meghfossa Date: Sat, 28 Oct 2023 16:25:59 -0600 Subject: [PATCH 4/4] Allow running tests workflow from github UI --- .github/workflows/tests.yml | 1 + 1 file changed, 1 insertion(+) diff --git a/.github/workflows/tests.yml b/.github/workflows/tests.yml index 862f8a88..1bad849a 100644 --- a/.github/workflows/tests.yml +++ b/.github/workflows/tests.yml @@ -1,6 +1,7 @@ name: Tests on: + workflow_dispatch: pull_request: push: branches: