diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,11 +1,247 @@ -## 0.4.31.2 +# Changelog for http-client -* Use redirectCount set through managerModifyRequest [#244](https://github.com/snoyberg/http-client/pull/244) +## 0.7.19 -## 0.4.31.1 +* 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 diff --git a/Data/KeyedPool.hs b/Data/KeyedPool.hs new file mode 100644 --- /dev/null +++ b/Data/KeyedPool.hs @@ -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 diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -1,8 +1,7 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} -- | -- -- = Simpler API @@ -12,14 +11,14 @@ -- 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/commercialhaskell/jump/blob/master/doc/http-client.md +-- 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, @@ -41,7 +40,7 @@ -- application which will make a large number of requests to different hosts, -- and will never make more than one connection to a single host, then sharing -- a 'Manager' will result in idle connections being kept open longer than --- necessary. In such a situation, it makes sense to use 'withManager' around +-- necessary. In such a situation, it makes sense to use 'newManager' before -- each new request, to avoid running out of file descriptors. (Note that the -- 'managerIdleConnectionCount' setting mitigates the risk of leaking too many -- file descriptors.) @@ -67,7 +66,7 @@ -- 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 +-- 'applyBasicAuth' are guaranteed to be total (or there's a bug in the -- library). -- -- One thing to be cautioned about: the type of 'parseRequest' allows it to work in @@ -75,12 +74,6 @@ -- the case of an invalid URI. In addition, if you leverage the @IsString@ -- 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 ( -- $example1 @@ -111,34 +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 @@ -153,10 +163,14 @@ , applyBasicProxyAuth , decompress , redirectCount - , checkStatus + , shouldStripHeaderOnRedirect + , shouldStripHeaderOnRedirectIfOnDifferentHostOnly + , checkResponse , responseTimeout , cookieJar , requestVersion + , redactHeaders + , earlyHintHeadersReceived -- ** Request body , RequestBody (..) , Popper @@ -172,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 @@ -194,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) @@ -202,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. -- @@ -222,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 @@ -230,13 +258,18 @@ -- -- 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 req0 = do - (man, req) <- getModifiedRequestManager man req0 - (req', res) <- httpRaw' req man + (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) @@ -245,9 +278,10 @@ Just req'' -> do writeIORef reqRef req'' body <- brReadSome (responseBody res) 1024 + `catch` handleClosedRead modifyIORef historyRef (. ((req, res { responseBody = body }):)) return (res, req'', True) - (_, res) <- httpRedirect' (redirectCount req0) go req0 + (_, res) <- httpRedirect' (redirectCount reqOrig) go reqOrig reqFinal <- readIORef reqRef history <- readIORef historyRef return HistoriedResponse @@ -288,7 +322,15 @@ 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 @@ -302,7 +344,7 @@ -- > main = do -- > manager <- newManager defaultManagerSettings -- > --- > request <- parseRequest "http://httpbin.org/post" +-- > request <- parseRequest "http://httpbin.org/get" -- > response <- httpLbs request manager -- > -- > putStrLn $ "The status code was: " ++ (show $ statusCode $ responseStatus response) @@ -315,6 +357,7 @@ -- > import Network.HTTP.Client -- > import Network.HTTP.Types.Status (statusCode) -- > import Data.Aeson (object, (.=), encode) +-- > import Data.Text (Text) -- > -- > main :: IO () -- > main = do @@ -322,6 +365,11 @@ -- > -- > -- Create the request -- > let requestObject = object ["name" .= "Michael", "age" .= 30] +-- > let requestObject = object +-- > [ "name" .= ("Michael" :: Text) +-- > , "age" .= (30 :: Int) +-- > ] +-- > -- > initialRequest <- parseRequest "http://httpbin.org/post" -- > let request = initialRequest { method = "POST", requestBody = RequestBodyLBS $ encode requestObject } -- > @@ -329,3 +377,34 @@ -- > 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. diff --git a/Network/HTTP/Client/Body.hs b/Network/HTTP/Client/Body.hs --- a/Network/HTTP/Client/Body.hs +++ b/Network/HTTP/Client/Body.hs @@ -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 diff --git a/Network/HTTP/Client/Connection.hs b/Network/HTTP/Client/Connection.hs --- a/Network/HTTP/Client/Connection.hs +++ b/Network/HTTP/Client/Connection.hs @@ -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.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,6 +92,9 @@ , 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 @@ -99,8 +115,7 @@ return $! Connection { connectionRead = do closed <- readIORef closedVar - when closed $ - throwIO ConnectionClosed + when closed $ throwHttp ConnectionClosed join $ atomicModifyIORef istack $ \stack -> case stack of x:xs -> (xs, return x) @@ -108,24 +123,27 @@ , connectionUnread = \x -> do closed <- readIORef closedVar - when closed $ - throwIO ConnectionClosed + when closed $ throwHttp ConnectionClosed atomicModifyIORef istack $ \stack -> (x:stack, ()) , connectionWrite = \x -> do closed <- readIORef closedVar - when closed $ - throwIO ConnectionClosed + 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 @@ -140,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 @@ -155,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 - tweakSocket sock - NS.connect sock (NS.addrAddress addr) - socketConnection sock chunksize) + E.bracketOnError (firstSuccessful addrs $ openSocket tweakSocket) NS.close f +openSocket tweakSocket addr = + E.bracketOnError + (NS.socket (NS.addrFamily addr) (NS.addrSocketType addr) + (NS.addrProtocol addr)) + NS.close + (\sock -> do + NS.setSocketOption sock NS.NoDelay 1 + tweakSocket sock + NS.connect sock (NS.addrAddress addr) + return sock) + +-- Pick up an IP using an approximation of the happy-eyeballs algorithm: +-- https://datatracker.ietf.org/doc/html/rfc8305 +-- firstSuccessful :: [NS.AddrInfo] -> (NS.AddrInfo -> IO a) -> IO a -firstSuccessful [] _ = error "getAddrInfo returned empty list" -firstSuccessful (a:as) cb = - cb a `E.catch` \(e :: E.IOException) -> - case as of - [] -> E.throwIO e - _ -> firstSuccessful as cb +firstSuccessful [] _ = error "getAddrInfo returned empty list" +firstSuccessful addresses cb = do + result <- newEmptyMVar + either E.throwIO pure =<< + withAsync (tryAddresses result) + (\_ -> takeMVar result) + where + -- https://datatracker.ietf.org/doc/html/rfc8305#section-5 + connectionAttemptDelay = 250 * 1000 + + tryAddresses result = do + z <- forConcurrently (zip addresses [0..]) $ \(addr, n) -> do + when (n > 0) $ threadDelay $ n * connectionAttemptDelay + tryAddress addr + + case listToMaybe (reverse z) of + Just e@(Left _) -> tryPutMVar result e + _ -> error $ "tryAddresses invariant violated: " ++ show addresses + where + tryAddress addr = do + r :: Either E.IOException a <- E.try $! cb addr + for_ r $ \_ -> tryPutMVar result r + pure r diff --git a/Network/HTTP/Client/Cookies.hs b/Network/HTTP/Client/Cookies.hs --- a/Network/HTTP/Client/Cookies.hs +++ b/Network/HTTP/Client/Cookies.hs @@ -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 = @@ -102,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 @@ -113,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\" @@ -123,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') @@ -145,12 +177,12 @@ condition2 = pathMatches (Req.path request) (cookie_path cookie) condition3 | not (cookie_secure_only cookie) = True - | otherwise = Req.secure request + | otherwise = isPotentiallyTrustworthyOrigin (Req.secure request) (Req.host request) condition4 | not (cookie_http_only cookie) = True | otherwise = is_http_api matching_cookies = filter matching_cookie $ expose cookie_jar - output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sort matching_cookies + output_cookies = map (\ c -> (cookie_name c, cookie_value c)) $ L.sortBy compareCookies matching_cookies output_line = toByteString $ renderCookies $ output_cookies folding_function cookie_jar'' cookie = case removeExistingCookieFromCookieJar cookie cookie_jar'' of (Just c, cookie_jar''') -> insertIntoCookieJar (c {cookie_last_access_time = now}) cookie_jar''' diff --git a/Network/HTTP/Client/Core.hs b/Network/HTTP/Client/Core.hs --- a/Network/HTTP/Client/Core.hs +++ b/Network/HTTP/Client/Core.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.Core ( withResponse @@ -7,32 +6,35 @@ , httpNoBody , httpRaw , httpRaw' + , requestAction , getModifiedRequestManager , responseOpen , responseClose - , applyCheckStatus , httpRedirect , httpRedirect' + , withConnection + , handleClosedRead ) where -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif -import Network.HTTP.Client.Body -import Network.HTTP.Client.Cookies +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.Types -import Network.HTTP.Types +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 @@ -94,45 +96,88 @@ 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 - httpRaw' req m - -- Not reused, or a non-retry, so this is a real exception - (Left e, _) -> throwIO e - -- Everything went ok, so the connection is good. If any exceptions get - -- thrown in the response body, just throw them as normal. - (Right res, _) -> case cookieJar req' of - Just _ -> do - now' <- getCurrentTime - let (cookie_jar, _) = updateCookieJar res req now' cookie_jar' - return (req, res {responseCookieJar = cookie_jar}) - Nothing -> return (req, res) +requestAction :: IORef (Request -> Manager -> IO (Response BodyReader)) +{-# NOINLINE requestAction #-} +requestAction = unsafePerformIO (newIORef action) where + 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 @@ -176,64 +221,32 @@ -- -- Since 0.1.0 responseOpen :: Request -> Manager -> IO (Response BodyReader) -responseOpen req0 manager' = handle addTlsHostPort $ mWrapIOException manager $ do - (req, res) <- - if redirectCount req0 == 0 - then httpRaw' req0 manager - else go (redirectCount req0) req0 - maybe (return res) throwIO =<< applyCheckStatus req (checkStatus req) 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 - manager = fromMaybe manager' (requestManagerOverride req0) - - addTlsHostPort (TlsException e) = throwIO $ TlsExceptionHostPort e (host req0) (port req0) - addTlsHostPort e = throwIO e + wrapExc :: Request -> IO a -> IO a + wrapExc req0 = handle $ throwIO . toHttpException req0 - go count req' = httpRedirect' + go manager0 count req' = httpRedirect' count (\req -> do - (manager, modReq) <- getModifiedRequestManager manager req + (manager, modReq) <- getModifiedRequestManager manager0 req (req'', res) <- httpRaw' modReq manager let mreq = if redirectCount modReq == 0 then Nothing - else getRedirectedRequest req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) + else getRedirectedRequest req' req'' (responseHeaders res) (responseCookieJar res) (statusCode (responseStatus res)) return (res, fromMaybe req'' mreq, isJust mreq)) req' --- | 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 -#ifndef MIN_VERSION_bytestring -#define MIN_VERSION_bytestring(x,y,z) 1 -#endif -#if MIN_VERSION_bytestring(0,10,0) - toStrict' = L.toStrict -#else - toStrict' = S.concat . L.toChunks -#endif - -- | Redirect loop. httpRedirect :: Int -- ^ 'redirectCount' @@ -247,6 +260,17 @@ (res, mbReq) <- http0 req' return (res, fromMaybe req0 mbReq, isJust mbReq) +handleClosedRead :: SomeException -> IO L.ByteString +handleClosedRead se + | Just ConnectionClosed <- fmap unHttpExceptionContentWrapper (fromException se) + = return L.empty + | Just (HttpExceptionRequest _ ConnectionClosed) <- fromException se + = return L.empty + | Just (IOError _ ResourceVanished _ _ _ _) <- fromException se + = return L.empty + | otherwise + = throwIO se + -- | Redirect loop. -- -- This extended version of 'httpRaw' also returns the Request potentially modified by @managerModifyRequest@. @@ -257,7 +281,7 @@ -> IO (Request, Response BodyReader) httpRedirect' count0 http' req0 = go count0 req0 [] where - go count _ ress | count < 0 = throwIO $ TooManyRedirects ress + go count _ ress | count < 0 = throwHttp $ TooManyRedirects ress go count req' ress = do (res, req, isRedirect) <- http' req' if isRedirect then do @@ -270,7 +294,7 @@ -- The connection may already be closed, e.g. -- when using withResponseHistory. See -- https://github.com/snoyberg/http-client/issues/169 - `catch` \(_ :: ConnectionClosed) -> return L.empty + `Control.Exception.catch` handleClosedRead responseClose res -- And now perform the actual redirect @@ -285,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 diff --git a/Network/HTTP/Client/Headers.hs b/Network/HTTP/Client/Headers.hs --- a/Network/HTTP/Client/Headers.hs +++ b/Network/HTTP/Client/Headers.hs @@ -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,29 +47,36 @@ 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 + 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 @@ -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.break (== charColon) bs - when (S.null bs2) $ throwIO $ InvalidHeader bs - return (CI.mk $! strip key, strip $! S.drop 1 bs2) + if S.null bs2 + then return Nothing + else return (Just (CI.mk $! strip key, strip $! S.drop 1 bs2)) strip = S.dropWhile (== charSpace) . fst . S.spanEnd (== charSpace) + +data HeadersValidationResult + = GoodHeaders + | BadHeaders S.ByteString -- contains a message with the reason + +validateHeaders :: RequestHeaders -> HeadersValidationResult +validateHeaders headers = + case mapMaybe validateHeader headers of + [] -> GoodHeaders + reasons -> BadHeaders (S8.unlines reasons) + where + validateHeader (k, v) + | S8.elem '\n' v = Just ("Header " <> CI.original k <> " has newlines") + | True = Nothing diff --git a/Network/HTTP/Client/Internal.hs b/Network/HTTP/Client/Internal.hs --- a/Network/HTTP/Client/Internal.hs +++ b/Network/HTTP/Client/Internal.hs @@ -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) diff --git a/Network/HTTP/Client/Manager.hs b/Network/HTTP/Client/Manager.hs --- a/Network/HTTP/Client/Manager.hs +++ b/Network/HTTP/Client/Manager.hs @@ -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,52 +17,25 @@ , proxyEnvironmentNamed , defaultProxy , dropProxyAuthSecure + , useProxySecureWithoutConnect ) where -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif -#if !MIN_VERSION_base(4,6,0) -import Prelude hiding (catch) -#endif -import Control.Applicative ((<|>)) -import Control.Arrow (first) -import 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.Char (toLower) 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 (applyBasicProxyAuth, extractBasicAuthInfo) -import Control.Concurrent.MVar (MVar, takeMVar, tryPutMVar, newEmptyMVar) -import System.Environment (getEnvironment) -import qualified Network.URI as U -import Control.Monad (guard) +import Network.HTTP.Proxy +import Data.KeyedPool +import Data.Maybe (isJust) -- | A value for the @managerRawConnection@ setting, but also allows you to -- modify the underlying @Socket@ to set additional settings. For a motivating @@ -78,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 @@ -94,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 @@ -110,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 1 (const 0) mx - m' = ManagerOpen cnt' (Map.insert key l' m) - in m' `seq` (m', maybe (return ()) connectionClose mx) - --- | Add a new element to the list, up to the given maximum number. If we're --- already at the maximum, return the new value as leftover. -addToList :: UTCTime -> Int -> a -> NonEmptyList a -> (NonEmptyList a, Maybe a) -addToList _ i x l | i <= 1 = (l, Just x) -addToList now _ x l@One{} = (Cons x 2 now l, Nothing) -addToList now maxCount x l@(Cons _ currCount _ _) - | maxCount > currCount = (Cons x (currCount + 1) now l, Nothing) - | otherwise = (l, Just x) - -- | Create a 'Manager'. The @Manager@ will be shut down automatically via -- garbage collection. -- @@ -179,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 @@ -283,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'. -- @@ -312,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 @@ -327,129 +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 - 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 - sh@(StatusHeaders status _ _) <- parseStatusHeaders conn Nothing Nothing - unless (status == status200) $ - throwIO $ ProxyConnectException ultHost ultPort $ Right $ StatusCodeException status [] (CJ []) - in mTlsProxyConnection m connstr parse (S8.unpack ultHost) + throwHttp $ ConnectionFailure (toException (e :: IOException)) -- | Get the proxy settings from the @Request@ itself. -- @@ -469,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 @@ -477,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. @@ -493,65 +323,12 @@ :: Text -- ^ environment variable name -> Maybe Proxy -- ^ fallback if no environment set -> ProxyOverride -proxyEnvironmentNamed name = - ProxyOverride . const . envHelper name - . maybe EHNoProxy EHUseProxy +proxyEnvironmentNamed name mp = ProxyOverride $ \secure' -> + systemProxyHelper (Just name) (httpProtocol secure') $ maybe EHNoProxy EHUseProxy mp -- | The default proxy settings for a manager. In particular: if the @http_proxy@ (or @https_proxy@) environment variable is set, use it. Otherwise, use the values in the @Request@. -- -- Since 0.4.7 defaultProxy :: ProxyOverride -defaultProxy = ProxyOverride $ \secure -> - envHelper (envName secure) EHFromRequest - -data EnvHelper = EHFromRequest - | EHNoProxy - | EHUseProxy Proxy - -envHelper :: Text -> EnvHelper -> IO (Request -> Request) -envHelper name eh = do - env <- getEnvironment - let lenv = Map.fromList $ map (first $ T.toLower . T.pack) env - lookupEnvVar n = lookup (T.unpack n) env <|> Map.lookup n lenv - noProxyDomains = domainSuffixes (lookupEnvVar "no_proxy") - case lookupEnvVar name of - Nothing -> return noEnvProxy - Just "" -> return noEnvProxy - Just str -> do - let invalid = 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 - port <- - case U.uriPort auth of - "" -> Just 80 - ':':rest -> - case decimal $ T.pack rest of - Right (p, "") -> Just p - _ -> Nothing - _ -> Nothing - - Just $ (Proxy (S8.pack $ U.uriRegName auth) port, extractBasicAuthInfo uri) - return $ \req -> - if host req `hasDomainSuffixIn` noProxyDomains - then noEnvProxy req - else maybe id (uncurry applyBasicProxyAuth) muserpass - req { proxy = Just p } - where noEnvProxy = case eh of - EHFromRequest -> id - EHNoProxy -> \req -> req { proxy = Nothing } - EHUseProxy p -> \req -> req { proxy = Just p } - prefixed s | S8.head s == '.' = s - | otherwise = S8.cons '.' s - domainSuffixes Nothing = [] - domainSuffixes (Just "") = [] - domainSuffixes (Just no_proxy) = [prefixed $ S8.dropWhile (== ' ') suffix | suffix <- S8.split ',' (S8.pack (map toLower no_proxy)), not (S8.null suffix)] - hasDomainSuffixIn host = any (`S8.isSuffixOf` prefixed (S8.map toLower host)) +defaultProxy = ProxyOverride $ \secure' -> + systemProxyHelper Nothing (httpProtocol secure') EHFromRequest diff --git a/Network/HTTP/Client/MultipartFormData.hs b/Network/HTTP/Client/MultipartFormData.hs --- a/Network/HTTP/Client/MultipartFormData.hs +++ b/Network/HTTP/Client/MultipartFormData.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE CPP, OverloadedStrings #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module handles building multipart/form-data. Example usage: -- -- > {-# LANGUAGE OverloadedStrings #-} @@ -10,7 +10,7 @@ -- > -- > import Control.Monad -- > --- > main = withSocketsDo $ void $ withManager defaultManagerSettings $ \m -> do +-- > main = void $ withManager defaultManagerSettings $ \m -> do -- > req1 <- parseRequest "http://random-cat-photo.net/cat.jpg" -- > res <- httpLbs req1 m -- > req2 <- parseRequest "http://example.org/~friedrich/blog/addPost.hs" @@ -24,6 +24,7 @@ ( -- * Part type Part + ,PartM ,partName ,partFilename ,partContentType @@ -77,17 +78,19 @@ import Control.Monad import Data.ByteString.Lazy.Internal (defaultChunkSize) +type Part = PartM IO + -- | A single part of a multipart message. -data Part = Part +data PartM m = Part { partName :: Text -- ^ Name of the corresponding \ , 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 \. +partBS :: Applicative m + => Text -- ^ Name of the corresponding \. -> 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 \. +partLBS :: Applicative m + => Text -- ^ Name of the corresponding \. -> 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 \. +partFileRequestBody :: Applicative m + => Text -- ^ Name of the corresponding \. -> 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 \. -> 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 diff --git a/Network/HTTP/Client/Request.hs b/Network/HTTP/Client/Request.hs --- a/Network/HTTP/Client/Request.hs +++ b/Network/HTTP/Client/Request.hs @@ -4,7 +4,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE BangPatterns #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module Network.HTTP.Client.Request @@ -12,36 +11,45 @@ , 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 , extractBasicAuthInfo + , throwErrorStatusCodes + , addProxySecureWithoutConnect ) where import Data.Int (Int64) -import Data.Maybe (fromMaybe, isJust, isNothing) -import Data.Monoid (mempty, mappend) +import Data.Maybe (fromMaybe, isNothing) +import Data.Monoid (mempty, mappend, (<>)) import Data.String (IsString(..)) import Data.Char (toLower) -import Control.Applicative ((<$>)) -import Control.Monad (when, unless, guard) +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) @@ -52,22 +60,18 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import qualified Network.HTTP.Types as W -import Network.URI (URI (..), URIAuth (..), parseURI, relativeTo, escapeURIString, unEscapeString, 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) @@ -80,32 +84,37 @@ parseUrl = parseUrlThrow {-# DEPRECATED parseUrl "Please use parseUrlThrow, parseRequest, or parseRequest_ instead" #-} --- | Same as 'parseRequest', except will throw an 'HttpException' in --- the event of a non-2XX response. +-- | Same as 'parseRequest', except will throw an 'HttpException' in the +-- event of a non-2XX response. This uses 'throwErrorStatusCodes' to +-- implement 'checkResponse'. -- -- @since 0.4.30 parseUrlThrow :: MonadThrow m => String -> m Request -parseUrlThrow s' = - case parseURI (encode s) of - Just uri -> liftM setMethod (setUri def uri) - Nothing -> throwM $ InvalidUrlException s "Invalid URL" +parseUrlThrow = + liftM yesThrow . parseRequest 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 } + 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'. @@ -113,39 +122,68 @@ -- You can place the request method at the beginning of the URL separated by a -- space, e.g.: -- --- @@@ --- parseRequeset "POST http://httpbin.org/post" --- @@@ +-- @ +-- parseRequest "POST http://httpbin.org/post" +-- @ -- -- Note that the request method must be provided as all capital letters. -- +-- 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 = - liftM noThrow . parseUrlThrow +parseRequest s' = + case parseURI (encode s) of + Just uri -> liftM setMethod (setUri defaultRequest uri) + Nothing -> throwM $ InvalidUrlException s "Invalid URL" where - noThrow req = req { checkStatus = \_ _ _ -> Nothing } + encode = escapeURIString isAllowedInURI + (mmethod, s) = + case break (== ' ') s' of + (x, ' ':y) | all (\c -> 'A' <= c && c <= 'Z') x -> (Just x, y) + _ -> (Nothing, s') --- | Same as 'parseRequest', but in the cases of a parse error --- generates an impure exception. Mostly useful for static strings which --- are known to be correctly formatted. + 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 = -#ifndef MIN_VERSION_network -#define MIN_VERSION_network(x,y,z) 1 -#endif -#if MIN_VERSION_network(2,4,0) - setUri req $ uri `relativeTo` getUri req -#else - case uri `relativeTo` getUri req of - Just uri' -> setUri req uri' - Nothing -> throwM $ InvalidUrlException (show uri) "Invalid URL" -#endif +setUriRelative req uri = setUri req $ uri `relativeTo` getUri req -- | Extract a 'URI' from the request. -- @@ -158,7 +196,7 @@ , uriAuthority = Just URIAuth { uriUserInfo = "" , uriRegName = S8.unpack $ host req - , uriPort = ':' : show (port req) + , uriPort = port' } , uriPath = S8.unpack $ path req , uriQuery = @@ -167,6 +205,11 @@ _ -> S8.unpack $ queryString req , uriFragment = "" } + where + port' + | secure req && (port req) == 443 = "" + | not (secure req) && (port req) == 80 = "" + | otherwise = ':' : show (port req) applyAnyUriBasedAuth :: URI -> Request -> Request applyAnyUriBasedAuth uri req = @@ -178,7 +221,7 @@ -- Return Nothing when there is no auth info in URI. extractBasicAuthInfo :: URI -> Maybe (S8.ByteString, S8.ByteString) extractBasicAuthInfo uri = do - userInfo <- uriUserInfo <$> uriAuthority uri + userInfo <- uriUserInfo A.<$> uriAuthority uri guard (':' `elem` userInfo) let (username, ':':password) = break (==':') . takeWhile (/='@') $ userInfo return (toLiteral username, toLiteral password) @@ -187,9 +230,18 @@ -- | Validate a 'URI', then add it to the request. setUri :: MonadThrow m => Request -> URI -> m Request -setUri req uri = do +setUri req uri = either throwInvalidUrlException return (setUriEither req uri) + where + throwInvalidUrlException = throwM . InvalidUrlException (show uri) + +-- | A variant of `setUri` that returns an error message on validation errors, +-- instead of propagating them with `throwM`. +-- +-- @since 0.6.1 +setUriEither :: Request -> URI -> Either String Request +setUriEither req uri = do sec <- parseScheme uri - auth <- maybe (failUri "URL must be absolute") return $ uriAuthority uri + auth <- maybe (Left "URL must be absolute") return $ uriAuthority uri port' <- parsePort sec auth return $ applyAnyUriBasedAuth uri req { host = S8.pack $ uriRegName auth @@ -202,61 +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) - --- | A default request value +-- Note that the default 'checkResponse' does nothing. -- -- @since 0.4.30 defaultRequest :: Request -defaultRequest = def { checkStatus = \_ _ _ -> Nothing } - -instance Default Request where - def = Request +defaultRequest = Request { host = "localhost" , port = 80 , secure = False @@ -270,40 +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 @@ -313,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" $ 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. -- @@ -334,6 +373,13 @@ addProxy hst prt req = req { proxy = Just $ Proxy hst prt } + +-- | Send secure requests to the proxy in plain text rather than using CONNECT. +-- +-- @since 0.7.2 +addProxySecureWithoutConnect :: Request -> Request +addProxySecureWithoutConnect req = req { proxySecureMode = ProxySecureWithoutConnect } + -- | Add a Proxy-Authorization header (with the specified username and -- password) to the given 'Request'. Ignore error handling: -- @@ -345,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'. -- @@ -374,6 +419,19 @@ && ("content-encoding", "gzip") `elem` hs' && decompress req (fromMaybe "" $ lookup "content-type" hs') +data EncapsulatedPopperException = EncapsulatedPopperException E.SomeException + deriving (Show) +instance E.Exception EncapsulatedPopperException + +-- | Encapsulate a thrown exception into a custom type +-- +-- During streamed body sending, both the Popper and the connection may throw IO exceptions; +-- however, we don't want to route the Popper exceptions through onRequestBodyException. +-- https://github.com/snoyberg/http-client/issues/469 +encapsulatePopperException :: IO a -> IO a +encapsulatePopperException action = + action `E.catch` (\(ex :: E.SomeException) -> E.throwIO (EncapsulatedPopperException ex)) + requestBuilder :: Request -> Connection -> IO (Maybe (IO ())) requestBuilder req Connection {..} = do (contentLength, sendNow, sendLater) <- toTriple (requestBody req) @@ -382,9 +440,12 @@ else sendNow >> return Nothing where expectContinue = Just "100-continue" == lookup "Expect" (requestHeaders req) - checkBadSend f = f `E.catch` onRequestBodyException req + checkBadSend f = f `E.catches` [ + E.Handler (\(EncapsulatedPopperException ex) -> throwIO ex) + , E.Handler (onRequestBodyException req) + ] writeBuilder = toByteStringIO connectionWrite - writeHeadersWith contentLength = writeBuilder . (builder contentLength `mappend`) + writeHeadersWith contentLength = writeBuilder . (builder contentLength `Data.Monoid.mappend`) flushHeaders contentLength = writeHeadersWith contentLength flush toTriple (RequestBodyLBS lbs) = do @@ -420,16 +481,16 @@ toTriple (RequestBodyIO mbody) = mbody >>= toTriple writeStream mlen withStream = - withStream (loop 0) + withStream (loop 0) where loop !n stream = do - bs <- stream + bs <- encapsulatePopperException stream if S.null bs - then case mlen of + 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) $ throwIO $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n) + Just len -> unless (len == n) $ throwHttp $ WrongRequestBodyStreamSize (fromIntegral len) (fromIntegral n) else do connectionWrite $ if (isNothing mlen) -- Chunked @@ -441,7 +502,6 @@ else bs loop (n + (S.length bs)) stream - hh | port req == 80 && not (secure req) = host req | port req == 443 && secure req = host req @@ -451,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 @@ -484,7 +551,7 @@ builder contentLength = fromByteString (method req) <> fromByteString " " - <> requestHostname + <> requestHostname req <> (case S8.uncons $ path req of Just ('/', _) -> fromByteString $ path req _ -> fromChar '/' <> fromByteString (path req)) @@ -515,13 +582,28 @@ -- -- @since 0.4.29 setRequestIgnoreStatus :: Request -> Request -setRequestIgnoreStatus req = req { checkStatus = \_ _ _ -> Nothing } +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. -- diff --git a/Network/HTTP/Client/Response.hs b/Network/HTTP/Client/Response.hs --- a/Network/HTTP/Client/Response.hs +++ b/Network/HTTP/Client/Response.hs @@ -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,6 +25,7 @@ import Network.HTTP.Client.Util import Network.HTTP.Client.Body import Network.HTTP.Client.Headers +import Data.KeyedPool -- | If a request is a redirection (status code 3xx) this function will create -- a new request from the old request, the server headers returned with the @@ -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 diff --git a/Network/HTTP/Client/Types.hs b/Network/HTTP/Client/Types.hs --- a/Network/HTTP/Client/Types.hs +++ b/Network/HTTP/Client/Types.hs @@ -1,25 +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 (..) - , ConnectionClosed (..) , HttpException (..) + , HttpExceptionContent (..) + , unHttpExceptionContentWrapper + , throwHttp + , toHttpException , Cookie (..) + , equalCookie + , equivCookie + , compareCookies , CookieJar (..) + , equalCookieJar + , equivCookieJar , Proxy (..) , RequestBody (..) , Popper , NeedsPopper , GivesPopper , Request (..) - , ConnReuse (..) - , ConnRelease - , ManagedConn (..) , Response (..) , ResponseClose (..) , Manager (..) @@ -31,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) @@ -51,12 +61,12 @@ import Network.Socket (HostAddress) import Data.IORef import qualified Network.Socket as NS -import qualified Data.IORef as I import qualified Data.Map as Map +import qualified Data.Set as Set import Data.Text (Text) import Data.Streaming.Zlib (ZlibException) -import Control.Concurrent.MVar (MVar) import Data.CaseInsensitive as CI +import Data.KeyedPool (KeyedPool) -- | An @IO@ action that represents an incoming response body coming from the -- server. Data provided by this action has already been gunzipped and @@ -77,48 +87,129 @@ -- ^ Send data to server , connectionClose :: IO () -- ^ Close connection. Any successive operation on the connection - -- (exept closing) should fail with `ConnectionClosed` exception. + -- (except closing) should fail with `ConnectionClosed` exception. -- It is allowed to close connection multiple times. } deriving T.Typeable -data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders +data StatusHeaders = StatusHeaders Status HttpVersion RequestHeaders RequestHeaders deriving (Show, Eq, Ord, T.Typeable) -data ConnectionClosed = ConnectionClosed - deriving (Eq, Show, T.Typeable) +-- | 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 -instance Exception ConnectionClosed +throwHttp :: HttpExceptionContent -> IO a +throwHttp = throwIO . HttpExceptionContentWrapper -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 +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. -- - -- - | 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. -- @@ -126,36 +217,45 @@ -- -- @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 - -- - -- Since 0.4.7 - | ResponseLengthAndChunkingBothUsed - -- ^ Detect a case where both the @content-length@ header - -- and @transfer-encoding: chunked@ are used. Since 0.4.8. + -- ^ Values in the proxy environment variable were invalid. + -- Provides the environment variable name and its value. -- - -- Since 0.4.11 this exception isn't thrown anymore. - | TlsExceptionHostPort SomeException S.ByteString Int - -- ^ TLS exception, together with the host and port + -- @since 0.5.0 + | ConnectionClosed + -- ^ Attempted to use a 'Connection' which was already closed -- - -- @since 0.4.24 + -- @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 @@ -175,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 = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b) - path_matches = cookie_path a == cookie_path b +-- | Instead of '(==)'. +-- +-- Since there was some confusion in the history of this library about how the 'Eq' instance +-- should work, it was removed for clarity, and replaced by 'equal' and 'equiv'. 'equal' +-- gives you equality of all fields of the 'Cookie' record. +-- +-- @since 0.7.0 +equalCookie :: Cookie -> Cookie -> Bool +equalCookie a b = and + [ cookie_name a == cookie_name b + , cookie_value a == cookie_value b + , cookie_expiry_time a == cookie_expiry_time b + , cookie_domain a == cookie_domain b + , cookie_path a == cookie_path b + , cookie_creation_time a == cookie_creation_time b + , cookie_last_access_time a == cookie_last_access_time b + , cookie_persistent a == cookie_persistent b + , cookie_host_only a == cookie_host_only b + , cookie_secure_only a == cookie_secure_only b + , cookie_http_only a == cookie_http_only b + ] -instance Ord Cookie where - compare c1 c2 +-- | Equality of name, domain, path only. This corresponds to step 11 of the algorithm +-- described in Section 5.3 \"Storage Model\". See also: 'equal'. +-- +-- @since 0.7.0 +equivCookie :: Cookie -> Cookie -> Bool +equivCookie a b = name_matches && domain_matches && path_matches + where name_matches = cookie_name a == cookie_name b + domain_matches = CI.foldCase (cookie_domain a) == CI.foldCase (cookie_domain b) + path_matches = cookie_path a == cookie_path b + +-- | Instead of @instance Ord Cookie@. See 'equalCookie', 'equivCookie'. +-- +-- @since 0.7.0 +compareCookies :: Cookie -> Cookie -> Ordering +compareCookies c1 c2 | S.length (cookie_path c1) > S.length (cookie_path c2) = LT | S.length (cookie_path c1) < S.length (cookie_path c2) = GT | cookie_creation_time c1 > cookie_creation_time c2 = GT | otherwise = LT -instance 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. @@ -241,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 @@ -277,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) = @@ -345,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. @@ -412,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 @@ -464,15 +613,78 @@ -- 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, "") + else h -- | A simple representation of the HTTP response. -- @@ -506,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 . @@ -529,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. -- @@ -538,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 @@ -552,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 -- @@ -572,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. -- @@ -587,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 @@ -604,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 @@ -650,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. @@ -662,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) diff --git a/Network/HTTP/Client/Util.hs b/Network/HTTP/Client/Util.hs --- a/Network/HTTP/Client/Util.hs +++ b/Network/HTTP/Client/Util.hs @@ -1,181 +1,15 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} module Network.HTTP.Client.Util - ( hGetSome - , (<>) - , readDec - , hasNoBody - , fromStrict - , timeout + ( readPositiveInt ) where -import Data.Monoid (Monoid, mappend) - -import qualified Data.ByteString.Char8 as S8 - -#ifndef MIN_VERSION_bytestring -#define MIN_VERSION_bytestring(x,y,z) 1 -#endif - -#if MIN_VERSION_bytestring(0,10,0) -import Data.ByteString.Lazy (fromStrict) -#else -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as S -#endif - -import qualified Data.Text as T -import qualified Data.Text.Read -import System.Timeout (timeout) - -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) - -#ifndef MIN_VERSION_base -#define MIN_VERSION_base(x,y,z) 1 -#endif -#if MIN_VERSION_base(4,3,0) -import Data.ByteString (hGetSome) -#else -import GHC.IO.Handle.Types -import System.IO (hWaitForInput, hIsEOF) -import System.IO.Error (mkIOError, illegalOperationErrorType) - --- | Like 'hGet', except that a shorter 'ByteString' may be returned --- if there are not enough bytes immediately available to satisfy the --- whole request. 'hGetSome' only blocks if there is no data --- available, and EOF has not yet been reached. -hGetSome :: Handle -> Int -> IO S.ByteString -hGetSome hh i - | i > 0 = let - loop = do - s <- S.hGetNonBlocking hh i - if not (S.null s) - then return s - else do eof <- hIsEOF hh - if eof then return s - else hWaitForInput hh (-1) >> loop - -- for this to work correctly, the - -- Handle should be in binary mode - -- (see GHC ticket #3808) - in loop - | i == 0 = return S.empty - | otherwise = illegalBufferSize hh "hGetSome" i - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn sz = - ioError (mkIOError illegalOperationErrorType msg (Just handle) Nothing) - --TODO: System.IO uses InvalidArgument here, but it's not exported :-( - where - msg = fn ++ ": illegal ByteString size " ++ showsPrec 9 sz [] -#endif - -infixr 5 <> -(<>) :: 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 diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Proxy.hs @@ -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 = "" `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')) diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -2,7 +2,7 @@ =========== Full tutorial docs are available at: -https://github.com/commercialhaskell/jump/blob/master/doc/http-client.md +https://github.com/snoyberg/http-client/blob/master/TUTORIAL.md An HTTP client engine, intended as a base layer for more user-friendly packages. diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,6 +1,6 @@ name: http-client -version: 0.4.31.2 -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: . 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,6 +113,9 @@ type: exitcode-stdio-1.0 hs-source-dirs: test-nonet default-language: Haskell2010 + ghc-options: -threaded + if os(windows) + cpp-options: -DWINDOWS other-modules: Network.HTTP.ClientSpec Network.HTTP.Client.ResponseSpec Network.HTTP.Client.BodySpec @@ -100,11 +123,14 @@ Network.HTTP.Client.RequestSpec Network.HTTP.Client.RequestBodySpec Network.HTTP.Client.CookieSpec + Network.HTTP.Client.ConnectionSpec + build-tool-depends: hspec-discover:hspec-discover build-depends: base , http-client , hspec , monad-control , bytestring + , cookie , text , http-types , blaze-builder @@ -115,7 +141,6 @@ , transformers , deepseq , case-insensitive - , base64-bytestring , zlib , async , streaming-commons >= 0.1.1 diff --git a/publicsuffixlist/Network/PublicSuffixList/Serialize.hs b/publicsuffixlist/Network/PublicSuffixList/Serialize.hs --- a/publicsuffixlist/Network/PublicSuffixList/Serialize.hs +++ b/publicsuffixlist/Network/PublicSuffixList/Serialize.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/BodySpec.hs b/test-nonet/Network/HTTP/Client/BodySpec.hs --- a/test-nonet/Network/HTTP/Client/BodySpec.hs +++ b/test-nonet/Network/HTTP/Client/BodySpec.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/ConnectionSpec.hs b/test-nonet/Network/HTTP/Client/ConnectionSpec.hs new file mode 100644 --- /dev/null +++ b/test-nonet/Network/HTTP/Client/ConnectionSpec.hs @@ -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" diff --git a/test-nonet/Network/HTTP/Client/CookieSpec.hs b/test-nonet/Network/HTTP/Client/CookieSpec.hs --- a/test-nonet/Network/HTTP/Client/CookieSpec.hs +++ b/test-nonet/Network/HTTP/Client/CookieSpec.hs @@ -1,10 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.CookieSpec where +import Control.Monad (when) +import Data.Monoid import Data.Time.Clock import Network.HTTP.Client.Internal -import Network.HTTP.Types import Test.Hspec +import qualified Data.Time as DT +import qualified Web.Cookie as WC main :: IO () main = hspec spec @@ -15,7 +18,7 @@ now <- getCurrentTime let cookie1 = Cookie "test" "value" now "doMain.Org" "/" now now False False False False cookie2 = Cookie "test" "value" now "DOMAIn.ORg" "/" now now False False False False - cookie1 `shouldBe` cookie2 + cookie1 `shouldSatisfy` (equivCookie cookie2) it "domainMatches - case insensitive" $ do domainMatches "www.org" "www.org" `shouldBe` True @@ -25,3 +28,49 @@ it "domainMatches - case insensitive, partial" $ do domainMatches "www.org" "xxx.www.org" `shouldBe` False domainMatches "xxx.www.org" "WWW.ORG" `shouldBe` True + + describe "equalCookie vs. equivCookie" $ do + let make :: IO Cookie + make = do + now <- DT.getCurrentTime + req <- parseRequest "http://www.example.com/path" + let Just cky = generateCookie (WC.parseSetCookie raw) req now True + raw = "somename=somevalue.v=1.k=1.d=1590419679.t=u.l=s.u=8b2734ae-9dd1-11ea-bd7f-3bcf5b8d5d2a.r=795e71b5; " <> + "Path=/access; Domain=example.com; HttpOnly; Secure" + return cky + + modifications :: [(String, Cookie -> Cookie, Bool)] + modifications + = [ ("cookie_name", \cky -> cky { cookie_name = "othername" }, True) + , ("cookie_value", \cky -> cky { cookie_value = "othervalue" }, False) + , ("cookie_expiry_time", \cky -> cky { cookie_expiry_time = DT.addUTCTime 60 $ cookie_expiry_time cky }, False) + , ("cookie_domain", \cky -> cky { cookie_domain = cookie_domain cky <> ".com" }, True) + , ("cookie_path", \cky -> cky { cookie_path = cookie_path cky <> "/sub" }, True) + , ("cookie_creation_time", \cky -> cky { cookie_creation_time = DT.addUTCTime 60 $ cookie_creation_time cky }, False) + , ("cookie_last_access_time", \cky -> cky { cookie_last_access_time = DT.addUTCTime 60 $ cookie_last_access_time cky }, False) + , ("cookie_persistent", \cky -> cky { cookie_persistent = not $ cookie_persistent cky }, False) + , ("cookie_host_only", \cky -> cky { cookie_host_only = not $ cookie_host_only cky }, False) + , ("cookie_secure_only", \cky -> cky { cookie_secure_only = not $ cookie_secure_only cky }, False) + , ("cookie_http_only", \cky -> cky { cookie_http_only = not $ cookie_http_only cky }, False) + ] + + check :: (String, Cookie -> Cookie, Bool) -> Spec + check (msg, f, countsForEquiv) = it msg $ do + cky <- make + cky `equalCookie` f cky `shouldBe` False + when countsForEquiv $ cky `equivCookie` f cky `shouldBe` False + + check `mapM_` modifications + + it "isPotentiallyTrustworthyOrigin" $ do + isPotentiallyTrustworthyOrigin True "" `shouldBe` True + let untrusty = ["example", "example.", "example.com", "foolocalhost", "1.1.1.1", "::1", "[::2]"] + trusty = + [ "127.0.0.1", "127.0.0.2", "127.127.127.127" + , "[::1]", "[0:0:0:0:0:0:0:1]" + , "localhost", "localhost." + , "a.b.c.localhost", "a.b.c.localhost." + ] + or (map (isPotentiallyTrustworthyOrigin False) untrusty) `shouldBe` False + and (map (isPotentiallyTrustworthyOrigin False) trusty) `shouldBe` True + diff --git a/test-nonet/Network/HTTP/Client/HeadersSpec.hs b/test-nonet/Network/HTTP/Client/HeadersSpec.hs --- a/test-nonet/Network/HTTP/Client/HeadersSpec.hs +++ b/test-nonet/Network/HTTP/Client/HeadersSpec.hs @@ -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: \r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "Content-Type: text/html\r\n\r\n" + , "
" + ] + (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", "") + , ("Link", "") + ] + [("Content-Type", "text/html") + ] + + inp >>= (`shouldBe` ["
"]) + + readMVar callbackResults + >>= (`shouldBe` Seq.fromList [ + [("Link", "") + , ("Link", "") + ]]) + + it "103 early hints (multiple sections)" $ do + let input = + [ "HTTP/1.1 103 Early Hints\r\n" + , "Link: \r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 103 Early Hints\r\n" + , "Link: \r\n\r\n" + , "HTTP/1.1 200 OK\r\n" + , "Content-Type: text/html\r\n\r\n" + , "
" + ] + (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", "") + , ("Link", "") + , ("Link", "") + ] + [("Content-Type", "text/html") + ] + + inp >>= (`shouldBe` ["
"]) + + readMVar callbackResults + >>= (`shouldBe` Seq.fromList [ + [("Link", "") + , ("Link", "") + ] + , [("Link", "")] + ]) diff --git a/test-nonet/Network/HTTP/Client/RequestBodySpec.hs b/test-nonet/Network/HTTP/Client/RequestBodySpec.hs --- a/test-nonet/Network/HTTP/Client/RequestBodySpec.hs +++ b/test-nonet/Network/HTTP/Client/RequestBodySpec.hs @@ -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 diff --git a/test-nonet/Network/HTTP/Client/RequestSpec.hs b/test-nonet/Network/HTTP/Client/RequestSpec.hs --- a/test-nonet/Network/HTTP/Client/RequestSpec.hs +++ b/test-nonet/Network/HTTP/Client/RequestSpec.hs @@ -2,44 +2,84 @@ module Network.HTTP.Client.RequestSpec where import Blaze.ByteString.Builder (fromByteString) -import Control.Applicative ((<$>)) +import Control.Applicative as A ((<$>)) import Control.Monad (join, forM_, (<=<)) import Data.IORef import Data.Maybe (isJust, fromMaybe, fromJust) -import qualified Data.ByteString.Char8 as S8 -import Network.HTTP.Client (parseUrl, requestHeaders, applyBasicProxyAuth) import Network.HTTP.Client.Internal -import Network.URI (URI(..), URIAuth(..), parseURI) +import Network.URI (URI(..), URIAuth(..), parseURI) import Test.Hspec +import Data.Monoid ((<>)) +import Network.HTTP.Client (defaultRequest) +import Data.List (isInfixOf) spec :: Spec spec = do describe "case insensitive scheme" $ do - forM_ ["http://example.com", "httP://example.com", "HttP://example.com", "HttPs://example.com"] $ \url -> - 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 @@ -67,16 +107,16 @@ 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 "" <$> cont) `shouldBe` Nothing + (const ("" :: 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) [] -> ([], "") diff --git a/test-nonet/Network/HTTP/Client/ResponseSpec.hs b/test-nonet/Network/HTTP/Client/ResponseSpec.hs --- a/test-nonet/Network/HTTP/Client/ResponseSpec.hs +++ b/test-nonet/Network/HTTP/Client/ResponseSpec.hs @@ -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 diff --git a/test-nonet/Network/HTTP/ClientSpec.hs b/test-nonet/Network/HTTP/ClientSpec.hs --- a/test-nonet/Network/HTTP/ClientSpec.hs +++ b/test-nonet/Network/HTTP/ClientSpec.hs @@ -1,82 +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 qualified Control.Concurrent.Async as Async -import Control.Exception (bracket, catch, IOException) -import Control.Monad (forever, replicateM_, void) -import Network.HTTP.Client +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 - 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 + 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") - (sClose . snd) + (NS.close . snd) $ \(port, lsocket) -> withAsync (N.runTCPServer (N.serverSettingsTCPSocket lsocket) app) (const $ inner port) where app ad = do Async.race_ - (forever (N.appRead ad)) - (N.appWrite ad "HTTP/1.1 301 Redirect\r\nLocation: /\r\nConnection: close\r\n\r\nhello") - N.appCloseConnection ad + (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 @@ -100,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 @@ -119,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)) } @@ -128,77 +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." - it "withResponseHistory and redirect" $ redirectCloseServer $ \port -> do + notWindows $ it "withResponseHistory and redirect" $ redirectCloseServer $ \port -> do -- see https://github.com/snoyberg/http-client/issues/169 - req' <- parseUrl $ "http://127.0.0.1:" ++ show port + req' <- parseUrlThrow $ "http://127.0.0.1:" ++ show port let req = req' {redirectCount = 1} - withManager defaultManagerSettings $ \man -> do - withResponseHistory req man (const $ return ()) - `shouldThrow` \e -> + man <- newManager defaultManagerSettings + withResponseHistory req man (const $ return ()) + `shouldThrow` \e -> case e of - TooManyRedirects _ -> True - _ -> False + 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" diff --git a/test/Network/HTTP/ClientSpec.hs b/test/Network/HTTP/ClientSpec.hs --- a/test/Network/HTTP/ClientSpec.hs +++ b/test/Network/HTTP/ClientSpec.hs @@ -1,59 +1,156 @@ {-# LANGUAGE OverloadedStrings #-} module Network.HTTP.ClientSpec where -import Control.Exception (toException) -import Network (withSocketsDo) -import Network.HTTP.Client -import Network.HTTP.Types (found302, status200, status405) -import Test.Hspec -import Data.ByteString.Lazy.Char8 () +import Control.Concurrent (threadDelay) +import qualified Data.ByteString.Char8 as BS +import Network.HTTP.Client +import Network.HTTP.Client.Internal +import Network.HTTP.Types (status200, found302, status405) +import Network.HTTP.Types.Status +import qualified Network.Socket as NS +import Test.Hspec +import Control.Applicative ((<$>)) +import Data.ByteString.Lazy.Char8 () -- orphan instance +import System.Mem (performGC) main :: IO () main = hspec spec spec :: Spec spec = describe "Client" $ do - it "works" $ withSocketsDo $ do - req <- parseUrl "http://httpbin.org/" + it "works" $ do + req <- parseUrlThrow "http://httpbin.org/" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 + -- Test the failure condition described in https://github.com/snoyberg/http-client/issues/489 + it "keeps connection alive long enough" $ do + req <- parseUrlThrow "http://httpbin.org/" + man <- newManager defaultManagerSettings + res <- responseOpen req man + responseStatus res `shouldBe` status200 + let + getChunk = responseBody res + drainAll = do + chunk <- getChunk + if BS.null chunk then pure () else drainAll + + -- The returned `BodyReader` used to not contain a reference to the `Managed Connection`, + -- only to the extracted connection and to the release action. Therefore, triggering a GC + -- would close the connection even though we were not done reading. + performGC + -- Not ideal, but weak finalizers run on a separate thread, so it's racing with our drain + -- call + threadDelay 500000 + + drainAll + -- Calling `responseClose res` here prevents the early collection from happening in this + -- test, but in a larger production application that did involve a `responseClose`, it still + -- occurred. + describe "method in URL" $ do - it "success" $ withSocketsDo $ do - req <- parseUrl "POST http://httpbin.org/post" + it "success" $ do + req <- parseUrlThrow "POST http://httpbin.org/post" man <- newManager defaultManagerSettings res <- httpLbs req man responseStatus res `shouldBe` status200 - it "failure" $ withSocketsDo $ do - req' <- parseUrl "PUT http://httpbin.org/post" - let req = req' - { checkStatus = \_ _ _ -> Nothing - } + 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 "managerModifyRequest" $ do + 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 - it "can set port to 80" $ do - let modify req = return req { port = 80 } - settings = defaultManagerSettings { managerModifyRequest = modify } - withManager settings $ \man -> do + xit "allows to disable redirect following" $ do + req <- (\ r -> r{ redirectCount = 0 }) <$> + parseRequest "http://httpbin.org/redirect-to?url=http://httpbin.org" + man <- newManager defaultManagerSettings + res <- httpLbs req man + responseStatus res `shouldBe` found302 + + context "managerModifyResponse" $ do + it "allows to modify the response status code" $ do + let modify :: Response BodyReader -> IO (Response BodyReader) + modify res = do + return res { + responseStatus = (responseStatus res) { + statusCode = 201 + } + } + settings = defaultManagerSettings { managerModifyResponse = modify } + man <- newManager settings + res <- httpLbs "http://httpbin.org" man + (statusCode.responseStatus) res `shouldBe` 201 + + it "modifies the response body" $ do + let modify :: Response BodyReader -> IO (Response BodyReader) + modify res = do + reader <- constBodyReader [BS.pack "modified response body"] + return res { + responseBody = reader + } + settings = defaultManagerSettings { managerModifyResponse = modify } + man <- newManager settings + res <- httpLbs "http://httpbin.org" man + responseBody res `shouldBe` "modified response body" + + context "managerModifyRequest" $ do + it "port" $ do + let modify req = return req { port = 80 } + settings = defaultManagerSettings { managerModifyRequest = modify } + man <- newManager settings res <- httpLbs "http://httpbin.org:1234" man responseStatus res `shouldBe` status200 - it "can set 'checkStatus' to throw StatusCodeException" $ do - let modify req = return req { checkStatus = \s hs cj -> Just $ toException $ StatusCodeException s hs cj } - settings = defaultManagerSettings { managerModifyRequest = modify } - withManager settings $ \man -> + 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 - it "can set redirectCount to 0 to prevent following redirects" $ do - let modify req = return req { redirectCount = 0 } - settings = defaultManagerSettings { managerModifyRequest = modify } - man <- newManager settings - httpLbs "http://httpbin.org/redirect-to?url=foo" man `shouldThrow` ( \ (StatusCodeException s _ _) -> s == found302) - + 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 ()