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