better UI flow through upgrade process

Move button to enable automatic upgrades to an alert displayed after
successful upgrade. Unclutters the UI and makes psychological sense.

Assistant/Alert.hs

@@ -15,6 +15,7 @@ import Assistant.Alert.Utility
 import qualified Remote
 import Utility.Tense
 import Logs.Transfer
+import Types.Distribution
 
 import Data.String
 import qualified Data.Text as T
@@ -216,44 +217,42 @@ notFsckedAlert mr button = Alert
 	, alertData = []
 	}
 
-canUpgradeAlert :: AlertPriority -> AlertButton -> Alert
+baseUpgradeAlert :: AlertButton -> TenseText -> Alert
-canUpgradeAlert priority button = Alert
+baseUpgradeAlert button message = Alert
-	{ alertHeader = Just $ fromString $
+	{ alertHeader = Just message
-		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
+	, alertPriority = High
 	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
 	, alertCounter = 0
 	, alertBlockDisplay = True
-	, alertName = Just CanUpgradeAlert
+	, alertName = Just UpgradeAlert
-	, alertCombiner = Just $ dataCombiner $ \_old new -> new
+	, alertCombiner = Just $ fullCombiner $ \new _old -> new
 	, alertData = []
 	}
 
-upgradeReadyAlert :: [AlertButton] -> Alert
+canUpgradeAlert :: AlertPriority -> AlertButton -> Alert
-upgradeReadyAlert buttons = Alert
+canUpgradeAlert priority button = 
-	{ alertHeader = Just $ fromString
+	(baseUpgradeAlert button $ fromString msg)
-		"A new version of git-annex has been installed."
+		{ alertPriority = priority }
-	, alertIcon = Just UpgradeIcon
+  where
-	, alertPriority = High
+	msg = if priority >= High
-	, alertButtons = buttons
+		then "An important upgrade of git-annex is available!"
-	, alertClosable = True
+		else "An upgrade of git-annex is available."
-	, alertClass = Message
+
-	, alertMessageRender = renderData
+upgradeReadyAlert :: AlertButton -> Alert
-	, alertCounter = 0
+upgradeReadyAlert button = baseUpgradeAlert button $
-	, alertBlockDisplay = True
+	fromString "A new version of git-annex has been installed."
-	, alertName = Just UpgradeReadyAlert
-	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertData = []
-	}
 
 upgradingAlert :: Alert
-upgradingAlert = activityAlert Nothing [fromString "Upgrading git-annex"]
+upgradingAlert = activityAlert Nothing [ fromString "Upgrading git-annex" ]
+
+upgradeFinishedAlert :: AlertButton -> GitAnnexVersion -> Alert
+upgradeFinishedAlert button version =
+	baseUpgradeAlert button $ fromString $ 
+		"Finished upgrading git-annex to version " ++ version
 
 brokenRepositoryAlert :: AlertButton -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"

Assistant/Threads/UpgradeWatcher.hs

@@ -23,6 +23,7 @@ import Assistant.Alert
 import Assistant.DaemonStatus
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
+import qualified Build.SysConfig
 #endif
 import qualified Annex
 import Types.Distribution
@@ -35,7 +36,10 @@ data WatcherState = InStartupScan | Started | Upgrading
 	deriving (Eq)
 
 upgradWatcherThread :: UrlRenderer -> NamedThread
-upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ go =<< liftIO programPath
+upgradWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
+	whenM (liftIO $ checkSuccessfulUpgrade) $
+		showSuccessfulUpgrade urlrenderer
+	go =<< liftIO programPath
   where
 	go Nothing = debug [ "cannot determine program path" ]
 	go (Just program) = do
@@ -80,7 +84,7 @@ changedFile urlrenderer mvar program file _status
  -}
 sanityCheck :: FilePath -> Assistant Bool
 sanityCheck program = do
