cleanup on failed upgrade

Assistant/Alert.hs

@@ -82,8 +82,8 @@ warningAlert name msg = Alert
 	, alertButtons = []
 	}
 
-errorAlert :: String -> AlertButton -> Alert
+errorAlert :: String -> [AlertButton] -> Alert
-errorAlert msg button = Alert
+errorAlert msg buttons = Alert
 	{ alertClass = Error
 	, alertHeader = Nothing
 	, alertMessageRender = renderData
@@ -95,7 +95,7 @@ errorAlert msg button = Alert
 	, alertIcon = Just ErrorIcon
 	, alertCombiner = Nothing
 	, alertName = Nothing
-	, alertButtons = [button]
+	, alertButtons = buttons
 	}
 
 activityAlert :: Maybe TenseText -> [TenseChunk] -> Alert
@@ -256,7 +256,11 @@ upgradeFinishedAlert button version =
 	baseUpgradeAlert (maybe [] (:[]) button) $ fromString $ 
 		"Finished upgrading git-annex to version " ++ version
 
-brokenRepositoryAlert :: AlertButton -> Alert
+upgradeFailedAlert :: String -> Alert
+upgradeFailedAlert msg = (errorAlert msg [])
+	{ alertHeader = Just $ fromString "Upgrade failed." }
+
+brokenRepositoryAlert :: [AlertButton] -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 
 repairingAlert :: String -> Alert

Assistant/Repair.hs

@@ -46,7 +46,7 @@ repairWhenNecessary urlrenderer u mrmt fsckresults
 		unless ok $ do
 			button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
 				RepairRepositoryR u
-			void $ addAlert $ brokenRepositoryAlert button
+			void $ addAlert $ brokenRepositoryAlert [button]
 #endif
 		return ok
 	| otherwise = return False

Assistant/Upgrade.hs

@@ -96,8 +96,7 @@ distributionDownloadComplete :: GitAnnexDistribution -> Assistant () -> Transfer
 distributionDownloadComplete d cleanup t 
 	| transferDirection t == Download = do
 		debug ["finished downloading git-annex distribution"]
-		maybe cleanup (upgradeToDistribution d cleanup)
+		maybe cleanup go =<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
-			=<< liftAnnex (withObjectLoc k fsckit (getM fsckit))
 	| otherwise = cleanup
   where
 	k = distributionKey d
@@ -109,6 +108,13 @@ distributionDownloadComplete d cleanup t
 				( return $ Just f
 				, return Nothing
 				)
+	go f = do
+		ua <- asIO $ upgradeToDistribution d cleanup f
+		fa <- asIO1 failedupgrade
+		liftIO $ ua `catchNonAsync` fa
+	failedupgrade e = do
+		cleanup
+		void $ addAlert $ upgradeFailedAlert $ show e
 
 {- The upgrade method varies by OS.
  -
@@ -144,9 +150,11 @@ upgradeToDistribution d cleanup f = do
 	 - into place. -}
 	unpack = liftIO $ do
 		olddir <- parentDir <$> readProgramFile
+		when (null olddir) $
+			error $ "Cannot find old distribution bundle; not upgrading."
 		newdir <- newVersionLocation d olddir "git-annex.linux."
 		whenM (doesDirectoryExist newdir) $
-			error $ "upgrade destination directory " ++ newdir ++ "already exists; not overwriting"
+			error $ "Upgrade destination directory " ++ newdir ++ "already exists; not overwriting."
 		withTmpDirIn (parentDir newdir) "git-annex.upgrade" $ \tmpdir -> do
 			let tarball = tmpdir </> "tar"
 			-- Cannot rely on filename extension, and this also