module Mit where
import Data.List.NonEmpty (NonEmpty ((:|)))
import qualified Data.List.NonEmpty as List1
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.Encoding.Base64 as Text
import qualified Data.Text.IO as Text
import qualified Data.Text.Lazy as Text.Lazy
import qualified Data.Text.Lazy.Builder as Text (Builder)
import qualified Data.Text.Lazy.Builder as Text.Builder
import Mit.Clock (getCurrentTime)
import Mit.Directory
import Mit.Git
import Mit.Prelude
import qualified Mit.Seq as Seq
import qualified Mit.Seq1 as Seq1
import Mit.State
import Mit.Undo
import System.Environment (getArgs)
import System.Exit (ExitCode (..), exitFailure)
-- FIXME: nicer "git status" story. in particular the conflict markers in the commits after a merge are a bit
-- ephemeral feeling
-- FIXME bail if active cherry-pick, active revert, active rebase, what else?
-- FIXME more Seq, less []
-- TODO mit init
-- TODO mit delete-branch
-- TODO tweak things to work with git < 2.30.1
-- TODO rewrite mit commit algorithm in readme
-- TODO git(hub,lab) flow or something?
-- TODO 'mit branch' with dirty working directory - apply changes to new worktree?
-- TODO undo in more cases?
-- TODO recommend merging master if it conflicts
-- TODO mit log
-- TODO optparse-applicative
main :: IO ()
main = do
getArgs >>= \case
["branch", branch] -> mitBranch (Text.pack branch)
["commit"] -> mitCommit
["merge", branch] -> mitMerge (Text.pack branch)
["sync"] -> mitSync
["undo"] -> mitUndo
_ -> do
putLines
[ "Usage:",
" mit branch ≪branch≫",
" mit clone ≪repo≫",
" mit commit",
" mit merge ≪branch≫",
" mit sync",
" mit undo"
]
exitFailure
dieIfBuggyGit :: IO ()
dieIfBuggyGit = do
version <- gitVersion
let validate (ver, err) = if version < ver then ((ver, err) :) else id
case foldr validate [] validations of
[] -> pure ()
errors ->
die $
map
(\(ver, err) -> "Prior to " <> Text.bold "git" <> " version " <> showGitVersion ver <> ", " <> err)
errors
where
validations :: [(GitVersion, Text)]
validations =
[ ( GitVersion 2 29 0,
Text.bold "git commit --patch"
<> " was broken for new files added with "
<> Text.bold "git add --intent-to-add"
<> "."
),
( GitVersion 2 30 1,
Text.bold "git stash create"
<> " was broken for new files added with "
<> Text.bold "git add --intent-to-add"
<> "."
)
]
dieIfMergeInProgress :: IO ()
dieIfMergeInProgress =
whenM gitMergeInProgress (die [Text.bold "git merge" <> " in progress."])
dieIfNotInGitDir :: IO ()
dieIfNotInGitDir =
try (evaluate gitdir) >>= \case
Left (_ :: ExitCode) -> exitFailure
Right _ -> pure ()
die :: [Text] -> IO a
die ss = do
Text.putStr (Text.red (Text.unlines ss))
exitFailure
mitBranch :: Text -> IO ()
mitBranch branch = do
dieIfNotInGitDir
gitBranchWorktreeDir branch >>= \case
Nothing -> do
whenM (doesDirectoryExist worktreeDir) (die ["Directory " <> Text.bold worktreeDir <> " already exists."])
gitl_ ["worktree", "add", "--detach", worktreeDir]
withCurrentDirectory worktreeDir do
whenNotM (gitSwitch branch) do
gitBranch branch
gitSwitch_ branch
gitFetch_ "origin"
whenM (gitRemoteBranchExists "origin" branch) do
let upstream = "origin/" <> branch
gitl_ ["reset", "--hard", upstream]
gitl_ ["branch", "--set-upstream-to", upstream]
Just directory ->
when (directory /= worktreeDir) do
die [Text.bold branch <> " is already checked out in " <> Text.bold directory <> "."]
where
worktreeDir :: Text
worktreeDir =
Text.dropWhileEnd (/= '/') rootdir <> branch
mitCommit :: IO ()
mitCommit = do
dieIfNotInGitDir
whenM gitExistUntrackedFiles dieIfBuggyGit
gitMergeInProgress >>= \case
False ->
gitDiff >>= \case
Differences -> mitCommit_
NoDifferences -> exitFailure
True -> mitCommitMerge
mitCommit_ :: IO ()
mitCommit_ = do
fetched <- gitFetch "origin"
branch <- gitCurrentBranch
let branch64 = Text.encodeBase64 branch
head <- gitHead
maybeUpstreamHead <- gitRemoteBranchHead "origin" branch
existRemoteCommits <- maybe (pure False) (gitExistCommitsBetween head) maybeUpstreamHead
existLocalCommits <- maybe (pure True) (\upstreamHead -> gitExistCommitsBetween upstreamHead "HEAD") maybeUpstreamHead
state0 <- readMitState branch64
stash <- gitCreateStash
let wouldFork = existRemoteCommits && not existLocalCommits
let shouldWarnAboutFork =
if wouldFork
then do
ago <- mitStateRanCommitAgo state0
if ago < 10_000_000_000
then pure False
else do
git_ ["reset", "--hard", fromJust maybeUpstreamHead]
canMergeCleanly <- git ["stash", "apply", stash]
git_ ["reset", "--hard", head]
git_ ["stash", "apply", stash]
gitUnstageChanges
pure canMergeCleanly
else pure False
-- Bail out early if we should warn that this commit would fork history
whenM shouldWarnAboutFork do
ranCommitAt <- Just <$> getCurrentTime
writeMitState branch64 state0 {ranCommitAt}
putLines
[ "",
" " <> Text.yellow (Text.italic branch <> " is not up-to-date."),
"",
" Run " <> Text.bold (Text.blue "mit sync") <> " first, or run " <> Text.bold (Text.blue "mit commit")
<> " again to record a commit anyway.",
""
]
exitFailure
committed <- gitCommit
localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD"
pushResult <-
case (localCommits, existRemoteCommits, fetched) of
(Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush)
(Seq.NonEmpty, True, _) -> pure (PushNotAttempted ForkedHistory)
(Seq.NonEmpty, False, False) -> pure (PushNotAttempted Offline)
(Seq.NonEmpty, False, True) -> PushAttempted <$> gitPush branch
let pushed =
case pushResult of
PushAttempted success -> success
PushNotAttempted _ -> False
-- Only bother resetting the "ran commit at" if we would fork and the commit was aborted
ranCommitAt <-
case (wouldFork, committed) of
(True, False) -> Just <$> getCurrentTime
_ -> pure Nothing
undos <-
case (pushed, committed, localCommits) of
(False, False, _) -> pure state0.undos
(False, True, _) -> pure [Reset head, Apply stash]
(True, True, Seq.Singleton) -> do
head1 <- gitHead
pure [Revert head1, Apply stash]
_ -> pure []
writeMitState branch64 MitState {head = (), merging = Nothing, ranCommitAt, undos}
putSummary
Summary
{ branch,
-- Whether we "can undo" from here is not exactly if the state says we can undo, because of one corner case:
-- we ran 'mit commit', then aborted the commit, and ultimately didn't push any other local changes.
--
-- In this case, the underlying state hasn't changed, so 'mit undo' will still work as if the 'mit commit'
-- was never run, we merely don't want to *say* "run 'mit undo' to undo" as feedback, because that sounds as
-- if it would undo the last command run, namely the 'mit commit' that was aborted.
canUndo = not (null undos) && committed,
conflicts = [],
syncs =
case Seq1.fromSeq localCommits of
Nothing -> []
Just commits ->
[ Sync
{ commits,
result = pushResultToSyncResult pushResult,
source = branch,
target = "origin/" <> branch
}
]
}
mitCommitMerge :: IO ()
mitCommitMerge = do
branch <- gitCurrentBranch
let branch64 = Text.encodeBase64 branch
head <- gitHead
state0 <- readMitState branch64
case state0.merging of
Nothing -> gitl_ ["commit", "--all", "--no-edit"]
Just merging ->
let message = fold ["⅄ ", if merging == branch then "" else merging <> " → ", branch]
in gitl_ ["commit", "--all", "--message", message]
case listToMaybe [commit | Apply commit <- state0.undos] of
Nothing -> mitSyncWith (Just [Reset head])
Just stash ->
gitApplyStash stash >>= \case
-- FIXME we just unstashed, now we're about to stash again :/
[] -> mitSyncWith (Just [Reset head, Apply stash])
conflicts -> do
writeMitState branch64 state0 {merging = Nothing, ranCommitAt = Nothing}
putSummary
Summary
{ branch,
canUndo = not (null state0.undos),
conflicts,
syncs = []
}
data PushResult
= PushAttempted Bool
| PushNotAttempted PushNotAttemptedReason
data PushNotAttemptedReason
= ForkedHistory -- local history has forked, need to sync
| NothingToPush -- no commits to push
| Offline -- fetch failed, so we seem offline
| UnseenCommits -- we just pulled remote commits; don't push in case there's something local to address
pushResultToSyncResult :: PushResult -> SyncResult
pushResultToSyncResult = \case
PushAttempted False -> SyncResult'Failure
PushAttempted True -> SyncResult'Success
PushNotAttempted ForkedHistory -> SyncResult'Failure
PushNotAttempted NothingToPush -> SyncResult'Success -- doesnt matter, wont be shown
PushNotAttempted Offline -> SyncResult'Offline
PushNotAttempted UnseenCommits -> SyncResult'Pending
-- FIXME if on branch 'foo', handle 'mitMerge foo' or 'mitMerge origin/foo' as 'mitSync'?
mitMerge :: Text -> IO ()
mitMerge target = do
dieIfNotInGitDir
dieIfMergeInProgress
whenM gitExistUntrackedFiles dieIfBuggyGit
branch <- gitCurrentBranch
let branch64 = Text.encodeBase64 branch
-- When given 'mit merge foo', prefer merging 'origin/foo' over 'foo'
targetCommit <- do
_fetched <- gitFetch "origin"
gitRemoteBranchHead "origin" target & onNothingM (git ["rev-parse", target] & onLeftM \_ -> exitFailure)
maybeMergeStatus <- mitMerge' ("⅄ " <> target <> " → " <> branch) targetCommit
writeMitState
branch64
MitState
{ head = (),
merging = do
mergeStatus <- maybeMergeStatus
case mergeStatus.result of
MergeResult'MergeConflicts _ -> Just target
MergeResult'StashConflicts _ -> Nothing,
ranCommitAt = Nothing,
undos =
case maybeMergeStatus of
Nothing -> []
Just mergeStatus -> List1.toList mergeStatus.undos
}
putSummary
Summary
{ branch,
canUndo = isJust maybeMergeStatus,
conflicts =
case maybeMergeStatus of
Nothing -> []
Just mergeStatus ->
case mergeStatus.result of
MergeResult'MergeConflicts conflicts -> List1.toList conflicts
MergeResult'StashConflicts conflicts -> conflicts,
syncs = do
mergeStatus <- maybeToList maybeMergeStatus
pure
Sync
{ commits = mergeStatus.commits,
result =
case mergeStatus.result of
MergeResult'MergeConflicts _ -> SyncResult'Failure
-- Even if we have conflicts from unstashing, we call this merge a success.
MergeResult'StashConflicts _ -> SyncResult'Success,
source = target,
target = branch
}
}
data MergeStatus = MergeStatus
{ commits :: Seq1 GitCommitInfo,
result :: MergeResult,
undos :: List1 Undo
}
data MergeResult
= MergeResult'MergeConflicts (List1 GitConflict)
| MergeResult'StashConflicts [GitConflict]
mitMerge' :: Text -> Text -> IO (Maybe MergeStatus)
mitMerge' message target = do
head <- gitHead
(Seq1.fromSeq <$> gitCommitsBetween (Just head) target) >>= \case
Nothing -> pure Nothing
Just commits -> do
maybeStash <- gitStash
let undos = Reset head :| maybeToList (Apply <$> maybeStash)
result <-
gitl ["merge", "--ff", "--no-commit", target] >>= \case
False -> do
conflicts <- gitConflicts
-- error: The following untracked working tree files would be overwritten by merge:
-- administration-client/administration-client.cabal
-- aeson-simspace/aeson-simspace.cabal
-- attack-designer/api/attack-designer-api.cabal
-- attack-designer/db/attack-designer-db.cabal
-- attack-designer/server/attack-designer-server.cabal
-- attack-integrations/attack-integrations.cabal
-- authz/simspace-authz.cabal
-- caching/caching.cabal
-- common-testlib/common-testlib.cabal
-- db-infra/db-infra.cabal
-- db-infra/migrations/0_migrate-rich-text-images-to-minio/migrate-rich-text-images-to-minio.cabal
-- db-infra/migrations/2.0.0.1010_migrate-questions-into-content-modules/range-data-server-migrate-questions-into-content-modules.cabal
-- db-infra/migrations/2.0.0.19_migrate-hello-table/range-data-server-migrate-hello-table.cabal
-- db-infra/migrations/2.0.0.21_migrate-puppet-yaml-to-text/range-data-server-migrate-puppet-yaml-to-text.cabal
-- db-infra/migrations/2.0.0.9015_migrate-refresh-stocks/range-data-server-migrate-refresh-stocks.cabal
-- db-infra/migrations/shared/range-data-server-migration.cabal
-- Please move or remove them before you merge.
-- Aborting
pure (MergeResult'MergeConflicts (List1.fromList conflicts))
True -> do
whenM gitMergeInProgress (gitl_ ["commit", "--message", message])
maybeConflicts <- for maybeStash gitApplyStash
pure (MergeResult'StashConflicts (fromMaybe [] maybeConflicts))
pure (Just MergeStatus {commits, result, undos})
-- TODO implement "lateral sync", i.e. a merge from some local or remote branch, followed by a sync to upstream
mitSync :: IO ()
mitSync = do
dieIfNotInGitDir
dieIfMergeInProgress
whenM gitExistUntrackedFiles dieIfBuggyGit
mitSyncWith Nothing
-- | @mitSyncWith maybeUndos@
--
-- Whenever recording what 'mit undo' should do after 'mit sync', if 'maybeUndos' is provided, we use them instead.
-- This is pulled into a function argument to get better undo behavior after committing a merge.
--
-- Consider:
--
-- The user runs 'mit merge foo' (with or without a clean working tree), and gets conflicts. After fixing them, she runs
-- 'mit commit'. This may result in *additional* conflicts due to the just-stashed uncommitted changes.
--
-- But either way, internally, we would like this 'mit commit' to effectively behave as a normal commit, in the sense
-- that we want to immediately push it upstream. That means the code would like to simply call 'mit sync' after
-- 'git commit'!
--
-- However, if this commit could be undone (i.e. we didn't push it), we wouldn't want that 'mit sync' to *locally*
-- compute where to undo, because it would just conclude, "oh, HEAD hasn't moved, and we didn't push, so there's nothing
-- to undo".
--
-- Instead, we want to undo to the point before running the 'mit merge' that caused the conflicts, which were later
-- resolved by 'mit commit'.
mitSyncWith :: Maybe [Undo] -> IO ()
mitSyncWith maybeUndos = do
fetched <- gitFetch "origin"
branch <- gitCurrentBranch
let branch64 = Text.encodeBase64 branch
maybeUpstreamHead <- gitRemoteBranchHead "origin" branch
maybeMergeStatus <-
case maybeUpstreamHead of
Nothing -> pure Nothing
Just upstreamHead -> mitMerge' ("⅄ " <> branch) upstreamHead
localCommits <- gitCommitsBetween maybeUpstreamHead "HEAD"
pushResult <-
case (localCommits, (.result) <$> maybeMergeStatus, fetched) of
(Seq.Empty, _, _) -> pure (PushNotAttempted NothingToPush)
-- "forked history" is ok - a bit different than history *already* having forked, in which case a push
-- would just fail, whereas this is just us choosing not to push while in the middle of a merge due to a
-- previous fork in the history
(Seq.NonEmpty, Just (MergeResult'MergeConflicts _), _) -> pure (PushNotAttempted ForkedHistory)
(Seq.NonEmpty, Just (MergeResult'StashConflicts _), _) -> pure (PushNotAttempted UnseenCommits)
(Seq.NonEmpty, Nothing, False) -> pure (PushNotAttempted Offline)
(Seq.NonEmpty, Nothing, True) -> PushAttempted <$> gitPush branch
let pushed =
case pushResult of
PushAttempted success -> success
PushNotAttempted _ -> False
let undos =
case pushed of
False -> fromMaybe (maybe [] (List1.toList . (.undos)) maybeMergeStatus) maybeUndos
True -> []
writeMitState
branch64
MitState
{ head = (),
merging = do
mergeStatus <- maybeMergeStatus
case mergeStatus.result of
MergeResult'MergeConflicts _ -> Just branch
MergeResult'StashConflicts _ -> Nothing,
ranCommitAt = Nothing,
undos
}
putSummary
Summary
{ branch,
canUndo = not (null undos),
conflicts =
case maybeMergeStatus of
Nothing -> []
Just mergeStatus ->
case mergeStatus.result of
MergeResult'MergeConflicts conflicts -> List1.toList conflicts
MergeResult'StashConflicts conflicts -> conflicts,
syncs =
catMaybes
[ do
mergeStatus <- maybeMergeStatus
pure
Sync
{ commits = mergeStatus.commits,
result =
case mergeStatus.result of
MergeResult'MergeConflicts _ -> SyncResult'Failure
MergeResult'StashConflicts _ -> SyncResult'Success,
source = "origin/" <> branch,
target = branch
},
do
commits <- Seq1.fromSeq localCommits
pure
Sync
{ commits,
result = pushResultToSyncResult pushResult,
source = branch,
target = "origin/" <> branch
}
]
}
-- FIXME output what we just undid
mitUndo :: IO ()
mitUndo = do
dieIfNotInGitDir
branch64 <- Text.encodeBase64 <$> gitCurrentBranch
state0 <- readMitState branch64
case List1.nonEmpty state0.undos of
Nothing -> exitFailure
Just undos1 -> applyUndos undos1
when (undosContainRevert state0.undos) mitSync
where
undosContainRevert :: [Undo] -> Bool
undosContainRevert = \case
[] -> False
Revert _ : _ -> True
_ : undos -> undosContainRevert undos
data Summary = Summary
{ branch :: Text,
canUndo :: Bool,
conflicts :: [GitConflict],
syncs :: [Sync]
}
data Sync = Sync
{ commits :: Seq1 GitCommitInfo,
result :: SyncResult,
source :: Text,
target :: Text
}
data SyncResult
= SyncResult'Failure
| SyncResult'Offline
| SyncResult'Pending
| SyncResult'Success
-- FIXME show some graph of where local/remote is at
putSummary :: Summary -> IO ()
putSummary summary =
let output = concatMap syncLines summary.syncs ++ conflictsLines ++ undoLines
in if null output then pure () else putLines (map (Text.Lazy.toStrict . Text.Builder.toLazyText) ("" : output))
where
conflictsLines :: [Text.Builder]
conflictsLines =
if null summary.conflicts
then []
else
" The following files have conflicts." :
map ((" " <>) . Text.Builder.red . showGitConflict) summary.conflicts ++ [""]
syncLines :: Sync -> [Text.Builder]
syncLines sync =
colorize
( Text.Builder.italic
(" " <> Text.Builder.fromText sync.source <> " → " <> Text.Builder.fromText sync.target)
) :
map ((" " <>) . prettyGitCommitInfo) (toList @Seq commits')
++ (if more then [" ...", ""] else [""])
where
colorize :: Text.Builder -> Text.Builder
colorize =
case sync.result of
SyncResult'Failure -> Text.Builder.red
SyncResult'Offline -> Text.Builder.brightBlack
SyncResult'Pending -> Text.Builder.yellow
SyncResult'Success -> Text.Builder.green
(commits', more) =
case Seq1.length sync.commits > 10 of
False -> (Seq1.toSeq sync.commits, False)
True -> (Seq1.dropEnd 1 sync.commits, True)
undoLines :: [Text.Builder]
undoLines =
if summary.canUndo
then [" Run " <> Text.Builder.bold (Text.Builder.blue "mit undo") <> " to undo this change.", ""]
else []
-- Undo file utils