diff options
Diffstat (limited to 'Git/Branch.hs')
| -rw-r--r-- | Git/Branch.hs | 82 |
1 files changed, 59 insertions, 23 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs index a2225dc..875f20f 100644 --- a/Git/Branch.hs +++ b/Git/Branch.hs @@ -13,6 +13,7 @@ import Common import Git import Git.Sha import Git.Command +import qualified Git.Config import qualified Git.Ref import qualified Git.BuildVersion @@ -23,7 +24,7 @@ import qualified Git.BuildVersion - branch is not created yet. So, this also looks at show-ref HEAD - to double-check. -} -current :: Repo -> IO (Maybe Git.Ref) +current :: Repo -> IO (Maybe Branch) current r = do v <- currentUnsafe r case v of @@ -35,7 +36,7 @@ current r = do ) {- The current branch, which may not really exist yet. -} -currentUnsafe :: Repo -> IO (Maybe Git.Ref) +currentUnsafe :: Repo -> IO (Maybe Branch) currentUnsafe r = parse . firstLine <$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r where @@ -48,15 +49,25 @@ currentUnsafe r = parse . firstLine changed :: Branch -> Branch -> Repo -> IO Bool changed origbranch newbranch repo | origbranch == newbranch = return False - | otherwise = not . null <$> diffs + | otherwise = not . null + <$> changed' origbranch newbranch [Param "-n1"] repo where - diffs = pipeReadStrict + +changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String +changed' origbranch newbranch extraps repo = pipeReadStrict ps repo + where + ps = [ Param "log" , Param (fromRef origbranch ++ ".." ++ fromRef newbranch) - , Param "-n1" , Param "--pretty=%H" - ] repo - + ] ++ extraps + +{- 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 + <$> changed' origbranch newbranch extraps repo + {- Check if it's possible to fast-forward from the old - ref to the new ref. - @@ -90,7 +101,7 @@ fastForward branch (first:rest) repo = where no_ff = return False do_ff to = do - update branch to repo + update' branch to repo return True findbest c [] = return $ Just c findbest c (r:rs) @@ -104,27 +115,37 @@ 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 +{- 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. -} data CommitMode = ManualCommit | AutomaticCommit deriving (Eq) +{- Prevent signing automatic commits. -} applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam] applyCommitMode commitmode ps | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") = Param "--no-gpg-sign" : ps | otherwise = ps +{- Some versions of git commit-tree honor commit.gpgsign themselves, + - but others need -S to be passed to enable gpg signing of manual commits. -} +applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam] +applyCommitModeForCommitTree commitmode ps r + | commitmode == ManualCommit = + case (Git.Config.getMaybe "commit.gpgsign" r) of + Just s | Git.Config.isTrue s == Just True -> + Param "-S":ps + _ -> ps' + | otherwise = ps' + where + ps' = applyCommitMode commitmode 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 @@ -144,36 +165,51 @@ commit commitmode allowempty message branch parentrefs repo = do pipeReadStrict [Param "write-tree"] repo ifM (cancommit tree) ( do - sha <- getSha "commit-tree" $ - pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo - update branch sha repo + sha <- commitTree commitmode message parentrefs tree repo + update' branch sha repo return $ Just sha , return Nothing ) where - 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 :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha commitAlways commitmode message branch parentrefs repo = fromJust <$> commit commitmode True message branch parentrefs repo +commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha +commitTree commitmode message parentrefs tree repo = + getSha "commit-tree" $ + pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) + sendmsg repo + where + sendmsg = Just $ flip hPutStr message + ps = applyCommitModeForCommitTree commitmode parentparams repo + parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs + {- A leading + makes git-push force pushing a branch. -} forcePush :: String -> String forcePush b = "+" ++ b -{- Updates a branch (or other ref) to a new Sha. -} -update :: Branch -> Sha -> Repo -> IO () -update branch sha = run +{- Updates a branch (or other ref) to a new Sha or branch Ref. -} +update :: String -> Branch -> Ref -> Repo -> IO () +update message branch r = run + [ Param "update-ref" + , Param "-m" + , Param message + , Param $ fromRef branch + , Param $ fromRef r + ] + +update' :: Branch -> Ref -> Repo -> IO () +update' branch r = run [ Param "update-ref" , Param $ fromRef branch - , Param $ fromRef sha + , Param $ fromRef r ] {- Checks out a branch, creating it if necessary. -} |