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.

Assistant/Alert.hs

@@ -42,6 +42,7 @@ mkAlertButton autoclose label urlrenderer route = do
 		{ buttonLabel = label
 		, buttonUrl = url
 		, buttonAction = if autoclose then Just close else Nothing
+		, buttonPrimary = True
 		}
 #endif
 
@@ -61,7 +62,7 @@ baseActivityAlert = Alert
 	, alertIcon = Just ActivityIcon
 	, alertCombiner = Nothing
 	, alertName = Nothing
-	, alertButton = Nothing
+	, alertButtons = []
 	}
 
 warningAlert :: String -> String -> Alert
@@ -77,7 +78,7 @@ warningAlert name msg = Alert
 	, alertIcon = Just ErrorIcon
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
 	, alertName = Just $ WarningAlert name
-	, alertButton = Nothing
+	, alertButtons = []
 	}
 
 errorAlert :: String -> AlertButton -> Alert
@@ -93,7 +94,7 @@ errorAlert msg button = Alert
 	, alertIcon = Just ErrorIcon
 	, alertCombiner = Nothing
 	, alertName = Nothing
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
@@ -160,7 +161,7 @@ sanityCheckFixAlert msg = Alert
 	, alertIcon = Just ErrorIcon
 	, alertName = Just SanityCheckFixAlert
 	, alertCombiner = Just $ dataCombiner (++)
-	, alertButton = Nothing
+	, alertButtons = []
 	}
   where
 	render alert = tenseWords $ alerthead : alertData alert ++ [alertfoot]
@@ -172,7 +173,7 @@ fsckingAlert button mr = baseActivityAlert
 	{ alertData = case mr of
 		Nothing -> [ UnTensed $ T.pack $ "Consistency check in progress" ]
 		Just r -> [ UnTensed $ T.pack $ "Consistency check of " ++ Remote.name r ++ " in progress"]
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 showFscking :: UrlRenderer -> Maybe Remote -> IO (Either E.SomeException a) -> Assistant a
@@ -204,7 +205,7 @@ notFsckedAlert mr button = Alert
 		]
 	, alertIcon = Just InfoIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -223,7 +224,7 @@ canUpgradeAlert priority button = Alert
 			else "An upgrade of git-annex is available."
 	, alertIcon = Just UpgradeIcon
 	, alertPriority = priority
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -234,13 +235,13 @@ canUpgradeAlert priority button = Alert
 	, alertData = []
 	}
 
-upgradeReadyAlert :: AlertButton -> Alert
-upgradeReadyAlert button = Alert
+upgradeReadyAlert :: [AlertButton] -> Alert
+upgradeReadyAlert buttons = Alert
 	{ alertHeader = Just $ fromString
 		"A new version of git-annex has been installed."
 	, alertIcon = Just UpgradeIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = buttons
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -267,7 +268,7 @@ pairingAlert :: AlertButton -> Alert
 pairingAlert button = baseActivityAlert
 	{ alertData = [ UnTensed "Pairing in progress" ]
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 pairRequestReceivedAlert :: String -> AlertButton -> Alert
@@ -283,7 +284,7 @@ pairRequestReceivedAlert who button = Alert
 	, alertIcon = Just InfoIcon
 	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertButton = Just button
+	, alertButtons = [button]
 	}
 
 pairRequestAcknowledgedAlert :: String -> Maybe AlertButton -> Alert
@@ -292,7 +293,7 @@ pairRequestAcknowledgedAlert who button = baseActivityAlert
 	, alertPriority = High
 	, alertName = Just $ PairAlert who
 	, alertCombiner = Just $ dataCombiner $ \_old new -> new
-	, alertButton = button
+	, alertButtons = maybe [] (:[]) button
 	}
 
 xmppNeededAlert :: AlertButton -> Alert
@@ -300,7 +301,7 @@ xmppNeededAlert button = Alert
 	{ alertHeader = Just "Share with friends, and keep your devices in sync across the cloud."
 	, alertIcon = Just TheCloud
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -319,7 +320,7 @@ cloudRepoNeededAlert friendname button = Alert
 		]
 	, alertIcon = Just ErrorIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData
@@ -337,7 +338,7 @@ remoteRemovalAlert desc button = Alert
 		"\" has been emptied, and can now be removed."
 	, alertIcon = Just InfoIcon
 	, alertPriority = High
-	, alertButton = Just button
+	, alertButtons = [button]
 	, alertClosable = True
 	, alertClass = Message
 	, alertMessageRender = renderData

Assistant/Alert/Utility.hs

@@ -87,7 +87,7 @@ makeAlertFiller success alert
 		{ alertClass = if c == Activity then c' else c
 		, alertPriority = Filler
 		, alertClosable = True
-		, alertButton = Nothing
+		, alertButtons = []
 		, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
 		}
   where

