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.

Assistant/WebApp/Configurators/Upgrade.hs

@@ -12,7 +12,6 @@ module Assistant.WebApp.Configurators.Upgrade where
 import Assistant.WebApp.Common
 import qualified Annex
 import Types.Distribution
-import Assistant.WebApp.OtherRepos
 import Assistant.Upgrade
 import Utility.HumanTime
 import Git
@@ -28,20 +27,14 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
 	$(widgetFile "configurators/upgrade/start")
 
 {- Finish upgrade by starting the new assistant in the same repository this
- - one is running in, and redirecting to it.
- -
- - Note that only the browser tab that requested this page gets redirected.
- - If the user has multiple web browser tabs open to the webapp,
- - the others will show the upgradingAlert, and keep running until
- - this process is terminated.
- -}
+ - one is running in, and redirecting to it. -}
 getConfigFinishUpgradeR :: Handler Html
 getConfigFinishUpgradeR = do
 	liftAssistant prepUpgrade
-	liftIO postUpgrade `after` startnewprocess
-  where
-	startnewprocess = switchToAssistant
+	url <- liftIO . newAssistantUrl
 		=<< liftAnnex (repoLocation <$> Annex.gitRepo)
+	liftAssistant $ postUpgrade url
+	redirect url
 
 getConfigEnableAutomaticUpgradeR :: Handler Html
 getConfigEnableAutomaticUpgradeR = do

Assistant/WebApp/Notifications.hs

@@ -28,6 +28,7 @@ import qualified Data.Text as T
 #ifndef WITH_OLD_YESOD
 import qualified Data.Aeson.Types as Aeson
 #endif
+import Control.Concurrent
 
 {- Add to any widget to make it auto-update using long polling.
  -
@@ -82,6 +83,9 @@ getNotifierRepoListR reposelector = notifierUrl route getRepoListBroadcaster
   where
 	route nid = RepoListR nid reposelector
 
+getNotifierGlobalRedirR :: Handler RepPlain
+getNotifierGlobalRedirR = notifierUrl GlobalRedirR getGlobalRedirBroadcaster
+
 getTransferBroadcaster :: Assistant NotificationBroadcaster
 getTransferBroadcaster = transferNotifier <$> getDaemonStatus
 
@@ -93,3 +97,20 @@ getBuddyListBroadcaster =  getBuddyBroadcaster <$> getAssistant buddyList
 
 getRepoListBroadcaster :: Assistant NotificationBroadcaster
 getRepoListBroadcaster =  syncRemotesNotifier <$> getDaemonStatus
+
+getGlobalRedirBroadcaster :: Assistant NotificationBroadcaster
+getGlobalRedirBroadcaster =  globalRedirNotifier <$> getDaemonStatus
+
+getGlobalRedirR :: NotificationId -> Handler Text
+getGlobalRedirR nid = do
+	tid <- liftIO myThreadId
+	liftIO $ do
+		hPutStrLn stderr $ show ("getGlobalRedirR waiting", tid)
+		hFlush stderr
+	waitNotifier getGlobalRedirBroadcaster nid
+	v <- globalRedirUrl <$> liftAssistant getDaemonStatus
+	liftIO $ do
+		hPutStrLn stderr $ show ("getGlobalRedirR got a val", v, tid)
+		hFlush stderr
+	maybe (getGlobalRedirR nid) (return . T.pack)
+		=<< globalRedirUrl <$> liftAssistant getDaemonStatus

Assistant/WebApp/OtherRepos.hs

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

Assistant/WebApp/routes

@@ -103,6 +103,9 @@
 /repolist/#NotificationId/#RepoSelector RepoListR GET
 /notifier/repolist/#RepoSelector NotifierRepoListR GET
 
+/globalredir/#NotificationId GlobalRedirR GET
+/notifier/globalredir NotifierGlobalRedirR GET
+
 /alert/close/#AlertId CloseAlert GET
 /alert/click/#AlertId/#Int ClickAlert GET
 /filebrowser FileBrowserR GET POST