restart on upgrade is working, including automatic restart

Made alerts be able to have multiple buttons, so the alerts about upgrading
can have a button that enables automatic upgrades.

Implemented automatic upgrading when the program file has changed.

Note that when an automatic upgrade happens, the webapp displays an alert
about it for a few minutes, and then closes. This still needs work.
This commit is contained in:
Joey Hess 2013-11-23 00:54:08 -04:00
parent 56e980215f
commit 6abaf19c41
15 changed files with 136 additions and 75 deletions

View file

@ -10,10 +10,10 @@
module Assistant.WebApp.Configurators.Local where
import Assistant.WebApp.Common
import Assistant.WebApp.OtherRepos
import Assistant.WebApp.Gpg
import Assistant.WebApp.MakeRemote
import Assistant.Sync
import Assistant.Upgrade
import Init
import qualified Git
import qualified Git.Construct

View file

@ -249,6 +249,7 @@ startLocalPairing stage oncancel alert muuid displaysecret secret = do
tid <- liftIO myThreadId
let selfdestruct = AlertButton
{ buttonLabel = "Cancel"
, buttonPrimary = True
, buttonUrl = urlrender DashboardR
, buttonAction = Just $ const $ do
oncancel

View file

@ -13,17 +13,12 @@ import Assistant.WebApp.Common
import qualified Annex
import Types.Distribution
import Assistant.WebApp.OtherRepos
import Assistant.Threads.Watcher
import Assistant.Alert
import Assistant.DaemonStatus
import Assistant.NamedThread
import Utility.ThreadScheduler
import Assistant.Upgrade
import Utility.HumanTime
import Git
import Config
import Data.Time.Clock
import Control.Concurrent
import System.Posix (getProcessID, signalProcess, sigTERM)
getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html
getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
@ -35,28 +30,18 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
{- Finish upgrade by starting the new assistant in the same repository this
- one is running in, and redirecting to it.
-
- Before the new assistant can be started, have to remove our
- gitAnnexUrlFile and our gitAnnexPidFile. Pausing the watcher is also
- a good idea, to avoid fighting when two assistants are running in the
- same repo.
-
- Note that only the tag that requested this page gets redirected.
- 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.
-}
getConfigFinishUpgradeR :: Handler Html
getConfigFinishUpgradeR = do
liftAssistant $ void $ addAlert upgradingAlert
liftIO . maybe noop (`throwTo` PauseWatcher) =<< liftAssistant (namedThreadId watchThread)
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
reapself `after` startnewprocess
getConfigFinishUpgradeR :: Bool -> Handler Html
getConfigFinishUpgradeR enableautoupgrade = do
when enableautoupgrade $ liftAnnex $
setConfig (annexConfig "autoupgrade")
(fromAutoUpgrade AutoUpgrade)
liftAssistant prepUpgrade
liftIO postUpgrade `after` startnewprocess
where
-- Wait for the redirect to be served to the browser
-- before terminating this process.
reapself = liftIO $ void $ forkIO $ do
threadDelaySeconds (Seconds 120)
signalProcess sigTERM =<< getProcessID
startnewprocess = switchToAssistant
=<< liftAnnex (repoLocation <$> Annex.gitRepo)

View file

@ -43,6 +43,7 @@ xmppNeeded = whenM (isNothing <$> liftAnnex getXMPPCreds) $ do
{ buttonLabel = "Configure a Jabber account"
, buttonUrl = urlrender XMPPConfigR
, buttonAction = Just close
, buttonPrimary = True
}
#else
xmppNeeded = return ()

View file

@ -17,9 +17,9 @@ import qualified Git.Config
import Config.Files
import qualified Utility.Url as Url
import Utility.Yesod
import Assistant.Upgrade
import Control.Concurrent
import System.Process (cwd)
getRepositorySwitcherR :: Handler Html
getRepositorySwitcherR = page "Switch repository" Nothing $ do
@ -63,13 +63,3 @@ switchToAssistant repo = do
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. -}
startAssistant :: FilePath -> IO ()
startAssistant repo = do
program <- readProgramFile
(_, _, _, pid) <-
createProcess $
(proc program ["assistant"]) { cwd = Just repo }
void $ checkSuccessProcess pid

View file

@ -50,6 +50,7 @@ sideBarDisplay = do
let message = renderAlertMessage alert
let messagelines = T.lines message
let multiline = length messagelines > 1
let buttons = zip (alertButtons alert) [1..]
$(widgetFile "sidebar/alert")
{- Called by client to get a sidebar display.
@ -79,16 +80,20 @@ getCloseAlert :: AlertId -> Handler ()
getCloseAlert = liftAssistant . removeAlert
{- When an alert with a button is clicked on, the button takes us here. -}
getClickAlert :: AlertId -> Handler ()
getClickAlert i = do
getClickAlert :: AlertId -> Int -> Handler ()
getClickAlert i bnum = do
m <- alertMap <$> liftAssistant getDaemonStatus
case M.lookup i m of
Just (Alert { alertButton = Just b }) -> do
{- Spawn a thread to run the action while redirecting. -}
case buttonAction b of
Nothing -> noop
Just a -> liftIO $ void $ forkIO $ a i
redirect $ buttonUrl b
Just (Alert { alertButtons = bs })
| length bs >= bnum -> do
let b = bs !! (bnum - 1)
{- Spawn a thread to run the action
- while redirecting. -}
case buttonAction b of
Nothing -> noop
Just a -> liftIO $ void $ forkIO $ a i
redirect $ buttonUrl b
| otherwise -> redirectBack
_ -> redirectBack
htmlIcon :: AlertIcon -> Widget

View file

@ -164,6 +164,10 @@ data RemovableDrive = RemovableDrive
data RepoKey = RepoKey KeyId | NoRepoKey
deriving (Read, Show, Eq, Ord)
instance PathPiece Bool where
toPathPiece = pack . show
fromPathPiece = readish . unpack
instance PathPiece RemovableDrive where
toPathPiece = pack . show
fromPathPiece = readish . unpack

View file

@ -22,7 +22,7 @@
/config/fsck ConfigFsckR GET POST
/config/fsck/preferences ConfigFsckPreferencesR POST
/config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
/config/upgrade/finish ConfigFinishUpgradeR GET
/config/upgrade/finish/#Bool ConfigFinishUpgradeR GET
/config/addrepository AddRepositoryR GET
/config/repository/new NewRepositoryR GET POST
@ -103,7 +103,7 @@
/notifier/repolist/#RepoSelector NotifierRepoListR GET
/alert/close/#AlertId CloseAlert GET
/alert/click/#AlertId ClickAlert GET
/alert/click/#AlertId/#Int ClickAlert GET
/filebrowser FileBrowserR GET POST
/transfer/pause/#Transfer PauseTransferR GET POST