-	untilM (liftIO $ nowriter <&&> present) $ do
+	untilM (liftIO $ present <&&> nowriter) $ do
 		debug [program, "is still being written; waiting"]
 		liftIO $ threadDelaySeconds (Seconds 60)
 	debug [program, "has changed, and seems to be ready to run"]
@@ -104,11 +108,20 @@ handleUpgrade urlrenderer = do
 			unattendedUpgrade
 #ifdef WITH_WEBAPP
 		, do
-			finish <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer (ConfigFinishUpgradeR False)
+			button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
-			noask <- mkAlertButton True (T.pack "Always Upgrade Automatically") urlrenderer (ConfigFinishUpgradeR True)
+			void $ addAlert $ upgradeReadyAlert button
-			void $ addAlert $ upgradeReadyAlert
-				[finish, noask { buttonPrimary = False }]
 #else
 		, noop
 #endif
 		)
+
+showSuccessfulUpgrade :: UrlRenderer -> Assistant ()
+showSuccessfulUpgrade urlrenderer = do
+#ifdef WITH_WEBAPP
+	button <- mkAlertButton True
+		(T.pack "Enable Automatic Upgrades")
+		urlrenderer ConfigEnableAutomaticUpgradeR
+	void $ addAlert $ upgradeFinishedAlert button Build.SysConfig.packageversion
+#else
+	noop
+#endif

Assistant/Types/Alert.hs

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

Assistant/Upgrade.hs

@@ -14,6 +14,7 @@ import Assistant.Alert
 import Assistant.DaemonStatus
 import Assistant.NamedThread
 import Utility.ThreadScheduler
+import Utility.Env
 import Git
 import Config.Files
 
@@ -32,6 +33,7 @@ prepUpgrade = do
 	liftIO . maybe noop (`throwTo` PauseWatcher) =<< namedThreadId watchThread
 	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexUrlFile)
 	liftIO . nukeFile =<< liftAnnex (fromRepo gitAnnexPidFile)
+	void $ liftIO $ setEnv upgradedEnv "1" True
 
 {- Wait for browser to update before terminating this process. -}
 postUpgrade :: IO ()
@@ -59,3 +61,9 @@ 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"

Assistant/WebApp/Configurators/Upgrade.hs

@@ -35,13 +35,16 @@ getConfigStartUpgradeR d = page "Upgrade git-annex" (Just Configuration) $ do
  - the others will show the upgradingAlert, and keep running until
  - this process is terminated.
  -}
-getConfigFinishUpgradeR :: Bool -> Handler Html
+getConfigFinishUpgradeR :: Handler Html
-getConfigFinishUpgradeR enableautoupgrade = do
+getConfigFinishUpgradeR = do
-	when enableautoupgrade $ liftAnnex $
-		setConfig (annexConfig "autoupgrade")
-			(fromAutoUpgrade AutoUpgrade)
 	liftAssistant prepUpgrade
 	liftIO postUpgrade `after` startnewprocess
   where
 	startnewprocess = switchToAssistant
 		=<< liftAnnex (repoLocation <$> Annex.gitRepo)
+
+getConfigEnableAutomaticUpgradeR :: Handler Html
+getConfigEnableAutomaticUpgradeR = do
+	liftAnnex $ setConfig (annexConfig "autoupgrade")
+		(fromAutoUpgrade AutoUpgrade)
+	redirect DashboardR

Assistant/WebApp/routes

@@ -22,7 +22,8 @@
 /config/fsck ConfigFsckR GET POST
 /config/fsck/preferences ConfigFsckPreferencesR POST
 /config/upgrade/start/#GitAnnexDistribution ConfigStartUpgradeR GET
-/config/upgrade/finish/#Bool ConfigFinishUpgradeR GET
+/config/upgrade/finish ConfigFinishUpgradeR GET
+/config/upgrade/automatically ConfigEnableAutomaticUpgradeR GET
 
 /config/addrepository AddRepositoryR GET
 /config/repository/new NewRepositoryR GET POST