http p2p proxy is now largely working

This commit is contained in:
Joey Hess 2024-07-26 10:24:23 -04:00
parent b391756b32
commit cc1da2d516
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
6 changed files with 180 additions and 87 deletions

View file

@ -116,11 +116,14 @@ serveGet st su apiver (B64Key k) cu bypass baf startat sec auth = do
validityv <- liftIO newEmptyTMVarIO
finalv <- liftIO newEmptyTMVarIO
annexworker <- liftIO $ async $ inAnnexWorker st $ do
let storer _offset len = sendContentWith $ \bs -> do
liftIO $ atomically $ putTMVar bsv (len, bs)
liftIO $ atomically $ takeTMVar endv
liftIO $ signalFullyConsumedByteString $
connOhdl $ serverP2PConnection conn
let storer _offset len = sendContentWith $ \bs -> liftIO $ do
atomically $ putTMVar bsv (len, bs)
atomically $ takeTMVar endv
case serverP2PConnection conn of
Just c ->
signalFullyConsumedByteString $
connOhdl c
Nothing -> noop
return $ \v -> do
liftIO $ atomically $ putTMVar validityv v
return True

View file

@ -24,15 +24,17 @@ import Annex.UUID
import Types.NumCopies
import Types.WorkerPool
import Annex.WorkerPool
import Types.Cluster
import CmdLine.Action (startConcurrency)
import Utility.ThreadScheduler
import Utility.HumanTime
import Annex.Proxy
import qualified P2P.Proxy as Proxy
import Types.Cluster
import qualified Types.Remote as Remote
import Servant
import qualified Data.Map as M
import qualified Data.Set as S
import Control.Concurrent.Async
import Control.Concurrent.STM
@ -225,52 +227,28 @@ withP2PConnections workerpool a = do
Right (Left reason) -> return $ Left $
ConnectionFailed $
fromMaybe "unknown uuid" reason
Right (Right (Right proxyremote)) -> do
openProxyConnectionToRemote proxyremote
>>= proxyConnection relv connparams workerpool
Right (Right (Left cluster)) -> do
openProxyConnectionToCluster cluster
>>= proxyConnection relv connparams workerpool
Right (Right (Right proxyremote)) ->
openProxyConnectionToRemote workerpool
(connectionProtocolVersion connparams)
(connectionBypass connparams)
proxyremote
>>= \case
Right conn -> proxyConnection relv connparams workerpool conn
Left ex -> return $ Left $
ConnectionFailed $ show ex
Right (Right (Left clusteruuid)) ->
undefined -- XXX todo
{-
openProxyConnectionToCluster clusteruuid
>>= proxyConnection clusteruuid 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)
data P2PConnectionPair = P2PConnectionPair
{ clientRunState :: RunState
, clientP2PConnection :: P2PConnection
, serverP2PConnection :: P2PConnection
, serverP2PConnection :: Maybe P2PConnection
, releaseP2PConnection :: IO ()
-- ^ Releases a P2P connection, which can be reused for other
-- requests.
@ -279,12 +257,47 @@ data P2PConnectionPair = P2PConnectionPair
-- longer usable.
}
mkP2PConnectionPair
localConnection
:: TMVar (IO ())
-> ConnectionParams
-> AnnexWorkerPool
-> IO (Either ConnectionProblem P2PConnectionPair)
localConnection relv connparams workerpool =
localP2PConnectionPair connparams relv $ \serverrunst serverconn ->
inAnnexWorker' workerpool $
void $ runFullProto serverrunst serverconn $
P2P.serveOneCommandAuthed
(connectionServerMode connparams)
(connectionServerUUID connparams)
localP2PConnectionPair
:: ConnectionParams
-> TMVar (IO ())
-> (RunState -> P2PConnection -> IO (Either SomeException ()))
-> IO (Either ConnectionProblem P2PConnectionPair)
mkP2PConnectionPair connparams relv startworker = do
localP2PConnectionPair connparams relv startworker = do
(clientconn, serverconn) <- mkP2PConnectionPair connparams
("http client", "http server")
clientrunst <- mkClientRunState connparams
serverrunst <- mkServerRunState connparams
asyncworker <- async $
startworker serverrunst serverconn
let releaseconn = atomically $ void $ tryPutTMVar relv $
liftIO $ wait asyncworker
>>= either throwM return
return $ Right $ P2PConnectionPair
{ clientRunState = clientrunst
, clientP2PConnection = clientconn
, serverP2PConnection = Just serverconn
, releaseP2PConnection = releaseconn
, closeP2PConnection = releaseconn
}
mkP2PConnectionPair
:: ConnectionParams
-> (String, String)
-> IO (P2PConnection, P2PConnection)
mkP2PConnectionPair connparams (n1, n2) = do
hdl1 <- newEmptyTMVarIO
hdl2 <- newEmptyTMVarIO
wait1 <- newEmptyTMVarIO
@ -297,37 +310,89 @@ mkP2PConnectionPair connparams relv startworker = do
if connectionWaitVar connparams
then Just wait2
else Nothing
let serverconn = P2PConnection Nothing
(const True) h1 h2
(ConnIdent (Just "http server"))
let clientconn = P2PConnection Nothing
(const True) h2 h1
(ConnIdent (Just "http client"))
clientrunst <- mkclientrunst
serverrunst <- mkserverrunst
(ConnIdent (Just n1))
let serverconn = P2PConnection Nothing
(const True) h1 h2
(ConnIdent (Just n2))
return (clientconn, serverconn)
mkServerRunState :: ConnectionParams -> IO RunState
mkServerRunState connparams = do
prototvar <- newTVarIO $ connectionProtocolVersion connparams
mkRunState $ const $ Serving
(connectionClientUUID connparams)
Nothing
prototvar
mkClientRunState :: ConnectionParams -> IO RunState
mkClientRunState connparams = do
prototvar <- newTVarIO $ connectionProtocolVersion connparams
mkRunState $ const $ Client prototvar
proxyConnection
:: TMVar (IO ())
-> ConnectionParams
-> AnnexWorkerPool
-> ProxyConnection
-> IO (Either ConnectionProblem P2PConnectionPair)
proxyConnection relv connparams workerpool proxyconn = do
(clientconn, proxyfromclientconn) <- mkP2PConnectionPair connparams
("http client", "proxy")
clientrunst <- mkClientRunState connparams
proxyfromclientrunst <- mkClientRunState connparams
asyncworker <- async $
startworker serverrunst serverconn
let releaseconn = atomically $ void $ tryPutTMVar relv $
liftIO $ wait asyncworker
>>= either throwM return
inAnnexWorker' workerpool $ do
proxystate <- liftIO Proxy.mkProxyState
concurrencyconfig <- Proxy.noConcurrencyConfig
-- TODO run remote protocol to get its version and
-- take minimum of that and connectionProtocolVersion
let protocolversion = connectionProtocolVersion connparams
let proxyparams = Proxy.ProxyParams
{ Proxy.proxyMethods = mkProxyMethods
, Proxy.proxyState = proxystate
, Proxy.proxyServerMode = connectionServerMode connparams
, Proxy.proxyClientSide = Proxy.ClientSide proxyfromclientrunst proxyfromclientconn
, Proxy.proxyUUID = proxyConnectionRemoteUUID proxyconn
, Proxy.proxySelector = Proxy.singleProxySelector $
proxyConnectionRemoteSide proxyconn
, Proxy.proxyConcurrencyConfig = concurrencyconfig
, Proxy.proxyProtocolVersion = protocolversion
}
let proxy mrequestmessage = case mrequestmessage of
Just requestmessage -> do
Proxy.proxyRequest proxydone proxyparams
requestcomplete requestmessage protoerrhandler
Nothing -> return ()
protoerrhandler proxy $
liftIO $ runNetProto proxyfromclientrunst proxyfromclientconn $
P2P.net P2P.receiveMessage
let releaseconn returntopool =
atomically $ void $ tryPutTMVar relv $
liftIO $ wait asyncworker
>>= either throwM return
return $ Right $ P2PConnectionPair
{ clientRunState = clientrunst
, clientP2PConnection = clientconn
, serverP2PConnection = serverconn
, releaseP2PConnection = releaseconn
, closeP2PConnection = releaseconn
, serverP2PConnection = Nothing
, releaseP2PConnection = releaseconn True
, closeP2PConnection = releaseconn False
}
where
mkserverrunst = do
prototvar <- newTVarIO $ connectionProtocolVersion connparams
mkRunState $ const $ Serving
(connectionClientUUID connparams)
Nothing
prototvar
mkclientrunst = do
prototvar <- newTVarIO $ connectionProtocolVersion connparams
mkRunState $ const $ Client prototvar
protoerrhandler cont a = a >>= \case
-- TODO protocol error, or client hung up, release the p2p
-- connection
Left err -> do
liftIO $ hPutStrLn stderr ("protoerrhandler: " ++ show err)
return ()
Right v -> do
liftIO $ print "protoerrhandler returned"
cont v
proxydone = return ()
requestcomplete () = return ()
data Locker = Locker
{ lockerThread :: Async ()
@ -441,9 +506,27 @@ inAnnexWorker' poolv annexaction = do
return res
data ProxyConnection = ProxyConnection
{ proxyP2PConnectionPair :: P2PConnectionPair
{ proxyConnectionRemoteUUID :: UUID
, proxyConnectionRemoteSide :: Proxy.RemoteSide
}
openProxyConnectionToRemote
:: AnnexWorkerPool
-> P2P.ProtocolVersion
-> [UUID]
-> Remote
-> IO (Either SomeException ProxyConnection)
openProxyConnectionToRemote workerpool protoversion bypass remote =
inAnnexWorker' workerpool (proxyRemoteSide protoversion bypass' remote) >>= \case
Left ex -> return (Left ex)
Right remoteside -> return $ Right $
ProxyConnection (Remote.uuid remote) remoteside
where
bypass' = P2P.Bypass (S.fromList bypass)
openProxyConnectionToCluster :: ClusterUUID -> IO ProxyConnection
openProxyConnectionToCluster cu = error "XXX" -- TODO
type ProxyConnectionPool =
M.Map (UUID, UUID, P2P.ProtocolVersion) [ProxyConnection]
@ -469,9 +552,3 @@ getProxyConnectionFromPool proxypool connparams = do
, connectionClientUUID connparams
, connectionProtocolVersion connparams
)
openProxyConnectionToRemote :: Remote -> IO ProxyConnection
openProxyConnectionToRemote remote = error "XXX" -- TODO
openProxyConnectionToCluster :: ClusterUUID -> IO ProxyConnection
openProxyConnectionToCluster cu = error "XXX" -- TODO