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.

17 files changed, 74 insertions, 39 deletions

diff --git a/Assistant/Alert.hs b/Assistant/Alert.hs
index 7e47e8396..9e248571d 100644
--- a/Assistant/Alert.hs
+++ b/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" ]
diff --git a/Assistant/Threads/Cronner.hs b/Assistant/Threads/Cronner.hs
index b2be122d8..6399de514 100644
--- a/Assistant/Threads/Cronner.hs
+++ b/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
diff --git a/Assistant/Threads/Transferrer.hs b/Assistant/Threads/Transferrer.hs
index 82f3f3e10..0bc419e15 100644
--- a/Assistant/Threads/Transferrer.hs
+++ b/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
diff --git a/Git/Repair.hs b/Git/Repair.hs
index 984378bbb..fb877bfb7 100644
--- a/Git/Repair.hs
+++ b/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
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index d2c3038af..4e89dcff2 100644
--- a/Remote/Bup.hs
+++ b/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
diff --git a/Remote/Directory.hs b/Remote/Directory.hs
index cee4d6a0a..16535070e 100644
--- a/Remote/Directory.hs
+++ b/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,
diff --git a/Remote/GCrypt.hs b/Remote/GCrypt.hs
index 89d2c431f..a421668f8 100644
--- a/Remote/GCrypt.hs
+++ b/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
diff --git a/Remote/Git.hs b/Remote/Git.hs
index 480d4f714..ba247078b 100644
--- a/Remote/Git.hs
+++ b/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
diff --git a/Remote/Glacier.hs b/Remote/Glacier.hs
index 5cd224d19..300e682a7 100644
--- a/Remote/Glacier.hs
+++ b/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,
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 88c70e0cf..fdb24d0cb 100644
--- a/Remote/Hook.hs
+++ b/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,
diff --git a/Remote/Rsync.hs b/Remote/Rsync.hs
index b0ef318d3..6bc5fd78f 100644
--- a/Remote/Rsync.hs
+++ b/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
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 348b240d4..0933f30de 100644
--- a/Remote/S3.hs
+++ b/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,
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 23de73c27..7c98dbf40 100644
--- a/Remote/Web.hs
+++ b/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,
diff --git a/Remote/WebDAV.hs b/Remote/WebDAV.hs
index 1a722f147..738dbde3f 100644
--- a/Remote/WebDAV.hs
+++ b/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,
diff --git a/Types/Remote.hs b/Types/Remote.hs
index fedfb366a..9afcbbe55 100644
--- a/Types/Remote.hs
+++ b/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
diff --git a/debian/changelog b/debian/changelog
index 5aa553d67..7dacd465d 100644
--- a/debian/changelog
+++ b/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
 
diff --git a/doc/design/assistant/disaster_recovery.mdwn b/doc/design/assistant/disaster_recovery.mdwn
index 4acead36f..269be0fd8 100644
--- a/doc/design/assistant/disaster_recovery.mdwn
+++ b/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?)