diff options
Diffstat (limited to 'Git/Branch.hs')
| -rw-r--r-- | Git/Branch.hs | 56 |
1 files changed, 40 insertions, 16 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs index 699fbf5..f30e357 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -1,6 +1,6 @@ {- git branch stuff - - - Copyright 2011 Joey Hess <id@joeyh.name> + - Copyright 2011-2021 Joey Hess <id@joeyh.name> - - Licensed under the GNU AGPL version 3 or higher. -} @@ -18,6 +18,7 @@ import qualified Git.Config import qualified Git.Ref import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 {- The currently checked out branch. - @@ -39,25 +40,27 @@ current r = do {- The current branch, which may not really exist yet. -} currentUnsafe :: Repo -> IO (Maybe Branch) -currentUnsafe r = parse . firstLine' - <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r +currentUnsafe r = parse . firstLine' <$> pipeReadStrict + [ Param "symbolic-ref" + , Param "-q" + , Param $ fromRef Git.Ref.headRef + ] r where parse b | B.null b = Nothing - | otherwise = Just $ Git.Ref $ decodeBS b + | otherwise = Just $ Git.Ref b {- Checks if the second branch has any commits not present on the first - branch. -} changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null + | otherwise = not . B.null <$> changed' origbranch newbranch [Param "-n1"] repo where -changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String -changed' origbranch newbranch extraps repo = - decodeBS <$> pipeReadStrict ps repo +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo where ps = [ Param "log" @@ -68,7 +71,7 @@ changed' origbranch newbranch extraps repo = {- Lists commits that are in the second branch and not in the first branch. -} changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha] changedCommits origbranch newbranch extraps repo = - catMaybes . map extractSha . lines + catMaybes . map extractSha . B8.lines <$> changed' origbranch newbranch extraps repo {- Check if it's possible to fast-forward from the old @@ -118,6 +121,13 @@ fastForward branch (first:rest) repo = (False, True) -> findbest c rs -- worse (False, False) -> findbest c rs -- same +{- Should the commit avoid the usual summary output? -} +newtype CommitQuiet = CommitQuiet Bool + +applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam] +applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps +applyCommitQuiet (CommitQuiet False) ps = ps + {- The user may have set commit.gpgsign, intending all their manual - commits to be signed. But signing automatic/background commits could - easily lead to unwanted gpg prompts or failures. @@ -145,12 +155,14 @@ applyCommitModeForCommitTree commitmode ps r ps' = applyCommitMode commitmode ps {- Commit via the usual git command. -} -commitCommand :: CommitMode -> [CommandParam] -> Repo -> IO Bool +commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool commitCommand = commitCommand' runBool -commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> [CommandParam] -> Repo -> IO a -commitCommand' runner commitmode ps = runner $ - Param "commit" : applyCommitMode commitmode ps +commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a +commitCommand' runner commitmode commitquiet ps = + runner $ Param "commit" : ps' + where + ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps) {- Commits the index into the specified branch (or other ref), - with the specified parent refs, and returns the committed sha. @@ -159,12 +171,11 @@ commitCommand' runner commitmode ps = runner $ - 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. + - in any way, or output a summary. -} commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha) commit commitmode allowempty message branch parentrefs repo = do - tree <- getSha "write-tree" $ - decodeBS' <$> pipeReadStrict [Param "write-tree"] repo + tree <- writeTree repo ifM (cancommit tree) ( do sha <- commitTree commitmode message parentrefs tree repo @@ -183,6 +194,19 @@ commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust <$> commit commitmode True message branch parentrefs repo +-- Throws exception if the index is locked, with an error message output by +-- git on stderr. +writeTree :: Repo -> IO Sha +writeTree repo = getSha "write-tree" $ + pipeReadStrict [Param "write-tree"] repo + +-- Avoids error output if the command fails due to eg, the index being locked. +writeTreeQuiet :: Repo -> IO (Maybe Sha) +writeTreeQuiet repo = extractSha <$> withNullHandle go + where + go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh }) + [Param "write-tree"] repo + commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha commitTree commitmode message parentrefs tree repo = getSha "commit-tree" $ |