6abaf19c41
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.
61 lines
1.8 KiB
Haskell
61 lines
1.8 KiB
Haskell
{- git-annex assistant upgrading
|
|
-
|
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Assistant.Upgrade where
|
|
|
|
import Assistant.Common
|
|
import qualified Annex
|
|
import Assistant.Threads.Watcher
|
|
import Assistant.Alert
|
|
import Assistant.DaemonStatus
|
|
import Assistant.NamedThread
|
|
import Utility.ThreadScheduler
|
|
import Git
|
|
import Config.Files
|
|
|
|
import Control.Concurrent
|
|
import System.Posix (getProcessID, signalProcess, sigTERM)
|
|
import System.Process (cwd)
|
|
|
|
{- 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.
|
|
-}
|
|
prepUpgrade :: Assistant ()
|
|
prepUpgrade = do
|
|
void $ addAlert upgradingAlert
|
|
liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
|
|
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
|
|
liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
|
|
|
|
{- Wait for browser to update before terminating this process. -}
|
|
postUpgrade :: IO ()
|
|
postUpgrade = void $ 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.
|
|
-}
|
|
unattendedUpgrade :: Assistant ()
|
|
unattendedUpgrade = do
|
|
prepUpgrade
|
|
liftIO . startAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo)
|
|
liftIO postUpgrade
|
|
|
|
{- 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
|