summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--Build/Configure.hs1
-rw-r--r--Git/Branch.hs36
-rw-r--r--Git/Config.hs9
-rw-r--r--Git/Fsck.hs28
-rw-r--r--Git/Index.hs32
-rw-r--r--Git/Ref.hs6
-rw-r--r--Git/Repair.hs46
-rw-r--r--Utility/Batch.hs50
-rw-r--r--debian/changelog6
-rw-r--r--debian/control8
-rw-r--r--doc/index.mdwn7
-rw-r--r--git-repair.cabal8
12 files changed, 159 insertions, 78 deletions
diff --git a/Build/Configure.hs b/Build/Configure.hs
index 5f41a1b..4912122 100644
--- a/Build/Configure.hs
+++ b/Build/Configure.hs
@@ -15,7 +15,6 @@ tests =
[ 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
index 7b3297d..405fa10 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -89,18 +89,38 @@ fastForward branch (first:rest) repo =
(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
index 1919ece..b5c1be0 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -110,8 +110,13 @@ store s repo = do
-}
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
index 8bfddb4..8d5b75b 100644
--- 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 @@ import qualified Data.Set as S
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 @@ type FsckResults = Maybe MissingObjects
-}
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
index 0000000..d9d5b03
--- /dev/null
+++ b/Git/Index.hs
@@ -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"
diff --git a/Git/Ref.hs b/Git/Ref.hs
index 6ce1b87..0947293 100644
--- a/Git/Ref.hs
+++ b/Git/Ref.hs
@@ -10,6 +10,7 @@ module Git.Ref where
import Common
import Git
import Git.Command
+import Git.Sha
import Data.Char (chr)
@@ -105,6 +106,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.
-
- The rules for this are complex; see git-check-ref-format(1) -}
diff --git a/Git/Repair.hs b/Git/Repair.hs
index f1e6818..5afa5f9 100644
--- a/Git/Repair.hs
+++ b/Git/Repair.hs
@@ -25,6 +25,7 @@ import Git.Objects
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 qualified Data.ByteString.Lazy as L
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 @@ explodePacks r = do
- 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 @@ retrieveMissingObjects missing referencerepo r
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 @@ retrieveMissingObjects missing referencerepo r
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 @@ rewriteIndex missing r
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 @@ runRepair' fsckresult forced referencerepo g = do
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 @@ runRepair' fsckresult forced referencerepo g = do
, "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
index 035a2eb..61026f1 100644
--- 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 @@ batch a = a
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 @@ batchCommandEnv command params environ = do
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
index 91d0bd2..1eb84fc 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -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
diff --git a/debian/control b/debian/control
index bf14911..cecd327 100644
--- a/debian/control
+++ b/debian/control
@@ -8,9 +8,11 @@ Build-Depends:
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 @@ Description: repair various forms of damage to git repositorie
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
index f880bc6..1d9a7a9 100644
--- a/doc/index.mdwn
+++ b/doc/index.mdwn
@@ -3,9 +3,14 @@
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 clone git://git-repair.branchable.com/ git-repair`
+* from [Hackage](http://hackage.haskell.org/package/git-repair)
## install
diff --git a/git-repair.cabal b/git-repair.cabal
index 05e3f46..c9374b0 100644
--- a/git-repair.cabal
+++ b/git-repair.cabal
@@ -1,5 +1,5 @@
Name: git-repair
-Version: 1.20131119
+Version: 1.20131122
Cabal-Version: >= 1.6
License: GPL
Maintainer: Joey Hess <joey@kitenet.net>
@@ -16,6 +16,10 @@ Description:
.
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 @@ Executable git-repair
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