diff --git a/Network/HTTP/Client.hs b/Network/HTTP/Client.hs --- a/Network/HTTP/Client.hs +++ b/Network/HTTP/Client.hs @@ -23,6 +23,17 @@ -- 'withManager' 'defaultManagerSettings' -- @ -- +-- While generally speaking it is a good idea to share a single @Manager@ +-- throughout your application, there are cases where it makes more sense to +-- create and destroy @Manager@s more frequently. As an example, if you have an +-- 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 +-- each new request, to avoid running out of file descriptors. (Note that the +-- 'managerIdleConnectionCount' setting mitigates the risk of leaking too many +-- file descriptors.) +-- -- The next core component is a @Request@, which represents a single HTTP -- request to be sent to a specific server. @Request@s allow for many settings -- to control exact how they function, but usually the simplest approach for @@ -73,6 +84,7 @@ , managerResponseTimeout , managerRetryableException , managerWrapIOException + , managerIdleConnectionCount -- * Request , parseUrl , applyBasicAuth 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 @@ -31,7 +31,7 @@ import qualified Data.Text as T import Control.Monad.IO.Class (MonadIO, liftIO) -import Control.Monad (unless) +import Control.Monad (unless, join) 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) @@ -76,32 +76,42 @@ Just e -> toException $ InternalIOException e Nothing -> se in handle $ throwIO . wrapper + , managerIdleConnectionCount = 512 } takeSocket :: Manager -> ConnKey -> IO (Maybe Connection) takeSocket man key = I.atomicModifyIORef (mConns man) go where - go Nothing = (Nothing, Nothing) - go (Just m) = + go ManagerClosed = (ManagerClosed, Nothing) + go mcOrig@(ManagerOpen idleCount m) = case Map.lookup key m of - Nothing -> (Just m, Nothing) - Just (One a _) -> (Just $ Map.delete key m, Just a) - Just (Cons a _ _ rest) -> (Just $ Map.insert key rest m, Just a) + 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 - msock <- I.atomicModifyIORef (mConns man) (go now) - maybe (return ()) connectionClose msock + join $ I.atomicModifyIORef (mConns man) (go now) where - go _ Nothing = (Nothing, Just ci) - go now (Just m) = - case Map.lookup key m of - Nothing -> (Just $ Map.insert key (One ci now) m, Nothing) + 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 - in (Just $ Map.insert key l' m, mx) + cnt' = idleCount + maybe 0 (const 1) mx + m' = ManagerOpen cnt' (Map.insert key l' m) + in m' `seq` (m', maybe (return ()) connectionClose mx) -- | Add a new element to the list, up to the given maximum number. If we're -- already at the maximum, return the new value as leftover. @@ -128,7 +138,7 @@ rawConnection <- managerRawConnection ms tlsConnection <- managerTlsConnection ms tlsProxyConnection <- managerTlsProxyConnection ms - mapRef <- I.newIORef (Just Map.empty) + mapRef <- I.newIORef $! ManagerOpen 0 Map.empty wmapRef <- I.mkWeakIORef mapRef $ closeManager' mapRef _ <- forkIO $ reap wmapRef let manager = Manager @@ -140,12 +150,12 @@ , mTlsProxyConnection = tlsProxyConnection , mRetryableException = managerRetryableException ms , mWrapIOException = managerWrapIOException ms + , mIdleConnectionCount = managerIdleConnectionCount ms } return manager -- | Collect and destroy any stale connections. -reap :: Weak (I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection)))) - -> IO () +reap :: Weak (I.IORef ConnsMap) -> IO () reap wmapRef = mask_ loop where @@ -159,16 +169,13 @@ goMapRef mapRef = do now <- getCurrentTime let isNotStale time = 30 `addUTCTime` time >= now - mtoDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale) - case mtoDestroy of - Nothing -> return () -- manager is closed - Just toDestroy -> do - mapM_ safeConnClose toDestroy - loop - findStaleWrap _ Nothing = (Nothing, Nothing) - findStaleWrap isNotStale (Just m) = + toDestroy <- I.atomicModifyIORef mapRef (findStaleWrap isNotStale) + mapM_ safeConnClose toDestroy + loop + findStaleWrap _ ManagerClosed = (ManagerClosed, []) + findStaleWrap isNotStale (ManagerOpen idleCount m) = let (x, y) = findStale isNotStale m - in (Just x, Just y) + in (ManagerOpen (idleCount - length y) x, y) findStale isNotStale = findStale' id id . Map.toList where @@ -244,11 +251,13 @@ closeManager :: Manager -> IO () closeManager = closeManager' . mConns -closeManager' :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))) +closeManager' :: I.IORef ConnsMap -> IO () closeManager' connsRef = mask_ $ do - m <- I.atomicModifyIORef connsRef $ \x -> (Nothing, x) - mapM_ (nonEmptyMapM_ safeConnClose) $ maybe [] Map.elems m + !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'. -- 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 @@ -22,6 +22,7 @@ , Response (..) , ResponseClose (..) , Manager (..) + , ConnsMap (..) , ManagerSettings (..) , NonEmptyList (..) , ConnHost (..) @@ -365,7 +366,7 @@ , responseTimeout :: Maybe Int -- ^ Number of microseconds to wait for a response. If -- @Nothing@, will wait indefinitely. Default: use - -- 'managerResponseTimeout' (which by default is 5 seconds). + -- 'managerResponseTimeout' (which by default is 30 seconds). -- -- Since 0.1.0 , getConnectionWrapper :: Maybe Int @@ -466,7 +467,7 @@ -- ^ Default timeout (in microseconds) to be applied to requests which do -- not provide a timeout value. -- - -- Default is 5 seconds + -- Default is 30 seconds -- -- Since 0.1.0 , managerRetryableException :: SomeException -> Bool @@ -483,6 +484,16 @@ -- Default: wrap all @IOException@s in the @InternalIOException@ constructor. -- -- Since 0.1.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. + -- + -- Default: 512 + -- + -- Since 0.3.7 } deriving T.Typeable @@ -492,7 +503,7 @@ -- -- Since 0.1.0 data Manager = Manager - { mConns :: I.IORef (Maybe (Map.Map ConnKey (NonEmptyList Connection))) + { mConns :: I.IORef ConnsMap -- ^ @Nothing@ indicates that the manager is closed. , mMaxConns :: Int -- ^ This is a per-@ConnKey@ value. @@ -503,8 +514,13 @@ , 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 } deriving T.Typeable + +data ConnsMap + = ManagerClosed + | ManagerOpen {-# UNPACK #-} !Int !(Map.Map ConnKey (NonEmptyList Connection)) data NonEmptyList a = One a UTCTime | diff --git a/http-client.cabal b/http-client.cabal --- a/http-client.cabal +++ b/http-client.cabal @@ -1,5 +1,5 @@ name: http-client -version: 0.3.6.1 +version: 0.3.7.1 synopsis: An HTTP client engine, intended as a base layer for more user-friendly packages. description: This codebase has been refactored from http-conduit. homepage: https://github.com/snoyberg/http-client @@ -12,6 +12,10 @@ extra-source-files: README.md cabal-version: >=1.10 +flag network-uri + description: Get Network.URI from the network-uri package + default: True + library exposed-modules: Network.HTTP.Client Network.HTTP.Client.MultipartFormData @@ -47,6 +51,10 @@ , random , filepath , mime-types + if flag(network-uri) + build-depends: network >= 2.6, network-uri >= 2.6 + else + build-depends: network < 2.6 default-language: Haskell2010 test-suite spec