converted reads from stderr to use hGetLineUntilExitOrEOF

These are all unlikely to suffer from the inherited stderr fd problem,
but who knows, it could happen.
This commit is contained in:
Joey Hess 2020-11-19 16:21:17 -04:00
parent 613455e059
commit ff0927bde9
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
3 changed files with 27 additions and 15 deletions

View file

@ -85,8 +85,8 @@ findBroken batchmode r = do
where
go _ (Just outh) (Just errh) pid = do
(o1, o2) <- concurrently
(parseFsckOutput maxobjs r outh)
(parseFsckOutput maxobjs r errh)
(parseFsckOutput maxobjs r outh pid)
(parseFsckOutput maxobjs r errh pid)
fsckok <- checkSuccessProcess pid
case mappend o1 o2 of
FsckOutput badobjs truncated
@ -121,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
@ -133,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