Avoids running commands during external git operations
This commit is contained in:
+70
-3
@@ -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
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|||||||
Reference in New Issue
Block a user