assistant: Automatically repair damanged git repository, if it can be done without losing data.

Assistant/Repair.hs

@@ -5,29 +5,53 @@
  - Licensed under the GNU AGPL version 3 or higher.
  -}
 
-{-# LANGUAGE QuasiQuotes, TemplateHaskell, OverloadedStrings #-}
+{-# LANGUAGE CPP #-}
 
 module Assistant.Repair where
 
 import Assistant.Common
 import Command.Repair (repairAnnexBranch)
+import Git.Fsck (FsckResults)
 import Git.Repair (runRepairOf)
 import Logs.FsckResults
 import Annex.UUID
 import Utility.Batch
 import Config.Files
 import Assistant.Sync
+import Assistant.Alert
+import Assistant.DaemonStatus
+import Assistant.Types.UrlRenderer
+#ifdef WITH_WEBAPP
+import Assistant.WebApp.Types
+#endif
 
+import qualified Data.Text as T
 import Control.Concurrent.Async
 
-runRepair :: UUID -> Assistant ()
+{- Try to do a non-destructive repair. If that fails, pop up an alert. -}
-runRepair u = do
+brokenRepositoryDetected :: FsckResults -> UrlRenderer -> UUID -> Assistant ()
+brokenRepositoryDetected fsckresults urlrenderer u = do
+	liftAnnex $ writeFsckResults u fsckresults
+	handle =<< runRepair u False
+  where
+	handle True = return ()
+	handle False = do
+#ifdef WITH_WEBAPP
+		button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
+			RepairRepositoryR u
+		void $ addAlert $ brokenRepositoryAlert button
+#else
+		return ()
+#endif
+
+runRepair :: UUID -> Bool -> Assistant Bool
+runRepair u destructiverepair = do
 	-- Stop the watcher from running while running repairs.
 	changeSyncable Nothing False
 
 	fsckresults <- liftAnnex $ readFsckResults u
 	myu <- liftAnnex getUUID
-	if u == myu
+	ok <- if u == myu
 		then localrepair fsckresults
 		else remoterepair fsckresults
 	liftAnnex $ writeFsckResults u Nothing
@@ -36,20 +60,28 @@ runRepair u = do
 	-- 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
+	when ok $
+		changeSyncable Nothing True
+
+	return ok
   where
   	localrepair fsckresults = do
 		-- 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.
-		needfsck <- liftAnnex $ do
+		ok <- liftAnnex $ do
 			(ok, stillmissing, modifiedbranches) <- inRepo $
-				runRepairOf fsckresults True
+				runRepairOf fsckresults destructiverepair
-			repairAnnexBranch stillmissing modifiedbranches
+			when destructiverepair $
-			return (not ok)
+				repairAnnexBranch stillmissing modifiedbranches
-		when needfsck $
+			return ok
+		-- 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) $
 			backgroundfsck [ Param "--fast" ]
+		return ok
 
 	remoterepair _fsckresults = do
 		error "TODO: remote repair"

Assistant/Threads/Cronner.hs

@@ -33,7 +33,7 @@ import Assistant.WebApp.Types
 #endif
 import Git.Remote (RemoteName)
 import qualified Git.Fsck
-import Logs.FsckResults
+import Assistant.Repair
 
 import Control.Concurrent.Async
 import Control.Concurrent.MVar
@@ -189,12 +189,9 @@ runActivity' urlrenderer (ScheduledSelfFsck _ d) = do
 		r <- Git.Fsck.findBroken True g
 		void $ batchCommand program (Param "fsck" : annexFsckParams d)
 		return r
-	when (Git.Fsck.foundBroken fsckresults) $ do
+	when (Git.Fsck.foundBroken fsckresults) $
-		u <- liftAnnex getUUID
+		brokenRepositoryDetected fsckresults urlrenderer
-		liftAnnex $ writeFsckResults u fsckresults
+			=<< liftAnnex getUUID
-		button <- mkAlertButton True (T.pack "Click Here") urlrenderer $
-			RepairRepositoryR u
-		void $ addAlert $ brokenRepositoryAlert button
 	mapM_ reget =<< liftAnnex (dirKeys gitAnnexBadDir)
   where
 	reget k = queueTransfers "fsck found bad file; redownloading" Next k Nothing Download

Assistant/WebApp/Repair.hs

@@ -25,7 +25,7 @@ getRepairRepositoryRunR :: UUID -> Handler Html
 getRepairRepositoryRunR = postRepairRepositoryRunR
 postRepairRepositoryRunR :: UUID -> Handler Html
 postRepairRepositoryRunR u = do
-	liftAssistant $ runRepair u
+	void $ liftAssistant $ runRepair u True
 	page "Repair repository" Nothing $ do
 		let repolist = repoListDisplay $
 			mainRepoSelector { nudgeAddMore = True }

debian/changelog

@@ -8,6 +8,8 @@ git-annex (4.20131025) UNRELEASED; urgency=low
   * directory, webdav: Fix bug introduced in version 4.20131002 that
     caused the chunkcount file to not be written. Work around repositories
     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.
 
  -- Joey Hess <joeyh@debian.org>  Sat, 26 Oct 2013 12:11:48 -0400