From 266dd117c63fcbbb69cc3f36a91303938150120d Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Mon, 11 May 2026 20:53:23 -0400 Subject: [PATCH] feat: add thread-safe logger and filter .git fs events MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - Introduce Logger newtype (MVar-backed) to serialize stderr output across concurrent repo watchers, preventing interleaved log lines - Thread Logger through runConverge → watchRepo → syncRepo → gitCommitAll - Switch watchDir → watchTree with isGitPath filter to ignore events inside .git directories, reducing noise and potential feedback loops - Extract logEvent as a standalone function --- src/Converge.hs | 84 ++++++++++++++++++++++++++++--------------------- 1 file changed, 49 insertions(+), 35 deletions(-) diff --git a/src/Converge.hs b/src/Converge.hs index da376f2..59f9960 100644 --- a/src/Converge.hs +++ b/src/Converge.hs @@ -27,7 +27,7 @@ where import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async (mapConcurrently_) -import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar, tryTakeMVar) +import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, takeMVar, tryPutMVar, tryTakeMVar, withMVar) import Control.Exception (bracket) import Control.Monad (forever, unless, void) import Data.Maybe (fromMaybe) @@ -39,7 +39,7 @@ import Data.Yaml (FromJSON (..), decodeFileThrow, withObject, (.:), (.:?)) import System.Directory (XdgDirectory (XdgConfig), doesFileExist, getCurrentDirectory, getXdgDirectory) import System.Exit (ExitCode (..)) import System.FSNotify -import System.FilePath (isAbsolute, ()) +import System.FilePath (isAbsolute, splitDirectories, ()) import System.IO (hPutStrLn, stderr) import System.Process (readProcessWithExitCode, spawnProcess) @@ -83,6 +83,15 @@ defaultOptions = , optNotifyCmd = "notify-send" } +{- | Logger that serializes output to stderr so concurrent repo watchers +don't interleave their log lines. +-} +newtype Logger = Logger (MVar ()) + +-- | Create a new thread-safe logger. +newLogger :: IO Logger +newLogger = Logger <$> newMVar () + ---------------------------------------------------------------------- -- Config file (YAML) ---------------------------------------------------------------------- @@ -132,15 +141,15 @@ configFileExists = defaultConfigPath >>= doesFileExist ---------------------------------------------------------------------- -- | Log a timestamped message to stderr. -logInfo :: Text -> IO () -logInfo msg = do +logInfo :: Logger -> Text -> IO () +logInfo (Logger lock) msg = withMVar lock $ \() -> 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) +logRepo :: Logger -> RepoConfig -> Text -> IO () +logRepo logger repo msg = logInfo logger ("[" <> T.pack (rcPath repo) <> "] " <> msg) ---------------------------------------------------------------------- -- Running @@ -148,8 +157,9 @@ logRepo repo msg = logInfo ("[" <> T.pack (rcPath repo) <> "] " <> msg) -- | Watch all configured repositories concurrently. runConverge :: Options -> IO () -runConverge opts = - mapConcurrently_ (watchRepo opts) (optRepos opts) +runConverge opts = do + logger <- newLogger + mapConcurrently_ (watchRepo opts logger) (optRepos opts) {- | Watch a single repository for changes. @@ -157,11 +167,11 @@ 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 +watchRepo :: Options -> Logger -> RepoConfig -> IO () +watchRepo opts logger repo = do absPath <- resolvePath (rcPath repo) let debounceUs = optDebounceMs opts * 1000 - logRepo repo ("watching " <> T.pack absPath <> " (debounce: " <> T.pack (show (optDebounceMs opts)) <> "ms)") + logRepo logger 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 @@ -169,13 +179,13 @@ watchRepo opts repo = do threadDelay debounceUs -- Drain any events that arrived during the debounce window void $ tryTakeMVar pending - syncRepo opts repo + syncRepo opts logger repo bracket (startManagerConf defaultConfig) stopManager $ \mgr -> do - _ <- watchDir mgr absPath (const True) $ \event -> do - logEvent repo event + _ <- watchTree mgr absPath (\e -> not (isGitPath (eventPath e))) $ \event -> do + logEvent logger repo event void $ tryPutMVar pending () forever $ threadDelay maxBound where @@ -184,9 +194,9 @@ watchRepo opts repo = do | otherwise = ( p) <$> getCurrentDirectory -- | Log a filesystem event. -logEvent :: RepoConfig -> Event -> IO () -logEvent repo event = - logRepo repo $ +logEvent :: Logger -> RepoConfig -> Event -> IO () +logEvent logger repo event = + logRepo logger repo $ T.pack (eventPath event) <> " " <> eventLabel event @@ -201,59 +211,63 @@ eventLabel event = case event of CloseWrite{} -> "write closed" Unknown{} -> "unknown" +-- | Check whether a file path lies inside a @.git@ directory. +isGitPath :: FilePath -> Bool +isGitPath = elem ".git" . splitDirectories + -- | Run a full sync cycle on a single repo: commit + pull + conflict check. -syncRepo :: Options -> RepoConfig -> IO () -syncRepo opts repo = do - logRepo repo "sync cycle starting" +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 repo "no changes to commit" + then logRepo logger 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) + 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 repo ("committed " <> T.strip hashOut) + logRepo logger 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)" + logRepo logger repo "nothing to commit (working tree clean)" | otherwise -> - logRepo repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr)) + logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr)) -- Pull - logRepo repo ("pulling " <> rcRemote repo <> "/" <> rcBranch repo) + 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 repo "pull: already up to date" - else logRepo repo ("pull succeeded:\n" <> trimmed) + then logRepo logger repo "pull: already up to date" + else logRepo logger repo ("pull succeeded:\n" <> trimmed) _ -> - logRepo repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr)) + 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 repo "*** MERGE CONFLICT detected! ***" + logRepo logger repo "*** MERGE CONFLICT detected! ***" notifyConflict opts repo - else logRepo repo "sync complete, no conflicts" + else logRepo logger repo "sync complete, no conflicts" ---------------------------------------------------------------------- -- Git operations ---------------------------------------------------------------------- -- | Stage all changes and commit with an auto-generated message. -gitCommitAll :: FilePath -> IO (ExitCode, Text, Text) -gitCommitAll repoPath = do +gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text) +gitCommitAll logger repoPath = do (_, _, stageErr) <- runGitIn repoPath ["add", "-A"] unless (T.null stageErr) $ - logInfo ("git add stderr: " <> stageErr) + logInfo logger ("git add stderr: " <> stageErr) runGitIn repoPath ["commit", "-m", "converge: auto-commit"] -- | Pull from the configured remote and branch.