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.
This commit is contained in:
parent
758ea89c74
commit
4c785c338a
4 changed files with 80 additions and 29 deletions
|
@ -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)
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue