-- | Low-level git commands
module Mit.GitCommand
  ( Command (..),
    ResetMode (..),
    FlagD (..),
    FlagForce (..),
    FlagIntentToAdd (..),
    FlagNoCommit (..),
    FlagNoFF (..),
    FlagNoRenames (..),
    FlagNoTrack (..),
    FlagQuiet (..),
    FlagVerify (..),
    git,
    git_,
  )
where

import Data.Sequence qualified as Seq
import Data.Text qualified as Text
import Data.Text.Builder.ANSI qualified as Text.Builder
import Data.Text.IO qualified as Text
import Data.Text.Lazy.Builder qualified as Text (Builder)
import Data.Text.Lazy.Builder qualified as Text.Builder
import Ki qualified
import Mit.Builder qualified as Builder
import Mit.Env (Env (..))
import Mit.Monad
import Mit.Prelude
import Mit.Process
import System.Exit (ExitCode (..))
import System.IO (Handle, hClose, hIsEOF)
import System.Posix.Process (getProcessGroupIDOf)
import System.Posix.Signals
import System.Process
import System.Process.Internals

data Command
  = AddAll
  | Add FlagIntentToAdd [Text]
  | Branch FlagNoTrack Text
  | BranchSetUpstreamTo Text
  | BranchShowCurrent
  | Clean FlagD FlagForce
  | Diff FlagQuiet
  | Fetch Text
  | Merge FlagNoCommit FlagNoFF Text
  | MergeAbort
  | Reset ResetMode FlagQuiet Text
  | ResetPaths FlagQuiet [Text]
  | RevParse FlagQuiet FlagVerify Text
  | StashApply FlagQuiet Text
  | StashCreate
  | StatusV1 FlagNoRenames
  | Switch Text
  | SymbolicRef Text

renderCommand :: Command -> [Text]
renderCommand :: Command -> [Text]
renderCommand = \case
  Add FlagIntentToAdd
intentToAdd [Text]
files -> [Text
"add"] forall a. [a] -> [a] -> [a]
++ FlagIntentToAdd -> [Text]
renderFlagIntentToAdd FlagIntentToAdd
intentToAdd forall a. [a] -> [a] -> [a]
++ [Text]
files
  Command
AddAll -> [Text
"add", Text
"--all"]
  Branch FlagNoTrack
noTrack Text
branch -> [Text
"branch"] forall a. [a] -> [a] -> [a]
++ FlagNoTrack -> [Text]
renderFlagNoTrack FlagNoTrack
noTrack forall a. [a] -> [a] -> [a]
++ [Text
branch]
  BranchSetUpstreamTo Text
upstream -> [Text
"branch", Text
"--set-upstream-to", Text
upstream]
  Command
BranchShowCurrent -> [Text
"branch", Text
"--show-current"]
  Clean FlagD
d FlagForce
force -> [Text
"clean"] forall a. [a] -> [a] -> [a]
++ FlagD -> [Text]
renderFlagD FlagD
d forall a. [a] -> [a] -> [a]
++ FlagForce -> [Text]
renderFlagForce FlagForce
force
  Diff FlagQuiet
quiet -> [Text
"diff"] forall a. [a] -> [a] -> [a]
++ FlagQuiet -> [Text]
renderFlagQuiet FlagQuiet
quiet
  Fetch Text
remote -> [Text
"fetch", Text
remote]
  Merge FlagNoCommit
noCommit FlagNoFF
noFF Text
commit -> [Text
"merge"] forall a. [a] -> [a] -> [a]
++ FlagNoCommit -> [Text]
renderFlagNoCommit FlagNoCommit
noCommit forall a. [a] -> [a] -> [a]
++ FlagNoFF -> [Text]
renderFlagNoFF FlagNoFF
noFF forall a. [a] -> [a] -> [a]
++ [Text
commit]
  Command
MergeAbort -> [Text
"merge", Text
"--abort"]
  Reset ResetMode
mode FlagQuiet
quiet Text
commit -> [Text
"reset", ResetMode -> Text
renderResetMode ResetMode
mode] forall a. [a] -> [a] -> [a]
++ FlagQuiet -> [Text]
renderFlagQuiet FlagQuiet
quiet forall a. [a] -> [a] -> [a]
++ [Text
commit]
  ResetPaths FlagQuiet
quiet [Text]
paths -> [Text
"reset"] forall a. [a] -> [a] -> [a]
++ FlagQuiet -> [Text]
renderFlagQuiet FlagQuiet
quiet forall a. [a] -> [a] -> [a]
++ [Text
"--"] forall a. [a] -> [a] -> [a]
++ [Text]
paths
  RevParse FlagQuiet
