make git fsck batch-capable

Git/Fsck.hs

@@ -16,6 +16,7 @@ import Git
 import Git.Command
 import Git.Sha
 import Git.CatFile
+import Utility.Batch
 
 import qualified Data.Set as S
 
@@ -31,17 +32,25 @@ type MissingObjects = S.Set Sha
  - 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.
  -}
-findBroken :: Repo -> IO (Maybe MissingObjects)
-findBroken r = do
-	(output, fsckok) <- processTranscript "git" (toCommand $ fsckParams r) Nothing
+findBroken :: Bool -> Repo -> IO (Maybe MissingObjects)
+findBroken batchmode 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
+  where
+	(command, params) = ("git", fsckParams r)
+	(command', params')
+		| batchmode = toBatchCommand (command, params)
+		| otherwise = (command, params)
 
 {- Finds objects that are missing from the git repsitory, or are corrupt.
- - Note that catting a corrupt object will cause cat-file to crash. -}
+ -
+ - Note that catting a corrupt object will cause cat-file to crash;
+ - this is detected and it's restarted.
+ -}
 findMissing :: [Sha] -> Repo -> IO MissingObjects
 findMissing objs r = go objs [] =<< start
   where

Git/RecoverRepository.hs

@@ -36,22 +36,22 @@ import qualified Data.ByteString.Lazy as L
 import System.Log.Logger
 import Data.Tuple.Utils
 
-{- Finds and removes corrupt objects from the repository, returning a list
- - of all such objects, which need to be found elsewhere to finish
- - recovery.
+{- Given a set of bad objects found by git fsck, removes all
+ - corrupt objects, and returns a list of missing objects,
+ - which need to be found elsewhere to finish recovery.
  -
- - Strategy: Run git fsck, remove objects it identifies as corrupt,
- - and repeat until git fsck finds no new objects.
+ - Since git fsck may crash on corrupt objects, and so not
+ - report the full set of corrupt or missing objects,
+ - this removes corrupt objects, and re-runs fsck, until it
+ - stabalizes.
  -
  - To remove corrupt objects, unpack all packs, and remove the packs
  - (to handle corrupt packs), and remove loose object files.
  -}
-cleanCorruptObjects :: Repo -> IO MissingObjects
-cleanCorruptObjects r = do
-	notice "Running git fsck ..."
-	check =<< findBroken r
+cleanCorruptObjects :: Maybe MissingObjects -> Repo -> IO MissingObjects
+cleanCorruptObjects mmissing r = check mmissing
   where
-  	check Nothing = do
+	check Nothing = do
 		notice "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?"
 		ifM (explodePacks r)
 			( retry S.empty
@@ -72,7 +72,7 @@ cleanCorruptObjects r = do
 				else return bad
 	retry oldbad = do
 		notice "Re-running git fsck to see if it finds more problems."
-		v <- findBroken r
+		v <- findBroken False r
 		case v of
 			Nothing -> error $ unwords
 				[ "git fsck found a problem, which was not corrected after removing"

Utility/Batch.hs

@@ -44,7 +44,28 @@ batch a = a
 maxNice :: Int
 maxNice = 19
 
-{- Runs a command in a way that's suitable for batch jobs.
+{- Converts a command to run niced. -}
+toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])
+toBatchCommand (command, params) = (command', params')
+  where
+#ifndef mingw32_HOST_OS
+	commandline = unwords $ map shellEscape $ command : toCommand params
+	nicedcommand
+		| Build.SysConfig.nice = "nice " ++ commandline
+		| otherwise = commandline
+	command' = "sh"
+	params' =
+		[ Param "-c"
+		, Param $ "exec " ++ nicedcommand
+		]
+#else
+	command' = command
+	params' = params
+#endif
+
+{- Runs a command in a way that's suitable for batch jobs that can be
+ - interrupted.
+ -
  - The command is run niced. If the calling thread receives an async
  - exception, it sends the command a SIGTERM, and after the command
  - finishes shuttting down, it re-raises the async exception. -}
@@ -63,15 +84,6 @@ batchCommandEnv command params environ = do
 			void $ waitForProcess pid
 			E.throwIO asyncexception
   where
-#ifndef mingw32_HOST_OS
-  	p = proc "sh"
-		[ "-c"
-		, "exec " ++ nicedcommand
-		]
-  	commandline = unwords $ map shellEscape $ command : toCommand params
-  	nicedcommand
-		| Build.SysConfig.nice = "nice " ++ commandline
-		| otherwise = commandline
-#else
-	p = proc command (toCommand params)
-#endif
+  	(command', params') = toBatchCommand (command, params)
+  	p = proc command' $ toCommand params'
+

git-recover-repository.hs

@@ -1,6 +1,6 @@
 {- git-recover-repository program
  -
- - Copyright 2012 Joey Hess <joey@kitenet.net>
+ - Copyright 2013 Joey Hess <joey@kitenet.net>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -15,6 +15,7 @@ import qualified Data.Set as S
 import Common
 import qualified Git
 import qualified Git.CurrentRepo
+import qualified Git.Fsck
 import qualified Git.RecoverRepository
 import qualified Git.Config
 import qualified Git.Branch
@@ -46,7 +47,9 @@ main = do
 	forced <- parseArgs
 	
 	g <- Git.Config.read =<< Git.CurrentRepo.get
-	missing <- Git.RecoverRepository.cleanCorruptObjects g
+	putStrLn "Running git fsck ..."
+	fsckresult <- Git.Fsck.findBroken False g
+	missing <- Git.RecoverRepository.cleanCorruptObjects fsckresult g
 	stillmissing <- Git.RecoverRepository.retrieveMissingObjects missing g
 	if S.null stillmissing
 		then putStr $ unlines