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.

3 files changed, 25 insertions, 18 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index e7d3e103d..a8d49cc5b 100644
--- a/Assistant/Alert.hs
+++ b/Assistant/Alert.hs
@@ -217,12 +217,12 @@ notFsckedAlert mr button = Alert
 	, alertData = []
 	}
 
-baseUpgradeAlert :: AlertButton -> TenseText -> Alert
-baseUpgradeAlert button message = Alert
+baseUpgradeAlert :: [AlertButton] -> TenseText -> Alert
+baseUpgradeAlert buttons message = Alert
 	{ alertHeader = Just message
 	, alertIcon = Just UpgradeIcon
 	, alertPriority = High
-	, alertButtons = [button]
+	, alertButtons = buttons
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -235,7 +235,7 @@ baseUpgradeAlert button message = Alert
 
 canUpgradeAlert :: AlertPriority -> AlertButton -> Alert
 canUpgradeAlert priority button = 
-	(baseUpgradeAlert button $ fromString msg)
+	(baseUpgradeAlert [button] $ fromString msg)
 		{ alertPriority = priority }
   where
 	msg = if priority >= High
@@ -243,15 +243,15 @@ canUpgradeAlert priority button =
 		else "An upgrade of git-annex is available."
 
 upgradeReadyAlert :: AlertButton -> Alert
-upgradeReadyAlert button = baseUpgradeAlert button $
+upgradeReadyAlert button = baseUpgradeAlert [button] $
 	fromString "A new version of git-annex has been installed."
 
 upgradingAlert :: Alert
 upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]
 
-upgradeFinishedAlert :: AlertButton -> GitAnnexVersion -> Alert
+upgradeFinishedAlert :: Maybe AlertButton -> GitAnnexVersion -> Alert
 upgradeFinishedAlert button version =
-	baseUpgradeAlert button $ fromString $ 
+	baseUpgradeAlert (maybe [] (:[]) button) $ fromString $ 
 		"Finished upgrading git-annex to version " ++ version
 
 brokenRepositoryAlert :: AlertButton -> Alert
diff --git a/Assistant/Threads/UpgradeWatcher.hs b/Assistant/Threads/UpgradeWatcher.hs
index 7cb42e597..6122d2535 100644
--- a/Assistant/Threads/UpgradeWatcher.hs
+++ b/Assistant/Threads/UpgradeWatcher.hs
@@ -25,8 +25,6 @@ import Assistant.DaemonStatus
 import Assistant.WebApp.Types
 import qualified Build.SysConfig
 #endif
-import qualified Annex
-import Types.Distribution
 
 import Control.Concurrent.MVar
 import Data.Tuple.Utils
@@ -102,7 +100,7 @@ handleUpgrade urlrenderer = do
 	-- (For example, other associated files may be being put into
 	-- place.)
 	liftIO $ threadDelaySeconds (Seconds 120)
-	ifM (liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig)
+	ifM autoUpgradeEnabled
 		( do
 			debug ["starting automatic upgrade"]
 			unattendedUpgrade
@@ -118,9 +116,12 @@ handleUpgrade urlrenderer = do
 showSuccessfulUpgrade :: UrlRenderer -> Assistant ()
 showSuccessfulUpgrade urlrenderer = do
 #ifdef WITH_WEBAPP
-	button <- mkAlertButton True
-		(T.pack "Enable Automatic Upgrades")
-		urlrenderer ConfigEnableAutomaticUpgradeR
+	button <- ifM autoUpgradeEnabled 
+		( pure Nothing
+		, Just <$> mkAlertButton True
+			(T.pack "Enable Automatic Upgrades")
+			urlrenderer ConfigEnableAutomaticUpgradeR
+		)
 	void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
 #else
 	noop
diff --git a/Assistant/Types/DaemonStatus.hs b/Assistant/Types/DaemonStatus.hs
index ecf67eaf7..1dd41c900 100644
--- a/Assistant/Types/DaemonStatus.hs
+++ b/Assistant/Types/DaemonStatus.hs
@@ -14,6 +14,7 @@ import Logs.Transfer
 import Assistant.Types.ThreadName
 import Assistant.Types.NetMessager
 import Assistant.Types.Alert
+import Utility.Url
 
 import Control.Concurrent.STM
 import Control.Concurrent.MVar
@@ -55,20 +56,23 @@ data DaemonStatus = DaemonStatus
 	, desynced :: S.Set UUID
 	-- Pairing request that is in progress.
 	, pairingInProgress :: Maybe PairingInProgress
-	-- Broadcasts notifications about all changes to the DaemonStatus
+	-- Broadcasts notifications about all changes to the DaemonStatus.
 	, changeNotifier :: NotificationBroadcaster
 	-- Broadcasts notifications when queued or current transfers change.
 	, transferNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when there's a change to the alerts
+	-- Broadcasts notifications when there's a change to the alerts.
 	, alertNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when the syncRemotes change
+	-- Broadcasts notifications when the syncRemotes change.
 	, syncRemotesNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when the scheduleLog changes
+	-- Broadcasts notifications when the scheduleLog changes.
 	, scheduleLogNotifier :: NotificationBroadcaster
 	-- Broadcasts a notification once the startup sanity check has run.
 	, startupSanityCheckNotifier :: NotificationBroadcaster
-	-- Broadcasts notifications when the network is connected
+	-- Broadcasts notifications when the network is connected.
 	, networkConnectedNotifier :: NotificationBroadcaster
+	-- Broadcasts notifications when a global redirect is needed.
+	, globalRedirNotifier :: NotificationBroadcaster
+	, globalRedirUrl :: Maybe URLString
 	-- When the XMPP client is connected, this will contain the XMPP
 	-- address.
 	, xmppClientID :: Maybe ClientID
@@ -106,5 +110,7 @@ newDaemonStatus = DaemonStatus
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
 	<*> newNotificationBroadcaster
+	<*> newNotificationBroadcaster
+	<*> pure Nothing
 	<*> pure Nothing
 	<*> pure M.empty