summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorJoey Hess <joey@kitenet.net>2013-12-01 15:14:13 -0400
committerJoey Hess <joey@kitenet.net>2013-12-01 15:14:13 -0400
commit3bdf2d2052f3a194b3f72500ca71867fb22e1315 (patch)
treed4a076f7fc1ca255ded959779d99404525f7de78
parent3c7357ee388795149e922d344bdbf32e1d1d5810 (diff)
downloadgit-repair-3bdf2d2052f3a194b3f72500ca71867fb22e1315.tar.gz
merge from git-annex
Note that the batchCommand stuff is not used in git-repair, so configure does not need to check for nice, ionice, and nocache, nor are they dependend on.
-rw-r--r--Build/Configure.hs1
-rw-r--r--Git/Branch.hs36
-rw-r--r--Git/Fsck.hs9
-rw-r--r--Git/Ref.hs6
-rw-r--r--Utility/Batch.hs43
5 files changed, 57 insertions, 38 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/Fsck.hs b/Git/Fsck.hs
index 8555aa0..8d5b75b 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -37,17 +37,16 @@ data FsckResults = FsckFoundMissing MissingObjects | FsckFailed
-}
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 FsckFailed
else return $ FsckFoundMissing badobjs
- where
- (command, params) = ("git", fsckParams r)
- (command', params')
- | batchmode = toBatchCommand (command, params)
- | otherwise = (command, params)
foundBroken :: FsckResults -> Bool
foundBroken FsckFailed = True
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/Utility/Batch.hs b/Utility/Batch.hs
index 035a2eb..958801e 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,38 @@ 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. -}
+toBatchCommand :: (String, [CommandParam]) -> IO (String, [CommandParam])
+toBatchCommand (command, params) = 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", [])
]
+ let (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
+ let command' = command
+ let params' = params
#endif
+ return (command', params')
{- 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
+ (command', params') <- toBatchCommand (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 +84,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'
-