diff --git a/Build/Configure.hs b/Build/Configure.hs --- a/Build/Configure.hs +++ b/Build/Configure.hs @@ -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 diff --git a/Git/Branch.hs b/Git/Branch.hs --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -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 diff --git a/Git/Config.hs b/Git/Config.hs --- a/Git/Config.hs +++ b/Git/Config.hs @@ -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 diff --git a/Git/Fsck.hs b/Git/Fsck.hs --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -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. - diff --git a/Git/Index.hs b/Git/Index.hs new file mode 100644 --- /dev/null +++ b/Git/Index.hs @@ -0,0 +1,32 @@ +{- git index file stuff + - + - Copyright 2011 Joey Hess + - + - 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" diff --git a/Git/Ref.hs b/Git/Ref.hs --- a/Git/Ref.hs +++ b/Git/Ref.hs @@ -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. - diff --git a/Git/Repair.hs b/Git/Repair.hs --- a/Git/Repair.hs +++ b/Git/Repair.hs @@ -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 diff --git a/Utility/Batch.hs b/Utility/Batch.hs --- a/Utility/Batch.hs +++ b/Utility/Batch.hs @@ -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' - diff --git a/debian/changelog b/debian/changelog --- a/debian/changelog +++ b/debian/changelog @@ -1,3 +1,9 @@ +git-repair (1.20131203) unstable; urgency=low + + * Fix build deps. Closes: #731179 + + -- Joey Hess 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 diff --git a/debian/control b/debian/control --- a/debian/control +++ b/debian/control @@ -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. diff --git a/doc/index.mdwn b/doc/index.mdwn --- a/doc/index.mdwn +++ b/doc/index.mdwn @@ -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` diff --git a/git-repair.cabal b/git-repair.cabal --- a/git-repair.cabal +++ b/git-repair.cabal @@ -1,5 +1,5 @@ Name: git-repair -Version: 1.20131122 +Version: 1.20131203 Cabal-Version: >= 1.6 License: GPL Maintainer: Joey Hess @@ -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