diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/Data/KeyedPool.hs b/Data/KeyedPool.hs new file mode 100644 --- /dev/null +++ b/Data/KeyedPool.hs @@ -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 () 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 @@ -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' 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 @@ -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. -- 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 @@ -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 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 @@ -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", "") +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. 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.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: . 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 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 @@ -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" 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,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