summaryrefslogtreecommitdiff
path: root/Git
diff options
context:
space:
mode:
Diffstat (limited to 'Git')
-rw-r--r--Git/Branch.hs64
-rw-r--r--Git/Command.hs9
-rw-r--r--Git/Config.hs1
-rw-r--r--Git/CurrentRepo.hs8
-rw-r--r--Git/Fsck.hs1
-rw-r--r--Git/Index.hs4
-rw-r--r--Git/LsFiles.hs4
-rw-r--r--Git/UpdateIndex.hs1
8 files changed, 63 insertions, 29 deletions
diff --git a/Git/Branch.hs b/Git/Branch.hs
index d182ceb..0b7d888 100644
--- a/Git/Branch.hs
+++ b/Git/Branch.hs
@@ -14,6 +14,7 @@ import Git
import Git.Sha
import Git.Command
import qualified Git.Ref
+import qualified Git.BuildVersion
{- The currently checked out branch.
-
@@ -52,7 +53,22 @@ changed origbranch newbranch repo
diffs = pipeReadStrict
[ Param "log"
, Param (fromRef origbranch ++ ".." ++ fromRef newbranch)
- , Params "--oneline -n1"
+ , Param "-n1"
+ , Param "--pretty=%H"
+ ] 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 <$>
+ pipeReadStrict
+ [ Param "log"
+ , Param $ fromRef old ++ ".." ++ fromRef new
+ , Param "-n1"
+ , Param "--pretty=%H"
+ , Param "--ancestry-path"
] repo
{- Given a set of refs that are all known to have commits not
@@ -74,7 +90,7 @@ fastForward branch (first:rest) repo =
where
no_ff = return False
do_ff to = do
- run [Param "update-ref", Param $ fromRef branch, Param $ fromRef to] repo
+ update branch to repo
return True
findbest c [] = return $ Just c
findbest c (r:rs)
@@ -88,6 +104,31 @@ 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
+ - commits to be signed. But signing automatic/background commits could
+ - easily lead to unwanted gpg prompts or failures.
+ -}
+data CommitMode = ManualCommit | AutomaticCommit
+ deriving (Eq)
+
+applyCommitMode :: CommitMode -> [CommandParam] -> [CommandParam]
+applyCommitMode commitmode ps
+ | commitmode == AutomaticCommit && not (Git.BuildVersion.older "2.0.0") =
+ Param "--no-gpg-sign" : ps
+ | otherwise = 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
+
{- Commits the index into the specified branch (or other ref),
- with the specified parent refs, and returns the committed sha.
-
@@ -97,30 +138,31 @@ fastForward branch (first:rest) repo =
- Unlike git-commit, does not run any hooks, or examine the work tree
- in any way.
-}
-commit :: Bool -> String -> Branch -> [Ref] -> Repo -> IO (Maybe Sha)
-commit allowempty message branch parentrefs repo = do
+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
ifM (cancommit tree)
( do
- sha <- getSha "commit-tree" $ pipeWriteRead
- (map Param $ ["commit-tree", fromRef tree] ++ ps)
- (Just $ flip hPutStr message) repo
+ sha <- getSha "commit-tree" $
+ pipeWriteRead ([Param "commit-tree", Param (fromRef tree)] ++ ps) sendmsg repo
update branch sha repo
return $ Just sha
, return Nothing
)
where
- ps = concatMap (\r -> ["-p", fromRef r]) parentrefs
+ 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 :: String -> Branch -> [Ref] -> Repo -> IO Sha
-commitAlways message branch parentrefs repo = fromJust
- <$> commit True message branch parentrefs repo
+commitAlways :: CommitMode -> String -> Branch -> [Ref] -> Repo -> IO Sha
+commitAlways commitmode message branch parentrefs repo = fromJust
+ <$> commit commitmode True message branch parentrefs repo
{- A leading + makes git-push force pushing a branch. -}
forcePush :: String -> String
diff --git a/Git/Command.hs b/Git/Command.hs
index a0c7c4b..30d2dcb 100644
--- a/Git/Command.hs
+++ b/Git/Command.hs
@@ -9,13 +9,10 @@
module Git.Command where
-import System.Process (std_out, env)
-
import Common
import Git
import Git.Types
import qualified Utility.CoProcess as CoProcess
-import Utility.Batch
{- Constructs a git command line operating on the specified repo. -}
gitCommandLine :: [CommandParam] -> Repo -> [CommandParam]
@@ -33,12 +30,6 @@ runBool :: [CommandParam] -> Repo -> IO Bool
runBool params repo = assertLocal repo $
boolSystemEnv "git" (gitCommandLine params repo) (gitEnv repo)
-{- Runs git in batch mode. -}
-runBatch :: BatchCommandMaker -> [CommandParam] -> Repo -> IO Bool
-runBatch batchmaker params repo = assertLocal repo $ do
- let (cmd, params') = batchmaker ("git", gitCommandLine params repo)
- boolSystemEnv cmd params' (gitEnv repo)
-
{- Runs git in the specified repo, throwing an error if it fails. -}
run :: [CommandParam] -> Repo -> IO ()
run params repo = assertLocal repo $
diff --git a/Git/Config.hs b/Git/Config.hs
index b5c1be0..d998fd1 100644
--- a/Git/Config.hs
+++ b/Git/Config.hs
@@ -9,7 +9,6 @@ module Git.Config where
import qualified Data.Map as M
import Data.Char
-import System.Process (cwd, env)
import Control.Exception.Extensible
import Common
diff --git a/Git/CurrentRepo.hs b/Git/CurrentRepo.hs
index ee91a6b..23ebbbc 100644
--- a/Git/CurrentRepo.hs
+++ b/Git/CurrentRepo.hs
@@ -37,8 +37,8 @@ get = do
case wt of
Nothing -> return r
Just d -> do
- cwd <- getCurrentDirectory
- unless (d `dirContains` cwd) $
+ curr <- getCurrentDirectory
+ unless (d `dirContains` curr) $
setCurrentDirectory d
return $ addworktree wt r
where
@@ -57,8 +57,8 @@ get = do
configure Nothing (Just r) = Git.Config.read r
configure (Just d) _ = do
absd <- absPath d
- cwd <- getCurrentDirectory
- r <- newFrom $ Local { gitdir = absd, worktree = Just cwd }
+ curr <- getCurrentDirectory
+ r <- newFrom $ Local { gitdir = absd, worktree = Just curr }
Git.Config.read r
configure Nothing Nothing = error "Not in a git repository."
diff --git a/Git/Fsck.hs b/Git/Fsck.hs
index 80f76dd..c6002f6 100644
--- a/Git/Fsck.hs
+++ b/Git/Fsck.hs
@@ -23,7 +23,6 @@ import Utility.Batch
import qualified Git.Version
import qualified Data.Set as S
-import System.Process (std_out, std_err)
import Control.Concurrent.Async
type MissingObjects = S.Set Sha
diff --git a/Git/Index.hs b/Git/Index.hs
index d9d5b03..d712245 100644
--- a/Git/Index.hs
+++ b/Git/Index.hs
@@ -30,3 +30,7 @@ override index = do
indexFile :: Repo -> FilePath
indexFile r = localGitDir r </> "index"
+
+{- Git locks the index by creating this file. -}
+indexFileLock :: Repo -> FilePath
+indexFileLock r = indexFile r ++ ".lock"
diff --git a/Git/LsFiles.hs b/Git/LsFiles.hs
index e155845..2aa05ba 100644
--- a/Git/LsFiles.hs
+++ b/Git/LsFiles.hs
@@ -132,8 +132,8 @@ typeChanged' ps l repo = do
-- git diff returns filenames relative to the top of the git repo;
-- convert to filenames relative to the cwd, like git ls-files.
let top = repoPath repo
- cwd <- getCurrentDirectory
- return (map (\f -> relPathDirToFile cwd $ top </> f) fs, cleanup)
+ currdir <- getCurrentDirectory
+ return (map (\f -> relPathDirToFile currdir $ top </> f) fs, cleanup)
where
prefix = [Params "diff --name-only --diff-filter=T -z"]
suffix = Param "--" : (if null l then [File "."] else map File l)
diff --git a/Git/UpdateIndex.hs b/Git/UpdateIndex.hs
index 4ecd773..7de2f1b 100644
--- a/Git/UpdateIndex.hs
+++ b/Git/UpdateIndex.hs
@@ -30,7 +30,6 @@ import Git.FilePath
import Git.Sha
import Control.Exception (bracket)
-import System.Process (std_in)
{- Streamers are passed a callback and should feed it lines in the form
- read by update-index, and generated by ls-tree. -}
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-27 08:58:56 +0000