global webapp redirects, to finish upgrades

When an automatic upgrade completes, or when the user clicks on the upgrade
button in one webapp, but also has it open in another browser window/tab,
we have a problem: The current web server is going to stop running in
minutes, but there is no way to send a redirect to the web browser to the
new url.

To solve this, used long polling, so the webapp is always listening for
urls it should redirect to. This allows globally redirecting every open
webapp. Works great! Tested with 2 web browsers with 2 tabs each.
May be useful for other purposes later too, dunno.

The overhead is 2 http requests per page load in the webapp. Due to yesod's
speed, this does not seem to noticibly delay it. Only 1 of the requests
could possibly block the page load, the other is async.
This commit is contained in:
Joey Hess 2013-11-23 14:47:38 -04:00
parent d24f7f94fe
commit 183f7355cd
11 changed files with 148 additions and 82 deletions

View file

@ -12,15 +12,10 @@ module Assistant.WebApp.OtherRepos where
import Assistant.Common
import Assistant.WebApp.Types
import Assistant.WebApp.Page
import qualified Git.Construct
import qualified Git.Config
import Config.Files
import qualified Utility.Url as Url
import Utility.Yesod
import Assistant.Upgrade
import Control.Concurrent
getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
repolist <- liftIO listOtherRepos
@ -38,28 +33,4 @@ listOtherRepos = do
getSwitchToRepositoryR :: FilePath -> Handler Html
getSwitchToRepositoryR repo = do
liftIO $ addAutoStartFile repo -- make this the new default repo
switchToAssistant repo
{- Starts up the assistant in the repository, and waits for it to create
- a gitAnnexUrlFile. Waits for the assistant to be up and listening for
- connections by testing the url. Once it's running, redirect to it. -}
switchToAssistant :: FilePath -> Handler Html
switchToAssistant repo = do
liftIO $ startAssistant repo
redirect =<< liftIO geturl
where
geturl = do
r <- Git.Config.read =<< Git.Construct.fromPath repo
waiturl $ gitAnnexUrlFile r
waiturl urlfile = do
v <- tryIO $ readFile urlfile
case v of
Left _ -> delayed $ waiturl urlfile
Right url -> ifM (listening url)
( return url
, delayed $ waiturl urlfile
)
listening url = catchBoolIO $ fst <$> Url.exists url [] Nothing
delayed a = do
threadDelay 100000 -- 1/10th of a second
a
redirect =<< liftIO (newAssistantUrl repo)