http-client 0.7.8 → 0.7.19
raw patch · 17 files changed
Files
- ChangeLog.md +49/−0
- Network/HTTP/Client.hs +25/−6
- Network/HTTP/Client/Body.hs +18/−5
- Network/HTTP/Client/Connection.hs +68/−17
- Network/HTTP/Client/Core.hs +94/−66
- Network/HTTP/Client/Headers.hs +47/−19
- Network/HTTP/Client/Manager.hs +7/−1
- Network/HTTP/Client/Request.hs +24/−4
- Network/HTTP/Client/Response.hs +51/−12
- Network/HTTP/Client/Types.hs +76/−13
- http-client.cabal +6/−2
- test-nonet/Network/HTTP/Client/BodySpec.hs +52/−10
- test-nonet/Network/HTTP/Client/ConnectionSpec.hs +23/−0
- test-nonet/Network/HTTP/Client/HeadersSpec.hs +76/−8
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +2/−2
- test-nonet/Network/HTTP/ClientSpec.hs +69/−0
- test/Network/HTTP/ClientSpec.hs +48/−0
ChangeLog.md view
@@ -1,5 +1,54 @@ # 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.+* Add `earlyHintHeadersReceived` callback to `Request`, which will be called on each HTTP 103 Early Hints header section received.++## 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)++## 0.7.13++* Create the ability to redact custom header values to censor sensitive information++## 0.7.12++* Fix premature connection closing due to weak reference lifetimes [#490](https://github.com/snoyberg/http-client/pull/490)++## 0.7.11++* Allow making requests to raw IPv6 hosts [#477](https://github.com/snoyberg/http-client/pull/477)+* Catch "resource vanished" exception on initial response read [#480](https://github.com/snoyberg/http-client/pull/480)+* Search for reachable IP addresses asynchronously (RFC 6555, 8305) after calling `getAddrInfo` to reduce latency [#472](https://github.com/snoyberg/http-client/pull/472).++## 0.7.10++* Consume trailers and last CRLF of chunked body. The trailers are not exposed,+ unless the raw body is requested.++## 0.7.9++* Exceptions from streamed request body now cause the request to fail. Previously they were+ routed through onRequestBodyException and, by default, the IOExceptions were discarded.+ ## 0.7.8 * Include the original `Request` in the `Response`. Expose it via `getOriginalRequest`.
Network/HTTP/Client.hs view
@@ -11,7 +11,7 @@ -- support for things like JSON request and response bodies. For most users, -- this will be an easier place to start. You can read the tutorial at: ----- https://haskell-lang.org/library/http-client+-- https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md -- -- = Lower-level API --@@ -112,6 +112,8 @@ , managerSetProxy , managerSetInsecureProxy , managerSetSecureProxy+ , managerSetMaxHeaderLength+ , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy@@ -162,10 +164,13 @@ , decompress , redirectCount , shouldStripHeaderOnRedirect+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly , checkResponse , responseTimeout , cookieJar , requestVersion+ , redactHeaders+ , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper@@ -182,6 +187,7 @@ , responseBody , responseCookieJar , getOriginalRequest+ , responseEarlyHints , throwErrorStatusCodes -- ** Response body , BodyReader@@ -203,12 +209,13 @@ , equivCookieJar , Proxy (..) , withConnection+ , strippedHostName -- * Cookies , module Network.HTTP.Client.Cookies ) where import Network.HTTP.Client.Body-import Network.HTTP.Client.Connection (makeConnection, socketConnection)+import Network.HTTP.Client.Connection (makeConnection, socketConnection, strippedHostName) import Network.HTTP.Client.Cookies import Network.HTTP.Client.Core import Network.HTTP.Client.Manager@@ -223,7 +230,7 @@ import Network.HTTP.Types (statusCode) import GHC.Generics (Generic) import Data.Typeable (Typeable)-import Control.Exception (bracket, handle, throwIO)+import Control.Exception (bracket, catch, handle, throwIO) -- | A datatype holding information on redirected requests and the final response. --@@ -262,6 +269,7 @@ (responseBody res') } case getRedirectedRequest+ req req' (responseHeaders res) (responseCookieJar res)@@ -270,6 +278,7 @@ Just req'' -> do writeIORef reqRef req'' body <- brReadSome (responseBody res) 1024+ `catch` handleClosedRead modifyIORef historyRef (. ((req, res { responseBody = body }):)) return (res, req'', True) (_, res) <- httpRedirect' (redirectCount reqOrig) go reqOrig@@ -313,6 +322,16 @@ 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 --@@ -347,9 +366,9 @@ -- > -- Create the request -- > let requestObject = object ["name" .= "Michael", "age" .= 30] -- > let requestObject = object--- > [ "name" .= ("Michael" :: Text)--- > , "age" .= (30 :: Int)--- > ]+-- > [ "name" .= ("Michael" :: Text)+-- > , "age" .= (30 :: Int)+-- > ] -- > -- > initialRequest <- parseRequest "http://httpbin.org/post" -- > let request = initialRequest { method = "POST", requestBody = RequestBodyLBS $ encode requestObject }
Network/HTTP/Client/Body.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} module Network.HTTP.Client.Body ( makeChunkedReader , makeLengthReader@@ -147,11 +148,12 @@ return bs makeChunkedReader- :: IO () -- ^ cleanup+ :: Maybe MaxHeaderLength+ -> IO () -- ^ cleanup -> Bool -- ^ raw -> Connection -> IO BodyReader-makeChunkedReader cleanup raw conn@Connection {..} = do+makeChunkedReader mhl cleanup raw conn@Connection {..} = do icount <- newIORef 0 return $ do bs <- go icount@@ -166,8 +168,11 @@ else return (empty, count0) if count <= 0 then do+ -- count == -1 indicates that all chunks have been consumed writeIORef icount (-1)- return $ if count /= (-1) && raw then rawCount else empty+ if | count /= -1 && raw -> S.append rawCount <$> readTrailersRaw+ | count /= -1 -> consumeTrailers *> pure empty+ | otherwise -> pure empty else do (bs, count') <- readChunk count writeIORef icount count'@@ -197,11 +202,11 @@ | otherwise = return (x, 0) requireNewline = do- bs <- connectionReadLine conn+ bs <- connectionReadLine mhl conn unless (S.null bs) $ throwHttp InvalidChunkHeaders readHeader = do- bs <- connectionReadLine conn+ bs <- connectionReadLine mhl conn case parseHex bs of Nothing -> throwHttp InvalidChunkHeaders Just hex -> return (bs `S.append` "\r\n", hex)@@ -222,3 +227,11 @@ | 65 <= w && w <= 70 = Just $ fromIntegral w - 55 | 97 <= w && w <= 102 = Just $ fromIntegral w - 87 | otherwise = Nothing++ readTrailersRaw = do+ bs <- connectionReadLine mhl conn+ if S.null bs+ then pure "\r\n"+ else (bs `S.append` "\r\n" `S.append`) <$> readTrailersRaw++ consumeTrailers = connectionDropTillBlankLine mhl conn
Network/HTTP/Client/Connection.hs view
@@ -5,47 +5,55 @@ ( connectionReadLine , connectionReadLineWith , connectionDropTillBlankLine+ , connectionUnreadLine , dummyConnection , openSocketConnection , openSocketConnectionSize , makeConnection , socketConnection , withSocket+ , strippedHostName ) where import Data.ByteString (ByteString, empty) import Data.IORef import Control.Monad+import Control.Concurrent+import Control.Concurrent.Async import Network.HTTP.Client.Types import Network.Socket (Socket, HostAddress) import qualified Network.Socket as NS import Network.Socket.ByteString (sendAll, recv) import qualified Control.Exception as E import qualified Data.ByteString as S-import Data.Word (Word8)+import Data.Foldable (for_) import Data.Function (fix)+import Data.Maybe (listToMaybe)+import Data.Word (Word8) -connectionReadLine :: Connection -> IO ByteString-connectionReadLine conn = do+connectionReadLine :: Maybe MaxHeaderLength -> Connection -> IO ByteString+connectionReadLine mhl conn = do bs <- connectionRead conn when (S.null bs) $ throwHttp IncompleteHeaders- connectionReadLineWith conn bs+ connectionReadLineWith mhl conn bs -- | Keep dropping input until a blank line is found.-connectionDropTillBlankLine :: Connection -> IO ()-connectionDropTillBlankLine conn = fix $ \loop -> do- bs <- connectionReadLine conn+connectionDropTillBlankLine :: Maybe MaxHeaderLength -> Connection -> IO ()+connectionDropTillBlankLine mhl conn = fix $ \loop -> do+ bs <- connectionReadLine mhl conn unless (S.null bs) loop -connectionReadLineWith :: Connection -> ByteString -> IO ByteString-connectionReadLineWith conn bs0 =+connectionReadLineWith :: Maybe MaxHeaderLength -> Connection -> ByteString -> IO ByteString+connectionReadLineWith mhl conn bs0 = go bs0 id 0 where go bs front total = case S.break (== charLF) bs of (_, "") -> do let total' = total + S.length bs- when (total' > 4096) $ throwHttp OverlongHeaders+ case fmap unMaxHeaderLength mhl of+ Nothing -> pure ()+ Just n -> when (total' > n) $ throwHttp OverlongHeaders bs' <- connectionRead conn when (S.null bs') $ throwHttp IncompleteHeaders go bs' (front . (bs:)) total'@@ -53,6 +61,11 @@ unless (S.null y) $! connectionUnread conn y return $! killCR $! S.concat $! front [x] +connectionUnreadLine :: Connection -> ByteString -> IO ()+connectionUnreadLine conn line = do+ connectionUnread conn (S.pack [charCR, charLF])+ connectionUnread conn line+ charLF, charCR :: Word8 charLF = 10 charCR = 13@@ -149,6 +162,24 @@ withSocket tweakSocket hostAddress' host' port' $ \ sock -> socketConnection sock chunksize +-- | strippedHostName takes a URI host name, as extracted+-- by 'Network.URI.regName', and strips square brackets+-- around IPv6 addresses.+--+-- The result is suitable for passing to services such as+-- name resolution ('Network.Socket.getAddr').+--+-- @since+strippedHostName :: String -> String+strippedHostName hostName =+ case hostName of+ '[':'v':_ -> hostName -- IPvFuture, no obvious way to deal with this+ '[':rest ->+ case break (== ']') rest of+ (ipv6, "]") -> ipv6+ _ -> hostName -- invalid host name+ _ -> hostName+ withSocket :: (Socket -> IO ()) -> Maybe HostAddress -> String -- ^ host@@ -159,7 +190,7 @@ let hints = NS.defaultHints { NS.addrSocketType = NS.Stream } addrs <- case hostAddress' of Nothing ->- NS.getAddrInfo (Just hints) (Just host') (Just $ show port')+ NS.getAddrInfo (Just hints) (Just $ strippedHostName host') (Just $ show port') Just ha -> return [NS.AddrInfo@@ -184,10 +215,30 @@ NS.connect sock (NS.addrAddress addr) return sock) +-- Pick up an IP using an approximation of the happy-eyeballs algorithm:+-- https://datatracker.ietf.org/doc/html/rfc8305+-- firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a-firstSuccessful [] _ = error "getAddrInfo returned empty list"-firstSuccessful (a:as) cb =- cb a `E.catch` \(e :: E.IOException) ->- case as of- [] -> E.throwIO e- _ -> firstSuccessful as cb+firstSuccessful [] _ = error "getAddrInfo returned empty list"+firstSuccessful addresses cb = do+ result <- newEmptyMVar+ either E.throwIO pure =<<+ withAsync (tryAddresses result)+ (\_ -> takeMVar result)+ where+ -- https://datatracker.ietf.org/doc/html/rfc8305#section-5+ connectionAttemptDelay = 250 * 1000++ tryAddresses result = do+ z <- forConcurrently (zip addresses [0..]) $ \(addr, n) -> do+ when (n > 0) $ threadDelay $ n * connectionAttemptDelay+ tryAddress addr++ case listToMaybe (reverse z) of+ Just e@(Left _) -> tryPutMVar result e+ _ -> error $ "tryAddresses invariant violated: " ++ show addresses+ where+ tryAddress addr = do+ r :: Either E.IOException a <- E.try $! cb addr+ for_ r $ \_ -> tryPutMVar result r+ pure r
Network/HTTP/Client/Core.hs view
@@ -6,12 +6,14 @@ , httpNoBody , httpRaw , httpRaw'+ , requestAction , getModifiedRequestManager , responseOpen , responseClose , httpRedirect , httpRedirect' , withConnection+ , handleClosedRead ) where import Network.HTTP.Types@@ -24,12 +26,15 @@ 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(..)) -- | Perform a @Request@ using a connection acquired from the given @Manager@, -- and then provide the @Response@ to the given function. This function is@@ -92,67 +97,87 @@ 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 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 -- to retrieve the possibly overridden Manager and the possibly modified@@ -218,7 +243,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' @@ -235,6 +260,17 @@ (res, mbReq) <- http0 req' return (res, fromMaybe req0 mbReq, isJust mbReq) +handleClosedRead :: SomeException -> IO L.ByteString+handleClosedRead se+ | Just ConnectionClosed <- fmap unHttpExceptionContentWrapper (fromException se)+ = return L.empty+ | Just (HttpExceptionRequest _ ConnectionClosed) <- fromException se+ = return L.empty+ | Just (IOError _ ResourceVanished _ _ _ _) <- fromException se+ = return L.empty+ | otherwise+ = throwIO se+ -- | Redirect loop. -- -- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@.@@ -258,15 +294,7 @@ -- The connection may already be closed, e.g. -- when using withResponseHistory. See -- https://github.com/snoyberg/http-client/issues/169- `Control.Exception.catch` \se ->- case () of- ()- | Just ConnectionClosed <-- fmap unHttpExceptionContentWrapper- (fromException se) -> return L.empty- | Just (HttpExceptionRequest _ ConnectionClosed) <-- fromException se -> return L.empty- _ -> throwIO se+ `Control.Exception.catch` handleClosedRead responseClose res -- And now perform the actual redirect
Network/HTTP/Client/Headers.hs view
@@ -1,4 +1,6 @@ {-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} module Network.HTTP.Client.Headers@@ -14,11 +16,11 @@ import qualified Data.CaseInsensitive as CI import Data.Maybe (mapMaybe) import Data.Monoid+import Data.Word (Word8) import Network.HTTP.Client.Connection import Network.HTTP.Client.Types-import System.Timeout (timeout) import Network.HTTP.Types-import Data.Word (Word8)+import System.Timeout (timeout) charSpace, charColon, charPeriod :: Word8 charSpace = 32@@ -26,8 +28,8 @@ charPeriod = 46 -parseStatusHeaders :: Connection -> Maybe Int -> Maybe (IO ()) -> IO StatusHeaders-parseStatusHeaders conn timeout' 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@@ -45,23 +47,30 @@ Just s -> return s Nothing -> sendBody >> getStatus + nextStatusHeaders :: IO (Maybe StatusHeaders) nextStatusHeaders = do- (s, v) <- nextStatusLine- if statusCode s == 100- then connectionDropTillBlankLine conn >> return Nothing- else Just . StatusHeaders s v A.<$> parseHeaders (0 :: Int) id+ (s, v) <- nextStatusLine mhl+ if | statusCode s == 100 -> connectionDropTillBlankLine mhl conn >> return Nothing+ | statusCode s == 103 -> do+ earlyHeaders <- parseEarlyHintHeadersUntilFailure 0 id+ onEarlyHintHeaders earlyHeaders+ nextStatusHeaders >>= \case+ Nothing -> return Nothing+ Just (StatusHeaders s' v' earlyHeaders' reqHeaders) ->+ return $ Just $ StatusHeaders s' v' (earlyHeaders <> earlyHeaders') reqHeaders+ | otherwise -> (Just <$>) $ StatusHeaders s v mempty A.<$> parseHeaders 0 id - nextStatusLine :: IO (Status, HttpVersion)- nextStatusLine = do+ nextStatusLine :: Maybe MaxHeaderLength -> IO (Status, HttpVersion)+ nextStatusLine mhl = do -- Ensure that there is some data coming in. If not, we want to signal -- this as a connection problem and not a protocol problem. bs <- connectionRead conn when (S.null bs) $ throwHttp NoResponseDataReceived- connectionReadLineWith conn bs >>= parseStatus 3+ connectionReadLineWith mhl conn bs >>= parseStatus mhl 3 - parseStatus :: Int -> S.ByteString -> IO (Status, HttpVersion)- parseStatus i bs | S.null bs && i > 0 = connectionReadLine conn >>= parseStatus (i - 1)- parseStatus _ bs = do+ parseStatus :: Maybe MaxHeaderLength -> Int -> S.ByteString -> IO (Status, HttpVersion)+ parseStatus mhl i bs | S.null bs && i > 0 = connectionReadLine mhl conn >>= parseStatus mhl (i - 1)+ parseStatus _ _ bs = do let (ver, bs2) = S.break (== charSpace) bs (code, bs3) = S.break (== charSpace) $ S.dropWhile (== charSpace) bs2 msg = S.dropWhile (== charSpace) bs3@@ -82,20 +91,39 @@ Just (i, "") -> Just i _ -> Nothing - parseHeaders 100 _ = throwHttp OverlongHeaders+ 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 count front = do- line <- connectionReadLine conn+ guardMaxNumberHeaders count+ line <- connectionReadLine mhl conn if S.null line then return $ front []- else do- mheader <- parseHeader line- case mheader of+ else+ parseHeader line >>= \case Just header -> parseHeaders (count + 1) $ front . (header:) Nothing -> -- Unparseable header line; rather than throwing -- an exception, ignore it for robustness. parseHeaders count front++ parseEarlyHintHeadersUntilFailure :: Int -> ([Header] -> [Header]) -> IO [Header]+ parseEarlyHintHeadersUntilFailure count front = do+ guardMaxNumberHeaders count+ line <- connectionReadLine mhl conn+ if S.null line+ then return $ front []+ else+ parseHeader line >>= \case+ Just header ->+ parseEarlyHintHeadersUntilFailure (count + 1) $ front . (header:)+ Nothing -> do+ connectionUnreadLine conn line+ return $ front [] parseHeader :: S.ByteString -> IO (Maybe Header) parseHeader bs = do
Network/HTTP/Client/Manager.hs view
@@ -92,6 +92,8 @@ , managerModifyResponse = return , managerProxyInsecure = defaultProxy , managerProxySecure = defaultProxy+ , managerMaxHeaderLength = Just $ MaxHeaderLength 4096+ , managerMaxNumberHeaders = Just $ MaxNumberHeaders 100 } -- | Create a 'Manager'. The @Manager@ will be shut down automatically via@@ -131,6 +133,8 @@ if secure req then httpsProxy req else httpProxy req+ , mMaxHeaderLength = managerMaxHeaderLength ms+ , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager @@ -257,7 +261,9 @@ , "\r\n" ] parse conn = do- StatusHeaders status _ _ <- parseStatusHeaders conn Nothing 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/Request.hs view
@@ -49,6 +49,7 @@ import Control.Monad (unless, guard) import Control.Monad.IO.Class (MonadIO, liftIO) import Numeric (showHex)+import qualified Data.Set as Set import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)@@ -121,9 +122,9 @@ -- You can place the request method at the beginning of the URL separated by a -- space, e.g.: ----- @@@+-- @ -- parseRequest "POST http://httpbin.org/post"--- @@@+-- @ -- -- Note that the request method must be provided as all capital letters. --@@ -302,7 +303,10 @@ Nothing -> throwIO se , requestManagerOverride = Nothing , shouldStripHeaderOnRedirect = const False+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False , proxySecureMode = ProxySecureWithConnect+ , redactHeaders = Set.singleton "Authorization"+ , earlyHintHeadersReceived = \_ -> return () } -- | Parses a URL via 'parseRequest_'@@ -415,6 +419,19 @@ && ("content-encoding", "gzip") `elem` hs' && decompress req (fromMaybe "" $ lookup "content-type" hs') +data EncapsulatedPopperException = EncapsulatedPopperException E.SomeException+ deriving (Show)+instance E.Exception EncapsulatedPopperException++-- | Encapsulate a thrown exception into a custom type+--+-- During streamed body sending, both the Popper and the connection may throw IO exceptions;+-- however, we don't want to route the Popper exceptions through onRequestBodyException.+-- https://github.com/snoyberg/http-client/issues/469+encapsulatePopperException :: IO a -> IO a+encapsulatePopperException action =+ action `E.catch` (\(ex :: E.SomeException) -> E.throwIO (EncapsulatedPopperException ex))+ requestBuilder :: Request -> Connection -> IO (Maybe (IO ())) requestBuilder req Connection {..} = do (contentLength, sendNow, sendLater) <- toTriple (requestBody req)@@ -423,7 +440,10 @@ else sendNow >> return Nothing where expectContinue = Just "100-continue" == lookup "Expect" (requestHeaders req)- checkBadSend f = f `E.catch` onRequestBodyException req+ checkBadSend f = f `E.catches` [+ E.Handler (\(EncapsulatedPopperException ex) -> throwIO ex)+ , E.Handler (onRequestBodyException req)+ ] writeBuilder = toByteStringIO connectionWrite writeHeadersWith contentLength = writeBuilder . (builder contentLength `Data.Monoid.mappend`) flushHeaders contentLength = writeHeadersWith contentLength flush@@ -464,7 +484,7 @@ withStream (loop 0) where loop !n stream = do- bs <- stream+ bs <- encapsulatePopperException stream if S.null bs then case mlen of -- If stream is chunked, no length argument
Network/HTTP/Client/Response.hs view
@@ -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,8 +70,40 @@ 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)@@ -84,21 +113,30 @@ { responseBody = L.fromChunks bss } -getResponse :: Maybe Int+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 timeout' req@(Request {..}) mconn cont = do+getResponse mhl mnh timeout' req@(Request {..}) mconn cont = do let conn = managedResource mconn- StatusHeaders s version hs <- parseStatusHeaders conn timeout' 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 -- should we put this connection back into the connection manager? toPut = Just "close" /= lookup "connection" hs && version > W.HttpVersion 1 0- cleanup bodyConsumed = managedRelease mconn $ if toPut && bodyConsumed then Reuse else DontReuse+ cleanup bodyConsumed = do+ managedRelease mconn $ if toPut && bodyConsumed then Reuse else DontReuse+ -- Keep alive the `Managed Connection` until we're done with it, to prevent an early+ -- collection.+ -- Reasoning: as long as someone holds a reference to the explicit cleanup,+ -- we shouldn't perform an implicit cleanup.+ keepAlive mconn + body <- -- RFC 2616 section 4.4_1 defines responses that must not include a body if hasNoBody method (W.statusCode s) || (mcl == Just 0 && not isChunked)@@ -108,7 +146,7 @@ else do body1 <- if isChunked- then makeChunkedReader (cleanup True) rawBody conn+ then makeChunkedReader mhl (cleanup True) rawBody conn else case mcl of Just len -> makeLengthReader (cleanup True) len conn@@ -125,6 +163,7 @@ , responseCookieJar = Data.Monoid.mempty , responseClose' = ResponseClose (cleanup False) , responseOriginalRequest = req {requestBody = ""}+ , responseEarlyHints = earlyHs } -- | Does this response have no body?
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 (..)@@ -38,6 +39,8 @@ , StreamFileStatus (..) , ResponseTimeout (..) , ProxySecureMode (..)+ , MaxHeaderLength (..)+ , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable)@@ -59,6 +62,7 @@ import Data.IORef import qualified Network.Socket as NS import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Text (Text) import Data.Streaming.Zlib (ZlibException) import Data.CaseInsensitive as CI@@ -88,7 +92,7 @@ } deriving T.Typeable -data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders+data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders RequestHeaders deriving (Show, Eq, Ord, T.Typeable) -- | A newtype wrapper which is not exported from this library but is an@@ -145,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@@ -342,7 +348,7 @@ -- | Define a HTTP proxy, consisting of a hostname and port number. data Proxy = Proxy- { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy.+ { proxyHost :: S.ByteString -- ^ The host name of the HTTP proxy in URI format. IPv6 addresses in square brackets. , proxyPort :: Int -- ^ The port number of the HTTP proxy. } deriving (Show, Read, Eq, Ord, T.Typeable)@@ -494,6 +500,9 @@ -- ^ Requested host name, used for both the IP address to connect to and -- the @host@ request header. --+ -- This is in URI format, with raw IPv6 addresses enclosed in square brackets.+ -- Use 'strippedHostName' when making network connections.+ -- -- Since 0.1.0 , port :: Int -- ^ The port to connect to. Also used for generating the @host@ request header.@@ -611,12 +620,29 @@ -- -- @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. -- -- Default: Use HTTP CONNECT. -- -- @since 0.7.2++ , redactHeaders :: Set.Set HeaderName+ -- ^ List of header values being redacted in case we show Request.+ --+ -- @since 0.7.13++ , earlyHintHeadersReceived :: [Header] -> IO ()+ -- ^ Called every time an HTTP 103 Early Hints header section is received from the server.+ --+ -- @since 0.7.16 } deriving T.Typeable @@ -640,7 +666,7 @@ , " host = " ++ show (host x) , " port = " ++ show (port x) , " secure = " ++ show (secure x)- , " requestHeaders = " ++ show (DL.map redactSensitiveHeader (requestHeaders x))+ , " requestHeaders = " ++ show (DL.map (redactSensitiveHeader $ redactHeaders x) (requestHeaders x)) , " path = " ++ show (path x) , " queryString = " ++ show (queryString x) --, " requestBody = " ++ show (requestBody x)@@ -654,9 +680,11 @@ , "}" ] -redactSensitiveHeader :: Header -> Header-redactSensitiveHeader ("Authorization", _) = ("Authorization", "<REDACTED>")-redactSensitiveHeader h = h+redactSensitiveHeader :: Set.Set HeaderName -> Header -> Header+redactSensitiveHeader toRedact h@(name, _) =+ if name `Set.member` toRedact+ then (name, "<REDACTED>")+ else h -- | A simple representation of the HTTP response. --@@ -692,10 +720,15 @@ -- Since 0.1.0 , responseOriginalRequest :: Request -- ^ Holds original @Request@ related to this @Response@ (with an empty body).- -- This field is intentionally not exported directly, but made availble+ -- This field is intentionally not exported directly, but made available -- via @getOriginalRequest@ instead. -- -- Since 0.7.8+ , responseEarlyHints :: ResponseHeaders+ -- ^ Early response headers sent by the server, as part of an HTTP+ -- 103 Early Hints section.+ --+ -- Since 0.7.16 } deriving (Show, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable) @@ -791,6 +824,18 @@ -- Default: respect the @proxy@ value on the @Request@ itself. -- -- 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 @@ -815,8 +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 @@ -868,3 +915,19 @@ , thisChunkSize :: Int } deriving (Eq, Show, Ord, T.Typeable)++-- | The maximum header size in bytes.+--+-- @since 0.7.14+newtype MaxHeaderLength = MaxHeaderLength+ { unMaxHeaderLength :: Int+ }+ 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.8+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@@ -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@@ -59,6 +59,7 @@ , ghc-prim , stm >= 2.3 , iproute >= 1.7.5+ , async >= 2.0 if flag(network-uri) build-depends: network >= 2.6, network-uri >= 2.6 else@@ -87,6 +88,7 @@ hs-source-dirs: test default-language: Haskell2010 other-modules: Network.HTTP.ClientSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base , http-client , hspec@@ -121,6 +123,8 @@ Network.HTTP.Client.RequestSpec Network.HTTP.Client.RequestBodySpec Network.HTTP.Client.CookieSpec+ Network.HTTP.Client.ConnectionSpec+ build-tool-depends: hspec-discover:hspec-discover build-depends: base , http-client , hspec
test-nonet/Network/HTTP/Client/BodySpec.hs view
@@ -20,42 +20,84 @@ spec = describe "BodySpec" $ do it "chunked, single" $ do (conn, _, input) <- dummyConnection- [ "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed"+ [ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed" ]- reader <- makeChunkedReader (return ()) False conn+ reader <- makeChunkedReader Nothing (return ()) False conn body <- brConsume reader S.concat body `shouldBe` "hello world" input' <- input S.concat input' `shouldBe` "not consumed" brComplete reader `shouldReturn` True + it "chunked, single, with trailers" $ do+ (conn, _, input) <- dummyConnection+ [ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: ignored\r\nbut: consumed\r\n\r\nnot consumed"+ ]+ reader <- makeChunkedReader Nothing (return ()) False conn+ body <- brConsume reader+ S.concat body `shouldBe` "hello world"+ input' <- input+ S.concat input' `shouldBe` "not consumed"+ brComplete reader `shouldReturn` True+ it "chunked, pieces" $ do (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack- "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed"- reader <- makeChunkedReader (return ()) False conn+ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"+ reader <- makeChunkedReader Nothing (return ()) False conn body <- brConsume reader S.concat body `shouldBe` "hello world" input' <- input S.concat input' `shouldBe` "not consumed" brComplete reader `shouldReturn` True + it "chunked, pieces, with trailers" $ do+ (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack+ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: ignored\r\nbut: consumed\r\n\r\nnot consumed"+ reader <- makeChunkedReader Nothing (return ()) False conn+ body <- brConsume reader+ S.concat body `shouldBe` "hello world"+ input' <- input+ S.concat input' `shouldBe` "not consumed"+ brComplete reader `shouldReturn` True+ it "chunked, raw" $ do (conn, _, input) <- dummyConnection- [ "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed"+ [ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed" ]- reader <- makeChunkedReader (return ()) True conn+ reader <- makeChunkedReader Nothing (return ()) True conn body <- brConsume reader- S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n"+ S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n" input' <- input S.concat input' `shouldBe` "not consumed" brComplete reader `shouldReturn` True + it "chunked, raw, with trailers" $ do+ (conn, _, input) <- dummyConnection+ [ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\nnot consumed"+ ]+ reader <- makeChunkedReader Nothing (return ()) True conn+ body <- brConsume reader+ S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\n"+ input' <- input+ S.concat input' `shouldBe` "not consumed"+ brComplete reader `shouldReturn` True+ it "chunked, pieces, raw" $ do (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack- "5\r\nhello\r\n6\r\n world\r\n0\r\nnot consumed"- reader <- makeChunkedReader (return ()) True conn+ "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\nnot consumed"+ reader <- makeChunkedReader Nothing (return ()) True conn body <- brConsume reader- S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n"+ S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\n\r\n"+ input' <- input+ S.concat input' `shouldBe` "not consumed"+ brComplete reader `shouldReturn` True++ it "chunked, pieces, raw, with trailers" $ do+ (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack+ "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\nnot consumed"+ reader <- makeChunkedReader Nothing (return ()) True conn+ body <- brConsume reader+ S.concat body `shouldBe` "5\r\nhello\r\n6\r\n world\r\n0\r\ntrailers-are: returned\r\nin-raw: body\r\n\r\n" input' <- input S.concat input' `shouldBe` "not consumed" brComplete reader `shouldReturn` True
+ test-nonet/Network/HTTP/Client/ConnectionSpec.hs view
@@ -0,0 +1,23 @@+module Network.HTTP.Client.ConnectionSpec where++import Network.HTTP.Client (strippedHostName)+import Test.Hspec++spec :: Spec+spec = do+ describe "strippedHostName" $ do+ it "passes along a normal domain name" $ do+ strippedHostName "example.com" `shouldBe` "example.com"+ it "passes along an IPv4 address" $ do+ strippedHostName "127.0.0.1" `shouldBe` "127.0.0.1"+ it "strips brackets of an IPv4 address" $ do+ strippedHostName "[::1]" `shouldBe` "::1"+ strippedHostName "[::127.0.0.1]" `shouldBe` "::127.0.0.1"++ describe "pathological cases" $ do+ -- just need to handle these gracefully, it's unclear+ -- what the result should be+ it "doesn't touch future ip address formats" $ do+ strippedHostName "[v2.huh]" `shouldBe` "[v2.huh]"+ it "doesn't strip trailing stuff" $ do+ strippedHostName "[::1]foo" `shouldBe` "[::1]foo"
test-nonet/Network/HTTP/Client/HeadersSpec.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Client.HeadersSpec where +import Control.Concurrent.MVar+import qualified Data.Sequence as Seq import Network.HTTP.Client.Internal import Network.HTTP.Types import Test.Hspec@@ -20,8 +23,8 @@ , "\nignored" ] (connection, _, _) <- dummyConnection input- statusHeaders <- parseStatusHeaders connection Nothing Nothing- statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)+ statusHeaders <- parseStatusHeaders Nothing Nothing connection Nothing (\_ -> return ()) Nothing+ statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) mempty [ ("foo", "bar") , ("baz", "bin") ]@@ -34,8 +37,8 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data"- statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody)- statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]+ statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody)+ statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` ["data"]) it "Expect: 100-continue (failure)" $ do@@ -44,8 +47,8 @@ ] (conn, out, _) <- dummyConnection input let sendBody = connectionWrite conn "data"- statusHeaders <- parseStatusHeaders conn Nothing (Just sendBody)- statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) []+ statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) (Just sendBody)+ statusHeaders `shouldBe` StatusHeaders status417 (HttpVersion 1 1) [] [] out >>= (`shouldBe` []) it "100 Continue without expectation is OK" $ do@@ -56,7 +59,72 @@ , "result" ] (conn, out, inp) <- dummyConnection input- statusHeaders <- parseStatusHeaders conn Nothing Nothing- statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [ ("foo", "bar") ]+ statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing (\_ -> return ()) Nothing+ statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1) [] [ ("foo", "bar") ] out >>= (`shouldBe` []) inp >>= (`shouldBe` ["result"])++ it "103 early hints" $ do+ let input =+ [ "HTTP/1.1 103 Early Hints\r\n"+ , "Link: </foo.js>\r\n"+ , "Link: </bar.js>\r\n\r\n"+ , "HTTP/1.1 200 OK\r\n"+ , "Content-Type: text/html\r\n\r\n"+ , "<div></div>"+ ]+ (conn, _, inp) <- dummyConnection input++ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty+ let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h))++ statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing+ statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)+ [("Link", "</foo.js>")+ , ("Link", "</bar.js>")+ ]+ [("Content-Type", "text/html")+ ]++ inp >>= (`shouldBe` ["<div></div>"])++ readMVar callbackResults+ >>= (`shouldBe` Seq.fromList [+ [("Link", "</foo.js>")+ , ("Link", "</bar.js>")+ ]])++ it "103 early hints (multiple sections)" $ do+ let input =+ [ "HTTP/1.1 103 Early Hints\r\n"+ , "Link: </foo.js>\r\n"+ , "Link: </bar.js>\r\n\r\n"+ , "HTTP/1.1 103 Early Hints\r\n"+ , "Link: </baz.js>\r\n\r\n"+ , "HTTP/1.1 200 OK\r\n"+ , "Content-Type: text/html\r\n\r\n"+ , "<div></div>"+ ]+ (conn, _, inp) <- dummyConnection input++ callbackResults :: MVar (Seq.Seq [Header]) <- newMVar mempty+ let onEarlyHintHeader h = modifyMVar_ callbackResults (return . (Seq.|> h))++ statusHeaders <- parseStatusHeaders Nothing Nothing conn Nothing onEarlyHintHeader Nothing+ statusHeaders `shouldBe` StatusHeaders status200 (HttpVersion 1 1)+ [("Link", "</foo.js>")+ , ("Link", "</bar.js>")+ , ("Link", "</baz.js>")+ ]+ [("Content-Type", "text/html")+ ]++ inp >>= (`shouldBe` ["<div></div>"])++ readMVar callbackResults+ >>= (`shouldBe` Seq.fromList [+ [("Link", "</foo.js>")+ , ("Link", "</bar.js>")+ ]+ , [("Link", "</baz.js>")]+ ])
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do- let getResponse' conn = getResponse 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@@ -59,7 +59,7 @@ , "Transfer-encoding: chunked\r\n\r\n" , "5\r\nHello\r" , "\n2\r\n W"- , "\r\n4 ignored\r\norld\r\n0\r\nHTTP/1.1"+ , "\r\n4 ignored\r\norld\r\n0\r\n\r\nHTTP/1.1" ] Response {..} <- getResponse' conn responseStatus `shouldBe` status200
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 @@ -39,6 +42,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@@ -177,6 +201,30 @@ 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 }@@ -278,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"
test/Network/HTTP/ClientSpec.hs view
@@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where +import Control.Concurrent (threadDelay) import qualified Data.ByteString.Char8 as BS import Network.HTTP.Client import Network.HTTP.Client.Internal import Network.HTTP.Types (status200, found302, status405) import Network.HTTP.Types.Status+import qualified Network.Socket as NS import Test.Hspec import Control.Applicative ((<$>)) import Data.ByteString.Lazy.Char8 () -- orphan instance+import System.Mem (performGC) main :: IO () main = hspec spec@@ -21,6 +24,31 @@ res <- httpLbs req man responseStatus res `shouldBe` status200 + -- Test the failure condition described in https://github.com/snoyberg/http-client/issues/489+ it "keeps connection alive long enough" $ do+ req <- parseUrlThrow "http://httpbin.org/"+ man <- newManager defaultManagerSettings+ res <- responseOpen req man+ responseStatus res `shouldBe` status200+ let+ getChunk = responseBody res+ drainAll = do+ chunk <- getChunk+ if BS.null chunk then pure () else drainAll++ -- The returned `BodyReader` used to not contain a reference to the `Managed Connection`,+ -- only to the extracted connection and to the release action. Therefore, triggering a GC+ -- would close the connection even though we were not done reading.+ performGC+ -- Not ideal, but weak finalizers run on a separate thread, so it's racing with our drain+ -- call+ threadDelay 500000++ drainAll+ -- Calling `responseClose res` here prevents the early collection from happening in this+ -- test, but in a larger production application that did involve a `responseClose`, it still+ -- occurred.+ describe "method in URL" $ do it "success" $ do req <- parseUrlThrow "POST http://httpbin.org/post"@@ -106,3 +134,23 @@ man <- newManager settings response <- httpLbs "http://httpbin.org/redirect-to?url=foo" man responseStatus response `shouldBe` found302++ -- skipped because CI doesn't have working IPv6+ xdescribe "raw IPV6 address as hostname" $ do+ it "works" $ do+ -- We rely on example.com serving a web page over IPv6.+ -- The request (currently) actually ends up as 404 due to+ -- virtual hosting, but we just care that the networking+ -- side works.+ (addr:_) <- NS.getAddrInfo+ (Just NS.defaultHints { NS.addrFamily = NS.AF_INET6 })+ (Just "example.com")+ (Just "http")+ -- ipv6Port will be of the form [::1]:80, which is good enough+ -- for our purposes; ideally we'd easily get just the ::1.+ let ipv6Port = show $ NS.addrAddress addr+ ipv6Port `shouldStartWith` "["+ req <- parseUrlThrow $ "http://" ++ ipv6Port+ man <- newManager defaultManagerSettings+ _ <- httpLbs (setRequestIgnoreStatus req) man+ return ()