From 619c8bd261a4fee0b0d40b664e55c51782e062f7 Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 21 Jul 2014 16:35:23 -0400 Subject: Merge from git-annex. --- Git/Branch.hs | 64 ++++++++++++++++++++++++++++++++++++++++++++---------- Git/Command.hs | 9 -------- Git/Config.hs | 1 - Git/CurrentRepo.hs | 8 +++---- Git/Fsck.hs | 1 - Git/Index.hs | 4 ++++ Git/LsFiles.hs | 4 ++-- Git/UpdateIndex.hs | 1 - 8 files changed, 63 insertions(+), 29 deletions(-) (limited to 'Git') diff --git a/Git/Branch.hs b/Git/Branch.hs index d182ceb..0b7d888 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -14,6 +14,7 @@ import Git import Git.Sha import Git.Command import qualified Git.Ref +import qualified Git.BuildVersion {- The currently checked out branch. - @@ -52,7 +53,22 @@ changed origbranch newbranch repo diffs = pipeReadStrict [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Params "--oneline -n1" + , Param "-n1" + , Param "--pretty=%H" + ] repo + +{- Check if it's possible to fast-forward from the old + - ref to the new ref. + - + - This requires there to be a path from the old to the new. -} +fastForwardable :: Ref -> Ref -> Repo -> IO Bool +fastForwardable old new repo = not . null <$> + pipeReadStrict + [ Param "log" + , Param $ fromRef old ++ ".." ++ fromRef new + , Param "-n1" + , Param "--pretty=%H" + , Param "--ancestry-path" ] repo {- Given a set of refs that are all known to have commits not @@ -74,7 +90,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo + update branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -88,6 +104,31 @@ fastForward branch (first:rest) repo = (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same +{- The user may have set commit.gpgsign, indending all their manual + - commits to be signed. But signing automatic/background commits could + - easily lead to unwanted gpg prompts or failures. + -} +data CommitMode = ManualCommit | AutomaticCommit + deriving (Eq) + +applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] +applyCommitMode commitmode ps + | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = + Param "--no-gpg-sign" : ps + | otherwise = ps + +{- Commit via the usual git command. -} +commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool +commitCommand = commitCommand' runBool + +{- Commit will fail when the tree is clean. This suppresses that error. -} +commitQuiet :: CommitMode -> [CommandParam] -> Repo -> IO () +commitQuiet commitmode ps = void . tryIO . commitCommand' runQuiet commitmode ps + +commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a +commitCommand' runner commitmode ps = runner $ + Param "commit" : applyCommitMode commitmode ps + {- Commits the index into the specified branch (or other ref), - with the specified parent refs, and returns the committed sha. - @@ -97,30 +138,31 @@ fastForward branch (first:rest) repo = - 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 +commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) +commit commitmode allowempty message branch parentrefs repo = do tree <- getSha "write-tree" $ pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do - sha <- getSha "commit-tree" $ pipeWriteRead - (map Param $ ["commit-tree", fromRef tree] ++ ps) - (Just $ flip hPutStr message) repo + sha <- getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo update branch sha repo return $ Just sha , return Nothing ) where - ps = concatMap (\r -> ["-p", fromRef r]) parentrefs + ps = applyCommitMode commitmode $ + map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs cancommit tree | allowempty = return True | otherwise = case parentrefs of [p] -> maybe False (tree /=) <$> Git.Ref.tree p repo _ -> return True + sendmsg = Just $ flip hPutStr message -commitAlways :: String -> Branch -> [Ref] -> Repo -> IO Sha -commitAlways message branch parentrefs repo = fromJust - <$> commit True message branch parentrefs repo +commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha +commitAlways commitmode message branch parentrefs repo = fromJust + <$> commit commitmode True message branch parentrefs repo {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String diff --git a/Git/Command.hs b/Git/Command.hs index a0c7c4b..30d2dcb 100644 --- a/Git/Command.hs +++ b/Git/Command.hs @@ -9,13 +9,10 @@ module Git.Command where -import System.Process (std_out, env) - import Common import Git import Git.Types import qualified Utility.CoProcess as CoProcess -import Utility.Batch {- Constructs a git command line operating on the specified repo. -} gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] @@ -33,12 +30,6 @@ runBool :: [CommandParam] -> Repo -> IO Bool runBool params repo = assertLocal repo $ boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo) -{- Runs git in batch mode. -} -runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool -runBatch batchmaker params repo = assertLocal repo $ do - let (cmd, params') = batchmaker ("git", gitCommandLine params repo) - boolSystemEnv cmd params' (gitEnv repo) - {- Runs git in the specified repo, throwing an error if it fails. -} run :: [CommandParam] -> Repo -> IO () run params repo = assertLocal repo $ diff --git a/Git/Config.hs b/Git/Config.hs index b5c1be0..d998fd1 100644 --- a/Git/Config.hs +++ b/Git/Config.hs @@ -9,7 +9,6 @@ module Git.Config where import qualified Data.Map as M import Data.Char -import System.Process (cwd, env) import Control.Exception.Extensible import Common diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs index ee91a6b..23ebbbc 100644 --- a/Git/CurrentRepo.hs +++ b/Git/CurrentRepo.hs @@ -37,8 +37,8 @@ get = do case wt of Nothing -> return r Just d -> do - cwd <- getCurrentDirectory - unless (d `dirContains` cwd) $ + curr <- getCurrentDirectory + unless (d `dirContains` curr) $ setCurrentDirectory d return $ addworktree wt r where @@ -57,8 +57,8 @@ get = do configure Nothing (Just r) = Git.Config.read r configure (Just d) _ = do absd <- absPath d - cwd <- getCurrentDirectory - r <- newFrom $ Local { gitdir = absd, worktree = Just cwd } + curr <- getCurrentDirectory + r <- newFrom $ Local { gitdir = absd, worktree = Just curr } Git.Config.read r configure Nothing Nothing = error "Not in a git repository." diff --git a/Git/Fsck.hs b/Git/Fsck.hs index 80f76dd..c6002f6 100644 --- a/Git/Fsck.hs +++ b/Git/Fsck.hs @@ -23,7 +23,6 @@ import Utility.Batch import qualified Git.Version import qualified Data.Set as S -import System.Process (std_out, std_err) import Control.Concurrent.Async type MissingObjects = S.Set Sha diff --git a/Git/Index.hs b/Git/Index.hs index d9d5b03..d712245 100644 --- a/Git/Index.hs +++ b/Git/Index.hs @@ -30,3 +30,7 @@ override index = do indexFile :: Repo -> FilePath indexFile r = localGitDir r "index" + +{- Git locks the index by creating this file. -} +indexFileLock :: Repo -> FilePath +indexFileLock r = indexFile r ++ ".lock" diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs index e155845..2aa05ba 100644 --- a/Git/LsFiles.hs +++ b/Git/LsFiles.hs @@ -132,8 +132,8 @@ typeChanged' ps l repo = do -- git diff returns filenames relative to the top of the git repo; -- convert to filenames relative to the cwd, like git ls-files. let top = repoPath repo - cwd <- getCurrentDirectory - return (map (\f -> relPathDirToFile cwd $ top f) fs, cleanup) + currdir <- getCurrentDirectory + return (map (\f -> relPathDirToFile currdir $ top f) fs, cleanup) where prefix = [Params "diff --name-only --diff-filter=T -z"] suffix = Param "--" : (if null l then [File "."] else map File l) diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs index 4ecd773..7de2f1b 100644 --- a/Git/UpdateIndex.hs +++ b/Git/UpdateIndex.hs @@ -30,7 +30,6 @@ import Git.FilePath import Git.Sha import Control.Exception (bracket) -import System.Process (std_in) {- Streamers are passed a callback and should feed it lines in the form - read by update-index, and generated by ls-tree. -} -- cgit v1.2.3