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/Alert.hs

@@ -177,6 +177,12 @@ fsckAlert button n = baseActivityAlert
 brokenRepositoryAlert :: AlertButton -> Alert
 brokenRepositoryAlert = errorAlert "Serious problems have been detected with your repository. This needs your immediate attention!"
 
+repairingAlert :: String -> Alert
+repairingAlert repodesc = activityAlert Nothing
+	[ Tensed "Attempting to repair" "Repaired"
+	, UnTensed $ T.pack repodesc
+	]
+
 pairingAlert :: AlertButton -> Alert
 pairingAlert button = baseActivityAlert
 	{ alertData = [ UnTensed "Pairing in progress" ]

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

Assistant/Threads/Cronner.hs

@@ -28,12 +28,14 @@ import Logs.Transfer
 import Assistant.Types.UrlRenderer
 import Assistant.Alert
 import Remote
+import qualified Types.Remote as Remote
 #ifdef WITH_WEBAPP
 import Assistant.WebApp.Types
 #endif
 import Git.Remote (RemoteName)
 import qualified Git.Fsck
 import Assistant.Repair
+import qualified Git
 
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
@@ -186,34 +188,39 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
 	program <- liftIO $ readProgramFile
 	g <- liftAnnex gitRepo
 	fsckresults <- showFscking urlrenderer Nothing $ tryNonAsync $ do
-		r <- Git.Fsck.findBroken True g
 		void $ batchCommand program (Param "fsck" : annexFsckParams d)
-		return r
-	when (Git.Fsck.foundBroken fsckresults) $
-		brokenRepositoryDetected fsckresults urlrenderer
-			=<< liftAnnex getUUID
+		Git.Fsck.findBroken True g
+	u <- liftAnnex getUUID
+	repairWhenNecessary urlrenderer u Nothing fsckresults
 	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
   where
 	reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download
-runActivity' urlrenderer (ScheduledRemoteFsck u s d) = go =<< liftAnnex (remoteFromUUID u)
+runActivity' urlrenderer (ScheduledRemoteFsck u s d) = handle =<< liftAnnex (remoteFromUUID u)
   where
-	go (Just r) = void $ case Remote.remoteFsck r of
-		Nothing -> void $ showFscking urlrenderer (Just $ Remote.name r) $ tryNonAsync $ do
+	handle Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
+	handle (Just rmt) = void $ case Remote.remoteFsck rmt of
+		Nothing -> go rmt $ do
 			program <- readProgramFile
-			batchCommand program $ 
+			void $ batchCommand program $ 
 				[ Param "fsck"
 				-- avoid downloading files
 				, Param "--fast"
 				, Param "--from"
-				, Param $ Remote.name r
+				, Param $ Remote.name rmt
 				] ++ annexFsckParams d
-		Just mkfscker ->
+		Just mkfscker -> do
 			{- Note that having mkfsker return an IO action
 			 - avoids running a long duration fsck in the
 			 - Annex monad. -}
-			void . showFscking urlrenderer (Just $ Remote.name r) . tryNonAsync
-				=<< liftAnnex (mkfscker (annexFsckParams d))
-	go Nothing = debug ["skipping remote fsck of uuid without a configured remote", fromUUID u, fromSchedule s]
+			go rmt =<< liftAnnex (mkfscker (annexFsckParams d))
+	go rmt annexfscker = do
+		fsckresults <- showFscking urlrenderer (Just $ Remote.name rmt) $ tryNonAsync $ do
+			void annexfscker
+			let r = Remote.repo rmt
+			if Git.repoIsLocal r && not (Git.repoIsLocalUnknown r)
+				then Just <$> Git.Fsck.findBroken True r
+				else pure Nothing
+		maybe noop (repairWhenNecessary urlrenderer u (Just rmt)) fsckresults
 
 showFscking :: UrlRenderer -> Maybe RemoteName -> IO (Either E.SomeException a) -> Assistant a
 showFscking urlrenderer remotename a = do

Assistant/Threads/Transferrer.hs

@@ -8,23 +8,10 @@
 module Assistant.Threads.Transferrer where
 
 import Assistant.Common
-import Assistant.DaemonStatus
 import Assistant.TransferQueue
 import Assistant.TransferSlots
-import Assistant.Alert
-import Assistant.Alert.Utility
-import Assistant.Commits
-import Assistant.Drop
-import Assistant.TransferrerPool
 import Logs.Transfer
-import Logs.Location
-import Annex.Content
-import qualified Remote
-import qualified Types.Remote as Remote
-import qualified Git
 import Config.Files
-import Assistant.Threads.TransferWatcher
-import Annex.Wanted
 
 {- Dispatches transfers from the queue. -}
 transfererThread :: NamedThread

Assistant/WebApp/Configurators/Delete.hs

@@ -11,7 +11,6 @@ module Assistant.WebApp.Configurators.Delete where
 
 import Assistant.WebApp.Common
 import Assistant.DeleteRemote
-import Assistant.WebApp.Utility
 import Assistant.DaemonStatus
 import Assistant.ScanRemotes
 import Assistant.Sync

Assistant/WebApp/Repair.hs

@@ -11,7 +11,8 @@ module Assistant.WebApp.Repair where
 
 import Assistant.WebApp.Common
 import Assistant.WebApp.RepoList
-import Remote (prettyUUID)
+import Remote (prettyUUID, remoteFromUUID)
+import Annex.UUID (getUUID)
 import Assistant.Repair
 
 getRepairRepositoryR :: UUID -> Handler Html
@@ -19,13 +20,15 @@ getRepairRepositoryR = postRepairRepositoryR
 postRepairRepositoryR :: UUID -> Handler Html
 postRepairRepositoryR u = page "Repair repository" Nothing $ do
 	repodesc <- liftAnnex $ prettyUUID u
+	repairingmainrepo <- (==) u <$> liftAnnex getUUID
 	$(widgetFile "control/repairrepository")
 
 getRepairRepositoryRunR :: UUID -> Handler Html
 getRepairRepositoryRunR = postRepairRepositoryRunR
 postRepairRepositoryRunR :: UUID -> Handler Html
 postRepairRepositoryRunR u = do
-	void $ liftAssistant $ runRepair u True
+	r <- liftAnnex $ remoteFromUUID u
+	void $ liftAssistant $ runRepair u r True
 	page "Repair repository" Nothing $ do
 		let repolist = repoListDisplay $
 			mainRepoSelector { nudgeAddMore = True }