Assistant/NamedThread.hs

@@ -82,7 +82,7 @@ startNamedThread urlrenderer (NamedThread afterstartupsanitycheck name a) = do
 					(RestartThreadR name)
 				runAssistant d $ void $ addAlert $
 					(warningAlert (fromThreadName name) msg)
-						{ alertButton = Just button }
+						{ alertButtons = [button] }
 #endif
 
 namedThreadId :: NamedThread -> Assistant (Maybe ThreadId)

Assistant/Threads/UpgradeWatcher.hs

@@ -12,6 +12,7 @@ module Assistant.Threads.UpgradeWatcher (
 ) where
 
 import Assistant.Common
+import Assistant.Upgrade
 import Utility.DirWatcher
 import Utility.DirWatcher.Types
 import Config.Files
@@ -23,6 +24,8 @@ import Assistant.DaemonStatus
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 #endif
+import qualified Annex
+import Types.Distribution
 
 import Control.Concurrent.MVar
 import Data.Tuple.Utils
@@ -77,14 +80,14 @@ changedFile urlrenderer mvar program file _status
  -}
 sanityCheck :: FilePath -> Assistant Bool
 sanityCheck program = do
-	whileM (liftIO $ haswriter <||> missing) $ do
+	untilM (liftIO $ nowriter <&&> present) $ 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
-  	missing = not <$> doesFileExist program
-	haswriter = not . null
+	present = doesFileExist program
+	nowriter = null
 		. filter (`elem` [Lsof.OpenReadWrite, Lsof.OpenWriteOnly])
 		. map snd3
 		<$> Lsof.query [program]
@@ -95,9 +98,17 @@ handleUpgrade urlrenderer = do
 	-- (For example, other associated files may be being put into
 	-- place.)
 	liftIO $ threadDelaySeconds (Seconds 120)
+	ifM (liftAnnex $ (==) AutoUpgrade . annexAutoUpgrade <$> Annex.getGitConfig)
+		( do
+			debug ["starting automatic upgrade"]
+			unattendedUpgrade
 #ifdef WITH_WEBAPP
-	button <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer ConfigFinishUpgradeR
-	void $ addAlert (upgradeReadyAlert button)
+		, do
+			finish <- mkAlertButton True (T.pack "Finish Upgrade") urlrenderer (ConfigFinishUpgradeR False)
+			noask <- mkAlertButton True (T.pack "Always Upgrade Automatically") urlrenderer (ConfigFinishUpgradeR True)
+			void $ addAlert $ upgradeReadyAlert
+				[finish, noask { buttonPrimary = False }]
 #else
-	noop
+		, noop
 #endif
+		)

Assistant/Types/Alert.hs

@@ -51,7 +51,7 @@ data Alert = Alert
 	, alertIcon :: Maybe AlertIcon
 	, alertCombiner :: Maybe AlertCombiner
 	, alertName :: Maybe AlertName
-	, alertButton :: Maybe AlertButton
+	, alertButtons :: [AlertButton]
 	}
 
 data AlertIcon = ActivityIcon | SyncIcon | SuccessIcon | ErrorIcon | InfoIcon | UpgradeIcon | TheCloud
@@ -75,4 +75,5 @@ data AlertButton = AlertButton
 	{ buttonLabel :: Text
 	, buttonUrl :: Text
 	, buttonAction :: Maybe (AlertId -> IO ())
+	, buttonPrimary :: Bool
 	}

Assistant/Upgrade.hs

@@ -0,0 +1,61 @@
+{- 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

Assistant/WebApp/Configurators/Local.hs

@@ -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

Assistant/WebApp/Configurators/Pairing.hs

@@ -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

Assistant/WebApp/Configurators/Upgrade.hs

@@ -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)

Assistant/WebApp/Configurators/XMPP.hs

@@ -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 ()

Assistant/WebApp/OtherRepos.hs

@@ -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

Assistant/WebApp/SideBar.hs

@@ -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

Assistant/WebApp/Types.hs

@@ -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

Assistant/WebApp/routes

@@ -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

templates/sidebar/alert.hamlet

@@ -19,7 +19,8 @@
       #{l}<br>
   $else
     #{message}
-  $maybe button <- alertButton alert
+  $if not (null buttons)
     <br>
-    <a .btn .btn-primary href="@{ClickAlert aid}">
-      #{buttonLabel button}
+    $forall (button, bnum) <- buttons
+      <a .btn :buttonPrimary button:.btn-primary :not (buttonPrimary button):.btn-success href="@{ClickAlert aid bnum}">
+        #{buttonLabel button}