git-repair 1.20131122 → 1.20131203
raw patch · 12 files changed
+157/−77 lines, 12 filesdep −SHA
Dependencies removed: SHA
Files
- Build/Configure.hs +0/−1
- Git/Branch.hs +28/−8
- Git/Config.hs +7/−2
- Git/Fsck.hs +15/−13
- Git/Index.hs +32/−0
- Git/Ref.hs +6/−0
- Git/Repair.hs +20/−26
- Utility/Batch.hs +26/−24
- debian/changelog +6/−0
- debian/control +7/−1
- doc/index.mdwn +4/−0
- git-repair.cabal +6/−2
Build/Configure.hs view
@@ -15,7 +15,6 @@ [ TestCase "version" getVersion , TestCase "git" $ requireCmd "git" "git --version >/dev/null" , TestCase "git version" getGitVersion- , TestCase "nice" $ testCmd "nice" "nice true >/dev/null" ] getGitVersion :: Test
Git/Branch.hs view
@@ -89,18 +89,38 @@ (False, False) -> findbest c rs -- same {- Commits the index into the specified branch (or other ref), - - with the specified parent refs, and returns the committed sha -}-commit :: String -> Branch -> [Ref] -> Repo -> IO Sha-commit message branch parentrefs repo = do+ - with the specified parent refs, and returns the committed sha.+ -+ - Without allowempy set, avoids making a commit if there is exactly+ - one parent, and it has the same tree that would be committed.+ -+ - Unlike git-commit, does not run any hooks, or examine the work tree+ - in any way.+ -}+commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)+commit allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo- sha <- getSha "commit-tree" $ pipeWriteRead- (map Param $ ["commit-tree", show tree] ++ ps)- (Just $ flip hPutStr message) repo- update branch sha repo- return sha+ ifM (cancommit tree)+ ( do+ sha <- getSha "commit-tree" $ pipeWriteRead+ (map Param $ ["commit-tree", show tree] ++ ps)+ (Just $ flip hPutStr message) repo+ update branch sha repo+ return $ Just sha+ , return Nothing+ ) where ps = concatMap (\r -> ["-p", show r]) parentrefs+ cancommit tree+ | allowempty = return True+ | otherwise = case parentrefs of+ [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo+ _ -> return True++commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha+commitAlways message branch parentrefs repo = fromJust+ <$> commit True message branch parentrefs repo {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String
Git/Config.hs view
@@ -110,8 +110,13 @@ -} updateLocation :: Repo -> IO Repo updateLocation r@(Repo { location = LocalUnknown d })- | isBare r = updateLocation' r $ Local d Nothing- | otherwise = updateLocation' r $ Local (d </> ".git") (Just d)+ | isBare r = ifM (doesDirectoryExist dotgit)+ ( updateLocation' r $ Local dotgit Nothing+ , updateLocation' r $ Local d Nothing+ )+ | otherwise = updateLocation' r $ Local dotgit (Just d)+ where+ dotgit = (d </> ".git") updateLocation r@(Repo { location = l@(Local {}) }) = updateLocation' r l updateLocation r = return r
Git/Fsck.hs view
@@ -6,11 +6,12 @@ -} module Git.Fsck (- FsckResults,+ FsckResults(..), MissingObjects, findBroken, foundBroken, findMissing,+ knownMissing, ) where import Common@@ -23,9 +24,7 @@ type MissingObjects = S.Set Sha -{- If fsck succeeded, Just a set of missing objects it found.- - If it failed, Nothing. -}-type FsckResults = Maybe MissingObjects+data FsckResults = FsckFoundMissing MissingObjects | FsckFailed {- 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@@ -38,21 +37,24 @@ -} findBroken :: Bool -> Repo -> IO FsckResults findBroken batchmode r = do+ let (command, params) = ("git", fsckParams r)+ (command', params') <- if batchmode+ then toBatchCommand (command, params)+ else return (command, params) (output, fsckok) <- processTranscript command' (toCommand params') Nothing let objs = findShas 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)+ then return FsckFailed+ else return $ FsckFoundMissing badobjs foundBroken :: FsckResults -> Bool-foundBroken Nothing = True-foundBroken (Just s) = not (S.null s)+foundBroken FsckFailed = True+foundBroken (FsckFoundMissing s) = not (S.null s)++knownMissing :: FsckResults -> MissingObjects+knownMissing FsckFailed = S.empty+knownMissing (FsckFoundMissing s) = s {- Finds objects that are missing from the git repsitory, or are corrupt. -
+ Git/Index.hs view
@@ -0,0 +1,32 @@+{- git index file stuff+ -+ - Copyright 2011 Joey Hess <joey@kitenet.net>+ -+ - Licensed under the GNU GPL version 3 or higher.+ -}++module Git.Index where++import Common+import Git+import Utility.Env++{- Forces git to use the specified index file.+ -+ - Returns an action that will reset back to the default+ - index file.+ -+ - Warning: Not thread safe.+ -}+override :: FilePath -> IO (IO ())+override index = do+ res <- getEnv var+ void $ setEnv var index True+ return $ void $ reset res+ where+ var = "GIT_INDEX_FILE"+ reset (Just v) = setEnv var v True+ reset _ = unsetEnv var++indexFile :: Repo -> FilePath+indexFile r = localGitDir r </> "index"
Git/Ref.hs view
@@ -10,6 +10,7 @@ import Common import Git import Git.Command+import Git.Sha import Data.Char (chr) @@ -104,6 +105,11 @@ matchingUniq refs repo = nubBy uniqref <$> matching refs repo where uniqref (a, _) (b, _) = a == b++{- Gets the sha of the tree a ref uses. -}+tree :: Ref -> Repo -> IO (Maybe Sha)+tree ref = extractSha <$$> pipeReadStrict+ [ Param "rev-parse", Param (show ref ++ ":") ] {- Checks if a String is a legal git ref name. -
Git/Repair.hs view
@@ -25,6 +25,7 @@ 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@@ -42,17 +43,16 @@ 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 @@ - 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 @@ 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 @@ 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 $@@ -380,9 +377,6 @@ UpdateIndex.stageFile sha blobtype file r reinject _ = return Nothing -indexFile :: Repo -> FilePath-indexFile r = localGitDir r </> "index"- newtype GoodCommits = GoodCommits (S.Set Sha) emptyGoodCommits :: GoodCommits@@ -452,7 +446,7 @@ 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)@@ -474,13 +468,13 @@ , "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
Utility/Batch.hs view
@@ -10,9 +10,6 @@ module Utility.Batch where import Common-#ifndef mingw32_HOST_OS-import qualified Build.SysConfig-#endif #if defined(linux_HOST_OS) || defined(__ANDROID__) import Control.Concurrent.Async@@ -46,36 +43,45 @@ maxNice :: Int maxNice = 19 -{- Converts a command to run niced. -}-toBatchCommand :: (String, [CommandParam]) -> (String, [CommandParam])-toBatchCommand (command, params) = (command', params')- where+{- Makes a command be run by whichever of nice, ionice, and nocache+ - are available in the path. -}+type BatchCommandMaker = (String, [CommandParam]) -> (String, [CommandParam])++getBatchCommandMaker :: IO BatchCommandMaker+getBatchCommandMaker = do #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+ nicers <- filterM (inPath . fst)+ [ ("nice", [])+ , ("ionice", ["-c3"])+ , ("nocache", []) ]+ return $ \(command, params) ->+ case nicers of+ [] -> (command, params)+ (first:rest) -> (fst first, map Param (snd first ++ concatMap (\p -> fst p : snd p) rest ++ [command]) ++ params) #else- command' = command- params' = params+ return id #endif +toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])+toBatchCommand v = do+ batchmaker <- getBatchCommandMaker+ return $ batchmaker v+ {- 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. -}+ - 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. -} batchCommand :: String -> [CommandParam] -> IO Bool batchCommand command params = batchCommandEnv command params Nothing batchCommandEnv :: String -> [CommandParam] -> Maybe [(String, String)] -> IO Bool batchCommandEnv command params environ = do+ batchmaker <- getBatchCommandMaker+ let (command', params') = batchmaker (command, params)+ let p = proc command' $ toCommand params' (_, _, _, pid) <- createProcess $ p { env = environ } r <- E.try (waitForProcess pid) :: IO (Either E.SomeException ExitCode) case r of@@ -85,7 +91,3 @@ terminateProcess pid void $ waitForProcess pid E.throwIO asyncexception- where- (command', params') = toBatchCommand (command, params)- p = proc command' $ toCommand params'-
debian/changelog view
@@ -1,3 +1,9 @@+git-repair (1.20131203) unstable; urgency=low++ * Fix build deps. Closes: #731179++ -- Joey Hess <joeyh@debian.org> Tue, 03 Dec 2013 15:02:21 -0400+ git-repair (1.20131122) unstable; urgency=low * Added test mode, which can be used to randomly corrupt test
debian/control view
@@ -8,9 +8,11 @@ libghc-missingh-dev, libghc-hslogger-dev, libghc-network-dev,- libghc-ifelse-dev, libghc-extensible-exceptions-dev, libghc-unix-compat-dev,+ libghc-ifelse-dev,+ libghc-text-dev,+ libghc-quickcheck2-dev, libghc-utf8-string-dev, libghc-async-dev, libghc-optparse-applicative-dev@@ -27,3 +29,7 @@ git-repair can repair various forms of damage to git repositories. . It is a complement to git fsck, which finds problems, but does not fix them.+ .+ As well as avoiding the need to rm -rf a damaged repository and re-clone,+ using git-repair can help rescue commits you've made to the damaged+ repository and not yet pushed out.
doc/index.mdwn view
@@ -3,6 +3,10 @@ It is a complement to `git fsck`, which finds problems, but does not fix them. +As well as avoiding the need to rm -rf a damaged repository and re-clone,+using git-repair can help rescue commits you've made to the damaged+repository and not yet pushed out.+ ## download * `git clone git://git-repair.branchable.com/ git-repair`
git-repair.cabal view
@@ -1,5 +1,5 @@ Name: git-repair-Version: 1.20131122+Version: 1.20131203 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess <joey@kitenet.net>@@ -16,6 +16,10 @@ . It is a complement to git fsck, which finds problems, but does not fix them.+ .+ As well as avoiding the need to rm -rf a damaged repository and re-clone,+ using git-repair can help rescue commits you've made to the damaged+ repository and not yet pushed out. Executable git-repair Main-Is: git-repair.hs@@ -23,7 +27,7 @@ Build-Depends: MissingH, hslogger, directory, filepath, containers, mtl, network, extensible-exceptions, unix-compat, bytestring, base >= 4.5, base < 5, IfElse, text, process, time, QuickCheck,- utf8-string, async, optparse-applicative, SHA+ utf8-string, async, optparse-applicative if (! os(windows)) Build-Depends: unix