1{- git branch stuff
2 -
3 - Copyright 2011-2021 Joey Hess <id@joeyh.name>
4 -
5 - Licensed under the GNU AGPL version 3 or higher.
6 -}
7
8{-# LANGUAGE BangPatterns #-}
9{-# LANGUAGE OverloadedStrings #-}
10
11module Git.Branch where
12
13import Common
14import Git
15import Git.Sha
16import Git.Command
17import qualified Git.Config
18import qualified Git.Ref
19
20import qualified Data.ByteString as B
21import qualified Data.ByteString.Char8 as B8
22
23{- The currently checked out branch.
24 -
25 - In a just initialized git repo before the first commit,
26 - symbolic-ref will show the master branch, even though that
27 - branch is not created yet. So, this also looks at show-ref
28 - to double-check.
29 -}
30current :: Repo -> IO (Maybe Branch)
31current r = do
32	v <- currentUnsafe r
33	case v of
34		Nothing -> return Nothing
35		Just branch ->
36			ifM (B.null <$> pipeReadStrict [Param "show-ref", Param $ fromRef branch] r)
37				( return Nothing
38				, return v
39				)
40
41{- The current branch, which may not really exist yet. -}
42currentUnsafe :: Repo -> IO (Maybe Branch)
43currentUnsafe r = parse . firstLine' <$> pipeReadStrict
44	[ Param "symbolic-ref"
45	, Param "-q"
46	, Param $ fromRef Git.Ref.headRef
47	] r
48  where
49	parse b
50		| B.null b = Nothing
51		| otherwise = Just $ Git.Ref b
52
53{- Checks if the second branch has any commits not present on the first
54 - branch. -}
55changed :: Branch -> Branch -> Repo -> IO Bool
56changed origbranch newbranch repo
57	| origbranch == newbranch = return False
58	| otherwise = not . B.null
59		<$> changed' origbranch newbranch [Param "-n1"] repo
60  where
61
62changed' :: Branch -> Branch -> [CommandParam] -> Repo -> IO B.ByteString
63changed' origbranch newbranch extraps repo = pipeReadStrict ps repo
64  where
65	ps =
66		[ Param "log"
67		, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
68		, Param "--pretty=%H"
69		] ++ extraps
70
71{- Lists commits that are in the second branch and not in the first branch. -}
72changedCommits :: Branch -> Branch -> [CommandParam] -> Repo -> IO [Sha]
73changedCommits origbranch newbranch extraps repo =
74	catMaybes . map extractSha . B8.lines
75		<$> changed' origbranch newbranch extraps repo
76
77{- Check if it's possible to fast-forward from the old
78 - ref to the new ref.
79 -
80 - This requires there to be a path from the old to the new. -}
81fastForwardable :: Ref -> Ref -> Repo -> IO Bool
82fastForwardable old new repo = not . B.null <$>
83	pipeReadStrict
84		[ Param "log"
85		, Param $ fromRef old ++ ".." ++ fromRef new
86		, Param "-n1"
87		, Param "--pretty=%H"
88		, Param "--ancestry-path"
89		] repo
90
91{- Given a set of refs that are all known to have commits not
92 - on the branch, tries to update the branch by a fast-forward.
93 -
94 - In order for that to be possible, one of the refs must contain
95 - every commit present in all the other refs.
96 -}
97fastForward :: Branch -> [Ref] -> Repo -> IO Bool
98fastForward _ [] _ = return True
99fastForward branch (first:rest) repo =
100	-- First, check that the branch does not contain any
101	-- new commits that are not in the first ref. If it does,
102	-- cannot fast-forward.
103	ifM (changed first branch repo)
104		( no_ff
105		, maybe no_ff do_ff =<< findbest first rest
106		)
107  where
108	no_ff = return False
109	do_ff to = do
110		update' branch to repo
111		return True
112	findbest c [] = return $ Just c
113	findbest c (r:rs)
114		| c == r = findbest c rs
115		| otherwise = do
116		better <- changed c r repo
117		worse <- changed r c repo
118		case (better, worse) of
119			(True, True) -> return Nothing -- divergent fail
120			(True, False) -> findbest r rs -- better
121			(False, True) -> findbest c rs -- worse
122			(False, False) -> findbest c rs -- same
123
124{- Should the commit avoid the usual summary output? -}
125newtype CommitQuiet = CommitQuiet Bool
126
127applyCommitQuiet :: CommitQuiet -> [CommandParam] -> [CommandParam]
128applyCommitQuiet (CommitQuiet True) ps = Param "--quiet" : ps
129applyCommitQuiet (CommitQuiet False) ps = ps
130
131{- The user may have set commit.gpgsign, intending all their manual
132 - commits to be signed. But signing automatic/background commits could
133 - easily lead to unwanted gpg prompts or failures.
134 -}
135data CommitMode = ManualCommit | AutomaticCommit
136	deriving (Eq)
137
138{- Prevent signing automatic commits. -}
139applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
140applyCommitMode commitmode ps
141	| commitmode == AutomaticCommit = Param "--no-gpg-sign" : ps
142	| otherwise = ps
143
144{- Some versions of git commit-tree honor commit.gpgsign themselves,
145 - but others need -S to be passed to enable gpg signing of manual commits. -}
146applyCommitModeForCommitTree :: CommitMode -> [CommandParam] -> Repo -> [CommandParam]
147applyCommitModeForCommitTree commitmode ps r
148	| commitmode == ManualCommit =
149		case Git.Config.getMaybe "commit.gpgsign" r of
150			Just s | Git.Config.isTrueFalse' s == Just True ->
151				Param "-S":ps
152			_ -> ps'
153	| otherwise = ps'
154  where
155	ps' = applyCommitMode commitmode ps
156
157{- Commit via the usual git command. -}
158commitCommand :: CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO Bool
159commitCommand = commitCommand' runBool
160
161commitCommand' :: ([CommandParam] -> Repo -> IO a) -> CommitMode -> CommitQuiet -> [CommandParam] -> Repo -> IO a
162commitCommand' runner commitmode commitquiet ps =
163	runner $ Param "commit" : ps'
164  where
165	ps' = applyCommitMode commitmode (applyCommitQuiet commitquiet ps)
166
167{- Commits the index into the specified branch (or other ref),
168 - with the specified parent refs, and returns the committed sha.
169 -
170 - Without allowempy set, avoids making a commit if there is exactly
171 - one parent, and it has the same tree that would be committed.
172 -
173 - Unlike git-commit, does not run any hooks, or examine the work tree
174 - in any way, or output a summary.
175 -}
176commit :: CommitMode -> Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
177commit commitmode allowempty message branch parentrefs repo = do
178	tree <- writeTree repo
179	ifM (cancommit tree)
180		( do
181			sha <- commitTree commitmode message parentrefs tree repo
182			update' branch sha repo
183			return $ Just sha
184		, return Nothing
185		)
186  where
187	cancommit tree
188		| allowempty = return True
189		| otherwise = case parentrefs of
190			[p] -> maybe False (tree /=) <$> Git.Ref.tree p repo
191			_ -> return True
192
193commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
194commitAlways commitmode message branch parentrefs repo = fromJust
195	<$> commit commitmode True message branch parentrefs repo
196
197-- Throws exception if the index is locked, with an error message output by
198-- git on stderr.
199writeTree :: Repo -> IO Sha
200writeTree repo = getSha "write-tree" $
201	pipeReadStrict [Param "write-tree"] repo
202
203-- Avoids error output if the command fails due to eg, the index being locked.
204writeTreeQuiet :: Repo -> IO (Maybe Sha)
205writeTreeQuiet repo = extractSha <$> withNullHandle go
206  where
207	go nullh = pipeReadStrict' (\p -> p { std_err = UseHandle nullh })
208		[Param "write-tree"] repo
209
210commitTree :: CommitMode -> String -> [Ref] -> Ref -> Repo -> IO Sha
211commitTree commitmode message parentrefs tree repo =
212	getSha "commit-tree" $
213		pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps)
214			sendmsg repo
215  where
216	sendmsg = Just $ flip hPutStr message
217	ps = applyCommitModeForCommitTree commitmode parentparams repo
218	parentparams = map Param $ concatMap (\r -> ["-p", fromRef r]) parentrefs
219
220{- A leading + makes git-push force pushing a branch. -}
221forcePush :: String -> String
222forcePush b = "+" ++ b
223
224{- Updates a branch (or other ref) to a new Sha or branch Ref. -}
225update :: String -> Branch -> Ref -> Repo -> IO ()
226update message branch r = run
227	[ Param "update-ref"
228	, Param "-m"
229	, Param message
230	, Param $ fromRef branch
231	, Param $ fromRef r
232	]
233
234update' :: Branch -> Ref -> Repo -> IO ()
235update' branch r = run
236	[ Param "update-ref"
237	, Param $ fromRef branch
238	, Param $ fromRef r
239	]
240
241{- Checks out a branch, creating it if necessary. -}
242checkout :: Branch -> Repo -> IO ()
243checkout branch = run
244	[ Param "checkout"
245	, Param "-q"
246	, Param "-B"
247	, Param $ fromRef $ Git.Ref.base branch
248	]
249
250{- Removes a branch. -}
251delete :: Branch -> Repo -> IO ()
252delete branch = run
253	[ Param "branch"
254	, Param "-q"
255	, Param "-D"
256	, Param $ fromRef $ Git.Ref.base branch
257	]
258