stop using cat-file --batch for findMissing

Some corrupt objects can cause it to say the object is several TB, which
led to OOM.

Added some fork overhead, but it shouldn't be too bad; this is only run
against objects fsck outputs, and most of the time that is only corrupt
objects, and objects that refer to them.

1 files changed, 9 insertions, 23 deletions

diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 2c4d1cd..309f4bb 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -17,12 +17,9 @@ import Common
 import Git
 import Git.Command
 import Git.Sha
-import Git.CatFile
 import Utility.Batch
-import Utility.ThreadScheduler
 
 import qualified Data.Set as S
-import Control.Concurrent.Async
 
 type MissingObjects = S.Set Sha
 
@@ -59,29 +56,18 @@ foundBroken (Just s) = not (S.null s)
 
 {- Finds objects that are missing from the git repsitory, or are corrupt.
  -
- - Note that catting a corrupt object will cause cat-file to crash,
- - or sometimes to stall; this is detected and it's restarted.
+ - This does not use git cat-file --batch, because catting a corrupt
+ - object can cause it to crash, or to report incorrect size information.
  -}
 findMissing :: [Sha] -> Repo -> IO MissingObjects
-findMissing objs r = go objs [] =<< start
+findMissing objs r = S.fromList <$> filterM (not <$$> cancat) objs
   where
-	start = catFileStart' False r
-	go [] c h = do
-		void $ tryIO $ catFileStop h
-		return $ S.fromList c
-	go (o:os) c h = do
-		reader <- async $ isNothing <$> catObjectDetails h o
-		killer <- async $ do
-			threadDelaySeconds (Seconds 60)
-			cancel reader
-		v <- waitCatch reader
-		cancel killer
-		case v of
-			Left _ -> do
-				void $ tryIO $ catFileStop h
-				go os (o:c) =<< start
-			Right True -> go os (o:c) h
-			Right False -> go os c h
+	cancat o = either (const False) (const True) <$> tryIO (cat o)
+	cat o = runQuiet
+		[ Param "cat-file"
+		, Param "-p"
+		, Param (show o)
+		] r
 
 findShas :: String -> [Sha]
 findShas = catMaybes . map extractSha . concat . map words . lines