From 07026cf58b8536f0d3ce2ba41c9bd002a895c0fb Mon Sep 17 00:00:00 2001
From: Joey Hess <joeyh@joeyh.name>
Date: Wed, 20 Nov 2024 13:18:25 -0400
Subject: [PATCH] add proxied uuids to http server state map

This fixes support for proxying after last commit broke it.

Note that withP2PConnections is called at server startup, and so only
proxies seen at that point will appear in the map and be used. It was
already the case that a proxy added after p2phttp was running would not
be served.

I think that is possibly a bug, but at least this commit doesn't
introduce the problem, though it might make it harder to fix it.

As bugs go, it's probably not a big deal, because after all,
git configs needs to be set in the local repository, followed by
git-annex updateproxy being run, to set up proxying. If someone is doing
that, they can restart their http server I suppose.
---
 Command/P2PHttp.hs | 17 +++++++----------
 P2P/Http/State.hs  |  5 +++--
 2 files changed, 10 insertions(+), 12 deletions(-)

diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs
index ec37bf6d0a..51f992cb91 100644
--- a/Command/P2PHttp.hs
+++ b/Command/P2PHttp.hs
@@ -16,7 +16,6 @@ import P2P.Http.Server
 import P2P.Http.Url
 import qualified P2P.Protocol as P2P
 import Utility.Env
-import Annex.UUID
 
 import Servant
 import qualified Network.Wai.Handler.Warp as Warp
@@ -103,19 +102,17 @@ optParser _ = Options
 		))
 
 seek :: Options -> CommandSeek
-seek o = do
-	u <- getUUID
-	getAnnexWorkerPool $ \workerpool ->
-		withP2PConnections workerpool
-			(fromMaybe 1 $ proxyConnectionsOption o)
-			(fromMaybe 1 $ clusterJobsOption o)
-			(go u workerpool)
+seek o = getAnnexWorkerPool $ \workerpool ->
+	withP2PConnections workerpool
+		(fromMaybe 1 $ proxyConnectionsOption o)
+		(fromMaybe 1 $ clusterJobsOption o)
+		(go workerpool)
   where
-	go u workerpool acquireconn = liftIO $ do
+	go workerpool servinguuids acquireconn = liftIO $ do
 		authenv <- getAuthEnv
 		st <- mkP2PHttpServerState acquireconn workerpool $
 			mkGetServerMode authenv o
-		let mst = M.singleton u st
+		let mst = M.fromList $ zip servinguuids (repeat st)
 		let settings = Warp.setPort port $ Warp.setHost host $
 			Warp.defaultSettings
 		case (certFileOption o, privateKeyFileOption o) of
diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs
index 24d430957e..a9df861220 100644
--- a/P2P/Http/State.hs
+++ b/P2P/Http/State.hs
@@ -213,7 +213,7 @@ withP2PConnections
 	:: AnnexWorkerPool
 	-> ProxyConnectionPoolSize
 	-> ClusterConcurrency
-	-> (AcquireP2PConnection -> Annex a)
+	-> ([UUID] -> AcquireP2PConnection -> Annex a)
 	-> Annex a
 withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do
 	enableInteractiveBranchAccess
@@ -228,7 +228,8 @@ withP2PConnections workerpool proxyconnectionpoolsize clusterconcurrency a = do
 	let endit = do
 		liftIO $ atomically $ putTMVar endv ()
 		liftIO $ wait asyncservicer
-	a (acquireconn reqv) `finally` endit
+	let servinguuids = myuuid : map proxyRemoteUUID (maybe [] S.toList myproxies)
+	a servinguuids (acquireconn reqv) `finally` endit
   where
 	acquireconn reqv connparams = do
 		respvar <- newEmptyTMVarIO