avoid repeatedly parsing the proxy log
This commit is contained in:
		
					parent
					
						
							
								2fdec6b4e1
							
						
					
				
			
			
				commit
				
					
						dfe65b92c8
					
				
			
		
					 3 changed files with 27 additions and 29 deletions
				
			
		| 
						 | 
				
			
			@ -245,19 +245,18 @@ proxySpecialRemote protoversion r ihdl ohdl owaitv oclosedv = go
 | 
			
		|||
{- Check if this repository can proxy for a specified remote uuid,
 | 
			
		||||
 - and if so enable proxying for it. -}
 | 
			
		||||
checkCanProxy :: UUID -> UUID -> Annex Bool
 | 
			
		||||
checkCanProxy remoteuuid ouruuid = checkCanProxy' remoteuuid ouruuid >>= \case
 | 
			
		||||
checkCanProxy remoteuuid ouruuid = do
 | 
			
		||||
	ourproxies <- M.lookup ouruuid <$> getProxies
 | 
			
		||||
	checkCanProxy' ourproxies remoteuuid >>= \case
 | 
			
		||||
		Right v -> do
 | 
			
		||||
			Annex.changeState $ \st -> st { Annex.proxyremote = Just v }
 | 
			
		||||
			return True
 | 
			
		||||
		Left Nothing -> return False
 | 
			
		||||
		Left (Just err) -> giveup err
 | 
			
		||||
 | 
			
		||||
checkCanProxy' :: UUID -> UUID -> Annex (Either (Maybe String) (Either ClusterUUID Remote))
 | 
			
		||||
checkCanProxy' remoteuuid ouruuid = M.lookup ouruuid <$> getProxies >>= \case
 | 
			
		||||
	Nothing -> return (Left Nothing)
 | 
			
		||||
	-- This repository has (or had) proxying enabled. So it's
 | 
			
		||||
	-- ok to display error messages that talk about proxies.
 | 
			
		||||
	Just proxies ->
 | 
			
		||||
checkCanProxy' :: Maybe (S.Set Proxy) -> UUID -> Annex (Either (Maybe String) (Either ClusterUUID Remote))
 | 
			
		||||
checkCanProxy' Nothing _ = return (Left Nothing)
 | 
			
		||||
checkCanProxy' (Just proxies) remoteuuid =
 | 
			
		||||
	case filter (\p -> proxyRemoteUUID p == remoteuuid) (S.toList proxies) of
 | 
			
		||||
		[] -> notconfigured
 | 
			
		||||
		ps -> case mkClusterUUID remoteuuid of
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -30,6 +30,7 @@ import Types.Cluster
 | 
			
		|||
import CmdLine.Action (startConcurrency)
 | 
			
		||||
import Utility.ThreadScheduler
 | 
			
		||||
import Utility.HumanTime
 | 
			
		||||
import Logs.Proxy
 | 
			
		||||
import Annex.Proxy
 | 
			
		||||
import Annex.Cluster
 | 
			
		||||
import qualified P2P.Proxy as Proxy
 | 
			
		||||
| 
						 | 
				
			
			@ -188,12 +189,13 @@ withP2PConnections
 | 
			
		|||
withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do
 | 
			
		||||
	enableInteractiveBranchAccess
 | 
			
		||||
	myuuid <- getUUID
 | 
			
		||||
	myproxies <- M.lookup myuuid <$> getProxies
 | 
			
		||||
	reqv <- liftIO newEmptyTMVarIO
 | 
			
		||||
	relv <- liftIO newEmptyTMVarIO
 | 
			
		||||
	endv <- liftIO newEmptyTMVarIO
 | 
			
		||||
	proxypool <- liftIO $ newTMVarIO (0, mempty)
 | 
			
		||||
	asyncservicer <- liftIO $ async $
 | 
			
		||||
		servicer myuuid proxypool reqv relv endv
 | 
			
		||||
		servicer myuuid myproxies proxypool reqv relv endv
 | 
			
		||||
	let endit = do
 | 
			
		||||
		liftIO $ atomically $ putTMVar endv ()
 | 
			
		||||
		liftIO $ wait asyncservicer
 | 
			
		||||
