Assistant, repair: Fix ignoring of git fsck errors due to duplicate file entries in tree objects.

Git/Fsck.hs

@@ -5,6 +5,8 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
+{-# LANGUAGE BangPatterns #-}
+
 module Git.Fsck (
 	FsckResults(..),
 	MissingObjects,
@@ -25,8 +27,6 @@ import qualified Git.Version
 import qualified Data.Set as S
 import Control.Concurrent.Async
 
-type MissingObjects = S.Set Sha
-
 data FsckResults 
 	= FsckFoundMissing
 		{ missingObjects :: MissingObjects
@@ -35,6 +35,25 @@ data FsckResults
 	| FsckFailed
 	deriving (Show)
 
+data FsckOutput 
+	= FsckOutput MissingObjects Truncated
+	| NoFsckOutput
+	| AllDuplicateEntriesWarning
+
+type MissingObjects = S.Set Sha
+
+type Truncated = Bool
+
+instance Monoid FsckOutput where
+	mempty = NoFsckOutput
+	mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)
+	mappend (FsckOutput s t) _ = FsckOutput s t
+	mappend _ (FsckOutput s t) = FsckOutput s t
+	mappend NoFsckOutput NoFsckOutput = NoFsckOutput
+	mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+	mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
+	mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+
 {- 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
  - the broken objects it does find.
@@ -58,18 +77,24 @@ findBroken batchmode r = do
 			{ std_out = CreatePipe
 			, std_err = CreatePipe
 			}
-	(bad1, bad2) <- concurrently
-		(readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))
-		(readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))
+	(o1, o2) <- concurrently
+		(parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))
+		(parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p))
 	fsckok <- checkSuccessProcess pid
-	let truncated = S.size bad1 == maxobjs || S.size bad1 == maxobjs
-	let badobjs = S.union bad1 bad2
-
-	if S.null badobjs && not fsckok
-		then return FsckFailed
-		else return $ FsckFoundMissing badobjs truncated
+	case mappend o1 o2 of
+		FsckOutput badobjs truncated
+			| S.null badobjs && not fsckok -> return FsckFailed
+			| otherwise -> return $ FsckFoundMissing badobjs truncated
+		NoFsckOutput
+			| not fsckok -> return FsckFailed
+			| otherwise -> return noproblem
+		-- If all fsck output was duplicateEntries warnings,
+		-- the repository is not broken, it just has some unusual
+		-- tree objects in it. So ignore nonzero exit status.
+		AllDuplicateEntriesWarning -> return noproblem
   where
 	maxobjs = 10000
+	noproblem = FsckFoundMissing S.empty False
 
 foundBroken :: FsckResults -> Bool
 foundBroken FsckFailed = True
@@ -87,10 +112,18 @@ knownMissing (FsckFoundMissing s _) = s
 findMissing :: [Sha] -> Repo -> IO MissingObjects
 findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
 
-readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects
-readMissingObjs maxobjs r supportsNoDangling h = do
-	objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h
-	findMissing objs r
+parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput
+parseFsckOutput maxobjs r supportsNoDangling h = do
+	ls <- lines <$> hGetContents h
+	if null ls
+		then return NoFsckOutput
+		else if all ("duplicateEntries" `isInfixOf`) ls
+			then return AllDuplicateEntriesWarning
+			else do
+				let shas = findShas supportsNoDangling ls
+				let !truncated = length shas > maxobjs
+				missingobjs <- findMissing (take maxobjs shas) r
+				return $ FsckOutput missingobjs truncated
 
 isMissing :: Sha -> Repo -> IO Bool
 isMissing s r = either (const True) (const False) <$> tryIO dump
@@ -100,12 +133,10 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
 		, Param (fromRef s)
 		] r
 
-findShas :: Bool -> String -> [Sha]
-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines
+findShas :: Bool -> [String] -> [Sha]
+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted
   where
 	wanted l
-		-- Skip lines like "error in tree <sha>: duplicateEntries: contains duplicate file entries"
-		| "duplicateEntries" `isInfixOf` l = False
 		| supportsNoDangling = True
 		| otherwise = not ("dangling " `isPrefixOf` l)