From 4c785c338a64a36846d59d01fbdc5ca783f33add Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Thu, 21 Nov 2024 15:09:12 -0400 Subject: [PATCH] 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 | 2 +- Command/P2PHttp.hs | 41 +++++++++++++++++++++++++++++++++-------- P2P/Http/Server.hs | 26 +++++++++++++------------- P2P/Http/State.hs | 40 +++++++++++++++++++++++++++++++++------- 4 files changed, 80 insertions(+), 29 deletions(-) diff --git a/CHANGELOG b/CHANGELOG index 76d77db4a3..c4fbf116fd 100644 --- a/CHANGELOG +++ b/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 Mon, 11 Nov 2024 12:26:00 -0400 diff --git a/Command/P2PHttp.hs b/Command/P2PHttp.hs index 16b7ce789e..31ee330f4d 100644 --- a/Command/P2PHttp.hs +++ b/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 $ - ifM ((/=) NoUUID <$> getUUID) - ( mkServerState o authenv - , return mempty - ) - runServer o (mconcat sts) + Annex.eval strd (mkstannex authenv oldst) + return (mconcat sts) + { updateRepos = updaterepos authenv + } + + 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) diff --git a/P2P/Http/Server.hs b/P2P/Http/Server.hs index 207c168fa5..6e3d530303 100644 --- a/P2P/Http/Server.hs +++ b/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 diff --git a/P2P/Http/State.hs b/P2P/Http/State.hs index 556553cfa1..1c6d8bb151 100644 --- a/P2P/Http/State.hs +++ b/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 = - case M.lookup (fromB64UUID su) (servedRepos mst) of +checkAuthActionClass mstv su sec auth actionclass go = + 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