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