diff options
Diffstat (limited to 'Git/Repair.hs')
| -rw-r--r-- | Git/Repair.hs | 220 |
1 files changed, 130 insertions, 90 deletions
diff --git a/Git/Repair.hs b/Git/Repair.hs index 66e6811..cea57df 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -1,10 +1,12 @@ {- git repository recovery - - - Copyright 2013-2014 Joey Hess <id@joeyh.name> + - Copyright 2013-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} +{-# LANGUAGE OverloadedStrings #-} + module Git.Repair ( runRepair, runRepairOf, @@ -27,6 +29,8 @@ import Git.Sha import Git.Types import Git.Fsck import Git.Index +import Git.Env +import Git.FilePath import qualified Git.Config as Config import qualified Git.Construct as Construct import qualified Git.LsTree as LsTree @@ -35,13 +39,15 @@ import qualified Git.Ref as Ref import qualified Git.RefLog as RefLog import qualified Git.UpdateIndex as UpdateIndex import qualified Git.Branch as Branch +import Utility.Directory.Create import Utility.Tmp.Dir import Utility.Rsync import Utility.FileMode -import Utility.Tuple +import qualified Utility.RawFilePath as R import qualified Data.Set as S import qualified Data.ByteString.Lazy as L +import qualified System.FilePath.ByteString as P {- Given a set of bad objects found by git fsck, which may not - be complete, finds and removes all corrupt objects. -} @@ -51,21 +57,20 @@ cleanCorruptObjects fsckresults r = do mapM_ removeLoose (S.toList $ knownMissing fsckresults) mapM_ removeBad =<< listLooseObjectShas r where - removeLoose s = nukeFile (looseObjectFile r s) + removeLoose s = removeWhenExistsWith R.removeLink (looseObjectFile r s) removeBad s = do - void $ tryIO $ allowRead $ looseObjectFile r s + void $ tryIO $ allowRead $ looseObjectFile r s whenM (isMissing s r) $ removeLoose s -{- Explodes all pack files, and deletes them. - - - - First moves all pack files to a temp dir, before unpacking them each in - - turn. +{- Explodes all pack files to loose objects, and deletes the pack files. - - - This is because unpack-objects will not unpack a pack file if it's in the - - git repo. + - git unpack-objects will not unpack objects from a pack file that are + - in the git repo. So, GIT_OBJECT_DIRECTORY is pointed to a temporary + - directory, and the loose objects then are moved into place, before + - deleting the pack files. - - - Also, this prevents unpack-objects from possibly looking at corrupt + - Also, that prevents unpack-objects from possibly looking at corrupt - pack files to see if they contain an object, while unpacking a - non-corrupt pack file. -} @@ -74,21 +79,32 @@ explodePacks r = go =<< listPackFiles r where go [] = return False go packs = withTmpDir "packs" $ \tmpdir -> do + r' <- addGitEnv r "GIT_OBJECT_DIRECTORY" tmpdir putStrLn "Unpacking all pack files." forM_ packs $ \packfile -> do - moveFile packfile (tmpdir </> takeFileName packfile) - nukeFile $ packIdxFile packfile - forM_ packs $ \packfile -> do - let tmp = tmpdir </> takeFileName packfile - allowRead tmp + -- Just in case permissions are messed up. + allowRead (toRawFilePath packfile) -- May fail, if pack file is corrupt. void $ tryIO $ - pipeWrite [Param "unpack-objects", Param "-r"] r $ \h -> - L.hPut h =<< L.readFile tmp + pipeWrite [Param "unpack-objects", Param "-r"] r' $ \h -> + L.hPut h =<< L.readFile packfile + objs <- dirContentsRecursive tmpdir + forM_ objs $ \objfile -> do + f <- relPathDirToFile + (toRawFilePath tmpdir) + (toRawFilePath objfile) + let dest = objectsDir r P.</> f + createDirectoryIfMissing True + (fromRawFilePath (parentDir dest)) + moveFile (toRawFilePath objfile) dest + forM_ packs $ \packfile -> do + let f = toRawFilePath packfile + removeWhenExistsWith R.removeLink f + removeWhenExistsWith R.removeLink (packIdxFile f) return True {- Try to retrieve a set of missing objects, from the remotes of a - - repository. Returns any that could not be retreived. + - repository. Returns any that could not be retrieved. - - 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 @@ -99,8 +115,11 @@ retrieveMissingObjects missing referencerepo r | not (foundBroken missing) = return missing | otherwise = withTmpDir "tmprepo" $ \tmpdir -> do unlessM (boolSystem "git" [Param "init", File tmpdir]) $ - error $ "failed to create temp repository in " ++ tmpdir - tmpr <- Config.read =<< Construct.fromAbsPath tmpdir + giveup $ "failed to create temp repository in " ++ tmpdir + tmpr <- Config.read =<< Construct.fromPath (toRawFilePath tmpdir) + let repoconfig r' = fromRawFilePath (localGitDir r' P.</> "config") + whenM (doesFileExist (repoconfig r)) $ + L.readFile (repoconfig r) >>= L.writeFile (repoconfig tmpr) rs <- Construct.fromRemotes r stillmissing <- pullremotes tmpr rs fetchrefstags missing if S.null (knownMissing stillmissing) @@ -122,24 +141,26 @@ retrieveMissingObjects missing referencerepo r ) pullremotes tmpr (rmt:rmts) fetchrefs ms | not (foundBroken ms) = return ms - | otherwise = do - putStrLn $ "Trying to recover missing objects from remote " ++ repoDescribe rmt ++ "." - ifM (fetchfrom (repoLocation rmt) fetchrefs tmpr) - ( do - void $ explodePacks tmpr - void $ copyObjects tmpr r - case ms of - FsckFailed -> pullremotes tmpr rmts fetchrefs ms - FsckFoundMissing s t -> do - stillmissing <- findMissing (S.toList s) r - pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) - , pullremotes tmpr rmts fetchrefs ms - ) - fetchfrom fetchurl ps fetchr = runBool ps' fetchr' + | otherwise = case remoteName rmt of + Just n -> do + putStrLn $ "Trying to recover missing objects from remote " ++ n ++ "." + ifM (fetchfrom n fetchrefs tmpr) + ( do + void $ explodePacks tmpr + void $ copyObjects tmpr r + case ms of + FsckFailed -> pullremotes tmpr rmts fetchrefs ms + FsckFoundMissing s t -> do + stillmissing <- findMissing (S.toList s) r + pullremotes tmpr rmts fetchrefs (FsckFoundMissing stillmissing t) + , pullremotes tmpr rmts fetchrefs ms + ) + Nothing -> pullremotes tmpr rmts fetchrefs ms + fetchfrom loc ps fetchr = runBool ps' fetchr' where ps' = [ Param "fetch" - , Param fetchurl + , Param loc , Param "--force" , Param "--update-head-ok" , Param "--quiet" @@ -159,8 +180,8 @@ retrieveMissingObjects missing referencerepo r copyObjects :: Repo -> Repo -> IO Bool copyObjects srcr destr = rsync [ Param "-qr" - , File $ addTrailingPathSeparator $ objectsDir srcr - , File $ addTrailingPathSeparator $ objectsDir destr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir srcr + , File $ addTrailingPathSeparator $ fromRawFilePath $ objectsDir destr ] {- To deal with missing objects that cannot be recovered, resets any @@ -232,23 +253,27 @@ getAllRefs r = getAllRefs' (fromRawFilePath (localGitDir r) </> "refs") getAllRefs' :: FilePath -> IO [Ref] getAllRefs' refdir = do let topsegs = length (splitPath refdir) - 1 - let toref = Ref . joinPath . drop topsegs . splitPath + let toref = Ref . toInternalGitPath . encodeBS + . joinPath . drop topsegs . splitPath map toref <$> dirContentsRecursive refdir explodePackedRefsFile :: Repo -> IO () explodePackedRefsFile r = do let f = packedRefsFile r + let f' = toRawFilePath f whenM (doesFileExist f) $ do rs <- mapMaybe parsePacked . lines - <$> catchDefaultIO "" (safeReadFile f) + <$> catchDefaultIO "" (safeReadFile f') forM_ rs makeref - nukeFile f + removeWhenExistsWith R.removeLink f' where makeref (sha, ref) = do - let dest = fromRawFilePath (localGitDir r) </> fromRef ref - createDirectoryIfMissing True (parentDir dest) - unlessM (doesFileExist dest) $ - writeFile dest (fromRef sha) + let gitd = localGitDir r + let dest = gitd P.</> fromRef' ref + let dest' = fromRawFilePath dest + createDirectoryUnder [gitd] (parentDir dest) + unlessM (doesFileExist dest') $ + writeFile dest' (fromRef sha) packedRefsFile :: Repo -> FilePath packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs" @@ -256,14 +281,14 @@ packedRefsFile r = fromRawFilePath (localGitDir r) </> "packed-refs" parsePacked :: String -> Maybe (Sha, Ref) parsePacked l = case words l of (sha:ref:[]) - | isJust (extractSha sha) && Ref.legal True ref -> - Just (Ref sha, Ref ref) + | isJust (extractSha (encodeBS sha)) && Ref.legal True ref -> + Just (Ref (encodeBS sha), Ref (encodeBS ref)) _ -> Nothing {- git-branch -d cannot be used to remove a branch that is directly - pointing to a corrupt commit. -} nukeBranchRef :: Branch -> Repo -> IO () -nukeBranchRef b r = nukeFile $ fromRawFilePath (localGitDir r) </> fromRef b +nukeBranchRef b r = removeWhenExistsWith R.removeLink $ localGitDir r P.</> fromRef' b {- Finds the most recent commit to a branch that does not need any - of the missing objects. If the input branch is good as-is, returns it. @@ -278,13 +303,13 @@ findUncorruptedCommit missing goodcommits branch r = do if ok then return (Just branch, goodcommits') else do - (ls, cleanup) <- pipeNullSplit + (ls, cleanup) <- pipeNullSplit' [ Param "log" , Param "-z" , Param "--format=%H" , Param (fromRef branch) ] r - let branchshas = catMaybes $ map (extractSha . decodeBL) ls + let branchshas = catMaybes $ map extractSha ls reflogshas <- RefLog.get branch r -- XXX Could try a bit harder here, and look -- for uncorrupted old commits in branches in the @@ -302,7 +327,11 @@ findUncorruptedCommit missing goodcommits branch r = do - the commit. Also adds to a set of commit shas that have been verified to - be good, which can be passed into subsequent calls to avoid - redundant work when eg, chasing down branches to find the first - - uncorrupted commit. -} + - uncorrupted commit. + - + - When the sha is not a commit but some other git object, returns + - true, but does not add it to the set. + -} verifyCommit :: MissingObjects -> GoodCommits -> Sha -> Repo -> IO (Bool, GoodCommits) verifyCommit missing goodcommits commit r | checkGoodCommit commit goodcommits = return (True, goodcommits) @@ -314,21 +343,28 @@ verifyCommit missing goodcommits commit r , Param (fromRef commit) ] r let committrees = map (parse . decodeBL) ls - if any isNothing committrees || null committrees - then do - void cleanup - return (False, goodcommits) - else do - let cts = catMaybes committrees - ifM (cleanup <&&> check cts) - ( return (True, addGoodCommits (map fst cts) goodcommits) - , return (False, goodcommits) - ) + -- git log on an object that is not a commit will + -- succeed without any output + if null committrees + then ifM cleanup + ( return (True, goodcommits) + , return (False, goodcommits) + ) + else if any isNothing committrees + then do + void cleanup + return (False, goodcommits) + else do + let cts = catMaybes committrees + ifM (cleanup <&&> check cts) + ( return (True, addGoodCommits (map fst cts) goodcommits) + , return (False, goodcommits) + ) where parse l = case words l of (commitsha:treesha:[]) -> (,) - <$> extractSha commitsha - <*> extractSha treesha + <$> extractSha (encodeBS commitsha) + <*> extractSha (encodeBS treesha) _ -> Nothing check [] = return True check ((c, t):rest) @@ -341,8 +377,9 @@ verifyTree :: MissingObjects -> Sha -> Repo -> IO Bool verifyTree missing treesha r | S.member treesha missing = return False | otherwise = do - (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive treesha []) r - let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree) ls + let nolong = LsTree.LsTreeLong False + (ls, cleanup) <- pipeNullSplit (LsTree.lsTreeParams LsTree.LsTreeRecursive nolong treesha []) r + let objshas = mapMaybe (LsTree.sha <$$> eitherToMaybe . LsTree.parseLsTree nolong) ls if any (`S.member` missing) objshas then do void cleanup @@ -376,9 +413,8 @@ missingIndex r = not <$> doesFileExist (fromRawFilePath (localGitDir r) </> "ind partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) partitionIndex r = do (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r - l <- forM indexcontents $ \i -> case i of - (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i - _ -> pure (False, i) + l <- forM indexcontents $ \i@(_file, sha, _mode, _stagenum) -> + (,) <$> isMissing sha r <*> pure i let (bad, good) = partition fst l return (map snd bad, map snd good, cleanup) @@ -390,17 +426,16 @@ rewriteIndex r | otherwise = do (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do - nukeFile (indexFile r) + removeWhenExistsWith R.removeLink (indexFile r) UpdateIndex.streamUpdateIndex r =<< (catMaybes <$> mapM reinject good) void cleanup - return $ map (fromRawFilePath . fst3) bad + return $ map (\(file,_, _, _) -> fromRawFilePath file) bad where - reinject (file, Just sha, Just mode) = case toTreeItemType mode of + reinject (file, sha, mode, _) = case toTreeItemType mode of Nothing -> return Nothing Just treeitemtype -> Just <$> - UpdateIndex.stageFile sha treeitemtype (fromRawFilePath file) r - reinject _ = return Nothing + UpdateIndex.stageFile sha treeitemtype file r newtype GoodCommits = GoodCommits (S.Set Sha) @@ -439,31 +474,36 @@ displayList items header preRepair :: Repo -> IO () preRepair g = do unlessM (validhead <$> catchDefaultIO "" (safeReadFile headfile)) $ do - nukeFile headfile - writeFile headfile "ref: refs/heads/master" + removeWhenExistsWith R.removeLink headfile + writeFile (fromRawFilePath headfile) "ref: refs/heads/master" explodePackedRefsFile g - unless (repoIsLocalBare g) $ do - let f = indexFile g - void $ tryIO $ allowWrite f + unless (repoIsLocalBare g) $ + void $ tryIO $ allowWrite $ indexFile g where - headfile = fromRawFilePath (localGitDir g) </> "HEAD" - validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) + headfile = localGitDir g P.</> "HEAD" + validhead s = "ref: refs/" `isPrefixOf` s + || isJust (extractSha (encodeBS s)) {- Put it all together. -} runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) runRepair removablebranch forced g = do preRepair g putStrLn "Running git fsck ..." - fsckresult <- findBroken False g + fsckresult <- findBroken False False g if foundBroken fsckresult - then runRepair' removablebranch fsckresult forced Nothing g + then do + putStrLn "Fsck found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g else do + putStrLn "Fsck found no problems. Checking for broken branches." bad <- badBranches S.empty g if null bad then do putStrLn "No problems found." return (True, []) - else runRepair' removablebranch fsckresult forced Nothing g + else do + putStrLn "Found problems, attempting repair." + runRepair' removablebranch fsckresult forced Nothing g runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepairOf fsckresult removablebranch forced referencerepo g = do @@ -473,7 +513,7 @@ runRepairOf fsckresult removablebranch forced referencerepo g = do runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) runRepair' removablebranch fsckresult forced referencerepo g = do cleanCorruptObjects fsckresult g - missing <- findBroken False g + missing <- findBroken False False g stillmissing <- retrieveMissingObjects missing referencerepo g case stillmissing of FsckFoundMissing s t @@ -502,7 +542,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) ( do cleanCorruptObjects FsckFailed g - stillmissing' <- findBroken False g + stillmissing' <- findBroken False False g case stillmissing' of FsckFailed -> return (False, []) FsckFoundMissing s t -> forcerepair s t @@ -548,7 +588,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do -- the repair process. if fscktruncated then do - fsckresult' <- findBroken False g + fsckresult' <- findBroken False False g case fsckresult' of FsckFailed -> do putStrLn "git fsck is failing" @@ -567,10 +607,10 @@ runRepair' removablebranch fsckresult forced referencerepo g = do else successfulfinish modifiedbranches corruptedindex = do - nukeFile (indexFile g) + removeWhenExistsWith R.removeLink (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. - fsckresult' <- findBroken False g + fsckresult' <- findBroken False False g result <- runRepairOf fsckresult' removablebranch forced referencerepo g putStrLn "Removed the corrupted index file. You should look at what files are present in your working tree and git add them back to the index when appropriate." return result @@ -611,7 +651,7 @@ runRepair' removablebranch fsckresult forced referencerepo g = do successfulRepair :: (Bool, [Branch]) -> Bool successfulRepair = fst -safeReadFile :: FilePath -> IO String +safeReadFile :: RawFilePath -> IO String safeReadFile f = do allowRead f - readFileStrict f + readFileStrict (fromRawFilePath f) |