Add detailed logging and fix event coalescing

- Add timestamped logging for events, commits, pulls, and conflicts
- Use MVar-based event coalescing so rapid changes trigger only one
  sync per debounce window (fixes missed changes from overlapping syncs)
- Handle 'nothing to commit' gracefully instead of treating it as error
- Log changed file list (git status --porcelain) during sync
- Log commit hash on success, pull output on success
- Remove unused imports
This commit is contained in:
2026-05-11 10:25:22 -04:00
parent 97e129a855
commit bd8e815134
+96 -14
View File
@@ -25,13 +25,16 @@ module Converge (
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.Async (mapConcurrently_)
import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar)
import Control.Exception (bracket)
import Control.Monad (forever, unless, when)
import Control.Monad (forever, unless, void)
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.Exit (ExitCode (..))
@@ -124,6 +127,21 @@ defaultConfigPath = (</> "converge/config.yaml") <$> getXdgDirectory XdgConfig "
configFileExists :: IO Bool
configFileExists = defaultConfigPath >>= doesFileExist
----------------------------------------------------------------------
-- Logging
----------------------------------------------------------------------
-- | Log a timestamped message to stderr.
logInfo :: Text -> IO ()
logInfo msg = do
now <- getCurrentTime
let ts = T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now
hPutStrLn stderr $ "[" <> T.unpack ts <> "] " <> T.unpack msg
-- | Log a message tagged with a repo path.
logRepo :: RepoConfig -> Text -> IO ()
logRepo repo msg = logInfo ("[" <> T.pack (rcPath repo) <> "] " <> msg)
----------------------------------------------------------------------
-- Running
----------------------------------------------------------------------
@@ -133,35 +151,98 @@ runConverge :: Options -> IO ()
runConverge opts =
mapConcurrently_ (watchRepo opts) (optRepos opts)
{- | Watch a single repository for changes.
Uses an 'MVar' to coalesce rapid events: the first event triggers a
debounce timer; subsequent events during the debounce window are
accumulated and drained, so only one sync runs per quiet period.
-}
watchRepo :: Options -> RepoConfig -> IO ()
watchRepo opts repo = do
absPath <- resolvePath (rcPath repo)
let debounceUs = optDebounceMs opts * 1000
logRepo repo ("watching " <> T.pack absPath <> " (debounce: " <> T.pack (show (optDebounceMs opts)) <> "ms)")
pending <- newEmptyMVar
-- Background sync loop: waits for an event signal, debounces, then syncs
_ <- forkIO $ forever $ do
takeMVar pending
threadDelay debounceUs
-- Drain any events that arrived during the debounce window
void $ tryTakeMVar pending
syncRepo opts repo
bracket
(startManagerConf defaultConfig)
stopManager
$ \mgr -> do
_ <- watchDir mgr absPath (const True) $ \_event -> do
threadDelay debounceUs
syncRepo opts repo
_ <- watchDir mgr absPath (const True) $ \event -> do
logEvent repo event
void $ tryPutMVar pending ()
forever $ threadDelay maxBound
where
resolvePath p
| isAbsolute p = pure p
| otherwise = (</> p) <$> getCurrentDirectory
-- | Log a filesystem event.
logEvent :: RepoConfig -> Event -> IO ()
logEvent repo event =
logRepo repo $
T.pack (eventPath event)
<> " "
<> eventLabel event
eventLabel :: Event -> Text
eventLabel event = case event of
Added{} -> "added"
Modified{} -> "modified"
ModifiedAttributes{} -> "modified (attrs)"
Removed{} -> "removed"
WatchedDirectoryRemoved{} -> "dir removed"
CloseWrite{} -> "write closed"
Unknown{} -> "unknown"
-- | Run a full sync cycle on a single repo: commit + pull + conflict check.
syncRepo :: Options -> RepoConfig -> IO ()
syncRepo opts repo = do
(commitCode, _, commitErr) <- gitCommitAll (rcPath repo)
unless (commitCode == ExitSuccess) $
hPutStrLn stderr ("[" <> rcPath repo <> "] git commit failed: " <> show commitErr)
(pullCode, _, pullErr) <- gitPull repo
unless (pullCode == ExitSuccess) $
hPutStrLn stderr ("[" <> rcPath repo <> "] git pull failed: " <> show pullErr)
logRepo 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 repo "no changes to commit"
else do
let count = length changed
let preview = T.unlines (take 15 changed)
logRepo repo ("staging " <> T.pack (show count) <> " file(s):\n" <> preview)
(commitCode, commitOut, commitErr) <- gitCommitAll (rcPath repo)
case commitCode of
ExitSuccess -> do
(_, hashOut, _) <- runGitIn (rcPath repo) ["log", "-1", "--format=%h %s"]
logRepo repo ("committed " <> T.strip hashOut)
_
| "nothing to commit" `T.isInfixOf` commitOut
|| "nothing to commit" `T.isInfixOf` commitErr ->
logRepo repo "nothing to commit (working tree clean)"
| otherwise ->
logRepo repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr))
-- Pull
logRepo 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 repo "pull: already up to date"
else logRepo repo ("pull succeeded:\n" <> trimmed)
_ ->
logRepo repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr))
-- Conflict check
conflicted <- hasConflicts (rcPath repo)
when conflicted $
notifyConflict opts repo
if conflicted
then do
logRepo repo "*** MERGE CONFLICT detected! ***"
notifyConflict opts repo
else logRepo repo "sync complete, no conflicts"
----------------------------------------------------------------------
-- Git operations
@@ -172,7 +253,7 @@ gitCommitAll :: FilePath -> IO (ExitCode, Text, Text)
gitCommitAll repoPath = do
(_, _, stageErr) <- runGitIn repoPath ["add", "-A"]
unless (T.null stageErr) $
hPutStrLn stderr ("git add stderr: " <> T.unpack stageErr)
logInfo ("git add stderr: " <> stageErr)
runGitIn repoPath ["commit", "-m", "converge: auto-commit"]
-- | Pull from the configured remote and branch.
@@ -208,6 +289,7 @@ notifyConflict opts repo = do
-- Internal helpers
----------------------------------------------------------------------
-- | Run a git command in the given repository directory.
runGitIn :: FilePath -> [String] -> IO (ExitCode, Text, Text)
runGitIn repoPath args = do
(code, out, err) <- readProcessWithExitCode "git" ("-C" : repoPath : args) ""