http-client 0.4.20 → 0.7.19
raw patch · 28 files changed
Files
- ChangeLog.md +308/−0
- Data/KeyedPool.hs +325/−0
- Network/HTTP/Client.hs +191/−48
- Network/HTTP/Client/Body.hs +69/−38
- Network/HTTP/Client/Connection.hs +140/−50
- Network/HTTP/Client/Cookies.hs +47/−11
- Network/HTTP/Client/Core.hs +193/−97
- Network/HTTP/Client/Headers.hs +87/−37
- Network/HTTP/Client/Internal.hs +2/−0
- Network/HTTP/Client/Manager.hs +119/−334
- Network/HTTP/Client/MultipartFormData.hs +37/−30
- Network/HTTP/Client/Request.hs +321/−176
- Network/HTTP/Client/Response.hs +85/−28
- Network/HTTP/Client/Types.hs +422/−121
- Network/HTTP/Client/Util.hs +9/−167
- Network/HTTP/Proxy.hs +380/−0
- README.md +7/−0
- http-client.cabal +38/−12
- publicsuffixlist/Network/PublicSuffixList/Serialize.hs +3/−3
- test-nonet/Network/HTTP/Client/BodySpec.hs +57/−15
- test-nonet/Network/HTTP/Client/ConnectionSpec.hs +23/−0
- test-nonet/Network/HTTP/Client/CookieSpec.hs +76/−0
- test-nonet/Network/HTTP/Client/HeadersSpec.hs +76/−8
- test-nonet/Network/HTTP/Client/RequestBodySpec.hs +4/−4
- test-nonet/Network/HTTP/Client/RequestSpec.hs +67/−27
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +3/−3
- test-nonet/Network/HTTP/ClientSpec.hs +240/−68
- test/Network/HTTP/ClientSpec.hs +138/−8
ChangeLog.md view
@@ -1,3 +1,311 @@+# 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)++## 0.5.3.4++* Doc improvements++## 0.5.3.3++* Add missing colon in Host header [#235](https://github.com/snoyberg/http-client/pull/235)++## 0.5.3.2++* Minor doc updates++## 0.5.3.1++* The closeConnection method for tls connections should not be called multiple+ times [#225](https://github.com/snoyberg/http-client/issues/225)++## 0.5.3++* Expose `makeConnection` and `socketConnection` as a stable API [#223](https://github.com/snoyberg/http-client/issues/223)++## 0.5.2++* Enable rawConnectionModifySocketSize to expose openSocketConnectionSize [#218](https://github.com/snoyberg/http-client/pull/218)++## 0.5.1++* Enable managerModifyRequest to modify redirectCount [#208](https://github.com/snoyberg/http-client/pull/208)++## 0.5.0.1++* Doc fix++## 0.5.0++* Remove `instance Default Request`+* Modify `instance IsString Request` to use `parseRequest` instead of `parseUrlThrow`+* Clean up the `HttpException` constructors+* Rename `checkStatus` to `checkResponse` and modify type+* Fix the ugly magic constant workaround for responseTimeout+* Remove `getConnectionWrapper`+* Add the `HttpExceptionRequest` wrapper so that all exceptions related to a+ request are thrown with that request's information++## 0.4.31++* Added length validation for RequestBodyStream [#205](https://github.com/snoyberg/http-client/pull/205)++## 0.4.30++* Initial implementation of [#193](https://github.com/snoyberg/http-client/issues/193)+ * Deprecate `parseUrl`+ * Add `parseUrlThrow`, `parseRequest`, and `parseRequest_`++## 0.4.29++* Changed the order of connecting a socket and tweaking a socket, such that the socket tweaking callback now happen before connecting.+* add setRequestIgnoreStatus [#201](https://github.com/snoyberg/http-client/pull/201)+* Added missing Host: HTTP header for https CONNECT [#192](https://github.com/snoyberg/http-client/pull/192)+* Fix: Redirects will be followed in httpRaw' when reusing a dead connection [#195](https://github.com/snoyberg/http-client/issues/195)++## 0.4.28++* Add support for including request method in URL+* `requestManagerOverride`+* `RequestBodyIO`++## 0.4.27.1++* Incorrect idle connection count in HTTP manager [#185](https://github.com/snoyberg/http-client/issues/185)++## 0.4.27++* Enable managerModifyRequest to modify checkStatus [#179](https://github.com/snoyberg/http-client/pull/179)++## 0.4.26.2++* Fix compilation for GHC 7.4++## 0.4.26.1++* Fix compilation for GHC < 7.10++## 0.4.26++* Make sure we never read from or write to closed socket [#170](https://github.com/snoyberg/http-client/pull/170)++## 0.4.25++* Don't error out when response body flushing fails [#169](https://github.com/snoyberg/http-client/issues/169)++## 0.4.24++* Use a new `TlsExceptionHostPort` exception to indicate the host and port of the server we were trying to connect to when a TLS exception occurred. See [commercialhaskell/stack#1010](https://github.com/commercialhaskell/stack/issues/1010)++## 0.4.23++* Case insensitive cookie domains [#158](https://github.com/snoyberg/http-client/issues/158)++## 0.4.22++* ProxyConnectException now returns Right HttpException. [#155](https://github.com/snoyberg/http-client/pull/155)++## 0.4.21++* Support `no_proxy` environment variable. [#140](https://github.com/snoyberg/http-client/issues/140) [#145](https://github.com/snoyberg/http-client/pull/145)+ ## 0.4.20 * Expose `brReadSome`
+ 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,75 +1,83 @@-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}-{-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-}--- | This is the main entry point for using http-client. Used by itself, this+{-# LANGUAGE CPP #-}+-- |+--+-- = Simpler API+--+-- The API below is rather low-level. The @Network.HTTP.Simple@ module (from+-- the @http-conduit@ package) provides a higher-level API with built-in+-- 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://github.com/snoyberg/http-client/blob/master/TUTORIAL.md+--+-- = Lower-level API+--+-- This is the main entry point for using http-client. Used by itself, this -- module provides low-level access for streaming request and response bodies, -- and only non-secure HTTP connections. Helper packages such as http-conduit--- provided higher level streaming approaches, while other helper packages like+-- provide higher level streaming approaches, while other helper packages like -- http-client-tls provide secure connections. -- -- There are three core components to be understood here: requests, responses,--- and managers. A @Manager@ keeps track of open connections to various hosts,+-- and managers. A 'Manager' keeps track of open connections to various hosts, -- and when requested, will provide either an existing open connection or--- create a new connection on demand. A @Manager@ also automatically reaps--- connections which have been unused for a certain period of time. A @Manager@+-- create a new connection on demand. A 'Manager' also automatically reaps+-- connections which have been unused for a certain period of time. A 'Manager' -- allows for more efficient HTTP usage by allowing for keep-alive connections. -- Secure HTTP connections can be allowed by modifying the settings used for--- creating a manager. The simplest way to create a @Manager@ is with:+-- creating a manager. The simplest way to create a 'Manager' is with: -- -- @ -- 'newManager' 'defaultManagerSettings' -- @ ----- While generally speaking it is a good idea to share a single @Manager@+-- While generally speaking it is a good idea to share a single 'Manager' -- throughout your application, there are cases where it makes more sense to--- create and destroy @Manager@s more frequently. As an example, if you have an+-- create and destroy 'Manager's more frequently. As an example, if you have an -- 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+-- a 'Manager' will result in idle connections being kept open longer than+-- 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.) ----- The next core component is a @Request@, which represents a single HTTP--- request to be sent to a specific server. @Request@s allow for many settings+-- The next core component is a 'Request', which represents a single HTTP+-- request to be sent to a specific server. 'Request's allow for many settings -- to control exact how they function, but usually the simplest approach for--- creating a @Request@ is to use 'parseUrl'.+-- creating a 'Request' is to use 'parseRequest'. ----- Finally, a @Response@ is the result of sending a single @Request@ to a--- server, over a connection which was acquired from a @Manager@. Note that you+-- Finally, a 'Response' is the result of sending a single 'Request' to a+-- server, over a connection which was acquired from a 'Manager'. Note that you -- must close the response when you're done with it to ensure that the--- connection is recycled to the @Manager@ to either be used by another--- request, or to be reaped. Usage of @withResponse@ will ensure that this+-- connection is recycled to the 'Manager' to either be used by another+-- request, or to be reaped. Usage of 'withResponse' will ensure that this -- happens automatically. -- -- Helper packages may provide replacements for various recommendations listed -- above. For example, if using http-client-tls, instead of using--- 'defaultManagerSettings', you would want to use @tlsManagerSettings@. Be+-- 'defaultManagerSettings', you would want to use 'tlsManagerSettings'. Be -- sure to read the relevant helper library documentation for more information. -- -- A note on exceptions: for the most part, all actions that perform I/O should--- be assumed to throw an @HttpException@ in the event of some problem, and all--- pure functions will be total. For example, @withResponse@, @httpLbs@, and--- @BodyReader@ can all throw exceptions. Functions like @responseStatus@ and--- @applyBasicAuth@ are guaranteed to be total (or there\'s a bug in the+-- be assumed to throw an 'HttpException' in the event of some problem, and all+-- pure functions will be total. For example, 'withResponse', 'httpLbs', and+-- 'BodyReader' can all throw exceptions. Functions like 'responseStatus' and+-- 'applyBasicAuth' are guaranteed to be total (or there's a bug in the -- library). ----- One thing to be cautioned about: the type of @parseUrl@ allows it to work in--- different monads. If used in the @IO@ monad, it will throw an exception in+-- One thing to be cautioned about: the type of 'parseRequest' allows it to work in+-- different monads. If used in the 'IO' monad, it will throw an exception in -- the case of an invalid URI. In addition, if you leverage the @IsString@--- instance of the @Request@ value via @OverloadedStrings@, an invalid URI will+-- instance of the 'Request' value via @OverloadedStrings@, an invalid URI will -- result in a partial value. Caveat emptor!------ Non-2xx responses: the default behavior of all functions in http-client is--- to automatically perform up to 10 redirects (response codes 301, 302, 303,--- and 307), and to throw a 'StatusCodeException' on all responses whose status--- are not in the 2xx range. These behaviors can be overridden by the--- 'redirectCount' and 'checkStatus' settings on a request, respectively. module Network.HTTP.Client- ( -- * Performing requests+ ( -- $example1++ -- * Performing requests withResponse , httpLbs , httpNoBody@@ -96,28 +104,51 @@ , managerTlsConnection , managerResponseTimeout , managerRetryableException- , managerWrapIOException+ , managerWrapException , managerIdleConnectionCount , managerModifyRequest+ , managerModifyResponse -- *** Manager proxy settings , managerSetProxy , managerSetInsecureProxy , managerSetSecureProxy+ , managerSetMaxHeaderLength+ , managerSetMaxNumberHeaders , ProxyOverride , proxyFromRequest , noProxy , useProxy+ , useProxySecureWithoutConnect , proxyEnvironment , proxyEnvironmentNamed , defaultProxy+ -- *** Response timeouts+ , ResponseTimeout+ , responseTimeoutMicro+ , responseTimeoutNone+ , responseTimeoutDefault -- *** Helpers , rawConnectionModifySocket+ , rawConnectionModifySocketSize -- * Request+ -- $parsing-request , parseUrl+ , 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@@ -132,10 +163,14 @@ , applyBasicProxyAuth , decompress , redirectCount- , checkStatus+ , shouldStripHeaderOnRedirect+ , shouldStripHeaderOnRedirectIfOnDifferentHostOnly+ , checkResponse , responseTimeout , cookieJar , requestVersion+ , redactHeaders+ , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper@@ -151,21 +186,36 @@ , responseHeaders , responseBody , responseCookieJar+ , getOriginalRequest+ , responseEarlyHints+ , throwErrorStatusCodes -- ** Response body , BodyReader , brRead , brReadSome , brConsume+ -- * Advanced connection creation+ , makeConnection+ , socketConnection -- * Misc , 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, strippedHostName) import Network.HTTP.Client.Cookies import Network.HTTP.Client.Core import Network.HTTP.Client.Manager@@ -173,7 +223,6 @@ import Network.HTTP.Client.Response import Network.HTTP.Client.Types -import Data.Text (Text) import Data.IORef (newIORef, writeIORef, readIORef, modifyIORef) import qualified Data.ByteString.Lazy as L import Data.Foldable (Foldable)@@ -181,7 +230,7 @@ import Network.HTTP.Types (statusCode) import GHC.Generics (Generic) import Data.Typeable (Typeable)-import Control.Exception (bracket)+import Control.Exception (bracket, catch, handle, throwIO) -- | A datatype holding information on redirected requests and the final response. --@@ -201,7 +250,7 @@ -- -- Since 0.4.1 }- deriving (Functor, Traversable, Foldable, Show, Typeable, Generic)+ deriving (Functor, Data.Traversable.Traversable, Data.Foldable.Foldable, Show, Typeable, Generic) -- | A variant of @responseOpen@ which keeps a history of all redirects -- performed in the interim, together with the first 1024 bytes of their@@ -209,23 +258,30 @@ -- -- Since 0.4.1 responseOpenHistory :: Request -> Manager -> IO (HistoriedResponse BodyReader)-responseOpenHistory req0 man = do- reqRef <- newIORef req0+responseOpenHistory reqOrig man0 = handle (throwIO . toHttpException reqOrig) $ do+ reqRef <- newIORef reqOrig historyRef <- newIORef id- let go req = do- res <- httpRaw req man+ let go req0 = do+ (man, req) <- getModifiedRequestManager man0 req0+ (req', res') <- httpRaw' req man+ let res = res'+ { responseBody = handle (throwIO . toHttpException req0)+ (responseBody res')+ } case getRedirectedRequest req+ req' (responseHeaders res) (responseCookieJar res) (statusCode $ responseStatus res) of- Nothing -> return (res, Nothing)- Just req' -> do- writeIORef reqRef req'+ Nothing -> return (res, req', False)+ Just req'' -> do+ writeIORef reqRef req'' body <- brReadSome (responseBody res) 1024+ `catch` handleClosedRead modifyIORef historyRef (. ((req, res { responseBody = body }):))- return (res, Just req')- res <- httpRedirect (redirectCount req0) go req0+ return (res, req'', True)+ (_, res) <- httpRedirect' (redirectCount reqOrig) go reqOrig reqFinal <- readIORef reqRef history <- readIORef historyRef return HistoriedResponse@@ -265,3 +321,90 @@ -- Since 0.4.7 managerSetProxy :: ProxyOverride -> ManagerSettings -> ManagerSettings managerSetProxy po = managerSetInsecureProxy po . managerSetSecureProxy po++-- @since 0.7.17+managerSetMaxHeaderLength :: Int -> ManagerSettings -> ManagerSettings+managerSetMaxHeaderLength l manager = manager+ { managerMaxHeaderLength = Just $ MaxHeaderLength l }++-- @since 0.7.18+managerSetMaxNumberHeaders :: Int -> ManagerSettings -> ManagerSettings+managerSetMaxNumberHeaders n manager = manager+ { managerMaxNumberHeaders = Just $ MaxNumberHeaders n }++-- $example1+-- = Example Usage+--+-- === Making a GET request+--+-- > import Network.HTTP.Client+-- > import Network.HTTP.Types.Status (statusCode)+-- >+-- > main :: IO ()+-- > main = do+-- > manager <- newManager defaultManagerSettings+-- >+-- > request <- parseRequest "http://httpbin.org/get"+-- > response <- httpLbs request manager+-- >+-- > putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response)+-- > print $ responseBody response+--+--+-- === Posting JSON to a server+--+-- > {-# LANGUAGE OverloadedStrings #-}+-- > import Network.HTTP.Client+-- > import Network.HTTP.Types.Status (statusCode)+-- > import Data.Aeson (object, (.=), encode)+-- > import Data.Text (Text)+-- >+-- > main :: IO ()+-- > main = do+-- > manager <- newManager defaultManagerSettings+-- >+-- > -- 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 }+-- >+-- > response <- httpLbs request manager+-- > putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response)+-- > print $ responseBody response+--++-- | Specify maximum time in microseconds the retrieval of response+-- headers is allowed to take+--+-- @since 0.5.0+responseTimeoutMicro :: Int -> ResponseTimeout+responseTimeoutMicro = ResponseTimeoutMicro++-- | Do not have a response timeout+--+-- @since 0.5.0+responseTimeoutNone :: ResponseTimeout+responseTimeoutNone = ResponseTimeoutNone++-- | Use the default response timeout+--+-- When used on a 'Request', means: use the manager's timeout value+--+-- When used on a 'ManagerSettings', means: default to 30 seconds+--+-- @since 0.5.0+responseTimeoutDefault :: ResponseTimeout+responseTimeoutDefault = ResponseTimeoutDefault++-- $parsing-request+--+-- The way you parse string of characters to construct a 'Request' will+-- determine whether exceptions will be thrown on non-2XX response status+-- codes. This is because the behavior is controlled by a setting in+-- 'Request' itself (see 'checkResponse') and different parsing functions+-- set it to different 'IO' actions.
Network/HTTP/Client/Body.hs view
@@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiWayIf #-} module Network.HTTP.Client.Body ( makeChunkedReader , makeLengthReader@@ -7,22 +8,22 @@ , makeUnlimitedReader , brConsume , brEmpty- , brAddCleanup+ , constBodyReader , brReadSome , brRead ) where import Network.HTTP.Client.Connection import Network.HTTP.Client.Types-import Control.Exception (throwIO, assert)-import Data.ByteString (ByteString, empty, uncons)+import Control.Exception (assert)+import Data.ByteString (empty, uncons) import Data.IORef import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L 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@@ -38,41 +39,43 @@ -- -- Since 0.4.20 brReadSome :: BodyReader -> Int -> IO L.ByteString-brReadSome brRead =+brReadSome brRead' = loop id where- loop front rem- | rem <= 0 = return $ L.fromChunks $ front []+ loop front rem'+ | rem' <= 0 = return $ L.fromChunks $ front [] | otherwise = do- bs <- brRead+ bs <- brRead' if S.null bs then return $ L.fromChunks $ front []- else loop (front . (bs:)) (rem - S.length bs)+ else loop (front . (bs:)) (rem' - S.length bs) 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. -- -- Since 0.1.0 brConsume :: BodyReader -> IO [S.ByteString]-brConsume brRead =+brConsume brRead' = go id where go front = do- x <- brRead+ x <- brRead' if S.null x then return $ front [] else go (front . (x:)) makeGzipReader :: BodyReader -> IO BodyReader-makeGzipReader brRead = do+makeGzipReader brRead' = do inf <- Z.initInflate $ Z.WindowBits 31 istate <- newIORef Nothing let goPopper popper = do@@ -88,9 +91,9 @@ else do writeIORef istate Nothing return bs- Z.PRError e -> throwIO $ HttpZlibException e+ Z.PRError e -> throwHttp $ HttpZlibException e start = do- bs <- brRead+ bs <- brRead' if S.null bs then return S.empty else do@@ -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@@ -119,26 +131,34 @@ then return empty else do bs <- connectionRead- when (S.null bs) $ throwIO $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count)+ when (S.null bs) $ throwHttp $ ResponseBodyTooShort (fromIntegral count0) (fromIntegral $ count0 - count) case compare count $ S.length bs of LT -> do 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'@@ -162,7 +185,7 @@ readChunk 0 = return (empty, 0) readChunk remainder = do bs <- connectionRead- when (S.null bs) $ throwIO InvalidChunkHeaders+ when (S.null bs) $ throwHttp InvalidChunkHeaders case compare remainder $ S.length bs of LT -> do let (x, y) = S.splitAt remainder bs@@ -179,13 +202,13 @@ | otherwise = return (x, 0) requireNewline = do- bs <- connectionReadLine conn- unless (S.null bs) $ throwIO InvalidChunkHeaders+ bs <- connectionReadLine mhl conn+ unless (S.null bs) $ throwHttp InvalidChunkHeaders readHeader = do- bs <- connectionReadLine conn+ bs <- connectionReadLine mhl conn case parseHex bs of- Nothing -> throwIO InvalidChunkHeaders+ Nothing -> throwHttp InvalidChunkHeaders Just hex -> return (bs `S.append` "\r\n", hex) parseHex bs0 =@@ -195,8 +218,8 @@ _ -> Nothing parseHex' i bs = case uncons bs of- Just (w, bs)- | Just i' <- toI w -> parseHex' (i * 16 + i') bs+ Just (w, bs')+ | Just i' <- toI w -> parseHex' (i * 16 + i') bs' _ -> i toI w@@ -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,53 +5,67 @@ ( 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.Exception (throwIO)+import Control.Concurrent+import Control.Concurrent.Async import Network.HTTP.Client.Types-import Network.Socket (Socket, sClose, HostAddress)+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) $ throwIO IncompleteHeaders- connectionReadLineWith conn bs+ when (S.null bs) $ throwHttp IncompleteHeaders+ 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.breakByte charLF bs of+ case S.break (== charLF) bs of (_, "") -> do let total' = total + S.length bs- when (total' > 4096) $ throwIO OverlongHeaders+ case fmap unMaxHeaderLength mhl of+ Nothing -> pure ()+ Just n -> when (total' > n) $ throwHttp OverlongHeaders bs' <- connectionRead conn- when (S.null bs') $ throwIO IncompleteHeaders+ when (S.null bs') $ throwHttp IncompleteHeaders go bs' (front . (bs:)) total' (x, S.drop 1 -> y) -> do 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@@ -62,7 +76,6 @@ | S.last bs == charCR = S.init bs | otherwise = bs - -- | For testing dummyConnection :: [ByteString] -- ^ input -> IO (Connection, IO [ByteString], IO [ByteString]) -- ^ conn, output, input@@ -79,28 +92,58 @@ , connectionClose = return () }, atomicModifyIORef ioutput $ \output -> ([], output), readIORef iinput) +-- | Create a new 'Connection' from a read, write, and close function.+--+-- @since 0.5.3 makeConnection :: IO ByteString -- ^ read -> (ByteString -> IO ()) -- ^ write -> IO () -- ^ close -> IO Connection makeConnection r w c = do istack <- newIORef []- _ <- mkWeakIORef istack c++ -- it is necessary to make sure we never read from or write to+ -- already closed connection.+ closedVar <- newIORef False++ let close = do+ closed <- atomicModifyIORef closedVar (\closed -> (True, closed))+ unless closed $+ c++ _ <- mkWeakIORef istack close return $! Connection- { connectionRead = join $ atomicModifyIORef istack $ \stack ->- case stack of- x:xs -> (xs, return x)- [] -> ([], r)- , connectionUnread = \x -> atomicModifyIORef istack $ \stack -> (x:stack, ())- , connectionWrite = w- , connectionClose = c+ { connectionRead = do+ closed <- readIORef closedVar+ when closed $ throwHttp ConnectionClosed+ join $ atomicModifyIORef istack $ \stack ->+ case stack of+ x:xs -> (xs, return x)+ [] -> ([], r)++ , connectionUnread = \x -> do+ closed <- readIORef closedVar+ when closed $ throwHttp ConnectionClosed+ atomicModifyIORef istack $ \stack -> (x:stack, ())++ , connectionWrite = \x -> do+ closed <- readIORef closedVar+ when closed $ throwHttp ConnectionClosed+ w x++ , connectionClose = close } -socketConnection :: Socket -> Int -> IO Connection+-- | Create a new 'Connection' from a 'Socket'.+--+-- @since 0.5.3+socketConnection :: Socket+ -> Int -- ^ chunk size+ -> IO Connection socketConnection socket chunksize = makeConnection (recv socket chunksize) (sendAll socket)- (sClose socket)+ (NS.close socket) openSocketConnection :: (Socket -> IO ()) -> Maybe HostAddress@@ -115,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- }- addrs <- case hostAddress of+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@@ -130,25 +198,47 @@ , NS.addrFamily = NS.AF_INET , NS.addrSocketType = NS.Stream , NS.addrProtocol = 6 -- tcp- , NS.addrAddress = NS.SockAddrInet (toEnum port) ha+ , NS.addrAddress = NS.SockAddrInet (toEnum port') ha , NS.addrCanonName = Nothing }] - firstSuccessful addrs $ \addr ->- E.bracketOnError- (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr)- (NS.addrProtocol addr))- (NS.sClose)- (\sock -> do- NS.setSocketOption sock NS.NoDelay 1- NS.connect sock (NS.addrAddress addr)- tweakSocket sock- 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,9 +30,9 @@ 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 qualified Network.HTTP.Client.Request as Req-import qualified Network.HTTP.Client.Response as Res import Network.HTTP.Client.Types as Req slash :: Integral a => a@@ -39,7 +40,7 @@ isIpAddress :: BS.ByteString -> Bool isIpAddress =- go 4+ go (4 :: Int) where go 0 bs = BS.null bs go rest bs =@@ -47,18 +48,22 @@ Just (i, x') | BS.null x' && i >= 0 && i < 256 -> go (rest - 1) y _ -> False where- (x, y') = BS.breakByte 46 bs -- period+ (x, y') = BS.break (== 46) bs -- period y = BS.drop 1 y' -- | This corresponds to the subcomponent algorithm entitled \"Domain Matching\" detailed -- in section 5.1.3-domainMatches :: BS.ByteString -> BS.ByteString -> Bool-domainMatches string domainString+domainMatches :: BS.ByteString -- ^ Domain to test+ -> BS.ByteString -- ^ Domain from a cookie+ -> Bool+domainMatches string' domainString' | string == domainString = True | BS.length string < BS.length domainString + 1 = False | domainString `BS.isSuffixOf` string && BS.singleton (BS.last difference) == "." && not (isIpAddress string) = True | otherwise = False where difference = BS.take (BS.length string - BS.length domainString) string+ string = CI.foldCase string'+ domainString = CI.foldCase domainString' -- | This corresponds to the subcomponent algorithm entitled \"Paths\" detailed -- in section 5.1.4@@ -98,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 @@ -109,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\"@@ -119,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')@@ -136,17 +172,17 @@ computeCookieString request cookie_jar now is_http_api = (output_line, cookie_jar') where matching_cookie cookie = condition1 && condition2 && condition3 && condition4 where condition1- | cookie_host_only cookie = Req.host request == cookie_domain cookie+ | cookie_host_only cookie = CI.foldCase (Req.host request) == CI.foldCase (cookie_domain cookie) | otherwise = domainMatches (Req.host request) (cookie_domain cookie) 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,31 +1,40 @@ {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.Core ( withResponse , httpLbs , httpNoBody , httpRaw+ , httpRaw'+ , requestAction+ , getModifiedRequestManager , responseOpen , responseClose- , applyCheckStatus , httpRedirect+ , httpRedirect'+ , withConnection+ , handleClosedRead ) where 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 as S-import qualified Data.ByteString.Char8 as S8 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@@ -66,56 +75,122 @@ httpNoBody :: Request -> Manager -> IO (Response ()) httpNoBody req man = withResponse req man $ return . void + -- | Get a 'Response' without any redirect following. httpRaw :: Request -> Manager -> IO (Response BodyReader)-httpRaw req0 m = do- req' <- mModifyRequest m $ mSetProxy m req0+httpRaw = fmap (fmap snd) . httpRaw'++-- | Get a 'Response' without any redirect following.+--+-- This extended version of 'httpRaw' also returns the potentially modified Request.+httpRaw'+ :: Request+ -> Manager+ -> IO (Request, Response BodyReader)+httpRaw' req0 m = do+ let req' = mSetProxy m req0 (req, cookie_jar') <- case cookieJar req' of Just cj -> do now <- getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now- Nothing -> return (req', mempty)- (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper- req- (responseTimeout' req)- (failedConnectionException 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+ Nothing -> return (req', Data.Monoid.mempty)+ 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- responseOpen 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 $ res {responseCookieJar = cookie_jar}- Nothing -> return res+requestAction :: IORef (Request -> Manager -> IO (Response BodyReader))+{-# NOINLINE requestAction #-}+requestAction = unsafePerformIO (newIORef action) where+ action+ :: Request+ -> Manager+ -> IO (Response BodyReader)+ action req m = do+ (timeout', mconn) <- getConnectionWrapper+ (responseTimeout' req)+ (getConn req m) - responseTimeout' req- | rt == useDefaultTimeout = mResponseTimeout m- | otherwise = rt+ -- 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- rt = responseTimeout req+ 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+-- Request.+--+-- (In case the Manager is overridden by requestManagerOverride, the Request is+-- being modified by managerModifyRequest of the new Manager, not the old one.)+getModifiedRequestManager :: Manager -> Request -> IO (Manager, Request)+getModifiedRequestManager manager0 req0 = do+ let manager = fromMaybe manager0 (requestManagerOverride req0)+ req <- mModifyRequest manager req0+ return (manager, req)+ -- | The most low-level function for initiating an HTTP request. -- -- The first argument to this function gives a full specification@@ -146,77 +221,86 @@ -- -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader)-responseOpen req0 manager = mWrapIOException manager $ do- res <-- if redirectCount req0 == 0- then httpRaw req0 manager- else go (redirectCount req0) req0- maybe (return res) throwIO =<< applyCheckStatus req0 (checkStatus req0) res+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+ mModifyResponse manager res+ { responseBody = wrapExc req0 (responseBody res)+ } where- go count req' = httpRedirect+ wrapExc :: Request -> IO a -> IO a+ wrapExc req0 = handle $ throwIO . toHttpException req0++ go manager0 count req' = httpRedirect' count (\req -> do- res <- httpRaw req manager- let mreq = getRedirectedRequest req (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))- return (res, mreq))+ (manager, modReq) <- getModifiedRequestManager manager0 req+ (req'', res) <- httpRaw' modReq manager+ let mreq = if redirectCount modReq == 0+ then Nothing+ else getRedirectedRequest req' req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res))+ return (res, fromMaybe req'' mreq, isJust mreq)) req' --- | Apply 'Request'\'s 'checkStatus' and return resulting exception if any.-applyCheckStatus- :: Request- -> (Status -> ResponseHeaders -> CookieJar -> Maybe SomeException)- -> Response BodyReader- -> IO (Maybe SomeException)-applyCheckStatus req checkStatus' res =- case checkStatus' (responseStatus res) (responseHeaders res) (responseCookieJar res) of- Nothing -> return Nothing- Just exc -> do- exc' <-- case fromException exc of- Just (StatusCodeException s hdrs cookie_jar) -> do- lbs <- brReadSome (responseBody res) 1024- return $ toException $ StatusCodeException s (hdrs ++- [ ("X-Response-Body-Start", toStrict' lbs)- , ("X-Request-URL", S.concat- [ method req- , " "- , S8.pack $ show $ getUri req- ])- ]) cookie_jar- _ -> return exc- responseClose res- return (Just exc')- where-#if MIN_VERSION_bytestring(0,10,0)- toStrict' = L.toStrict-#else- toStrict' = S.concat . L.toChunks-#endif---- | Redirect loop+-- | Redirect loop. httpRedirect :: Int -- ^ 'redirectCount' -> (Request -> IO (Response BodyReader, Maybe Request)) -- ^ function which performs a request and returns a response, and possibly another request if there's a redirect. -> Request -> IO (Response BodyReader)-httpRedirect count0 http' req0 = go count0 req0 []+httpRedirect count0 http0 req0 = fmap snd $ httpRedirect' count0 http' req0 where- go count _ ress | count < 0 = throwIO $ TooManyRedirects ress+ -- adapt callback API+ http' req' = do+ (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@.+httpRedirect'+ :: Int -- ^ 'redirectCount'+ -> (Request -> IO (Response BodyReader, Request, Bool)) -- ^ function which performs a request and returns a response, the potentially modified request, and a Bool indicating if there was a redirect.+ -> Request+ -> IO (Request, Response BodyReader)+httpRedirect' count0 http' req0 = go count0 req0 []+ where+ go count _ ress | count < 0 = throwHttp $ TooManyRedirects ress go count req' ress = do- (res, mreq) <- http' req'- case mreq of- Just req -> do- -- Allow the original connection to return to the- -- connection pool immediately by flushing the body.- -- If the response body is too large, don't flush, but- -- instead just close the connection.- let maxFlush = 1024- lbs <- brReadSome (responseBody res) maxFlush- responseClose res+ (res, req, isRedirect) <- http' req'+ if isRedirect then do+ -- Allow the original connection to return to the+ -- connection pool immediately by flushing the body.+ -- If the response body is too large, don't flush, but+ -- instead just close the connection.+ let maxFlush = 1024+ lbs <- brReadSome (responseBody res) maxFlush+ -- The connection may already be closed, e.g.+ -- when using withResponseHistory. See+ -- https://github.com/snoyberg/http-client/issues/169+ `Control.Exception.catch` handleClosedRead+ responseClose res - -- And now perform the actual redirect- go (count - 1) req (res { responseBody = lbs }:ress)- Nothing -> return res+ -- And now perform the actual redirect+ go (count - 1) req (res { responseBody = lbs }:ress)+ else+ return (req, res) -- | Close any open resources associated with the given @Response@. In general, -- this will either close an active @Connection@ or return it to the @Manager@@@ -225,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,38 +1,41 @@+{-# 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 ((<$>), (<*>))-import Control.Exception (throwIO)+import Control.Applicative as A ((<$>), (<*>)) import Control.Monad 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) -charLF, charCR, charSpace, charColon, charPeriod :: Word8-charLF = 10-charCR = 13+charSpace, charColon, charPeriod :: Word8 charSpace = 32 charColon = 58 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 withTimeout = case timeout' of Nothing -> id- Just t -> timeout t >=> maybe (throwIO ResponseTimeout) return+ Just t -> timeout t >=> maybe (throwHttp ResponseTimeout) return getStatus = withTimeout next where@@ -44,36 +47,43 @@ 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 <$> parseHeaders 0 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) $ throwIO NoResponseDataReceived- connectionReadLineWith conn bs >>= parseStatus 3+ when (S.null bs) $ throwHttp NoResponseDataReceived+ 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- let (ver, bs2) = S.breakByte charSpace bs- (code, bs3) = S.breakByte charSpace $ S.dropWhile (== charSpace) bs2+ 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- case (,) <$> parseVersion ver <*> readInt code of+ case (,) <$> parseVersion ver A.<*> readInt code of Just (ver', code') -> return (Status code' msg, ver')- Nothing -> throwIO $ InvalidStatusLine bs+ Nothing -> throwHttp $ InvalidStatusLine bs stripPrefixBS x y | x `S.isPrefixOf` y = Just $ S.drop (S.length x) y | otherwise = Nothing parseVersion bs0 = do bs1 <- stripPrefixBS "HTTP/" bs0- let (num1, S.drop 1 -> num2) = S.breakByte charPeriod bs1+ let (num1, S.drop 1 -> num2) = S.break (== charPeriod) bs1 HttpVersion <$> readInt num1 <*> readInt num2 readInt bs =@@ -81,19 +91,59 @@ Just (i, "") -> Just i _ -> Nothing - parseHeaders 100 _ = throwIO 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.breakByte charColon bs- when (S.null bs2) $ throwIO $ InvalidHeader bs- return (CI.mk $! strip key, strip $! S.drop 1 bs2)+ let (key, bs2) = S.break (== charColon) bs+ 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,18 +1,15 @@-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE CPP #-}-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.Client.Manager ( ManagerSettings (..) , newManager , closeManager , withManager , getConn- , failedConnectionException , defaultManagerSettings , rawConnectionModifySocket+ , rawConnectionModifySocketSize , proxyFromRequest , noProxy , useProxy@@ -20,48 +17,25 @@ , proxyEnvironmentNamed , defaultProxy , dropProxyAuthSecure+ , useProxySecureWithoutConnect ) where -#if !MIN_VERSION_base(4,6,0)-import Prelude hiding (catch)-#endif-import Control.Applicative ((<|>))-import Control.Arrow (first)-import Data.Monoid (mappend)-import System.IO (hClose, hFlush, IOMode(..))-import qualified Data.IORef as I-import qualified Data.Map as Map- import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L -import qualified Blaze.ByteString.Builder as Blaze- import Data.Text (Text)-import qualified Data.Text as T-import Data.Text.Read (decimal) -import Control.Monad.IO.Class (MonadIO, liftIO)-import Control.Monad (unless, join, when, void, mplus)-import Control.Exception (mask_, SomeException, bracket, catch, throwIO, fromException, mask, IOException, Exception (..), handle)-import Control.Concurrent (forkIO, threadDelay)-import Data.Time (UTCTime (..), Day (..), DiffTime, getCurrentTime, addUTCTime)-import Control.DeepSeq (deepseq)+import Control.Monad (unless)+import Control.Exception (throwIO, fromException, IOException, Exception (..), handle) import qualified Network.Socket as NS -import Data.Maybe (mapMaybe)-import System.IO (Handle)-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 (username, password, applyBasicProxyAuth)-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@@ -74,11 +48,12 @@ -- | Same as @rawConnectionModifySocket@, but also takes in a chunk size. ----- Since 0.4.5+-- @since 0.5.2 rawConnectionModifySocketSize :: (NS.Socket -> IO ()) -> IO (Int -> Maybe NS.HostAddress -> String -> Int -> IO Connection) rawConnectionModifySocketSize = return . openSocketConnectionSize + -- | Default value for @ManagerSettings@. -- -- Note that this value does /not/ have support for SSL/TLS. If you need to@@ -90,14 +65,14 @@ defaultManagerSettings = ManagerSettings { managerConnCount = 10 , managerRawConnection = return $ openSocketConnection (const $ return ())- , managerTlsConnection = return $ \_ _ _ -> throwIO TlsNotSupported- , managerTlsProxyConnection = return $ \_ _ _ _ _ _ -> throwIO TlsNotSupported- , managerResponseTimeout = Just 30000000+ , managerTlsConnection = return $ \_ _ _ -> throwHttp TlsNotSupported+ , managerTlsProxyConnection = return $ \_ _ _ _ _ _ -> throwHttp TlsNotSupported+ , managerResponseTimeout = ResponseTimeoutDefault , managerRetryableException = \e -> case fromException e of Just (_ :: IOException) -> True _ ->- case fromException e of+ case fmap unHttpExceptionContentWrapper $ fromException e of -- Note: Some servers will timeout connections by accepting -- the incoming packets for the new request, but closing -- the connection as soon as we try to read. To make sure@@ -106,62 +81,21 @@ Just NoResponseDataReceived -> True Just IncompleteHeaders -> True _ -> False- , managerWrapIOException =+ , managerWrapException = \_req -> let wrapper se = case fromException se of- Just e -> toException $ InternalIOException e- Nothing -> se- in handle $ throwIO . wrapper+ Just (_ :: IOException) -> throwHttp $ InternalException se+ Nothing -> throwIO se+ 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 0 (const 1) 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. --@@ -175,79 +109,36 @@ 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- , mWrapIOException = managerWrapIOException ms- , mIdleConnectionCount = managerIdleConnectionCount ms+ , mWrapException = managerWrapException 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 where@@ -279,23 +170,7 @@ seqDT :: DiffTime -> b -> b 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'. --@@ -308,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@@ -323,127 +190,92 @@ 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)---- | Create an exception to be thrown if the connection for the given request--- fails.-failedConnectionException :: Request -> HttpException-failedConnectionException req =- FailedConnectionException host' port'- where- (_, host', port') = getConnDest req--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 dropProxyAuthSecure req- | secure req && useProxy = req+ | secure req && useProxy' = req { requestHeaders = filter (\(k, _) -> k /= "Proxy-Authorization") (requestHeaders req) } | 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 = throwIO $ InvalidDestinationHost h- | otherwise =- getManagedConn m (ConnKey connKeyHost connport (host req) (port req) (secure req)) $- wrapConnectExc $ go connaddr connhost connport+ | S8.null h = throwHttp $ InvalidDestinationHost h+ | 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 ->- throwIO $ FailedConnectionException2 connhost connport (secure req)- (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- connstr = S8.concat- [ "CONNECT "- , ultHost- , ":"- , S8.pack $ show ultPort- , " HTTP/1.1\r\n"- , proxyAuthorizationHeader- , "\r\n"- ]- parse conn = do- sh@(StatusHeaders status _ _) <- parseStatusHeaders conn Nothing Nothing- unless (status == status200) $- throwIO $ ProxyConnectException ultHost ultPort $ Left $ S8.pack $ show sh- in mTlsProxyConnection m connstr parse (S8.unpack ultHost)+ throwHttp $ ConnectionFailure (toException (e :: IOException)) -- | Get the proxy settings from the @Request@ itself. --@@ -463,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@@ -471,13 +312,8 @@ -- Since 0.4.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"+proxyEnvironment mp = ProxyOverride $ \secure' ->+ 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.@@ -487,63 +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- case lookup (T.unpack name) env <|> Map.lookup name lenv of- Nothing -> return noEnvProxy- Just "" -> return noEnvProxy- Just str -> do- let invalid = throwIO $ 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- let muserpass =- if null authInfo- then Nothing- else Just ( S8.pack $ username authInfo- , S8.pack $ password authInfo- )- authInfo = U.uriUserInfo auth-- 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, muserpass)- return $ \req ->- 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 }+defaultProxy = ProxyOverride $ \secure' ->+ 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,10 +10,10 @@ -- > -- > import Control.Monad -- >--- > main = withSocketsDo $ void $ withManager defaultManagerSettings $ \m -> do--- > req1 <- parseUrl "http://random-cat-photo.net/cat.jpg"+-- > main = void $ withManager defaultManagerSettings $ \m -> do+-- > req1 <- parseRequest "http://random-cat-photo.net/cat.jpg" -- > res <- httpLbs req1 m--- > req2 <- parseUrl "http://example.org/~friedrich/blog/addPost.hs"+-- > req2 <- parseRequest "http://example.org/~friedrich/blog/addPost.hs" -- > flip httpLbs m =<< -- > (formDataBody [partBS "title" "Bleaurgh" -- > ,partBS "text" $ TE.encodeUtf8 "矢田矢田矢田矢田矢田"@@ -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 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=\""@@ -225,7 +232,7 @@ <> cp "Content-Type: " <> cp ct _ -> mempty)- <> foldMap (\(k, v) ->+ <> Data.Foldable.foldMap (\(k, v) -> cp "\r\n" <> cp (CI.original k) <> cp ": "@@ -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
@@ -3,40 +3,53 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-}-+{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.Client.Request ( parseUrl+ , parseUrlThrow+ , parseRequest+ , parseRequest_+ , requestFromURI+ , requestFromURI_+ , defaultRequest , setUriRelative , getUri , setUri+ , setUriEither , browserDecompress , alwaysDecompress , addProxy , applyBasicAuth , applyBasicProxyAuth+ , applyBearerAuth , urlEncodedBody , needsGunzip , requestBuilder- , useDefaultTimeout+ , setRequestIgnoreStatus+ , setRequestCheckStatus , setQueryString+#if MIN_VERSION_http_types(0,12,1)+ , setQueryStringPartialEscape+#endif , streamFile , observedStreamFile- , username- , password+ , extractBasicAuthInfo+ , throwErrorStatusCodes+ , addProxySecureWithoutConnect ) where import Data.Int (Int64)-import Data.Maybe (fromMaybe, isJust)-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 ((<$>))-import Control.Monad (when, unless)+import Control.Applicative as A ((<$>))+import Control.Monad (unless, guard)+import Control.Monad.IO.Class (MonadIO, liftIO) import Numeric (showHex)--import Data.Default.Class (Default (def))+import qualified Data.Set as Set import Blaze.ByteString.Builder (Builder, fromByteString, fromLazyByteString, toByteStringIO, flush) import Blaze.ByteString.Builder.Char8 (fromChar, fromShow)@@ -47,53 +60,130 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Network.HTTP.Types as W-import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, isAllowedInURI, isReserved)+import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, isAllowedInURI) -import Control.Monad.IO.Class (liftIO)-import Control.Exception (Exception, toException, throw, throwIO, IOException)+import Control.Exception (throw, throwIO, IOException) import qualified Control.Exception as E import qualified Data.CaseInsensitive as CI import qualified Data.ByteString.Base64 as B64 +import Network.HTTP.Client.Body import Network.HTTP.Client.Types import Network.HTTP.Client.Util-import Network.HTTP.Client.Connection -import Network.HTTP.Client.Util (readDec, (<>))-import Data.Time.Clock import Control.Monad.Catch (MonadThrow, throwM)-import Data.IORef import System.IO (withBinaryFile, hTell, hFileSize, Handle, IOMode (ReadMode))+import Control.Monad (liftM) +-- | Deprecated synonym for 'parseUrlThrow'. You probably want+-- 'parseRequest' or 'parseRequest_' instead.+--+-- @since 0.1.0+parseUrl :: MonadThrow m => String -> m Request+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. 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 = 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'. ----- Since 0.1.0-parseUrl :: MonadThrow m => String -> m Request-parseUrl s =+-- You can place the request method at the beginning of the URL separated by a+-- space, e.g.:+--+-- @+-- parseRequest "POST http://httpbin.org/post"+-- @+--+-- Note that the request method must be provided as all capital letters.+--+-- 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' = case parseURI (encode s) of- Just uri -> setUri def uri+ Just uri -> liftM setMethod (setUri defaultRequest uri) Nothing -> throwM $ InvalidUrlException s "Invalid URL" where encode = escapeURIString isAllowedInURI+ (mmethod, s) =+ case break (== ' ') s' of+ (x, ' ':y) | all (\c -> 'A' <= c && c <= 'Z') x -> (Just x, y)+ _ -> (Nothing, s') + setMethod req =+ case mmethod of+ Nothing -> req+ Just m -> req { method = S8.pack m }++-- | 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 =-#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. --@@ -106,7 +196,7 @@ , uriAuthority = Just URIAuth { uriUserInfo = "" , uriRegName = S8.unpack $ host req- , uriPort = ':' : show (port req)+ , uriPort = port' } , uriPath = S8.unpack $ path req , uriQuery =@@ -115,36 +205,43 @@ _ -> 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 =- if hasAuth- then applyBasicAuth (S8.pack theuser) (S8.pack thepass) req- else req- where- hasAuth = (notEmpty theuser) && (notEmpty thepass)- notEmpty = not . null- theuser = username authInfo- thepass = password authInfo- authInfo = maybe "" uriUserInfo $ uriAuthority uri--username :: String -> String-username = encode . takeWhile (/=':') . authPrefix--password :: String -> String-password = encode . takeWhile (/='@') . drop 1 . dropWhile (/=':')--encode :: String -> String-encode = escapeURIString (not . isReserved)+ case extractBasicAuthInfo uri of+ Just auth -> uncurry applyBasicAuth auth req+ Nothing -> req -authPrefix :: String -> String-authPrefix u = if '@' `elem` u then takeWhile (/= '@') u else ""+-- | Extract basic access authentication info in URI.+-- Return Nothing when there is no auth info in URI.+extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString)+extractBasicAuthInfo uri = do+ userInfo <- uriUserInfo A.<$> uriAuthority uri+ guard (':' `elem` userInfo)+ let (username, ':':password) = break (==':') . takeWhile (/='@') $ userInfo+ return (toLiteral username, toLiteral password)+ where+ toLiteral = S8.pack . unEscapeString -- | 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@@ -157,55 +254,32 @@ , 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 -instance Show Request where- show x = unlines- [ "Request {"- , " host = " ++ show (host x)- , " port = " ++ show (port x)- , " secure = " ++ show (secure x)- , " requestHeaders = " ++ show (requestHeaders x)- , " path = " ++ show (path x)- , " queryString = " ++ show (queryString x)- --, " requestBody = " ++ show (requestBody x)- , " method = " ++ show (method x)- , " proxy = " ++ show (proxy x)- , " rawBody = " ++ show (rawBody x)- , " redirectCount = " ++ show (redirectCount x)- , " responseTimeout = " ++ show (responseTimeout x)- , " requestVersion = " ++ show (requestVersion x)- , "}"- ]---- | Magic value to be placed in a 'Request' to indicate that we should use the--- timeout value in the @Manager@.+-- | A default request value, a GET request of localhost/:80, with an+-- empty request body. ----- Since 1.9.3-useDefaultTimeout :: Maybe Int-useDefaultTimeout = Just (-3425)--instance Default Request where- def = Request+-- Note that the default 'checkResponse' does nothing.+--+-- @since 0.4.30+defaultRequest :: Request+defaultRequest = Request { host = "localhost" , port = 80 , secure = False@@ -219,39 +293,29 @@ , rawBody = False , decompress = browserDecompress , redirectCount = 10- , checkStatus = \s@(W.Status sci _) hs cookie_jar ->- if 200 <= sci && sci < 300- then Nothing- else Just $ toException $ StatusCodeException s hs cookie_jar- , responseTimeout = useDefaultTimeout- , getConnectionWrapper = \mtimeout exc f ->- case mtimeout of- Nothing -> fmap ((,) Nothing) f- Just timeout' -> do- before <- getCurrentTime- mres <- timeout timeout' f- case mres of- Nothing -> throwIO exc- Just res -> do- now <- getCurrentTime- let timeSpentMicro = diffUTCTime now before * 1000000- remainingTime = round $ fromIntegral timeout' - timeSpentMicro- if remainingTime <= 0- then throwIO exc- else return (Just remainingTime, res)- , cookieJar = Just def+ , checkResponse = \_ _ -> return ()+ , responseTimeout = ResponseTimeoutDefault+ , cookieJar = Just Data.Monoid.mempty , requestVersion = W.http11 , onRequestBodyException = \se -> case E.fromException se of 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_'+--+-- /NOTE/: Prior to version 0.5.0, this instance used 'parseUrlThrow'+-- instead. instance IsString Request where- fromString s =- case parseUrl s of- Left e -> throw e- Right r -> r+ fromString = parseRequest_+ {-# INLINE fromString #-} -- | Always decompress a compressed stream. alwaysDecompress :: S.ByteString -> Bool@@ -261,19 +325,46 @@ 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: ----- > applyBasicAuth "user" "pass" $ fromJust $ parseUrl url+-- > applyBasicAuth "user" "pass" $ parseRequest_ url --+-- NOTE: The function @applyDigestAuth@ is provided by the @http-client-tls@+-- package instead of this package due to extra dependencies. Please use that+-- package if you need to use digest authentication.+-- -- Since 0.1.0 applyBasicAuth :: S.ByteString -> S.ByteString -> Request -> Request 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. --@@ -282,10 +373,17 @@ 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: ----- > applyBasicProxyAuth "user" "pass" <$> parseUrl "http://example.org"+-- > applyBasicProxyAuth "user" "pass" <$> parseRequest "http://example.org" -- -- Since 0.3.4 @@ -293,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'. --@@ -322,70 +419,88 @@ && ("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 {..}- | expectContinue = flushHeaders >> return (Just (checkBadSend sendLater))- | otherwise = sendNow >> return Nothing+requestBuilder req Connection {..} = do+ (contentLength, sendNow, sendLater) <- toTriple (requestBody req)+ if expectContinue+ then flushHeaders contentLength >> return (Just (checkBadSend sendLater))+ 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 = writeBuilder . (builder `mappend`)- flushHeaders = writeHeadersWith flush-- (contentLength, sendNow, sendLater) =- case requestBody req of- RequestBodyLBS lbs ->- let body = fromLazyByteString lbs- now = checkBadSend $ writeHeadersWith body- later = writeBuilder body- in (Just (L.length lbs), now, later)-- RequestBodyBS bs ->- let body = fromByteString bs- now = checkBadSend $ writeHeadersWith body- later = writeBuilder body- in (Just (fromIntegral $ S.length bs), now, later)-- RequestBodyBuilder len body ->- let now = checkBadSend $ writeHeadersWith body- later = writeBuilder body- in (Just len, now, later)-- -- See https://github.com/snoyberg/http-client/issues/74 for usage- -- of flush here.- RequestBodyStream len stream ->- let body = writeStream False stream- -- Don't check for a bad send on the headers themselves.- -- Ideally, we'd do the same thing for the other request body- -- types, but it would also introduce a performance hit since- -- we couldn't merge request headers and bodies together.- now = flushHeaders >> checkBadSend body- in (Just len, now, body)+ writeHeadersWith contentLength = writeBuilder . (builder contentLength `Data.Monoid.mappend`)+ flushHeaders contentLength = writeHeadersWith contentLength flush - RequestBodyStreamChunked stream ->- let body = writeStream True stream- now = flushHeaders >> checkBadSend body- in (Nothing, now, body)+ toTriple (RequestBodyLBS lbs) = do+ let body = fromLazyByteString lbs+ len = Just $ L.length lbs+ now = checkBadSend $ writeHeadersWith len body+ later = writeBuilder body+ return (len, now, later)+ toTriple (RequestBodyBS bs) = do+ let body = fromByteString bs+ len = Just $ fromIntegral $ S.length bs+ now = checkBadSend $ writeHeadersWith len body+ later = writeBuilder body+ return (len, now, later)+ toTriple (RequestBodyBuilder len body) = do+ let now = checkBadSend $ writeHeadersWith (Just len) body+ later = writeBuilder body+ return (Just len, now, later)+ toTriple (RequestBodyStream len stream) = do+ -- See https://github.com/snoyberg/http-client/issues/74 for usage+ -- of flush here.+ let body = writeStream (Just . fromIntegral $ len) stream+ -- Don't check for a bad send on the headers themselves.+ -- Ideally, we'd do the same thing for the other request body+ -- types, but it would also introduce a performance hit since+ -- we couldn't merge request headers and bodies together.+ now = flushHeaders (Just len) >> checkBadSend body+ return (Just len, now, body)+ toTriple (RequestBodyStreamChunked stream) = do+ let body = writeStream Nothing stream+ now = flushHeaders Nothing >> checkBadSend body+ return (Nothing, now, body)+ toTriple (RequestBodyIO mbody) = mbody >>= toTriple - writeStream isChunked withStream =- withStream loop+ writeStream mlen withStream =+ withStream (loop 0) where- loop stream = do- bs <- stream+ loop !n stream = do+ bs <- encapsulatePopperException stream if S.null bs- then when isChunked $ connectionWrite "0\r\n\r\n"+ then case mlen of+ -- If stream is chunked, no length argument+ Nothing -> connectionWrite "0\r\n\r\n"+ -- Not chunked - validate length argument+ Just len -> unless (len == n) $ throwHttp $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n) else do connectionWrite $- if isChunked+ if (isNothing mlen) -- Chunked then S.concat [ S8.pack $ showHex (S.length bs) "\r\n" , bs , "\r\n" ] else bs- loop stream-+ loop (n + (S.length bs)) stream hh | port req == 80 && not (secure req) = host req@@ -396,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@@ -418,17 +540,18 @@ Nothing -> ("Host", hh) : x Just{} -> x - headerPairs :: W.RequestHeaders- headerPairs = hostHeader+ headerPairs :: Maybe Int64 -> W.RequestHeaders+ headerPairs contentLength+ = hostHeader $ acceptEncodingHeader $ contentLengthHeader contentLength $ requestHeaders req - builder :: Builder- builder =+ builder :: Maybe Int64 -> Builder+ builder contentLength = fromByteString (method req) <> fromByteString " "- <> requestHostname+ <> requestHostname req <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromChar '/' <> fromByteString (path req))@@ -446,7 +569,7 @@ <> foldr (\a b -> headerPairToBuilder a <> b) (fromByteString "\r\n")- headerPairs+ (headerPairs contentLength) headerPairToBuilder (k, v) = fromByteString (CI.original k)@@ -454,11 +577,33 @@ <> fromByteString v <> fromByteString "\r\n" +-- | Modify the request so that non-2XX status codes do not generate a runtime+-- 'StatusCodeException'.+--+-- @since 0.4.29+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,23 +1,20 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE CPP #-}+{-# LANGUAGE RecordWildCards #-} module Network.HTTP.Client.Response ( getRedirectedRequest , getResponse , lbsResponse+ , getOriginalRequest ) where -import Control.Monad ((>=>), when)--import Control.Exception (throwIO)-+import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L--import Data.Default.Class (def)+import qualified Data.CaseInsensitive as CI+import Control.Arrow (second) -import Data.Maybe (isJust)+import Data.Monoid (mempty)+import Data.List (nubBy) import qualified Network.HTTP.Types as W import Network.URI (parseURIReference, escapeURIString, isAllowedInURI)@@ -28,12 +25,13 @@ 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 -- redirection, and the redirection code itself. This function returns 'Nothing' -- if the code is not a 3xx, there is no 'location' header included, or if the--- redirected response couldn't be parsed with 'parseUrl'.+-- redirected response couldn't be parsed with 'parseRequest'. -- -- If a user of this library wants to know the url chain that results from a -- specific request, that user has to re-implement the redirect-following logic@@ -46,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@@ -72,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)@@ -83,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)@@ -107,21 +146,39 @@ 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 , responseVersion = version , responseHeaders = hs , responseBody = body- , responseCookieJar = def+ , 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,24 +1,31 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveFoldable #-}-{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} module Network.HTTP.Client.Types ( BodyReader , Connection (..) , StatusHeaders (..) , HttpException (..)+ , HttpExceptionContent (..)+ , unHttpExceptionContentWrapper+ , throwHttp+ , toHttpException , Cookie (..)+ , equalCookie+ , equivCookie+ , compareCookies , CookieJar (..)+ , equalCookieJar+ , equivCookieJar , Proxy (..) , RequestBody (..) , Popper , NeedsPopper , GivesPopper , Request (..)- , ConnReuse (..)- , ConnRelease- , ManagedConn (..) , Response (..) , ResponseClose (..) , Manager (..)@@ -30,19 +37,23 @@ , ConnKey (..) , ProxyOverride (..) , StreamFileStatus (..)+ , ResponseTimeout (..)+ , ProxySecureMode (..)+ , MaxHeaderLength (..)+ , MaxNumberHeaders (..) ) where import qualified Data.Typeable as T (Typeable) import Network.HTTP.Types-import Control.Exception (Exception, IOException, SomeException)+import Control.Exception (Exception, SomeException, throwIO) import Data.Word (Word64) import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import Blaze.ByteString.Builder (Builder, fromLazyByteString, fromByteString, toLazyByteString) import Data.Int (Int64)-import Data.Default.Class 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)@@ -50,11 +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@@ -74,68 +86,176 @@ , connectionWrite :: S.ByteString -> IO () -- ^ Send data to server , connectionClose :: IO ()+ -- ^ Close connection. Any successive operation on the connection+ -- (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) -data HttpException = StatusCodeException Status ResponseHeaders CookieJar- | InvalidUrlException String String- | TooManyRedirects [Response L.ByteString] -- ^ List of encountered responses containing redirects in reverse chronological order; including last redirect, which triggered the exception and was not followed.- | UnparseableRedirect (Response L.ByteString) -- ^ Response containing unparseable redirect.- | TooManyRetries- | HttpParserException String- | HandshakeFailed+-- | A newtype wrapper which is not exported from this library but is an+-- instance of @Exception@. This allows @HttpExceptionContent@ to be thrown+-- (via this wrapper), but users of the library can't accidentally try to catch+-- it (when they /should/ be trying to catch 'HttpException').+--+-- @since 0.5.0+newtype HttpExceptionContentWrapper = HttpExceptionContentWrapper+ { unHttpExceptionContentWrapper :: HttpExceptionContent+ }+ deriving (Show, T.Typeable)+instance Exception HttpExceptionContentWrapper++throwHttp :: HttpExceptionContent -> IO a+throwHttp = throwIO . HttpExceptionContentWrapper++toHttpException :: Request -> HttpExceptionContentWrapper -> HttpException+toHttpException req (HttpExceptionContentWrapper e) = HttpExceptionRequest req e++-- | An exception which may be generated by this library+--+-- @since 0.5.0+data HttpException+ = HttpExceptionRequest Request HttpExceptionContent+ -- ^ Most exceptions are specific to a 'Request'. Inspect the+ -- 'HttpExceptionContent' value for details on what occurred.+ --+ -- @since 0.5.0+ | InvalidUrlException String String+ -- ^ A URL (first field) is invalid for a given reason+ -- (second argument).+ --+ -- @since 0.5.0+ deriving (Show, T.Typeable)+instance Exception HttpException++data HttpExceptionContent+ = StatusCodeException (Response ()) S.ByteString+ -- ^ Generated by the @parseUrlThrow@ function when the+ -- server returns a non-2XX response status code.+ --+ -- May include the beginning of the response body.+ --+ -- @since 0.5.0+ | TooManyRedirects [Response L.ByteString]+ -- ^ The server responded with too many redirects for a+ -- request.+ --+ -- Contains the list of encountered responses containing+ -- redirects in reverse chronological order; including last+ -- redirect, which triggered the exception and was not+ -- followed.+ --+ -- @since 0.5.0 | OverlongHeaders+ -- ^ 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- | FailedConnectionException String Int- -- ^ host/port+ -- ^ The server took too long to return a response. This can+ -- be altered via 'responseTimeout' or+ -- 'managerResponseTimeout'. --- -- Note that in old versions of http-client and- -- http-conduit, this exception would indicate a failed- -- attempt to create a connection. However, since (at least)- -- http-client 0.4, it indicates a timeout occurred while- -- trying to establish the connection. For more information- -- on this, see:+ -- @since 0.5.0+ | ConnectionTimeout+ -- ^ Attempting to connect to the server timed out. --- -- <https://github.com/snoyberg/http-client/commit/b86b1cdd91e56ee33150433dedb32954d2082621#commitcomment-10718689>- | FailedConnectionException2 String Int Bool SomeException -- ^ host\/port\/secure- | ExpectedBlankAfter100Continue+ -- @since 0.5.0+ | ConnectionFailure SomeException+ -- ^ An exception occurred when trying to connect to the+ -- server.+ --+ -- @since 0.5.0 | InvalidStatusLine S.ByteString+ -- ^ The status line returned by the server could not be parsed.+ --+ -- @since 0.5.0 | InvalidHeader S.ByteString- | InternalIOException IOException- | ProxyConnectException S.ByteString Int (Either S.ByteString HttpException) -- ^ host/port+ -- ^ 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+ -- failing socket action or a TLS exception.+ --+ -- @since 0.5.0+ | ProxyConnectException S.ByteString Int Status+ -- ^ A non-200 status code was returned when trying to+ -- connect to the proxy server on the given host and port.+ --+ -- @since 0.5.0 | NoResponseDataReceived- | TlsException SomeException+ -- ^ No response data was received from the server at all.+ -- This exception may deserve special handling within the+ -- library, since it may indicate that a pipelining has been+ -- used, and a connection thought to be open was in fact+ -- closed.+ --+ -- @since 0.5.0 | TlsNotSupported+ -- ^ Exception thrown when using a @Manager@ which does not+ -- have support for secure connections. Typically, you will+ -- want to use @tlsManagerSettings@ from @http-client-tls@+ -- to overcome this.+ --+ -- @since 0.5.0+ | WrongRequestBodyStreamSize Word64 Word64+ -- ^ The request body provided did not match the expected size.+ --+ -- Provides the expected and actual size.+ --+ -- @since 0.4.31 | ResponseBodyTooShort Word64 Word64- -- ^ Expected size/actual size.+ -- ^ The returned response body is too short. Provides the+ -- expected size and actual size. --- -- Since 1.9.4+ -- @since 0.5.0 | InvalidChunkHeaders- -- ^+ -- ^ A chunked response body had invalid headers. --- -- Since 1.9.4+ -- @since 0.5.0 | IncompleteHeaders+ -- ^ An incomplete set of response headers were returned.+ --+ -- @since 0.5.0 | InvalidDestinationHost S.ByteString+ -- ^ The host we tried to connect to is invalid (e.g., an+ -- empty string). | HttpZlibException ZlibException- -- ^+ -- ^ An exception was thrown when inflating a response body. --- -- Since 0.3+ -- @since 0.5.0 | InvalidProxyEnvironmentVariable Text Text- -- ^ Environment name and value+ -- ^ Values in the proxy environment variable were invalid.+ -- Provides the environment variable name and its value. --- -- Since 0.4.7- | ResponseLengthAndChunkingBothUsed- -- ^ Detect a case where both the @content-length@ header- -- and @transfer-encoding: chunked@ are used. Since 0.4.8.+ -- @since 0.5.0+ | ConnectionClosed+ -- ^ Attempted to use a 'Connection' which was already closed --- -- Since 0.4.11 this exception isn't thrown anymore.+ -- @since 0.5.0+ | InvalidProxySettings Text+ -- ^ Proxy settings are not valid (Windows specific currently)+ -- @since 0.5.7 deriving (Show, T.Typeable)-instance Exception HttpException +-- Purposely not providing this instance, since we don't want users to+-- accidentally try and catch these exceptions instead of HttpException+--+-- instance Exception HttpExceptionContent + -- This corresponds to the description of a cookie detailed in Section 5.3 \"Storage Model\" data Cookie = Cookie { cookie_name :: S.ByteString@@ -155,44 +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 = cookie_domain a == 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 Default CookieJar where- def = CJ []+-- | See 'equalCookie'.+--+-- @since 0.7.0+equalCookieJar :: CookieJar -> CookieJar -> Bool+equalCookieJar (CJ cj1) (CJ cj2) = and $ zipWith equalCookie cj1 cj2 -instance Eq CookieJar where- (==) cj1 cj2 = (DL.sort $ expose cj1) == (DL.sort $ expose cj2)+-- | See 'equalCookieJar', 'equalCookie'.+--+-- @since 0.7.0+equivCookieJar :: CookieJar -> CookieJar -> Bool+equivCookieJar cj1 cj2 = and $+ zipWith equivCookie (DL.sortBy compareCookies $ expose cj1) (DL.sortBy compareCookies $ expose cj2) --- | Since 1.9-instance Monoid CookieJar where- mempty = def- (CJ a) `mappend` (CJ b) = CJ (DL.nub $ DL.sortBy compare' $ a `mappend` b)- where compare' c1 c2 =+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.@@ -208,6 +377,11 @@ | RequestBodyBuilder Int64 Builder | RequestBodyStream Int64 (GivesPopper ()) | RequestBodyStreamChunked (GivesPopper ())+ | RequestBodyIO (IO RequestBody)+ -- ^ Allows creation of a @RequestBody@ inside the @IO@ monad, which is+ -- useful for making easier APIs (like @setRequestBodyFile@).+ --+ -- @since 0.4.28 deriving T.Typeable -- | --@@ -216,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@@ -252,6 +431,7 @@ simplify (RequestBodyBuilder len b) = Left (len, b) simplify (RequestBodyStream i gp) = Right (Just i, gp) simplify (RequestBodyStreamChunked gp) = Right (Nothing, gp)+simplify (RequestBodyIO _mbody) = error "FIXME No support for Monoid on RequestBodyIO" builderToStream :: (Int64, Builder) -> (Maybe Int64, GivesPopper ()) builderToStream (len, builder) =@@ -288,17 +468,17 @@ -- | All information on how to connect to a host and what should be sent in the -- HTTP request. ----- If you simply wish to download from a URL, see 'parseUrl'.+-- If you simply wish to download from a URL, see 'parseRequest'. -- -- The constructor for this data type is not exposed. Instead, you should use--- either the 'def' method to retrieve a default instance, or 'parseUrl' to+-- either the 'defaultRequest' value, or 'parseRequest' to -- construct from a URL, and then use the records below to make modifications. -- This approach allows http-client to add configuration options without -- breaking backwards compatibility. -- -- For example, to construct a POST request, you could do something like: ----- > initReq <- parseUrl "http://www.example.com/path"+-- > initReq <- parseRequest "http://www.example.com/path" -- > let req = initReq -- > { method = "POST" -- > }@@ -320,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.@@ -387,28 +570,19 @@ -- no redirects. Default value: 10. -- -- Since 0.1.0- , checkStatus :: Status -> ResponseHeaders -> CookieJar -> Maybe SomeException- -- ^ Check the status code. Note that this will run after all redirects are- -- performed. Default: return a @StatusCodeException@ on non-2XX responses.- --- -- Since 0.1.0- , responseTimeout :: Maybe Int- -- ^ Number of microseconds to wait for a response. If- -- @Nothing@, will wait indefinitely. Default: use- -- 'managerResponseTimeout' (which by default is 30 seconds).+ , checkResponse :: Request -> Response BodyReader -> IO ()+ -- ^ Check the response immediately after receiving the status and headers.+ -- This can be useful for throwing exceptions on non-success status codes. --- -- Since 0.1.0- , getConnectionWrapper :: Maybe Int- -> HttpException- -> IO (ConnRelease, Connection, ManagedConn)- -> IO (Maybe Int, (ConnRelease, Connection, ManagedConn))- -- ^ Wraps the calls for getting new connections. This can be useful for- -- instituting some kind of timeouts. The first argument is the value of- -- @responseTimeout@. Second argument is the exception to be thrown on- -- failure.+ -- In previous versions of http-client, this went under the name+ -- @checkStatus@, but was renamed to avoid confusion about the new default+ -- behavior (doing nothing). --- -- Default: If @responseTimeout@ is @Nothing@, does nothing. Otherwise,- -- institutes timeout, and returns remaining time for @responseTimeout@.+ -- @since 0.5.0+ , responseTimeout :: ResponseTimeout+ -- ^ 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@@ -432,15 +606,85 @@ -- Default: ignore @IOException@s, rethrow all other exceptions. -- -- Since: 0.4.6++ , requestManagerOverride :: Maybe Manager+ -- ^ A 'Manager' value that should override whatever @Manager@ value was+ -- passed in to the HTTP request function manually. This is useful when+ -- 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 -data ConnReuse = Reuse | DontReuse- deriving T.Typeable+-- | 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) -type ConnRelease = ConnReuse -> IO ()+instance Show Request where+ show x = unlines+ [ "Request {"+ , " host = " ++ show (host x)+ , " port = " ++ show (port x)+ , " secure = " ++ show (secure x)+ , " requestHeaders = " ++ show (DL.map (redactSensitiveHeader $ redactHeaders x) (requestHeaders x))+ , " path = " ++ show (path x)+ , " queryString = " ++ show (queryString x)+ --, " requestBody = " ++ show (requestBody x)+ , " method = " ++ show (method x)+ , " proxy = " ++ show (proxy x)+ , " rawBody = " ++ show (rawBody x)+ , " redirectCount = " ++ show (redirectCount x)+ , " responseTimeout = " ++ show (responseTimeout x)+ , " requestVersion = " ++ show (requestVersion x)+ , " proxySecureMode = " ++ show (proxySecureMode x)+ , "}"+ ] -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. --@@ -474,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, Foldable, 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>.@@ -497,7 +756,6 @@ -- ^ Create an insecure connection. -- -- Since 0.1.0- -- FIXME in the future, combine managerTlsConnection and managerTlsProxyConnection , managerTlsConnection :: IO (Maybe NS.HostAddress -> String -> Int -> IO Connection) -- ^ Create a TLS connection. Default behavior: throw an exception that TLS is not supported. --@@ -506,13 +764,13 @@ -- ^ Create a TLS proxy connection. Default behavior: throw an exception that TLS is not supported. -- -- Since 0.2.2- , managerResponseTimeout :: Maybe Int- -- ^ Default timeout (in microseconds) to be applied to requests which do- -- not provide a timeout value.+ , managerResponseTimeout :: ResponseTimeout+ -- ^ Default timeout to be applied to requests which do not provide a+ -- timeout value. -- -- Default is 30 seconds --- -- Since 0.1.0+ -- @since 0.5.0 , managerRetryableException :: SomeException -> Bool -- ^ Exceptions for which we should retry our request if we were reusing an -- already open connection. In the case of IOExceptions, for example, we@@ -520,19 +778,21 @@ -- new one. -- -- Since 0.1.0- , managerWrapIOException :: forall a. IO a -> IO a+ , managerWrapException :: forall a. Request -> IO a -> IO a -- ^ Action wrapped around all attempted @Request@s, usually used to wrap -- up exceptions in library-specific types. --- -- Default: wrap all @IOException@s in the @InternalIOException@ constructor.+ -- Default: wrap all @IOException@s in the @InternalException@ constructor. --- -- Since 0.1.0+ -- @since 0.5.0 , managerIdleConnectionCount :: Int -- ^ Total number of idle connection to keep open at a given time. -- -- 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 --@@ -540,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. --@@ -555,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 @@ -572,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.- , mResponseTimeout :: Maybe Int+ { 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- , mWrapIOException :: forall a. IO a -> IO a- , mIdleConnectionCount :: Int+ , mWrapException :: forall a. Request -> IO a -> IO a , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request+ , mModifyResponse :: Response BodyReader -> IO (Response BodyReader) -- ^ See 'managerProxy'+ , mMaxHeaderLength :: Maybe MaxHeaderLength+ , mMaxNumberHeaders :: Maybe MaxNumberHeaders } deriving T.Typeable @@ -618,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.@@ -630,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-#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)--import System.IO.Unsafe (unsafePerformIO)-import Control.Exception (mask_, Exception, throwTo, try, finally, SomeException, assert)-import Control.Monad (join, when, void)-import Control.Concurrent (myThreadId, threadDelay, forkIO)-import Data.IORef-import Data.Function (fix)-import Data.Typeable (Typeable)--#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 <>-(<>) :: Monoid m => m -> m -> m-(<>) = 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
@@ -1,9 +1,16 @@ http-client =========== +Full tutorial docs are available at:+https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md+ An HTTP client engine, intended as a base layer for more user-friendly packages. This codebase has been refactored from [http-conduit](http://www.stackage.org/package/http-conduit).++Note that, if you want to make HTTPS secure connections, you should use+[http-client-tls](https://www.stackage.org/package/http-client-tls) in addition+to this library. Below is a series of cookbook recipes. A number of recipes exist elsewhere, including `Network.HTTP.Client` and `Network.HTTP.Conduit`. The goal is to
http-client.cabal view
@@ -1,6 +1,6 @@ name: http-client-version: 0.4.20-synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages.+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 license: MIT@@ -31,24 +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- , bytestring >= 0.9+ Data.KeyedPool+ build-depends: base >= 4.10 && < 5+ , bytestring >= 0.10 , text >= 0.11 , http-types >= 0.8 , blaze-builder >= 0.3- , data-default-class , 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@@ -56,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@@ -68,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@@ -82,7 +103,6 @@ , transformers , deepseq , case-insensitive- , base64-bytestring , zlib , async , streaming-commons >= 0.1.1@@ -93,17 +113,24 @@ 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 Network.HTTP.Client.HeadersSpec 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
publicsuffixlist/Network/PublicSuffixList/Serialize.hs view
@@ -35,7 +35,7 @@ getText bs0 = (TE.decodeUtf8 v, BS.drop 1 bs1) where- (v, bs1) = BS.breakByte 0 bs0+ (v, bs1) = BS.break (== 0) bs0 getDataStructure :: BS.ByteString -> DataStructure getDataStructure bs0 =@@ -48,13 +48,13 @@ putTree = putMap . children putMap :: Map T.Text (Tree T.Text) -> Builder-putMap m = foldMap putPair (Map.toList m) `mappend` fromWord8 0+putMap m = Data.Foldable.foldMap putPair (Map.toList m) `mappend` fromWord8 0 putPair :: (T.Text, Tree T.Text) -> Builder putPair (x, y) = putText x `mappend` putTree y putText :: T.Text -> Builder-putText t = fromText t `mappend` fromWord8 0+putText t = fromText t `Data.Monoid.mappend` fromWord8 0 putDataStructure :: DataStructure -> BS.ByteString putDataStructure (x, y) = toByteString $ putTree x `mappend` putTree y
test-nonet/Network/HTTP/Client/BodySpec.hs view
@@ -12,59 +12,101 @@ main = hspec spec brComplete :: BodyReader -> IO Bool-brComplete brRead = do- xs <- brRead+brComplete brRead' = do+ xs <- brRead' return (xs == "") spec :: Spec 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
@@ -0,0 +1,76 @@+{-# 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++spec :: Spec+spec = describe "CookieSpec" $ do+ it "cookie equality - case insensitive Eq" $ do+ 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 `shouldSatisfy` (equivCookie cookie2)++ it "domainMatches - case insensitive" $ do+ domainMatches "www.org" "www.org" `shouldBe` True+ domainMatches "wWw.OrG" "Www.oRG" `shouldBe` True+ domainMatches "wxw.OrG" "Www.oRG" `shouldBe` False++ 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/RequestBodySpec.hs view
@@ -7,8 +7,8 @@ import System.IO import Data.IORef import qualified Data.ByteString as BS-import Network.HTTP.Client (streamFile, parseUrl, requestBody)-import Network.HTTP.Client.Internal (dummyConnection, Connection, connectionWrite, requestBuilder)+import Network.HTTP.Client (streamFile, parseUrlThrow, requestBody)+import Network.HTTP.Client.Internal (dummyConnection, connectionWrite, requestBuilder) import System.Directory (getTemporaryDirectory) spec :: Spec@@ -19,11 +19,11 @@ withBinaryFile path ReadMode $ \h' -> do conn <- verifyFileConnection h' - req0 <- parseUrl "http://example.com"+ req0 <- parseUrlThrow "http://example.com" body <- streamFile path let req = req0 { requestBody = body } - requestBuilder req conn+ _ <- requestBuilder req conn hIsEOF h' `shouldReturn` True where withTmpFile = bracket getTmpFile closeTmpFile
test-nonet/Network/HTTP/Client/RequestSpec.hs view
@@ -2,43 +2,84 @@ module Network.HTTP.Client.RequestSpec where import Blaze.ByteString.Builder (fromByteString)-import Control.Applicative ((<$>))-import Control.Monad (join, forM_)+import Control.Applicative as A ((<$>))+import Control.Monad (join, forM_, (<=<)) import Data.IORef import Data.Maybe (isJust, fromMaybe, fromJust)-import Network.HTTP.Client (parseUrl, requestHeaders, applyBasicProxyAuth) import Network.HTTP.Client.Internal-import Network.URI (URI(..), URIAuth(..)) --(parseURI, relativeTo, escapeURIString, isAllowedInURI)+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 ->- it url $ case parseUrl url of+ 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 url $ case parseUrl url of+ 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 parseUrl "http://agent:topsecret@example.com" of+ case parseUrlThrow "http://agent:topsecret@example.com" of Nothing -> error "failed" Just _ -> return () :: IO () it "add username/password to headers section" $ do- let request = parseUrl "http://user:pass@example.com"- field = join $ lookup "Authorization" . requestHeaders <$> request+ let request = parseUrlThrow "http://user:pass@example.com"+ field = join $ lookup "Authorization" . requestHeaders A.<$> request requestHostnameWithoutAuth = "example.com" (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" <$> parseUrl "http://example.org"+ let request = applyBasicProxyAuth "user" "pass" <$> parseUrlThrow "http://example.org" field = join $ lookup "Proxy-Authorization" . requestHeaders <$> request it "Should add a proxy-authorization header" $ do field `shouldSatisfy` isJust@@ -46,37 +87,36 @@ field `shouldBe` Just "Basic dXNlcjpwYXNz" describe "extract credentials from a URI" $ do+ let username = return . fst <=< extractBasicAuthInfo <=< parseURI+ password = return . snd <=< extractBasicAuthInfo <=< parseURI it "fetches non-empty username before the first ':'" $ do- username "agent:secret@example.com" `shouldBe` "agent"-- it "extra colons do not delimit username" $ do- username "agent:006:supersecret@example.com" `shouldBe` "agent"+ username "http://agent:secret@example.com" `shouldBe` Just "agent" it "after ':' is considered password" $ do- password "agent007:shakenNotStirred@example.com" `shouldBe` "shakenNotStirred"+ password "http://agent007:shakenNotStirred@example.com" `shouldBe` Just "shakenNotStirred" - it "encodes username special characters per RFC3986" $ do- username "/?#[]!$&'()*+,;=:therealpassword@example.com" `shouldBe` "%2F%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D"+ it "decodes username special characters per RFC3986" $ do+ username "http://%2F%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D:therealpassword@example.com" `shouldBe` Just "/?#[]!$&'()*+,;=" - it "encodes password special characters per RFC3986" $ do- password "therealusername:?#[]!$&'()*+,;=/@example.com" `shouldBe` "%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D%2F"+ it "decodes password special characters per RFC3986" $ do+ password "http://therealusername:%3F%23%5B%5D%21%24%26%27%28%29%2A%2B%2C%3B%3D%2F@example.com" `shouldBe` Just "?#[]!$&'()*+,;=/" it "no auth is empty" $ do- username "example.com" `shouldBe` ""- password "example.com" `shouldBe` ""+ username "http://example.com" `shouldBe` Nothing+ password "http://example.com" `shouldBe` Nothing describe "requestBuilder" $ do it "sends the full request, combining headers and body in the non-streaming case" $ do- let Just req = parseUrl "http://localhost"+ let Just req = parseUrlThrow "http://localhost" let req' = req { method = "PUT", path = "foo" } (conn, out, _) <- dummyConnection [] forM_ (bodies `zip` out1) $ \(b, o) -> do cont <- requestBuilder (req' { requestBody = b } ) conn- (const "<IO ()>" <$> cont) `shouldBe` Nothing+ (const ("<IO ()>" :: String) <$> cont) `shouldBe` Nothing out >>= (`shouldBe` o) it "sends only headers and returns an action for the body on 'Expect: 100-continue'" $ do- let Just req = parseUrl "http://localhost"+ let Just req = parseUrlThrow "http://localhost" let req' = req { requestHeaders = [("Expect", "100-continue")] , method = "PUT" , path = "foo"@@ -114,7 +154,7 @@ popper dat = do r <- newIORef dat- return . atomicModifyIORef' r $ \xs ->+ return . atomicModifyIORef r $ \xs -> case xs of (x:xs') -> (xs', x) [] -> ([], "")
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -16,8 +16,8 @@ spec :: Spec spec = describe "ResponseSpec" $ do- let getResponse' conn = getResponse (const $ return ()) Nothing req conn Nothing- Just req = parseUrl "http://localhost"+ let getResponse' conn = getResponse Nothing Nothing Nothing req (dummyManaged conn) Nothing+ req = parseRequest_ "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection [ "HTTP/1.1 200 OK\r\n"@@ -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,66 +1,135 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.HTTP.ClientSpec where -import Control.Concurrent (forkIO, threadDelay)+import Control.Concurrent (threadDelay, yield) import Control.Concurrent.Async (withAsync)-import Control.Exception (bracket)-import Control.Monad (forever, replicateM_, void)-import Network.HTTP.Client+import qualified Control.Concurrent.Async as Async+import Control.Exception (bracket, throwIO, ErrorCall(..))+import qualified Control.Exception as E+import Control.Monad (forever, replicateM_, when, unless)+import Network.HTTP.Client hiding (port)+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 import qualified Data.ByteString.Lazy as SL import Data.ByteString.Lazy.Char8 () -- orphan instance+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 -redirectServer :: (Int -> IO a) -> IO a-redirectServer inner = bracket+silentIOError :: IO () -> IO ()+silentIOError a = a `E.catch` \e -> do+ let _ = e :: IOError+ return ()++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 $ 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")+ (NS.close . snd)+ $ \(port, lsocket) -> withAsync+ (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app)+ (const $ inner port)+ where app ad = do- forkIO $ forever $ N.appRead ad- 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+ 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")+ 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) where- app ad = do- forkIO $ forever $ N.appRead ad- forever $ do+ app ad = Async.race_+ (silentIOError $ forever $ N.appRead ad)+ (silentIOError $ forever $ do N.appWrite ad $ S.concat [ "HTTP/1.1 100 Continue\r\n" , if extraHeaders then "foo:bar\r\nbaz: bin\r\n" else "" , "\r\nHTTP/1.1 200 OK\r\ncontent-length: 5\r\n\r\nhello\r\n" ]- threadDelay 10000+ threadDelay 10000) 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) where- app ad = do+ app ad = silentIOError $ do let readHeaders front = do newBS <- N.appRead ad let bs = S.append front newBS@@ -84,14 +153,16 @@ 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 = do+ app ad = silentIOError $ do let readHeaders front = do newBS <- N.appRead ad let bs = S.append front newBS@@ -103,8 +174,7 @@ getChunkedResponse :: Int -> Manager -> IO (Response SL.ByteString) getChunkedResponse port' man = flip httpLbs man "http://localhost"- { port = port'- , checkStatus = \_ _ _ -> Nothing+ { NC.port = port' , requestBody = RequestBodyStreamChunked ($ return (S.replicate 100000 65)) } @@ -112,66 +182,168 @@ spec = describe "Client" $ do describe "fails on empty hostnames #40" $ do let test url = it url $ do- req <- parseUrl url+ req <- parseUrlThrow url man <- newManager defaultManagerSettings _ <- httpLbs req man `shouldThrow` \e -> case e of- InvalidDestinationHost "" -> True+ HttpExceptionRequest _ (InvalidDestinationHost "") -> True _ -> False return () mapM_ test ["http://", "https://", "http://:8000", "https://:8001"]- it "redirecting #41" $ redirectServer $ \port -> do- req' <- parseUrl $ "http://127.0.0.1:" ++ show port+ 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 }- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do httpLbs req man `shouldThrow` \e -> case e of- TooManyRedirects _ -> True+ HttpExceptionRequest _ (TooManyRedirects _) -> True _ -> False- it "redirectCount=0" $ redirectServer $ \port -> do- req' <- parseUrl $ "http://127.0.0.1:" ++ show port+ it "redirectCount=0" $ redirectServer Nothing $ \port -> do+ req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' { redirectCount = 0 }- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do httpLbs req man `shouldThrow` \e -> case e of- StatusCodeException{} -> True+ HttpExceptionRequest _ StatusCodeException{} -> True _ -> False it "connecting to missing server gives nice error message" $ do (port, socket) <- N.bindRandomPortTCP "*4"- sClose socket- req <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager defaultManagerSettings $ \man ->- httpLbs req man `shouldThrow` \e ->- case e of- FailedConnectionException2 "127.0.0.1" port' False _ -> port == port'- _ -> False+ NS.close socket+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ man <- newManager defaultManagerSettings+ httpLbs req man `shouldThrow` \e ->+ case e of+ HttpExceptionRequest req' (ConnectionFailure _)+ -> host req == host req'+ && NC.port req == NC.port req'+ _ -> False describe "extra headers after 100 #49" $ do let test x = it (show x) $ bad100Server x $ \port -> do- req <- parseUrl $ "http://127.0.0.1:" ++ show port- withManager defaultManagerSettings $ \man -> replicateM_ 10 $ do- x <- httpLbs req man- responseBody x `shouldBe` "hello"+ req <- parseUrlThrow $ "http://127.0.0.1:" ++ show port+ man <- newManager defaultManagerSettings+ replicateM_ 10 $ do+ x' <- httpLbs req man+ responseBody x' `shouldBe` "hello" test False test True - it "early close on a 413" $ earlyClose413 $ \port' -> do- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "goodbye"- responseStatus res `shouldBe` status413+ 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- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` ""+ 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- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks."+ 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- withManager defaultManagerSettings $ \man -> do- res <- getChunkedResponse port' man- responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks."+ notWindows $ it "length and chunking" $ lengthAndChunked $ \port' -> do+ man <- newManager defaultManagerSettings+ res <- getChunkedResponse port' man+ responseBody res `shouldBe` "Wikipedia in\r\n\r\nchunks."++ 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}+ man <- newManager defaultManagerSettings+ withResponseHistory req man (const $ return ())+ `shouldThrow` \e ->+ case e of+ HttpExceptionRequest _ (TooManyRedirects _) -> True+ _ -> False++ it "should not write to closed connection" $ do+ -- see https://github.com/snoyberg/http-client/issues/225+ closedRef <- newIORef False+ okRef <- newIORef True+ let checkStatus = do+ closed <- readIORef closedRef+ when closed $ do+ writeIORef okRef False++ conn <- makeConnection+ (return S.empty)+ (const checkStatus)+ (checkStatus >> writeIORef closedRef True)++ Internal.connectionClose conn++ -- let GC release the connection and run finalizers+ performGC+ yield+ performGC++ 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,26 +1,156 @@ {-# 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.Types (status200)+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- req <- parseUrl "http://httpbin.org/"+ it "works" $ do+ req <- parseUrlThrow "http://httpbin.org/" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 - it "managerModifyRequest" $ do- let modify req = return req { port = 80 }- settings = defaultManagerSettings { managerModifyRequest = modify }- withManager settings $ \man -> do+ -- Test the failure condition described in https://github.com/snoyberg/http-client/issues/489+ it "keeps connection alive long enough" $ do+ req <- parseUrlThrow "http://httpbin.org/"+ man <- newManager defaultManagerSettings+ res <- responseOpen req man+ responseStatus res `shouldBe` status200+ let+ getChunk = responseBody res+ drainAll = do+ chunk <- getChunk+ if BS.null chunk then pure () else drainAll++ -- The returned `BodyReader` used to not contain a reference to the `Managed Connection`,+ -- only to the extracted connection and to the release action. Therefore, triggering a GC+ -- would close the connection even though we were not done reading.+ performGC+ -- Not ideal, but weak finalizers run on a separate thread, so it's racing with our drain+ -- call+ threadDelay 500000++ drainAll+ -- Calling `responseClose res` here prevents the early collection from happening in this+ -- test, but in a larger production application that did involve a `responseClose`, it still+ -- occurred.++ describe "method in URL" $ do+ it "success" $ do+ req <- parseUrlThrow "POST http://httpbin.org/post"+ man <- newManager defaultManagerSettings+ res <- httpLbs req man+ responseStatus res `shouldBe` status200++ 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+ 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++ 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 }+ settings = defaultManagerSettings { managerModifyRequest = modify }+ man <- newManager settings res <- httpLbs "http://httpbin.org:1234" man responseStatus res `shouldBe` status200++ it "checkResponse" $ do+ let modify req = return req { checkResponse = \_ _ -> error "some exception" }+ settings = defaultManagerSettings { managerModifyRequest = modify }+ man <- newManager settings+ httpLbs "http://httpbin.org" man `shouldThrow` anyException++ 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 ()