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:
parent
d24f7f94fe
commit
183f7355cd
11 changed files with 148 additions and 82 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -14,9 +14,14 @@ import Assistant.Alert
|
|||
import Assistant.DaemonStatus
|
||||
import Assistant.NamedThread
|
||||
import Utility.ThreadScheduler
|
||||
import Utility.NotificationBroadcaster
|
||||
import Utility.Url
|
||||
import Utility.Env
|
||||
import Git
|
||||
import qualified Git.Construct
|
||||
import qualified Git.Config
|
||||
import Config.Files
|
||||
import Types.Distribution
|
||||
|
||||
import Control.Concurrent
|
||||
import System.Posix (getProcessID, signalProcess, sigTERM)
|
||||
|
@ -35,22 +40,58 @@ prepUpgrade = do
|
|||
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
|
||||
void $ liftIO $ setEnv upgradedEnv "1" True
|
||||
|
||||
{- Wait for browser to update before terminating this process. -}
|
||||
postUpgrade :: IO ()
|
||||
postUpgrade = void $ forkIO $ do
|
||||
threadDelaySeconds (Seconds 120)
|
||||
signalProcess sigTERM =<< getProcessID
|
||||
{- To finish an upgrade, send a global redirect to the new url
|
||||
- to any web browsers that are displaying the webapp.
|
||||
-
|
||||
- Wait for browser to update before terminating this process. -}
|
||||
postUpgrade :: URLString -> Assistant ()
|
||||
postUpgrade url = do
|
||||
modifyDaemonStatus_ $ \status -> status { globalRedirUrl = Just url }
|
||||
liftIO . sendNotification . globalRedirNotifier =<< getDaemonStatus
|
||||
void $ liftIO $ forkIO $ do
|
||||
threadDelaySeconds (Seconds 120)
|
||||
signalProcess sigTERM =<< getProcessID
|
||||
|
||||
{- Upgrade without interaction in the webapp.
|
||||
-
|
||||
- XXX If the webapp is open, this will make it stop working
|
||||
- or close, with no more indication why than an alert.
|
||||
-}
|
||||
{- Upgrade without interaction in the webapp. -}
|
||||
unattendedUpgrade :: Assistant ()
|
||||
unattendedUpgrade = do
|
||||
prepUpgrade
|
||||
liftIO . startAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo)
|
||||
liftIO postUpgrade
|
||||
url <- liftIO . newAssistantUrl
|
||||
=<< liftAnnex (repoLocation <$> Annex.gitRepo)
|
||||
postUpgrade url
|
||||
|
||||
autoUpgradeEnabled :: Assistant Bool
|
||||
autoUpgradeEnabled = liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig
|
||||
|
||||
checkSuccessfulUpgrade :: IO Bool
|
||||
checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
|
||||
|
||||
upgradedEnv :: String
|
||||
upgradedEnv = "GIT_ANNEX_UPGRADED"
|
||||
|
||||
{- 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. -}
|
||||
newAssistantUrl :: FilePath -> IO URLString
|
||||
newAssistantUrl repo = do
|
||||
startAssistant repo
|
||||
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 <$> exists url [] Nothing
|
||||
delayed a = do
|
||||
threadDelay 100000 -- 1/10th of a second
|
||||
a
|
||||
|
||||
{- Returns once the assistant has daemonized, but possibly before it's
|
||||
- listening for web connections. -}
|
||||
|
@ -61,9 +102,3 @@ startAssistant repo = do
|
|||
createProcess $
|
||||
(proc program ["assistant"]) { cwd = Just repo }
|
||||
void $ checkSuccessProcess pid
|
||||
|
||||
checkSuccessfulUpgrade :: IO Bool
|
||||
checkSuccessfulUpgrade = isJust <$> getEnv upgradedEnv
|
||||
|
||||
upgradedEnv :: String
|
||||
upgradedEnv = "GIT_ANNEX_UPGRADED"
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,11 +1,10 @@
|
|||
// Updates a div with a specified id, by polling an url,
|
||||
// which should return a new div, with the same id.
|
||||
|
||||
connfails=0;
|
||||
|
||||
longpollcallbacks = $.Callbacks();
|
||||
|
||||
function longpoll(url, divid, cont, fail) {
|
||||
// Updates a div with a specified id, by polling an url,
|
||||
// which should return a new div, with the same id.
|
||||
function longpoll_div(url, divid, cont, fail) {
|
||||
$.ajax({
|
||||
'url': url,
|
||||
'dataType': 'html',
|
||||
|
@ -26,3 +25,18 @@ function longpoll(url, divid, cont, fail) {
|
|||
}
|
||||
});
|
||||
}
|
||||
|
||||
function longpoll_data(url, cont) {
|
||||
$.ajax({
|
||||
'url': url,
|
||||
'dataType': 'text',
|
||||
'success': function(data, status, jqxhr) {
|
||||
connfails=0;
|
||||
cont(1, data);
|
||||
},
|
||||
'error': function(jqxhr, msg, e) {
|
||||
connfails=connfails+1;
|
||||
cont(0);
|
||||
}
|
||||
});
|
||||
}
|
||||
|
|
|
@ -1,7 +1,7 @@
|
|||
$(function() {
|
||||
$.get("@{geturl}", function(url){
|
||||
var f = function() {
|
||||
longpoll(url, #{ident}
|
||||
longpoll_div(url, #{ident}
|
||||
, function() { setTimeout(f, #{delay}); }
|
||||
, function() { window.location.reload(true); }
|
||||
);
|
||||
|
|
22
templates/page.julius
Normal file
22
templates/page.julius
Normal file
|
@ -0,0 +1,22 @@
|
|||
$(function() {
|
||||
$.get("@{NotifierGlobalRedirR}", function(url){
|
||||
var f = function() {
|
||||
longpoll_data(url,
|
||||
function(ok, redirurl) {
|
||||
if (ok) {
|
||||
if (redirurl) {
|
||||
window.location = redirurl;
|
||||
}
|
||||
else {
|
||||
setTimeout(f, 10);
|
||||
}
|
||||
}
|
||||
else {
|
||||
setTimeout(f, 5000);
|
||||
}
|
||||
}
|
||||
);
|
||||
};
|
||||
setTimeout(f, 500);
|
||||
});
|
||||
});
|
Loading…
Reference in a new issue