jbrechtel
25b8f24906
- gitCommitAll: abort commit when staging (git add -A) fails, e.g. due to a stale .git/index.lock. Previously the failure was ignored and commit proceeded on an empty or partial index. - gitPull: remove explicit branch argument from git pull --rebase. Passing both remote and branch can conflict with the branch's configured tracking ref, causing 'Cannot rebase onto multiple branches'. Now uses just --rebase <remote>, letting git resolve the tracking branch from config. - Test: index.lock scenario verifies commit is aborted on staging failure.
427 lines
16 KiB
Haskell
427 lines
16 KiB
Haskell
module Converge (
|
|
-- * Core types
|
|
Options (..),
|
|
RepoConfig (..),
|
|
defaultOptions,
|
|
defaultRepoConfig,
|
|
|
|
-- * Config file
|
|
Config (..),
|
|
loadConfig,
|
|
configToOptions,
|
|
defaultConfigPath,
|
|
configFileExists,
|
|
|
|
-- * Running
|
|
runConverge,
|
|
syncRepo,
|
|
|
|
-- * Logger
|
|
Logger (..),
|
|
newLogger,
|
|
|
|
-- * Git operations
|
|
gitCommitAll,
|
|
gitPull,
|
|
gitPush,
|
|
runGitIn,
|
|
hasConflicts,
|
|
isInMiddleOfOperation,
|
|
checkIndicatorFiles,
|
|
|
|
-- * Notifications
|
|
notifyUser,
|
|
|
|
-- * File filtering
|
|
isGitIgnored,
|
|
)
|
|
where
|
|
|
|
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, 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), doesDirectoryExist, doesFileExist, getCurrentDirectory, getXdgDirectory)
|
|
import System.Exit (ExitCode (..))
|
|
import System.FSNotify
|
|
import System.FilePath (isAbsolute, splitDirectories, (</>))
|
|
import System.IO (hPutStrLn, stderr)
|
|
import System.Process (readProcess, readProcessWithExitCode, spawnProcess)
|
|
|
|
-- | Configuration for a single repository to watch.
|
|
data RepoConfig = RepoConfig
|
|
{ rcPath :: !FilePath
|
|
-- ^ Path to the git repository.
|
|
, rcRemote :: !Text
|
|
-- ^ Remote name to pull from.
|
|
, rcBranch :: !Text
|
|
-- ^ Branch to pull.
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
-- | Top-level options for converge.
|
|
data Options = Options
|
|
{ optRepos :: ![RepoConfig]
|
|
-- ^ Repositories to watch.
|
|
, optDebounceMs :: !Int
|
|
-- ^ Debounce window in milliseconds.
|
|
, optNotifyCmd :: !Text
|
|
-- ^ Command used for desktop notifications.
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
-- | Sensible defaults for a single repo (cwd, origin, main).
|
|
defaultRepoConfig :: RepoConfig
|
|
defaultRepoConfig =
|
|
RepoConfig
|
|
{ rcPath = "."
|
|
, rcRemote = "origin"
|
|
, rcBranch = "main"
|
|
}
|
|
|
|
-- | Sensible defaults for options.
|
|
defaultOptions :: Options
|
|
defaultOptions =
|
|
Options
|
|
{ optRepos = [defaultRepoConfig]
|
|
, optDebounceMs = 5000
|
|
, optNotifyCmd = "notify-send"
|
|
}
|
|
|
|
{- | Logger that serializes output to stderr so concurrent repo watchers
|
|
don't interleave their log lines.
|
|
-}
|
|
newtype Logger = Logger (MVar ())
|
|
|
|
-- | Create a new thread-safe logger.
|
|
newLogger :: IO Logger
|
|
newLogger = Logger <$> newMVar ()
|
|
|
|
----------------------------------------------------------------------
|
|
-- Config file (YAML)
|
|
----------------------------------------------------------------------
|
|
|
|
-- | Shape of the optional YAML config file.
|
|
data Config = Config
|
|
{ cfgRepos :: ![RepoConfig]
|
|
, cfgDebounceMs :: !(Maybe Int)
|
|
}
|
|
deriving (Show, Eq)
|
|
|
|
instance FromJSON Config where
|
|
parseJSON = withObject "Config" $ \o ->
|
|
Config
|
|
<$> o .: "repos"
|
|
<*> o .:? "debounce_ms"
|
|
|
|
instance FromJSON RepoConfig where
|
|
parseJSON = withObject "RepoConfig" $ \o ->
|
|
RepoConfig
|
|
<$> o .: "path"
|
|
<*> (fromMaybe "origin" <$> o .:? "remote")
|
|
<*> (fromMaybe "main" <$> o .:? "branch")
|
|
|
|
-- | Load a YAML config file.
|
|
loadConfig :: FilePath -> IO Config
|
|
loadConfig = decodeFileThrow
|
|
|
|
-- | Convert a Config to Options (filling in defaults).
|
|
configToOptions :: Config -> Options
|
|
configToOptions cfg =
|
|
defaultOptions
|
|
{ optRepos = cfgRepos cfg
|
|
, optDebounceMs = fromMaybe 5000 (cfgDebounceMs cfg)
|
|
}
|
|
|
|
-- | The default XDG config file path: @$XDG_CONFIG_HOME/converge/config.yaml@.
|
|
defaultConfigPath :: IO FilePath
|
|
defaultConfigPath = (</> "converge/config.yaml") <$> getXdgDirectory XdgConfig ""
|
|
|
|
-- | Check whether the default config file exists.
|
|
configFileExists :: IO Bool
|
|
configFileExists = defaultConfigPath >>= doesFileExist
|
|
|
|
----------------------------------------------------------------------
|
|
-- Logging
|
|
----------------------------------------------------------------------
|
|
|
|
-- | Log a timestamped message to stderr.
|
|
logInfo :: Logger -> Text -> IO ()
|
|
logInfo (Logger lock) msg = withMVar lock $ \() -> do
|
|
now <- getCurrentTime
|
|
let ts = T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now
|
|
hPutStrLn stderr $ "[" <> T.unpack ts <> "] " <> T.unpack msg
|
|
|
|
-- | Log a message tagged with a repo path.
|
|
logRepo :: Logger -> RepoConfig -> Text -> IO ()
|
|
logRepo logger repo msg = logInfo logger ("[" <> T.pack (rcPath repo) <> "] " <> msg)
|
|
|
|
----------------------------------------------------------------------
|
|
-- Running
|
|
----------------------------------------------------------------------
|
|
|
|
-- | Watch all configured repositories concurrently.
|
|
runConverge :: Options -> IO ()
|
|
runConverge opts = do
|
|
logger <- newLogger
|
|
mapConcurrently_ (watchRepo opts logger) (optRepos opts)
|
|
|
|
{- | Watch a single repository for changes.
|
|
|
|
Uses an 'MVar' to coalesce rapid events: the first event triggers a
|
|
debounce timer; subsequent events during the debounce window are
|
|
accumulated and drained, so only one sync runs per quiet period.
|
|
-}
|
|
watchRepo :: Options -> Logger -> RepoConfig -> IO ()
|
|
watchRepo opts logger repo = do
|
|
absPath <- resolvePath (rcPath repo)
|
|
let debounceUs = optDebounceMs opts * 1000
|
|
logRepo logger repo ("watching " <> T.pack absPath <> " (debounce: " <> T.pack (show (optDebounceMs opts)) <> "ms)")
|
|
pending <- newEmptyMVar
|
|
-- Background sync loop: waits for an event signal, debounces, then syncs
|
|
_ <- forkIO $ forever $ do
|
|
takeMVar pending
|
|
threadDelay debounceUs
|
|
-- 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
|
|
ignored <- isGitIgnored (rcPath repo) (eventPath event)
|
|
unless ignored $ do
|
|
logEvent logger repo event
|
|
void $ tryPutMVar pending ()
|
|
forever $ threadDelay maxBound
|
|
where
|
|
resolvePath p
|
|
| isAbsolute p = pure p
|
|
| otherwise = (</> p) <$> getCurrentDirectory
|
|
|
|
-- | Log a filesystem event.
|
|
logEvent :: Logger -> RepoConfig -> Event -> IO ()
|
|
logEvent logger repo event =
|
|
logRepo logger repo $
|
|
T.pack (eventPath event)
|
|
<> " "
|
|
<> eventLabel event
|
|
|
|
eventLabel :: Event -> Text
|
|
eventLabel event = case event of
|
|
Added{} -> "added"
|
|
Modified{} -> "modified"
|
|
ModifiedAttributes{} -> "modified (attrs)"
|
|
Removed{} -> "removed"
|
|
WatchedDirectoryRemoved{} -> "dir removed"
|
|
CloseWrite{} -> "write closed"
|
|
Unknown{} -> "unknown"
|
|
|
|
-- | Check whether a file path lies inside a @.git@ directory.
|
|
isGitPath :: FilePath -> Bool
|
|
isGitPath = elem ".git" . splitDirectories
|
|
|
|
{- | 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"
|
|
-- 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
|
|
----------------------------------------------------------------------
|
|
|
|
-- | Stage all changes and commit with an auto-generated message.
|
|
gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text)
|
|
gitCommitAll logger repoPath = do
|
|
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, rebasing onto the tracked upstream branch.
|
|
gitPull :: Logger -> RepoConfig -> IO (ExitCode, Text, Text)
|
|
gitPull logger repo =
|
|
loggedGit logger (rcPath 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
|
|
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.
|
|
notifyUser :: Options -> String -> String -> IO ()
|
|
notifyUser opts title body = do
|
|
let cmd = T.unpack (optNotifyCmd opts)
|
|
_ <- spawnProcess cmd ["--urgency=critical", title, body]
|
|
pure ()
|
|
|
|
----------------------------------------------------------------------
|
|
-- Internal helpers
|
|
----------------------------------------------------------------------
|
|
|
|
-- | 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)
|