mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

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

Browse source 
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.
This commit is contained in:
Joey Hess 2024-11-21 15:09:12 -04:00
parent 758ea89c74
commit 4c785c338a
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
4 changed files with 80 additions and 29 deletions
Download patch file Download diff file Expand all files Collapse all files

41
Command/P2PHttp.hs
View file

@ -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)