assistant: Support repairing git remotes that are locally accessible

(eg, on removable drives)

gcrypt remotes are not yet handled.

This commit was sponsored by Sören Brunk.

Assistant/Repair.hs

@@ -11,8 +11,11 @@ module Assistant.Repair where
 
 import Assistant.Common
 import Command.Repair (repairAnnexBranch)
-import Git.Fsck (FsckResults)
+import Git.Fsck (FsckResults, foundBroken)
 import Git.Repair (runRepairOf)
+import qualified Git
+import qualified Remote
+import qualified Types.Remote as Remote
 import Logs.FsckResults
 import Annex.UUID
 import Utility.Batch
@@ -28,11 +31,16 @@ import Assistant.WebApp.Types
 import qualified Data.Text as T
 import Control.Concurrent.Async
 
-{- Try to do a non-destructive repair. If that fails, pop up an alert. -}
-brokenRepositoryDetected :: FsckResults -> UrlRenderer -> UUID -> Assistant ()
-brokenRepositoryDetected fsckresults urlrenderer u = do
-	liftAnnex $ writeFsckResults u fsckresults
-	handle =<< runRepair u False
+{- When the FsckResults require a repair, tries to do a non-destructive
+ - repair. If that fails, pops up an alert. -}
+repairWhenNecessary :: UrlRenderer -> UUID -> Maybe Remote -> FsckResults -> Assistant ()
+repairWhenNecessary urlrenderer u mrmt fsckresults
+	| foundBroken fsckresults = do
+		liftAnnex $ writeFsckResults u fsckresults
+		repodesc <- liftAnnex $ Remote.prettyUUID u
+		handle =<< alertDuring (repairingAlert repodesc)
+			(runRepair u mrmt False)
+	| otherwise = noop
   where
 	handle True = return ()
 	handle False = do
@@ -44,47 +52,58 @@ brokenRepositoryDetected fsckresults urlrenderer u = do
 		return ()
 #endif
 
-runRepair :: UUID -> Bool -> Assistant Bool
-runRepair u destructiverepair = do
-	-- Stop the watcher from running while running repairs.
-	changeSyncable Nothing False
-
+runRepair :: UUID -> Maybe Remote -> Bool -> Assistant Bool
+runRepair u mrmt destructiverepair = do
 	fsckresults <- liftAnnex $ readFsckResults u
 	myu <- liftAnnex getUUID
 	ok <- if u == myu
 		then localrepair fsckresults
 		else remoterepair fsckresults
 	liftAnnex $ writeFsckResults u Nothing
-
-	-- 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.
-	when ok $
-		changeSyncable Nothing True
+	debug [ "Repaired", show u, show ok ]
 
 	return ok
   where
   	localrepair fsckresults = do
+		-- Stop the watcher from running while running repairs.
+		changeSyncable Nothing False
+
 		-- This intentionally runs the repair inside the Annex
 		-- monad, which is not strictly necessary, but keeps
 		-- other threads that might be trying to use the Annex
 		-- from running until it completes.
-		ok <- liftAnnex $ do
-			(ok, stillmissing, modifiedbranches) <- inRepo $
-				runRepairOf fsckresults destructiverepair
-			when destructiverepair $
-				repairAnnexBranch stillmissing modifiedbranches
-			return ok
+		ok <- liftAnnex $ repair fsckresults Nothing
+
 		-- Run a background fast fsck if a destructive repair had
 		-- to be done, to ensure that the git-annex branch
 		-- reflects the current state of the repo.
-		when (destructiverepair && not ok) $
+		when destructiverepair $
 			backgroundfsck [ Param "--fast" ]
+
+		-- 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.
+		when (ok || destructiverepair) $
+			changeSyncable Nothing True
+
 		return ok
 
-	remoterepair _fsckresults = do
-		error "TODO: remote repair"
+	remoterepair fsckresults = case Remote.repairRepo =<< mrmt of
+		Nothing -> return False
+		Just mkrepair -> do
+			thisrepopath <- liftIO . absPath
+				=<< liftAnnex (fromRepo Git.repoPath)
+			a <- liftAnnex $ mkrepair $
+				repair fsckresults (Just thisrepopath)
+			liftIO $ catchBoolIO a
+
+	repair fsckresults referencerepo = do
+		(ok, stillmissing, modifiedbranches) <- inRepo $
+			runRepairOf fsckresults destructiverepair referencerepo
+		when destructiverepair $
+			repairAnnexBranch stillmissing modifiedbranches
+		return ok
 	
 	backgroundfsck params = liftIO $ void $ async $ do
 		program <- readProgramFile