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 }

Git/Repair.hs

@@ -124,9 +124,13 @@ explodePacks r = do
 
 {- Try to retrieve a set of missing objects, from the remotes of a
  - repository. Returns any that could not be retreived.
+ - 
+ - If another clone of the repository exists locally, which might not be a
+ - remote of the repo being repaired, its path can be passed as a reference
+ - repository.
  -}
-retrieveMissingObjects :: MissingObjects -> Repo -> IO MissingObjects
-retrieveMissingObjects missing r
+retrieveMissingObjects :: MissingObjects -> Maybe FilePath -> Repo -> IO MissingObjects
+retrieveMissingObjects missing referencerepo r
 	| S.null missing = return missing
 	| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
 		unlessM (boolSystem "git" [Params "init", File tmpdir]) $
@@ -137,12 +141,19 @@ retrieveMissingObjects missing r
 			then return stillmissing
 			else pullremotes tmpr (remotes r) fetchallrefs stillmissing
   where
-	pullremotes _tmpr [] _ stillmissing = return stillmissing
+	pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
+		Nothing -> return stillmissing
+		Just p -> ifM (fetchfrom p fetchrefs tmpr)
+			( do
+				void $ copyObjects tmpr r
+				findMissing (S.toList stillmissing) r
+			, return stillmissing
+			)
 	pullremotes tmpr (rmt:rmts) fetchrefs s
 		| S.null s = return s
 		| otherwise = do
 			putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt
-			ifM (fetchsome rmt fetchrefs tmpr)
+			ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
 				( do
 					void $ copyObjects tmpr r
 					stillmissing <- findMissing (S.toList s) r
@@ -155,9 +166,9 @@ retrieveMissingObjects missing r
 						]
 					pullremotes tmpr rmts fetchrefs s
 				)
-	fetchsome rmt ps = runBool $
+	fetchfrom fetchurl ps = runBool $
 		[ Param "fetch"
-		, Param (repoLocation rmt)
+		, Param fetchurl
 		, Params "--force --update-head-ok --quiet"
 		] ++ ps
 	-- fetch refs and tags
@@ -427,14 +438,15 @@ runRepair forced g = do
 	putStrLn "Running git fsck ..."
 	fsckresult <- findBroken False g
 	if foundBroken fsckresult
-		then runRepairOf fsckresult forced g
+		then runRepairOf fsckresult forced Nothing g
 		else do
 			putStrLn "No problems found."
 			return (True, S.empty, [])
-runRepairOf :: FsckResults -> Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
-runRepairOf fsckresult forced g = do
+
+runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepairOf fsckresult forced referencerepo g = do
 	missing <- cleanCorruptObjects fsckresult g
-	stillmissing <- retrieveMissingObjects missing g
+	stillmissing <- retrieveMissingObjects missing referencerepo g
 	if S.null stillmissing
 		then successfulfinish stillmissing []
 		else do

Remote/Bup.hs

@@ -64,6 +64,7 @@ gen r u c gc = do
 		, hasKeyCheap = bupLocal buprepo
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
+		, repairRepo = Nothing
 		, config = c
 		, repo = r
 		, gitconfig = gc

Remote/Directory.hs

@@ -55,6 +55,7 @@ gen r u c gc = do
 			hasKeyCheap = True,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
+			repairRepo = Nothing,
 			config = M.empty,
 			repo = r,
 			gitconfig = gc,

Remote/GCrypt.hs

@@ -108,6 +108,7 @@ gen' r u c gc = do
 		, hasKeyCheap = repoCheap r
 		, whereisKey = Nothing
 		, remoteFsck = Nothing
+		, repairRepo = Nothing
 		, config = M.empty
 		, localpath = localpathCalc r
 		, repo = r

Remote/Git.hs

@@ -117,6 +117,9 @@ gen r u c gc
 			, remoteFsck = if Git.repoIsUrl r
 				then Nothing
 				else Just $ fsckOnRemote r
+			, repairRepo = if Git.repoIsUrl r
+				then Nothing
+				else Just $ repairRemote r
 			, config = M.empty
 			, localpath = localpathCalc r
 			, repo = r
