summaryrefslogtreecommitdiff
path: root/Git/Branch.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Git/Branch.hs')
-rw-r--r--Git/Branch.hs108
1 files changed, 73 insertions, 35 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs
index a2225dc..699fbf5 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -2,10 +2,11 @@
-
- Copyright 2011 Joey Hess <id@joeyh.name>
-
- - Licensed under the GNU GPL version 3 or higher.
+ - Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
module Git.Branch where
@@ -13,56 +14,69 @@ import Common
import Git
import Git.Sha
import Git.Command
+import qualified Git.Config
import qualified Git.Ref
-import qualified Git.BuildVersion
+
+import qualified Data.ByteString as B
{- The currently checked out branch.
-
- In a just initialized git repo before the first commit,
- symbolic-ref will show the master branch, even though that
- - branch is not created yet. So, this also looks at show-ref HEAD
+ - branch is not created yet. So, this also looks at show-ref
- to double-check.
-}
-current :: Repo -> IO (Maybe Git.Ref)
+current :: Repo -> IO (Maybe Branch)
current r = do
v <- currentUnsafe r
case v of
Nothing -> return Nothing
Just branch ->
- ifM (null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
+ ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
( return Nothing
, return v
)
{- The current branch, which may not really exist yet. -}
-currentUnsafe :: Repo -> IO (Maybe Git.Ref)
-currentUnsafe r = parse . firstLine
+currentUnsafe :: Repo -> IO (Maybe Branch)
+currentUnsafe r = parse . firstLine'
<$> pipeReadStrict [Param "symbolic-ref", Param "-q", Param $ fromRef Git.Ref.headRef] r
where
- parse l
- | null l = Nothing
- | otherwise = Just $ Git.Ref l
+ parse b
+ | B.null b = Nothing
+ | otherwise = Just $ Git.Ref $ decodeBS 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 <$> diffs
+ | otherwise = not . null
+ <$> changed' origbranch newbranch [Param "-n1"] repo
+ where
+
+changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO String
+changed' origbranch newbranch extraps repo =
+ decodeBS <$> pipeReadStrict ps repo
where
- diffs = pipeReadStrict
+ 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.
-
- 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 <$>
+fastForwardable old new repo = not . B.null <$>
pipeReadStrict
[ Param "log"
, Param $ fromRef old ++ ".." ++ fromRef new
@@ -90,7 +104,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 +118,36 @@ 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
+ | commitmode == AutomaticCommit = 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.isTrueFalse' 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
@@ -141,39 +164,54 @@ commitCommand' runner commitmode ps = runner $
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
+ decodeBS' <$> 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. -}
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-03 08:16:28 +0000