| 
						 | 
				
			
			@ -204,7 +206,7 @@ withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do
 | 
			
		|||
		atomically $ putTMVar reqv (connparams, respvar)
 | 
			
		||||
		atomically $ takeTMVar respvar
 | 
			
		||||
 | 
			
		||||
	servicer myuuid proxypool reqv relv endv = do
 | 
			
		||||
	servicer myuuid myproxies proxypool reqv relv endv = do
 | 
			
		||||
		reqrel <- liftIO $
 | 
			
		||||
			atomically $ 
 | 
			
		||||
				(Right <$> takeTMVar reqv)
 | 
			
		||||
| 
						 | 
				
			
			@ -214,25 +216,25 @@ withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do
 | 
			
		|||
				(Left . Left <$> takeTMVar endv)
 | 
			
		||||
		case reqrel of
 | 
			
		||||
			Right (connparams, respvar) -> do
 | 
			
		||||
				servicereq myuuid proxypool relv connparams
 | 
			
		||||
				servicereq myuuid myproxies proxypool relv connparams
 | 
			
		||||
					>>= atomically . putTMVar respvar
 | 
			
		||||
				servicer myuuid proxypool reqv relv endv
 | 
			
		||||
				servicer myuuid myproxies proxypool reqv relv endv
 | 
			
		||||
			Left (Right releaseconn) -> do
 | 
			
		||||
				releaseconn
 | 
			
		||||
				servicer myuuid proxypool reqv relv endv
 | 
			
		||||
				servicer myuuid myproxies proxypool reqv relv endv
 | 
			
		||||
			Left (Left ()) -> return ()
 | 
			
		||||
	
 | 
			
		||||
	servicereq myuuid proxypool relv connparams
 | 
			
		||||
	servicereq myuuid myproxies proxypool relv connparams
 | 
			
		||||
		| connectionServerUUID connparams == myuuid =
 | 
			
		||||
			localConnection relv connparams workerpool
 | 
			
		||||
		| otherwise =
 | 
			
		||||
			atomically (getProxyConnectionPool proxypool connparams) >>= \case
 | 
			
		||||
				Just conn -> proxyConnection proxyconnectionpoolsize relv connparams workerpool proxypool conn
 | 
			
		||||
				Nothing -> checkcanproxy myuuid proxypool relv connparams
 | 
			
		||||
				Nothing -> checkcanproxy myproxies proxypool relv connparams
 | 
			
		||||
 | 
			
		||||
	checkcanproxy myuuid proxypool relv connparams = 
 | 
			
		||||
	checkcanproxy myproxies proxypool relv connparams = 
 | 
			
		||||
		inAnnexWorker' workerpool
 | 
			
		||||
			(checkCanProxy' (connectionServerUUID connparams) myuuid)
 | 
			
		||||
			(checkCanProxy' myproxies (connectionServerUUID connparams))
 | 
			
		||||
		>>= \case
 | 
			
		||||
			Right (Left reason) -> return $ Left $
 | 
			
		||||
				ConnectionFailed $ 
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
| 
						 | 
				
			
			@ -28,9 +28,6 @@ Planned schedule of work:
 | 
			
		|||
 | 
			
		||||
## work notes
 | 
			
		||||
 | 
			
		||||
* getProxies reads the proxy log every time, which is unncessarily slow.
 | 
			
		||||
  memoize
 | 
			
		||||
 | 
			
		||||
* An interrupted PUT to cluster that has a node that is a special remote
 | 
			
		||||
  over http leaves open the connection to the cluster, so the next request
 | 
			
		||||
  opens another one.
 | 
			
		||||
| 
						 | 
				
			
			
 | 
			
		|||
		Loading…
	
	Add table
		Add a link
		
	
		Reference in a new issue