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:
|
||||
- converge
|
||||
- hspec
|
||||
- temporary
|
||||
|
||||
+183
-63
@@ -14,14 +14,26 @@ module Converge (
|
||||
|
||||
-- * Running
|
||||
runConverge,
|
||||
syncRepo,
|
||||
|
||||
-- * Logger
|
||||
Logger (..),
|
||||
newLogger,
|
||||
|
||||
-- * Git operations
|
||||
gitCommitAll,
|
||||
gitPull,
|
||||
gitPush,
|
||||
runGitIn,
|
||||
hasConflicts,
|
||||
isInMiddleOfOperation,
|
||||
checkIndicatorFiles,
|
||||
|
||||
-- * Notifications
|
||||
notifyConflict,
|
||||
notifyUser,
|
||||
|
||||
-- * File filtering
|
||||
isGitIgnored,
|
||||
)
|
||||
where
|
||||
|
||||
@@ -29,14 +41,14 @@ import Control.Concurrent (forkIO, threadDelay)
|
||||
import Control.Concurrent.Async (mapConcurrently_)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar, tryPutMVar, tryTakeMVar, withMVar)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad (forever, unless, void)
|
||||
import Control.Monad (forever, unless, void, when)
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as T
|
||||
import Data.Time.Clock (getCurrentTime)
|
||||
import Data.Time.Format (defaultTimeLocale, formatTime)
|
||||
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.FSNotify
|
||||
import System.FilePath (isAbsolute, splitDirectories, (</>))
|
||||
@@ -180,13 +192,17 @@ watchRepo opts logger repo = do
|
||||
-- Drain any events that arrived during the debounce window
|
||||
void $ tryTakeMVar pending
|
||||
syncRepo opts logger repo
|
||||
-- Sync any uncommitted changes that exist on startup
|
||||
syncRepo opts logger repo
|
||||
bracket
|
||||
(startManagerConf defaultConfig)
|
||||
stopManager
|
||||
$ \mgr -> do
|
||||
_ <- watchTree mgr absPath (\e -> not (isGitPath (eventPath e))) $ \event -> do
|
||||
logEvent logger repo event
|
||||
void $ tryPutMVar pending ()
|
||||
ignored <- isGitIgnored (rcPath repo) (eventPath event)
|
||||
unless ignored $ do
|
||||
logEvent logger repo event
|
||||
void $ tryPutMVar pending ()
|
||||
forever $ threadDelay maxBound
|
||||
where
|
||||
resolvePath p
|
||||
@@ -215,48 +231,88 @@ eventLabel event = case event of
|
||||
isGitPath :: FilePath -> Bool
|
||||
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 opts logger repo = do
|
||||
logRepo logger repo "sync cycle starting"
|
||||
-- Check what's changed
|
||||
(_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
|
||||
let changed = filter (not . T.null) (T.lines statusOut)
|
||||
if null changed
|
||||
then logRepo logger repo "no changes to commit"
|
||||
else do
|
||||
let count = length changed
|
||||
let preview = T.unlines (take 15 changed)
|
||||
logRepo logger repo ("staging " <> T.pack (show count) <> " file(s):\n" <> preview)
|
||||
(commitCode, commitOut, commitErr) <- gitCommitAll logger (rcPath repo)
|
||||
case commitCode of
|
||||
ExitSuccess -> do
|
||||
(_, hashOut, _) <- runGitIn (rcPath repo) ["log", "-1", "--format=%h %s"]
|
||||
logRepo logger repo ("committed " <> T.strip hashOut)
|
||||
_
|
||||
| "nothing to commit" `T.isInfixOf` commitOut
|
||||
|| "nothing to commit" `T.isInfixOf` commitErr ->
|
||||
logRepo logger repo "nothing to commit (working tree clean)"
|
||||
| otherwise ->
|
||||
logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
|
||||
-- Pull
|
||||
logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
|
||||
(pullCode, pullOut, pullErr) <- gitPull repo
|
||||
case pullCode of
|
||||
ExitSuccess -> do
|
||||
let trimmed = T.strip pullOut
|
||||
if T.null trimmed
|
||||
then logRepo logger repo "pull: already up to date"
|
||||
else logRepo logger repo ("pull succeeded:\n" <> trimmed)
|
||||
_ ->
|
||||
logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
|
||||
-- Conflict check
|
||||
conflicted <- hasConflicts (rcPath repo)
|
||||
if conflicted
|
||||
then do
|
||||
logRepo logger repo "*** MERGE CONFLICT detected! ***"
|
||||
notifyConflict opts repo
|
||||
else logRepo logger repo "sync complete, no conflicts"
|
||||
-- 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
|
||||
(_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
|
||||
let changed = filter (not . T.null) (T.lines statusOut)
|
||||
if null changed
|
||||
then logRepo logger repo "no changes to commit"
|
||||
else do
|
||||
let count = length changed
|
||||
let preview = T.unlines (take 15 changed)
|
||||
logRepo logger repo ("staging " <> T.pack (show count) <> " file(s):\n" <> preview)
|
||||
(commitCode, commitOut, commitErr) <- gitCommitAll logger (rcPath repo)
|
||||
case commitCode of
|
||||
ExitSuccess -> do
|
||||
(_, hashOut, _) <- runGitIn (rcPath repo) ["log", "-1", "--format=%h %s"]
|
||||
logRepo logger repo ("committed " <> T.strip hashOut)
|
||||
_
|
||||
| "nothing to commit" `T.isInfixOf` commitOut
|
||||
|| "nothing to commit" `T.isInfixOf` commitErr ->
|
||||
logRepo logger repo "nothing to commit (working tree clean)"
|
||||
| otherwise -> do
|
||||
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
|
||||
logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
|
||||
(pullCode, pullOut, pullErr) <- gitPull logger repo
|
||||
case pullCode of
|
||||
ExitSuccess -> do
|
||||
let trimmed = T.strip pullOut
|
||||
if T.null trimmed
|
||||
then logRepo logger repo "pull: already up to date"
|
||||
else logRepo logger repo ("pull succeeded:\n" <> trimmed)
|
||||
_ -> do
|
||||
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
|
||||
conflicted <- hasConflicts (rcPath repo)
|
||||
if conflicted
|
||||
then do
|
||||
logRepo logger repo "*** MERGE CONFLICT detected! ***"
|
||||
notifyUser
|
||||
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
|
||||
@@ -265,18 +321,43 @@ syncRepo opts logger repo = do
|
||||
-- | Stage all changes and commit with an auto-generated message.
|
||||
gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text)
|
||||
gitCommitAll logger repoPath = do
|
||||
(_, _, stageErr) <- runGitIn repoPath ["add", "-A"]
|
||||
unless (T.null stageErr) $
|
||||
logInfo logger ("git add stderr: " <> stageErr)
|
||||
hostname <- init <$> readProcess "hostname" [] ""
|
||||
runGitIn repoPath ["commit", "-m", "converge: auto-commit from " <> hostname]
|
||||
addResult@(addCode, _, addErr) <- loggedGit logger repoPath ["add", "-A"]
|
||||
unless (T.null addErr) $
|
||||
logInfo logger ("git add stderr: " <> addErr)
|
||||
if addCode /= ExitSuccess
|
||||
then pure addResult
|
||||
else do
|
||||
hostname <- init <$> readProcess "hostname" [] ""
|
||||
loggedGit logger repoPath ["commit", "-m", "converge: auto-commit from " <> hostname]
|
||||
|
||||
-- | Pull from the configured remote and branch.
|
||||
gitPull :: RepoConfig -> IO (ExitCode, Text, Text)
|
||||
gitPull repo =
|
||||
runGitIn
|
||||
-- | Pull from the configured remote, rebasing onto the tracked upstream branch.
|
||||
gitPull :: Logger -> RepoConfig -> IO (ExitCode, Text, Text)
|
||||
gitPull logger repo =
|
||||
loggedGit
|
||||
logger
|
||||
(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.
|
||||
hasConflicts :: FilePath -> IO Bool
|
||||
@@ -284,20 +365,59 @@ hasConflicts repoPath = do
|
||||
(_, diffOut, _) <- runGitIn repoPath ["diff", "--check"]
|
||||
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
|
||||
----------------------------------------------------------------------
|
||||
|
||||
-- | Send a desktop notification about a merge conflict.
|
||||
notifyConflict :: Options -> RepoConfig -> IO ()
|
||||
notifyConflict opts repo = do
|
||||
-- | Send a desktop notification.
|
||||
notifyUser :: Options -> String -> String -> IO ()
|
||||
notifyUser opts title body = do
|
||||
let cmd = T.unpack (optNotifyCmd opts)
|
||||
title = "Converge: Merge Conflict"
|
||||
body =
|
||||
"A merge conflict occurred in "
|
||||
<> T.pack (rcPath repo)
|
||||
<> ". Manual resolution required."
|
||||
_ <- spawnProcess cmd ["--urgency=critical", title, T.unpack body]
|
||||
_ <- spawnProcess cmd ["--urgency=critical", title, body]
|
||||
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
|
||||
|
||||
import qualified GitCommitSpec
|
||||
import qualified GitPullSpec
|
||||
import qualified GitSafetySpec
|
||||
import Test.Hspec
|
||||
|
||||
main :: IO ()
|
||||
main = hspec $ do
|
||||
describe "Converge" $ do
|
||||
it "compiles" $ do
|
||||
True `shouldBe` True
|
||||
GitCommitSpec.spec
|
||||
GitPullSpec.spec
|
||||
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