http-client 0.5.7.1 → 0.5.8
raw patch · 10 files changed
+453/−272 lines, 10 filesdep +stmdep ~basedep ~containersdep ~streaming-commons
Dependencies added: stm
Dependency ranges changed: base, containers, streaming-commons
Files
- ChangeLog.md +6/−0
- Data/KeyedPool.hs +320/−0
- Network/HTTP/Client/Core.hs +9/−8
- Network/HTTP/Client/Internal.hs +2/−0
- Network/HTTP/Client/Manager.hs +72/−228
- Network/HTTP/Client/Response.hs +6/−5
- Network/HTTP/Client/Types.hs +26/−28
- http-client.cabal +4/−2
- test-nonet/Network/HTTP/Client/RequestSpec.hs +7/−0
- test-nonet/Network/HTTP/Client/ResponseSpec.hs +1/−1
ChangeLog.md view
@@ -1,3 +1,9 @@+## 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
+ Data/KeyedPool.hs view
@@ -0,0 +1,320 @@+{-# 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+ , 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)+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 ()
Network/HTTP/Client/Core.hs view
@@ -28,6 +28,7 @@ import Data.Monoid import Control.Monad (void) import System.Timeout (timeout)+import Data.KeyedPool -- | Perform a @Request@ using a connection acquired from the given @Manager@, -- and then provide the @Response@ to the given function. This function is@@ -90,7 +91,7 @@ now <- getCurrentTime return $ insertCookiesIntoRequest req' (evictExpiredCookies cj now) now Nothing -> return (req', Data.Monoid.mempty)- (timeout', (connRelease, ci, isManaged)) <- getConnectionWrapper+ (timeout', mconn) <- getConnectionWrapper (responseTimeout' req) (getConn req m) @@ -99,20 +100,20 @@ -- connections after accepting the request headers, so we need to check for -- exceptions in both. ex <- try $ do- cont <- requestBuilder (dropProxyAuthSecure req) ci+ cont <- requestBuilder (dropProxyAuthSecure req) (managedResource mconn) - getResponse connRelease timeout' req ci cont+ getResponse timeout' req mconn cont - case (ex, isManaged) of+ case ex of -- Connection was reused, and might have been closed. Try again- (Left e, Reused) | mRetryableException m e -> do- connRelease DontReuse+ Left e | managedReused mconn && mRetryableException m e -> do+ managedRelease mconn DontReuse httpRaw' req m -- Not reused, or a non-retry, so this is a real exception- (Left e, _) -> throwIO e+ 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+ Right res -> case cookieJar req' of Just _ -> do now' <- getCurrentTime let (cookie_jar, _) = updateCookieJar res req now' cookie_jar'
Network/HTTP/Client/Internal.hs view
@@ -25,6 +25,7 @@ , module Network.HTTP.Client.Types -- * Various utilities , module Network.HTTP.Client.Util+ , dummyManaged ) where import Network.HTTP.Client.Body@@ -37,3 +38,4 @@ import Network.HTTP.Client.Response import Network.HTTP.Client.Types import Network.HTTP.Client.Util+import Data.KeyedPool (dummyManaged)
Network/HTTP/Client/Manager.hs view
@@ -22,28 +22,22 @@ , dropProxyAuthSecure ) where -import qualified Data.IORef as I-import qualified Data.Map as Map- import qualified Data.ByteString.Char8 as S8 import Data.Text (Text)-import qualified Data.Text as T -import Control.Monad (unless, join, void)-import Control.Exception (mask_, catch, throwIO, fromException, mask, IOException, Exception (..), handle)-import Control.Concurrent (forkIO, threadDelay)-import Data.Time (UTCTime (..), getCurrentTime, addUTCTime)+import Control.Monad (unless)+import Control.Exception (throwIO, fromException, IOException, Exception (..), handle) import qualified Network.Socket as NS -import System.Mem.Weak (Weak, deRefWeak) import Network.HTTP.Types (status200) import Network.HTTP.Client.Types import Network.HTTP.Client.Connection import Network.HTTP.Client.Headers (parseStatusHeaders) import Network.HTTP.Proxy-import Control.Concurrent.MVar (MVar, takeMVar, tryPutMVar, newEmptyMVar)+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@@ -102,50 +96,6 @@ , managerProxySecure = defaultProxy } -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. --@@ -159,28 +109,24 @@ newManager :: ManagerSettings -> IO Manager newManager ms = do NS.withSocketsDo $ return ()- rawConnection <- managerRawConnection ms- tlsConnection <- managerTlsConnection ms- tlsProxyConnection <- managerTlsProxyConnection ms- mapRef <- I.newIORef $! ManagerOpen 0 Map.empty- baton <- newEmptyMVar- wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef httpProxy <- runProxyOverride (managerProxyInsecure ms) False httpsProxy <- runProxyOverride (managerProxySecure ms) True - _ <- forkIO $ reap baton wmapRef+ createConnection <- mkCreateConnection ms++ keyedPool <- createKeyedPool+ createConnection+ connectionClose+ (managerConnCount ms)+ (managerIdleConnectionCount ms)+ (const (return ())) -- could allow something in ManagerSettings to handle exceptions more nicely+ let manager = Manager- { mConns = mapRef- , mConnsBaton = baton- , mMaxConns = managerConnCount ms+ { mConns = keyedPool , mResponseTimeout = managerResponseTimeout ms- , mRawConnection = rawConnection- , mTlsConnection = tlsConnection- , mTlsProxyConnection = tlsProxyConnection , mRetryableException = managerRetryableException ms , mWrapException = managerWrapException ms- , mIdleConnectionCount = managerIdleConnectionCount ms , mModifyRequest = managerModifyRequest ms , mModifyResponse = managerModifyResponse ms , mSetProxy = \req ->@@ -190,49 +136,6 @@ } 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@@ -267,23 +170,6 @@ seqDT = seq -} -neToList :: NonEmptyList a -> [(UTCTime, a)]-neToList (One a t) = [(t, a)]-neToList (Cons a _ t nelist) = (t, a) : neToList nelist--neFromList :: [(UTCTime, a)] -> Maybe (NonEmptyList a)-neFromList [] = Nothing-neFromList [(t, a)] = Just (One a t)-neFromList xs =- Just . snd . go $ xs- where- go [] = error "neFromList.go []"- go [(t, a)] = (2, One a t)- go ((t, a):rest) =- let (i, rest') = go rest- i' = i + 1- in i' `seq` (i', Cons a i t rest')- -- | Close all connections in a 'Manager'. -- -- Note that this doesn't affect currently in-flight connections,@@ -295,14 +181,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@@ -310,64 +188,6 @@ withManager settings f = newManager settings >>= f {-# DEPRECATED withManager "Use newManager instead" #-} -safeConnClose :: Connection -> IO ()-safeConnClose ci = connectionClose ci `Control.Exception.catch` \(_ :: IOException) -> return ()--nonEmptyMapM_ :: Monad m => (a -> m ()) -> NonEmptyList a -> m ()-nonEmptyMapM_ f (One x _) = f x-nonEmptyMapM_ f (Cons x _ _ l) = f x >> nonEmptyMapM_ f l---- | This function needs to acquire a @ConnInfo@- either from the @Manager@ or--- via I\/O, and register it with the @ResourceT@ so it is guaranteed to be--- either released or returned to the manager.-getManagedConn- :: Manager- -> ConnKey- -> IO Connection- -> IO (ConnRelease, Connection, ManagedConn)--- We want to avoid any holes caused by async exceptions, so let's mask.-getManagedConn man key open = mask $ \restore -> do- -- Try to take the socket out of the manager.- mci <- takeSocket man key- (ci, isManaged) <-- case mci of- -- There wasn't a matching connection in the manager, so create a- -- new one.- Nothing -> do- ci <- restore open- return (ci, Fresh)- -- Return the existing one- Just ci -> return (ci, Reused)-- -- When we release this connection, we can either reuse it (put it back in- -- the manager) or not reuse it (close the socket). We set up a mutable- -- reference to track what we want to do. By default, we say not to reuse- -- it, that way if an exception is thrown, the connection won't be reused.- toReuseRef <- I.newIORef DontReuse- wasReleasedRef <- I.newIORef False-- -- When the connection is explicitly released, we update our toReuseRef to- -- indicate what action should be taken, and then call release.- let connRelease r = do- I.writeIORef toReuseRef r- releaseHelper-- releaseHelper = mask $ \restore' -> do- wasReleased <- I.atomicModifyIORef wasReleasedRef $ \x -> (True, x)- unless wasReleased $ do- toReuse <- I.readIORef toReuseRef- restore' $ case toReuse of- Reuse -> putSocket man key ci- DontReuse -> connectionClose ci-- return (connRelease, ci, isManaged)--getConnDest :: Request -> (Bool, String, Int)-getConnDest req =- case proxy req of- Just p -> (True, S8.unpack (proxyHost p), proxyPort p)- Nothing -> (False, S8.unpack $ host req, port req)- -- | Drop the Proxy-Authorization header from the request if we're using a -- secure proxy. dropProxyAuthSecure :: Request -> Request@@ -378,52 +198,76 @@ } | otherwise = req where- (useProxy', _, _) = getConnDest req+ useProxy' = isJust (proxy req) getConn :: Request -> Manager- -> IO (ConnRelease, Connection, ManagedConn)+ -> IO (Managed Connection) getConn req m -- Stop Mac OS X from getting high: -- https://github.com/snoyberg/http-client/issues/40#issuecomment-39117909 | S8.null h = throwHttp $ InvalidDestinationHost h- | otherwise =- getManagedConn m (ConnKey connKeyHost connport (host req) (port req) (secure req)) $- wrapConnectExc $ go connaddr connhost connport+ | otherwise = takeKeyedPool (mConns m) connkey where h = host req- (useProxy', connhost, connport) = getConnDest req- (connaddr, connKeyHost) =- case (hostAddress req, useProxy') of- (Just ha, False) -> (Just ha, HostAddress ha)- _ -> (Nothing, HostName $ T.pack connhost)+ connkey = connKey req +connKey :: Request -> ConnKey+connKey req =+ case proxy req of+ Nothing+ | secure req -> simple CKSecure+ | otherwise -> simple CKRaw+ Just p -> CKProxy+ (proxyHost p)+ (proxyPort p)+ (lookup "Proxy-Authorization" (requestHeaders req))+ (host req)+ (port req)+ where+ simple con = con (hostAddress req) (host req) (port req)++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+ StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing+ unless (status == status200) $+ throwHttp $ ProxyConnectException ultHost ultPort status+ in tlsProxyConnection+ connstr+ parse+ (S8.unpack ultHost)+ Nothing -- we never have a HostAddress we can use+ (S8.unpack connhost)+ connport+ where wrapConnectExc = handle $ \e -> throwHttp $ ConnectionFailure (toException (e :: IOException))- go =- case (secure req, useProxy') of- (False, _) -> mRawConnection m- (True, False) -> mTlsConnection m- (True, True) ->- let ultHost = host req- ultPort = port req- proxyAuthorizationHeader = maybe "" (\h' -> S8.concat ["Proxy-Authorization: ", h', "\r\n"]) . lookup "Proxy-Authorization" $ requestHeaders req- hostHeader = S8.concat ["Host: ", ultHost, ":", (S8.pack $ show ultPort), "\r\n"]- connstr = S8.concat- [ "CONNECT "- , ultHost- , ":"- , S8.pack $ show ultPort- , " HTTP/1.1\r\n"- , proxyAuthorizationHeader- , hostHeader- , "\r\n"- ]- parse conn = do- StatusHeaders status _ _ <- parseStatusHeaders conn Nothing Nothing- unless (status == status200) $- throwHttp $ ProxyConnectException ultHost ultPort status- in mTlsProxyConnection m connstr parse (S8.unpack ultHost) -- | Get the proxy settings from the @Request@ itself. --
Network/HTTP/Client/Response.hs view
@@ -23,6 +23,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@@ -78,20 +79,20 @@ { responseBody = L.fromChunks bss } -getResponse :: ConnRelease- -> Maybe Int+getResponse :: 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+getResponse timeout' req@(Request {..}) mconn cont = do+ let conn = managedResource mconn StatusHeaders s version hs <- parseStatusHeaders conn timeout' cont let mcl = lookup "content-length" hs >>= readDec . S8.unpack isChunked = ("transfer-encoding", "chunked") `elem` 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 = managedRelease mconn $ if toPut && bodyConsumed then Reuse else DontReuse body <- -- RFC 2616 section 4.4_1 defines responses that must not include a body
Network/HTTP/Client/Types.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE RankNTypes #-}+{-# LANGUAGE OverloadedStrings #-} module Network.HTTP.Client.Types ( BodyReader , Connection (..)@@ -20,9 +21,6 @@ , NeedsPopper , GivesPopper , Request (..)- , ConnReuse (..)- , ConnRelease- , ManagedConn (..) , Response (..) , ResponseClose (..) , Manager (..)@@ -54,12 +52,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 Data.Text (Text) import Data.Streaming.Zlib (ZlibException)-import Control.Concurrent.MVar (MVar) import Data.CaseInsensitive as CI+import Data.KeyedPool (KeyedPool)+import Control.Applicative((<$>)) -- | An @IO@ action that represents an incoming response body coming from the -- server. Data provided by this action has already been gunzipped and@@ -558,7 +556,7 @@ , " host = " ++ show (host x) , " port = " ++ show (port x) , " secure = " ++ show (secure x)- , " requestHeaders = " ++ show (requestHeaders x)+ , " requestHeaders = " ++ show (DL.map redactSensitiveHeader (requestHeaders x)) , " path = " ++ show (path x) , " queryString = " ++ show (queryString x) --, " requestBody = " ++ show (requestBody x)@@ -571,12 +569,9 @@ , "}" ] -data ConnReuse = Reuse | DontReuse- deriving T.Typeable--type ConnRelease = ConnReuse -> IO ()--data ManagedConn = Fresh | Reused+redactSensitiveHeader :: Header -> Header+redactSensitiveHeader ("Authorization", value) = ("Authorization", "<REDACTED>")+redactSensitiveHeader h = h -- | A simple representation of the HTTP response. --@@ -667,7 +662,9 @@ -- -- This limit helps deal with the case where you are making a large number -- of connections to different hosts. Without this limit, you could run out- -- of file descriptors.+ -- of file descriptors. Additionally, it can be set to zero to prevent+ -- reuse of any connections. Doing this is useful when the server your application+ -- is talking to sits behind a load balancer. -- -- Default: 512 --@@ -713,24 +710,11 @@ -- -- Since 0.1.0 data Manager = Manager- { mConns :: I.IORef ConnsMap- -- ^ @Nothing@ indicates that the manager is closed.- , mConnsBaton :: MVar ()- -- ^ Used to indicate to the reaper thread that it has some work to do.- -- This must be filled every time a connection is returned to the manager.- -- While redundant with the @IORef@ above, this allows us to have the- -- reaper thread fully blocked instead of running every 5 seconds when- -- there are no connections to manage.- , mMaxConns :: Int- -- ^ This is a per-@ConnKey@ value.+ { mConns :: KeyedPool ConnKey Connection , mResponseTimeout :: ResponseTimeout -- ^ Copied from 'managerResponseTimeout'- , mRawConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection- , mTlsConnection :: Maybe NS.HostAddress -> String -> Int -> IO Connection- , mTlsProxyConnection :: S.ByteString -> (Connection -> IO ()) -> String -> Maybe NS.HostAddress -> String -> Int -> IO Connection , mRetryableException :: SomeException -> Bool , mWrapException :: forall a. Request -> IO a -> IO a- , mIdleConnectionCount :: Int , mModifyRequest :: Request -> IO Request , mSetProxy :: Request -> Request , mModifyResponse :: Response BodyReader -> IO (Response BodyReader)@@ -760,7 +744,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.
http-client.cabal view
@@ -1,5 +1,5 @@ name: http-client-version: 0.5.7.1+version: 0.5.8 synopsis: An HTTP client engine description: Hackage documentation generation is not reliable. For up to date documentation, please see: <http://www.stackage.org/package/http-client>. homepage: https://github.com/snoyberg/http-client@@ -36,6 +36,7 @@ Network.PublicSuffixList.Types Network.PublicSuffixList.Serialize Network.PublicSuffixList.DataStructure+ Data.KeyedPool build-depends: base >= 4.5 && < 5 , bytestring >= 0.10 , text >= 0.11@@ -43,7 +44,7 @@ , blaze-builder >= 0.3 , time >= 1.2 , network >= 2.4- , streaming-commons >= 0.1.0.2 && < 0.2+ , streaming-commons >= 0.1.0.2 && < 0.3 , containers , transformers , deepseq >= 1.3 && <1.5@@ -56,6 +57,7 @@ , filepath , mime-types , ghc-prim+ , stm if flag(network-uri) build-depends: network >= 2.6, network-uri >= 2.6 else
test-nonet/Network/HTTP/Client/RequestSpec.hs view
@@ -10,6 +10,8 @@ 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@@ -36,6 +38,11 @@ (uriRegName $ fromJust $ uriAuthority $ getUri $ fromJust request) `shouldBe` requestHostnameWithoutAuth field `shouldSatisfy` isJust field `shouldBe` Just "Basic dXNlcjpwYXNz"++ describe "Show Request" $+ it "redacts authorization header content" $ do+ let request = defaultRequest { requestHeaders = [("Authorization", "secret")] }+ isInfixOf "secret" (show request) `shouldBe` False describe "applyBasicProxyAuth" $ do let request = applyBasicProxyAuth "user" "pass" <$> parseUrlThrow "http://example.org"
test-nonet/Network/HTTP/Client/ResponseSpec.hs view
@@ -16,7 +16,7 @@ spec :: Spec spec = describe "ResponseSpec" $ do- let getResponse' conn = getResponse (const $ return ()) Nothing req conn Nothing+ let getResponse' conn = getResponse Nothing req (dummyManaged conn) Nothing req = parseRequest_ "http://localhost" it "basic" $ do (conn, _, _) <- dummyConnection