diff options
| -rw-r--r-- | .gitignore | 3 | ||||
| -rw-r--r-- | Git/FilePath.hs | 15 | ||||
| -rw-r--r-- | Git/Fsck.hs | 14 | ||||
| -rw-r--r-- | Git/Repair.hs | 121 | ||||
| -rw-r--r-- | TODO | 2 | ||||
| -rw-r--r-- | Utility/Process.hs | 10 | ||||
| -rw-r--r-- | Utility/Rsync.hs | 3 | ||||
| -rw-r--r-- | Utility/ThreadScheduler.hs | 7 | ||||
| -rw-r--r-- | debian/changelog | 6 | ||||
| -rw-r--r-- | git-repair.cabal | 2 | ||||
| -rw-r--r-- | git-repair.hs | 4 |
11 files changed, 117 insertions, 70 deletions
diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..55a966c --- /dev/null +++ b/.gitignore @@ -0,0 +1,3 @@ +Build/SysConfig.hs +tags +git-repair diff --git a/Git/FilePath.hs b/Git/FilePath.hs index 37d740f..4189244 100644 --- a/Git/FilePath.hs +++ b/Git/FilePath.hs @@ -45,15 +45,24 @@ asTopFilePath :: FilePath -> TopFilePath asTopFilePath file = TopFilePath file {- Git may use a different representation of a path when storing - - it internally. For example, on Windows, git uses '/' to separate paths - - stored in the repository, despite Windows using '\' -} + - it internally. + - + - On Windows, git uses '/' to separate paths stored in the repository, + - despite Windows using '\'. Also, git on windows dislikes paths starting + - with "./" or ".\". + - + -} type InternalGitPath = String toInternalGitPath :: FilePath -> InternalGitPath #ifndef mingw32_HOST_OS toInternalGitPath = id #else -toInternalGitPath = replace "\\" "/" +toInternalGitPath p = + let p' = replace "\\" "/" p + in if "./" `isPrefixOf` p' + then dropWhile (== '/') (drop 1 p') + else p' #endif fromInternalGitPath :: InternalGitPath -> FilePath diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 8d5b75b..5389d46 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -11,6 +11,7 @@ module Git.Fsck ( findBroken, foundBroken, findMissing, + isMissing, knownMissing, ) where @@ -25,6 +26,7 @@ import qualified Data.Set as S type MissingObjects = S.Set Sha data FsckResults = FsckFoundMissing MissingObjects | FsckFailed + deriving (Show) {- 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 @@ -59,15 +61,17 @@ knownMissing (FsckFoundMissing s) = s {- Finds objects that are missing from the git repsitory, or are corrupt. - - This does not use git cat-file --batch, because catting a corrupt - - object can cause it to crash, or to report incorrect size information.a + - object can cause it to crash, or to report incorrect size information. -} findMissing :: [Sha] -> Repo -> IO MissingObjects -findMissing objs r = S.fromList <$> filterM (not <$$> present) objs +findMissing objs r = S.fromList <$> filterM (`isMissing` r) objs + +isMissing :: Sha -> Repo -> IO Bool +isMissing s r = either (const True) (const False) <$> tryIO dump where - present o = either (const False) (const True) <$> tryIO (dump o) - dump o = runQuiet + dump = runQuiet [ Param "show" - , Param (show o) + , Param (show s) ] r findShas :: String -> [Sha] diff --git a/Git/Repair.hs b/Git/Repair.hs index 5afa5f9..3ae9c9f 100644 --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -1,4 +1,5 @@ {- git repository recovery +import qualified Data.Set as S - - Copyright 2013 Joey Hess <joey@kitenet.net> - @@ -12,10 +13,11 @@ module Git.Repair ( cleanCorruptObjects, retrieveMissingObjects, resetLocalBranches, - removeTrackingBranches, checkIndex, + checkIndexFast, missingIndex, emptyGoodCommits, + isTrackingBranch, ) where import Common @@ -187,15 +189,17 @@ resetLocalBranches missing goodcommits r = , Param (show c) ] r +isTrackingBranch :: Ref -> Bool +isTrackingBranch b = "refs/remotes/" `isPrefixOf` show b + {- To deal with missing objects that cannot be recovered, removes - - any remote tracking branches that reference them. Returns a list of - - all removed branches. + - any branches (filtered by a predicate) that reference them + - Returns a list of all removed branches. -} -removeTrackingBranches :: MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits) -removeTrackingBranches missing goodcommits r = - go [] goodcommits =<< filter istrackingbranch <$> getAllRefs r +removeBadBranches :: (Ref -> Bool) -> MissingObjects -> GoodCommits -> Repo -> IO ([Branch], GoodCommits) +removeBadBranches removablebranch missing goodcommits r = + go [] goodcommits =<< filter removablebranch <$> getAllRefs r where - istrackingbranch b = "refs/remotes/" `isPrefixOf` show b go removed gcs [] = return (removed, gcs) go removed gcs (b:bs) = do (ok, gcs') <- verifyCommit missing gcs b r @@ -335,35 +339,42 @@ verifyTree missing treesha r {- Checks that the index file only refers to objects that are not missing, - and is not itself corrupt. Note that a missing index file is not - considered a problem (repo may be new). -} -checkIndex :: MissingObjects -> Repo -> IO Bool -checkIndex missing r = do - (bad, _good, cleanup) <- partitionIndex missing r +checkIndex :: Repo -> IO Bool +checkIndex r = do + (bad, _good, cleanup) <- partitionIndex r if null bad then cleanup else do void cleanup return False +{- Does not check every object the index refers to, but only that the index + - itself is not corrupt. -} +checkIndexFast :: Repo -> IO Bool +checkIndexFast r = do + (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r + length indexcontents `seq` cleanup + missingIndex :: Repo -> IO Bool missingIndex r = not <$> doesFileExist (localGitDir r </> "index") -partitionIndex :: MissingObjects -> Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) -partitionIndex missing r = do +{- Finds missing and ok files staged in the index. -} +partitionIndex :: Repo -> IO ([LsFiles.StagedDetails], [LsFiles.StagedDetails], IO Bool) +partitionIndex r = do (indexcontents, cleanup) <- LsFiles.stagedDetails [repoPath r] r - let (bad, good) = partition ismissing indexcontents - return (bad, good, cleanup) - where - getblob (_file, Just sha, Just _mode) = Just sha - getblob _ = Nothing - ismissing = maybe False (`S.member` missing) . getblob + l <- forM indexcontents $ \i -> case i of + (_file, Just sha, Just _mode) -> (,) <$> isMissing sha r <*> pure i + _ -> pure (False, i) + let (bad, good) = partition fst l + return (map snd bad, map snd good, cleanup) {- Rewrites the index file, removing from it any files whose blobs are - missing. Returns the list of affected files. -} -rewriteIndex :: MissingObjects -> Repo -> IO [FilePath] -rewriteIndex missing r +rewriteIndex :: Repo -> IO [FilePath] +rewriteIndex r | repoIsLocalBare r = return [] | otherwise = do - (bad, good, cleanup) <- partitionIndex missing r + (bad, good, cleanup) <- partitionIndex r unless (null bad) $ do nukeFile (indexFile r) UpdateIndex.streamUpdateIndex r @@ -425,40 +436,40 @@ preRepair g = do validhead s = "ref: refs/" `isPrefixOf` s || isJust (extractSha s) {- Put it all together. -} -runRepair :: Bool -> Repo -> IO (Bool, MissingObjects, [Branch]) -runRepair forced g = do +runRepair :: (Ref -> Bool) -> Bool -> Repo -> IO (Bool, [Branch]) +runRepair removablebranch forced g = do preRepair g putStrLn "Running git fsck ..." fsckresult <- findBroken False g if foundBroken fsckresult - then runRepair' fsckresult forced Nothing g + then runRepair' removablebranch fsckresult forced Nothing g else do putStrLn "No problems found." - return (True, S.empty, []) + return (True, []) -runRepairOf :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) -runRepairOf fsckresult forced referencerepo g = do +runRepairOf :: FsckResults -> (Ref -> Bool) -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepairOf fsckresult removablebranch forced referencerepo g = do preRepair g - runRepair' fsckresult forced referencerepo g + runRepair' removablebranch fsckresult forced referencerepo g -runRepair' :: FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, MissingObjects, [Branch]) -runRepair' fsckresult forced referencerepo g = do +runRepair' :: (Ref -> Bool) -> FsckResults -> Bool -> Maybe FilePath -> Repo -> IO (Bool, [Branch]) +runRepair' removablebranch fsckresult forced referencerepo g = do missing <- cleanCorruptObjects fsckresult g stillmissing <- retrieveMissingObjects missing referencerepo g case stillmissing of FsckFoundMissing s | S.null s -> if repoIsLocalBare g - then successfulfinish S.empty [] - else ifM (checkIndex S.empty g) - ( successfulfinish s [] + then successfulfinish [] + else ifM (checkIndex g) + ( successfulfinish [] , do putStrLn "No missing objects found, but the index file is corrupt!" if forced then corruptedindex - else needforce S.empty + else needforce ) | otherwise -> if forced - then ifM (checkIndex s g) + then ifM (checkIndex g) ( continuerepairs s , corruptedindex ) @@ -467,20 +478,22 @@ runRepair' fsckresult forced referencerepo g = do [ show (S.size s) , "missing objects could not be recovered!" ] - unsuccessfulfinish s + unsuccessfulfinish FsckFailed - | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex S.empty g) + | forced -> ifM (pure (repoIsLocalBare g) <||> checkIndex g) ( do missing' <- cleanCorruptObjects FsckFailed g case missing' of - FsckFailed -> return (False, S.empty, []) - FsckFoundMissing stillmissing' -> continuerepairs stillmissing' + FsckFailed -> return (False, []) + FsckFoundMissing stillmissing' -> + continuerepairs stillmissing' , corruptedindex ) - | otherwise -> unsuccessfulfinish S.empty + | otherwise -> unsuccessfulfinish where continuerepairs stillmissing = do - (remotebranches, goodcommits) <- removeTrackingBranches stillmissing emptyGoodCommits g + (removedbranches, goodcommits) <- removeBadBranches removablebranch stillmissing emptyGoodCommits g + let remotebranches = filter isTrackingBranch removedbranches unless (null remotebranches) $ putStrLn $ unwords [ "Removed" @@ -492,12 +505,12 @@ runRepair' fsckresult forced referencerepo g = do "Reset these local branches to old versions before the missing objects were committed:" displayList (map show deletedbranches) "Deleted these local branches, which could not be recovered due to missing objects:" - deindexedfiles <- rewriteIndex stillmissing g + deindexedfiles <- rewriteIndex g displayList deindexedfiles "Removed these missing files from the index. You should look at what files are present in your working tree and git add them back to the index when appropriate." let modifiedbranches = resetbranches ++ deletedbranches if null resetbranches && null deletedbranches - then successfulfinish stillmissing modifiedbranches + then successfulfinish modifiedbranches else do unless (repoIsLocalBare g) $ do mcurr <- Branch.currentUnsafe g @@ -511,36 +524,36 @@ runRepair' fsckresult forced referencerepo g = do ] putStrLn "Successfully recovered repository!" putStrLn "Please carefully check that the changes mentioned above are ok.." - return (True, stillmissing, modifiedbranches) + return (True, modifiedbranches) corruptedindex = do nukeFile (indexFile g) -- The corrupted index can prevent fsck from finding other -- problems, so re-run repair. fsckresult' <- findBroken False g - result <- runRepairOf fsckresult' forced referencerepo 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 - successfulfinish stillmissing modifiedbranches = do + successfulfinish modifiedbranches = do mapM_ putStrLn [ "Successfully recovered repository!" , "You should run \"git fsck\" to make sure, but it looks like everything was recovered ok." ] - return (True, stillmissing, modifiedbranches) - unsuccessfulfinish stillmissing = do + return (True, modifiedbranches) + unsuccessfulfinish = do if repoIsLocalBare g then do putStrLn "If you have a clone of this bare repository, you should add it as a remote of this repository, and retry." putStrLn "If there are no clones of this repository, you can instead retry with the --force parameter to force recovery to a possibly usable state." - return (False, stillmissing, []) - else needforce stillmissing - needforce stillmissing = do + return (False, []) + else needforce + needforce = do putStrLn "To force a recovery to a usable state, retry with the --force parameter." - return (False, stillmissing, []) + return (False, []) -successfulRepair :: (Bool, MissingObjects, [Branch]) -> Bool -successfulRepair = fst3 +successfulRepair :: (Bool, [Branch]) -> Bool +successfulRepair = fst safeReadFile :: FilePath -> IO String safeReadFile f = do @@ -0,0 +1,2 @@ +* git-reflog can fail if HEAD is missing. + Manually parse the reflog in this case (or supply a dummy HEAD?) diff --git a/Utility/Process.hs b/Utility/Process.hs index 398e8a3..03cbe95 100644 --- a/Utility/Process.hs +++ b/Utility/Process.hs @@ -22,6 +22,7 @@ module Utility.Process ( createProcessChecked, createBackgroundProcess, processTranscript, + processTranscript', withHandle, withBothHandles, withQuietOutput, @@ -162,10 +163,13 @@ createBackgroundProcess p a = a =<< createProcess p - returns a transcript combining its stdout and stderr, and - whether it succeeded or failed. -} processTranscript :: String -> [String] -> (Maybe String) -> IO (String, Bool) +processTranscript cmd opts input = processTranscript' cmd opts Nothing input + +processTranscript' :: String -> [String] -> Maybe [(String, String)] -> (Maybe String) -> IO (String, Bool) #ifndef mingw32_HOST_OS {- This implementation interleves stdout and stderr in exactly the order - the process writes them. -} -processTranscript cmd opts input = do +processTranscript' cmd opts environ input = do (readf, writef) <- createPipe readh <- fdToHandle readf writeh <- fdToHandle writef @@ -174,6 +178,7 @@ processTranscript cmd opts input = do { std_in = if isJust input then CreatePipe else Inherit , std_out = UseHandle writeh , std_err = UseHandle writeh + , env = environ } hClose writeh @@ -195,12 +200,13 @@ processTranscript cmd opts input = do return (transcript, ok) #else {- This implementation for Windows puts stderr after stdout. -} -processTranscript cmd opts input = do +processTranscript' cmd opts environ input = do p@(_, _, _, pid) <- createProcess $ (proc cmd opts) { std_in = if isJust input then CreatePipe else Inherit , std_out = CreatePipe , std_err = CreatePipe + , env = environ } getout <- mkreader (stdoutHandle p) diff --git a/Utility/Rsync.hs b/Utility/Rsync.hs index 5f322a0..2c5e39b 100644 --- a/Utility/Rsync.hs +++ b/Utility/Rsync.hs @@ -67,7 +67,8 @@ rsyncParamsFixup = map fixup -} rsyncProgress :: MeterUpdate -> [CommandParam] -> IO Bool rsyncProgress meterupdate params = do - r <- withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) + r <- catchBoolIO $ + withHandle StdoutHandle createProcessSuccess p (feedprogress 0 []) {- For an unknown reason, piping rsync's output like this does - causes it to run a second ssh process, which it neglects to wait - on. Reap the resulting zombie. -} diff --git a/Utility/ThreadScheduler.hs b/Utility/ThreadScheduler.hs index c3e871c..dbb6cb3 100644 --- a/Utility/ThreadScheduler.hs +++ b/Utility/ThreadScheduler.hs @@ -53,8 +53,11 @@ unboundDelay time = do {- Pauses the main thread, letting children run until program termination. -} waitForTermination :: IO () waitForTermination = do +#ifdef mingw32_HOST_OS + runEvery (Seconds 600) $ + void getLine +#else lock <- newEmptyMVar -#ifndef mingw32_HOST_OS let check sig = void $ installHandler sig (CatchOnce $ putMVar lock ()) Nothing check softwareTermination @@ -62,8 +65,8 @@ waitForTermination = do whenM (queryTerminal stdInput) $ check keyboardSignal #endif -#endif takeMVar lock +#endif oneSecond :: Microseconds oneSecond = 1000000 diff --git a/debian/changelog b/debian/changelog index 1eb84fc..7914ff4 100644 --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-repair (1.20131213) unstable; urgency=low + + * Improve repair of index files in some situations. + + -- Joey Hess <joeyh@debian.org> Fri, 13 Dec 2013 14:51:51 -0400 + git-repair (1.20131203) unstable; urgency=low * Fix build deps. Closes: #731179 diff --git a/git-repair.cabal b/git-repair.cabal index c9374b0..eb98193 100644 --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20131122 +Version: 1.20131213 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net> diff --git a/git-repair.hs b/git-repair.hs index 0aedc27..847ef0c 100644 --- a/git-repair.hs +++ b/git-repair.hs @@ -59,7 +59,7 @@ main = execParser opts >>= go repair :: Settings -> IO () repair settings = do g <- Git.Config.read =<< Git.CurrentRepo.get - ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair (forced settings) g) + ifM (Git.Repair.successfulRepair <$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g) ( exitSuccess , exitFailure ) @@ -94,7 +94,7 @@ runTest settings damage = withTmpDir "tmprepo" $ \tmpdir -> do g <- Git.Config.read =<< Git.Construct.fromPath cloneloc Git.Destroyer.applyDamage damage g repairstatus <- catchMaybeIO $ Git.Repair.successfulRepair - <$> Git.Repair.runRepair (forced settings) g + <$> Git.Repair.runRepair Git.Repair.isTrackingBranch (forced settings) g case repairstatus of Just True -> testResult repairstatus . Just . not . Git.Fsck.foundBroken |