diff options
author | Joey Hess <joeyh@joeyh.name> | 2021-01-11 21:52:32 -0400 |
---|---|---|
committer | Joey Hess <joeyh@joeyh.name> | 2021-01-11 21:52:32 -0400 |
commit | ad48349741384ed0e49fab9cf13ac7f90aba0dd1 (patch) | |
tree | 6b8c894ce1057d069f89e7209c266f00ea43ec66 /Git/Fsck.hs | |
parent | b3e72e94efbce652f25fb99d6c6ace8beb2a52d4 (diff) | |
download | git-repair-ad48349741384ed0e49fab9cf13ac7f90aba0dd1.tar.gz |
Merge from git-annex.
Diffstat (limited to 'Git/Fsck.hs')
-rw-r--r-- | Git/Fsck.hs | 54 |
1 files changed, 31 insertions, 23 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 69a9e9f..7440b92 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -77,27 +77,31 @@ findBroken batchmode r = do 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 @@ -117,9 +121,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 +133,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 |