quiet FlagVerify
verify Text
commit -> [Text
"rev-parse"] forall a. [a] -> [a] -> [a]
++ FlagQuiet -> [Text]
renderFlagQuiet FlagQuiet
quiet forall a. [a] -> [a] -> [a]
++ FlagVerify -> [Text]
renderFlagVerify FlagVerify
verify forall a. [a] -> [a] -> [a]
++ [Text
commit]
  StashApply FlagQuiet
quiet Text
commit -> [Text
"stash", Text
"apply"] forall a. [a] -> [a] -> [a]
++ FlagQuiet -> [Text]
renderFlagQuiet FlagQuiet
quiet forall a. [a] -> [a] -> [a]
++ [Text
commit]
  Command
StashCreate -> [Text
"stash", Text
"create"]
  StatusV1 FlagNoRenames
noRenames -> [Text
"status"] forall a. [a] -> [a] -> [a]
++ FlagNoRenames -> [Text]
renderFlagNoRenames FlagNoRenames
noRenames forall a. [a] -> [a] -> [a]
++ [Text
"--porcelain=v1"]
  Switch Text
branch -> [Text
"switch", Text
branch]
  SymbolicRef Text
commit -> [Text
"symbolic-ref", Text
commit]

data ResetMode
  = Mixed
  | Hard

renderResetMode :: ResetMode -> Text
renderResetMode :: ResetMode -> Text
renderResetMode = \case
  ResetMode
Mixed -> Text
"--mixed"
  ResetMode
Hard -> Text
"--hard"

data FlagD
  = FlagD
  | NoFlagD

renderFlagD :: FlagD -> [Text]
renderFlagD :: FlagD -> [Text]
renderFlagD = \case
  FlagD
FlagD -> [Text
"-d"]
  FlagD
NoFlagD -> []

data FlagForce
  = FlagForce
  | NoFlagForce

renderFlagForce :: FlagForce -> [Text]
renderFlagForce :: FlagForce -> [Text]
renderFlagForce = \case
  FlagForce
FlagForce -> [Text
"--force"]
  FlagForce
NoFlagForce -> []

data FlagIntentToAdd
  = FlagIntentToAdd
  | NoFlagIntentToAdd

renderFlagIntentToAdd :: FlagIntentToAdd -> [Text]
renderFlagIntentToAdd :: FlagIntentToAdd -> [Text]
renderFlagIntentToAdd = \case
  FlagIntentToAdd
FlagIntentToAdd -> [Text
"--intent-to-add"]
  FlagIntentToAdd
NoFlagIntentToAdd -> []

data FlagNoCommit
  = FlagNoCommit
  | NoFlagNoCommit

renderFlagNoCommit :: FlagNoCommit -> [Text]
renderFlagNoCommit :: FlagNoCommit -> [Text]
renderFlagNoCommit = \case
  FlagNoCommit
FlagNoCommit -> [Text
"--no-commit"]
  FlagNoCommit
NoFlagNoCommit -> []

data FlagNoFF
  = FlagNoFF
  | NoFlagNoFF

renderFlagNoFF :: FlagNoFF -> [Text]
renderFlagNoFF :: FlagNoFF -> [Text]
renderFlagNoFF = \case
  FlagNoFF
FlagNoFF -> [Text
"--no-ff"]
  FlagNoFF
NoFlagNoFF -> []

data FlagNoRenames
  = FlagNoRenames
  | NoFlagNoRenames

renderFlagNoRenames :: FlagNoRenames -> [Text]
renderFlagNoRenames :: FlagNoRenames -> [Text]
renderFlagNoRenames = \case
  FlagNoRenames
FlagNoRenames -> [Text
"--no-renames"]
  FlagNoRenames
NoFlagNoRenames -> []

data FlagNoTrack
  = FlagNoTrack
  | NoFlagNoTrack

renderFlagNoTrack :: FlagNoTrack -> [Text]
renderFlagNoTrack :: FlagNoTrack -> [Text]
renderFlagNoTrack = \case
  FlagNoTrack
FlagNoTrack -> [Text
"--no-track"]
  FlagNoTrack
NoFlagNoTrack -> []

data FlagQuiet
  = FlagQuiet
  | NoFlagQuiet

renderFlagQuiet :: FlagQuiet -> [Text]
renderFlagQuiet :: FlagQuiet -> [Text]
renderFlagQuiet = \case
  FlagQuiet
