diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index aebb2d0d45..31864876c1 100644 --- a/P2P/Http/State.hs +++ b/P2P/Http/State.hs @@ -28,6 +28,7 @@ import CmdLine.Action (startConcurrency) import Utility.ThreadScheduler import Utility.HumanTime import Annex.Proxy +import qualified P2P.Proxy as Proxy import Types.Cluster import Servant @@ -213,8 +214,8 @@ withP2PConnections workerpool a = do | connectionServerUUID connparams == myuuid = localConnection relv connparams workerpool | otherwise = - atomically (getProxyConnection proxypool connparams) >>= \case - Just conn -> proxyConnection relv connparams proxypool conn + atomically (getProxyConnectionFromPool proxypool connparams) >>= \case + Just conn -> proxyConnection relv connparams workerpool conn Nothing -> checkcanproxy myuuid proxypool relv connparams checkcanproxy myuuid proxypool relv connparams = @@ -226,32 +227,45 @@ withP2PConnections workerpool a = do fromMaybe "unknown uuid" reason Right (Right (Right proxyremote)) -> do openProxyConnectionToRemote proxyremote - >>= proxyConnection relv connparams proxypool + >>= proxyConnection relv connparams workerpool Right (Right (Left cluster)) -> do openProxyConnectionToCluster cluster - >>= proxyConnection relv connparams proxypool + >>= proxyConnection relv connparams workerpool Left ex -> return $ Left $ ConnectionFailed $ show ex + +proxyConnection + :: TMVar (IO ()) + -> ConnectionParams + -> AnnexWorkerPool + -> ProxyConnection + -> IO (Either ConnectionProblem P2PConnectionPair) +proxyConnection relv connparams workerpool proxyconn = + -- XXX fixme mkP2PConnectionPair is not quite right for this + mkP2PConnectionPair connparams relv $ \serverrunst serverconn -> + inAnnexWorker' workerpool $ do + let proxyparams = undefined -- XXX + let remoteside = undefined -- XXX + let requestmessage = undefined -- XXX + let proxydone = return () + let requestcomplete = \() -> return () + let protoerrhandler = \a -> \case + Left err -> giveup err + Right v -> return v + Proxy.proxyRequest proxydone proxyparams requestcomplete requestmessage protoerrhandler + localConnection :: TMVar (IO ()) -> ConnectionParams -> AnnexWorkerPool -> IO (Either ConnectionProblem P2PConnectionPair) -localConnection relv connparams workerpool = mkP2PConnectionPair connparams relv $ - \serverrunst serverconn -> inAnnexWorker' workerpool $ - void $ runFullProto serverrunst serverconn $ - P2P.serveOneCommandAuthed - (connectionServerMode connparams) - (connectionServerUUID connparams) - -proxyConnection - :: TMVar (IO ()) - -> ConnectionParams - -> TMVar (M.Map UUID [ProxyConnection]) - -> ProxyConnection - -> IO (Either ConnectionProblem P2PConnectionPair) -proxyConnection relv connparams proxypool conn = error "XXX" -- TODO - +localConnection relv connparams workerpool = + mkP2PConnectionPair connparams relv $ \serverrunst serverconn -> + inAnnexWorker' workerpool $ + void $ runFullProto serverrunst serverconn $ + P2P.serveOneCommandAuthed + (connectionServerMode connparams) + (connectionServerUUID connparams) data P2PConnectionPair = P2PConnectionPair { clientRunState :: RunState @@ -427,25 +441,34 @@ inAnnexWorker' poolv annexaction = do return res data ProxyConnection = ProxyConnection + { proxyP2PConnectionPair :: P2PConnectionPair + } -getProxyConnection - :: TMVar (M.Map UUID [ProxyConnection]) +type ProxyConnectionPool = + M.Map (UUID, UUID, P2P.ProtocolVersion) [ProxyConnection] + +getProxyConnectionFromPool + :: TMVar ProxyConnectionPool -> ConnectionParams -> STM (Maybe ProxyConnection) -getProxyConnection proxypool connparams = do +getProxyConnectionFromPool proxypool connparams = do m <- takeTMVar proxypool - case M.lookup (connectionServerUUID connparams) m of + case M.lookup k m of Nothing -> do putTMVar proxypool m return Nothing Just [] -> do - putTMVar proxypool $ - M.insert (connectionServerUUID connparams) [] m + putTMVar proxypool $ M.insert k [] m return Nothing Just (c:cs) -> do - putTMVar proxypool $ - M.insert (connectionServerUUID connparams) cs m + putTMVar proxypool $ M.insert k cs m return (Just c) + where + k = + ( connectionServerUUID connparams + , connectionClientUUID connparams + , connectionProtocolVersion connparams + ) openProxyConnectionToRemote :: Remote -> IO ProxyConnection openProxyConnectionToRemote remote = error "XXX" -- TODO diff --git a/doc/todo/git-annex_proxies.mdwn b/doc/todo/git-annex_proxies.mdwn index d739ade896..28d090073a 100644 --- a/doc/todo/git-annex_proxies.mdwn +++ b/doc/todo/git-annex_proxies.mdwn @@ -30,6 +30,8 @@ Planned schedule of work: * Make http server support proxies and clusters. + Current status: laying the keystone + * Support proxying to git remotes using annex+http urls. (Current documentation says proxying only works with ssh remotes, so current state is not confusing, but this still needs to be done