assistant restart on upgrade

Assistant.hs

@@ -153,7 +153,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
 #endif
 				, assist $ netWatcherThread
 				, assist $ upgraderThread urlrenderer
-				, assist $ upgradWatcherThread
+				, assist $ upgradWatcherThread urlrenderer
 				, assist $ netWatcherFallbackThread
 				, assist $ transferScannerThread urlrenderer
 				, assist $ cronnerThread urlrenderer

Assistant/Alert.hs

@@ -217,11 +217,10 @@ notFsckedAlert mr button = Alert
 
 canUpgradeAlert :: AlertPriority -> AlertButton -> Alert
 canUpgradeAlert priority button = Alert
-	{ alertHeader = Just $ fromString $ concat
+	{ alertHeader = Just $ fromString $
-		[ if priority >= High
+		if priority >= High
 			then "An important upgrade of git-annex is available!"
 			else "An upgrade of git-annex is available."
-		]
 	, alertIcon = Just UpgradeIcon
 	, alertPriority = priority
 	, alertButton = Just button
@@ -230,11 +229,31 @@ canUpgradeAlert priority button = Alert
 	, alertMessageRender = renderData
 	, alertCounter = 0
 	, alertBlockDisplay = True
-	, alertName = Just UpgradeAlert
+	, alertName = Just CanUpgradeAlert
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertData = []
 	}
 
+upgradeReadyAlert :: AlertButton -> Alert
+upgradeReadyAlert button = Alert
+	{ alertHeader = Just $ fromString
+		"A new version of git-annex has been installed."
+	, alertIcon = Just UpgradeIcon
+	, alertPriority = High
+	, alertButton = Just button
+	, alertClosable = True
+	, alertClass = Message
+	, alertMessageRender = renderData
+	, alertCounter = 0
+	, alertBlockDisplay = True
+	, alertName = Just UpgradeReadyAlert
+	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertData = []
+	}
+
+upgradingAlert :: Alert
+upgradingAlert = activityAlert Nothing [fromString "Upgrading git-annex"]
+
 brokenRepositoryAlert :: AlertButton -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 

Assistant/Threads/UpgradeWatcher.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE CPP #-}
+
 module Assistant.Threads.UpgradeWatcher (
 	upgradWatcherThread
 ) where
@@ -13,19 +15,29 @@ import Assistant.Common
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import Config.Files
+import qualified Utility.Lsof as Lsof
+import Utility.ThreadScheduler
+import Assistant.Types.UrlRenderer
+import Assistant.Alert
+import Assistant.DaemonStatus
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
 
 import Control.Concurrent.MVar
+import Data.Tuple.Utils
+import qualified Data.Text as T
 
 data WatcherState = InStartupScan | Started | Upgrading
 	deriving (Eq)
 
-upgradWatcherThread :: NamedThread
+upgradWatcherThread :: UrlRenderer -> NamedThread
-upgradWatcherThread = namedThread "UpgradeWatcher" $ go =<< liftIO programPath
+upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ go =<< liftIO programPath
   where
 	go Nothing = debug [ "cannot determine program path" ]
 	go (Just program) = do
 		mvar <- liftIO $ newMVar InStartupScan
-		changed <- Just <$> asIO2 (changedFile mvar program)
+		changed <- Just <$> asIO2 (changedFile urlrenderer mvar program)
 		let hooks = mkWatchHooks
 			{ addHook = changed
 			, addSymlinkHook = changed
@@ -42,10 +54,44 @@ upgradWatcherThread = namedThread "UpgradeWatcher" $ go =<< liftIO programPath
 		void $ swapMVar mvar Started
 		return r
 
-changedFile :: MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
+changedFile :: UrlRenderer -> MVar WatcherState -> FilePath -> FilePath -> Maybe FileStatus -> Assistant ()
-changedFile mvar program file _status
+changedFile urlrenderer mvar program file _status
-	| program == file = do
+	| program /= file = noop
+	| otherwise = do
 		state <- liftIO $ readMVar mvar
-		when (state == Started) $
+		when (state == Started) $ do
-			debug [ "saw change to", file ]
+			setstate Upgrading
-	| otherwise = noop
+			ifM (sanityCheck program)
+				( handleUpgrade urlrenderer
+				, do
+					debug ["new version of", program, "failed sanity check; not using"]
+					setstate Started
+				)
+  where
+	setstate = void . liftIO . swapMVar mvar
+
+{- The program's file has been changed. Before restarting,
+ - it needs to not be open for write by anything, and should run
+ - successfully when run with the parameter "version".
+ -}
+sanityCheck :: FilePath -> Assistant Bool
+sanityCheck program = do
+	whileM (liftIO haswriter) $ do
+		debug [program, "is still being written; waiting"]
+		liftIO $ threadDelaySeconds (Seconds 60)
+	debug [program, "has changed, and seems to be ready to run"]
+	liftIO $ boolSystem program [Param "version"]
+  where
+	haswriter = not . null
+		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
+		. map snd3
+		<$> Lsof.query [program]
+
+handleUpgrade :: UrlRenderer -> Assistant ()
+handleUpgrade urlrenderer = do
+#ifdef WITH_WEBAPP
+	button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
+	void $ addAlert (upgradeReadyAlert button)
+#else
+	noop
+#endif

Assistant/Threads/Upgrader.hs

@@ -73,7 +73,7 @@ checkUpgrade urlrenderer = do
 canUpgrade :: AlertPriority -> UrlRenderer -> GitAnnexDistribution -> Assistant ()
 canUpgrade urgency urlrenderer d = do
 #ifdef WITH_WEBAPP
-	button <- mkAlertButton False (T.pack "Upgrade") urlrenderer (ConfigUpgradeR d)
+	button <- mkAlertButton True (T.pack "Upgrade") urlrenderer (ConfigStartUpgradeR d)
 	void $ addAlert (canUpgradeAlert urgency button)
 #else
 	noop

Assistant/Types/Alert.hs

@@ -31,7 +31,8 @@ data AlertName
 	| CloudRepoNeededAlert
 	| SyncAlert
 	| NotFsckedAlert
-	| UpgradeAlert
+	| CanUpgradeAlert
+	| UpgradeReadyAlert
 	deriving (Eq)
 
 {- The first alert is the new alert, the second is an old alert.

Assistant/WebApp/Configurators/Upgrade.hs

@@ -10,15 +10,47 @@
 module Assistant.WebApp.Configurators.Upgrade where
 
 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 Utility.HumanTime
+import Git
 
 import Data.Time.Clock
+import Control.Concurrent
 
-getConfigUpgradeR :: GitAnnexDistribution -> Handler Html
+getConfigStartUpgradeR :: GitAnnexDistribution -> Handler Html
-getConfigUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
+getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
 	now <- liftIO getCurrentTime
 	let upgradeage = Duration $ floor $
 		now `diffUTCTime` distributionReleasedate d
-	$(widgetFile "configurators/upgrade")
+	$(widgetFile "configurators/upgrade/start")
 
+{- 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.
+ -}
+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)
+	ret <- switchToAssistant =<< liftAnnex (repoLocation <$> Annex.gitRepo)
+	void . liftIO . forkIO =<< liftAssistant (asIO reaper)
+	return ret
+  where
+	-- Wait for the redirect to be served to the browser
+	-- before terminating this process.
+	reaper = do
+		liftIO $ threadDelaySeconds (Seconds 120)
+		liftIO $ exitSuccess

Assistant/WebApp/OtherRepos.hs

@@ -35,14 +35,17 @@ listOtherRepos = do
 	names <- mapM relHome gooddirs
 	return $ sort $ zip names gooddirs
 
-{- 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.
- -}
 getSwitchToRepositoryR :: FilePath -> Handler Html
 getSwitchToRepositoryR repo = do
-	liftIO $ startAssistant repo
 	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

Assistant/WebApp/routes

@@ -21,7 +21,8 @@
 /config/xmpp/needcloudrepo/#UUID NeedCloudRepoR GET
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
-/config/upgrade/#GitAnnexDistribution ConfigUpgradeR GET
+/config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
+/config/upgrade/finish ConfigFinishUpgradeR GET
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST