From 34c823242780e1a75dc4832b220409d0c2aa6b0a Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Wed, 13 May 2026 21:00:09 -0400 Subject: [PATCH] Avoids running commands during external git operations --- src/Converge.hs | 153 ++++++++++++++++++++++++++++++++++-------------- 1 file changed, 110 insertions(+), 43 deletions(-) diff --git a/src/Converge.hs b/src/Converge.hs index 16aa454..e58e3ca 100644 --- a/src/Converge.hs +++ b/src/Converge.hs @@ -19,9 +19,13 @@ module Converge ( gitCommitAll, gitPull, hasConflicts, + isInMiddleOfOperation, -- * Notifications notifyConflict, + + -- * File filtering + isGitIgnored, ) where @@ -29,14 +33,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, ()) @@ -185,8 +189,10 @@ watchRepo opts logger repo = do 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 +221,65 @@ 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 -> + 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" ---------------------------------------------------------------------- -- Git operations @@ -284,6 +307,50 @@ 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 ----------------------------------------------------------------------