p2phttp: notice when new repositories are added to --directory

When a uuid is not known, rescan for new repositories. Easy.

When a repository is removed, it will also get removed from the server
state on the next scan. But until a new uuid is seen, there will not be
a scan. This leaves the server trying to serve a uuid whose repository
is gone. That seems buggy. While getting just fails, dropping fails the
first time, but seems to leave the server in an unusable state, so the
next drop attempt hangs. The server is still able to serve other uuids,
only the one whose repository was removed has that problem.

CHANGELOG

@@ -21,7 +21,7 @@ git-annex (10.20241032) UNRELEASED; urgency=medium
     uses the same hostname as remote.name.url, which is itself a http(s)
     url, they are assumed to share a username and password. This avoids
     unnecessary duplicate password prompts.
-  * p2phttp: Added --directory option which serves all git-annex
+  * p2phttp: Added --directory option which serves multiple git-annex
     repositories located inside a directory.
 
  -- Joey Hess <id@joeyh.name>  Mon, 11 Nov 2024 12:26:00 -0400

Command/P2PHttp.hs

@@ -28,6 +28,7 @@ import qualified Network.Wai.Handler.WarpTLS as Warp
 import Network.Socket (PortNumber)
 import qualified Data.Map as M
 import Data.String
+import Control.Concurrent.STM
 
 cmd :: Command
 cmd = noMessages $ dontCheck repoExists $ 
@@ -132,15 +133,37 @@ startIO o
 		giveup "Use the --directory option to specify which git-annex repositories to serve."
 	| otherwise = do
 		authenv <- getAuthEnv
+		st <- mkst authenv mempty
+		runServer o st
+  where
+	mkst authenv oldst = do
 		repos <- findRepos o
 		sts <- forM repos $ \r -> do
 			strd <- Annex.new r
-			Annex.eval strd $
+			Annex.eval strd (mkstannex authenv oldst)
-				ifM ((/=) NoUUID <$> getUUID)
+		return (mconcat sts)
-					( mkServerState o authenv
+			{ updateRepos = updaterepos authenv
-					, return mempty
+			}
-					)
+	
-		runServer o (mconcat sts)
+	mkstannex authenv oldst = do
+		u <- getUUID
+		if u == NoUUID
+			then return mempty
+			else case M.lookup u (servedRepos oldst) of
+				Nothing -> mkServerState o authenv
+				Just old -> return $ P2PHttpServerState
+					{ servedRepos = M.singleton u old
+					, serverShutdownCleanup = mempty
+					, updateRepos = mempty
+					}
+	
+	updaterepos authenv oldst = do
+		newst <- mkst authenv oldst
+		return $ newst
+			{ serverShutdownCleanup = 
+				serverShutdownCleanup newst 
+					<> serverShutdownCleanup oldst
+			}
 
 runServer :: Options -> P2PHttpServerState -> IO ()
 runServer o mst = go `finally` serverShutdownCleanup mst
@@ -148,12 +171,13 @@ runServer o mst = go `finally` serverShutdownCleanup mst
 	go = do
 		let settings = Warp.setPort port $ Warp.setHost host $
 			Warp.defaultSettings
+		mstv <- newTMVarIO mst
 		case (certFileOption o, privateKeyFileOption o) of
-			(Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mst)
+			(Nothing, Nothing) -> Warp.runSettings settings (p2pHttpApp mstv)
 			(Just certfile, Just privatekeyfile) -> do
 				let tlssettings = Warp.tlsSettingsChain
 					certfile (chainFileOption o) privatekeyfile
-				Warp.runTLS tlssettings settings (p2pHttpApp mst)
+				Warp.runTLS tlssettings settings (p2pHttpApp mstv)
 			_ -> giveup "You must use both --certfile and --privatekeyfile options to enable HTTPS."
 	port = maybe
 		(fromIntegral defaultP2PHttpProtocolPort)
