http-client 0.5.14 → 0.7.19
raw patch · 23 files changed
Files
- ChangeLog.md +124/−0
- Network/HTTP/Client.hs +37/−8
- Network/HTTP/Client/Body.hs +43/−21
- Network/HTTP/Client/Connection.hs +93/−32
- Network/HTTP/Client/Cookies.hs +37/−3
- Network/HTTP/Client/Core.hs +94/−60
- Network/HTTP/Client/Headers.hs +57/−23
- Network/HTTP/Client/Manager.hs +34/−16
- Network/HTTP/Client/MultipartFormData.hs +32/−25
- Network/HTTP/Client/Request.hs +81/−20
- Network/HTTP/Client/Response.hs +66/−14
- Network/HTTP/Client/Types.hs +179/−31
- Network/HTTP/Client/Util.hs +9/−9
- Network/HTTP/Proxy.hs +1/−1
- README.md +1/−1
- http-client.cabal +10/−4
- test-nonet/Network/HTTP/Client/BodySpec.hs +55/−13
- test-nonet/Network/HTTP/Client/ConnectionSpec.hs +23/−0
- test-nonet/Network/HTTP/Client/CookieSpec.hs +51/−1
- test-nonet/Network/HTTP/Client/HeadersSpec.hs +76/−8
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +2/−2
- test-nonet/Network/HTTP/ClientSpec.hs +102/−9
- test/Network/HTTP/ClientSpec.hs +63/−3
ChangeLog.md view
@@ -1,5 +1,129 @@ # 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`.++## 0.7.7++* Allow secure cookies for localhost without HTTPS [#460](https://github.com/snoyberg/http-client/pull/460)++## 0.7.6++* Add `applyBearerAuth` function [#457](https://github.com/snoyberg/http-client/pull/457/files)++## 0.7.5++* Force closing connections in case of exceptions throwing [#454](https://github.com/snoyberg/http-client/pull/454).++## 0.7.4++* Depend on base64-bytestring instead of memory [#453](https://github.com/snoyberg/http-client/pull/453)++## 0.7.3++* Added `withSocket` to `Network.HTTP.Client.Connection`.++## 0.7.2.1++* Fix bug in `useProxySecureWithoutConnect`.++## 0.7.2++* Add a new proxy mode, proxySecureWithoutConnect, for sending HTTPS requests in plain text to a proxy without using the CONNECT method.++## 0.7.1++* Remove `AI_ADDRCONFIG` [#400](https://github.com/snoyberg/http-client/issues/400)++## 0.7.0++* Remove Eq instances for Cookie, CookieJar, Response, Ord instance for Cookie [#435](https://github.com/snoyberg/http-client/pull/435)++## 0.6.4.1++* Win32 2.8 support [#430](https://github.com/snoyberg/http-client/pull/430)++## 0.6.4++* Avoid throwing an exception when a malformed HTTP header is received,+ to be as robust as commonly used HTTP clients.+ See [#398](https://github.com/snoyberg/http-client/issues/398)++## 0.6.3++* Detect response body termination before reading an extra null chunk+ when possible. This allows connections to be reused in some corner+ cases. See+ [#395](https://github.com/snoyberg/http-client/issues/395)++## 0.6.2++* Add `shouldStripHeaderOnRedirect` option to `Request` [#300](https://github.com/snoyberg/http-client/issues/300)++## 0.6.1.1++* Ensure that `Int` parsing doesn't overflow [#383](https://github.com/snoyberg/http-client/issues/383)++## 0.6.1++* Add `setUriEither` to `Network.HTTP.Client.Internal`++## 0.6.0++* Generalize `renderParts` over arbitrary applicative functors. One particular+ use case that is enabled by this change is that now `renderParts` can be used+ in pure code by using it in combination with `runIdentity`.+ ## 0.5.14 * Omit port for `getUri` when protocol is `http` and port is `80`, or when
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 --@@ -40,7 +40,7 @@ -- application which will make a large number of requests to different hosts, -- and will never make more than one connection to a single host, then sharing -- a 'Manager' will result in idle connections being kept open longer than--- necessary. In such a situation, it makes sense to use 'withManager' around+-- necessary. In such a situation, it makes sense to use 'newManager' before -- each new request, to avoid running out of file descriptors. (Note that the -- 'managerIdleConnectionCount' setting mitigates the risk of leaking too many -- file descriptors.)@@ -112,10 +112,13 @@ , managerSetProxy , managerSetInsecureProxy , managerSetSecureProxy+ , managerSetMaxHeaderLength+ , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy , useProxy+ , useProxySecureWithoutConnect , proxyEnvironment , proxyEnvironmentNamed , defaultProxy@@ -137,6 +140,7 @@ , requestFromURI_ , defaultRequest , applyBasicAuth+ , applyBearerAuth , urlEncodedBody , getUri , setRequestIgnoreStatus@@ -159,10 +163,14 @@ , applyBasicProxyAuth , decompress , redirectCount+ , shouldStripHeaderOnRedirect+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly , checkResponse , responseTimeout , cookieJar , requestVersion+ , redactHeaders+ , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper@@ -178,6 +186,8 @@ , responseHeaders , responseBody , responseCookieJar+ , getOriginalRequest+ , responseEarlyHints , throwErrorStatusCodes -- ** Response body , BodyReader@@ -191,15 +201,21 @@ , HttpException (..) , HttpExceptionContent (..) , Cookie (..)+ , equalCookie+ , equivCookie+ , compareCookies , CookieJar+ , equalCookieJar+ , 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@@ -214,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. --@@ -253,6 +269,7 @@ (responseBody res') } case getRedirectedRequest+ req req' (responseHeaders res) (responseCookieJar res)@@ -261,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@@ -304,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 --@@ -338,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 }@@ -350,7 +378,8 @@ -- > print $ responseBody response -- --- | Specify a response timeout in microseconds+-- | Specify maximum time in microseconds the retrieval of response+-- headers is allowed to take -- -- @since 0.5.0 responseTimeoutMicro :: Int -> ResponseTimeout
Network/HTTP/Client/Body.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} module Network.HTTP.Client.Body ( makeChunkedReader , makeLengthReader@@ -8,7 +9,6 @@ , brConsume , brEmpty , constBodyReader- , brAddCleanup , brReadSome , brRead ) where@@ -23,7 +23,7 @@ import Control.Monad (unless, when) import qualified Data.Streaming.Zlib as Z --- ^ Get a single chunk of data from the response body, or an empty+-- | Get a single chunk of data from the response body, or an empty -- bytestring if no more data is available. -- -- Note that in order to consume the entire request body, you will need to@@ -61,12 +61,6 @@ [] -> ([], S.empty) x:xs -> (xs, x) -brAddCleanup :: IO () -> BodyReader -> BodyReader-brAddCleanup cleanup brRead' = do- bs <- brRead'- when (S.null bs) cleanup- return bs- -- | Strictly consume all remaining chunks of data from the stream. -- -- Since 0.1.0@@ -111,16 +105,25 @@ Nothing -> start Just popper -> goPopper popper -makeUnlimitedReader :: Connection -> IO BodyReader-makeUnlimitedReader Connection {..} = do+makeUnlimitedReader+ :: IO () -- ^ cleanup+ -> Connection+ -> IO BodyReader+makeUnlimitedReader cleanup Connection {..} = do icomplete <- newIORef False return $ do bs <- connectionRead- when (S.null bs) $ writeIORef icomplete True+ when (S.null bs) $ do+ writeIORef icomplete True+ cleanup return bs -makeLengthReader :: Int -> Connection -> IO BodyReader-makeLengthReader count0 Connection {..} = do+makeLengthReader+ :: IO () -- ^ cleanup+ -> Int+ -> Connection+ -> IO BodyReader+makeLengthReader cleanup count0 Connection {..} = do icount <- newIORef count0 return $ do count <- readIORef icount@@ -134,20 +137,28 @@ let (x, y) = S.splitAt count bs connectionUnread y writeIORef icount (-1)+ cleanup return x EQ -> do writeIORef icount (-1)+ cleanup return bs GT -> do writeIORef icount (count - S.length bs) return bs -makeChunkedReader :: Bool -- ^ raw- -> Connection- -> IO BodyReader-makeChunkedReader raw conn@Connection {..} = do+makeChunkedReader+ :: Maybe MaxHeaderLength+ -> IO () -- ^ cleanup+ -> Bool -- ^ raw+ -> Connection+ -> IO BodyReader+makeChunkedReader mhl cleanup raw conn@Connection {..} = do icount <- newIORef 0- return $ go icount+ return $ do+ bs <- go icount+ when (S.null bs) cleanup+ pure bs where go icount = do count0 <- readIORef icount@@ -157,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'@@ -188,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)@@ -213,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,46 +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'@@ -52,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@@ -144,14 +158,39 @@ -> String -- ^ host -> Int -- ^ port -> IO Connection-openSocketConnectionSize tweakSocket chunksize hostAddress' host' port' = do- let hints = NS.defaultHints {- NS.addrFlags = [NS.AI_ADDRCONFIG]- , NS.addrSocketType = NS.Stream- }+openSocketConnectionSize tweakSocket chunksize hostAddress' host' port' =+ 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+ -> Int -- ^ port+ -> (Socket -> IO a)+ -> IO a+withSocket tweakSocket hostAddress' host' port' f = do+ 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@@ -163,21 +202,43 @@ , NS.addrCanonName = Nothing }] - firstSuccessful addrs $ \addr ->- E.bracketOnError- (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)- (NS.addrProtocol addr))- NS.close- (\sock -> do- NS.setSocketOption sock NS.NoDelay 1- tweakSocket sock- NS.connect sock (NS.addrAddress addr)- socketConnection sock chunksize)+ E.bracketOnError (firstSuccessful addrs $ openSocket tweakSocket) NS.close f +openSocket tweakSocket addr =+ E.bracketOnError+ (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)+ (NS.addrProtocol addr))+ NS.close+ (\sock -> do+ NS.setSocketOption sock NS.NoDelay 1+ tweakSocket sock+ 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/Cookies.hs view
@@ -14,6 +14,7 @@ , removeExistingCookieFromCookieJar , domainMatches , isIpAddress+ , isPotentiallyTrustworthyOrigin , defaultPath ) where @@ -29,6 +30,8 @@ import qualified Network.PublicSuffixList.Lookup as PSL import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)+import qualified Data.IP as IP+import Text.Read (readMaybe) import Network.HTTP.Client.Types as Req @@ -100,7 +103,7 @@ where (mc, lc) = removeExistingCookieFromCookieJarHelper cookie (expose cookie_jar') removeExistingCookieFromCookieJarHelper _ [] = (Nothing, []) removeExistingCookieFromCookieJarHelper c (c' : cs)- | c == c' = (Just c', cs)+ | c `equivCookie` c' = (Just c', cs) | otherwise = (cookie', c' : cookie_jar'') where (cookie', cookie_jar'') = removeExistingCookieFromCookieJarHelper c cs @@ -111,6 +114,37 @@ isPublicSuffix :: BS.ByteString -> Bool isPublicSuffix = PSL.isSuffix . decodeUtf8With lenientDecode +-- | Algorithm described in \"Secure Contexts\", Section 3.1, \"Is origin potentially trustworthy?\"+--+-- Note per RFC6265 section 5.4 user agent is free to define the meaning of "secure" protocol.+--+-- See:+-- https://w3c.github.io/webappsec-secure-contexts/#is-origin-trustworthy+isPotentiallyTrustworthyOrigin :: Bool -- ^ True if HTTPS+ -> BS.ByteString -- ^ Host+ -> Bool -- ^ Whether or not the origin is potentially trustworthy+isPotentiallyTrustworthyOrigin secure host+ | secure = True -- step 3+ | isLoopbackAddr4 = True -- step 4, part 1+ | isLoopbackAddr6 = True -- step 4, part 2+ | isLoopbackHostname = True -- step 5+ | otherwise = False+ where isLoopbackHostname =+ host == "localhost"+ || host == "localhost."+ || BS.isSuffixOf ".localhost" host+ || BS.isSuffixOf ".localhost." host+ isLoopbackAddr4 =+ fmap (take 1 . IP.fromIPv4) (readMaybe (S8.unpack host)) == Just [127]+ isLoopbackAddr6 =+ fmap IP.toHostAddress6 maddr6 == Just (0, 0, 0, 1)+ maddr6 = do+ (c1, rest1) <- S8.uncons host+ (rest2, c2) <- S8.unsnoc rest1+ case [c1, c2] of+ "[]" -> readMaybe (S8.unpack rest2)+ _ -> Nothing+ -- | This corresponds to the eviction algorithm described in Section 5.3 \"Storage Model\" evictExpiredCookies :: CookieJar -- ^ Input cookie jar -> UTCTime -- ^ Value that should be used as \"now\"@@ -143,12 +177,12 @@ condition2 = pathMatches (Req.path request) (cookie_path cookie) condition3 | not (cookie_secure_only cookie) = True- | otherwise = Req.secure request+ | otherwise = isPotentiallyTrustworthyOrigin (Req.secure request) (Req.host request) condition4 | not (cookie_http_only cookie) = True | otherwise = is_http_api matching_cookies = filter matching_cookie $ expose cookie_jar- output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies+ output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sortBy compareCookies matching_cookies output_line = toByteString $ renderCookies $ output_cookies folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar'''
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,61 +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 -> 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 res -> do- now <- getCurrentTime- let timeSpentMicro = diffUTCTime now before * 1000000- remainingTime = round $ fromIntegral timeout' - timeSpentMicro- if remainingTime <= 0- then throwHttp ConnectionTimeout- else return (Just remainingTime, res)+ 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@@ -212,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' @@ -229,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@.@@ -252,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@@ -12,14 +14,13 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.CaseInsensitive as CI-import Data.Char (ord) 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@@ -27,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@@ -46,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@@ -83,20 +91,46 @@ 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- header <- parseHeader line- parseHeaders (count + 1) $ front . (header:)+ 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 - parseHeader :: S.ByteString -> IO Header+ 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 let (key, bs2) = S.break (== charColon) bs- when (S.null bs2) $ throwHttp $ InvalidHeader bs- return (CI.mk $! strip key, strip $! S.drop 1 bs2)+ if S.null bs2+ then return Nothing+ else return (Just (CI.mk $! strip key, strip $! S.drop 1 bs2)) strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace)
Network/HTTP/Client/Manager.hs view
@@ -17,6 +17,7 @@ , proxyEnvironmentNamed , defaultProxy , dropProxyAuthSecure+ , useProxySecureWithoutConnect ) where import qualified Data.ByteString.Char8 as S8@@ -91,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@@ -130,6 +133,8 @@ if secure req then httpsProxy req else httpProxy req+ , mMaxHeaderLength = managerMaxHeaderLength ms+ , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager @@ -210,21 +215,23 @@ connkey = connKey req connKey :: Request -> ConnKey-connKey req =- case proxy req of- Nothing- | secure req -> simple CKSecure- | otherwise -> simple CKRaw- Just p- | secure req -> CKProxy- (proxyHost p)- (proxyPort p)- (lookup "Proxy-Authorization" (requestHeaders req))- (host req)- (port req)- | otherwise -> CKRaw Nothing (proxyHost p) (proxyPort p)- where- simple con = con (hostAddress req) (host req) (port req)+connKey req@Request { proxy = Nothing, secure = False } =+ CKRaw (hostAddress req) (host req) (port req)+connKey req@Request { proxy = Nothing, secure = True } =+ CKSecure (hostAddress req) (host req) (port req)+connKey Request { proxy = Just p, secure = False } =+ CKRaw Nothing (proxyHost p) (proxyPort p)+connKey req@Request { proxy = Just p, secure = True,+ proxySecureMode = ProxySecureWithConnect } =+ CKProxy+ (proxyHost p)+ (proxyPort p)+ (lookup "Proxy-Authorization" (requestHeaders req))+ (host req)+ (port req)+connKey Request { proxy = Just p, secure = True,+ proxySecureMode = ProxySecureWithoutConnect } =+ CKRaw Nothing (proxyHost p) (proxyPort p) mkCreateConnection :: ManagerSettings -> IO (ConnKey -> IO Connection) mkCreateConnection ms = do@@ -254,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@@ -285,6 +294,15 @@ -- Since 0.4.7 useProxy :: Proxy -> ProxyOverride useProxy p = ProxyOverride $ const $ return $ \req -> req { proxy = Just p }++-- | Send secure requests to the proxy in plain text rather than using CONNECT,+-- regardless of the value in the @Request@.+--+-- @since 0.7.2+useProxySecureWithoutConnect :: Proxy -> ProxyOverride+useProxySecureWithoutConnect p = ProxyOverride $+ const $ return $ \req -> req { proxy = Just p,+ proxySecureMode = ProxySecureWithoutConnect } -- | Get the proxy settings from the default environment variable (@http_proxy@ -- for insecure, @https_proxy@ for secure). If no variable is set, then fall
Network/HTTP/Client/MultipartFormData.hs view
@@ -24,6 +24,7 @@ ( -- * Part type Part+ ,PartM ,partName ,partFilename ,partContentType@@ -77,17 +78,19 @@ import Control.Monad import Data.ByteString.Lazy.Internal (defaultChunkSize) +type Part = PartM IO+ -- | A single part of a multipart message.-data Part = Part+data PartM m = Part { partName :: Text -- ^ Name of the corresponding \<input\> , partFilename :: Maybe String -- ^ A file name, if this is an attached file , partContentType :: Maybe MimeType -- ^ Content type , partHeaders :: [Header] -- ^ List of additional headers- , partGetBody :: IO RequestBody -- ^ Action in m which returns the body+ , partGetBody :: m RequestBody -- ^ Action in m which returns the body -- of a message. } -instance Show Part where+instance Show (PartM m) where showsPrec d (Part n f c h _) = showParen (d>=11) $ showString "Part " . showsPrec 11 n@@ -104,19 +107,21 @@ -- -- The 'Part' does not have a file name or content type associated -- with it.-partBS :: Text -- ^ Name of the corresponding \<input\>.+partBS :: Applicative m+ => Text -- ^ Name of the corresponding \<input\>. -> BS.ByteString -- ^ The body for this 'Part'.- -> Part-partBS n b = Part n Data.Monoid.mempty mempty mempty $ return $ RequestBodyBS b+ -> PartM m+partBS n b = Part n Data.Monoid.mempty mempty mempty $ pure $ RequestBodyBS b -- | Make a 'Part' whose content is a lazy 'BL.ByteString'. -- -- The 'Part' does not have a file name or content type associated -- with it.-partLBS :: Text -- ^ Name of the corresponding \<input\>.+partLBS :: Applicative m+ => Text -- ^ Name of the corresponding \<input\>. -> BL.ByteString -- ^ The body for this 'Part'.- -> Part-partLBS n b = Part n mempty mempty mempty $ return $ RequestBodyLBS b+ -> PartM m+partLBS n b = Part n mempty mempty mempty $ pure $ RequestBodyLBS b -- | Make a 'Part' from a file. --@@ -179,12 +184,13 @@ -- > partFileRequestBody "file" mempty mempty -- -- The 'Part' does not have a content type associated with it.-partFileRequestBody :: Text -- ^ Name of the corresponding \<input\>.+partFileRequestBody :: Applicative m+ => Text -- ^ Name of the corresponding \<input\>. -> FilePath -- ^ File name to supply to the server. -> RequestBody -- ^ Data to upload.- -> Part+ -> PartM m partFileRequestBody n f rqb =- partFileRequestBodyM n f $ return rqb+ partFileRequestBodyM n f $ pure rqb -- | Construct a 'Part' from action returning the 'RequestBody' --@@ -195,8 +201,8 @@ -- The 'Part' does not have a content type associated with it. partFileRequestBodyM :: Text -- ^ Name of the corresponding \<input\>. -> FilePath -- ^ File name to supply to the server.- -> IO RequestBody -- ^ Action that will supply data to upload.- -> Part+ -> m RequestBody -- ^ Action that will supply data to upload.+ -> PartM m partFileRequestBodyM n f rqb = Part n (Just f) (Just $ defaultMimeLookup $ pack f) mempty rqb @@ -205,12 +211,13 @@ cp bs = RequestBodyBuilder (fromIntegral $ BS.length bs) $ copyByteString bs -- | Add a list of additional headers to this 'Part'.-addPartHeaders :: Part -> [Header] -> Part+addPartHeaders :: PartM m -> [Header] -> PartM m addPartHeaders p hs = p { partHeaders = partHeaders p <> hs } -renderPart :: BS.ByteString -- ^ Boundary between parts.- -> Part -> IO RequestBody-renderPart boundary (Part name mfilename mcontenttype hdrs get) = liftM render get+renderPart :: Functor m+ => BS.ByteString -- ^ Boundary between parts.+ -> PartM m -> m RequestBody+renderPart boundary (Part name mfilename mcontenttype hdrs get) = render <$> get where render renderBody = cp "--" <> cp boundary <> cp "\r\n" <> cp "Content-Disposition: form-data; name=\""@@ -234,9 +241,10 @@ <> renderBody <> cp "\r\n" -- | Combine the 'Part's to form multipart/form-data body-renderParts :: BS.ByteString -- ^ Boundary between parts.- -> [Part] -> IO RequestBody-renderParts boundary parts = (fin . mconcat) `liftM` mapM (renderPart boundary) parts+renderParts :: Applicative m+ => BS.ByteString -- ^ Boundary between parts.+ -> [PartM m] -> m RequestBody+renderParts boundary parts = (fin . mconcat) <$> traverse (renderPart boundary) parts where fin = (<> cp "--" <> cp boundary <> cp "--\r\n") -- | Generate a boundary simillar to those generated by WebKit-based browsers.@@ -273,13 +281,12 @@ formDataBodyWithBoundary boundary a b -- | Add form data with supplied boundary-formDataBodyWithBoundary :: BS.ByteString -> [Part] -> Request -> IO Request+formDataBodyWithBoundary :: Applicative m => BS.ByteString -> [PartM m] -> Request -> m Request formDataBodyWithBoundary boundary parts req = do- body <- renderParts boundary parts- return $ req+ (\ body -> req { method = methodPost , requestHeaders = (hContentType, "multipart/form-data; boundary=" <> boundary) : Prelude.filter (\(x, _) -> x /= hContentType) (requestHeaders req) , requestBody = body- }+ }) <$> renderParts boundary parts
Network/HTTP/Client/Request.hs view
@@ -17,11 +17,13 @@ , setUriRelative , getUri , setUri+ , setUriEither , browserDecompress , alwaysDecompress , addProxy , applyBasicAuth , applyBasicProxyAuth+ , applyBearerAuth , urlEncodedBody , needsGunzip , requestBuilder@@ -35,10 +37,11 @@ , observedStreamFile , extractBasicAuthInfo , throwErrorStatusCodes+ , addProxySecureWithoutConnect ) where import Data.Int (Int64)-import Data.Maybe (fromMaybe, isJust, isNothing)+import Data.Maybe (fromMaybe, isNothing) import Data.Monoid (mempty, mappend, (<>)) import Data.String (IsString(..)) import Data.Char (toLower)@@ -46,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)@@ -61,7 +65,7 @@ import Control.Exception (throw, throwIO, IOException) import qualified Control.Exception as E import qualified Data.CaseInsensitive as CI-import qualified Data.ByteArray.Encoding as BAE+import qualified Data.ByteString.Base64 as B64 import Network.HTTP.Client.Body import Network.HTTP.Client.Types@@ -118,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. --@@ -226,9 +230,18 @@ -- | Validate a 'URI', then add it to the request. setUri :: MonadThrow m => Request -> URI -> m Request-setUri req uri = do+setUri req uri = either throwInvalidUrlException return (setUriEither req uri)+ where+ throwInvalidUrlException = throwM . InvalidUrlException (show uri)++-- | A variant of `setUri` that returns an error message on validation errors,+-- instead of propagating them with `throwM`.+--+-- @since 0.6.1+setUriEither :: Request -> URI -> Either String Request+setUriEither req uri = do sec <- parseScheme uri- auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri+ auth <- maybe (Left "URL must be absolute") return $ uriAuthority uri port' <- parsePort sec auth return $ applyAnyUriBasedAuth uri req { host = S8.pack $ uriRegName auth@@ -241,22 +254,19 @@ , queryString = S8.pack $ uriQuery uri } where- failUri :: MonadThrow m => String -> m a- failUri = throwM . InvalidUrlException (show uri)- parseScheme URI{uriScheme = scheme} = case map toLower scheme of "http:" -> return False "https:" -> return True- _ -> failUri "Invalid scheme"+ _ -> Left "Invalid scheme" parsePort sec URIAuth{uriPort = portStr} = case portStr of -- If the user specifies a port, then use it ':':rest -> maybe- (failUri "Invalid port")+ (Left "Invalid port") return- (readDec rest)+ (readPositiveInt rest) -- Otherwise, use the default port _ -> case sec of False {- HTTP -} -> return 80@@ -292,6 +302,11 @@ Just (_ :: IOException) -> return () Nothing -> throwIO se , requestManagerOverride = Nothing+ , shouldStripHeaderOnRedirect = const False+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly = False+ , proxySecureMode = ProxySecureWithConnect+ , redactHeaders = Set.singleton "Authorization"+ , earlyHintHeadersReceived = \_ -> return () } -- | Parses a URL via 'parseRequest_'@@ -316,7 +331,7 @@ -> S8.ByteString -- ^ Password -> S8.ByteString buildBasicAuth user passwd =- S8.append "Basic " (BAE.convertToBase BAE.Base64 (S8.concat [ user, ":", passwd ]))+ S8.append "Basic " (B64.encode (S8.concat [ user, ":", passwd ])) -- | Add a Basic Auth header (with the specified user name and password) to the -- given Request. Ignore error handling:@@ -334,6 +349,22 @@ where authHeader = (CI.mk "Authorization", buildBasicAuth user passwd) +-- | Build a bearer-auth header value+buildBearerAuth ::+ S8.ByteString -- ^ Token+ -> S8.ByteString+buildBearerAuth token =+ S8.append "Bearer " token++-- | Add a Bearer Auth header to the given 'Request'+--+-- @since 0.7.6+applyBearerAuth :: S.ByteString -> Request -> Request+applyBearerAuth bearerToken req =+ req { requestHeaders = authHeader : requestHeaders req }+ where+ authHeader = (CI.mk "Authorization", buildBearerAuth bearerToken)+ -- | Add a proxy to the Request so that the Request when executed will use -- the provided proxy. --@@ -342,6 +373,13 @@ addProxy hst prt req = req { proxy = Just $ Proxy hst prt } ++-- | Send secure requests to the proxy in plain text rather than using CONNECT.+--+-- @since 0.7.2+addProxySecureWithoutConnect :: Request -> Request+addProxySecureWithoutConnect req = req { proxySecureMode = ProxySecureWithoutConnect }+ -- | Add a Proxy-Authorization header (with the specified username and -- password) to the given 'Request'. Ignore error handling: --@@ -381,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)@@ -389,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@@ -430,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@@ -457,10 +511,17 @@ | secure req = fromByteString "https://" | otherwise = fromByteString "http://" - requestHostname- | isJust (proxy req) && not (secure req)- = requestProtocol <> fromByteString hh- | otherwise = mempty+ requestHostname (Request { proxy = Nothing }) = mempty+ requestHostname (Request { proxy = Just _,+ secure = False }) =+ requestProtocol <> fromByteString hh+ requestHostname (Request { proxy = Just _,+ secure = True,+ proxySecureMode = ProxySecureWithConnect }) = mempty+ requestHostname (Request { proxy = Just _,+ secure = True,+ proxySecureMode = ProxySecureWithoutConnect }) =+ requestProtocol <> fromByteString hh contentLengthHeader (Just contentLength') = if method req `elem` ["GET", "HEAD"] && contentLength' == 0@@ -490,7 +551,7 @@ builder contentLength = fromByteString (method req) <> fromByteString " "- <> requestHostname+ <> requestHostname req <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromChar '/' <> fromByteString (path req))
Network/HTTP/Client/Response.hs view
@@ -4,6 +4,7 @@ ( getRedirectedRequest , getResponse , lbsResponse+ , getOriginalRequest ) where import Data.ByteString (ByteString)@@ -13,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)@@ -42,18 +44,18 @@ -- > (\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')- req' <- setUriRelative req =<< parseURIReference l+ req' <- fmap stripHeaders <$> setUriRelative req =<< parseURIReference l return $ if code == 302 || code == 303 -- According to the spec, this should *only* be for status code@@ -68,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)@@ -79,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- let mcl = lookup "content-length" hs >>= readDec . S8.unpack+ 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)@@ -103,15 +146,14 @@ else do body1 <- if isChunked- then makeChunkedReader rawBody conn+ then makeChunkedReader mhl (cleanup True) rawBody conn else case mcl of- Just len -> makeLengthReader len conn- Nothing -> makeUnlimitedReader conn- body2 <- if needsGunzip req hs+ Just len -> makeLengthReader (cleanup True) len conn+ Nothing -> makeUnlimitedReader (cleanup True) conn+ if needsGunzip req hs then makeGzipReader body1 else return body1- return $ brAddCleanup (cleanup True) body2 return Response { responseStatus = s@@ -120,6 +162,8 @@ , responseBody = body , responseCookieJar = Data.Monoid.mempty , responseClose' = ResponseClose (cleanup False)+ , responseOriginalRequest = req {requestBody = ""}+ , responseEarlyHints = earlyHs } -- | Does this response have no body?@@ -130,3 +174,11 @@ hasNoBody _ 204 = True hasNoBody _ 304 = True hasNoBody _ i = 100 <= i && i < 200++-- | Retrieve the orignal 'Request' from a 'Response'+--+-- Note that the 'requestBody' is not available and always set to empty.+--+-- @since 0.7.8+getOriginalRequest :: Response a -> Request+getOriginalRequest = responseOriginalRequest
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 (..)@@ -13,7 +14,12 @@ , throwHttp , toHttpException , Cookie (..)+ , equalCookie+ , equivCookie+ , compareCookies , CookieJar (..)+ , equalCookieJar+ , equivCookieJar , Proxy (..) , RequestBody (..) , Popper@@ -32,6 +38,9 @@ , ProxyOverride (..) , StreamFileStatus (..) , ResponseTimeout (..)+ , ProxySecureMode (..)+ , MaxHeaderLength (..)+ , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable)@@ -53,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@@ -82,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@@ -139,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@@ -263,26 +275,64 @@ newtype CookieJar = CJ { expose :: [Cookie] } deriving (Read, Show, T.Typeable) --- This corresponds to step 11 of the algorithm described in Section 5.3 \"Storage Model\"-instance Eq Cookie where- (==) a b = name_matches && domain_matches && path_matches- where name_matches = cookie_name a == cookie_name b- domain_matches = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b)- path_matches = cookie_path a == cookie_path b+-- | Instead of '(==)'.+--+-- Since there was some confusion in the history of this library about how the 'Eq' instance+-- should work, it was removed for clarity, and replaced by 'equal' and 'equiv'. 'equal'+-- gives you equality of all fields of the 'Cookie' record.+--+-- @since 0.7.0+equalCookie :: Cookie -> Cookie -> Bool+equalCookie a b = and+ [ cookie_name a == cookie_name b+ , cookie_value a == cookie_value b+ , cookie_expiry_time a == cookie_expiry_time b+ , cookie_domain a == cookie_domain b+ , cookie_path a == cookie_path b+ , cookie_creation_time a == cookie_creation_time b+ , cookie_last_access_time a == cookie_last_access_time b+ , cookie_persistent a == cookie_persistent b+ , cookie_host_only a == cookie_host_only b+ , cookie_secure_only a == cookie_secure_only b+ , cookie_http_only a == cookie_http_only b+ ] -instance Ord Cookie where- compare c1 c2+-- | Equality of name, domain, path only. This corresponds to step 11 of the algorithm+-- described in Section 5.3 \"Storage Model\". See also: 'equal'.+--+-- @since 0.7.0+equivCookie :: Cookie -> Cookie -> Bool+equivCookie a b = name_matches && domain_matches && path_matches+ where name_matches = cookie_name a == cookie_name b+ domain_matches = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b)+ path_matches = cookie_path a == cookie_path b++-- | Instead of @instance Ord Cookie@. See 'equalCookie', 'equivCookie'.+--+-- @since 0.7.0+compareCookies :: Cookie -> Cookie -> Ordering+compareCookies c1 c2 | S.length (cookie_path c1) > S.length (cookie_path c2) = LT | S.length (cookie_path c1) < S.length (cookie_path c2) = GT | cookie_creation_time c1 > cookie_creation_time c2 = GT | otherwise = LT -instance Eq CookieJar where- (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)+-- | See 'equalCookie'.+--+-- @since 0.7.0+equalCookieJar :: CookieJar -> CookieJar -> Bool+equalCookieJar (CJ cj1) (CJ cj2) = and $ zipWith equalCookie cj1 cj2 +-- | See 'equalCookieJar', 'equalCookie'.+--+-- @since 0.7.0+equivCookieJar :: CookieJar -> CookieJar -> Bool+equivCookieJar cj1 cj2 = and $+ zipWith equivCookie (DL.sortBy compareCookies $ expose cj1) (DL.sortBy compareCookies $ expose cj2)+ instance Semigroup CookieJar where- (CJ a) <> (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a <> b)- where compare' c1 c2 =+ (CJ a) <> (CJ b) = CJ (DL.nubBy equivCookie $ DL.sortBy mostRecentFirst $ a <> b)+ where mostRecentFirst c1 c2 = -- inverse so that recent cookies are kept by nub over older if cookie_creation_time c1 > cookie_creation_time c2 then LT@@ -298,11 +348,20 @@ -- | 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) +-- | Define how to make secure connections using a proxy server.+data ProxySecureMode =+ ProxySecureWithConnect+ -- ^ Use the HTTP CONNECT verb to forward a secure connection through the proxy.+ | ProxySecureWithoutConnect+ -- ^ Send the request directly to the proxy with an https URL. This mode can be+ -- used to offload TLS handling to a trusted local proxy.+ deriving (Show, Read, Eq, Ord, T.Typeable)+ -- | When using one of the 'RequestBodyStream' \/ 'RequestBodyStreamChunked' -- constructors, you must ensure that the 'GivesPopper' can be called multiple -- times. Usually this is not a problem.@@ -441,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.@@ -518,9 +580,9 @@ -- -- @since 0.5.0 , responseTimeout :: ResponseTimeout- -- ^ Number of microseconds to wait for a response. If- -- @Nothing@, will wait indefinitely. Default: use- -- 'managerResponseTimeout' (which by default is 30 seconds).+ -- ^ Number of microseconds to wait for a response (see 'ResponseTimeout'+ -- for more information). Default: use 'managerResponseTimeout' (which by+ -- default is 30 seconds). -- -- Since 0.1.0 , cookieJar :: Maybe CookieJar@@ -551,16 +613,51 @@ -- dealing with implicit global managers, such as in @Network.HTTP.Simple@ -- -- @since 0.4.28++ , shouldStripHeaderOnRedirect :: HeaderName -> Bool+ -- ^ Decide whether a header must be stripped from the request+ -- when following a redirect. Default: keep all headers intact.+ --+ -- @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 --- | How to deal with timing out a response+-- | How to deal with timing out on retrieval of response headers. -- -- @since 0.5.0 data ResponseTimeout = ResponseTimeoutMicro !Int+ -- ^ Wait the given number of microseconds for response headers to+ -- load, then throw an exception | ResponseTimeoutNone+ -- ^ Wait indefinitely | ResponseTimeoutDefault+ -- ^ Fall back to the manager setting ('managerResponseTimeout') or, in its+ -- absence, Wait 30 seconds and then throw an exception. deriving (Eq, Show) instance Show Request where@@ -569,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)@@ -579,12 +676,15 @@ , " redirectCount = " ++ show (redirectCount x) , " responseTimeout = " ++ show (responseTimeout x) , " requestVersion = " ++ show (requestVersion x)+ , " proxySecureMode = " ++ show (proxySecureMode x) , "}" ] -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. --@@ -618,15 +718,30 @@ -- be impossible. -- -- 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 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, Eq, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable)+ deriving (Show, T.Typeable, Functor, Data.Foldable.Foldable, Data.Traversable.Traversable) +-- Purposely not providing this instance. It used to use 'equivCookieJar'+-- semantics before 0.7.0, but should, if anything, use 'equalCookieJar'+-- semantics.+--+-- instance Exception Eq+ newtype ResponseClose = ResponseClose { runResponseClose :: IO () } deriving T.Typeable instance Show ResponseClose where show _ = "ResponseClose"-instance Eq ResponseClose where- _ == _ = True -- | Settings for a @Manager@. Please use the 'defaultManagerSettings' function and then modify -- individual settings. For more information, see <http://www.yesodweb.com/book/settings-types>.@@ -685,6 +800,9 @@ , managerModifyRequest :: Request -> IO Request -- ^ Perform the given modification to a @Request@ before performing it. --+ -- This function may be called more than once during request processing.+ -- see https://github.com/snoyberg/http-client/issues/350+ -- -- Default: no modification -- -- Since 0.4.4@@ -706,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 @@ -730,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 @@ -783,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)
Network/HTTP/Client/Util.hs view
@@ -1,15 +1,15 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Client.Util- ( readDec+ ( readPositiveInt ) where -import qualified Data.Text as T-import qualified Data.Text.Read+import Text.Read (readMaybe)+import Control.Monad (guard) -readDec :: Integral i => String -> Maybe i-readDec s =- case Data.Text.Read.decimal $ T.pack s of- Right (i, t)- | T.null t -> Just i- _ -> Nothing+-- | Read a positive 'Int', accounting for overflow+readPositiveInt :: String -> Maybe Int+readPositiveInt s = do+ i <- readMaybe s+ guard $ i >= 0+ Just i
Network/HTTP/Proxy.hs view
@@ -175,7 +175,7 @@ enable <- toBool . maybe 0 id A.<$> regQueryValueDWORD hkey "ProxyEnable" if enable then do-#if MIN_VERSION_Win32(2, 6, 0)+#if MIN_VERSION_Win32(2, 6, 0) && !MIN_VERSION_Win32(2, 8, 0) server <- regQueryValue hkey "ProxyServer" exceptions <- try $ regQueryValue hkey "ProxyOverride" :: IO (Either IOException String) #else
README.md view
@@ -2,7 +2,7 @@ =========== Full tutorial docs are available at:-https://haskell-lang.org/library/http-client+https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md An HTTP client engine, intended as a base layer for more user-friendly packages.
http-client.cabal view
@@ -1,5 +1,5 @@ name: http-client-version: 0.5.14+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@@ -37,7 +37,7 @@ Network.PublicSuffixList.Serialize Network.PublicSuffixList.DataStructure Data.KeyedPool- build-depends: base >= 4.6 && < 5+ build-depends: base >= 4.10 && < 5 , bytestring >= 0.10 , text >= 0.11 , http-types >= 0.8@@ -47,9 +47,9 @@ , 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- , memory >= 0.7+ , base64-bytestring >= 1.0 , cookie , exceptions >= 0.4 , array@@ -58,6 +58,8 @@ , mime-types , 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@@ -86,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@@ -120,11 +123,14 @@ 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 , monad-control , bytestring+ , cookie , text , http-types , blaze-builder
test-nonet/Network/HTTP/Client/BodySpec.hs view
@@ -20,51 +20,93 @@ 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 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 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 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 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+ it "length, single" $ do (conn, _, input) <- dummyConnection [ "hello world done" ]- reader <- makeLengthReader 11 conn+ reader <- makeLengthReader (return ()) 11 conn body <- brConsume reader S.concat body `shouldBe` "hello world" input' <- input@@ -74,7 +116,7 @@ it "length, pieces" $ do (conn, _, input) <- dummyConnection $ map S.singleton $ S.unpack "hello world done"- reader <- makeLengthReader 11 conn+ reader <- makeLengthReader (return ()) 11 conn body <- brConsume reader S.concat body `shouldBe` "hello world" input' <- input@@ -85,7 +127,7 @@ let orig = L.fromChunks $ replicate 5000 "Hello world!" origZ = compress orig (conn, _, input) <- dummyConnection $ L.toChunks origZ ++ ["ignored"]- reader' <- makeLengthReader (fromIntegral $ L.length origZ) conn+ reader' <- makeLengthReader (return ()) (fromIntegral $ L.length origZ) conn reader <- makeGzipReader reader' body <- brConsume reader L.fromChunks body `shouldBe` orig
+ 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/CookieSpec.hs view
@@ -1,9 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.CookieSpec where +import Control.Monad (when)+import Data.Monoid import Data.Time.Clock import Network.HTTP.Client.Internal import Test.Hspec+import qualified Data.Time as DT+import qualified Web.Cookie as WC main :: IO () main = hspec spec@@ -14,7 +18,7 @@ now <- getCurrentTime let cookie1 = Cookie "test" "value" now "doMain.Org" "/" now now False False False False cookie2 = Cookie "test" "value" now "DOMAIn.ORg" "/" now now False False False False- cookie1 `shouldBe` cookie2+ cookie1 `shouldSatisfy` (equivCookie cookie2) it "domainMatches - case insensitive" $ do domainMatches "www.org" "www.org" `shouldBe` True@@ -24,3 +28,49 @@ it "domainMatches - case insensitive, partial" $ do domainMatches "www.org" "xxx.www.org" `shouldBe` False domainMatches "xxx.www.org" "WWW.ORG" `shouldBe` True++ describe "equalCookie vs. equivCookie" $ do+ let make :: IO Cookie+ make = do+ now <- DT.getCurrentTime+ req <- parseRequest "http://www.example.com/path"+ let Just cky = generateCookie (WC.parseSetCookie raw) req now True+ raw = "somename=somevalue.v=1.k=1.d=1590419679.t=u.l=s.u=8b2734ae-9dd1-11ea-bd7f-3bcf5b8d5d2a.r=795e71b5; " <>+ "Path=/access; Domain=example.com; HttpOnly; Secure"+ return cky++ modifications :: [(String, Cookie -> Cookie, Bool)]+ modifications+ = [ ("cookie_name", \cky -> cky { cookie_name = "othername" }, True)+ , ("cookie_value", \cky -> cky { cookie_value = "othervalue" }, False)+ , ("cookie_expiry_time", \cky -> cky { cookie_expiry_time = DT.addUTCTime 60 $ cookie_expiry_time cky }, False)+ , ("cookie_domain", \cky -> cky { cookie_domain = cookie_domain cky <> ".com" }, True)+ , ("cookie_path", \cky -> cky { cookie_path = cookie_path cky <> "/sub" }, True)+ , ("cookie_creation_time", \cky -> cky { cookie_creation_time = DT.addUTCTime 60 $ cookie_creation_time cky }, False)+ , ("cookie_last_access_time", \cky -> cky { cookie_last_access_time = DT.addUTCTime 60 $ cookie_last_access_time cky }, False)+ , ("cookie_persistent", \cky -> cky { cookie_persistent = not $ cookie_persistent cky }, False)+ , ("cookie_host_only", \cky -> cky { cookie_host_only = not $ cookie_host_only cky }, False)+ , ("cookie_secure_only", \cky -> cky { cookie_secure_only = not $ cookie_secure_only cky }, False)+ , ("cookie_http_only", \cky -> cky { cookie_http_only = not $ cookie_http_only cky }, False)+ ]++ check :: (String, Cookie -> Cookie, Bool) -> Spec+ check (msg, f, countsForEquiv) = it msg $ do+ cky <- make+ cky `equalCookie` f cky `shouldBe` False+ when countsForEquiv $ cky `equivCookie` f cky `shouldBe` False++ check `mapM_` modifications++ it "isPotentiallyTrustworthyOrigin" $ do+ isPotentiallyTrustworthyOrigin True "" `shouldBe` True+ let untrusty = ["example", "example.", "example.com", "foolocalhost", "1.1.1.1", "::1", "[::2]"]+ trusty =+ [ "127.0.0.1", "127.0.0.2", "127.127.127.127"+ , "[::1]", "[0:0:0:0:0:0:0:1]"+ , "localhost", "localhost."+ , "a.b.c.localhost", "a.b.c.localhost."+ ]+ or (map (isPotentiallyTrustworthyOrigin False) untrusty) `shouldBe` False+ and (map (isPotentiallyTrustworthyOrigin False) trusty) `shouldBe` True+
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
@@ -13,6 +13,7 @@ import qualified Network.HTTP.Client as NC import qualified Network.HTTP.Client.Internal as Internal import Network.HTTP.Types (status413)+import Network.HTTP.Types.Header import qualified Network.Socket as NS import Test.Hspec import qualified Data.Streaming.Network as N@@ -30,6 +31,9 @@ notWindows x = x #endif +crlf :: S.ByteString+crlf = "\r\n"+ main :: IO () main = hspec spec @@ -38,21 +42,49 @@ let _ = e :: IOError return () -redirectServer :: (Int -> IO a) -> IO a-redirectServer inner = bracket+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+redirectServer 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: /\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 $ forever $ do- N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: /\r\ncontent-length: 5\r\n\r\n"- threadDelay 10000- N.appWrite ad "hello\r\n"- threadDelay 10000)+ (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") redirectCloseServer :: (Int -> IO a) -> IO a redirectCloseServer inner = bracket@@ -158,8 +190,43 @@ _ -> False return () mapM_ test ["http://", "https://", "http://:8000", "https://:8001"]- it "redirecting #41" $ redirectServer $ \port -> do+ it "headers can be stripped on redirect" $ redirectServer (Just 5) $ \port -> do req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ let req = req' { requestHeaders = [(hAuthorization, "abguvatgbfrrurer")]+ , redirectCount = 10+ , shouldStripHeaderOnRedirect = (== hAuthorization)+ }+ 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 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 } man <- newManager defaultManagerSettings replicateM_ 10 $ do@@ -167,7 +234,7 @@ case e of HttpExceptionRequest _ (TooManyRedirects _) -> True _ -> False- it "redirectCount=0" $ redirectServer $ \port -> do+ it "redirectCount=0" $ redirectServer Nothing $ \port -> do req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' { redirectCount = 0 } man <- newManager defaultManagerSettings@@ -254,3 +321,29 @@ ok <- readIORef okRef unless ok $ throwIO (ErrorCall "already closed")++ it "does not allow port overflow #383" $ do+ 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"@@ -33,15 +61,27 @@ man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status405+ describe "bearer auth" $ do+ it "success" $ do+ initialReq <- parseUrlThrow "http://httpbin.org/bearer"+ let finalReq = applyBearerAuth "token" initialReq+ man <- newManager defaultManagerSettings+ res <- httpLbs finalReq man+ responseStatus res `shouldBe` status200+ it "failure" $ do+ req <- parseRequest "http://httpbin.org/bearer"+ man <- newManager defaultManagerSettings+ res <- httpLbs req man+ responseStatus res `shouldBe` status401 describe "redirects" $ do- it "follows redirects" $ do+ xit "follows redirects" $ do req <- parseRequest "http://httpbin.org/redirect-to?url=http://httpbin.org" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 - it "allows to disable redirect following" $ do+ xit "allows to disable redirect following" $ do req <- (\ r -> r{ redirectCount = 0 }) <$> parseRequest "http://httpbin.org/redirect-to?url=http://httpbin.org" man <- newManager defaultManagerSettings@@ -88,9 +128,29 @@ man <- newManager settings httpLbs "http://httpbin.org" man `shouldThrow` anyException - it "redirectCount" $ do+ xit "redirectCount" $ do let modify req = return req { redirectCount = 0 } settings = defaultManagerSettings { managerModifyRequest = modify } 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 ()