Adds shouldStripHeaderOnRedirectIfOnDifferentHostOnly option on Request

.gitignore

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

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 modReq 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

@@ -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)

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.
     --

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 }