merge improved fsck types from git-repair and some associated changes

This commit is contained in:
Joey Hess 2013-11-30 14:29:11 -04:00
parent a8e8bd4360
commit 6edac746f0
6 changed files with 57 additions and 46 deletions

View file

@ -15,7 +15,6 @@ module Git.Repair (
removeTrackingBranches,
checkIndex,
missingIndex,
nukeIndex,
emptyGoodCommits,
) where
@ -26,6 +25,7 @@ import Git.Objects
import Git.Sha
import Git.Types
import Git.Fsck
import Git.Index
import qualified Git.Config as Config
import qualified Git.Construct as Construct
import qualified Git.LsTree as LsTree
@ -43,16 +43,16 @@ import qualified Data.ByteString.Lazy as L
import Data.Tuple.Utils
{- Given a set of bad objects found by git fsck, which may not
- be complete, finds and removes all corrupt objects, and
- returns a list of missing objects, which need to be
- found elsewhere to finish recovery.
- be complete, finds and removes all corrupt objects,
- and returns missing objects.
-}
cleanCorruptObjects :: FsckResults -> Repo -> IO (Maybe MissingObjects)
cleanCorruptObjects :: FsckResults -> Repo -> IO FsckResults
cleanCorruptObjects fsckresults r = do
void $ explodePacks r
objs <- listLooseObjectShas r
mapM_ (tryIO . allowRead . looseObjectFile r) objs
bad <- findMissing objs r
void $ removeLoose r $ S.union bad (fromMaybe S.empty fsckresults)
void $ removeLoose r $ S.union bad (knownMissing fsckresults)
-- Rather than returning the loose objects that were removed, re-run
-- fsck. Other missing objects may have been in the packs,
-- and this way fsck will find them.
@ -98,20 +98,17 @@ explodePacks r = do
- If another clone of the repository exists locally, which might not be a
- remote of the repo being repaired, its path can be passed as a reference
- repository.
- Can also be run with Nothing, if it's not known which objects are
- missing, just that some are. (Ie, fsck failed badly.)
-}
retrieveMissingObjects :: Maybe MissingObjects -> Maybe FilePath -> Repo -> IO (Maybe MissingObjects)
retrieveMissingObjects :: FsckResults -> Maybe FilePath -> Repo -> IO FsckResults
retrieveMissingObjects missing referencerepo r
| missing == Just S.empty = return $ Just S.empty
| not (foundBroken missing) = return missing
| otherwise = withTmpDir "tmprepo" $ \tmpdir -> do
unlessM (boolSystem "git" [Params "init", File tmpdir]) $
error $ "failed to create temp repository in " ++ tmpdir
tmpr <- Config.read =<< Construct.fromAbsPath tmpdir
stillmissing <- pullremotes tmpr (remotes r) fetchrefstags missing
if stillmissing == Just S.empty
then return $ Just S.empty
if S.null (knownMissing stillmissing)
then return stillmissing
else pullremotes tmpr (remotes r) fetchallrefs stillmissing
where
pullremotes tmpr [] fetchrefs stillmissing = case referencerepo of
@ -121,12 +118,12 @@ retrieveMissingObjects missing referencerepo r
void $ explodePacks tmpr
void $ copyObjects tmpr r
case stillmissing of
Nothing -> return $ Just S.empty
Just s -> Just <$> findMissing (S.toList s) r
FsckFailed -> return $ FsckFailed
FsckFoundMissing s -> FsckFoundMissing <$> findMissing (S.toList s) r
, return stillmissing
)
pullremotes tmpr (rmt:rmts) fetchrefs ms
| ms == Just S.empty = return $ Just S.empty
| not (foundBroken ms) = return ms
| otherwise = do
putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "."
ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr)
@ -134,10 +131,10 @@ retrieveMissingObjects missing referencerepo r
void $ explodePacks tmpr
void $ copyObjects tmpr r
case ms of
Nothing -> pullremotes tmpr rmts fetchrefs ms
Just s -> do
FsckFailed -> pullremotes tmpr rmts fetchrefs ms
FsckFoundMissing s -> do
stillmissing <- findMissing (S.toList s) r
pullremotes tmpr rmts fetchrefs (Just stillmissing)
pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing)
, pullremotes tmpr rmts fetchrefs ms
)
fetchfrom fetchurl ps = runBool $
@ -368,7 +365,7 @@ rewriteIndex missing r
| otherwise = do
(bad, good, cleanup) <- partitionIndex missing r
unless (null bad) $ do
nukeIndex r
nukeFile (indexFile r)
UpdateIndex.streamUpdateIndex r
=<< (catMaybes <$> mapM reinject good)
void cleanup
@ -380,9 +377,6 @@ rewriteIndex missing r
UpdateIndex.stageFile sha blobtype file r
reinject _ = return Nothing
nukeIndex :: Repo -> IO ()
nukeIndex r = nukeFile (localGitDir r </> "index")
newtype GoodCommits = GoodCommits (S.Set Sha)
emptyGoodCommits :: GoodCommits
@ -423,6 +417,9 @@ preRepair g = do
nukeFile headfile
writeFile headfile "ref: refs/heads/master"
explodePackedRefsFile g
unless (repoIsLocalBare g) $ do
let f = indexFile g
void $ tryIO $ allowWrite f
where
headfile = localGitDir g </> "HEAD"
validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s)
@ -449,7 +446,7 @@ runRepair' fsckresult forced referencerepo g = do
missing <- cleanCorruptObjects fsckresult g
stillmissing <- retrieveMissingObjects missing referencerepo g
case stillmissing of
Just s
FsckFoundMissing s
| S.null s -> if repoIsLocalBare g
then successfulfinish S.empty []
else ifM (checkIndex S.empty g)
@ -471,13 +468,13 @@ runRepair' fsckresult forced referencerepo g = do
, "missing objects could not be recovered!"
]
unsuccessfulfinish s
Nothing
FsckFailed
| forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g)
( do
missing' <- cleanCorruptObjects Nothing g
missing' <- cleanCorruptObjects FsckFailed g
case missing' of
Nothing -> return (False, S.empty, [])
Just stillmissing' -> continuerepairs stillmissing'
FsckFailed -> return (False, S.empty, [])
FsckFoundMissing stillmissing' -> continuerepairs stillmissing'
, corruptedindex
)
| otherwise -> unsuccessfulfinish S.empty
@ -517,7 +514,7 @@ runRepair' fsckresult forced referencerepo g = do
return (True, stillmissing, modifiedbranches)
corruptedindex = do
nukeIndex g
nukeFile (indexFile g)
-- The corrupted index can prevent fsck from finding other
-- problems, so re-run repair.
fsckresult' <- findBroken False g