module Mit.Git where
import qualified Data.List as List
import qualified Data.Sequence as Seq
import qualified Data.Text as Text
import qualified Data.Text.ANSI as Text
import qualified Data.Text.Builder.ANSI as Text.Builder
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy.Builder as Text (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import qualified Ki
import Mit.Globals (debug)
import Mit.Prelude
import Mit.Process
import System.Directory (doesFileExist)
import System.Environment (lookupEnv)
import System.Exit (ExitCode (..))
import System.IO (Handle, hClose, hIsEOF)
import System.IO.Unsafe (unsafePerformIO)
import System.Posix.Process (getProcessGroupIDOf)
import System.Posix.Signals
import System.Posix.Terminal (queryTerminal)
import System.Process
import System.Process.Internals
gitdir :: Text
gitdir =
unsafePerformIO (git ["rev-parse", "--absolute-git-dir"])
{-# NOINLINE gitdir #-}
-- | The root of this git worktree.
rootdir :: Text
rootdir =
unsafePerformIO (git ["rev-parse", "--show-toplevel"])
{-# NOINLINE rootdir #-}
data DiffResult
= Differences
| NoDifferences
data GitCommitInfo = GitCommitInfo
{ author :: Text,
date :: Text,
hash :: Text,
shorthash :: Text,
subject :: Text
}
deriving stock (Show)
prettyGitCommitInfo :: GitCommitInfo -> Text.Builder
prettyGitCommitInfo info =
fold
[ Text.Builder.bold (Text.Builder.black (Text.Builder.fromText info.shorthash)),
" ",
Text.Builder.bold (Text.Builder.white (Text.Builder.fromText info.subject)),
" - ",
Text.Builder.italic (Text.Builder.white (Text.Builder.fromText info.author)),
" ",
Text.Builder.italic (Text.Builder.yellow (Text.Builder.fromText info.date)) -- FIXME some other color, magenta?
]
data GitConflict
= GitConflict GitConflictXY Text
deriving stock (Eq, Show)
parseGitConflict :: Text -> Maybe GitConflict
parseGitConflict line = do
[xy, name] <- Just (Text.words line)
GitConflict <$> parseGitConflictXY xy <*> Just name
showGitConflict :: GitConflict -> Text.Builder
showGitConflict (GitConflict xy name) =
Text.Builder.fromText name <> " (" <> showGitConflictXY xy <> ")"
data GitConflictXY
= AA -- both added
| AU -- added by us
| DD -- both deleted
| DU -- deleted by us
| UA -- added by them
| UD -- deleted by them
| UU -- both modified
deriving stock (Eq, Show)
parseGitConflictXY :: Text -> Maybe GitConflictXY
parseGitConflictXY = \case
"AA" -> Just AA
"AU" -> Just AU
"DD" -> Just DD
"DU" -> Just DU
"UA" -> Just UA
"UD" -> Just UD
"UU" -> Just UU
_ -> Nothing
showGitConflictXY :: GitConflictXY -> Text.Builder
showGitConflictXY = \case
AA -> "both added"
AU -> "added by us"
DD -> "both deleted"
DU -> "deleted by us"
UA -> "added by them"
UD -> "deleted by them"
UU -> "both modified"
data GitVersion
= GitVersion Int Int Int
deriving stock (Eq, Ord)
showGitVersion :: GitVersion -> Text
showGitVersion (GitVersion x y z) =
Text.pack (show x) <> "." <> Text.pack (show y) <> "." <> Text.pack (show z)
-- | Apply stash, return conflicts.
gitApplyStash :: Text -> IO [GitConflict]
gitApplyStash stash = do
conflicts <-
git ["stash", "apply", stash] >>= \case
False -> gitConflicts
True -> pure []
gitUnstageChanges
pure conflicts
-- | Create a branch.
gitBranch :: Text -> IO ()
gitBranch branch =
gitl_ ["branch", "--no-track", branch]
-- | Does the given local branch (refs/heads/...) exist?
gitBranchExists :: Text -> IO Bool
gitBranchExists branch =
git ["rev-parse", "--verify", "refs/heads/" <> branch]
-- | Get the head of a local branch (refs/heads/...).
gitBranchHead :: Text -> IO (Maybe Text)
gitBranchHead branch =
git ["rev-parse", "refs/heads/" <> branch] <&> \case
Left _ -> Nothing
Right head -> Just head
-- | Get the directory a branch's worktree is checked out in, if it exists.
gitBranchWorktreeDir :: Text -> IO (Maybe Text)
gitBranchWorktreeDir branch = do
worktrees <- gitWorktreeList
pure case List.find (\worktree -> worktree.branch == Just branch) worktrees of
Nothing -> Nothing
Just worktree -> Just worktree.directory
gitCommit :: IO Bool
gitCommit =
queryTerminal 0 >>= \case
False -> do
message <- lookupEnv "MIT_COMMIT_MESSAGE"
gitl ["commit", "--all", "--message", maybe "" Text.pack message]
True ->
gitl2 ["commit", "--patch", "--quiet"] <&> \case
ExitFailure _ -> False
ExitSuccess -> True
gitCommitsBetween :: Maybe Text -> Text -> IO (Seq GitCommitInfo)
gitCommitsBetween commit1 commit2 =
if commit1 == Just commit2
then pure Seq.empty
else do
commits <-
-- --first-parent seems desirable for topic branches
git
[ "rev-list",
"--color=always",
"--date=human",
"--format=format:%an\xFEFF%ad\xFEFF%H\xFEFF%h\xFEFF%s",
"--max-count=11",
maybe id (\c1 c2 -> c1 <> ".." <> c2) commit1 commit2
]
pure (parseCommitInfo <$> dropEvens commits)
where
-- git rev-list with a custom format prefixes every commit with a redundant line :|
dropEvens :: Seq a -> Seq a
dropEvens = \case
_ Seq.:<| x Seq.:<| xs -> x Seq.<| dropEvens xs
xs -> xs
parseCommitInfo :: Text -> GitCommitInfo
parseCommitInfo line =
case Text.split (== '\xFEFF') line of
[author, date, hash, shorthash, subject] -> GitCommitInfo {author, date, hash, shorthash, subject}
_ -> error (Text.unpack line)
gitConflicts :: IO [GitConflict]
gitConflicts =
mapMaybe parseGitConflict <$> git ["status", "--no-renames", "--porcelain=v1"]
gitCreateStash :: IO Text
gitCreateStash = do
git_ ["add", "--all"] -- it seems certain things (like renames), unless staged, cannot be stashed
stash <- git ["stash", "create"]
gitUnstageChanges
pure stash
-- | Get the current branch.
gitCurrentBranch :: IO Text
gitCurrentBranch =
git ["branch", "--show-current"]
gitDefaultBranch :: Text -> IO Text
gitDefaultBranch remote = do
ref <- git ["symbolic-ref", "refs/remotes/" <> remote <> "/HEAD"]
pure (Text.drop (14 + Text.length remote) ref)
-- FIXME document this
gitDiff :: IO DiffResult
gitDiff = do
gitUnstageChanges
git ["diff", "--quiet"] <&> \case
False -> Differences
True -> NoDifferences
gitExistCommitsBetween :: Text -> Text -> IO Bool
gitExistCommitsBetween commit1 commit2 =
if commit1 == commit2
then pure False
else isJust <$> git ["rev-list", "--max-count=1", commit1 <> ".." <> commit2]
-- | Do any untracked files exist?
gitExistUntrackedFiles :: IO Bool
gitExistUntrackedFiles =
not . null <$> gitListUntrackedFiles
gitFetch :: Text -> IO Bool
gitFetch remote =
gitl ["fetch", remote]
gitFetch_ :: Text -> IO ()
gitFetch_ =
void . gitFetch
gitHead :: IO Text
gitHead =
git ["rev-parse", "HEAD"]
-- | List all untracked files.
gitListUntrackedFiles :: IO [Text]
gitListUntrackedFiles =
git ["ls-files", "--exclude-standard", "--other"]
gitMergeInProgress :: IO Bool
gitMergeInProgress =
doesFileExist (Text.unpack (gitdir <> "/MERGE_HEAD"))
gitPush :: Text -> IO Bool
gitPush branch =
gitl ["push", "--set-upstream", "origin", branch <> ":" <> branch]
-- | Does the given remote branch (refs/remotes/...) exist?
gitRemoteBranchExists :: Text -> Text -> IO Bool
gitRemoteBranchExists remote branch =
git ["rev-parse", "--verify", "refs/remotes/" <> remote <> "/" <> branch]
-- | Get the head of a remote branch.
gitRemoteBranchHead :: Text -> Text -> IO (Maybe Text)
gitRemoteBranchHead remote branch =
git ["rev-parse", "refs/remotes/" <> remote <> "/" <> branch] <&> \case
Left _ -> Nothing
Right head -> Just head
-- | Stash uncommitted changes (if any).
gitStash :: IO (Maybe Text)
gitStash = do
gitDiff >>= \case
Differences -> do
stash <- gitCreateStash
git_ ["clean", "-d", "--force"]
git_ ["reset", "--hard", "HEAD"]
pure (Just stash)
NoDifferences -> pure Nothing
gitSwitch :: Text -> IO Bool
gitSwitch branch =
git ["switch", branch]
gitSwitch_ :: Text -> IO ()
gitSwitch_ branch =
git_ ["switch", branch]
gitUnstageChanges :: IO ()
gitUnstageChanges = do
git_ ["reset", "--mixed"]
untrackedFiles <- gitListUntrackedFiles
unless (null untrackedFiles) (git_ ("add" : "--intent-to-add" : untrackedFiles))
gitVersion :: IO GitVersion
gitVersion = do
v0 <- git ["--version"]
fromMaybe (throwIO (userError ("Could not parse git version from: " <> Text.unpack v0))) do
["git", "version", v1] <- Just (Text.words v0)
[sx, sy, sz] <- Just (Text.split (== '.') v1)
x <- readMaybe (Text.unpack sx)
y <- readMaybe (Text.unpack sy)
z <- readMaybe (Text.unpack sz)
pure (pure (GitVersion x y z))
data GitWorktree = GitWorktree
{ branch :: Maybe Text,
commit :: Text,
directory :: Text
}
-- /dir/one 0efd393c35 [oingo] -> ("/dir/one", "0efd393c35", Just "oingo")
-- /dir/two dc0c114266 (detached HEAD) -> ("/dir/two", "dc0c114266", Nothing)
gitWorktreeList :: IO [GitWorktree]
gitWorktreeList = do
map f <$> git ["worktree", "list"]
where
f :: Text -> GitWorktree
f line =
case Text.words line of
[directory, commit, stripBrackets -> Just branch] -> GitWorktree {branch = Just branch, commit, directory}
[directory, commit, "(detached", "HEAD)"] -> GitWorktree {branch = Nothing, commit, directory}
_ -> error (Text.unpack line)
where
stripBrackets :: Text -> Maybe Text
stripBrackets =
Text.stripPrefix "[" >=> Text.stripSuffix "]"
-- git@github.com:mitchellwrosen/mit.git -> Just ("git@github.com:mitchellwrosen/mit.git", "mit")
parseGitRepo :: Text -> Maybe (Text, Text)
parseGitRepo url = do
url' <- Text.stripSuffix ".git" url
pure (url, Text.takeWhileEnd (/= '/') url')
git :: ProcessOutput a => [Text] -> IO a
git =
git' False
gitl :: ProcessOutput a => [Text] -> IO a
gitl =
git' True
git' :: ProcessOutput a => Bool -> [Text] -> IO a
git' effectful args = do
let spec :: CreateProcess
spec =
CreateProcess
{ child_group = Nothing,
child_user = Nothing,
close_fds = True,
cmdspec = RawCommand "git" (map Text.unpack args),
create_group = False,
cwd = Nothing,
delegate_ctlc = False,
env = Nothing,
new_session = False,
std_err = CreatePipe,
std_in = NoStream,
std_out = CreatePipe,
-- windows-only
create_new_console = False,
detach_console = False,
use_process_jobs = False
}
when effectful (logProcess "git" args)
bracket (createProcess spec) cleanup \(_maybeStdin, maybeStdout, maybeStderr, processHandle) ->
Ki.scoped \scope -> do
stdoutThread <- Ki.fork scope (drainTextHandle (fromJust maybeStdout))
stderrThread <- Ki.fork scope (drainTextHandle (fromJust maybeStderr))
exitCode <- waitForProcess processHandle
stdoutLines <- Ki.await stdoutThread
stderrLines <- Ki.await stderrThread
debugPrintGit args stdoutLines stderrLines exitCode
fromProcessOutput stdoutLines stderrLines exitCode
where
cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanup (maybeStdin, maybeStdout, maybeStderr, process) =
void @_ @ExitCode terminate `finally` closeHandles
where
closeHandles :: IO ()
closeHandles =
whenJust maybeStdin hClose
`finally` whenJust maybeStdout hClose
`finally` whenJust maybeStderr hClose
terminate :: IO ExitCode
terminate = do
withProcessHandle process \case
ClosedHandle _ -> pure ()
OpenExtHandle {} -> bug "OpenExtHandle is Windows-only"
OpenHandle pid -> do
pgid <- getProcessGroupIDOf pid
signalProcessGroup sigTERM pgid
waitForProcess process
git_ :: [Text] -> IO ()
git_ =
git
gitl_ :: [Text] -> IO ()
gitl_ =
gitl
-- Yucky interactive/inherity variant (so 'git commit' can open an editor).
gitl2 :: [Text] -> IO ExitCode
gitl2 args = do
logProcess "git" args
(Nothing, Nothing, Just stderrHandle, processHandle) <-
createProcess
CreateProcess
{ child_group = Nothing,
child_user = Nothing,
close_fds = True,
cmdspec = RawCommand "git" (map Text.unpack args),
create_group = False,
cwd = Nothing,
delegate_ctlc = True,
env = Nothing,
new_session = False,
std_err = CreatePipe,
std_in = Inherit,
std_out = Inherit,
-- windows-only
create_new_console = False,
detach_console = False,
use_process_jobs = False
}
exitCode <-
waitForProcess processHandle `catch` \case
UserInterrupt -> pure (ExitFailure (-130))
exception -> throwIO exception
stderrLines <- drainTextHandle stderrHandle
debugPrintGit args Seq.empty stderrLines exitCode
pure exitCode
debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> IO ()
debugPrintGit args stdoutLines stderrLines exitCode =
when debug do
putLines do
let output :: [Text]
output =
map (Text.brightBlack . (" " <>)) (toList @Seq (stdoutLines <> stderrLines))
Text.bold (Text.brightBlack (Text.unwords (marker <> " git" : map quoteText args))) : output
where
marker :: Text
marker =
case exitCode of
ExitFailure _ -> "✗"
ExitSuccess -> "✓"
drainTextHandle :: Handle -> IO (Seq Text)
drainTextHandle handle = do
let loop acc =
hIsEOF handle >>= \case
False -> do
line <- Text.hGetLine handle
loop $! acc Seq.|> line
True -> pure acc
loop Seq.empty