diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # Changelog for http-client +## 0.7.19 + +* Make mockable via `Network.HTTP.Client.Internal.requestAction` [#554](https://github.com/snoyberg/http-client/pull/554) + +## 0.7.18 + +* Add the `managerSetMaxNumberHeaders` function to the `Client` module to configure `managerMaxNumberHeaders` in `ManagerSettings`. + +## 0.7.17 + +* Add `managerSetMaxHeaderLength` to `Client` to change `ManagerSettings` `MaxHeaderLength`. + ## 0.7.16 * Add `responseEarlyHints` field to `Response`, containing a list of all HTTP 103 Early Hints headers received from the server. diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -112,6 +112,8 @@ , managerSetProxy , managerSetInsecureProxy , managerSetSecureProxy + , managerSetMaxHeaderLength + , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy @@ -319,6 +321,16 @@ -- Since 0.4.7 managerSetProxy :: ProxyOverride -> ManagerSettings -> ManagerSettings managerSetProxy po = managerSetInsecureProxy po . managerSetSecureProxy po + +-- @since 0.7.17 +managerSetMaxHeaderLength :: Int -> ManagerSettings -> ManagerSettings +managerSetMaxHeaderLength l manager = manager + { managerMaxHeaderLength = Just $ MaxHeaderLength l } + +-- @since 0.7.18 +managerSetMaxNumberHeaders :: Int -> ManagerSettings -> ManagerSettings +managerSetMaxNumberHeaders n manager = manager + { managerMaxNumberHeaders = Just $ MaxNumberHeaders n } -- $example1 -- = Example Usage 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 @@ -6,6 +6,7 @@ , httpNoBody , httpRaw , httpRaw' + , requestAction , getModifiedRequestManager , responseOpen , responseClose @@ -25,11 +26,13 @@ import Network.HTTP.Client.Cookies import Data.Maybe (fromMaybe, isJust) import Data.Time +import Data.IORef import Control.Exception import qualified Data.ByteString.Lazy as L import Data.Monoid import Control.Monad (void) import System.Timeout (timeout) +import System.IO.Unsafe (unsafePerformIO) import Data.KeyedPool import GHC.IO.Exception (IOException(..), IOErrorType(..)) @@ -94,66 +97,86 @@ now <- getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now Nothing -> return (req', Data.Monoid.mempty) - (timeout', mconn) <- getConnectionWrapper - (responseTimeout' req) - (getConn req m) - - -- Originally, we would only test for exceptions when sending the request, - -- not on calling @getResponse@. However, some servers seem to close - -- connections after accepting the request headers, so we need to check for - -- exceptions in both. - ex <- try $ do - cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn) + res <- makeRequest req m + case cookieJar req' of + Just _ -> do + now' <- getCurrentTime + let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' + return (req, res {responseCookieJar = cookie_jar}) + Nothing -> return (req, res) - getResponse (mMaxHeaderLength m) timeout' req mconn cont +makeRequest + :: Request + -> Manager + -> IO (Response BodyReader) +makeRequest req m = do + action <- readIORef requestAction + action req m - case ex of - -- Connection was reused, and might have been closed. Try again - Left e | managedReused mconn && mRetryableException m e -> do - managedRelease mconn DontReuse - httpRaw' req m - -- Not reused, or a non-retry, so this is a real exception - Left e -> do - -- Explicitly release connection for all real exceptions: - -- https://github.com/snoyberg/http-client/pull/454 - managedRelease mconn DontReuse - throwIO e - -- Everything went ok, so the connection is good. If any exceptions get - -- thrown in the response body, just throw them as normal. - Right res -> case cookieJar req' of - Just _ -> do - now' <- getCurrentTime - let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' - return (req, res {responseCookieJar = cookie_jar}) - Nothing -> return (req, res) +requestAction :: IORef (Request -> Manager -> IO (Response BodyReader)) +{-# NOINLINE requestAction #-} +requestAction = unsafePerformIO (newIORef action) where - getConnectionWrapper mtimeout f = - case mtimeout of - Nothing -> fmap ((,) Nothing) f - Just timeout' -> do - before <- getCurrentTime - mres <- timeout timeout' f - case mres of - Nothing -> throwHttp ConnectionTimeout - Just mConn -> do - now <- getCurrentTime - let timeSpentMicro = diffUTCTime now before * 1000000 - remainingTime = round $ fromIntegral timeout' - timeSpentMicro - if remainingTime <= 0 - then do - managedRelease mConn DontReuse - throwHttp ConnectionTimeout - else return (Just remainingTime, mConn) + action + :: Request + -> Manager + -> IO (Response BodyReader) + action req m = do + (timeout', mconn) <- getConnectionWrapper + (responseTimeout' req) + (getConn req m) - responseTimeout' req = - case responseTimeout req of - ResponseTimeoutDefault -> - case mResponseTimeout m of - ResponseTimeoutDefault -> Just 30000000 - ResponseTimeoutNone -> Nothing - ResponseTimeoutMicro u -> Just u - ResponseTimeoutNone -> Nothing - ResponseTimeoutMicro u -> Just u + -- Originally, we would only test for exceptions when sending the request, + -- not on calling @getResponse@. However, some servers seem to close + -- connections after accepting the request headers, so we need to check for + -- exceptions in both. + ex <- try $ do + cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn) + + getResponse (mMaxHeaderLength m) (mMaxNumberHeaders m) timeout' req mconn cont + + case ex of + -- Connection was reused, and might have been closed. Try again + Left e | managedReused mconn && mRetryableException m e -> do + managedRelease mconn DontReuse + action req m + -- Not reused, or a non-retry, so this is a real exception + Left e -> do + -- Explicitly release connection for all real exceptions: + -- https://github.com/snoyberg/http-client/pull/454 + managedRelease mconn DontReuse + throwIO e + -- Everything went ok, so the connection is good. If any exceptions get + -- thrown in the response body, just throw them as normal. + Right res -> return res + where + getConnectionWrapper mtimeout f = + case mtimeout of + Nothing -> fmap ((,) Nothing) f + Just timeout' -> do + before <- getCurrentTime + mres <- timeout timeout' f + case mres of + Nothing -> throwHttp ConnectionTimeout + Just mConn -> do + now <- getCurrentTime + let timeSpentMicro = diffUTCTime now before * 1000000 + remainingTime = round $ fromIntegral timeout' - timeSpentMicro + if remainingTime <= 0 + then do + managedRelease mConn DontReuse + throwHttp ConnectionTimeout + else return (Just remainingTime, mConn) + + responseTimeout' req = + case responseTimeout req of + ResponseTimeoutDefault -> + case mResponseTimeout m of + ResponseTimeoutDefault -> Just 30000000 + ResponseTimeoutNone -> Nothing + ResponseTimeoutMicro u -> Just u + ResponseTimeoutNone -> Nothing + ResponseTimeoutMicro u -> Just u -- | The used Manager can be overridden (by requestManagerOverride) and the used -- Request can be modified (through managerModifyRequest). This function allows diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs --- a/Network/HTTP/Client/Headers.hs +++ b/Network/HTTP/Client/Headers.hs @@ -28,8 +28,8 @@ charPeriod = 46 -parseStatusHeaders :: Maybe MaxHeaderLength -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders -parseStatusHeaders mhl conn timeout' onEarlyHintHeaders cont +parseStatusHeaders :: Maybe MaxHeaderLength -> Maybe MaxNumberHeaders -> Connection -> Maybe Int -> ([Header] -> IO ()) -> Maybe (IO ()) -> IO StatusHeaders +parseStatusHeaders mhl mnh conn timeout' onEarlyHintHeaders cont | Just k <- cont = getStatusExpectContinue k | otherwise = getStatus where @@ -91,9 +91,14 @@ Just (i, "") -> Just i _ -> Nothing + guardMaxNumberHeaders :: Int -> IO () + guardMaxNumberHeaders count = case fmap unMaxNumberHeaders mnh of + Nothing -> pure () + Just n -> when (count >= n) $ throwHttp TooManyHeaderFields + parseHeaders :: Int -> ([Header] -> [Header]) -> IO [Header] - parseHeaders 100 _ = throwHttp OverlongHeaders parseHeaders count front = do + guardMaxNumberHeaders count line <- connectionReadLine mhl conn if S.null line then return $ front [] @@ -107,8 +112,8 @@ parseHeaders count front parseEarlyHintHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header] - parseEarlyHintHeadersUntilFailure 100 _ = throwHttp OverlongHeaders parseEarlyHintHeadersUntilFailure count front = do + guardMaxNumberHeaders count line <- connectionReadLine mhl conn if S.null line then return $ front [] diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs --- a/Network/HTTP/Client/Manager.hs +++ b/Network/HTTP/Client/Manager.hs @@ -93,6 +93,7 @@ , managerProxyInsecure = defaultProxy , managerProxySecure = defaultProxy , managerMaxHeaderLength = Just $ MaxHeaderLength 4096 + , managerMaxNumberHeaders = Just $ MaxNumberHeaders 100 } -- | Create a 'Manager'. The @Manager@ will be shut down automatically via @@ -133,6 +134,7 @@ then httpsProxy req else httpProxy req , mMaxHeaderLength = managerMaxHeaderLength ms + , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager @@ -259,7 +261,9 @@ , "\r\n" ] parse conn = do - StatusHeaders status _ _ _ <- parseStatusHeaders (managerMaxHeaderLength ms) conn Nothing (\_ -> return ()) Nothing + let mhl = managerMaxHeaderLength ms + mnh = managerMaxNumberHeaders ms + StatusHeaders status _ _ _ <- parseStatusHeaders mhl mnh conn Nothing (\_ -> return ()) Nothing unless (status == status200) $ throwHttp $ ProxyConnectException ultHost ultPort status in tlsProxyConnection 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 @@ -81,10 +81,10 @@ 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 + case (hostDiffer r, shouldStripOnlyIfHostDiffer) of (True, True) -> stripHeaders' r (True, False) -> stripHeaders' r (False, False) -> stripHeaders' r @@ -92,7 +92,7 @@ -- We need to check if we have omitted headers in previous -- request chain. Consider request chain: -- - -- 1. example-1.com + -- 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) -- @@ -114,14 +114,15 @@ } getResponse :: Maybe MaxHeaderLength + -> Maybe MaxNumberHeaders -> Maybe Int -> Request -> Managed Connection -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'. -> IO (Response BodyReader) -getResponse mhl timeout' req@(Request {..}) mconn cont = do +getResponse mhl mnh timeout' req@(Request {..}) mconn cont = do let conn = managedResource mconn - StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl conn timeout' earlyHintHeadersReceived cont + StatusHeaders s version earlyHs hs <- parseStatusHeaders mhl mnh 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 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 @@ -1,8 +1,9 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Network.HTTP.Client.Types ( BodyReader , Connection (..) @@ -39,6 +40,7 @@ , ResponseTimeout (..) , ProxySecureMode (..) , MaxHeaderLength (..) + , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable) @@ -147,12 +149,14 @@ -- -- @since 0.5.0 | OverlongHeaders - -- ^ Either too many headers, or too many total bytes in a - -- single header, were returned by the server, and the - -- memory exhaustion protection in this library has kicked - -- in. + -- ^ Too many total bytes in the HTTP header were returned + -- by the server. -- -- @since 0.5.0 + | TooManyHeaderFields + -- ^ Too many HTTP header fields were returned by the server. + -- + -- @since 0.7.18 | ResponseTimeout -- ^ The server took too long to return a response. This can -- be altered via 'responseTimeout' or @@ -821,6 +825,17 @@ -- -- Since 0.4.7 , managerMaxHeaderLength :: Maybe MaxHeaderLength + -- ^ Configure the maximum size, in bytes, of an HTTP header field. + -- + -- Default: 4096 + -- + -- @since 0.7.17 + , managerMaxNumberHeaders :: Maybe MaxNumberHeaders + -- ^ Configure the maximum number of HTTP header fields. + -- + -- Default: 100 + -- + -- @since 0.7.18 } deriving T.Typeable @@ -845,9 +860,10 @@ , mWrapException :: forall a. Request -> IO a -> IO a , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request - , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) + , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) -- ^ See 'managerProxy' , mMaxHeaderLength :: Maybe MaxHeaderLength + , mMaxNumberHeaders :: Maybe MaxNumberHeaders } deriving T.Typeable @@ -906,4 +922,12 @@ newtype MaxHeaderLength = MaxHeaderLength { unMaxHeaderLength :: Int } - deriving (Eq, Show) + deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable) + +-- | The maximum number of header fields. +-- +-- @since 0.7.18 +newtype MaxNumberHeaders = MaxNumberHeaders + { unMaxNumberHeaders :: Int + } + deriving (Eq, Show, Ord, Num, Enum, Bounded, T.Typeable) 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.16 +version: 0.7.19 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 diff --git a/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/test-nonet/Network/HTTP/Client/HeadersSpec.hs --- a/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/test-nonet/Network/HTTP/Client/HeadersSpec.hs @@ -23,7 +23,7 @@ , "\nignored" ] (connection, _, _) <- dummyConnection input - statusHeaders <- parseStatusHeaders Nothing connection Nothing (\_ -> return ()) Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing connection Nothing (\_ -> return ()) Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty [ ("foo", "bar") , ("baz", "bin") @@ -37,7 +37,7 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data" - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody) + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody) statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` ["data"]) @@ -47,7 +47,7 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data" - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) (Just sendBody) + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody) statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] [] out >>= (`shouldBe` []) @@ -59,7 +59,7 @@ , "result" ] (conn, out, inp) <- dummyConnection input - statusHeaders <- parseStatusHeaders Nothing conn Nothing (\_ -> return ()) Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` []) inp >>= (`shouldBe` ["result"]) @@ -78,7 +78,7 @@ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h)) - statusHeaders <- parseStatusHeaders Nothing conn Nothing onEarlyHintHeader Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [("Link", "") , ("Link", "") @@ -110,7 +110,7 @@ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h)) - statusHeaders <- parseStatusHeaders Nothing conn Nothing onEarlyHintHeader Nothing + statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [("Link", "") , ("Link", "") diff --git a/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/test-nonet/Network/HTTP/Client/ResponseSpec.hs --- a/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do - let getResponse' conn = getResponse Nothing Nothing req (dummyManaged conn) Nothing + let getResponse' conn = getResponse Nothing Nothing Nothing req (dummyManaged conn) Nothing req = parseRequest_ "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection 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 @@ -31,6 +31,9 @@ notWindows x = x #endif +crlf :: S.ByteString +crlf = "\r\n" + main :: IO () main = hspec spec @@ -323,3 +326,24 @@ case parseRequest "https://o_O:18446744072699450606" of Left _ -> pure () :: IO () Right req -> error $ "Invalid request: " ++ show req + + it "too many header fields" $ do + let message = S.concat $ + ["HTTP/1.1 200 OK", crlf] <> replicate 120 ("foo: bar" <> crlf) <> [crlf, "body"] + + serveWith message $ \port -> do + man <- newManager $ managerSetMaxNumberHeaders 120 defaultManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + httpLbs req man `shouldThrow` \e -> case e of + HttpExceptionRequest _ TooManyHeaderFields -> True + _otherwise -> False + + it "not too many header fields" $ do + let message = S.concat $ + ["HTTP/1.1 200 OK", crlf] <> replicate 120 ("foo: bar" <> crlf) <> [crlf, "body"] + + serveWith message $ \port -> do + man <- newManager $ managerSetMaxNumberHeaders 121 defaultManagerSettings + req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port + res <- httpLbs req man + responseBody res `shouldBe` "body"