summaryrefslogtreecommitdiff
path: root/Git/Fsck.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2014-03-12 15:18:43 -0400
committerGravatar Joey Hess <joey@kitenet.net>2014-03-12 15:18:43 -0400
commit3a7b7c8ac97f263e5fdf6281ef6812aba4af0042 (patch)
tree42be53b2ff001d4c8b3471aea090c68de33de879 /Git/Fsck.hs
parent4d79d2327819111f97954e10dce2c8ce53b0ab31 (diff)
fully fix fsck memory use by iterative fscking
Not very well tested, but I'm sure it doesn't eg, loop forever.
Diffstat (limited to 'Git/Fsck.hs')
-rw-r--r--Git/Fsck.hs26
1 files changed, 17 insertions, 9 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index e8fa02129..80f76dd90 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -28,7 +28,12 @@ import Control.Concurrent.Async
type MissingObjects = S.Set Sha
-data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
+data FsckResults
+ = FsckFoundMissing
+ { missingObjects :: MissingObjects
+ , missingObjectsTruncated :: Bool
+ }
+ | FsckFailed
deriving (Show)
{- Runs fsck to find some of the broken objects in the repository.
@@ -55,22 +60,25 @@ findBroken batchmode r = do
, std_err = CreatePipe
}
(bad1, bad2) <- concurrently
- (readMissingObjs r supportsNoDangling (stdoutHandle p))
- (readMissingObjs r supportsNoDangling (stderrHandle p))
+ (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))
+ (readMissingObjs 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
+ else return $ FsckFoundMissing badobjs truncated
+ where
+ maxobjs = 10000
foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
-foundBroken (FsckFoundMissing s) = not (S.null s)
+foundBroken (FsckFoundMissing s _) = not (S.null s)
knownMissing :: FsckResults -> MissingObjects
knownMissing FsckFailed = S.empty
-knownMissing (FsckFoundMissing s) = s
+knownMissing (FsckFoundMissing s _) = s
{- Finds objects that are missing from the git repsitory, or are corrupt.
-
@@ -80,9 +88,9 @@ knownMissing (FsckFoundMissing s) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-readMissingObjs :: Repo -> Bool -> Handle -> IO MissingObjects
-readMissingObjs r supportsNoDangling h = do
- objs <- findShas supportsNoDangling <$> hGetContents h
+readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects
+readMissingObjs maxobjs r supportsNoDangling h = do
+ objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h
findMissing objs r
isMissing :: Sha -> Repo -> IO Bool