summaryrefslogtreecommitdiff
path: root/Git/Fsck.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Git/Fsck.hs')
-rw-r--r--Git/Fsck.hs67
1 files changed, 50 insertions, 17 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index f3e6db9..a716b56 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -5,6 +5,8 @@
- Licensed under the GNU GPL version 3 or higher.
-}
+{-# LANGUAGE BangPatterns #-}
+
module Git.Fsck (
FsckResults(..),
MissingObjects,
@@ -25,8 +27,6 @@ import qualified Git.Version
import qualified Data.Set as S
import Control.Concurrent.Async
-type MissingObjects = S.Set Sha
-
data FsckResults
= FsckFoundMissing
{ missingObjects :: MissingObjects
@@ -35,6 +35,25 @@ data FsckResults
| FsckFailed
deriving (Show)
+data FsckOutput
+ = FsckOutput MissingObjects Truncated
+ | NoFsckOutput
+ | AllDuplicateEntriesWarning
+
+type MissingObjects = S.Set Sha
+
+type Truncated = Bool
+
+instance Monoid FsckOutput where
+ mempty = NoFsckOutput
+ mappend (FsckOutput s1 t1) (FsckOutput s2 t2) = FsckOutput (S.union s1 s2) (t1 || t2)
+ mappend (FsckOutput s t) _ = FsckOutput s t
+ mappend _ (FsckOutput s t) = FsckOutput s t
+ mappend NoFsckOutput NoFsckOutput = NoFsckOutput
+ mappend AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+ mappend AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning
+ mappend NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning
+
{- Runs fsck to find some of the broken objects in the repository.
- May not find all broken objects, if fsck fails on bad data in some of
- the broken objects it does find.
@@ -58,18 +77,24 @@ findBroken batchmode r = do
{ std_out = CreatePipe
, std_err = CreatePipe
}
- (bad1, bad2) <- concurrently
- (readMissingObjs maxobjs r supportsNoDangling (stdoutHandle p))
- (readMissingObjs maxobjs r supportsNoDangling (stderrHandle p))
+ (o1, o2) <- concurrently
+ (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p))
+ (parseFsckOutput 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 truncated
+ 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
where
maxobjs = 10000
+ noproblem = FsckFoundMissing S.empty False
foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
@@ -87,10 +112,18 @@ knownMissing (FsckFoundMissing s _) = s
findMissing :: [Sha] -> Repo -> IO MissingObjects
findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs
-readMissingObjs :: Int -> Repo -> Bool -> Handle -> IO MissingObjects
-readMissingObjs maxobjs r supportsNoDangling h = do
- objs <- take maxobjs . findShas supportsNoDangling <$> hGetContents h
- findMissing objs r
+parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput
+parseFsckOutput maxobjs r supportsNoDangling h = do
+ ls <- lines <$> hGetContents h
+ if null ls
+ then return NoFsckOutput
+ else if all ("duplicateEntries" `isInfixOf`) ls
+ then return AllDuplicateEntriesWarning
+ else do
+ let shas = findShas supportsNoDangling ls
+ let !truncated = length shas > maxobjs
+ missingobjs <- findMissing (take maxobjs shas) r
+ return $ FsckOutput missingobjs truncated
isMissing :: Sha -> Repo -> IO Bool
isMissing s r = either (const True) (const False) <$> tryIO dump
@@ -100,8 +133,8 @@ isMissing s r = either (const True) (const False) <$> tryIO dump
, Param (fromRef s)
] r
-findShas :: Bool -> String -> [Sha]
-findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted . lines
+findShas :: Bool -> [String] -> [Sha]
+findShas supportsNoDangling = catMaybes . map extractSha . concat . map words . filter wanted
where
wanted l
| supportsNoDangling = True