From 501d65eeabe701b10736e94d7dc2ab704d43605a Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 10 Jun 2024 18:01:36 -0400 Subject: [PATCH] started implementing git-annex-shell proxy So far, it negotiates VERSION with both parties. This is a tricky dance. Untested. --- Command/P2PStdIO.hs | 38 ++++++++++++++- P2P/Proxy.hs | 90 ++++++++++++++++++++++++++++++++++++ Remote/Helper/Ssh.hs | 29 +++++++----- doc/design/p2p_protocol.mdwn | 2 +- git-annex.cabal | 1 + 5 files changed, 146 insertions(+), 14 deletions(-) create mode 100644 P2P/Proxy.hs diff --git a/Command/P2PStdIO.hs b/Command/P2PStdIO.hs index c657a85ac8..685d6a5747 100644 --- a/Command/P2PStdIO.hs +++ b/Command/P2PStdIO.hs @@ -1,6 +1,6 @@ {- git-annex command - - - Copyright 2018 Joey Hess + - Copyright 2018-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -10,10 +10,12 @@ module Command.P2PStdIO where import Command import P2P.IO import P2P.Annex +import P2P.Proxy import qualified P2P.Protocol as P2P import qualified Annex import Annex.UUID import qualified CmdLine.GitAnnexShell.Checks as Checks +import Remote.Helper.Ssh (openP2PSshConnection', closeP2PSshConnection) import System.IO.Error @@ -35,6 +37,12 @@ start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do (True, _) -> P2P.ServeReadOnly (False, True) -> P2P.ServeAppendOnly (False, False) -> P2P.ServeReadWrite + Annex.getState Annex.proxyremote >>= \case + Nothing -> performLocal theiruuid servermode + Just r -> performProxy theiruuid servermode r + +performLocal :: UUID -> P2P.ServerMode -> CommandPerform +performLocal theiruuid servermode = do myuuid <- getUUID let conn = stdioP2PConnection Nothing let server = do @@ -48,3 +56,31 @@ start theiruuid = startingCustomOutput (ActionItemOther Nothing) $ do Left e -> giveup (describeProtoFailure e) where done = next $ return True + +performProxy :: UUID -> P2P.ServerMode -> Remote -> CommandPerform +performProxy clientuuid servermode remote = do + clientside <- ClientSide + <$> liftIO (mkRunState $ Serving clientuuid Nothing) + <*> pure (stdioP2PConnection Nothing) + getClientProtocolVersion clienterrhandler remote clientside $ \case + Nothing -> done + Just (clientmaxversion, othermsg) -> + connectremote clientmaxversion $ \remoteside -> + proxy clienterrhandler done servermode + clientside remoteside othermsg + where + -- FIXME: Support special remotes and non-ssh git remotes. + connectremote clientmaxversion cont = + openP2PSshConnection' remote clientmaxversion >>= \case + Just conn@(P2P.IO.OpenConnection (remoterunst, remoteconn, _)) -> + cont (RemoteSide remoterunst remoteconn) + `finally` liftIO (closeP2PSshConnection conn) + _ -> giveup "Unable to connect to remote." + + clienterrhandler cont a = a >>= \case + -- Avoid displaying an error when the client hung up on us. + Left (ProtoFailureIOError e) | isEOFError e -> done + Left e -> giveup (describeProtoFailure e) + Right v -> cont v + + done = next $ return True diff --git a/P2P/Proxy.hs b/P2P/Proxy.hs new file mode 100644 index 0000000000..92db9a4c7a --- /dev/null +++ b/P2P/Proxy.hs @@ -0,0 +1,90 @@ +{- P2P protocol proxying + - + - Copyright 2024 Joey Hess + - + - Licensed under the GNU AGPL version 3 or higher. + -} + +{-# LANGUAGE RankNTypes, FlexibleContexts #-} + +module P2P.Proxy where + +import Annex.Common +import P2P.Protocol +import P2P.IO +import qualified Remote + +data ClientSide = ClientSide RunState P2PConnection +data RemoteSide = RemoteSide RunState P2PConnection + +{- This is the first thing run when proxying with a client. Most clients + - will send a VERSION message, although version 0 clients will not and + - will send some other message. + - + - But before the client will send VERSION, it needs to see AUTH_SUCCESS. + - So send that, although the connection with the remote is not actually + - brought up yet. + -} +getClientProtocolVersion + :: (forall t. ((t -> Annex r) -> Annex (Either ProtoFailure t) -> Annex r)) + -> Remote + -> ClientSide + -> (Maybe (ProtocolVersion, Maybe Message) -> Annex r) + -> Annex r +getClientProtocolVersion clienterrhandler remote (ClientSide clientrunst clientconn) cont = + clienterrhandler cont $ + liftIO $ runNetProto clientrunst clientconn $ + getClientProtocolVersion' remote + +getClientProtocolVersion' :: Remote -> Proto (Maybe (ProtocolVersion, Maybe Message)) +getClientProtocolVersion' remote = do + net $ sendMessage (AUTH_SUCCESS (Remote.uuid remote)) + msg <- net receiveMessage + case msg of + Nothing -> return Nothing + Just (VERSION v) -> + -- If the client sends a newer version than we + -- understand, reduce it; we need to parse the + -- protocol too. + let v' = if v > maxProtocolVersion + then maxProtocolVersion + else v + in return (Just (v', Nothing)) + Just othermsg -> return + (Just (defaultProtocolVersion, Just othermsg)) + +{- Proxy between the client and the remote. This picks up after + - getClientProtocolVersion, and after the connection to + - the remote has been made, and the protocol version negotiated with the + - remote. + -} +proxy + :: (forall t. ((t -> Annex r) -> Annex (Either ProtoFailure t) -> Annex r)) + -> Annex r + -> ServerMode + -> ClientSide + -> RemoteSide + -> Maybe Message + -- ^ non-VERSION message that was received from the client and has + -- not been responded to yet + -> Annex r +proxy clienterrhandler endsuccess servermode (ClientSide clientrunst clientconn) (RemoteSide remoterunst remoteconn) othermessage = do + case othermessage of + Just message -> clientmessage (Just message) + Nothing -> do + -- Send client the VERSION from the remote. + proxyprotocolversion <- + either (const defaultProtocolVersion) id + <$> toremote (net getProtocolVersion) + clienterrhandler (\() -> getnextclientmessage) $ + toclient $ net $ sendMessage + (VERSION proxyprotocolversion) + where + toremote = liftIO . runNetProto remoterunst remoteconn + toclient = liftIO . runNetProto clientrunst clientconn + + getnextclientmessage = clienterrhandler clientmessage $ + toclient (net receiveMessage) + + clientmessage Nothing = endsuccess + clientmessage (Just message) = giveup "TODO" -- XXX diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index d712706fd2..787bc1824f 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex remote access with ssh and git-annex-shell - - - Copyright 2011-2022 Joey Hess + - Copyright 2011-2024 Joey Hess - - Licensed under the GNU AGPL version 3 or higher. -} @@ -231,14 +231,24 @@ storeP2PSshConnection connpool conn = atomically $ modifyTVar' connpool $ \case -- If the remote does not support the P2P protocol, that's remembered in -- the connection pool. openP2PSshConnection :: Remote -> P2PSshConnectionPool -> Annex (Maybe P2PSshConnection) -openP2PSshConnection r connpool = do +openP2PSshConnection r connpool = + openP2PSshConnection' r P2P.maxProtocolVersion >>= \case + Just conn -> return (Just conn) + Nothing -> do + liftIO $ rememberunsupported + return Nothing + where + rememberunsupported = atomically $ + modifyTVar' connpool $ + maybe (Just P2PSshUnsupported) Just + +openP2PSshConnection' :: Remote -> P2P.ProtocolVersion -> Annex (Maybe P2PSshConnection) +openP2PSshConnection' r maxprotoversion = do u <- getUUID let ps = [Param (fromUUID u)] repo <- getRepo r git_annex_shell ConsumeStdin repo "p2pstdio" ps [] >>= \case - Nothing -> do - liftIO $ rememberunsupported - return Nothing + Nothing -> return Nothing Just (cmd, params) -> start cmd params where start cmd params = liftIO $ do @@ -261,7 +271,7 @@ openP2PSshConnection r connpool = do -- When the connection is successful, the remote -- will send an AUTH_SUCCESS with its uuid. let proto = P2P.postAuth $ - P2P.negotiateProtocolVersion P2P.maxProtocolVersion + P2P.negotiateProtocolVersion maxprotoversion tryNonAsync (P2P.runNetProto runst conn proto) >>= \case Right (Right (Just theiruuid)) | theiruuid == uuid r -> return $ Just c @@ -271,12 +281,7 @@ openP2PSshConnection r connpool = do -- server. if exitcode == Just (ExitFailure 255) then return (Just cclosed) - else do - rememberunsupported - return Nothing - rememberunsupported = atomically $ - modifyTVar' connpool $ - maybe (Just P2PSshUnsupported) Just + else return Nothing -- Runs a P2P Proto action on a remote when it supports that, -- otherwise the fallback action. diff --git a/doc/design/p2p_protocol.mdwn b/doc/design/p2p_protocol.mdwn index 90b2352df6..1ee5f00172 100644 --- a/doc/design/p2p_protocol.mdwn +++ b/doc/design/p2p_protocol.mdwn @@ -41,7 +41,7 @@ is successful. Or, it can fail the authentication, and close the connection. AUTH-SUCCESS UUID - AUTH_FAILURE + AUTH-FAILURE Note that authentication does not guarantee that the client is talking to who they expect to be talking to. This, and encryption of the connection, diff --git a/git-annex.cabal b/git-annex.cabal index 112e62c8cd..c5e6c19d7c 100644 --- a/git-annex.cabal +++ b/git-annex.cabal @@ -870,6 +870,7 @@ Executable git-annex P2P.Auth P2P.IO P2P.Protocol + P2P.Proxy Remote Remote.Adb Remote.BitTorrent