Adds shouldStripHeaderOnRedirectIfOnDifferentHostOnly option on Request

.github/workflows/tests.yml

@@ -1,6 +1,7 @@
 name: Tests
 
 on:
+    workflow_dispatch:
     pull_request:
     push:
         branches:

.gitignore

@@ -11,3 +11,4 @@ cabal.sandbox.config
 .stack-work/
 tarballs/
 *~
+dist-newstyle/

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)

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)

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 req' req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))
         return (res, fromMaybe req'' mreq, isJust mreq))
       req'
 

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"
         }

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)
@@ -43,21 +44,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 origReq 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 +70,40 @@ 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 :: 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 = do
+        case (hostDiffer r, shouldStripOnlyIfHostDiffer) of 
+            (True, True) -> stripHeaders' r
+            (True, False) -> stripHeaders' r
+            (False, False) -> stripHeaders' 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) $
+                        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)

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.7.15
+
     , proxySecureMode :: ProxySecureMode
     -- ^ How to proxy an HTTPS request.
     --

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: <http://www.stackage.org/package/http-client>.
 homepage:            https://github.com/snoyberg/http-client

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 }