http-client 0.5.4 → 0.7.19
raw patch · 26 files changed
Files
- ChangeLog.md +197/−0
- Data/KeyedPool.hs +325/−0
- Network/HTTP/Client.hs +54/−12
- Network/HTTP/Client/Body.hs +51/−20
- Network/HTTP/Client/Connection.hs +93/−32
- Network/HTTP/Client/Cookies.hs +38/−4
- Network/HTTP/Client/Core.hs +113/−65
- Network/HTTP/Client/Headers.hs +77/−24
- Network/HTTP/Client/Internal.hs +2/−0
- Network/HTTP/Client/Manager.hs +100/−308
- Network/HTTP/Client/MultipartFormData.hs +34/−27
- Network/HTTP/Client/Request.hs +176/−55
- Network/HTTP/Client/Response.hs +82/−19
- Network/HTTP/Client/Types.hs +232/−63
- Network/HTTP/Client/Util.hs +9/−167
- Network/HTTP/Proxy.hs +380/−0
- README.md +1/−1
- http-client.cabal +35/−9
- 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/RequestSpec.hs +45/−3
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +2/−2
- test-nonet/Network/HTTP/ClientSpec.hs +133/−27
- test/Network/HTTP/ClientSpec.hs +95/−7
ChangeLog.md view
@@ -1,3 +1,200 @@+# 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+ protocol is `https` and port is `443`+* Sending requests with invalid headers now throws InvalidRequestHeader exception++## 0.5.13.1++* Add a workaround for a cabal bug [haskell-infra/hackage-trustees#165](https://github.com/haskell-infra/hackage-trustees/issues/165)++## 0.5.13++* Adds `setRequestCheckStatus` and `throwErrorStatusCodes` functions.+ See [#304](https://github.com/snoyberg/http-client/issues/304)+* Add `withConnection` function.+ See [#352](https://github.com/snoyberg/http-client/pull/352).++## 0.5.12.1++* Make the chunked transfer-encoding detection case insensitive+ [#303](https://github.com/snoyberg/http-client/pull/303)+* Remove some unneeded language extensions+* Mark older versions of GHC as unsupported++## 0.5.12++* Added `requestFromURI` and `requestFromURI_` functions.+* Fixed non-TLS connections going though proxy [#337](https://github.com/snoyberg/http-client/issues/337)++## 0.5.11++* Replaced `base64-bytestring` dependency with `memory`.++## 0.5.10++* New function to partial escape query strings++## 0.5.9++* Add `Semigroup` instances for GHC 8.4 [#320](https://github.com/snoyberg/http-client/pull/320)++## 0.5.8++* Switch to the new STM-based manager+ [#254](https://github.com/snoyberg/http-client/pull/254)+* Redact sensitive headers [#318](https://github.com/snoyberg/http-client/pull/318)++## 0.5.7.1++* Code cleanup/delete dead code+* Compat with Win32 2.6 [#309](https://github.com/snoyberg/http-client/issues/309)++## 0.5.7.0++* Support for Windows system proxy settings+ [#274](https://github.com/snoyberg/http-client/pull/274)++## 0.5.6.1++* Revert socks5 and socks5h support from+ [#262](https://github.com/snoyberg/http-client/pull/262); the support was+ untested and did not work as intended.++## 0.5.6++* Added socks5 and socks5h support [#262](https://github.com/snoyberg/http-client/pull/262)++## 0.5.5++* http-client should allow to log requests and responses [#248](https://github.com/snoyberg/http-client/issues/248)+ ## 0.5.4 * Derive ‘Eq’ for ‘ResponseTimeout’ [#239](https://github.com/snoyberg/http-client/pull/239)
+ Data/KeyedPool.hs view
@@ -0,0 +1,325 @@+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE ScopedTypeVariables #-}+-- | Similar to Data.Pool from resource-pool, but resources are+-- identified by some key. To clarify semantics of this module:+--+-- * The pool holds onto and tracks idle resources. Active resources+-- (those checked out via 'takeKeyedPool') are not tracked at all by+-- 'KeyedPool' itself.+--+-- * The pool limits the number of idle resources per key and the+-- total number of idle resources.+--+-- * There is no limit placed on /active/ resources. As such: there+-- will be no delay when calling 'takeKeyedPool': it will either use+-- an idle resource already present, or create a new one+-- immediately.+--+-- * Once the garbage collector cleans up the 'kpAlive' value, the+-- pool will be shut down, by placing a 'PoolClosed' into the+-- 'kpVar' and destroying all existing idle connection.+--+-- * A reaper thread will destroy unused idle resources regularly. It+-- will stop running once 'kpVar' contains a 'PoolClosed' value.+--+-- * 'takeKeyedPool' is async exception safe, but relies on the+-- /caller/ to ensure prompt cleanup. See its comment for more+-- information.+module Data.KeyedPool+ ( KeyedPool+ , createKeyedPool+ , takeKeyedPool+ , Managed+ , managedResource+ , managedReused+ , managedRelease+ , keepAlive+ , Reuse (..)+ , dummyManaged+ ) where++import Control.Concurrent (forkIOWithUnmask, threadDelay)+import Control.Concurrent.STM+import Control.Exception (mask_, catch, SomeException)+import Control.Monad (join, unless, void)+import Data.Map (Map)+import Data.Maybe (isJust)+import qualified Data.Map.Strict as Map+import Data.Time (UTCTime, getCurrentTime, addUTCTime)+import Data.IORef (IORef, newIORef, mkWeakIORef, readIORef)+import qualified Data.Foldable as F+import GHC.Conc (unsafeIOToSTM)+import System.IO.Unsafe (unsafePerformIO)++data KeyedPool key resource = KeyedPool+ { kpCreate :: !(key -> IO resource)+ , kpDestroy :: !(resource -> IO ())+ , kpMaxPerKey :: !Int+ , kpMaxTotal :: !Int+ , kpVar :: !(TVar (PoolMap key resource))+ , kpAlive :: !(IORef ())+ }++data PoolMap key resource+ = PoolClosed+ | PoolOpen+ -- Total number of resources in the pool+ {-# UNPACK #-} !Int+ !(Map key (PoolList resource))+ deriving F.Foldable++-- | A non-empty list which keeps track of its own length and when+-- each resource was created.+data PoolList a+ = One a {-# UNPACK #-} !UTCTime+ | Cons+ a++ -- size of the list from this point and on+ {-# UNPACK #-} !Int++ {-# UNPACK #-} !UTCTime+ !(PoolList a)+ deriving F.Foldable++plistToList :: PoolList a -> [(UTCTime, a)]+plistToList (One a t) = [(t, a)]+plistToList (Cons a _ t plist) = (t, a) : plistToList plist++plistFromList :: [(UTCTime, a)] -> Maybe (PoolList a)+plistFromList [] = Nothing+plistFromList [(t, a)] = Just (One a t)+plistFromList xs =+ Just . snd . go $ xs+ where+ go [] = error "plistFromList.go []"+ go [(t, a)] = (2, One a t)+ go ((t, a):rest) =+ let (i, rest') = go rest+ i' = i + 1+ in i' `seq` (i', Cons a i t rest')++-- | Create a new 'KeyedPool' which will automatically clean up after+-- itself when all referenced to the 'KeyedPool' are gone. It will+-- also fork a reaper thread to regularly kill off unused resource.+createKeyedPool+ :: Ord key+ => (key -> IO resource) -- ^ create a new resource+ -> (resource -> IO ())+ -- ^ Destroy a resource. Note that exceptions thrown by this will be+ -- silently discarded. If you want reporting, please install an+ -- exception handler yourself.+ -> Int -- ^ number of resources per key to allow in the pool+ -> Int -- ^ number of resources to allow in the pool across all keys+ -> (SomeException -> IO ()) -- ^ what to do if the reaper throws an exception+ -> IO (KeyedPool key resource)+createKeyedPool create destroy maxPerKey maxTotal onReaperException = do+ var <- newTVarIO $ PoolOpen 0 Map.empty++ -- We use a different IORef for the weak ref instead of the var+ -- above since the reaper thread will always be holding onto a+ -- reference.+ alive <- newIORef ()+ void $ mkWeakIORef alive $ destroyKeyedPool' destroy var++ -- Make sure to fork _after_ we've established the mkWeakIORef. If+ -- we did it the other way around, it would be possible for an+ -- async exception to happen before our destroyKeyedPool' handler+ -- was installed, and then reap would have to rely on detecting an+ -- STM deadlock before it could ever exit. This way, the reap+ -- function will only start running when we're guaranteed that+ -- cleanup will be triggered.++ -- Ensure that we have a normal masking state in the new thread.+ _ <- forkIOWithUnmask $ \restore -> keepRunning $ restore $ reap destroy var+ return KeyedPool+ { kpCreate = create+ , kpDestroy = destroy+ , kpMaxPerKey = maxPerKey+ , kpMaxTotal = maxTotal+ , kpVar = var+ , kpAlive = alive+ }+ where+ keepRunning action =+ loop+ where+ loop = action `catch` \e -> onReaperException e >> loop++-- | Make a 'KeyedPool' inactive and destroy all idle resources.+destroyKeyedPool' :: (resource -> IO ())+ -> TVar (PoolMap key resource)+ -> IO ()+destroyKeyedPool' destroy var = do+ m <- atomically $ swapTVar var PoolClosed+ F.mapM_ (ignoreExceptions . destroy) m++-- | Run a reaper thread, which will destroy old resources. It will+-- stop running once our pool switches to PoolClosed, which is handled+-- via the mkWeakIORef in the creation of the pool.+reap :: forall key resource.+ Ord key+ => (resource -> IO ())+ -> TVar (PoolMap key resource)+ -> IO ()+reap destroy var =+ loop+ where+ loop = do+ threadDelay (5 * 1000 * 1000)+ join $ atomically $ do+ m'' <- readTVar var+ case m'' of+ PoolClosed -> return (return ())+ PoolOpen idleCount m+ | Map.null m -> retry+ | otherwise -> do+ (m', toDestroy) <- findStale idleCount m+ writeTVar var m'+ return $ do+ mask_ (mapM_ (ignoreExceptions . destroy) toDestroy)+ loop++ findStale :: Int+ -> Map key (PoolList resource)+ -> STM (PoolMap key resource, [resource])+ findStale idleCount m = do+ -- We want to make sure to get the time _after_ any delays+ -- occur due to the retry call above. Since getCurrentTime has+ -- no side effects outside of the STM block, this is a safe+ -- usage.+ now <- unsafeIOToSTM getCurrentTime+ let isNotStale time = 30 `addUTCTime` time >= now+ let findStale' toKeep toDestroy [] =+ (Map.fromList (toKeep []), toDestroy [])+ findStale' toKeep toDestroy ((key, plist):rest) =+ findStale' toKeep' toDestroy' rest+ where+ -- Note: By definition, the timestamps must be in+ -- descending order, so we don't need to traverse the+ -- whole list.+ (notStale, stale) = span (isNotStale . fst) $ plistToList plist+ toDestroy' = toDestroy . (map snd stale++)+ toKeep' =+ case plistFromList notStale of+ Nothing -> toKeep+ Just x -> toKeep . ((key, x):)+ let (toKeep, toDestroy) = findStale' id id (Map.toList m)+ let idleCount' = idleCount - length toDestroy+ return (PoolOpen idleCount' toKeep, toDestroy)++-- | Check out a value from the 'KeyedPool' with the given key.+--+-- This function will internally call 'mask_' to ensure async safety,+-- and will return a value which uses weak references to ensure that+-- the value is cleaned up. However, if you want to ensure timely+-- resource cleanup, you should bracket this operation together with+-- 'managedRelease'.+takeKeyedPool :: Ord key => KeyedPool key resource -> key -> IO (Managed resource)+takeKeyedPool kp key = mask_ $ join $ atomically $ do+ (m, mresource) <- fmap go $ readTVar (kpVar kp)+ writeTVar (kpVar kp) $! m+ return $ do+ resource <- maybe (kpCreate kp key) return mresource+ alive <- newIORef ()+ isReleasedVar <- newTVarIO False++ let release action = mask_ $ do+ isReleased <- atomically $ swapTVar isReleasedVar True+ unless isReleased $+ case action of+ Reuse -> putResource kp key resource+ DontReuse -> ignoreExceptions $ kpDestroy kp resource++ _ <- mkWeakIORef alive $ release DontReuse+ return Managed+ { _managedResource = resource+ , _managedReused = isJust mresource+ , _managedRelease = release+ , _managedAlive = alive+ }+ where+ go PoolClosed = (PoolClosed, Nothing)+ go pcOrig@(PoolOpen idleCount m) =+ case Map.lookup key m of+ Nothing -> (pcOrig, Nothing)+ Just (One a _) ->+ (PoolOpen (idleCount - 1) (Map.delete key m), Just a)+ Just (Cons a _ _ rest) ->+ (PoolOpen (idleCount - 1) (Map.insert key rest m), Just a)++-- | Try to return a resource to the pool. If too many resources+-- already exist, then just destroy it.+putResource :: Ord key => KeyedPool key resource -> key -> resource -> IO ()+putResource kp key resource = do+ now <- getCurrentTime+ join $ atomically $ do+ (m, action) <- fmap (go now) (readTVar (kpVar kp))+ writeTVar (kpVar kp) $! m+ return action+ where+ go _ PoolClosed = (PoolClosed, kpDestroy kp resource)+ go now pc@(PoolOpen idleCount m)+ | idleCount >= kpMaxTotal kp = (pc, kpDestroy kp resource)+ | otherwise = case Map.lookup key m of+ Nothing ->+ let cnt' = idleCount + 1+ m' = PoolOpen cnt' (Map.insert key (One resource now) m)+ in (m', return ())+ Just l ->+ let (l', mx) = addToList now (kpMaxPerKey kp) resource l+ cnt' = idleCount + maybe 1 (const 0) mx+ m' = PoolOpen cnt' (Map.insert key l' m)+ in (m', maybe (return ()) (kpDestroy kp) mx)++-- | Add a new element to the list, up to the given maximum number. If we're+-- already at the maximum, return the new value as leftover.+addToList :: UTCTime -> Int -> a -> PoolList a -> (PoolList a, Maybe a)+addToList _ i x l | i <= 1 = (l, Just x)+addToList now _ x l@One{} = (Cons x 2 now l, Nothing)+addToList now maxCount x l@(Cons _ currCount _ _)+ | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)+ | otherwise = (l, Just x)++-- | A managed resource, which can be returned to the 'KeyedPool' when+-- work with it is complete. Using garbage collection, it will default+-- to destroying the resource if the caller does not explicitly use+-- 'managedRelease'.+data Managed resource = Managed+ { _managedResource :: !resource+ , _managedReused :: !Bool+ , _managedRelease :: !(Reuse -> IO ())+ , _managedAlive :: !(IORef ())+ }++-- | Get the raw resource from the 'Managed' value.+managedResource :: Managed resource -> resource+managedResource = _managedResource++-- | Was this value taken from the pool?+managedReused :: Managed resource -> Bool+managedReused = _managedReused++-- | Release the resource, after which it is invalid to use the+-- 'managedResource' value. 'Reuse' returns the resource to the+-- pool; 'DontReuse' destroys it.+managedRelease :: Managed resource -> Reuse -> IO ()+managedRelease = _managedRelease++data Reuse = Reuse | DontReuse++-- | For testing purposes only: create a dummy Managed wrapper+dummyManaged :: resource -> Managed resource+dummyManaged resource = Managed+ { _managedResource = resource+ , _managedReused = False+ , _managedRelease = const (return ())+ , _managedAlive = unsafePerformIO (newIORef ())+ }++ignoreExceptions :: IO () -> IO ()+ignoreExceptions f = f `catch` \(_ :: SomeException) -> return ()++-- | Prevent the managed resource from getting released before you want to use.+keepAlive :: Managed resource -> IO ()+keepAlive = readIORef . _managedAlive
Network/HTTP/Client.hs view
@@ -1,8 +1,7 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE CPP #-} -- | -- -- = Simpler API@@ -12,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 --@@ -41,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.)@@ -108,14 +107,18 @@ , managerWrapException , managerIdleConnectionCount , managerModifyRequest+ , managerModifyResponse -- *** Manager proxy settings , managerSetProxy , managerSetInsecureProxy , managerSetSecureProxy+ , managerSetMaxHeaderLength+ , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy , useProxy+ , useProxySecureWithoutConnect , proxyEnvironment , proxyEnvironmentNamed , defaultProxy@@ -133,13 +136,19 @@ , parseUrlThrow , parseRequest , parseRequest_+ , requestFromURI+ , requestFromURI_ , defaultRequest- , applyBasicAuth+ , applyBearerAuth , urlEncodedBody , getUri , setRequestIgnoreStatus+ , setRequestCheckStatus , setQueryString+#if MIN_VERSION_http_types(0,12,1)+ , setQueryStringPartialEscape+#endif -- ** Request type and fields , Request , method@@ -154,10 +163,14 @@ , applyBasicProxyAuth , decompress , redirectCount+ , shouldStripHeaderOnRedirect+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly , checkResponse , responseTimeout , cookieJar , requestVersion+ , redactHeaders+ , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper@@ -173,6 +186,9 @@ , responseHeaders , responseBody , responseCookieJar+ , getOriginalRequest+ , responseEarlyHints+ , throwErrorStatusCodes -- ** Response body , BodyReader , brRead@@ -185,14 +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@@ -207,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. --@@ -235,8 +258,8 @@ -- -- Since 0.4.1 responseOpenHistory :: Request -> Manager -> IO (HistoriedResponse BodyReader)-responseOpenHistory req0 man0 = handle (throwIO . toHttpException req0) $ do- reqRef <- newIORef req0+responseOpenHistory reqOrig man0 = handle (throwIO . toHttpException reqOrig) $ do+ reqRef <- newIORef reqOrig historyRef <- newIORef id let go req0 = do (man, req) <- getModifiedRequestManager man0 req0@@ -246,6 +269,7 @@ (responseBody res') } case getRedirectedRequest+ req req' (responseHeaders res) (responseCookieJar res)@@ -254,9 +278,10 @@ 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 req0) go req0+ (_, res) <- httpRedirect' (redirectCount reqOrig) go reqOrig reqFinal <- readIORef reqRef history <- readIORef historyRef return HistoriedResponse@@ -297,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 --@@ -309,7 +344,7 @@ -- > main = do -- > manager <- newManager defaultManagerSettings -- >--- > request <- parseRequest "http://httpbin.org/post"+-- > request <- parseRequest "http://httpbin.org/get" -- > response <- httpLbs request manager -- > -- > putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response)@@ -322,6 +357,7 @@ -- > import Network.HTTP.Client -- > import Network.HTTP.Types.Status (statusCode) -- > import Data.Aeson (object, (.=), encode)+-- > import Data.Text (Text) -- > -- > main :: IO () -- > main = do@@ -329,6 +365,11 @@ -- > -- > -- Create the request -- > let requestObject = object ["name" .= "Michael", "age" .= 30]+-- > let requestObject = object+-- > [ "name" .= ("Michael" :: Text)+-- > , "age" .= (30 :: Int)+-- > ]+-- > -- > initialRequest <- parseRequest "http://httpbin.org/post" -- > let request = initialRequest { method = "POST", requestBody = RequestBodyLBS $ encode requestObject } -- >@@ -337,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@@ -7,7 +8,7 @@ , makeUnlimitedReader , brConsume , brEmpty- , brAddCleanup+ , constBodyReader , brReadSome , brRead ) where@@ -22,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@@ -52,11 +53,13 @@ brEmpty :: BodyReader brEmpty = return S.empty -brAddCleanup :: IO () -> BodyReader -> BodyReader-brAddCleanup cleanup brRead' = do- bs <- brRead'- when (S.null bs) cleanup- return bs+constBodyReader :: [S.ByteString] -> IO BodyReader+constBodyReader input = do+ iinput <- newIORef input+ return $ atomicModifyIORef iinput $ \input' ->+ case input' of+ [] -> ([], S.empty)+ x:xs -> (xs, x) -- | Strictly consume all remaining chunks of data from the stream. --@@ -102,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@@ -125,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@@ -148,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'@@ -179,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)@@ -204,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\"@@ -121,7 +155,7 @@ insertCookiesIntoRequest :: Req.Request -- ^ The request to insert into -> CookieJar -- ^ Current cookie jar -> UTCTime -- ^ Value that should be used as \"now\"- -> (Req.Request, CookieJar) -- ^ (Ouptut request, Updated cookie jar (last-access-time is updated))+ -> (Req.Request, CookieJar) -- ^ (Output request, Updated cookie jar (last-access-time is updated)) insertCookiesIntoRequest request cookie_jar now | BS.null cookie_string = (request, cookie_jar') | otherwise = (request {Req.requestHeaders = cookie_header : purgedHeaders}, cookie_jar')@@ -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
@@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.Core ( withResponse@@ -7,30 +6,35 @@ , httpNoBody , httpRaw , httpRaw'+ , requestAction , getModifiedRequestManager , responseOpen , responseClose , httpRedirect , httpRedirect'+ , withConnection+ , handleClosedRead ) where -#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif import Network.HTTP.Types import Network.HTTP.Client.Manager import Network.HTTP.Client.Types+import Network.HTTP.Client.Headers import Network.HTTP.Client.Body import Network.HTTP.Client.Request import Network.HTTP.Client.Response 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@@ -93,61 +97,87 @@ now <- getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now Nothing -> return (req', Data.Monoid.mempty)- (timeout', (connRelease, ci, isManaged)) <- 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) ci+ 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 connRelease timeout' req ci cont+makeRequest+ :: Request+ -> Manager+ -> IO (Response BodyReader)+makeRequest req m = do+ action <- readIORef requestAction+ action req m - case (ex, isManaged) of- -- Connection was reused, and might have been closed. Try again- (Left e, Reused) | mRetryableException m e -> do- connRelease 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@@ -192,11 +222,14 @@ -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader) responseOpen inputReq manager' = do+ case validateHeaders (requestHeaders inputReq) of+ GoodHeaders -> return ()+ BadHeaders reason -> throwHttp $ InvalidRequestHeader reason (manager, req0) <- getModifiedRequestManager manager' inputReq wrapExc req0 $ mWrapException manager req0 $ do (req, res) <- go manager (redirectCount req0) req0 checkResponse req req res- return res+ mModifyResponse manager res { responseBody = wrapExc req0 (responseBody res) } where@@ -210,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' @@ -227,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@.@@ -250,15 +294,7 @@ -- The connection may already be closed, e.g. -- when using withResponseHistory. See -- https://github.com/snoyberg/http-client/issues/169- `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@@ -273,3 +309,15 @@ -- Since 0.1.0 responseClose :: Response a -> IO () responseClose = runResponseClose . responseClose'++-- | Perform an action using a @Connection@ acquired from the given @Manager@.+--+-- You should use this only when you have to read and write interactively+-- through the connection (e.g. connection by the WebSocket protocol).+--+-- @since 0.5.13+withConnection :: Request -> Manager -> (Connection -> IO a) -> IO a+withConnection origReq man action = do+ mHttpConn <- getConn (mSetProxy man origReq) man+ action (managedResource mHttpConn) <* keepAlive mHttpConn+ `finally` managedRelease mHttpConn DontReuse
Network/HTTP/Client/Headers.hs view
@@ -1,8 +1,12 @@+{-# LANGUAGE DisambiguateRecordFields #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE ViewPatterns #-} module Network.HTTP.Client.Headers ( parseStatusHeaders+ , validateHeaders+ , HeadersValidationResult (..) ) where import Control.Applicative as A ((<$>), (<*>))@@ -10,11 +14,13 @@ import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.CaseInsensitive as CI+import Data.Maybe (mapMaybe)+import Data.Monoid+import Data.Word (Word8) import Network.HTTP.Client.Connection import Network.HTTP.Client.Types-import Network.HTTP.Client.Util (timeout) import Network.HTTP.Types-import Data.Word (Word8)+import System.Timeout (timeout) charSpace, charColon, charPeriod :: Word8 charSpace = 32@@ -22,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@@ -41,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@@ -78,19 +91,59 @@ 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)++data HeadersValidationResult+ = GoodHeaders+ | BadHeaders S.ByteString -- contains a message with the reason++validateHeaders :: RequestHeaders -> HeadersValidationResult+validateHeaders headers =+ case mapMaybe validateHeader headers of+ [] -> GoodHeaders+ reasons -> BadHeaders (S8.unlines reasons)+ where+ validateHeader (k, v)+ | S8.elem '\n' v = Just ("Header " <> CI.original k <> " has newlines")+ | True = Nothing
Network/HTTP/Client/Internal.hs view
@@ -25,6 +25,7 @@ , module Network.HTTP.Client.Types -- * Various utilities , module Network.HTTP.Client.Util+ , dummyManaged ) where import Network.HTTP.Client.Body@@ -37,3 +38,4 @@ import Network.HTTP.Client.Response import Network.HTTP.Client.Types import Network.HTTP.Client.Util+import Data.KeyedPool (dummyManaged)
Network/HTTP/Client/Manager.hs view
@@ -1,9 +1,6 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Client.Manager ( ManagerSettings (..) , newManager@@ -20,43 +17,25 @@ , proxyEnvironmentNamed , defaultProxy , dropProxyAuthSecure+ , useProxySecureWithoutConnect ) where -#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif-#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Control.Applicative ((<|>))-import Control.Arrow (first)-import qualified Data.IORef as I-import qualified Data.Map as Map- import qualified Data.ByteString.Char8 as S8 -import Data.Char (toLower) import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Read (decimal) -import Control.Monad (unless, join, void)-import Control.Exception (mask_, catch, throwIO, fromException, mask, IOException, Exception (..), handle)-import Control.Concurrent (forkIO, threadDelay)-import Data.Time (UTCTime (..), getCurrentTime, addUTCTime)+import Control.Monad (unless)+import Control.Exception (throwIO, fromException, IOException, Exception (..), handle) import qualified Network.Socket as NS -import System.Mem.Weak (Weak, deRefWeak) import Network.HTTP.Types (status200) import Network.HTTP.Client.Types import Network.HTTP.Client.Connection import Network.HTTP.Client.Headers (parseStatusHeaders)-import Network.HTTP.Client.Request (applyBasicProxyAuth, extractBasicAuthInfo)-import Control.Concurrent.MVar (MVar, takeMVar, tryPutMVar, newEmptyMVar)-import System.Environment (getEnvironment)-import qualified Network.URI as U-import Control.Monad (guard)+import Network.HTTP.Proxy+import Data.KeyedPool+import Data.Maybe (isJust) -- | A value for the @managerRawConnection@ setting, but also allows you to -- modify the underlying @Socket@ to set additional settings. For a motivating@@ -110,54 +89,13 @@ in handle wrapper , managerIdleConnectionCount = 512 , managerModifyRequest = return+ , managerModifyResponse = return , managerProxyInsecure = defaultProxy , managerProxySecure = defaultProxy+ , managerMaxHeaderLength = Just $ MaxHeaderLength 4096+ , managerMaxNumberHeaders = Just $ MaxNumberHeaders 100 } -takeSocket :: Manager -> ConnKey -> IO (Maybe Connection)-takeSocket man key =- I.atomicModifyIORef (mConns man) go- where- go ManagerClosed = (ManagerClosed, Nothing)- go mcOrig@(ManagerOpen idleCount m) =- case Map.lookup key m of- Nothing -> (mcOrig, Nothing)- Just (One a _) ->- let mc = ManagerOpen (idleCount - 1) (Map.delete key m)- in mc `seq` (mc, Just a)- Just (Cons a _ _ rest) ->- let mc = ManagerOpen (idleCount - 1) (Map.insert key rest m)- in mc `seq` (mc, Just a)--putSocket :: Manager -> ConnKey -> Connection -> IO ()-putSocket man key ci = do- now <- getCurrentTime- join $ I.atomicModifyIORef (mConns man) (go now)- void $ tryPutMVar (mConnsBaton man) ()- where- go _ ManagerClosed = (ManagerClosed , connectionClose ci)- go now mc@(ManagerOpen idleCount m)- | idleCount >= mIdleConnectionCount man = (mc, connectionClose ci)- | otherwise = case Map.lookup key m of- Nothing ->- let cnt' = idleCount + 1- m' = ManagerOpen cnt' (Map.insert key (One ci now) m)- in m' `seq` (m', return ())- Just l ->- let (l', mx) = addToList now (mMaxConns man) ci l- cnt' = idleCount + maybe 1 (const 0) mx- m' = ManagerOpen cnt' (Map.insert key l' m)- in m' `seq` (m', maybe (return ()) connectionClose mx)---- | Add a new element to the list, up to the given maximum number. If we're--- already at the maximum, return the new value as leftover.-addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a)-addToList _ i x l | i <= 1 = (l, Just x)-addToList now _ x l@One{} = (Cons x 2 now l, Nothing)-addToList now maxCount x l@(Cons _ currCount _ _)- | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing)- | otherwise = (l, Just x)- -- | Create a 'Manager'. The @Manager@ will be shut down automatically via -- garbage collection. --@@ -171,79 +109,35 @@ newManager :: ManagerSettings -> IO Manager newManager ms = do NS.withSocketsDo $ return ()- rawConnection <- managerRawConnection ms- tlsConnection <- managerTlsConnection ms- tlsProxyConnection <- managerTlsProxyConnection ms- mapRef <- I.newIORef $! ManagerOpen 0 Map.empty- baton <- newEmptyMVar- wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef httpProxy <- runProxyOverride (managerProxyInsecure ms) False httpsProxy <- runProxyOverride (managerProxySecure ms) True - _ <- forkIO $ reap baton wmapRef+ createConnection <- mkCreateConnection ms++ keyedPool <- createKeyedPool+ createConnection+ connectionClose+ (managerConnCount ms)+ (managerIdleConnectionCount ms)+ (const (return ())) -- could allow something in ManagerSettings to handle exceptions more nicely+ let manager = Manager- { mConns = mapRef- , mConnsBaton = baton- , mMaxConns = managerConnCount ms+ { mConns = keyedPool , mResponseTimeout = managerResponseTimeout ms- , mRawConnection = rawConnection- , mTlsConnection = tlsConnection- , mTlsProxyConnection = tlsProxyConnection , mRetryableException = managerRetryableException ms , mWrapException = managerWrapException ms- , mIdleConnectionCount = managerIdleConnectionCount ms , mModifyRequest = managerModifyRequest ms+ , mModifyResponse = managerModifyResponse ms , mSetProxy = \req -> if secure req then httpsProxy req else httpProxy req+ , mMaxHeaderLength = managerMaxHeaderLength ms+ , mMaxNumberHeaders = managerMaxNumberHeaders ms } return manager --- | Collect and destroy any stale connections.-reap :: MVar () -> Weak (I.IORef ConnsMap) -> IO ()-reap baton wmapRef =- mask_ loop- where- loop = do- threadDelay (5 * 1000 * 1000)- mmapRef <- deRefWeak wmapRef- case mmapRef of- Nothing -> return () -- manager is closed- Just mapRef -> goMapRef mapRef-- goMapRef mapRef = do- now <- getCurrentTime- let isNotStale time = 30 `addUTCTime` time >= now- (newMap, toDestroy) <- I.atomicModifyIORef mapRef $ \m ->- let (newMap, toDestroy) = findStaleWrap isNotStale m- in (newMap, (newMap, toDestroy))- mapM_ safeConnClose toDestroy- case newMap of- ManagerOpen _ m | not $ Map.null m -> return ()- _ -> takeMVar baton- loop- findStaleWrap _ ManagerClosed = (ManagerClosed, [])- findStaleWrap isNotStale (ManagerOpen idleCount m) =- let (x, y) = findStale isNotStale m- in (ManagerOpen (idleCount - length y) x, y)- findStale isNotStale =- findStale' id id . Map.toList- where- findStale' destroy keep [] = (Map.fromList $ keep [], destroy [])- findStale' destroy keep ((connkey, nelist):rest) =- findStale' destroy' keep' rest- where- -- Note: By definition, the timestamps must be in descending order,- -- so we don't need to traverse the whole list.- (notStale, stale) = span (isNotStale . fst) $ neToList nelist- destroy' = destroy . (map snd stale++)- keep' =- case neFromList notStale of- Nothing -> keep- Just x -> keep . ((connkey, x):)- {- FIXME why isn't this being used anymore? flushStaleCerts now = Map.fromList . mapMaybe flushStaleCerts' . Map.toList@@ -278,23 +172,6 @@ seqDT = seq -} -neToList :: NonEmptyList a -> [(UTCTime, a)]-neToList (One a t) = [(t, a)]-neToList (Cons a _ t nelist) = (t, a) : neToList nelist--neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a)-neFromList [] = Nothing-neFromList [(t, a)] = Just (One a t)-neFromList xs =- Just . snd . go $ xs- where- go [] = error "neFromList.go []"- go [(t, a)] = (2, One a t)- go ((t, a):rest) =- let (i, rest') = go rest- i' = i + 1- in i' `seq` (i', Cons a i t rest')- -- | Close all connections in a 'Manager'. -- -- Note that this doesn't affect currently in-flight connections,@@ -306,14 +183,6 @@ closeManager _ = return () {-# DEPRECATED closeManager "Manager will be closed for you automatically when no longer in use" #-} -closeManager' :: I.IORef ConnsMap- -> IO ()-closeManager' connsRef = mask_ $ do- !m <- I.atomicModifyIORef connsRef $ \x -> (ManagerClosed, x)- case m of- ManagerClosed -> return ()- ManagerOpen _ m' -> mapM_ (nonEmptyMapM_ safeConnClose) $ Map.elems m'- -- | Create, use and close a 'Manager'. -- -- Since 0.2.1@@ -321,64 +190,6 @@ withManager settings f = newManager settings >>= f {-# DEPRECATED withManager "Use newManager instead" #-} -safeConnClose :: Connection -> IO ()-safeConnClose ci = connectionClose ci `catch` \(_ :: IOException) -> return ()--nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()-nonEmptyMapM_ f (One x _) = f x-nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l---- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or--- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be--- either released or returned to the manager.-getManagedConn- :: Manager- -> ConnKey- -> IO Connection- -> IO (ConnRelease, Connection, ManagedConn)--- We want to avoid any holes caused by async exceptions, so let's mask.-getManagedConn man key open = mask $ \restore -> do- -- Try to take the socket out of the manager.- mci <- takeSocket man key- (ci, isManaged) <-- case mci of- -- There wasn't a matching connection in the manager, so create a- -- new one.- Nothing -> do- ci <- restore open- return (ci, Fresh)- -- Return the existing one- Just ci -> return (ci, Reused)-- -- When we release this connection, we can either reuse it (put it back in- -- the manager) or not reuse it (close the socket). We set up a mutable- -- reference to track what we want to do. By default, we say not to reuse- -- it, that way if an exception is thrown, the connection won't be reused.- toReuseRef <- I.newIORef DontReuse- wasReleasedRef <- I.newIORef False-- -- When the connection is explicitly released, we update our toReuseRef to- -- indicate what action should be taken, and then call release.- let connRelease r = do- I.writeIORef toReuseRef r- releaseHelper-- releaseHelper = mask $ \restore' -> do- wasReleased <- I.atomicModifyIORef wasReleasedRef $ \x -> (True, x)- unless wasReleased $ do- toReuse <- I.readIORef toReuseRef- restore' $ case toReuse of- Reuse -> putSocket man key ci- DontReuse -> connectionClose ci-- return (connRelease, ci, isManaged)--getConnDest :: Request -> (Bool, String, Int)-getConnDest req =- case proxy req of- Just p -> (True, S8.unpack (proxyHost p), proxyPort p)- Nothing -> (False, S8.unpack $ host req, port req)- -- | Drop the Proxy-Authorization header from the request if we're using a -- secure proxy. dropProxyAuthSecure :: Request -> Request@@ -389,52 +200,82 @@ } | otherwise = req where- (useProxy', _, _) = getConnDest req+ useProxy' = isJust (proxy req) getConn :: Request -> Manager- -> IO (ConnRelease, Connection, ManagedConn)+ -> IO (Managed Connection) getConn req m -- Stop Mac OS X from getting high: -- https://github.com/snoyberg/http-client/issues/40#issuecomment-39117909 | S8.null h = throwHttp $ InvalidDestinationHost h- | otherwise =- getManagedConn m (ConnKey connKeyHost connport (host req) (port req) (secure req)) $- wrapConnectExc $ go connaddr connhost connport+ | otherwise = takeKeyedPool (mConns m) connkey where h = host req- (useProxy', connhost, connport) = getConnDest req- (connaddr, connKeyHost) =- case (hostAddress req, useProxy') of- (Just ha, False) -> (Just ha, HostAddress ha)- _ -> (Nothing, HostName $ T.pack connhost)+ connkey = connKey req +connKey :: Request -> ConnKey+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+ rawConnection <- managerRawConnection ms+ tlsConnection <- managerTlsConnection ms+ tlsProxyConnection <- managerTlsProxyConnection ms++ return $ \ck -> wrapConnectExc $ case ck of+ CKRaw connaddr connhost connport ->+ rawConnection connaddr (S8.unpack connhost) connport+ CKSecure connaddr connhost connport ->+ tlsConnection connaddr (S8.unpack connhost) connport+ CKProxy connhost connport mProxyAuthHeader ultHost ultPort ->+ let proxyAuthorizationHeader = maybe+ ""+ (\h' -> S8.concat ["Proxy-Authorization: ", h', "\r\n"])+ mProxyAuthHeader+ hostHeader = S8.concat ["Host: ", ultHost, ":", (S8.pack $ show ultPort), "\r\n"]+ connstr = S8.concat+ [ "CONNECT "+ , ultHost+ , ":"+ , S8.pack $ show ultPort+ , " HTTP/1.1\r\n"+ , proxyAuthorizationHeader+ , hostHeader+ , "\r\n"+ ]+ parse conn = do+ 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+ connstr+ parse+ (S8.unpack ultHost)+ Nothing -- we never have a HostAddress we can use+ (S8.unpack connhost)+ connport+ where wrapConnectExc = handle $ \e -> throwHttp $ ConnectionFailure (toException (e :: IOException))- go =- case (secure req, useProxy') of- (False, _) -> mRawConnection m- (True, False) -> mTlsConnection m- (True, True) ->- let ultHost = host req- ultPort = port req- proxyAuthorizationHeader = maybe "" (\h' -> S8.concat ["Proxy-Authorization: ", h', "\r\n"]) . lookup "Proxy-Authorization" $ requestHeaders req- hostHeader = S8.concat ["Host: ", ultHost, ":", (S8.pack $ show ultPort), "\r\n"]- connstr = S8.concat- [ "CONNECT "- , ultHost- , ":"- , S8.pack $ show ultPort- , " HTTP/1.1\r\n"- , proxyAuthorizationHeader- , hostHeader- , "\r\n"- ]- parse conn = do- StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing- unless (status == status200) $- throwHttp $ ProxyConnectException ultHost ultPort status- in mTlsProxyConnection m connstr parse (S8.unpack ultHost) -- | Get the proxy settings from the @Request@ itself. --@@ -454,6 +295,15 @@ 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 -- back to the given value. @Nothing@ is equivalent to 'noProxy', @Just@ is@@ -463,12 +313,7 @@ proxyEnvironment :: Maybe Proxy -- ^ fallback if no environment set -> ProxyOverride proxyEnvironment mp = ProxyOverride $ \secure' ->- envHelper (envName secure') $ maybe EHNoProxy EHUseProxy mp--envName :: Bool -- ^ secure?- -> Text-envName False = "http_proxy"-envName True = "https_proxy"+ systemProxyHelper Nothing (httpProtocol secure') $ maybe EHNoProxy EHUseProxy mp -- | Same as 'proxyEnvironment', but instead of default environment variable -- names, allows you to set your own name.@@ -478,65 +323,12 @@ :: Text -- ^ environment variable name -> Maybe Proxy -- ^ fallback if no environment set -> ProxyOverride-proxyEnvironmentNamed name =- ProxyOverride . const . envHelper name- . maybe EHNoProxy EHUseProxy+proxyEnvironmentNamed name mp = ProxyOverride $ \secure' ->+ systemProxyHelper (Just name) (httpProtocol secure') $ maybe EHNoProxy EHUseProxy mp -- | The default proxy settings for a manager. In particular: if the @http_proxy@ (or @https_proxy@) environment variable is set, use it. Otherwise, use the values in the @Request@. -- -- Since 0.4.7 defaultProxy :: ProxyOverride defaultProxy = ProxyOverride $ \secure' ->- envHelper (envName secure') EHFromRequest--data EnvHelper = EHFromRequest- | EHNoProxy- | EHUseProxy Proxy--envHelper :: Text -> EnvHelper -> IO (Request -> Request)-envHelper name eh = do- env <- getEnvironment- let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env- lookupEnvVar n = lookup (T.unpack n) env <|> Map.lookup n lenv- noProxyDomains = domainSuffixes (lookupEnvVar "no_proxy")- case lookupEnvVar name of- Nothing -> return noEnvProxy- Just "" -> return noEnvProxy- Just str -> do- let invalid = throwHttp $ InvalidProxyEnvironmentVariable name (T.pack str)- (p, muserpass) <- maybe invalid return $ do- uri <- case U.parseURI str of- Just u | U.uriScheme u == "http:" -> return u- _ -> U.parseURI $ "http://" ++ str-- guard $ U.uriScheme uri == "http:"- guard $ null (U.uriPath uri) || U.uriPath uri == "/"- guard $ null $ U.uriQuery uri- guard $ null $ U.uriFragment uri-- auth <- U.uriAuthority uri- port' <-- case U.uriPort auth of- "" -> Just 80- ':':rest ->- case decimal $ T.pack rest of- Right (p, "") -> Just p- _ -> Nothing- _ -> Nothing-- Just $ (Proxy (S8.pack $ U.uriRegName auth) port', extractBasicAuthInfo uri)- return $ \req ->- if host req `hasDomainSuffixIn` noProxyDomains- then noEnvProxy req- else maybe id (uncurry applyBasicProxyAuth) muserpass- req { proxy = Just p }- where noEnvProxy = case eh of- EHFromRequest -> id- EHNoProxy -> \req -> req { proxy = Nothing }- EHUseProxy p -> \req -> req { proxy = Just p }- prefixed s | S8.head s == '.' = s- | otherwise = S8.cons '.' s- domainSuffixes Nothing = []- domainSuffixes (Just "") = []- domainSuffixes (Just no_proxy) = [prefixed $ S8.dropWhile (== ' ') suffix | suffix <- S8.split ',' (S8.pack (map toLower no_proxy)), not (S8.null suffix)]- hasDomainSuffixIn host' = any (`S8.isSuffixOf` prefixed (S8.map toLower host'))+ systemProxyHelper Nothing (httpProtocol secure') EHFromRequest
Network/HTTP/Client/MultipartFormData.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE CPP, OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-} -- | This module handles building multipart/form-data. Example usage: -- -- > {-# LANGUAGE OverloadedStrings #-}@@ -10,7 +10,7 @@ -- > -- > import Control.Monad -- >--- > main = withSocketsDo $ void $ withManager defaultManagerSettings $ \m -> do+-- > main = void $ withManager defaultManagerSettings $ \m -> do -- > req1 <- parseRequest "http://random-cat-photo.net/cat.jpg" -- > res <- httpLbs req1 m -- > req2 <- parseRequest "http://example.org/~friedrich/blog/addPost.hs"@@ -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
@@ -11,33 +11,45 @@ , parseUrlThrow , parseRequest , parseRequest_+ , requestFromURI+ , requestFromURI_ , defaultRequest , setUriRelative , getUri , setUri+ , setUriEither , browserDecompress , alwaysDecompress , addProxy , applyBasicAuth , applyBasicProxyAuth+ , applyBearerAuth , urlEncodedBody , needsGunzip , requestBuilder , setRequestIgnoreStatus+ , setRequestCheckStatus , setQueryString+#if MIN_VERSION_http_types(0,12,1)+ , setQueryStringPartialEscape+#endif , streamFile , observedStreamFile , extractBasicAuthInfo+ , throwErrorStatusCodes+ , addProxySecureWithoutConnect ) where import Data.Int (Int64)-import Data.Maybe (fromMaybe, isJust, isNothing)-import Data.Monoid (mempty, mappend)+import Data.Maybe (fromMaybe, isNothing)+import Data.Monoid (mempty, mappend, (<>)) import Data.String (IsString(..)) import Data.Char (toLower) import Control.Applicative as A ((<$>)) 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)@@ -72,29 +84,37 @@ parseUrl = parseUrlThrow {-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-} --- | Same as 'parseRequest', except will throw an 'HttpException' in--- the event of a non-2XX response.+-- | Same as 'parseRequest', except will throw an 'HttpException' in the+-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to+-- implement 'checkResponse'. -- -- @since 0.4.30 parseUrlThrow :: MonadThrow m => String -> m Request parseUrlThrow = liftM yesThrow . parseRequest where- yesThrow req = req- { checkResponse = \_req res ->- let W.Status sci _ = responseStatus res in- if 200 <= sci && sci < 300- then return ()- else do- chunk <- brReadSome (responseBody res) 1024- let res' = fmap (const ()) res- throwHttp $ StatusCodeException res' (L.toStrict chunk)- }+ yesThrow req = req { checkResponse = throwErrorStatusCodes } +-- | Throws a 'StatusCodeException' wrapped in 'HttpExceptionRequest',+-- if the response's status code indicates an error (if it isn't 2xx).+-- This can be used to implement 'checkResponse'.+--+-- @since 0.5.13+throwErrorStatusCodes :: MonadIO m => Request -> Response BodyReader -> m ()+throwErrorStatusCodes req res = do+ let W.Status sci _ = responseStatus res+ if 200 <= sci && sci < 300+ then return ()+ else liftIO $ do+ chunk <- brReadSome (responseBody res) 1024+ let res' = fmap (const ()) res+ let ex = StatusCodeException res' (L.toStrict chunk)+ throwIO $ HttpExceptionRequest req ex+ -- | Convert a URL into a 'Request'. ----- This defaults some of the values in 'Request', such as setting 'method' to--- GET and 'requestHeaders' to @[]@.+-- This function defaults some of the values in 'Request', such as setting 'method' to+-- @"GET"@ and 'requestHeaders' to @[]@. -- -- Since this function uses 'MonadThrow', the return monad can be anything that is -- an instance of 'MonadThrow', such as 'IO' or 'Maybe'.@@ -102,15 +122,17 @@ -- You can place the request method at the beginning of the URL separated by a -- space, e.g.: ----- @@@--- parseRequeset "POST http://httpbin.org/post"--- @@@+-- @+-- parseRequest "POST http://httpbin.org/post"+-- @ -- -- Note that the request method must be provided as all capital letters. ----- 'Request' created by this function won't cause exceptions on non-2XX+-- A 'Request' created by this function won't cause exceptions on non-2XX -- response status codes. --+-- To create a request which throws on non-2XX status codes, see 'parseUrlThrow'+-- -- @since 0.4.30 parseRequest :: MonadThrow m => String -> m Request parseRequest s' =@@ -129,26 +151,39 @@ Nothing -> req Just m -> req { method = S8.pack m } --- | Same as 'parseRequest', but in the cases of a parse error--- generates an impure exception. Mostly useful for static strings which--- are known to be correctly formatted.+-- | Same as 'parseRequest', but parse errors cause an impure exception.+-- Mostly useful for static strings which are known to be correctly+-- formatted. parseRequest_ :: String -> Request parseRequest_ = either throw id . parseRequest +-- | Convert a 'URI' into a 'Request'.+--+-- This can fail if the given 'URI' is not absolute, or if the+-- 'URI' scheme is not @"http"@ or @"https"@. In these cases the function+-- will throw an error via 'MonadThrow'.+--+-- This function defaults some of the values in 'Request', such as setting 'method' to+-- @"GET"@ and 'requestHeaders' to @[]@.+--+-- A 'Request' created by this function won't cause exceptions on non-2XX+-- response status codes.+--+-- @since 0.5.12+requestFromURI :: MonadThrow m => URI -> m Request+requestFromURI = setUri defaultRequest++-- | Same as 'requestFromURI', but if the conversion would fail,+-- throws an impure exception.+--+-- @since 0.5.12+requestFromURI_ :: URI -> Request+requestFromURI_ = either throw id . requestFromURI+ -- | Add a 'URI' to the request. If it is absolute (includes a host name), add -- it as per 'setUri'; if it is relative, merge it with the existing request. setUriRelative :: MonadThrow m => Request -> URI -> m Request-setUriRelative req uri =-#ifndef MIN_VERSION_network-#define MIN_VERSION_network(x,y,z) 1-#endif-#if MIN_VERSION_network(2,4,0)- setUri req $ uri `relativeTo` getUri req-#else- case uri `relativeTo` getUri req of- Just uri' -> setUri req uri'- Nothing -> throwM $ InvalidUrlException (show uri) "Invalid URL"-#endif+setUriRelative req uri = setUri req $ uri `relativeTo` getUri req -- | Extract a 'URI' from the request. --@@ -161,7 +196,7 @@ , uriAuthority = Just URIAuth { uriUserInfo = "" , uriRegName = S8.unpack $ host req- , uriPort = ':' : show (port req)+ , uriPort = port' } , uriPath = S8.unpack $ path req , uriQuery =@@ -170,6 +205,11 @@ _ -> S8.unpack $ queryString req , uriFragment = "" }+ where+ port'+ | secure req && (port req) == 443 = ""+ | not (secure req) && (port req) == 80 = ""+ | otherwise = ':' : show (port req) applyAnyUriBasedAuth :: URI -> Request -> Request applyAnyUriBasedAuth uri req =@@ -190,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@@ -205,29 +254,29 @@ , 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 True {- HTTPS -} -> return 443 --- | A default request value+-- | A default request value, a GET request of localhost/:80, with an+-- empty request body. --+-- Note that the default 'checkResponse' does nothing.+-- -- @since 0.4.30 defaultRequest :: Request defaultRequest = Request@@ -253,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_'@@ -271,6 +325,14 @@ browserDecompress :: S.ByteString -> Bool browserDecompress = (/= "application/x-tar") +-- | Build a basic-auth header value+buildBasicAuth ::+ S8.ByteString -- ^ Username+ -> S8.ByteString -- ^ Password+ -> S8.ByteString+buildBasicAuth 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: --@@ -285,9 +347,24 @@ applyBasicAuth user passwd req = req { requestHeaders = authHeader : requestHeaders req } where- authHeader = (CI.mk "Authorization", basic)- basic = S8.append "Basic " (B64.encode $ S8.concat [ user, ":", passwd ])+ 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. --@@ -296,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: --@@ -307,8 +391,7 @@ applyBasicProxyAuth user passwd req = req { requestHeaders = authHeader : requestHeaders req } where- authHeader = (CI.mk "Proxy-Authorization", basic)- basic = S8.append "Basic " (B64.encode $ S8.concat [ user , ":", passwd ])+ authHeader = (CI.mk "Proxy-Authorization", buildBasicAuth user passwd) -- | Add url-encoded parameters to the 'Request'. --@@ -336,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)@@ -344,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@@ -385,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@@ -412,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@@ -445,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))@@ -478,11 +584,26 @@ setRequestIgnoreStatus :: Request -> Request setRequestIgnoreStatus req = req { checkResponse = \_ _ -> return () } +-- | Modify the request so that non-2XX status codes generate a runtime+-- 'StatusCodeException', by using 'throwErrorStatusCodes'+--+-- @since 0.5.13+setRequestCheckStatus :: Request -> Request+setRequestCheckStatus req = req { checkResponse = throwErrorStatusCodes }+ -- | Set the query string to the given key/value pairs. -- -- Since 0.3.6 setQueryString :: [(S.ByteString, Maybe S.ByteString)] -> Request -> Request setQueryString qs req = req { queryString = W.renderQuery True qs }++#if MIN_VERSION_http_types(0,12,1)+-- | Set the query string to the given key/value pairs.+--+-- @since 0.5.10+setQueryStringPartialEscape :: [(S.ByteString, [W.EscapeItem])] -> Request -> Request+setQueryStringPartialEscape qs req = req { queryString = W.renderQueryPartialEscape True qs }+#endif -- | Send a file as the request body. --
Network/HTTP/Client/Response.hs view
@@ -1,17 +1,20 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Network.HTTP.Client.Response ( getRedirectedRequest , getResponse , lbsResponse+ , getOriginalRequest ) where +import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L+import qualified Data.CaseInsensitive as CI+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)@@ -22,6 +25,7 @@ import Network.HTTP.Client.Util import Network.HTTP.Client.Body import Network.HTTP.Client.Headers+import Data.KeyedPool -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the@@ -40,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@@ -66,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)@@ -77,21 +113,30 @@ { responseBody = L.fromChunks bss } -getResponse :: ConnRelease+getResponse :: Maybe MaxHeaderLength+ -> Maybe MaxNumberHeaders -> Maybe Int -> Request- -> Connection+ -> Managed Connection -> Maybe (IO ()) -- ^ Action to run in case of a '100 Continue'. -> IO (Response BodyReader)-getResponse connRelease timeout' req@(Request {..}) conn cont = do- StatusHeaders s version hs <- parseStatusHeaders conn timeout' cont- let mcl = lookup "content-length" hs >>= readDec . S8.unpack- isChunked = ("transfer-encoding", "chunked") `elem` hs+getResponse mhl mnh timeout' req@(Request {..}) mconn cont = do+ let conn = managedResource mconn+ 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 = connRelease $ 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)@@ -101,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@@ -118,4 +162,23 @@ , responseBody = body , responseCookieJar = Data.Monoid.mempty , responseClose' = ResponseClose (cleanup False)+ , responseOriginalRequest = req {requestBody = ""}+ , responseEarlyHints = earlyHs }++-- | Does this response have no body?+hasNoBody :: ByteString -- ^ request method+ -> Int -- ^ status code+ -> Bool+hasNoBody "HEAD" _ = True+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,7 +1,8 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Network.HTTP.Client.Types ( BodyReader@@ -13,16 +14,18 @@ , throwHttp , toHttpException , Cookie (..)+ , equalCookie+ , equivCookie+ , compareCookies , CookieJar (..)+ , equalCookieJar+ , equivCookieJar , Proxy (..) , RequestBody (..) , Popper , NeedsPopper , GivesPopper , Request (..)- , ConnReuse (..)- , ConnRelease- , ManagedConn (..) , Response (..) , ResponseClose (..) , Manager (..)@@ -35,6 +38,9 @@ , ProxyOverride (..) , StreamFileStatus (..) , ResponseTimeout (..)+ , ProxySecureMode (..)+ , MaxHeaderLength (..)+ , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable)@@ -46,7 +52,8 @@ import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString) import Data.Int (Int64) import Data.Foldable (Foldable)-import Data.Monoid+import Data.Monoid (Monoid(..))+import Data.Semigroup (Semigroup(..)) import Data.String (IsString, fromString) import Data.Time (UTCTime) import Data.Traversable (Traversable)@@ -54,12 +61,12 @@ import Network.Socket (HostAddress) import Data.IORef import qualified Network.Socket as NS-import qualified Data.IORef as I import qualified Data.Map as Map+import qualified Data.Set as Set import Data.Text (Text) import Data.Streaming.Zlib (ZlibException)-import Control.Concurrent.MVar (MVar) import Data.CaseInsensitive as CI+import Data.KeyedPool (KeyedPool) -- | An @IO@ action that represents an incoming response body coming from the -- server. Data provided by this action has already been gunzipped and@@ -80,12 +87,12 @@ -- ^ Send data to server , connectionClose :: IO () -- ^ Close connection. Any successive operation on the connection- -- (exept closing) should fail with `ConnectionClosed` exception.+ -- (except closing) should fail with `ConnectionClosed` exception. -- It is allowed to close connection multiple times. } 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@@ -142,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@@ -159,7 +168,7 @@ -- -- @since 0.5.0 | ConnectionFailure SomeException- -- ^ An exception occured when trying to connect to the+ -- ^ An exception occurred when trying to connect to the -- server. -- -- @since 0.5.0@@ -171,6 +180,10 @@ -- ^ The given response header line could not be parsed -- -- @since 0.5.0+ | InvalidRequestHeader S.ByteString+ -- ^ The given request header is not compliant (e.g. has newlines)+ --+ -- @since 0.5.14 | InternalException SomeException -- ^ An exception was raised by an underlying library when -- performing the request. Most often, this is caused by a@@ -232,6 +245,9 @@ -- ^ Attempted to use a 'Connection' which was already closed -- -- @since 0.5.0+ | InvalidProxySettings Text+ -- ^ Proxy settings are not valid (Windows specific currently)+ -- @since 0.5.7 deriving (Show, T.Typeable) -- Purposely not providing this instance, since we don't want users to@@ -259,41 +275,93 @@ 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 --- | Since 1.9-instance Data.Monoid.Monoid CookieJar where- mempty = CJ []- (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)- where compare' c1 c2 =+-- | 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.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 else GT +-- | Since 1.9+instance Data.Monoid.Monoid CookieJar where+ mempty = CJ []+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif+ -- | 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.@@ -322,9 +390,14 @@ fromString str = RequestBodyBS (fromString str) instance Monoid RequestBody where mempty = RequestBodyBS S.empty- mappend x0 y0 =+#if !(MIN_VERSION_base(4,11,0))+ mappend = (<>)+#endif++instance Semigroup RequestBody where+ x0 <> y0 = case (simplify x0, simplify y0) of- (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x `mappend` y)+ (Left (i, x), Left (j, y)) -> RequestBodyBuilder (i + j) (x <> y) (Left x, Right y) -> combine (builderToStream x) y (Right x, Left y) -> combine x (builderToStream y) (Right x, Right y) -> combine x y@@ -427,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.@@ -504,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@@ -537,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@@ -555,7 +666,7 @@ , " host = " ++ show (host x) , " port = " ++ show (port x) , " secure = " ++ show (secure x)- , " requestHeaders = " ++ show (requestHeaders x)+ , " requestHeaders = " ++ show (DL.map (redactSensitiveHeader $ redactHeaders x) (requestHeaders x)) , " path = " ++ show (path x) , " queryString = " ++ show (queryString x) --, " requestBody = " ++ show (requestBody x)@@ -565,15 +676,15 @@ , " redirectCount = " ++ show (redirectCount x) , " responseTimeout = " ++ show (responseTimeout x) , " requestVersion = " ++ show (requestVersion x)+ , " proxySecureMode = " ++ show (proxySecureMode x) , "}" ] -data ConnReuse = Reuse | DontReuse- deriving T.Typeable--type ConnRelease = ConnReuse -> IO ()--data ManagedConn = Fresh | Reused+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. --@@ -607,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>.@@ -664,7 +790,9 @@ -- -- This limit helps deal with the case where you are making a large number -- of connections to different hosts. Without this limit, you could run out- -- of file descriptors.+ -- of file descriptors. Additionally, it can be set to zero to prevent+ -- reuse of any connections. Doing this is useful when the server your application+ -- is talking to sits behind a load balancer. -- -- Default: 512 --@@ -672,9 +800,18 @@ , 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+ , managerModifyResponse :: Response BodyReader -> IO (Response BodyReader)+ -- ^ Perform the given modification to a @Response@ after receiving it.+ --+ -- Default: no modification+ --+ -- @since 0.5.5 , managerProxyInsecure :: ProxyOverride -- ^ How HTTP proxy server settings should be discovered. --@@ -687,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 @@ -704,27 +853,17 @@ -- -- Since 0.1.0 data Manager = Manager- { mConns :: I.IORef ConnsMap- -- ^ @Nothing@ indicates that the manager is closed.- , mConnsBaton :: MVar ()- -- ^ Used to indicate to the reaper thread that it has some work to do.- -- This must be filled every time a connection is returned to the manager.- -- While redundant with the @IORef@ above, this allows us to have the- -- reaper thread fully blocked instead of running every 5 seconds when- -- there are no connections to manage.- , mMaxConns :: Int- -- ^ This is a per-@ConnKey@ value.+ { mConns :: KeyedPool ConnKey Connection , mResponseTimeout :: ResponseTimeout -- ^ Copied from 'managerResponseTimeout'- , mRawConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection- , mTlsConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection- , mTlsProxyConnection :: S.ByteString -> (Connection -> IO ()) -> String -> Maybe NS.HostAddress -> String -> Int -> IO Connection , mRetryableException :: SomeException -> Bool , mWrapException :: forall a. Request -> IO a -> IO a- , mIdleConnectionCount :: Int , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request+ , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) -- ^ See 'managerProxy'+ , mMaxHeaderLength :: Maybe MaxHeaderLength+ , mMaxNumberHeaders :: Maybe MaxNumberHeaders } deriving T.Typeable @@ -750,7 +889,21 @@ -- | @ConnKey@ consists of a hostname, a port and a @Bool@ -- specifying whether to use SSL.-data ConnKey = ConnKey ConnHost Int S.ByteString Int Bool+data ConnKey+ = CKRaw (Maybe HostAddress) {-# UNPACK #-} !S.ByteString !Int+ | CKSecure (Maybe HostAddress) {-# UNPACK #-} !S.ByteString !Int+ | CKProxy+ {-# UNPACK #-} !S.ByteString+ !Int++ -- Proxy-Authorization request header+ (Maybe S.ByteString)++ -- ultimate host+ {-# UNPACK #-} !S.ByteString++ -- ultimate port+ !Int deriving (Eq, Show, Ord, T.Typeable) -- | Status of streaming a request body from a file.@@ -762,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,173 +1,15 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections #-} module Network.HTTP.Client.Util- ( hGetSome- , (<>)- , readDec- , hasNoBody- , fromStrict- , timeout+ ( readPositiveInt ) where -import Data.Monoid (Monoid, mappend)--import qualified Data.ByteString.Char8 as S8--#ifndef MIN_VERSION_bytestring-#define MIN_VERSION_bytestring(x,y,z) 1-#endif--#if MIN_VERSION_bytestring(0,10,0)-import Data.ByteString.Lazy (fromStrict)-#else-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as S-#endif--import qualified Data.Text as T-import qualified Data.Text.Read-import System.Timeout (timeout)--#ifndef MIN_VERSION_base-#define MIN_VERSION_base(x,y,z) 1-#endif-#if MIN_VERSION_base(4,3,0)-import Data.ByteString (hGetSome)-#else-import GHC.IO.Handle.Types-import System.IO (hWaitForInput, hIsEOF)-import System.IO.Error (mkIOError, illegalOperationErrorType)---- | Like 'hGet', except that a shorter 'ByteString' may be returned--- if there are not enough bytes immediately available to satisfy the--- whole request. 'hGetSome' only blocks if there is no data--- available, and EOF has not yet been reached.-hGetSome :: Handle -> Int -> IO S.ByteString-hGetSome hh i- | i > 0 = let- loop = do- s <- S.hGetNonBlocking hh i- if not (S.null s)- then return s- else do eof <- hIsEOF hh- if eof then return s- else hWaitForInput hh (-1) >> loop- -- for this to work correctly, the- -- Handle should be in binary mode- -- (see GHC ticket #3808)- in loop- | i == 0 = return S.empty- | otherwise = illegalBufferSize hh "hGetSome" i--illegalBufferSize :: Handle -> String -> Int -> IO a-illegalBufferSize handle fn sz =- ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing)- --TODO: System.IO uses InvalidArgument here, but it's not exported :-(- where- msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz []-#endif--infixr 5 <>-(<>) :: Data.Monoid.Monoid m => m -> m -> m-(<>) = Data.Monoid.mappend--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--hasNoBody :: S8.ByteString -- ^ request method- -> Int -- ^ status code- -> Bool-hasNoBody "HEAD" _ = True-hasNoBody _ 204 = True-hasNoBody _ 304 = True-hasNoBody _ i = 100 <= i && i < 200--#if !MIN_VERSION_bytestring(0,10,0)-{-# INLINE fromStrict #-}-fromStrict :: S.ByteString -> L.ByteString-fromStrict x = L.fromChunks [x]-#endif---- Disabling the custom timeout code for now. See: https://github.com/snoyberg/http-client/issues/116-{--data TimeoutHandler = TimeoutHandler {-# UNPACK #-} !TimeSpec (IO ())-newtype TimeoutManager = TimeoutManager (IORef ([TimeoutHandler], Bool))--newTimeoutManager :: IO TimeoutManager-newTimeoutManager = fmap TimeoutManager $ newIORef ([], False)--timeoutManager :: TimeoutManager-timeoutManager = unsafePerformIO newTimeoutManager-{-# NOINLINE timeoutManager #-}--spawnWorker :: TimeoutManager -> IO ()-spawnWorker (TimeoutManager ref) = void $ forkIO $ fix $ \loop -> do- threadDelay 500000- join $ atomicModifyIORef ref $ \(hs, isCleaning) -> assert (not isCleaning) $- if null hs- then (([], False), return ())- else (([], True), ) $ do- now <- getTime Monotonic- front <- go now id hs- atomicModifyIORef ref $ \(hs', isCleaning') ->- assert isCleaning' $ ((front hs', False), ())- loop- where- go now =- go'- where- go' front [] = return front- go' front (h@(TimeoutHandler time action):hs)- | time < now = do- _ :: Either SomeException () <- try action- go' front hs- | otherwise = go' (front . (h:)) hs--addHandler :: TimeoutManager -> TimeoutHandler -> IO ()-addHandler man@(TimeoutManager ref) h = mask_ $ join $ atomicModifyIORef ref- $ \(hs, isCleaning) ->- let hs' = h : hs- action- | isCleaning || not (null hs) = return ()- | otherwise = spawnWorker man- in ((hs', isCleaning), action)---- | Has same semantics as @System.Timeout.timeout@, but implemented in such a--- way to avoid high-concurrency contention issues. See:------ https://github.com/snoyberg/http-client/issues/98-timeout :: Int -> IO a -> IO (Maybe a)-timeout delayU inner = do- TimeSpec nowS nowN <- getTime Monotonic- let (delayS, delayU') = delayU `quotRem` 1000000- delayN = delayU' * 1000- stopN' = nowN + delayN- stopS' = nowS + delayS- (stopN, stopS)- | stopN' > 1000000000 = (stopN' - 1000000000, stopS' + 1)- | otherwise = (stopN', stopS')- toStop = TimeSpec stopS stopN- toThrow <- newIORef True- tid <- myThreadId- let handler = TimeoutHandler toStop $ do- toThrow' <- readIORef toThrow- when toThrow' $ throwTo tid TimeoutTriggered- eres <- try $ do- addHandler timeoutManager handler- inner `finally` writeIORef toThrow False- return $ case eres of- Left TimeoutTriggered -> Nothing- Right x -> Just x+import Text.Read (readMaybe)+import Control.Monad (guard) -data TimeoutTriggered = TimeoutTriggered- deriving (Show, Typeable)-instance Exception TimeoutTriggered--}+-- | 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
@@ -0,0 +1,380 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}++{-+Copyright (c) 2002, Warrick Gray+Copyright (c) 2002-2005, Ian Lynagh+Copyright (c) 2003-2006, Bjorn Bringert+Copyright (c) 2004, Andre Furtado+Copyright (c) 2004-2005, Dominic Steinitz+Copyright (c) 2007, Robin Bate Boerop+Copyright (c) 2008-2010, Sigbjorn Finne+Copyright (c) 2009, Eric Kow+Copyright (c) 2010, Antoine Latter+Copyright (c) 2004, 2010-2011, Ganesh Sittampalam+Copyright (c) 2011, Duncan Coutts+Copyright (c) 2011, Matthew Gruen+Copyright (c) 2011, Jeremy Yallop+Copyright (c) 2011, Eric Hesselink+Copyright (c) 2011, Yi Huang+Copyright (c) 2011, Tom Lokhorst+Copyright (c) 2017, Vassil Keremidchiev++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * The names of contributors may not be used to endorse or promote+ products derived from this software without specific prior+ written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+-}++module Network.HTTP.Proxy( ProxyProtocol(..), EnvHelper(..),+ systemProxyHelper, envHelper,+ httpProtocol,+ ProxySettings ) where++import qualified Control.Applicative as A+import Control.Arrow (first)+import Control.Monad (guard)+import qualified Data.ByteString.Char8 as S8+import Data.Char (toLower)+import qualified Data.Map as Map+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Network.HTTP.Client.Request (applyBasicProxyAuth,+ extractBasicAuthInfo)+import Network.HTTP.Client.Types (HttpExceptionContent (..),+ Proxy (..), Request (..),+ throwHttp)+import qualified Network.URI as U+import System.Environment (getEnvironment)++#if defined(mingw32_HOST_OS)+import Control.Exception (IOException, bracket, catch, try)+import Control.Monad (join, liftM, mplus, when)+import Data.List (isInfixOf, isPrefixOf)+import Foreign (Storable (peek, sizeOf), alloca,+ castPtr, toBool)+import Network.URI (parseAbsoluteURI)+import Safe (readDef)+import System.IO+import System.Win32.Registry (hKEY_CURRENT_USER, rEG_DWORD,+ regCloseKey, regOpenKey,+ regQueryValue, regQueryValueEx)+import System.Win32.Types (DWORD, HKEY)+#endif++type EnvName = T.Text+type HostAddress = S8.ByteString+type UserName = S8.ByteString+type Password = S8.ByteString++-- There are other proxy protocols like SOCKS, FTP, etc.+data ProxyProtocol = HTTPProxy | HTTPSProxy++instance Show ProxyProtocol where+ show HTTPProxy = "http"+ show HTTPSProxy = "https"++data ProxySettings = ProxySettings { _proxyHost :: Proxy,+ _proxyAuth :: Maybe (UserName, Password) }+ deriving Show++httpProtocol :: Bool -> ProxyProtocol+httpProtocol True = HTTPSProxy+httpProtocol False = HTTPProxy++data EnvHelper = EHFromRequest+ | EHNoProxy+ | EHUseProxy Proxy++headJust :: [Maybe a] -> Maybe a+headJust [] = Nothing+headJust (Nothing:xs) = headJust xs+headJust ((y@(Just _)):_) = y++systemProxyHelper :: Maybe T.Text -> ProxyProtocol -> EnvHelper -> IO (Request -> Request)+systemProxyHelper envOveride prot eh = do+ let envName' Nothing = envName prot+ envName' (Just name) = name++ modifier <- envHelper (envName' envOveride)++-- Under Windows try first env. variables override then Windows proxy settings+#if defined(mingw32_HOST_OS)+ modifier' <- systemProxy prot+ let modifiers = [modifier, modifier']+#else+ let modifiers = [modifier]+#endif++ let chooseMod :: Request -> Maybe ProxySettings+ chooseMod req = headJust . map (\m -> m . host $ req) $ modifiers++ noEnvProxy = case eh of+ EHFromRequest -> id+ EHNoProxy -> \req -> req { proxy = Nothing }+ EHUseProxy p -> \req -> req { proxy = Just p }++ let result req = toRequest . chooseMod $ req where+ toRequest Nothing = noEnvProxy req+ toRequest (Just (ProxySettings p muserpass)) = maybe id (uncurry applyBasicProxyAuth) muserpass+ req { proxy = Just p }+ return result+++#if defined(mingw32_HOST_OS)+windowsProxyString :: ProxyProtocol -> IO (Maybe (String, String))+windowsProxyString proto = do+ mProxy <- registryProxyString+ return $ do+ (proxies, exceptions) <- mProxy+ protoProxy <- parseWindowsProxy proto proxies+ return (protoProxy, exceptions)++registryProxyLoc :: (HKEY,String)+registryProxyLoc = (hive, path)+ where+ -- some sources say proxy settings should be at+ -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+ -- \CurrentVersion\Internet Settings\ProxyServer+ -- but if the user sets them with IE connection panel they seem to+ -- end up in the following place:+ hive = hKEY_CURRENT_USER+ path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++-- read proxy settings from the windows registry; this is just a best+-- effort and may not work on all setups.+registryProxyString :: IO (Maybe (String, String))+registryProxyString = catch+ (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do+ enable <- toBool . maybe 0 id A.<$> regQueryValueDWORD hkey "ProxyEnable"+ if enable+ then do+#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+ server <- regQueryValue hkey (Just "ProxyServer")+ exceptions <- try $ regQueryValue hkey (Just "ProxyOverride") :: IO (Either IOException String)+#endif+ return $ Just (server, either (const "") id exceptions)+ else return Nothing)+ hideError where+ hideError :: IOException -> IO (Maybe (String, String))+ hideError _ = return Nothing++-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..."+-- even though the following article indicates otherwise+-- https://support.microsoft.com/en-us/kb/819961+--+-- to be sure, parse strings where each entry in the ';'-separated list above is+-- either in the format "protocol=..." or "protocol://..."+parseWindowsProxy :: ProxyProtocol -> String -> Maybe String+parseWindowsProxy proto s =+ case proxies of+ x:_ -> Just x+ _ -> Nothing+ where+ parts = split ';' s+ pr x = case break (== '=') x of+ (p, []) -> p -- might be in format http://+ (p, u) -> p ++ "://" ++ drop 1 u++ protoPrefix = (show proto) ++ "://"+ proxies = filter (isPrefixOf protoPrefix) . map pr $ parts++ split :: Eq a => a -> [a] -> [[a]]+ split _ [] = []+ split a xs = case break (a ==) xs of+ (ys, []) -> [ys]+ (ys, _:zs) -> ys:split a zs++-- Extract proxy settings from Windows registry. This is a standard way in Windows OS.+systemProxy :: ProxyProtocol -> IO (HostAddress -> Maybe ProxySettings)+systemProxy proto = do+ let isURLlocal "127.0.0.1" = True+ isURLlocal "localhost" = True+ isURLlocal _ = False++ hasLocal exceptions = "<local>" `isInfixOf` exceptions++ settings <- fetchProxy proto+ return $ \url -> do+ (proxy, exceptions) <- settings++ -- Skip proxy for local hosts if it's enabled in IE settings+ -- TODO Implement skipping for address patterns, like (*.google.com)+ if (isURLlocal url && hasLocal exceptions) || (url `S8.isInfixOf` (S8.pack exceptions)) then Nothing+ else Just proxy++-- | @fetchProxy flg@ gets the local proxy settings and parse the string+-- into a @Proxy@ value.+-- Proxy settings are sourced from IE/WinInet's proxy+-- setting in the Registry.+fetchProxy :: ProxyProtocol -> IO (Maybe (ProxySettings, String))+fetchProxy proto = do+ mstr <- windowsProxyString proto+ case mstr of+ Nothing -> return Nothing+ Just (proxy, except) -> case parseProxy proto proxy of+ Just p -> return $ Just (p, except)+ Nothing ->+ throwHttp . InvalidProxySettings . T.pack . unlines $+ [ "Invalid http proxy uri: " ++ show proxy+ , "proxy uri must be http with a hostname"+ , "ignoring http proxy, trying a direct connection"+ ]++-- | @parseProxy str@ translates a proxy server string into a @ProxySettings@ value;+-- returns @Nothing@ if not well-formed.+parseProxy :: ProxyProtocol -> String -> Maybe ProxySettings+parseProxy proto str = join+ . fmap (uri2proxy proto)+ $ parseHttpURI str+ `mplus` parseHttpURI (protoPrefix ++ str)+ where+ protoPrefix = (show proto) ++ "://"+ parseHttpURI str' =+ case parseAbsoluteURI str' of+ Just uri@U.URI{U.uriAuthority = Just{}} -> Just (fixUserInfo uri)+ _ -> Nothing++ -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+ -- which lack the @\"http://\"@ URI scheme. The problem is that+ -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+ -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+ --+ -- So our strategy is to try parsing as normal uri first and if it lacks the+ -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+ --++-- | @dropWhileTail p ls@ chops off trailing elements from @ls@+-- until @p@ returns @False@.+dropWhileTail :: (a -> Bool) -> [a] -> [a]+dropWhileTail f ls =+ case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] }+ where+ chop x (Just xs) = Just (x:xs)+ chop x _+ | f x = Nothing+ | otherwise = Just [x]++-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence+-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second+-- list is empty and the first is equal to @ls@.+chopAtDelim :: Eq a => a -> [a] -> ([a],[a])+chopAtDelim elt xs =+ case break (==elt) xs of+ (_,[]) -> (xs,[])+ (as,_:bs) -> (as,bs)++-- | tidy up user portion, don't want the trailing "\@".+fixUserInfo :: U.URI -> U.URI+fixUserInfo uri = uri{ U.uriAuthority = f `fmap` U.uriAuthority uri }+ where+ f a@U.URIAuth{U.uriUserInfo=s} = a{U.uriUserInfo=dropWhileTail (=='@') s}++defaultHTTPport :: ProxyProtocol -> Int+defaultHTTPport HTTPProxy = 80+defaultHTTPport HTTPSProxy = 443++uri2proxy :: ProxyProtocol -> U.URI -> Maybe ProxySettings+uri2proxy proto uri@U.URI{ U.uriAuthority = Just (U.URIAuth auth' hst prt) } =+ if (show proto ++ ":") == U.uriScheme uri then+ Just (ProxySettings (Proxy (S8.pack hst) (port prt)) auth) else Nothing+ where+ port (':':xs) = readDef (defaultHTTPport proto) xs+ port _ = (defaultHTTPport proto)++ auth =+ case auth' of+ [] -> Nothing+ as -> Just ((S8.pack . U.unEscapeString $ usr), (S8.pack . U.unEscapeString $ pwd))+ where+ (usr,pwd) = chopAtDelim ':' as++uri2proxy _ _ = Nothing++regQueryValueDWORD :: HKEY -> String -> IO (Maybe DWORD)+regQueryValueDWORD hkey name = alloca $ \ptr -> do+ key <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+ if key == rEG_DWORD then+ Just A.<$> peek ptr+ else return Nothing++-- defined(mingw32_HOST_OS)+#endif++envName :: ProxyProtocol -> EnvName+envName proto = T.pack $ show proto ++ "_proxy"++-- Extract proxy settings from environment variables. This is a standard way in Linux.+envHelper :: EnvName -> IO (HostAddress -> Maybe ProxySettings)+envHelper name = do+ env <- getEnvironment+ let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env+ lookupEnvVar n = lookup (T.unpack n) env A.<|> Map.lookup n lenv+ noProxyDomains = domainSuffixes (lookupEnvVar "no_proxy")++ case lookupEnvVar name of+ Nothing -> return . const $ Nothing+ Just "" -> return . const $ Nothing+ Just str -> do+ let invalid = throwHttp $ InvalidProxyEnvironmentVariable name (T.pack str)+ (p, muserpass) <- maybe invalid return $ do+ let allowedScheme x = x == "http:"+ uri <- case U.parseURI str of+ Just u | allowedScheme (U.uriScheme u) -> return u+ _ -> U.parseURI $ "http://" ++ str++ guard $ allowedScheme $ U.uriScheme uri+ guard $ null (U.uriPath uri) || U.uriPath uri == "/"+ guard $ null $ U.uriQuery uri+ guard $ null $ U.uriFragment uri++ auth <- U.uriAuthority uri+ port' <-+ case U.uriPort auth of+ "" -> Just 80+ ':':rest ->+ case decimal $ T.pack rest of+ Right (p, "") -> Just p+ _ -> Nothing+ _ -> Nothing++ Just (Proxy (S8.pack $ U.uriRegName auth) port', extractBasicAuthInfo uri)+ return $ \hostRequest ->+ if hostRequest `hasDomainSuffixIn` noProxyDomains+ then Nothing+ else Just $ ProxySettings p muserpass+ where prefixed s | S8.head s == '.' = s+ | otherwise = S8.cons '.' s+ domainSuffixes Nothing = []+ domainSuffixes (Just "") = []+ domainSuffixes (Just no_proxy) = [prefixed $ S8.dropWhile (== ' ') suffix | suffix <- S8.split ',' (S8.pack (map toLower no_proxy)), not (S8.null suffix)]+ hasDomainSuffixIn host' = any (`S8.isSuffixOf` prefixed (S8.map toLower host'))
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.4+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@@ -31,23 +31,25 @@ Network.HTTP.Client.Response Network.HTTP.Client.Types Network.HTTP.Client.Util+ Network.HTTP.Proxy Network.PublicSuffixList.Lookup Network.PublicSuffixList.Types Network.PublicSuffixList.Serialize Network.PublicSuffixList.DataStructure- build-depends: base >= 4.5 && < 5+ Data.KeyedPool+ build-depends: base >= 4.10 && < 5 , bytestring >= 0.10 , text >= 0.11 , http-types >= 0.8 , blaze-builder >= 0.3 , time >= 1.2- , network >= 2.3- , streaming-commons >= 0.1.0.2 && < 0.2- , containers+ , network >= 2.4+ , streaming-commons >= 0.1.0.2 && < 0.3+ , containers >= 0.5 , transformers- , deepseq >= 1.3 && <1.5+ , deepseq >= 1.3 && <1.6 , case-insensitive >= 1.0- , base64-bytestring >= 1.0 && <1.1+ , base64-bytestring >= 1.0 , cookie , exceptions >= 0.4 , array@@ -55,10 +57,29 @@ , filepath , 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 build-depends: network < 2.6++ if !impl(ghc>=8.0)+ build-depends: semigroups >= 0.16.1++ -- See build failure at https://travis-ci.org/snoyberg/http-client/jobs/359573631+ if impl(ghc < 7.10)+ -- Disable building with GHC before 8.0.2.+ -- Due to a cabal bug, do not use buildable: False,+ -- but instead give it an impossible constraint.+ -- See: https://github.com/haskell-infra/hackage-trustees/issues/165+ build-depends: unsupported-ghc-version > 1 && < 1+++ if os(mingw32)+ build-depends: Win32, safe+ default-language: Haskell2010 test-suite spec@@ -67,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@@ -81,7 +103,6 @@ , transformers , deepseq , case-insensitive- , base64-bytestring , zlib , async , streaming-commons >= 0.1.1@@ -92,6 +113,9 @@ type: exitcode-stdio-1.0 hs-source-dirs: test-nonet default-language: Haskell2010+ ghc-options: -threaded+ if os(windows)+ cpp-options: -DWINDOWS other-modules: Network.HTTP.ClientSpec Network.HTTP.Client.ResponseSpec Network.HTTP.Client.BodySpec@@ -99,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@@ -114,7 +141,6 @@ , transformers , deepseq , case-insensitive- , base64-bytestring , zlib , async , streaming-commons >= 0.1.1
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/RequestSpec.hs view
@@ -7,21 +7,39 @@ import Data.IORef import Data.Maybe (isJust, fromMaybe, fromJust) import Network.HTTP.Client.Internal-import Network.URI (URI(..), URIAuth(..), parseURI) +import Network.URI (URI(..), URIAuth(..), parseURI) import Test.Hspec+import Data.Monoid ((<>))+import Network.HTTP.Client (defaultRequest)+import Data.List (isInfixOf) spec :: Spec spec = do describe "case insensitive scheme" $ do- forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url ->+ forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url -> do it url $ case parseUrlThrow url of Nothing -> error "failed" Just _ -> return () :: IO ()- forM_ ["ftp://example.com"] $ \url ->+ it ("URI " ++ url) $ do+ case parseURI url of+ Nothing -> error ("invalid test URI: " ++ url)+ Just uri ->+ case requestFromURI uri of+ Nothing -> error "failed"+ Just _ -> return () :: IO ()+ forM_ ["ftp://example.com"] $ \url -> do it url $ case parseUrlThrow url of Nothing -> return () :: IO () Just req -> error $ show req+ it ("URI " ++ url) $ do+ case parseURI url of+ Nothing -> error ("invalid test URI: " ++ url)+ Just uri ->+ case requestFromURI uri of+ Nothing -> return () :: IO ()+ Just req -> error (show req) + describe "authentication in url" $ do it "passes validation" $ do case parseUrlThrow "http://agent:topsecret@example.com" of@@ -35,6 +53,30 @@ (uriRegName $ fromJust $ uriAuthority $ getUri $ fromJust request) `shouldBe` requestHostnameWithoutAuth field `shouldSatisfy` isJust field `shouldBe` Just "Basic dXNlcjpwYXNz"++ describe "getUri" $ do+ context "when protocol is http and port is 80" $ do+ it "omits port" $ do+ let url = "http://example.com/"+ request <- parseRequest url+ show (getUri request) `shouldBe` url++ context "when protocol is https and port is 443" $ do+ it "omits port" $ do+ let url = "https://example.com/"+ request <- parseRequest url+ show (getUri request) `shouldBe` url++ context "when protocol is https and port is 80" $ do+ it "does not omit port" $ do+ let url = "https://example.com:80/"+ request <- parseRequest url+ show (getUri request) `shouldBe` url++ describe "Show Request" $+ it "redacts authorization header content" $ do+ let request = defaultRequest { requestHeaders = [("Authorization", "secret")] }+ isInfixOf "secret" (show request) `shouldBe` False describe "applyBasicProxyAuth" $ do let request = applyBasicProxyAuth "user" "pass" <$> parseUrlThrow "http://example.org"
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do- let getResponse' conn = getResponse (const $ return ()) Nothing req 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
@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.ClientSpec where@@ -12,7 +13,8 @@ import qualified Network.HTTP.Client as NC import qualified Network.HTTP.Client.Internal as Internal import Network.HTTP.Types (status413)-import Network.Socket (sClose)+import Network.HTTP.Types.Header+import qualified Network.Socket as NS import Test.Hspec import qualified Data.Streaming.Network as N import qualified Data.ByteString as S@@ -21,6 +23,17 @@ import Data.IORef import System.Mem (performGC) +-- See: https://github.com/snoyberg/http-client/issues/111#issuecomment-366526660+notWindows :: Monad m => m () -> m ()+#ifdef WINDOWS+notWindows _ = return ()+#else+notWindows x = x+#endif++crlf :: S.ByteString+crlf = "\r\n"+ main :: IO () main = hspec spec @@ -29,26 +42,54 @@ 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")- (sClose . snd)+ (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 (N.bindRandomPortTCP "*4")- (sClose . snd)+ (NS.close . snd) $ \(port, lsocket) -> withAsync (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) (const $ inner port)@@ -57,13 +98,15 @@ Async.race_ (silentIOError $ forever (N.appRead ad)) (silentIOError $ N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: /\r\nConnection: close\r\n\r\nhello")- N.appCloseConnection ad+ case N.appRawSocket ad of+ Nothing -> error "appRawSocket failed"+ Just s -> NS.shutdown s NS.ShutdownSend bad100Server :: Bool -- ^ include extra headers? -> (Int -> IO a) -> IO a bad100Server extraHeaders inner = bracket (N.bindRandomPortTCP "*4")- (sClose . snd)+ (NS.close . snd) $ \(port, lsocket) -> withAsync (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) (const $ inner port)@@ -81,7 +124,7 @@ earlyClose413 :: (Int -> IO a) -> IO a earlyClose413 inner = bracket (N.bindRandomPortTCP "*4")- (sClose . snd)+ (NS.close . snd) $ \(port, lsocket) -> withAsync (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) (const $ inner port)@@ -110,12 +153,14 @@ lengthZeroAndChunkZero = serveWith "HTTP/1.1 200 OK\r\ncontent-length: 0\r\ntransfer-encoding: chunked\r\n\r\n0\r\n\r\n" serveWith :: S.ByteString -> (Int -> IO a) -> IO a-serveWith resp inner = bracket- (N.bindRandomPortTCP "*4")- (sClose . snd)- $ \(port, lsocket) -> withAsync- (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app)- (const $ inner port)+serveWith resp inner = do+ (port, lsocket) <- (N.bindRandomPortTCP "*4")+ res <- Async.race+ (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app)+ (inner port)+ case res of+ Left () -> error $ "serveWith: got Left"+ Right x -> return x where app ad = silentIOError $ do let readHeaders front = do@@ -145,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@@ -154,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@@ -165,7 +245,7 @@ _ -> False it "connecting to missing server gives nice error message" $ do (port, socket) <- N.bindRandomPortTCP "*4"- sClose socket+ NS.close socket req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port man <- newManager defaultManagerSettings httpLbs req man `shouldThrow` \e ->@@ -185,28 +265,28 @@ test False test True - it "early close on a 413" $ earlyClose413 $ \port' -> do+ notWindows $ it "early close on a 413" $ earlyClose413 $ \port' -> do man <- newManager defaultManagerSettings res <- getChunkedResponse port' man responseBody res `shouldBe` "goodbye" responseStatus res `shouldBe` status413 - it "length zero and chunking zero #108" $ lengthZeroAndChunkZero $ \port' -> do+ notWindows $ it "length zero and chunking zero #108" $ lengthZeroAndChunkZero $ \port' -> do man <- newManager defaultManagerSettings res <- getChunkedResponse port' man responseBody res `shouldBe` "" - it "length zero and chunking" $ lengthZeroAndChunked $ \port' -> do+ notWindows $ it "length zero and chunking" $ lengthZeroAndChunked $ \port' -> do man <- newManager defaultManagerSettings res <- getChunkedResponse port' man responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks." - it "length and chunking" $ lengthAndChunked $ \port' -> do+ notWindows $ it "length and chunking" $ lengthAndChunked $ \port' -> do man <- newManager defaultManagerSettings res <- getChunkedResponse port' man responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks." - it "withResponseHistory and redirect" $ redirectCloseServer $ \port -> do+ notWindows $ it "withResponseHistory and redirect" $ redirectCloseServer $ \port -> do -- see https://github.com/snoyberg/http-client/issues/169 req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' {redirectCount = 1}@@ -241,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,51 +1,119 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where -import Network (withSocketsDo)+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 spec :: Spec spec = describe "Client" $ do- it "works" $ withSocketsDo $ do+ it "works" $ do req <- parseUrlThrow "http://httpbin.org/" man <- newManager defaultManagerSettings 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" $ withSocketsDo $ do+ it "success" $ do req <- parseUrlThrow "POST http://httpbin.org/post" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 - it "failure" $ withSocketsDo $ do+ it "failure" $ do req <- parseRequest "PUT http://httpbin.org/post" 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 res <- httpLbs req man responseStatus res `shouldBe` found302 + context "managerModifyResponse" $ do+ it "allows to modify the response status code" $ do+ let modify :: Response BodyReader -> IO (Response BodyReader)+ modify res = do+ return res {+ responseStatus = (responseStatus res) {+ statusCode = 201+ }+ }+ settings = defaultManagerSettings { managerModifyResponse = modify }+ man <- newManager settings+ res <- httpLbs "http://httpbin.org" man+ (statusCode.responseStatus) res `shouldBe` 201++ it "modifies the response body" $ do+ let modify :: Response BodyReader -> IO (Response BodyReader)+ modify res = do+ reader <- constBodyReader [BS.pack "modified response body"]+ return res {+ responseBody = reader+ }+ settings = defaultManagerSettings { managerModifyResponse = modify }+ man <- newManager settings+ res <- httpLbs "http://httpbin.org" man+ responseBody res `shouldBe` "modified response body"+ context "managerModifyRequest" $ do it "port" $ do let modify req = return req { port = 80 }@@ -60,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 ()