diff options
Diffstat (limited to 'Git/Fsck.hs')
| -rw-r--r-- | Git/Fsck.hs | 61 |
1 files changed, 31 insertions, 30 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index a716b56..6f33e11 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -2,7 +2,7 @@ - - Copyright 2013 Joey Hess <id@joeyh.name> - - - Licensed under the GNU GPL version 3 or higher. + - Licensed under the GNU AGPL version 3 or higher. -} {-# LANGUAGE BangPatterns #-} @@ -22,10 +22,11 @@ import Git import Git.Command import Git.Sha import Utility.Batch -import qualified Git.Version import qualified Data.Set as S import Control.Concurrent.Async +import qualified Data.Semigroup as Sem +import Prelude data FsckResults = FsckFoundMissing @@ -44,15 +45,21 @@ type MissingObjects = S.Set Sha type Truncated = Bool +appendFsckOutput :: FsckOutput -> FsckOutput -> FsckOutput +appendFsckOutput (FsckOutput s1 t1) (FsckOutput s2 t2) = + FsckOutput (S.union s1 s2) (t1 || t2) +appendFsckOutput (FsckOutput s t) _ = FsckOutput s t +appendFsckOutput _ (FsckOutput s t) = FsckOutput s t +appendFsckOutput NoFsckOutput NoFsckOutput = NoFsckOutput +appendFsckOutput AllDuplicateEntriesWarning AllDuplicateEntriesWarning = AllDuplicateEntriesWarning +appendFsckOutput AllDuplicateEntriesWarning NoFsckOutput = AllDuplicateEntriesWarning +appendFsckOutput NoFsckOutput AllDuplicateEntriesWarning = AllDuplicateEntriesWarning + +instance Sem.Semigroup FsckOutput where + (<>) = appendFsckOutput + 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 @@ -65,9 +72,7 @@ instance Monoid FsckOutput where -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do - supportsNoDangling <- (>= Git.Version.normalize "1.7.10") - <$> Git.Version.installed - let (command, params) = ("git", fsckParams supportsNoDangling r) + let (command, params) = ("git", fsckParams r) (command', params') <- if batchmode then toBatchCommand (command, params) else return (command, params) @@ -78,8 +83,8 @@ findBroken batchmode r = do , std_err = CreatePipe } (o1, o2) <- concurrently - (parseFsckOutput maxobjs r supportsNoDangling (stdoutHandle p)) - (parseFsckOutput maxobjs r supportsNoDangling (stderrHandle p)) + (parseFsckOutput maxobjs r (stdoutHandle p)) + (parseFsckOutput maxobjs r (stderrHandle p)) fsckok <- checkSuccessProcess pid case mappend o1 o2 of FsckOutput badobjs truncated @@ -112,15 +117,15 @@ knownMissing (FsckFoundMissing s _) = s findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs -parseFsckOutput :: Int -> Repo -> Bool -> Handle -> IO FsckOutput -parseFsckOutput maxobjs r supportsNoDangling h = do +parseFsckOutput :: Int -> Repo -> Handle -> IO FsckOutput +parseFsckOutput maxobjs r 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 shas = findShas ls let !truncated = length shas > maxobjs missingobjs <- findMissing (take maxobjs shas) r return $ FsckOutput missingobjs truncated @@ -133,18 +138,14 @@ 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 +findShas :: [String] -> [Sha] +findShas = catMaybes . map extractSha . concat . map words . filter wanted where - wanted l - | supportsNoDangling = True - | otherwise = not ("dangling " `isPrefixOf` l) - -fsckParams :: Bool -> Repo -> [CommandParam] -fsckParams supportsNoDangling = gitCommandLine $ map Param $ catMaybes - [ Just "fsck" - , if supportsNoDangling - then Just "--no-dangling" - else Nothing - , Just "--no-reflogs" + wanted l = not ("dangling " `isPrefixOf` l) + +fsckParams :: Repo -> [CommandParam] +fsckParams = gitCommandLine $ map Param + [ "fsck" + , "--no-dangling" + , "--no-reflogs" ] |