Avoids running commands during external git operations

This commit is contained in:
2026-05-13 21:00:09 -04:00
parent a151cf26c4
commit 34c8232427
+70 -3
View File
@@ -19,9 +19,13 @@ module Converge (
gitCommitAll, gitCommitAll,
gitPull, gitPull,
hasConflicts, hasConflicts,
isInMiddleOfOperation,
-- * Notifications -- * Notifications
notifyConflict, notifyConflict,
-- * File filtering
isGitIgnored,
) )
where where
@@ -29,14 +33,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, (</>))
@@ -185,6 +189,8 @@ watchRepo opts logger repo = do
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 +221,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)
@@ -284,6 +307,50 @@ 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
---------------------------------------------------------------------- ----------------------------------------------------------------------