Compare commits
12 Commits
a151cf26c4
...
d22ea39cde
| Author | SHA1 | Date | |
|---|---|---|---|
| d22ea39cde | |||
| 25b8f24906 | |||
| 7d2a4b3a30 | |||
| 2f2cc16551 | |||
| e0f986a5ee | |||
| 63e034fd01 | |||
| eb847c03f6 | |||
| bcf43d5d83 | |||
| ee8a4cb449 | |||
| 4bc23b5d7c | |||
| 65bf75cdf2 | |||
| 34c8232427 |
@@ -0,0 +1,133 @@
|
|||||||
|
# AGENTS.md — Project guide for AI coding agents
|
||||||
|
|
||||||
|
## Project overview
|
||||||
|
|
||||||
|
**Converge** watches git repositories for file changes, automatically commits them, and pulls from a remote via rebase. It notifies the user via `notify-send` on merge conflicts.
|
||||||
|
|
||||||
|
- **Language**: Haskell (GHC 9.10.3, Stackage lts-24.38)
|
||||||
|
- **Build system**: Stack (config in `stack.yaml`, packages in `package.yaml`)
|
||||||
|
- **Cabal file**: `converge.cabal` is generated from `package.yaml` via hpack
|
||||||
|
|
||||||
|
## File layout
|
||||||
|
|
||||||
|
```
|
||||||
|
src/Converge.hs # Single library module — all core logic
|
||||||
|
app/Main.hs # CLI entry point (optparse-applicative)
|
||||||
|
test/Spec.hs # Test runner (imports and runs all spec modules)
|
||||||
|
test/TestHelper.hs # Shared test utilities (temp repos, sentinel files)
|
||||||
|
test/GitCommitSpec.hs # Commit behaviour tests
|
||||||
|
test/GitPullSpec.hs # Pull/rebase tests
|
||||||
|
test/GitSafetySpec.hs # Operation-in-progress detection tests
|
||||||
|
SPEC.md # Human-readable specifications
|
||||||
|
converge.example.yaml # Example config file
|
||||||
|
converge.service # systemd unit file
|
||||||
|
```
|
||||||
|
|
||||||
|
## Architecture
|
||||||
|
|
||||||
|
All core logic lives in the single `Converge` module (`src/Converge.hs`). Key sections:
|
||||||
|
|
||||||
|
- **Types**: `Options`, `RepoConfig`, `Config`, `Logger` (an `MVar ()` for serialized logging)
|
||||||
|
- **Config**: YAML config file parsing via `Data.Yaml`, XDG path discovery
|
||||||
|
- **File watching**: `fsnotify` via `watchRepo` — one per configured repo, each in its own thread (via `async`)
|
||||||
|
- **Debounce**: An `MVar` pattern coalesces rapid events into one sync per quiet period
|
||||||
|
- **Sync cycle** (`syncRepo`): guarded by `isInMiddleOfOperation`, then stage + commit + pull + conflict check
|
||||||
|
- **Git operations**: shell out to `git` via `System.Process.readProcessWithExitCode` — no libgit2 dependency
|
||||||
|
- **Notifications**: shell out to `notify-send` via `System.Process.spawnProcess`
|
||||||
|
|
||||||
|
### Git operations
|
||||||
|
|
||||||
|
| Function | Git command |
|
||||||
|
|---|---|
|
||||||
|
| `gitCommitAll` | `git add -A` + `git commit -m "converge: auto-commit from <host>"` |
|
||||||
|
| `gitPull` | `git pull --rebase <remote> <branch>` |
|
||||||
|
| `hasConflicts` | `git diff --check` looking for `<<<<<<<` / `=======` / `>>>>>>>` |
|
||||||
|
| `isInMiddleOfOperation` | `git rev-parse --git-dir` then checks sentinel files/dirs |
|
||||||
|
|
||||||
|
### Operation detection sentinels
|
||||||
|
|
||||||
|
`checkIndicatorFiles` checks these inside `.git/`:
|
||||||
|
|
||||||
|
| File/Dir | Operation |
|
||||||
|
|---|---|
|
||||||
|
| `MERGE_HEAD` | Merge in progress |
|
||||||
|
| `REVERT_HEAD` | Revert in progress |
|
||||||
|
| `CHERRY_PICK_HEAD` | Cherry-pick in progress |
|
||||||
|
| `BISECT_LOG` | Bisect in progress |
|
||||||
|
| `rebase-apply/` | Rebase in progress |
|
||||||
|
| `rebase-merge/` | Rebase in progress |
|
||||||
|
| `sequencer/` | Sequencer-based operation in progress |
|
||||||
|
|
||||||
|
`REBASE_HEAD` is intentionally excluded — git does not remove it when a rebase completes, causing false positives.
|
||||||
|
|
||||||
|
## Build / test / run
|
||||||
|
|
||||||
|
```bash
|
||||||
|
stack build # Build library + executable + tests
|
||||||
|
stack test # Build and run the test suite
|
||||||
|
stack exec converge -- [options] # Run the tool directly
|
||||||
|
./scripts/build # Format + build + compress (uses Docker via ./hs)
|
||||||
|
./scripts/test # Run tests (uses Docker via ./hs)
|
||||||
|
./scripts/run # Run the tool (uses Docker via ./hs)
|
||||||
|
```
|
||||||
|
|
||||||
|
## Test conventions
|
||||||
|
|
||||||
|
Tests use **hspec** and create real temporary git repositories — no mocking of git commands. This avoids complexity and tests actual git semantics.
|
||||||
|
|
||||||
|
### Helper module (`test/TestHelper.hs`)
|
||||||
|
|
||||||
|
- `withTempGitRepo :: (FilePath -> IO a) -> IO a` — creates a temp dir, runs `git init -b main`, configures user, makes an initial commit, runs the action, cleans up.
|
||||||
|
- `withTempGitRepoWithRemote :: (FilePath -> IO a) -> IO a` — like above but also creates a bare remote, adds it as `origin`, and pushes the initial commit.
|
||||||
|
- `runGitIn :: FilePath -> [String] -> IO (ExitCode, Text, Text)` — runs `git -C <path> <args>`.
|
||||||
|
- `rawGit :: [String] -> IO (ExitCode, Text, Text)` — runs `git <args>` without `-C` (for `git clone`, etc.).
|
||||||
|
- `testLogger :: IO Logger` — creates a test Logger backed by a fresh `MVar`.
|
||||||
|
- Sentinel helpers (`createMergeHead`, `createRebaseApply`, etc.) — create the known sentinel files/dirs inside `.git/`.
|
||||||
|
|
||||||
|
### Writing new tests
|
||||||
|
|
||||||
|
1. Create a new spec module in `test/` (e.g., `test/MyNewSpec.hs`)
|
||||||
|
2. Export a top-level `spec :: Spec` value
|
||||||
|
3. Import it in `test/Spec.hs` and add it to the `hspec` block
|
||||||
|
4. Use `withTempGitRepo` for tests that need a git repo
|
||||||
|
5. If the test needs new exports from `Converge`, add them to the module's export list
|
||||||
|
|
||||||
|
### Spec coverage
|
||||||
|
|
||||||
|
Tests are organized to match `SPEC.md`:
|
||||||
|
|
||||||
|
Anytime new behavior is added the `SPEC.md` should be updated and a corresponding hspec test written.
|
||||||
|
|
||||||
|
| Spec | Test module | Key tests |
|
||||||
|
|---|---|---|
|
||||||
|
| Creates commit on file change | `GitCommitSpec` | Commit creation, content inclusion, no duplicate commits |
|
||||||
|
| One commit per debounce window | `GitCommitSpec` | Idempotency of `gitCommitAll` |
|
||||||
|
| Pulls from remote origin | `GitPullSpec` | Fast-forward pull scenario |
|
||||||
|
| Rebases on pull | `GitPullSpec` | Divergent history → linear history, no merge commits |
|
||||||
|
| No-op during operations | `GitSafetySpec` | All 7 sentinel types + clean repo |
|
||||||
|
|
||||||
|
## Key conventions
|
||||||
|
|
||||||
|
- **Default extensions** (from `package.yaml`): `OverloadedStrings`, `RecordWildCards`, `ScopedTypeVariables`, `TupleSections`
|
||||||
|
- **GHC options**: `-Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints`
|
||||||
|
- **Strings are `Text`** (via `OverloadedStrings`), not `String`
|
||||||
|
- **Logging** goes through the `Logger` newtype wrapping `MVar ()` — all logging is serialized to stderr
|
||||||
|
- **Hostname** for commit messages is obtained via `readProcess "hostname" [] ""`
|
||||||
|
- **Git commands** always use `readProcessWithExitCode` (not `readProcess` except for hostname)
|
||||||
|
|
||||||
|
## Dependencies
|
||||||
|
|
||||||
|
| Package | Purpose |
|
||||||
|
|---|---|
|
||||||
|
| `async` | Concurrent repo watching |
|
||||||
|
| `fsnotify` | File system event monitoring |
|
||||||
|
| `optparse-applicative` | CLI argument parsing |
|
||||||
|
| `yaml` | Config file parsing |
|
||||||
|
| `temporary` (test only) | Temp directories for test repos |
|
||||||
|
| `hspec` (test only) | Test framework |
|
||||||
|
|
||||||
|
## External requirements
|
||||||
|
|
||||||
|
- `git` must be on PATH (no libgit2 dependency)
|
||||||
|
- `notify-send` for desktop notifications (optional — only called on conflict)
|
||||||
|
- `hostname` command for commit message generation
|
||||||
@@ -0,0 +1,14 @@
|
|||||||
|
# Converge specifications
|
||||||
|
|
||||||
|
## Creates a commit after a file is changed
|
||||||
|
## Only creates one commit when multiple changes occur within a 5 second window
|
||||||
|
|
||||||
|
## Pulls changes from remote "origin" before pushing commits
|
||||||
|
## Rebases when pulling changes from "origin"
|
||||||
|
|
||||||
|
## Does not operate (stage, commit or push) on git repos when:
|
||||||
|
### a rebase is in progess
|
||||||
|
### a merge is in progess
|
||||||
|
### a revert is in progess
|
||||||
|
### a cherry-pick is in progess
|
||||||
|
### a bisect is in progess
|
||||||
@@ -0,0 +1,17 @@
|
|||||||
|
# ~~Expand desktop notifications~~
|
||||||
|
|
||||||
|
~~Converge should use notify-send anytime there is a failure with a git operation~~
|
||||||
|
|
||||||
|
✅ Done (notify-send on commit, pull, and push failures — eb847c0)
|
||||||
|
|
||||||
|
# ~~Commit and push uncommitted changes~~
|
||||||
|
|
||||||
|
~~On startup, Converge should detect any uncommitted changes in a monitored repo and then commit and push them.~~
|
||||||
|
|
||||||
|
✅ Done (startup sync + push — 63e034f)
|
||||||
|
|
||||||
|
# ~~Git write operations should be logged~~
|
||||||
|
|
||||||
|
~~All git operations that modify repo state should be logged - including the time, command, arguments and exit code. Possibly the standard out and standard error.~~
|
||||||
|
|
||||||
|
✅ Done (loggedGit helper — 2f2cc16)
|
||||||
@@ -65,3 +65,4 @@ tests:
|
|||||||
dependencies:
|
dependencies:
|
||||||
- converge
|
- converge
|
||||||
- hspec
|
- hspec
|
||||||
|
- temporary
|
||||||
|
|||||||
+147
-27
@@ -14,14 +14,26 @@ module Converge (
|
|||||||
|
|
||||||
-- * Running
|
-- * Running
|
||||||
runConverge,
|
runConverge,
|
||||||
|
syncRepo,
|
||||||
|
|
||||||
|
-- * Logger
|
||||||
|
Logger (..),
|
||||||
|
newLogger,
|
||||||
|
|
||||||
-- * Git operations
|
-- * Git operations
|
||||||
gitCommitAll,
|
gitCommitAll,
|
||||||
gitPull,
|
gitPull,
|
||||||
|
gitPush,
|
||||||
|
runGitIn,
|
||||||
hasConflicts,
|
hasConflicts,
|
||||||
|
isInMiddleOfOperation,
|
||||||
|
checkIndicatorFiles,
|
||||||
|
|
||||||
-- * Notifications
|
-- * Notifications
|
||||||
notifyConflict,
|
notifyUser,
|
||||||
|
|
||||||
|
-- * File filtering
|
||||||
|
isGitIgnored,
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
@@ -29,14 +41,14 @@ import Control.Concurrent (forkIO, threadDelay)
|
|||||||
import Control.Concurrent.Async (mapConcurrently_)
|
import Control.Concurrent.Async (mapConcurrently_)
|
||||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar, tryPutMVar, tryTakeMVar, withMVar)
|
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar, tryPutMVar, tryTakeMVar, withMVar)
|
||||||
import Control.Exception (bracket)
|
import Control.Exception (bracket)
|
||||||
import Control.Monad (forever, unless, void)
|
import Control.Monad (forever, unless, void, when)
|
||||||
import Data.Maybe (fromMaybe)
|
import Data.Maybe (fromMaybe)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Time.Clock (getCurrentTime)
|
import Data.Time.Clock (getCurrentTime)
|
||||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||||
import Data.Yaml (FromJSON (..), decodeFileThrow, withObject, (.:), (.:?))
|
import Data.Yaml (FromJSON (..), decodeFileThrow, withObject, (.:), (.:?))
|
||||||
import System.Directory (XdgDirectory (XdgConfig), doesFileExist, getCurrentDirectory, getXdgDirectory)
|
import System.Directory (XdgDirectory (XdgConfig), doesDirectoryExist, doesFileExist, getCurrentDirectory, getXdgDirectory)
|
||||||
import System.Exit (ExitCode (..))
|
import System.Exit (ExitCode (..))
|
||||||
import System.FSNotify
|
import System.FSNotify
|
||||||
import System.FilePath (isAbsolute, splitDirectories, (</>))
|
import System.FilePath (isAbsolute, splitDirectories, (</>))
|
||||||
@@ -180,11 +192,15 @@ watchRepo opts logger repo = do
|
|||||||
-- Drain any events that arrived during the debounce window
|
-- Drain any events that arrived during the debounce window
|
||||||
void $ tryTakeMVar pending
|
void $ tryTakeMVar pending
|
||||||
syncRepo opts logger repo
|
syncRepo opts logger repo
|
||||||
|
-- Sync any uncommitted changes that exist on startup
|
||||||
|
syncRepo opts logger repo
|
||||||
bracket
|
bracket
|
||||||
(startManagerConf defaultConfig)
|
(startManagerConf defaultConfig)
|
||||||
stopManager
|
stopManager
|
||||||
$ \mgr -> do
|
$ \mgr -> do
|
||||||
_ <- watchTree mgr absPath (\e -> not (isGitPath (eventPath e))) $ \event -> do
|
_ <- watchTree mgr absPath (\e -> not (isGitPath (eventPath e))) $ \event -> do
|
||||||
|
ignored <- isGitIgnored (rcPath repo) (eventPath event)
|
||||||
|
unless ignored $ do
|
||||||
logEvent logger repo event
|
logEvent logger repo event
|
||||||
void $ tryPutMVar pending ()
|
void $ tryPutMVar pending ()
|
||||||
forever $ threadDelay maxBound
|
forever $ threadDelay maxBound
|
||||||
@@ -215,10 +231,27 @@ eventLabel event = case event of
|
|||||||
isGitPath :: FilePath -> Bool
|
isGitPath :: FilePath -> Bool
|
||||||
isGitPath = elem ".git" . splitDirectories
|
isGitPath = elem ".git" . splitDirectories
|
||||||
|
|
||||||
-- | Run a full sync cycle on a single repo: commit + pull + conflict check.
|
{- | Check whether a file path is ignored by the repository's gitignore rules.
|
||||||
|
Uses @git check-ignore -q@ which respects all gitignore sources
|
||||||
|
(.gitignore, .git/info/exclude, global gitignore, etc.).
|
||||||
|
-}
|
||||||
|
isGitIgnored :: FilePath -> FilePath -> IO Bool
|
||||||
|
isGitIgnored repoPath filePath = do
|
||||||
|
(code, _, _) <- readProcessWithExitCode "git" ["-C", repoPath, "check-ignore", "-q", filePath] ""
|
||||||
|
pure (code == ExitSuccess)
|
||||||
|
|
||||||
|
{- | Run a full sync cycle on a single repo: commit + pull + conflict check.
|
||||||
|
Skips the cycle if the repo is in the middle of an operation such as a
|
||||||
|
merge, rebase, revert, cherry-pick, or bisect.
|
||||||
|
-}
|
||||||
syncRepo :: Options -> Logger -> RepoConfig -> IO ()
|
syncRepo :: Options -> Logger -> RepoConfig -> IO ()
|
||||||
syncRepo opts logger repo = do
|
syncRepo opts logger repo = do
|
||||||
logRepo logger repo "sync cycle starting"
|
logRepo logger repo "sync cycle starting"
|
||||||
|
-- Guard: bail out if an operation (merge, rebase, revert, etc.) is in progress
|
||||||
|
inProgress <- isInMiddleOfOperation (rcPath repo)
|
||||||
|
when inProgress $ do
|
||||||
|
logRepo logger repo "*** SKIPPING: an operation (merge/rebase/revert/cherry-pick/bisect) is in progress ***"
|
||||||
|
unless inProgress $ do
|
||||||
-- Check what's changed
|
-- Check what's changed
|
||||||
(_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
|
(_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
|
||||||
let changed = filter (not . T.null) (T.lines statusOut)
|
let changed = filter (not . T.null) (T.lines statusOut)
|
||||||
@@ -237,26 +270,49 @@ syncRepo opts logger repo = do
|
|||||||
| "nothing to commit" `T.isInfixOf` commitOut
|
| "nothing to commit" `T.isInfixOf` commitOut
|
||||||
|| "nothing to commit" `T.isInfixOf` commitErr ->
|
|| "nothing to commit" `T.isInfixOf` commitErr ->
|
||||||
logRepo logger repo "nothing to commit (working tree clean)"
|
logRepo logger repo "nothing to commit (working tree clean)"
|
||||||
| otherwise ->
|
| otherwise -> do
|
||||||
logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
|
logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
|
||||||
|
notifyUser
|
||||||
|
opts
|
||||||
|
"Converge: Commit Failed"
|
||||||
|
("Commit failed in " <> rcPath repo <> " (exit " <> show commitCode <> ")")
|
||||||
-- Pull
|
-- Pull
|
||||||
logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
|
logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
|
||||||
(pullCode, pullOut, pullErr) <- gitPull repo
|
(pullCode, pullOut, pullErr) <- gitPull logger repo
|
||||||
case pullCode of
|
case pullCode of
|
||||||
ExitSuccess -> do
|
ExitSuccess -> do
|
||||||
let trimmed = T.strip pullOut
|
let trimmed = T.strip pullOut
|
||||||
if T.null trimmed
|
if T.null trimmed
|
||||||
then logRepo logger repo "pull: already up to date"
|
then logRepo logger repo "pull: already up to date"
|
||||||
else logRepo logger repo ("pull succeeded:\n" <> trimmed)
|
else logRepo logger repo ("pull succeeded:\n" <> trimmed)
|
||||||
_ ->
|
_ -> do
|
||||||
logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
|
logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
|
||||||
|
notifyUser
|
||||||
|
opts
|
||||||
|
"Converge: Pull Failed"
|
||||||
|
("Pull failed in " <> rcPath repo <> " (exit " <> show pullCode <> ")")
|
||||||
-- Conflict check
|
-- Conflict check
|
||||||
conflicted <- hasConflicts (rcPath repo)
|
conflicted <- hasConflicts (rcPath repo)
|
||||||
if conflicted
|
if conflicted
|
||||||
then do
|
then do
|
||||||
logRepo logger repo "*** MERGE CONFLICT detected! ***"
|
logRepo logger repo "*** MERGE CONFLICT detected! ***"
|
||||||
notifyConflict opts repo
|
notifyUser
|
||||||
else logRepo logger repo "sync complete, no conflicts"
|
opts
|
||||||
|
"Converge: Merge Conflict"
|
||||||
|
("A merge conflict occurred in " <> rcPath repo <> ". Manual resolution required.")
|
||||||
|
else do
|
||||||
|
logRepo logger repo "sync complete, no conflicts"
|
||||||
|
-- Push local commits to remote
|
||||||
|
(pushCode, pushOut, pushErr) <- gitPush logger repo
|
||||||
|
case pushCode of
|
||||||
|
ExitSuccess ->
|
||||||
|
logRepo logger repo "push succeeded"
|
||||||
|
_ -> do
|
||||||
|
logRepo logger repo ("push FAILED (exit " <> T.pack (show pushCode) <> "): " <> T.strip (pushOut <> pushErr))
|
||||||
|
notifyUser
|
||||||
|
opts
|
||||||
|
"Converge: Push Failed"
|
||||||
|
("Push failed in " <> rcPath repo <> " (exit " <> show pushCode <> ")")
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- Git operations
|
-- Git operations
|
||||||
@@ -265,18 +321,43 @@ syncRepo opts logger repo = do
|
|||||||
-- | Stage all changes and commit with an auto-generated message.
|
-- | Stage all changes and commit with an auto-generated message.
|
||||||
gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text)
|
gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text)
|
||||||
gitCommitAll logger repoPath = do
|
gitCommitAll logger repoPath = do
|
||||||
(_, _, stageErr) <- runGitIn repoPath ["add", "-A"]
|
addResult@(addCode, _, addErr) <- loggedGit logger repoPath ["add", "-A"]
|
||||||
unless (T.null stageErr) $
|
unless (T.null addErr) $
|
||||||
logInfo logger ("git add stderr: " <> stageErr)
|
logInfo logger ("git add stderr: " <> addErr)
|
||||||
|
if addCode /= ExitSuccess
|
||||||
|
then pure addResult
|
||||||
|
else do
|
||||||
hostname <- init <$> readProcess "hostname" [] ""
|
hostname <- init <$> readProcess "hostname" [] ""
|
||||||
runGitIn repoPath ["commit", "-m", "converge: auto-commit from " <> hostname]
|
loggedGit logger repoPath ["commit", "-m", "converge: auto-commit from " <> hostname]
|
||||||
|
|
||||||
-- | Pull from the configured remote and branch.
|
-- | Pull from the configured remote, rebasing onto the tracked upstream branch.
|
||||||
gitPull :: RepoConfig -> IO (ExitCode, Text, Text)
|
gitPull :: Logger -> RepoConfig -> IO (ExitCode, Text, Text)
|
||||||
gitPull repo =
|
gitPull logger repo =
|
||||||
runGitIn
|
loggedGit
|
||||||
|
logger
|
||||||
(rcPath repo)
|
(rcPath repo)
|
||||||
["pull", "--no-edit", T.unpack (rcRemote repo), T.unpack (rcBranch repo)]
|
["pull", "--rebase", T.unpack (rcRemote repo)]
|
||||||
|
|
||||||
|
-- | Push to the configured remote and branch.
|
||||||
|
gitPush :: Logger -> RepoConfig -> IO (ExitCode, Text, Text)
|
||||||
|
gitPush logger repo =
|
||||||
|
loggedGit
|
||||||
|
logger
|
||||||
|
(rcPath repo)
|
||||||
|
["push", T.unpack (rcRemote repo), T.unpack (rcBranch repo)]
|
||||||
|
|
||||||
|
-- | Run a git command and log the invocation and exit code.
|
||||||
|
loggedGit :: Logger -> FilePath -> [String] -> IO (ExitCode, Text, Text)
|
||||||
|
loggedGit logger repoPath args = do
|
||||||
|
logInfo logger ("RUN: git -C " <> T.pack repoPath <> " " <> T.intercalate " " (map T.pack args))
|
||||||
|
result@(code, _, err) <- runGitIn repoPath args
|
||||||
|
let msg = "EXIT " <> T.pack (show code)
|
||||||
|
details =
|
||||||
|
if code /= ExitSuccess && not (T.null err)
|
||||||
|
then ": " <> T.strip err
|
||||||
|
else ""
|
||||||
|
logInfo logger (msg <> details)
|
||||||
|
pure result
|
||||||
|
|
||||||
-- | Check if the repository currently has merge conflicts.
|
-- | Check if the repository currently has merge conflicts.
|
||||||
hasConflicts :: FilePath -> IO Bool
|
hasConflicts :: FilePath -> IO Bool
|
||||||
@@ -284,20 +365,59 @@ hasConflicts repoPath = do
|
|||||||
(_, diffOut, _) <- runGitIn repoPath ["diff", "--check"]
|
(_, diffOut, _) <- runGitIn repoPath ["diff", "--check"]
|
||||||
pure $ any (`T.isInfixOf` diffOut) ["<<<<<<<", "=======", ">>>>>>>"]
|
pure $ any (`T.isInfixOf` diffOut) ["<<<<<<<", "=======", ">>>>>>>"]
|
||||||
|
|
||||||
|
{- | Check whether a repository is in the middle of an operation that would
|
||||||
|
make it unsafe to commit or pull: merge, rebase, revert, cherry-pick,
|
||||||
|
or bisect.
|
||||||
|
|
||||||
|
Detects these by checking for well-known sentinel files and directories
|
||||||
|
inside the repository's git directory (discovered via @git rev-parse --git-dir@).
|
||||||
|
-}
|
||||||
|
isInMiddleOfOperation :: FilePath -> IO Bool
|
||||||
|
isInMiddleOfOperation repoPath = do
|
||||||
|
(code, gitDirOut, _) <- runGitIn repoPath ["rev-parse", "--git-dir"]
|
||||||
|
case code of
|
||||||
|
ExitSuccess -> do
|
||||||
|
let gitDir = T.strip gitDirOut
|
||||||
|
-- Use the relative git-dir path inside the repo
|
||||||
|
let fullGitDir = repoPath </> T.unpack gitDir
|
||||||
|
checkIndicatorFiles fullGitDir
|
||||||
|
_ ->
|
||||||
|
-- Not a git repo at all; treat as "no operation"
|
||||||
|
pure False
|
||||||
|
|
||||||
|
{- | Check for sentinel files/directories that indicate an in-progress operation.
|
||||||
|
|
||||||
|
Note: @REBASE_HEAD@ is intentionally excluded from the sentinel files.
|
||||||
|
Git does not remove it when a rebase completes, so it produces false
|
||||||
|
positives. The reliable rebase indicators are the @rebase-apply@ and
|
||||||
|
@rebase-merge@ directories, which are checked below.
|
||||||
|
-}
|
||||||
|
checkIndicatorFiles :: FilePath -> IO Bool
|
||||||
|
checkIndicatorFiles gitDir = do
|
||||||
|
let sentinelFiles =
|
||||||
|
[ "MERGE_HEAD"
|
||||||
|
, "REVERT_HEAD"
|
||||||
|
, "CHERRY_PICK_HEAD"
|
||||||
|
, "BISECT_LOG"
|
||||||
|
]
|
||||||
|
let sentinelDirs =
|
||||||
|
[ "rebase-apply"
|
||||||
|
, "rebase-merge"
|
||||||
|
, "sequencer"
|
||||||
|
]
|
||||||
|
fileHits <- mapM (\f -> doesFileExist (gitDir </> f)) sentinelFiles
|
||||||
|
dirHits <- mapM (\d -> doesDirectoryExist (gitDir </> d)) sentinelDirs
|
||||||
|
pure $ or fileHits || or dirHits
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
-- Notifications
|
-- Notifications
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
-- | Send a desktop notification about a merge conflict.
|
-- | Send a desktop notification.
|
||||||
notifyConflict :: Options -> RepoConfig -> IO ()
|
notifyUser :: Options -> String -> String -> IO ()
|
||||||
notifyConflict opts repo = do
|
notifyUser opts title body = do
|
||||||
let cmd = T.unpack (optNotifyCmd opts)
|
let cmd = T.unpack (optNotifyCmd opts)
|
||||||
title = "Converge: Merge Conflict"
|
_ <- spawnProcess cmd ["--urgency=critical", title, body]
|
||||||
body =
|
|
||||||
"A merge conflict occurred in "
|
|
||||||
<> T.pack (rcPath repo)
|
|
||||||
<> ". Manual resolution required."
|
|
||||||
_ <- spawnProcess cmd ["--urgency=critical", title, T.unpack body]
|
|
||||||
pure ()
|
pure ()
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|||||||
@@ -0,0 +1,93 @@
|
|||||||
|
module GitCommitSpec (spec) where
|
||||||
|
|
||||||
|
import Converge (Options (..), RepoConfig (..), defaultOptions, defaultRepoConfig, gitCommitAll, syncRepo)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import System.Exit (ExitCode (..))
|
||||||
|
import System.FilePath ((</>))
|
||||||
|
import Test.Hspec
|
||||||
|
import TestHelper
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "gitCommitAll" $ do
|
||||||
|
it "creates a commit after a file is changed" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
countBefore <- commitCount repo
|
||||||
|
countBefore `shouldBe` 1 -- initial commit from helper
|
||||||
|
writeFile (repo </> "hello.txt") "hello world"
|
||||||
|
(code, _, _) <- gitCommitAll logger repo
|
||||||
|
code `shouldBe` ExitSuccess
|
||||||
|
countAfter <- commitCount repo
|
||||||
|
countAfter `shouldBe` (countBefore + 1)
|
||||||
|
|
||||||
|
it "includes the changed file in the commit" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
writeFile (repo </> "data.txt") "some data"
|
||||||
|
(code, _, _) <- gitCommitAll logger repo
|
||||||
|
code `shouldBe` ExitSuccess
|
||||||
|
|
||||||
|
(_, logOut, _) <- runGitIn repo ["log", "-1", "--name-only", "--oneline"]
|
||||||
|
logOut `shouldSatisfy` ("data.txt" `T.isInfixOf`)
|
||||||
|
|
||||||
|
it "does not create a new commit when there are no changes" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
countBefore <- commitCount repo
|
||||||
|
(code, _, _) <- gitCommitAll logger repo
|
||||||
|
-- git commit exits non-zero when there is nothing to commit
|
||||||
|
code `shouldSatisfy` (/= ExitSuccess)
|
||||||
|
countAfter <- commitCount repo
|
||||||
|
countAfter `shouldBe` countBefore
|
||||||
|
|
||||||
|
it "creates only one commit when called multiple times with the same staged changes" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
writeFile (repo </> "single.txt") "single change"
|
||||||
|
(code1, _, _) <- gitCommitAll logger repo
|
||||||
|
code1 `shouldBe` ExitSuccess
|
||||||
|
-- Second call: nothing left to commit
|
||||||
|
countBefore2 <- commitCount repo
|
||||||
|
(code2, _, _) <- gitCommitAll logger repo
|
||||||
|
code2 `shouldSatisfy` (/= ExitSuccess)
|
||||||
|
countAfter2 <- commitCount repo
|
||||||
|
countAfter2 `shouldBe` countBefore2
|
||||||
|
|
||||||
|
it "aborts commit when staging fails (e.g. index.lock exists)" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
-- Create a lock file to make git add -A fail
|
||||||
|
writeFile (repo </> ".git" </> "index.lock") "locked"
|
||||||
|
writeFile (repo </> "new.txt") "new file"
|
||||||
|
countBefore <- commitCount repo
|
||||||
|
(code, _, err) <- gitCommitAll logger repo
|
||||||
|
-- Staging fails, so commit should not happen
|
||||||
|
code `shouldSatisfy` (/= ExitSuccess)
|
||||||
|
err `shouldSatisfy` ("index.lock" `T.isInfixOf`)
|
||||||
|
commitCount repo `shouldReturn` countBefore
|
||||||
|
|
||||||
|
describe "startup sync" $ do
|
||||||
|
it "commits and pushes uncommitted changes on startup" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepoWithRemote $ \repo -> do
|
||||||
|
-- Leave a file uncommitted (simulating state before converge starts)
|
||||||
|
writeFile (repo </> "uncommitted.txt") "pending change"
|
||||||
|
|
||||||
|
countBefore <- commitCount repo
|
||||||
|
countBefore `shouldBe` 1
|
||||||
|
|
||||||
|
let cfg = defaultRepoConfig{rcPath = repo}
|
||||||
|
let opts =
|
||||||
|
defaultOptions
|
||||||
|
{ optRepos = [cfg]
|
||||||
|
, optNotifyCmd = "true" -- avoid firing notify-send
|
||||||
|
}
|
||||||
|
syncRepo opts logger cfg
|
||||||
|
|
||||||
|
countAfter <- commitCount repo
|
||||||
|
countAfter `shouldBe` 2
|
||||||
|
|
||||||
|
-- Verify the commit was pushed to remote
|
||||||
|
(_, remoteLog, _) <- runGitIn repo ["log", "origin/main", "--oneline", "--name-only"]
|
||||||
|
remoteLog `shouldSatisfy` ("uncommitted.txt" `T.isInfixOf`)
|
||||||
@@ -0,0 +1,86 @@
|
|||||||
|
module GitPullSpec (spec) where
|
||||||
|
|
||||||
|
import Converge (RepoConfig (..), defaultRepoConfig, gitPull)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import System.Directory (createDirectory)
|
||||||
|
import System.Exit (ExitCode (..))
|
||||||
|
import System.FilePath ((</>))
|
||||||
|
import System.IO.Temp (withSystemTempDirectory)
|
||||||
|
import Test.Hspec
|
||||||
|
import TestHelper
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "gitPull" $ do
|
||||||
|
it "pulls changes from remote 'origin'" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withTempGitRepoWithRemote $ \local -> do
|
||||||
|
-- Make a second commit on local and push to remote
|
||||||
|
writeFile (local </> "upstream.txt") "pushed to remote"
|
||||||
|
_ <- runGitIn local ["add", "upstream.txt"]
|
||||||
|
_ <- runGitIn local ["commit", "-m", "second commit"]
|
||||||
|
_ <- runGitIn local ["push", "origin", "main"]
|
||||||
|
|
||||||
|
-- Rewind local to the initial commit (simulate being behind)
|
||||||
|
_ <- runGitIn local ["reset", "--hard", "HEAD~1"]
|
||||||
|
|
||||||
|
countBefore <- commitCount local
|
||||||
|
countBefore `shouldBe` 1
|
||||||
|
|
||||||
|
let cfg = defaultRepoConfig{rcPath = local}
|
||||||
|
(code, _, _) <- gitPull logger cfg
|
||||||
|
code `shouldBe` ExitSuccess
|
||||||
|
|
||||||
|
countAfter <- commitCount local
|
||||||
|
countAfter `shouldBe` 2
|
||||||
|
|
||||||
|
it "rebases local commits on top of pulled changes" $ do
|
||||||
|
logger <- testLogger
|
||||||
|
withSystemTempDirectory "converge-test-rebase" $ \tmp -> do
|
||||||
|
let remoteDir = tmp </> "remote.git"
|
||||||
|
let localDir = tmp </> "local"
|
||||||
|
|
||||||
|
-- Create directories before git init
|
||||||
|
createDirectory remoteDir
|
||||||
|
createDirectory localDir
|
||||||
|
|
||||||
|
-- Create bare remote
|
||||||
|
_ <- runGitIn remoteDir ["init", "--bare", "-b", "main"]
|
||||||
|
|
||||||
|
-- Create local repo, push initial commit
|
||||||
|
_ <- runGitIn localDir ["init", "-b", "main"]
|
||||||
|
_ <- runGitIn localDir ["config", "user.name", "test"]
|
||||||
|
_ <- runGitIn localDir ["config", "user.email", "test@test"]
|
||||||
|
_ <- runGitIn localDir ["remote", "add", "origin", remoteDir]
|
||||||
|
writeFile (localDir </> "initial.txt") "initial"
|
||||||
|
_ <- runGitIn localDir ["add", "initial.txt"]
|
||||||
|
_ <- runGitIn localDir ["commit", "-m", "initial commit"]
|
||||||
|
_ <- runGitIn localDir ["push", "-u", "origin", "main"]
|
||||||
|
|
||||||
|
-- Make a local-only commit (divergent from remote)
|
||||||
|
writeFile (localDir </> "local.txt") "local-only change"
|
||||||
|
_ <- runGitIn localDir ["add", "local.txt"]
|
||||||
|
_ <- runGitIn localDir ["commit", "-m", "local commit"]
|
||||||
|
|
||||||
|
-- Push a *different* commit to remote (from another clone)
|
||||||
|
let otherDir = tmp </> "other"
|
||||||
|
_ <- rawGit ["clone", remoteDir, otherDir]
|
||||||
|
_ <- runGitIn otherDir ["config", "user.name", "test"]
|
||||||
|
_ <- runGitIn otherDir ["config", "user.email", "test@test"]
|
||||||
|
writeFile (otherDir </> "remote.txt") "remote-only change"
|
||||||
|
_ <- runGitIn otherDir ["add", "remote.txt"]
|
||||||
|
_ <- runGitIn otherDir ["commit", "-m", "remote commit"]
|
||||||
|
_ <- runGitIn otherDir ["push", "origin", "main"]
|
||||||
|
|
||||||
|
-- Pull with --rebase: local commits are rebased on top
|
||||||
|
-- of the fetched remote commit, yielding a linear history.
|
||||||
|
let cfg = defaultRepoConfig{rcPath = localDir}
|
||||||
|
(code, _, _) <- gitPull logger cfg
|
||||||
|
code `shouldBe` ExitSuccess
|
||||||
|
-- Rebase produces linear history: 3 commits, no merge commit
|
||||||
|
c <- commitCount localDir
|
||||||
|
c `shouldBe` 3
|
||||||
|
-- Verify no merge commits exist (each commit has exactly 1 parent)
|
||||||
|
(_, logOut, _) <- runGitIn localDir ["log", "--format=%P", "--all"]
|
||||||
|
let parentCounts = map (length . words) (lines (T.unpack logOut))
|
||||||
|
parentCounts `shouldSatisfy` all (<= 1)
|
||||||
@@ -0,0 +1,68 @@
|
|||||||
|
module GitSafetySpec (spec) where
|
||||||
|
|
||||||
|
import Converge (checkIndicatorFiles, isInMiddleOfOperation)
|
||||||
|
import Test.Hspec
|
||||||
|
import TestHelper
|
||||||
|
|
||||||
|
spec :: Spec
|
||||||
|
spec = do
|
||||||
|
describe "isInMiddleOfOperation" $ do
|
||||||
|
it "returns False when no operation is in progress" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` False
|
||||||
|
|
||||||
|
describe "merge detection" $ do
|
||||||
|
it "returns True when MERGE_HEAD exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createMergeHead repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "revert detection" $ do
|
||||||
|
it "returns True when REVERT_HEAD exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createRevertHead repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "cherry-pick detection" $ do
|
||||||
|
it "returns True when CHERRY_PICK_HEAD exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createCherryPickHead repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "bisect detection" $ do
|
||||||
|
it "returns True when BISECT_LOG exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createBisectLog repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "rebase detection" $ do
|
||||||
|
it "returns True when rebase-apply directory exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createRebaseApply repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
it "returns True when rebase-merge directory exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createRebaseMerge repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "sequencer detection" $ do
|
||||||
|
it "returns True when sequencer directory exists" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
createSequencer repo
|
||||||
|
result <- isInMiddleOfOperation repo
|
||||||
|
result `shouldBe` True
|
||||||
|
|
||||||
|
describe "checkIndicatorFiles" $ do
|
||||||
|
it "returns False for a clean git directory" $ do
|
||||||
|
withTempGitRepo $ \repo -> do
|
||||||
|
dir <- gitDir repo
|
||||||
|
result <- checkIndicatorFiles dir
|
||||||
|
result `shouldBe` False
|
||||||
+6
-3
@@ -1,9 +1,12 @@
|
|||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
|
import qualified GitCommitSpec
|
||||||
|
import qualified GitPullSpec
|
||||||
|
import qualified GitSafetySpec
|
||||||
import Test.Hspec
|
import Test.Hspec
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = hspec $ do
|
main = hspec $ do
|
||||||
describe "Converge" $ do
|
GitCommitSpec.spec
|
||||||
it "compiles" $ do
|
GitPullSpec.spec
|
||||||
True `shouldBe` True
|
GitSafetySpec.spec
|
||||||
|
|||||||
@@ -0,0 +1,137 @@
|
|||||||
|
module TestHelper (
|
||||||
|
withTempGitRepo,
|
||||||
|
withTempGitRepoWithRemote,
|
||||||
|
rawGit,
|
||||||
|
runGitIn,
|
||||||
|
testLogger,
|
||||||
|
commitCount,
|
||||||
|
gitDir,
|
||||||
|
createMergeHead,
|
||||||
|
createRevertHead,
|
||||||
|
createCherryPickHead,
|
||||||
|
createBisectLog,
|
||||||
|
createRebaseApply,
|
||||||
|
createRebaseMerge,
|
||||||
|
createSequencer,
|
||||||
|
) where
|
||||||
|
|
||||||
|
import Control.Concurrent.MVar (newMVar)
|
||||||
|
import Converge (Logger (..))
|
||||||
|
import Data.Text (Text)
|
||||||
|
import qualified Data.Text as T
|
||||||
|
import System.Directory (createDirectory)
|
||||||
|
import System.Exit (ExitCode)
|
||||||
|
import System.FilePath ((</>))
|
||||||
|
import System.IO.Temp (withSystemTempDirectory)
|
||||||
|
import System.Process (readProcessWithExitCode)
|
||||||
|
|
||||||
|
-- | Run a git command in the given repository directory.
|
||||||
|
runGitIn :: FilePath -> [String] -> IO (ExitCode, Text, Text)
|
||||||
|
runGitIn repoPath args = do
|
||||||
|
(code, out, err) <- readProcessWithExitCode "git" ("-C" : repoPath : args) ""
|
||||||
|
pure (code, T.pack out, T.pack err)
|
||||||
|
|
||||||
|
-- | Run a git command directly (no -C prefix) -- useful for git clone, etc.
|
||||||
|
rawGit :: [String] -> IO (ExitCode, Text, Text)
|
||||||
|
rawGit args = do
|
||||||
|
(code, out, err) <- readProcessWithExitCode "git" args ""
|
||||||
|
pure (code, T.pack out, T.pack err)
|
||||||
|
|
||||||
|
-- | Create a test logger (serialized writes to stderr).
|
||||||
|
testLogger :: IO Logger
|
||||||
|
testLogger = Logger <$> newMVar ()
|
||||||
|
|
||||||
|
{- | Create a temporary git repository, configure a user, make an initial
|
||||||
|
commit on branch "main", run the action with the repo path, then clean up.
|
||||||
|
-}
|
||||||
|
withTempGitRepo :: (FilePath -> IO a) -> IO a
|
||||||
|
withTempGitRepo action = withSystemTempDirectory "converge-test" $ \tmp -> do
|
||||||
|
let repo = tmp </> "repo"
|
||||||
|
createDirectory repo
|
||||||
|
_ <- runGitIn repo ["init", "-b", "main"]
|
||||||
|
_ <- runGitIn repo ["config", "user.name", "converge-test"]
|
||||||
|
_ <- runGitIn repo ["config", "user.email", "test@converge.local"]
|
||||||
|
-- Create an initial commit so the repo has a HEAD and git log works.
|
||||||
|
writeFile (repo </> "initial.txt") "initial"
|
||||||
|
_ <- runGitIn repo ["add", "initial.txt"]
|
||||||
|
_ <- runGitIn repo ["commit", "-m", "initial commit"]
|
||||||
|
action repo
|
||||||
|
|
||||||
|
{- | Create a temporary git repo with a bare remote, run the action with the
|
||||||
|
local repo path, then clean up. The local repo is pushed to the remote
|
||||||
|
so origin/main is reachable via fetch/pull.
|
||||||
|
-}
|
||||||
|
withTempGitRepoWithRemote :: (FilePath -> IO a) -> IO a
|
||||||
|
withTempGitRepoWithRemote action = withSystemTempDirectory "converge-test-remote" $ \tmp -> do
|
||||||
|
let remoteDir = tmp </> "remote.git"
|
||||||
|
let localDir = tmp </> "local"
|
||||||
|
-- Create bare remote
|
||||||
|
createDirectory remoteDir
|
||||||
|
_ <- runGitIn remoteDir ["init", "--bare", "-b", "main"]
|
||||||
|
-- Create local repo pointing at the remote
|
||||||
|
createDirectory localDir
|
||||||
|
_ <- runGitIn localDir ["init", "-b", "main"]
|
||||||
|
_ <- runGitIn localDir ["config", "user.name", "converge-test"]
|
||||||
|
_ <- runGitIn localDir ["config", "user.email", "test@converge.local"]
|
||||||
|
_ <- runGitIn localDir ["remote", "add", "origin", remoteDir]
|
||||||
|
-- Initial commit + push so origin/main is established
|
||||||
|
writeFile (localDir </> "initial.txt") "initial"
|
||||||
|
_ <- runGitIn localDir ["add", "initial.txt"]
|
||||||
|
_ <- runGitIn localDir ["commit", "-m", "initial commit"]
|
||||||
|
_ <- runGitIn localDir ["push", "-u", "origin", "main"]
|
||||||
|
action localDir
|
||||||
|
|
||||||
|
-- | Count commits reachable from HEAD.
|
||||||
|
commitCount :: FilePath -> IO Int
|
||||||
|
commitCount repo = do
|
||||||
|
(_, out, _) <- runGitIn repo ["rev-list", "--count", "HEAD"]
|
||||||
|
let stripped = T.unpack (T.strip out)
|
||||||
|
case reads stripped of
|
||||||
|
[(n, "")] -> pure n
|
||||||
|
_ -> pure 0
|
||||||
|
|
||||||
|
-- | Get the .git directory path inside the repository.
|
||||||
|
gitDir :: FilePath -> IO FilePath
|
||||||
|
gitDir repo = do
|
||||||
|
(_, out, _) <- runGitIn repo ["rev-parse", "--git-dir"]
|
||||||
|
pure (repo </> T.unpack (T.strip out))
|
||||||
|
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
-- Sentinel helpers: create well-known git files/directories inside
|
||||||
|
-- .git that indicate an in-progress operation.
|
||||||
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
|
createMergeHead :: FilePath -> IO ()
|
||||||
|
createMergeHead repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
writeFile (dir </> "MERGE_HEAD") ""
|
||||||
|
|
||||||
|
createRevertHead :: FilePath -> IO ()
|
||||||
|
createRevertHead repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
writeFile (dir </> "REVERT_HEAD") ""
|
||||||
|
|
||||||
|
createCherryPickHead :: FilePath -> IO ()
|
||||||
|
createCherryPickHead repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
writeFile (dir </> "CHERRY_PICK_HEAD") ""
|
||||||
|
|
||||||
|
createBisectLog :: FilePath -> IO ()
|
||||||
|
createBisectLog repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
writeFile (dir </> "BISECT_LOG") ""
|
||||||
|
|
||||||
|
createRebaseApply :: FilePath -> IO ()
|
||||||
|
createRebaseApply repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
createDirectory (dir </> "rebase-apply")
|
||||||
|
|
||||||
|
createRebaseMerge :: FilePath -> IO ()
|
||||||
|
createRebaseMerge repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
createDirectory (dir </> "rebase-merge")
|
||||||
|
|
||||||
|
createSequencer :: FilePath -> IO ()
|
||||||
|
createSequencer repo = do
|
||||||
|
dir <- gitDir repo
|
||||||
|
createDirectory (dir </> "sequencer")
|
||||||
Reference in New Issue
Block a user