Improve repair of git-annex index file.

Fixes a test case I received where a corrupted repo was repaired, but the
git-annex branch was not. The root of the problem was that the
MissingObject returned by the repair code was not necessarily a complete
set of all objects that might have been deleted during the repair.

So, stop trying to return that at all, and instead make the index file
checking code explicitly verify that each object the index uses is present.

Assistant/Repair.hs

@@ -98,10 +98,10 @@ runRepair u mrmt destructiverepair = do
 			liftIO $ catchBoolIO a
 
 	repair fsckresults referencerepo = do
-		(ok, stillmissing, modifiedbranches) <- inRepo $
+		(ok, modifiedbranches) <- inRepo $
 			runRepairOf fsckresults destructiverepair referencerepo
 		when destructiverepair $
-			repairAnnexBranch stillmissing modifiedbranches
+			repairAnnexBranch modifiedbranches
 		return ok
 	
 	backgroundfsck params = liftIO $ void $ async $ do

Assistant/Threads/SanityChecker.hs

@@ -29,7 +29,6 @@ import Git.Repair
 import Git.Index
 
 import Data.Time.Clock.POSIX
-import qualified Data.Set as S
 
 {- This thread runs once at startup, and most other threads wait for it
  - to finish. (However, the webapp thread does not, to prevent the UI
@@ -41,7 +40,7 @@ sanityCheckerStartupThread startupdelay = namedThreadUnchecked "SanityCheckerSta
 
 	{- A corrupt index file can prevent the assistant from working at
 	 - all, so detect and repair. -}
-	ifM (not <$> liftAnnex (inRepo (checkIndex S.empty)))
+	ifM (not <$> liftAnnex (inRepo checkIndexFast))
 		( do
 			notice ["corrupt index file found at startup; removing and restaging"]
 			liftAnnex $ inRepo $ nukeFile . indexFile

Command/Repair.hs

@@ -12,7 +12,6 @@ import Command
 import qualified Annex
 import qualified Git.Repair
 import qualified Annex.Branch
-import Git.Fsck (MissingObjects)
 import Git.Types
 import Annex.Version
 
@@ -28,12 +27,12 @@ start = next $ next $ runRepair =<< Annex.getState Annex.force
 
 runRepair :: Bool -> Annex Bool
 runRepair forced = do
-	(ok, stillmissing, modifiedbranches) <- inRepo $
+	(ok, modifiedbranches) <- inRepo $
 		Git.Repair.runRepair forced
 	-- This command can be run in git repos not using git-annex,
 	-- so avoid git annex branch stuff in that case.
 	whenM (isJust <$> getVersion) $
-		repairAnnexBranch stillmissing modifiedbranches
+		repairAnnexBranch modifiedbranches
 	return ok
 
 {- After git repository repair, the .git/annex/index file could
@@ -50,8 +49,8 @@ runRepair forced = do
  - yet reflected in the index, this does properly merge those into the
  - index before committing.
  -}
-repairAnnexBranch :: MissingObjects -> [Branch] -> Annex ()
-repairAnnexBranch missing modifiedbranches
+repairAnnexBranch :: [Branch] -> Annex ()
+repairAnnexBranch modifiedbranches
 	| Annex.Branch.fullname `elem` modifiedbranches = ifM okindex
 		( commitindex
 		, do
@@ -63,8 +62,7 @@ repairAnnexBranch missing modifiedbranches
 		, nukeindex
 		)
   where
-	okindex = Annex.Branch.withIndex $
-		inRepo $ Git.Repair.checkIndex missing
+	okindex = Annex.Branch.withIndex $ inRepo $ Git.Repair.checkIndex
 	commitindex = do
 		Annex.Branch.forceCommit "committing index after git repository repair"
 		liftIO $ putStrLn "Successfully recovered the git-annex branch using .git/annex/index"

Git/Fsck.hs

@@ -11,6 +11,7 @@ module Git.Fsck (
 	findBroken,
 	foundBroken,
 	findMissing,
+	isMissing,
 	knownMissing,
 ) where
 
@@ -25,6 +26,7 @@ import qualified Data.Set as S
 type MissingObjects = S.Set Sha
 
 data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
+	deriving (Show)
 
 {- Runs fsck to find some of the broken objects in the repository.
  - May not find all broken objects, if fsck fails on bad data in some of
@@ -59,15 +61,17 @@ knownMissing (FsckFoundMissing s) = s
 {- Finds objects that are missing from the git repsitory, or are corrupt.
  -
  - This does not use git cat-file --batch, because catting a corrupt
- - object can cause it to crash, or to report incorrect size information.a
+ - object can cause it to crash, or to report incorrect size information.
  -}
 findMissing :: [Sha] -> Repo -> IO MissingObjects
-findMissing objs r = S.fromList <$> filterM (not <$$> present) objs
+findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
+
+isMissing :: Sha -> Repo -> IO Bool
+isMissing s r = either (const True) (const False) <$> tryIO dump
   where
-	present o = either (const False) (const True) <$> tryIO (dump o)
-	dump o = runQuiet
+	dump = runQuiet
 		[ Param "show"
-		, Param (show o)
+		, Param (show s)
 		] r
 
 findShas :: String -> [Sha]

Git/Repair.hs

@@ -1,4 +1,5 @@
 {- git repository recovery
+import qualified Data.Set as S
  -
  - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
@@ -335,8 +336,8 @@ verifyTree missing treesha r
 {- Checks that the index file only refers to objects that are not missing,
  - and is not itself corrupt. Note that a missing index file is not
  - considered a problem (repo may be new). -}
-checkIndex :: MissingObjects -> Repo -> IO Bool
-checkIndex missing r = do
+checkIndex :: Repo -> IO Bool
+checkIndex r = do
 	(bad, _good, cleanup) <- partitionIndex missing r
 	if null bad
 		then cleanup
@@ -347,23 +348,22 @@ checkIndex missing r = do
 missingIndex :: Repo -> IO Bool
 missingIndex r = not <$> doesFileExist (localGitDir r </> "index")
 
-partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
-partitionIndex missing r = do
+{- Finds missing and ok files staged in the index. -}
+partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool)
+partitionIndex 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
+	l <- forM_ indexcontents $ \i -> case i of
+		(_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i
+		_ _> pure (False, i)
+	return (map snd bad, map snd good, cleanup)
 
 {- 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
+rewriteIndex :: Repo -> IO [FilePath]
+rewriteIndex r
 	| repoIsLocalBare r = return []
 	| otherwise = do
-		(bad, good, cleanup) <- partitionIndex missing r
+		(bad, good, cleanup) <- partitionIndex r
 		unless (null bad) $ do
 			nukeFile (indexFile r)
 			UpdateIndex.streamUpdateIndex r
@@ -425,7 +425,7 @@ preRepair g = do
 	validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
 
 {- Put it all together. -}
-runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair :: Bool -> Repo -> IO (Bool, [Branch])
 runRepair forced g = do
 	preRepair g
 	putStrLn "Running git fsck ..."
@@ -434,23 +434,23 @@ runRepair forced g = do
 		then runRepair' fsckresult forced Nothing g
 		else do
 			putStrLn "No problems found."
-			return (True, S.empty, [])
+			return (True, [])
 
-runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
 runRepairOf fsckresult forced referencerepo g = do
 	preRepair g
 	runRepair' fsckresult forced referencerepo g
 
-runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch])
+runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch])
 runRepair' fsckresult forced referencerepo g = do
 	missing <- cleanCorruptObjects fsckresult g
 	stillmissing <- retrieveMissingObjects missing referencerepo g
 	case stillmissing of
 		FsckFoundMissing s
 			| S.null s -> if repoIsLocalBare g
-				then successfulfinish S.empty []
-				else ifM (checkIndex S.empty g)
-					( successfulfinish s []
+				then successfulfinish []
+				else ifM (checkIndex g)
+					( successfulfinish []
 					, do
 						putStrLn "No missing objects found, but the index file is corrupt!"
 						if forced
@@ -458,7 +458,7 @@ runRepair' fsckresult forced referencerepo g = do
 							else needforce S.empty
 					)
 			| otherwise -> if forced
-				then ifM (checkIndex s g)
+				then ifM (checkIndex g)
 					( continuerepairs s
 					, corruptedindex
 					)
@@ -467,17 +467,18 @@ runRepair' fsckresult forced referencerepo g = do
 						[ show (S.size s)
 						, "missing objects could not be recovered!"
 						]
-					unsuccessfulfinish s
+					unsuccessfulfinish
 		FsckFailed
-			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)
+			| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g)
 				( do
 					missing' <- cleanCorruptObjects FsckFailed g
 					case missing' of
 						FsckFailed -> return (False, S.empty, [])
-						FsckFoundMissing stillmissing' -> continuerepairs stillmissing'
+						FsckFoundMissing stillmissing' ->
+							continuerepairs stillmissing'
 				, corruptedindex
 				)
-			| otherwise -> unsuccessfulfinish S.empty
+			| otherwise -> unsuccessfulfinish
   where
 	continuerepairs stillmissing = do
 		(remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g
@@ -492,12 +493,12 @@ runRepair' fsckresult forced referencerepo g = do
 			"Reset these local branches to old versions before the missing objects were committed:"
 		displayList (map show deletedbranches)
 			"Deleted these local branches, which could not be recovered due to missing objects:"
-		deindexedfiles <- rewriteIndex stillmissing g
+		deindexedfiles <- rewriteIndex g
 		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."
 		let modifiedbranches = resetbranches ++ deletedbranches
 		if null resetbranches && null deletedbranches
-			then successfulfinish stillmissing modifiedbranches
+			then successfulfinish modifiedbranches
 			else do
 				unless (repoIsLocalBare g) $ do
 					mcurr <- Branch.currentUnsafe g
@@ -511,7 +512,7 @@ runRepair' fsckresult forced referencerepo g = do
 								]
 				putStrLn "Successfully recovered repository!"
 				putStrLn "Please carefully check that the changes mentioned above are ok.."
-				return (True, stillmissing, modifiedbranches)
+				return (True, modifiedbranches)
 	
 	corruptedindex = do
 		nukeFile (indexFile g)
@@ -522,22 +523,22 @@ runRepair' fsckresult forced referencerepo g = do
 		putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate."
 		return result
 
-	successfulfinish stillmissing modifiedbranches = do
+	successfulfinish modifiedbranches = do
 		mapM_ putStrLn
 			[ "Successfully recovered repository!"
 			, "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok."
 			]
-		return (True, stillmissing, modifiedbranches)
-	unsuccessfulfinish stillmissing = do
+		return (True, modifiedbranches)
+	unsuccessfulfinish = 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 retry."
 				putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state."
-				return (False, stillmissing, [])
+				return (False, [])
 			else needforce stillmissing
-	needforce stillmissing = do
+	needforce = do
 		putStrLn "To force a recovery to a usable state, retry with the --force parameter."
-		return (False, stillmissing, [])
+		return (False, [])
 
 successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool
 successfulRepair = fst3

debian/changelog

@@ -22,6 +22,7 @@ git-annex (5.20131131) UNRELEASED; urgency=low
   * Windows: Support annex.diskreserve.
   * Fix bad behavior in Firefox, which was caused by an earlier fix to
     bad behavior in Chromium.
+  * Improve repair of git-annex index file.
 
  -- Joey Hess <joeyh@debian.org>  Sun, 01 Dec 2013 13:57:58 -0400