From 3bdf2d2052f3a194b3f72500ca71867fb22e1315 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Sun, 1 Dec 2013 15:14:13 -0400 Subject: 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. --- Build/Configure.hs | 1 - Git/Branch.hs | 36 ++++++++++++++++++++++++++++-------- Git/Fsck.hs | 9 ++++----- Git/Ref.hs | 6 ++++++ Utility/Batch.hs | 43 +++++++++++++++++++------------------------ 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' - -- cgit v1.2.3