diff options
| -rw-r--r-- | Git/Fsck.hs | 17 | ||||
| -rw-r--r-- | Git/RecoverRepository.hs | 22 | ||||
| -rw-r--r-- | Utility/Batch.hs | 38 | ||||
| -rw-r--r-- | git-recover-repository.hs | 7 |
4 files changed, 54 insertions, 30 deletions
diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 5fdc73385..3872c6b04 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -16,6 +16,7 @@ import Git import Git.Command import Git.Sha import Git.CatFile +import Utility.Batch import qualified Data.Set as S @@ -31,17 +32,25 @@ type MissingObjects = S.Set Sha - to be a git sha. Not all such shas are of broken objects, so ask git - to try to cat the object, and see if it fails. -} -findBroken :: Repo -> IO (Maybe MissingObjects) -findBroken r = do - (output, fsckok) <- processTranscript "git" (toCommand $ fsckParams r) Nothing +findBroken :: Bool -> Repo -> IO (Maybe MissingObjects) +findBroken batchmode r = do + (output, fsckok) <- processTranscript command' (toCommand params') Nothing let objs = parseFsckOutput output badobjs <- findMissing objs r if S.null badobjs && not fsckok then return Nothing else return $ Just badobjs + where + (command, params) = ("git", fsckParams r) + (command', params') + | batchmode = toBatchCommand (command, params) + | otherwise = (command, params) {- Finds objects that are missing from the git repsitory, or are corrupt. - - Note that catting a corrupt object will cause cat-file to crash. -} + - + - Note that catting a corrupt object will cause cat-file to crash; + - this is detected and it's restarted. + -} findMissing :: [Sha] -> Repo -> IO MissingObjects findMissing objs r = go objs [] =<< start where diff --git a/Git/RecoverRepository.hs b/Git/RecoverRepository.hs index c2cad53f2..a109896e7 100644 --- a/Git/RecoverRepository.hs +++ b/Git/RecoverRepository.hs @@ -36,22 +36,22 @@ import qualified Data.ByteString.Lazy as L import System.Log.Logger import Data.Tuple.Utils -{- Finds and removes corrupt objects from the repository, returning a list - - of all such objects, which need to be found elsewhere to finish - - recovery. +{- Given a set of bad objects found by git fsck, removes all + - corrupt objects, and returns a list of missing objects, + - which need to be found elsewhere to finish recovery. - - - Strategy: Run git fsck, remove objects it identifies as corrupt, - - and repeat until git fsck finds no new objects. + - Since git fsck may crash on corrupt objects, and so not + - report the full set of corrupt or missing objects, + - this removes corrupt objects, and re-runs fsck, until it + - stabalizes. - - To remove corrupt objects, unpack all packs, and remove the packs - (to handle corrupt packs), and remove loose object files. -} -cleanCorruptObjects :: Repo -> IO MissingObjects -cleanCorruptObjects r = do - notice "Running git fsck ..." - check =<< findBroken r +cleanCorruptObjects :: Maybe MissingObjects -> Repo -> IO MissingObjects +cleanCorruptObjects mmissing r = check mmissing where - check Nothing = do + check Nothing = do notice "git fsck found a problem but no specific broken objects. Perhaps a corrupt pack file?" ifM (explodePacks r) ( retry S.empty @@ -72,7 +72,7 @@ cleanCorruptObjects r = do else return bad retry oldbad = do notice "Re-running git fsck to see if it finds more problems." - v <- findBroken r + v <- findBroken False r case v of Nothing -> error $ unwords [ "git fsck found a problem, which was not corrected after removing" diff --git a/Utility/Batch.hs b/Utility/Batch.hs index fcd844885..011d30c94 100644 --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -44,7 +44,28 @@ batch a = a maxNice :: Int maxNice = 19 -{- Runs a command in a way that's suitable for batch jobs. +{- Converts a command to run niced. -} +toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam]) +toBatchCommand (command, params) = (command', params') + where +#ifndef mingw32_HOST_OS + commandline = unwords $ map shellEscape $ command : toCommand params + nicedcommand + | Build.SysConfig.nice = "nice " ++ commandline + | otherwise = commandline + command' = "sh" + params' = + [ Param "-c" + , Param $ "exec " ++ nicedcommand + ] +#else + command' = command + params' = params +#endif + +{- Runs a command in a way that's suitable for batch jobs that can be + - interrupted. + - - The command is run niced. If the calling thread receives an async - exception, it sends the command a SIGTERM, and after the command - finishes shuttting down, it re-raises the async exception. -} @@ -63,15 +84,6 @@ batchCommandEnv command params environ = do void $ waitForProcess pid E.throwIO asyncexception where -#ifndef mingw32_HOST_OS - p = proc "sh" - [ "-c" - , "exec " ++ nicedcommand - ] - commandline = unwords $ map shellEscape $ command : toCommand params - nicedcommand - | Build.SysConfig.nice = "nice " ++ commandline - | otherwise = commandline -#else - p = proc command (toCommand params) -#endif + (command', params') = toBatchCommand (command, params) + p = proc command' $ toCommand params' + diff --git a/git-recover-repository.hs b/git-recover-repository.hs index 11a0b3a1c..d2249a433 100644 --- a/git-recover-repository.hs +++ b/git-recover-repository.hs @@ -1,6 +1,6 @@ {- git-recover-repository program - - - Copyright 2012 Joey Hess <joey@kitenet.net> + - Copyright 2013 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -15,6 +15,7 @@ import qualified Data.Set as S import Common import qualified Git import qualified Git.CurrentRepo +import qualified Git.Fsck import qualified Git.RecoverRepository import qualified Git.Config import qualified Git.Branch @@ -46,7 +47,9 @@ main = do forced <- parseArgs g <- Git.Config.read =<< Git.CurrentRepo.get - missing <- Git.RecoverRepository.cleanCorruptObjects g + putStrLn "Running git fsck ..." + fsckresult <- Git.Fsck.findBroken False g + missing <- Git.RecoverRepository.cleanCorruptObjects fsckresult g stillmissing <- Git.RecoverRepository.retrieveMissingObjects missing g if S.null stillmissing then putStr $ unlines |