FlagQuiet -> [Text
"--quiet"]
  FlagQuiet
NoFlagQuiet -> []

data FlagVerify
  = FlagVerify
  | NoFlagVerify

renderFlagVerify :: FlagVerify -> [Text]
renderFlagVerify :: FlagVerify -> [Text]
renderFlagVerify = \case
  FlagVerify
FlagVerify -> [Text
"--verify"]
  FlagVerify
NoFlagVerify -> []

------------------------------------------------------------------------------------------------------------------------
-- Git process  stuff

git :: ProcessOutput a => Command -> Mit Env x a
git :: forall a x. ProcessOutput a => Command -> Mit Env x a
git =
  forall a x. ProcessOutput a => [Text] -> Mit Env x a
runGit forall b c a. (b -> c) -> (a -> b) -> a -> c
. Command -> [Text]
renderCommand

git_ :: Command -> Mit Env x ()
git_ :: forall x. Command -> Mit Env x ()
git_ =
  forall a x. ProcessOutput a => Command -> Mit Env x a
git

runGit :: ProcessOutput a => [Text] -> Mit Env x a
runGit :: forall a x. ProcessOutput a => [Text] -> Mit Env x a
runGit [Text]
args = do
  let spec :: CreateProcess
      spec :: CreateProcess
spec =
        CreateProcess
          { child_group :: Maybe GroupID
child_group = forall a. Maybe a
Nothing,
            child_user :: Maybe UserID
child_user = forall a. Maybe a
Nothing,
            close_fds :: Bool
close_fds = Bool
True,
            cmdspec :: CmdSpec
cmdspec = FilePath -> [FilePath] -> CmdSpec
RawCommand FilePath
"git" (forall a b. (a -> b) -> [a] -> [b]
map Text -> FilePath
Text.unpack [Text]
args),
            create_group :: Bool
create_group = Bool
False,
            cwd :: Maybe FilePath
cwd = forall a. Maybe a
Nothing,
            delegate_ctlc :: Bool
delegate_ctlc = Bool
False,
            env :: Maybe [(FilePath, FilePath)]
env = forall a. Maybe a
Nothing,
            new_session :: Bool
new_session = Bool
False,
            std_err :: StdStream
std_err = StdStream
CreatePipe,
            std_in :: StdStream
std_in = StdStream
NoStream,
            std_out :: StdStream
std_out = StdStream
CreatePipe,
            -- windows-only
            create_new_console :: Bool
create_new_console = Bool
False,
            detach_console :: Bool
detach_console = Bool
False,
            use_process_jobs :: Bool
use_process_jobs = Bool
False
          }

  forall a r x b.
(forall v. (a -> IO v) -> IO v)
-> (a -> Mit r (X x b) b) -> Mit r x b
with (forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket (CreateProcess
-> IO (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle)
createProcess CreateProcess
spec) (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanup) \(Maybe Handle
_maybeStdin, Maybe Handle
maybeStdout, Maybe Handle
maybeStderr, ProcessHandle
processHandle) -> do
    forall a r x b.
(forall v. (a -> IO v) -> IO v)
-> (a -> Mit r (X x b) b) -> Mit r x b
with forall a. (Scope -> IO a) -> IO a
Ki.scoped \Scope
scope -> do
      Thread (Seq Text)
stdoutThread <- forall a r x. IO a -> Mit r x a
io (forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStdout)))
      Thread (Seq Text)
stderrThread <- forall a r x. IO a -> Mit r x a
io (forall a. Scope -> IO a -> IO (Thread a)
Ki.fork Scope
scope (Handle -> IO (Seq Text)
drainTextHandle (forall a. HasCallStack => Maybe a -> a
fromJust Maybe Handle
maybeStderr)))
      ExitCode
exitCode <- forall a r x. IO a -> Mit r x a
io (ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
processHandle)
      Seq Text
stdoutLines <- forall a r x. IO a -> Mit r x a
io (forall a. STM a -> IO a
atomically (forall a. Thread a -> STM a
Ki.await Thread (Seq Text)
stdoutThread))
      Seq Text
stderrLines <- forall a r x. IO a -> Mit r x a
io (forall a. STM a -> IO a
atomically (forall a. Thread a -> STM a
Ki.await Thread (Seq Text)
stderrThread))
      forall x.
[Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode
      forall a r x. IO a -> Mit r x a
io (forall a.
ProcessOutput a =>
Seq Text -> Seq Text -> ExitCode -> IO a
fromProcessOutput Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode)
  where
    cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
    cleanup :: (Maybe Handle, Maybe Handle, Maybe Handle, ProcessHandle) -> IO ()
cleanup (Maybe Handle
maybeStdin, Maybe Handle
maybeStdout, Maybe Handle
maybeStderr, ProcessHandle
process) =
      forall (f :: * -> *) a. Functor f => f a -> f ()
void @_ @ExitCode IO ExitCode
terminate forall a b. IO a -> IO b -> IO a
`finally` IO ()
closeHandles
      where
        closeHandles :: IO ()
        closeHandles :: IO ()
closeHandles =
          forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdin Handle -> IO ()
hClose
            forall a b. IO a -> IO b -> IO a
`finally` forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStdout Handle -> IO ()
hClose
            forall a b. IO a -> IO b -> IO a
`finally` forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust Maybe Handle
maybeStderr Handle -> IO ()
hClose
        terminate :: IO ExitCode
        terminate :: IO ExitCode
terminate = do
          forall a. ProcessHandle -> (ProcessHandle__ -> IO a) -> IO a
withProcessHandle ProcessHandle
process \case
            ClosedHandle ExitCode
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
            OpenExtHandle {} -> forall a. Text -> a
bug Text
"OpenExtHandle is Windows-only"
            OpenHandle PHANDLE
pid -> do
              PHANDLE
pgid <- PHANDLE -> IO PHANDLE
getProcessGroupIDOf PHANDLE
pid
              Signal -> PHANDLE -> IO ()
signalProcessGroup Signal
sigTERM PHANDLE
pgid
          ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
process

debugPrintGit :: [Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit :: forall x.
[Text] -> Seq Text -> Seq Text -> ExitCode -> Mit Env x ()
debugPrintGit [Text]
args Seq Text
stdoutLines Seq Text
stderrLines ExitCode
exitCode = do
  Env
env <- forall r x. Mit r x r
getEnv
  forall a r x. IO a -> Mit r x a
io case Env
env.verbosity of
    Int
1 -> Builder -> IO ()
Builder.putln (Builder -> Builder
Text.Builder.brightBlack Builder
v1)
    Int
2 -> Builder -> IO ()
Builder.putln (Builder -> Builder
Text.Builder.brightBlack (Builder
v1 forall a. Semigroup a => a -> a -> a
<> Builder
v2))
    Int
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    v1 :: Builder
v1 = Builder -> Builder
Text.Builder.bold (Builder
marker forall a. Semigroup a => a -> a -> a
<> Builder
" git " forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *). Foldable f => f Builder -> Builder
Builder.hcat (forall a b. (a -> b) -> [a] -> [b]
map Text -> Builder
quote [Text]
args))
    v2 :: Builder
v2 = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\Text
line -> Builder
"\n    " forall a. Semigroup a => a -> a -> a
<> Text -> Builder
Text.Builder.fromText Text
line) (Seq Text
stdoutLines forall a. Semigroup a => a -> a -> a
<> Seq Text
stderrLines)

    quote :: Text -> Text.Builder
    quote :: Text -> Builder
quote Text
s =
      if (Char -> Bool) -> Text -> Bool
Text.any Char -> Bool
isSpace Text
s
        then Builder -> Builder
Builder.squoted (Text -> Builder
Text.Builder.fromText (HasCallStack => Text -> Text -> Text -> Text
Text.replace Text
"'" Text
"\\'" Text
s))
        else Text -> Builder
Text.Builder.fromText Text
s

    marker :: Text.Builder
    marker :: Builder
marker =
      case ExitCode
exitCode of
        ExitFailure Int
_ -> Char -> Builder
Text.Builder.singleton Char
'✗'
        ExitCode
ExitSuccess -> Char -> Builder
Text.Builder.singleton Char
'✓'

drainTextHandle :: Handle -> IO (Seq Text)
drainTextHandle :: Handle -> IO (Seq Text)
drainTextHandle Handle
handle = do
  let loop :: Seq Text -> IO (Seq Text)
loop Seq Text
acc =
        Handle -> IO Bool
hIsEOF Handle
handle forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Bool
False -> do
            Text
line <- Handle -> IO Text
Text.hGetLine Handle
handle
            Seq Text -> IO (Seq Text)
loop forall a b. (a -> b) -> a -> b
$! Seq Text
acc forall a. Seq a -> a -> Seq a
Seq.|> Text
line
          Bool
True -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Seq Text
acc
  Seq Text -> IO (Seq Text)
loop forall a. Seq a
Seq.empty