wire git repair into webapp

Assistant/WebApp/Repair.hs

@@ -10,7 +10,17 @@
 module Assistant.WebApp.Repair where
 
 import Assistant.WebApp.Common
+import Assistant.WebApp.Utility
+import Assistant.WebApp.RepoList
 import Remote (prettyUUID)
+import Command.Repair (repairAnnexBranch)
+import Git.Repair (runRepairOf)
+import Logs.FsckResults
+import Annex.UUID
+import Utility.Batch
+import Config.Files
+
+import Control.Concurrent.Async
 
 getRepairRepositoryR :: UUID -> Handler Html
 getRepairRepositoryR = postRepairRepositoryR
@@ -20,7 +30,51 @@ postRepairRepositoryR u = page "Repair repository" Nothing $ do
 	$(widgetFile "control/repairrepository")
 
 getRepairRepositoryRunR :: UUID -> Handler Html
-getRepairRepositoryRunR = postRepairRepositoryR
+getRepairRepositoryRunR = postRepairRepositoryRunR
 postRepairRepositoryRunR :: UUID -> Handler Html
-postRepairRepositoryRunR u = page "Repair repository" Nothing $ do
+postRepairRepositoryRunR u = do
-	$(widgetFile "control/repairrepository/run")
+	-- Stop the watcher from running while running repairs.
+	changeSyncable Nothing False
+
+	fsckthread <- liftAssistant $ runRepair u
+
+	-- Start the watcher running again. This also triggers it to do a
+	-- startup scan, which is especially important if the git repo
+	-- repair removed files from the index file. Those files will be
+	-- seen as new, and re-added to the repository.
+	changeSyncable Nothing True
+
+	liftAnnex $ writeFsckResults u Nothing
+
+	page "Repair repository" Nothing $ do
+		let repolist = repoListDisplay $
+			mainRepoSelector { nudgeAddMore = True }
+		$(widgetFile "control/repairrepository/done")
+
+runRepair :: UUID -> Assistant ()
+runRepair u = do
+	fsckresults <- liftAnnex (readFsckResults u)
+	myu <- liftAnnex getUUID
+	if u == myu
+		then localrepair fsckresults
+		else remoterepair fsckresults
+  where
+  	localrepair fsckresults = do
+		-- This intentionally runs the repair inside the Annex
+		-- monad, which is not stricktly necessary, but keeps
+		-- other threads that might be trying to use the Annex
+		-- from running until it completes.
+		needfsck <- liftAnnex $ do
+			(ok, stillmissing, modifiedbranches) <- inRepo $
+				runRepairOf fsckresults True
+			repairAnnexBranch stillmissing modifiedbranches
+			return (not ok)
+		when needfsck $
+			backgroundfsck [ Param "--fast" ]
+
+	remoterepair fsckresults = do
+		error "TODO: remote repair"
+	
+	backgroundfsck params = liftIO $ void $ async $ do
+		program <- readProgramFile
+		batchCommand program (Param "fsck" : params)

Command/Repair.hs

@@ -29,8 +29,7 @@ runRepair :: Bool -> Annex Bool
 runRepair forced = do
 	(ok, stillmissing, modifiedbranches) <- inRepo $
 		Git.Repair.runRepair forced
-	when ok $
+	repairAnnexBranch stillmissing modifiedbranches
-		repairAnnexBranch stillmissing modifiedbranches
 	return ok
 
 {- After git repository repair, the .git/annex/index file could

Git/Repair.hs

@@ -7,6 +7,7 @@
 
 module Git.Repair (
 	runRepair,
+	runRepairOf,
 	cleanCorruptObjects,
 	retrieveMissingObjects,
 	resetLocalBranches,
@@ -426,24 +427,25 @@ runRepair forced g = do
 	putStrLn "Running git fsck ..."
 	fsckresult <- findBroken False g
 	if foundBroken fsckresult
-		then makerepairs fsckresult
+		then runRepairOf fsckresult forced g
 		else do
 			putStrLn "No problems found."
 			return (True, S.empty, [])
+runRepairOf :: FsckResults -> Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepairOf fsckresult forced g = do
+	missing <- cleanCorruptObjects fsckresult g
+	stillmissing <- retrieveMissingObjects missing g
+	if S.null stillmissing
+		then successfulfinish stillmissing []
+		else do
+			putStrLn $ unwords
+				[ show (S.size stillmissing)
+				, "missing objects could not be recovered!"
+				]
+			if forced
+				then continuerepairs stillmissing
+				else unsuccessfulfinish stillmissing
   where
-	makerepairs fsckresult = do
-		missing <- cleanCorruptObjects fsckresult g
-		stillmissing <- retrieveMissingObjects missing g
-		if S.null stillmissing
-			then successfulfinish stillmissing []
-			else do
-				putStrLn $ unwords
-					[ show (S.size stillmissing)
-					, "missing objects could not be recovered!"
-					]
-				if forced
-					then continuerepairs stillmissing
-					else unsuccessfulfinish stillmissing
 	continuerepairs stillmissing = do
 		(remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g
 		unless (null remotebranches) $

templates/control/repairrepository/done.hamlet

@@ -0,0 +1,13 @@
+<div .span9 .hero-unit>
+  <p>
+    Good news: Your repository has successfully been repaired!
+  <p>
+    This problem could have had a variety of causes. If your computer #
+    lost power, or the drive containing this repository #
+    was disconnected, it would explain this type of problem.
+  <p>
+    On the other hand, it's possible that you have a hardware problem.
+  <p>
+    Remember: Lots of copies keep stuff safe! The more repositories you #
+    have, the less likely you are to lose data no matter what goes wrong.
+  ^{repolist}

templates/control/repairrepository/run.hamlet

@@ -1,3 +0,0 @@
-<div .span9 .hero-unit>
-  <p>
-    TODO