diff options
Diffstat (limited to 'Git/Fsck.hs')
-rw-r--r-- | Git/Fsck.hs | 73 |
1 files changed, 47 insertions, 26 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 6f33e11..4544c13 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -1,4 +1,5 @@ {- git fsck interface +i it is not fully repoducibleI repeated the same steps - - Copyright 2013 Joey Hess <id@joeyh.name> - @@ -69,37 +70,52 @@ instance Monoid FsckOutput where - 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. + - + - Note that there is a possible false positive: When changes are being + - made to the repo while this is running, fsck might complain about a + - missing object that has not made it to disk yet. Catting the object + - then succeeds, so it's not included in the FsckResults. But, fsck then + - exits nonzero, and so FsckFailed is returned. Set ignorenonzeroexit + - to avoid this false positive, at the risk of perhaps missing a problem + - so bad that fsck crashes without outputting any missing shas. -} -findBroken :: Bool -> Repo -> IO FsckResults -findBroken batchmode r = do +findBroken :: Bool -> Bool -> Repo -> IO FsckResults +findBroken batchmode ignorenonzeroexit r = do let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params) - p@(_, _, _, pid) <- createProcess $ - (proc command' (toCommand params')) - { std_out = CreatePipe - , std_err = CreatePipe - } - (o1, o2) <- concurrently - (parseFsckOutput maxobjs r (stdoutHandle p)) - (parseFsckOutput maxobjs r (stderrHandle p)) - fsckok <- checkSuccessProcess pid - 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 + let p = (proc command' (toCommand params')) + { std_out = CreatePipe + , std_err = CreatePipe + } + withCreateProcess p go where + go _ (Just outh) (Just errh) pid = do + (o1, o2) <- concurrently + (parseFsckOutput maxobjs r outh pid) + (parseFsckOutput maxobjs r errh pid) + fsckok <- checkSuccessProcess pid + 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 + go _ _ _ _ = error "internal" + maxobjs = 10000 noproblem = FsckFoundMissing S.empty False + fsckfailed + | ignorenonzeroexit = noproblem + | otherwise = FsckFailed foundBroken :: FsckResults -> Bool foundBroken FsckFailed = True @@ -117,9 +133,9 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r h = do - ls <- lines <$> hGetContents h +parseFsckOutput :: Int -> Repo -> Handle -> ProcessHandle -> IO FsckOutput +parseFsckOutput maxobjs r h pid = do + ls <- getlines [] if null ls then return NoFsckOutput else if all ("duplicateEntries" `isInfixOf`) ls @@ -129,6 +145,10 @@ parseFsckOutput maxobjs r h = do let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated + where + getlines c = hGetLineUntilExitOrEOF pid h >>= \case + Nothing -> return (reverse c) + Just l -> getlines (l:c) isMissing :: Sha -> Repo -> IO Bool isMissing s r = either (const True) (const False) <$> tryIO dump @@ -139,7 +159,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump ] r findShas :: [String] -> [Sha] -findShas = catMaybes . map extractSha . concat . map words . filter wanted +findShas = catMaybes . map (extractSha . encodeBS) + . concat . map words . filter wanted where wanted l = not ("dangling " `isPrefixOf` l) |