@@ -169,6 +193,7 @@ mkServerState o authenv =
 	withAnnexWorkerPool (jobsOption o) $
 		mkP2PHttpServerState
 			(mkGetServerMode authenv o)
+			return
 			(fromMaybe 1 $ proxyConnectionsOption o)
 			(fromMaybe 1 $ clusterJobsOption o)
 

P2P/Http/Server.hs

@@ -45,10 +45,10 @@ import Control.Concurrent
 import System.IO.Unsafe
 import Data.Either
 
-p2pHttpApp :: P2PHttpServerState -> Application
+p2pHttpApp :: TMVar P2PHttpServerState -> Application
 p2pHttpApp = serve p2pHttpAPI . serveP2pHttp
 
-serveP2pHttp :: P2PHttpServerState -> Server P2PHttpAPI
+serveP2pHttp :: TMVar P2PHttpServerState -> Server P2PHttpAPI
 serveP2pHttp st
 	=    serveGet st
 	:<|> serveGet st
@@ -91,7 +91,7 @@ serveP2pHttp st
 	:<|> serveGetGeneric st
 
 serveGetGeneric
-	:: P2PHttpServerState
+	:: TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> B64Key
 	-> Maybe (B64UUID ClientSide)
@@ -109,7 +109,7 @@ serveGetGeneric st su@(B64UUID u) k mcu bypass =
 
 serveGet
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> B64Key
@@ -222,7 +222,7 @@ serveGet mst su apiver (B64Key k) cu bypass baf startat sec auth = do
 
 serveCheckPresent
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> B64Key
@@ -240,7 +240,7 @@ serveCheckPresent st su apiver (B64Key k) cu bypass sec auth = do
 
 serveRemove
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> (RemoveResultPlus -> t)
 	-> B64UUID ServerSide
 	-> v
@@ -262,7 +262,7 @@ serveRemove st resultmangle su apiver (B64Key k) cu bypass sec auth = do
 
 serveRemoveBefore
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> B64Key
@@ -285,7 +285,7 @@ serveRemoveBefore st su apiver (B64Key k) cu bypass (Timestamp ts) sec auth = do
 
 serveGetTimestamp
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> B64UUID ClientSide
@@ -304,7 +304,7 @@ serveGetTimestamp st su apiver cu bypass sec auth = do
 
 servePut
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> (PutResultPlus -> t)
 	-> B64UUID ServerSide
 	-> v
@@ -421,7 +421,7 @@ servePutResult resultmangle res = case res of
 
 servePut'
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> (PutResultPlus -> t)
 	-> B64UUID ServerSide
 	-> v
@@ -439,7 +439,7 @@ servePut' st resultmangle su v = servePut st resultmangle su v Nothing
 
 servePutOffset
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> (PutOffsetResultPlus -> t)
 	-> B64UUID ServerSide
 	-> v
@@ -463,7 +463,7 @@ servePutOffset st resultmangle su apiver (B64Key k) cu bypass sec auth = do
 
 serveLockContent
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> B64Key
@@ -500,7 +500,7 @@ serveLockContent mst su apiver (B64Key k) cu bypass sec auth = do
 
 serveKeepLocked
 	:: APIVersion v
-	=> P2PHttpServerState
+	=> TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> v
 	-> LockID

P2P/Http/State.hs

@@ -50,12 +50,16 @@ import Prelude
 data P2PHttpServerState = P2PHttpServerState
 	{ servedRepos :: M.Map UUID PerRepoServerState
 	, serverShutdownCleanup :: IO ()
+	, updateRepos :: UpdateRepos
 	}
 
+type UpdateRepos = P2PHttpServerState -> IO P2PHttpServerState
+
 instance Monoid P2PHttpServerState where
 	mempty = P2PHttpServerState
 		{ servedRepos = mempty
 		, serverShutdownCleanup = noop
+		, updateRepos = const mempty
 		}
 
 instance Sem.Semigroup P2PHttpServerState where