@@ -419,6 +422,10 @@ fsckOnRemote r params
 			] ++ env
 		batchCommandEnv program (Param "fsck" : params) (Just env')
 
+{- The passed repair action is run in the Annex monad of the remote. -}
+repairRemote :: Git.Repo -> Annex Bool -> Annex (IO Bool)
+repairRemote r a = return $ Remote.Git.onLocal r a
+
 {- Runs an action on a local repository inexpensively, by making an annex
  - monad using that repository. -}
 onLocal :: Git.Repo -> Annex a -> IO a

Remote/Glacier.hs

@@ -60,6 +60,7 @@ gen r u c gc = new <$> remoteCost gc veryExpensiveRemoteCost
 			hasKeyCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
+			repairRepo = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,

Remote/Hook.hs

@@ -53,6 +53,7 @@ gen r u c gc = do
 			hasKeyCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
+			repairRepo = Nothing,
 			config = M.empty,
 			localpath = Nothing,
 			repo = r,

Remote/Rsync.hs

@@ -80,6 +80,7 @@ gen r u c gc = do
 			, hasKeyCheap = False
 			, whereisKey = Nothing
 			, remoteFsck = Nothing
+			, repairRepo = Nothing
 			, config = M.empty
 			, repo = r
 			, gitconfig = gc

Remote/S3.hs

@@ -63,6 +63,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			hasKeyCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
+			repairRepo = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,

Remote/Web.hs

@@ -57,6 +57,7 @@ gen r _ _ gc =
 		hasKeyCheap = False,
 		whereisKey = Just getUrls,
 		remoteFsck = Nothing,
+		repairRepo = Nothing,
 		config = M.empty,
 		gitconfig = gc,
 		localpath = Nothing,

Remote/WebDAV.hs

@@ -66,6 +66,7 @@ gen r u c gc = new <$> remoteCost gc expensiveRemoteCost
 			hasKeyCheap = False,
 			whereisKey = Nothing,
 			remoteFsck = Nothing,
+			repairRepo = Nothing,
 			config = c,
 			repo = r,
 			gitconfig = gc,

Types/Remote.hs

@@ -69,6 +69,8 @@ data RemoteA a = Remote {
 	-- without transferring all the data to the local repo
 	-- The parameters are passed to the fsck command on the remote.
 	remoteFsck :: Maybe ([CommandParam] -> a (IO Bool)),
+	-- Runs an action to repair the remote's git repository.
+	repairRepo :: Maybe (a Bool -> a (IO Bool)),
 	-- a Remote has a persistent configuration store
 	config :: RemoteConfig,
 	-- git repo for the Remote

debian/changelog

@@ -10,6 +10,8 @@ git-annex (4.20131025) UNRELEASED; urgency=low
     without such a file, so files can still be retreived from them.
   * assistant: Automatically repair damanged git repository, if it can
     be done without losing data.
+  * assistant: Support repairing git remotes that are locally accessible
+    (eg, on removable drives).
 
  -- Joey Hess <joeyh@debian.org>  Sat, 26 Oct 2013 12:11:48 -0400
 

doc/design/assistant/disaster_recovery.mdwn

@@ -59,8 +59,6 @@ call it for non-local remotes.
 
 Add git fsck to scheduled self fsck **done**
 
-TODO: Add git fsck of local remotes to scheduled remote fscks.
-
 TODO: git fsck on ssh remotes? Probably not worth the complexity..
 
 TODO: If committing to the repository fails, after resolving any dangling
@@ -71,6 +69,11 @@ If git fsck finds problems, launch git repository repair. **done**
 git annex fsck --fast at end of repository repair to ensure
 git-annex branch is accurate. **done**
 
+TODO: "Repair" gcrypt remotes, by removing all refs and objects,
+and re-pushing. (Since the objects are encrypted data, there is no way
+to pull missing ones from anywhere..) 
+Need to preserve gcrypt-id while doing this!
+
 TODO: along with displaying alert when there is a problem detected
 by consistency check, send an email alert. (Using system MTA?)
 

templates/control/repairrepository.hamlet

@@ -7,12 +7,13 @@
   <p>
     While this is not good, this problem can be automatically repaired,
     often without data loss.
-  <p>
-    When possible, the corrupt data will be recovered from other #
-    repositories. You should make sure any other repositories that might #
-    have this data are available before continuing. So, plug in any #
-    removable drive that contains a repository, or make sure your network #
-    connection to other repositories is active.
+  $if repairingmainrepo
+    <p>
+      When possible, the corrupt data will be recovered from other #
+      repositories. You should make sure any other repositories that might #
+      have this data are available before continuing. So, plug in any #
+      removable drive that contains a repository, or make sure your network #
+      connection to other repositories is active.
   <p>
     <a .btn .btn-primary href="@{RepairRepositoryRunR u}" onclick="$('#workingmodal').modal('show');">
       Start Repair Process