try to recover even if git fsck cannot be coaxed to tell us any bad objects

Sometimes git fsck outputs no shas even with --verbose, but fails, due to
badly corrupt objects. The best thing to do in this situation is to try to
pull and rsync from remotes, hoping that the bad objects will be
overwritten.

1 files changed, 45 insertions, 13 deletions

diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 2c94230..16b0235 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -21,6 +21,8 @@ import Git.CatFile
 import Utility.Batch
 
 import qualified Data.Set as S
+import System.Process (std_err, std_out)
+import Control.Concurrent
 
 type MissingObjects = S.Set Sha
 
@@ -36,17 +38,47 @@ type FsckResults = Maybe MissingObjects
  - look for anything in its output (both stdout and stderr) that appears
  - to be a git sha. Not all such shas are of broken objects, so ask git
  - to try to cat the object, and see if it fails.
+ -
+ - Some forms of corruption will crash fsck in ways that does not let it
+ - output the sha of the broken object. In such a case, Nothing will be
+ - returned. In this case, to find broken objects, re-run with tryharder
+ - set to True. This makes fsck run in verbose mode, so it prints out
+ - shas before checking them. We assume that the last sha is the one that
+ - it crashed on, and it may have crashed following from eg, a commit to a
+ - tree to a subtree. So, run git show on the sha, and examin the stderr
+ - to find an actual bad sha.
  -}
-findBroken :: Bool -> Repo -> IO FsckResults
-findBroken batchmode r = do
+findBroken :: Bool -> Bool -> Repo -> IO FsckResults
+findBroken batchmode tryharder r = do
 	(output, fsckok) <- processTranscript command' (toCommand params') Nothing
-	let objs = parseFsckOutput output
-	badobjs <- findMissing objs r
-	if S.null badobjs && not fsckok
-		then return Nothing
-		else return $ Just badobjs
+	let objs = findShas output
+	if fsckok || not tryharder
+		then do
+			badobjs <- findMissing objs r
+			if S.null badobjs && not fsckok
+				then return Nothing
+				else return $ Just badobjs
+		else case lastMaybe objs of
+			Nothing -> return Nothing
+			Just o -> do
+				p@(_, _, _, pid) <- createProcess $
+					( proc "git" $ toCommand $ gitCommandLine [ Param "show", Param $ show o ] r )
+					{ std_err = CreatePipe
+					, std_out = CreatePipe
+					}
+				void $ forkIO $ void $ hGetContents (stdoutHandle p)
+				objs' <- findShas <$>
+					hGetContentsStrict (stderrHandle p)
+				badobjs <- findMissing objs' r
+				ifM (checkSuccessProcess pid)
+					( if S.null badobjs
+						then return Nothing
+						else return $ Just badobjs
+					, return $ Just $ S.singleton o
+					)
+
   where
-	(command, params) = ("git", fsckParams r)
+	(command, params) = ("git", fsckParams tryharder r)
 	(command', params')
 		| batchmode = toBatchCommand (command, params)
 		| otherwise = (command, params)
@@ -76,12 +108,12 @@ findMissing objs r = go objs [] =<< start
 			Right True -> go os (o:c) h
 			Right False -> go os c h
 
-parseFsckOutput :: String -> [Sha]
-parseFsckOutput = catMaybes . map extractSha . concat . map words . lines
+findShas :: String -> [Sha]
+findShas = catMaybes . map extractSha . concat . map words . lines
 
-fsckParams :: Repo -> [CommandParam]
-fsckParams = gitCommandLine
+fsckParams :: Bool -> Repo -> [CommandParam]
+fsckParams verbose = gitCommandLine $
 	[ Param "fsck"
 	, Param "--no-dangling"
 	, Param "--no-reflogs"
-	]
+	] ++ if verbose then [ Param "--verbose" ] else []