@@ -64,6 +68,10 @@ instance Sem.Semigroup P2PHttpServerState where
 		, serverShutdownCleanup = do
 			serverShutdownCleanup a
 			serverShutdownCleanup b
+		, updateRepos = \st -> do
+			a' <- updateRepos a st
+			b' <- updateRepos b st
+			return (a' <> b')
 		}
 
 data PerRepoServerState = PerRepoServerState
@@ -98,7 +106,7 @@ data ActionClass = ReadAction | WriteAction | RemoveAction | LockAction
 withP2PConnection
 	:: APIVersion v
 	=> v
-	-> P2PHttpServerState
+	-> TMVar P2PHttpServerState
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
@@ -119,7 +127,7 @@ withP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams conna
 withP2PConnection'
 	:: APIVersion v
 	=> v
-	-> P2PHttpServerState
+	-> TMVar P2PHttpServerState
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
@@ -137,7 +145,7 @@ withP2PConnection' apiver mst cu su bypass sec auth actionclass fconnparams conn
 getP2PConnection
 	:: APIVersion v
 	=> v
-	-> P2PHttpServerState
+	-> TMVar P2PHttpServerState
 	-> B64UUID ClientSide
 	-> B64UUID ServerSide
 	-> [B64UUID Bypass]
@@ -165,16 +173,32 @@ getP2PConnection apiver mst cu su bypass sec auth actionclass fconnparams =
 			, connectionWaitVar = True
 			}
 
+getPerRepoServerState :: TMVar P2PHttpServerState -> B64UUID ServerSide -> IO (Maybe PerRepoServerState)
+getPerRepoServerState mstv su = do
+	mst <- atomically $ readTMVar mstv
+	case lookupst mst of
+		Just st -> return (Just st)
+		Nothing -> do
+			mst' <- atomically $ takeTMVar mstv
+			mst'' <- updateRepos mst' mst'
+			debug "P2P.Http" $
+				"Rescanned for repositories, now serving UUIDs: "
+					++ show (M.keys (servedRepos mst''))
+			atomically $ putTMVar mstv mst''
+			return $ lookupst mst''
+  where
+	lookupst mst = M.lookup (fromB64UUID su) (servedRepos mst)
+
 checkAuthActionClass
-	:: P2PHttpServerState
+	:: TMVar P2PHttpServerState
 	-> B64UUID ServerSide
 	-> IsSecure
 	-> Maybe Auth
 	-> ActionClass
 	-> (PerRepoServerState -> P2P.ServerMode -> Handler a)
 	-> Handler a
-checkAuthActionClass mst su sec auth actionclass go =
+checkAuthActionClass mstv su sec auth actionclass go =
-	case M.lookup (fromB64UUID su) (servedRepos mst) of
+	liftIO (getPerRepoServerState mstv su) >>= \case
 		Just st -> select st
 		Nothing -> throwError err404
   where
@@ -234,11 +258,12 @@ type AcquireP2PConnection
 
 mkP2PHttpServerState
 	:: GetServerMode
+	-> UpdateRepos
 	-> ProxyConnectionPoolSize
 	-> ClusterConcurrency
 	-> AnnexWorkerPool
 	-> Annex P2PHttpServerState
-mkP2PHttpServerState getservermode proxyconnectionpoolsize clusterconcurrency workerpool = do
+mkP2PHttpServerState getservermode updaterepos proxyconnectionpoolsize clusterconcurrency workerpool = do
 	enableInteractiveBranchAccess
 	myuuid <- getUUID
 	myproxies <- M.lookup myuuid <$> getProxies
@@ -256,6 +281,7 @@ mkP2PHttpServerState getservermode proxyconnectionpoolsize clusterconcurrency wo
 	return $ P2PHttpServerState
 		{ servedRepos = M.fromList $ zip servinguuids (repeat st)
 		, serverShutdownCleanup = endit
+		, updateRepos = updaterepos
 		}
   where
 	acquireconn reqv connparams = do