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:
parent
56e980215f
commit
6abaf19c41
15 changed files with 136 additions and 75 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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 ()
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue