Avoids running commands during external git operations

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
+                ignored <- isGitIgnored (rcPath repo) (eventPath event)
-                void $ tryPutMVar pending ()
+                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
+    -- Guard: bail out if an operation (merge, rebase, revert, etc.) is in progress
-    (_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
+    inProgress <- isInMiddleOfOperation (rcPath repo)
-    let changed = filter (not . T.null) (T.lines statusOut)
+    when inProgress $ do
-    if null changed
+        logRepo logger repo "*** SKIPPING: an operation (merge/rebase/revert/cherry-pick/bisect) is in progress ***"
-        then logRepo logger repo "no changes to commit"
+    unless inProgress $ do
-        else do
+        -- Check what's changed
-            let count = length changed
+        (_, statusOut, _) <- runGitIn (rcPath repo) ["status", "--porcelain"]
-            let preview = T.unlines (take 15 changed)
+        let changed = filter (not . T.null) (T.lines statusOut)
-            logRepo logger repo ("staging " <> T.pack (show count) <> " file(s):\n" <> preview)
+        if null changed
-            (commitCode, commitOut, commitErr) <- gitCommitAll logger (rcPath repo)
+            then logRepo logger repo "no changes to commit"
-            case commitCode of
+            else do
-                ExitSuccess -> do
+                let count = length changed
-                    (_, hashOut, _) <- runGitIn (rcPath repo) ["log", "-1", "--format=%h %s"]
+                let preview = T.unlines (take 15 changed)
-                    logRepo logger repo ("committed " <> T.strip hashOut)
+                logRepo logger repo ("staging " <> T.pack (show count) <> " file(s):\n" <> preview)
-                _
+                (commitCode, commitOut, commitErr) <- gitCommitAll logger (rcPath repo)
-                    | "nothing to commit" `T.isInfixOf` commitOut
+                case commitCode of
-                        || "nothing to commit" `T.isInfixOf` commitErr ->
+                    ExitSuccess -> do
-                        logRepo logger repo "nothing to commit (working tree clean)"
+                        (_, hashOut, _) <- runGitIn (rcPath repo) ["log", "-1", "--format=%h %s"]
-                    | otherwise ->
+                        logRepo logger repo ("committed " <> T.strip hashOut)
-                        logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
+                    _
-    -- Pull
+                        | "nothing to commit" `T.isInfixOf` commitOut
-    logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
+                            || "nothing to commit" `T.isInfixOf` commitErr ->
-    (pullCode, pullOut, pullErr) <- gitPull repo
+                            logRepo logger repo "nothing to commit (working tree clean)"
-    case pullCode of
+                        | otherwise ->
-        ExitSuccess -> do
+                            logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
-            let trimmed = T.strip pullOut
+        -- Pull
-            if T.null trimmed
+        logRepo logger repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo)
-                then logRepo logger repo "pull: already up to date"
+        (pullCode, pullOut, pullErr) <- gitPull repo
-                else logRepo logger repo ("pull succeeded:\n" <> trimmed)
+        case pullCode of
-        _ ->
+            ExitSuccess -> do
-            logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
+                let trimmed = T.strip pullOut
-    -- Conflict check
+                if T.null trimmed
-    conflicted <- hasConflicts (rcPath repo)
+                    then logRepo logger repo "pull: already up to date"
-    if conflicted
+                    else logRepo logger repo ("pull succeeded:\n" <> trimmed)
-        then do
+            _ ->
-            logRepo logger repo "*** MERGE CONFLICT detected! ***"
+                logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
-            notifyConflict opts repo
+        -- Conflict check
-        else logRepo logger repo "sync complete, no conflicts"
+        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
 ----------------------------------------------------------------------