started implementing git-annex-shell proxy

So far, it negotiates VERSION with both parties. This is a tricky dance.

Untested.

Command/P2PStdIO.hs

@@ -1,6 +1,6 @@
 {- git-annex command
  -
- - Copyright 2018 Joey Hess <id@joeyh.name>
+ - Copyright 2018-2024 Joey Hess <id@joeyh.name>
  -
  - 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

P2P/Proxy.hs

@@ -0,0 +1,90 @@
+{- P2P protocol proxying
+ -
+ - Copyright 2024 Joey Hess <id@joeyh.name>
+ -
+ - 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

Remote/Helper/Ssh.hs

@@ -1,6 +1,6 @@
 {- git-annex remote access with ssh and git-annex-shell
  -
- - Copyright 2011-2022 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2024 Joey Hess <id@joeyh.name>
  -
  - 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
+		Nothing -> return Nothing
-			liftIO $ rememberunsupported
-			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
+					else return Nothing
-						rememberunsupported
-						return Nothing
-	rememberunsupported = atomically $
-		modifyTVar' connpool $
-			maybe (Just P2PSshUnsupported) Just
 
 -- Runs a P2P Proto action on a remote when it supports that,
 -- otherwise the fallback action.

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,

git-annex.cabal

@@ -870,6 +870,7 @@ Executable git-annex
     P2P.Auth
     P2P.IO
     P2P.Protocol
+    P2P.Proxy
     Remote
     Remote.Adb
     Remote.BitTorrent