From bd8e81513422a23342270fb9773f9d4d26326ee1 Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Mon, 11 May 2026 10:25:22 -0400 Subject: [PATCH] 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 --- src/Converge.hs | 110 ++++++++++++++++++++++++++++++++++++++++++------ 1 file changed, 96 insertions(+), 14 deletions(-) diff --git a/src/Converge.hs b/src/Converge.hs index 3476df9..da376f2 100644 --- a/src/Converge.hs +++ b/src/Converge.hs @@ -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) ""