repair command: add handling of git-annex branch and index

Annex/Branch.hs

@@ -20,6 +20,7 @@ module Annex.Branch (
 	get,
 	change,
 	commit,
+	forceCommit,
 	files,
 	withIndex,
 	performTransitions,
@@ -168,7 +169,7 @@ updateTo pairs = do
 				else inRepo $ Git.Branch.fastForward fullname refs
 			if ff
 				then updateIndex jl branchref
-				else commitBranch jl branchref merge_desc commitrefs
+				else commitIndex jl branchref merge_desc commitrefs
 		liftIO cleanjournal
 
 {- Gets the content of a file, which may be in the journal, or in the index
@@ -210,10 +211,15 @@ set = setJournalFile
 
 {- Stages the journal, and commits staged changes to the branch. -}
 commit :: String -> Annex ()
-commit message = whenM journalDirty $ lockJournal $ \jl -> do
+commit = whenM journalDirty . forceCommit
+
+{- Commits the current index to the branch even without any journalleda
+ - changes. -}
+forceCommit :: String -> Annex ()
+forceCommit message = lockJournal $ \jl -> do
 	cleanjournal <- stageJournal jl
 	ref <- getBranch
-	withIndex $ commitBranch jl ref message [fullname]
+	withIndex $ commitIndex jl ref message [fullname]
 	liftIO cleanjournal
 
 {- Commits the staged changes in the index to the branch.
@@ -234,12 +240,12 @@ commit message = whenM journalDirty $ lockJournal $ \jl -> do
  - previous point, though getting it a long time ago makes the race
  - more likely to occur.
  -}
-commitBranch :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
-commitBranch jl branchref message parents = do
+commitIndex :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex jl branchref message parents = do
 	showStoringStateAction
-	commitBranch' jl branchref message parents
-commitBranch' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
-commitBranch' jl branchref message parents = do
+	commitIndex' jl branchref message parents
+commitIndex' :: JournalLocked -> Git.Ref -> String -> [Git.Ref] -> Annex ()
+commitIndex' jl branchref message parents = do
 	updateIndex jl branchref
 	committedref <- inRepo $ Git.Branch.commit message fullname parents
 	setIndexSha committedref
@@ -265,7 +271,7 @@ commitBranch' jl branchref message parents = do
 	 - into the index, and recommit on top of the bad commit. -}
 	fixrace committedref lostrefs = do
 		mergeIndex jl lostrefs
-		commitBranch jl committedref racemessage [committedref]
+		commitIndex jl committedref racemessage [committedref]
 		
 	racemessage = message ++ " (recovery from race)"
 
@@ -482,7 +488,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
 				setIndexSha committedref
 			else do
 				ref <- getBranch
-				commitBranch jl ref message (nub $ fullname:transitionedrefs)
+				commitIndex jl ref message (nub $ fullname:transitionedrefs)
   where
   	message
 		| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc

Command/Repair.hs

@@ -10,7 +10,9 @@ module Command.Repair where
 import Common.Annex
 import Command
 import qualified Annex
-import Git.RecoverRepository (runRecovery)
+import qualified Git.Repair
+import qualified Annex.Branch
+import Git.Fsck (MissingObjects)
 
 def :: [Command]
 def = [noCommit $ dontCheck repoExists $
@@ -20,6 +22,37 @@ seek :: [CommandSeek]
 seek = [withNothing start]
 
 start :: CommandStart
-start = next $ next $ do
-	force <- Annex.getState Annex.force
-	inRepo $ runRecovery force
+start = next $ next $ runRepair =<< Annex.getState Annex.force
+
+runRepair :: Bool -> Annex Bool
+runRepair forced = do
+	(ok, stillmissing) <- inRepo $ Git.Repair.runRepair forced
+	when ok $
+		repairAnnexBranch stillmissing
+	return ok
+
+{- After git repository repair, the .git/annex/index file could
+ - still be broken, by pointing to bad objects, or might just be corrupt on
+ - its own. Since this index file is not used to stage things
+ - for long durations of time, it can safely be deleted if it is broken.
+ -
+ - Otherwise, commit the index file to the git-annex branch.
+ - This way, if the git-annex branch got rewound to an old version by
+ - the repository repair, or was completely deleted, this will get it back
+ - to a good state. Note that in the unlikely case where the git-annex
+ - branch is ok, and has new changes from elsewhere not yet reflected in
+ - the index, this does properly merge those into the index before
+ - committing.
+ -}
+repairAnnexBranch :: MissingObjects -> Annex ()
+repairAnnexBranch missing = ifM okindex
+	( do
+		Annex.Branch.forceCommit "committing index after git repository repair"
+		liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"
+	, do
+		inRepo $ nukeFile . gitAnnexIndex
+		liftIO $ putStrLn "Had to delete the .git/annex/index file as it was corrupt. It would be a very good idea to run: git annex fsck --fast"
+	)
+  where
+	okindex = Annex.Branch.withIndex $
+		inRepo $ Git.Repair.checkIndex missing

Git/LsFiles.hs

@@ -20,6 +20,7 @@ module Git.LsFiles (
 	Conflicting(..),
 	Unmerged(..),
 	unmerged,
+	StagedDetails,
 ) where
 
 import Common
@@ -79,18 +80,20 @@ staged' ps l = pipeNullSplit $ prefix ++ ps ++ suffix
 	prefix = [Params "diff --cached --name-only -z"]
 	suffix = Param "--" : map File l
 
+type StagedDetails = (FilePath, Maybe Sha, Maybe FileMode)
+
 {- Returns details about files that are staged in the index,
  - as well as files not yet in git. Skips ignored files. -}
-stagedOthersDetails :: [FilePath] -> Repo -> IO ([(FilePath, Maybe Sha, Maybe FileMode)], IO Bool)
+stagedOthersDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
 stagedOthersDetails = stagedDetails' [Params "--others --exclude-standard"]
 
 {- Returns details about all files that are staged in the index. -}
-stagedDetails :: [FilePath] -> Repo -> IO ([(FilePath, Maybe Sha, Maybe FileMode)], IO Bool)
+stagedDetails :: [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
 stagedDetails = stagedDetails' []
 
 {- Gets details about staged files, including the Sha of their staged
  - contents. -}
-stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([(FilePath, Maybe Sha, Maybe FileMode)], IO Bool)
+stagedDetails' :: [CommandParam] -> [FilePath] -> Repo -> IO ([StagedDetails], IO Bool)
 stagedDetails' ps l repo = do
 	(ls, cleanup) <- pipeNullSplit params repo
 	return (map parse ls, cleanup)

Git/Repair.hs

@@ -5,13 +5,14 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Git.RecoverRepository (
-	runRecovery,
+module Git.Repair (
+	runRepair,
 	cleanCorruptObjects,
 	retrieveMissingObjects,
 	resetLocalBranches,
 	removeTrackingBranches,
 	rewriteIndex,
+	checkIndex,
 	emptyGoodCommits,
 ) where
 
@@ -355,14 +356,33 @@ verifyTree missing treesha r
 			-- as long as ls-tree succeeded, we're good
 			else cleanup
 
+{- Checks that the index file only refers to objects that are not missing. -}
+checkIndex :: MissingObjects -> Repo -> IO Bool
+checkIndex missing r = do
+	(bad, _good, cleanup) <- partitionIndex missing r
+	if null bad
+		then cleanup
+		else do
+			void cleanup
+			return False
+
+partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
+partitionIndex missing r = do
+	(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
+	let (bad, good) = partition ismissing indexcontents
+	return (bad, good, cleanup)
+  where
+	getblob (_file, Just sha, Just _mode) = Just sha
+	getblob _ = Nothing
+	ismissing = maybe False (`S.member` missing) . getblob
+
 {- Rewrites the index file, removing from it any files whose blobs are
  - missing. Returns the list of affected files. -}
 rewriteIndex :: MissingObjects -> Repo -> IO [FilePath]
 rewriteIndex missing r
 	| repoIsLocalBare r = return []
 	| otherwise = do
-		(indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r
-		let (bad, good) = partition ismissing indexcontents
+		(bad, good, cleanup) <- partitionIndex missing r
 		unless (null bad) $ do
 			nukeFile (localGitDir r </> "index")
 			UpdateIndex.streamUpdateIndex r
@@ -370,9 +390,6 @@ rewriteIndex missing r
 		void cleanup
 		return $ map fst3 bad
   where
-	getblob (_file, Just sha, Just _mode) = Just sha
-	getblob _ = Nothing
-	ismissing = maybe False (`S.member` missing) . getblob
 	reinject (file, Just sha, Just mode) = case toBlobType mode of
 		Nothing -> return Nothing
 		Just blobtype -> Just <$>
@@ -404,14 +421,14 @@ displayList items header
 		| otherwise = items
 
 {- Put it all together. -}
-runRecovery :: Bool -> Repo -> IO Bool
-runRecovery forced g = do
+runRepair :: Bool -> Repo -> IO (Bool, MissingObjects)
+runRepair forced g = do
 	putStrLn "Running git fsck ..."
 	fsckresult <- findBroken False g
 	missing <- cleanCorruptObjects fsckresult g
 	stillmissing <- retrieveMissingObjects missing g
 	if S.null stillmissing
-		then successfulfinish
+		then successfulfinish stillmissing
 		else do
 			putStrLn $ unwords
 				[ show (S.size stillmissing)
@@ -435,7 +452,7 @@ runRecovery forced g = do
 					displayList deindexedfiles
 						"Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate."
 					if null resetbranches && null deletedbranches
-						then successfulfinish
+						then successfulfinish stillmissing
 						else do
 							unless (repoIsLocalBare g) $ do
 								mcurr <- Branch.currentUnsafe g
@@ -449,19 +466,19 @@ runRecovery forced g = do
 											]
 							putStrLn "Successfully recovered repository!"
 							putStrLn "Please carefully check that the changes mentioned above are ok.."
-							return True
+							return (True, stillmissing)
 				else do
 					if repoIsLocalBare g
 						then do
 							putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and re-run git-recover-repository."
 							putStrLn "If there are no clones of this repository, you can instead run git-recover-repository with the --force parameter to force recovery to a possibly usable state."
 						else putStrLn "To force a recovery to a usable state, run this command again with the --force parameter."
-					return False
+					return (False, stillmissing)
   where
-	successfulfinish = do
+	successfulfinish stillmissing = do
 		mapM_ putStrLn
 			[ "Successfully recovered repository!"
 			, "You should run \"git fsck\" to make sure, but it looks like"
 			, "everything was recovered ok."
 			]
-		return True
+		return (True, stillmissing)

doc/design/assistant/disaster_recovery.mdwn

@@ -55,7 +55,7 @@ everything) to have the assistant do.
 Note that Remote.Git already tries to use this, but the assistant does not
 call it for non-local remotes.
 
-## git fsck
+## git fsck and repair
 
 Add git fsck to scheduled self fsck **done**
 
@@ -64,11 +64,14 @@ TODO: Add git fsck of local remotes to scheduled remote fscks.
 TODO: Display an alert to nudge user to schedule a fsck, if none is
 scheduled. Without being annoying about it.
 
-TODO: If committing to the repository fails, after resolving any dangling lock
-files (see above), it should git fsck.
+TODO: If committing to the repository fails, after resolving any dangling
+lock files (see above), it should git fsck.
 
 If git fsck finds problems, launch git repository repair.
 
+TODO: git annex fsck --fast at end of repository repair to ensure
+git-annex branch is accurate.
+
 TODO: along with displaying alert when there is a problem, send an email
 alert. (Using system MTA?)
 
@@ -144,10 +147,7 @@ that was found for it.
   uncommitted. Or if the index is missing/corrupt, any files in the tree will
   show as modified and uncommitted. User (or git-annex assistant) can then
   commit as appropriate. Print appropriate warning message. **done**
-* TODO: Special handling for git-annex branch: Reset to last good commit
-  (or to dummy empty commit is there is not one), and 
-  then commit `.git/annex/index` over top of that, and then run a
-  `git annex fsck --fast` to fix up any object location info.
+* Special handling for git-annex branch and index. **done**
 * Remote tracking branches can just be removed, and then `git fetch`
   from the remote, which will re-download missing objects from it and
   reinstate the tracking branch. **done**

git-recover-repository.hs

@@ -12,7 +12,7 @@ import Common
 import qualified Git
 import qualified Git.CurrentRepo
 import qualified Git.Fsck
-import qualified Git.RecoverRepository
+import qualified Git.Repair
 import qualified Git.Config
 import qualified Git.Branch
 
@@ -35,7 +35,7 @@ main = do
 	forced <- parseArgs
 	
 	g <- Git.Config.read =<< Git.CurrentRepo.get
-	ifM (Git.RecoverRepository.runRecovery forced g)
+	ifM (fst <$> Git.Repair.runRepair forced g)
 		( exitSuccess
 		, exitFailure
 		)