packages feed

http-client 0.7.16 → 0.7.19

raw patch · 11 files changed

Files

ChangeLog.md view
@@ -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.
Network/HTTP/Client.hs view
@@ -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
Network/HTTP/Client/Core.hs view
@@ -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
Network/HTTP/Client/Headers.hs view
@@ -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 []
Network/HTTP/Client/Manager.hs view
@@ -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
Network/HTTP/Client/Response.hs view
@@ -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
Network/HTTP/Client/Types.hs view
@@ -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)
http-client.cabal view
@@ -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: <http://www.stackage.org/package/http-client>. homepage:            https://github.com/snoyberg/http-client
test-nonet/Network/HTTP/Client/HeadersSpec.hs view
@@ -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", "</foo.js>")             , ("Link", "</bar.js>")@@ -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", "</foo.js>")             , ("Link", "</bar.js>")
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -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
test-nonet/Network/HTTP/ClientSpec.hs view
@@ -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"