diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/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/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -162,6 +162,7 @@ , decompress , redirectCount , shouldStripHeaderOnRedirect + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly , checkResponse , responseTimeout , cookieJar @@ -264,6 +265,7 @@ (responseBody res') } case getRedirectedRequest + req req' (responseHeaders res) (responseCookieJar res) diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -220,7 +220,7 @@ (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' diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -303,6 +303,7 @@ Nothing -> throwIO se , requestManagerOverride = Nothing , shouldStripHeaderOnRedirect = const False + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False , proxySecureMode = ProxySecureWithConnect , redactHeaders = Set.singleton "Authorization" } diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs --- a/Network/HTTP/Client/Response.hs +++ b/Network/HTTP/Client/Response.hs @@ -14,6 +14,7 @@ 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 @@ -- > (\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,7 +70,39 @@ 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. diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -616,6 +616,13 @@ -- -- @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. -- diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/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 @@ -47,7 +47,7 @@ , streaming-commons >= 0.1.0.2 && < 0.3 , containers >= 0.5 , transformers - , deepseq >= 1.3 && <1.5 + , deepseq >= 1.3 && <1.6 , case-insensitive >= 1.0 , base64-bytestring >= 1.0 , cookie diff --git a/test-nonet/Network/HTTP/ClientSpec.hs b/test-nonet/Network/HTTP/ClientSpec.hs --- a/test-nonet/Network/HTTP/ClientSpec.hs +++ b/test-nonet/Network/HTTP/ClientSpec.hs @@ -39,6 +39,27 @@ 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 @@ -176,6 +197,30 @@ withResponseHistory req man $ \hr -> 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