From f66dfcbccb7fe772e05872fd6fd2c3565fa65bdd Mon Sep 17 00:00:00 2001 From: James Brechtel Date: Thu, 14 May 2026 10:13:36 -0400 Subject: [PATCH] Add configurable log levels and log file support - New LogLevel type: Debug, Info, Warn, Error with Ord instance - Logger holds configured level and output handle (stderr or file) - --log-level and --log-file CLI flags - log_level and log_file YAML config fields - Log messages assigned appropriate severity levels - Test logger updated to new Logger structure - All 17 tests passing --- SPEC.md | 3 ++ app/Main.hs | 64 ++++++++++++++++------ converge.example.yaml | 3 ++ src/Converge.hs | 120 ++++++++++++++++++++++++++++++++---------- test/TestHelper.hs | 7 +-- 5 files changed, 152 insertions(+), 45 deletions(-) diff --git a/SPEC.md b/SPEC.md index 929b5ae..6bc06f5 100644 --- a/SPEC.md +++ b/SPEC.md @@ -12,3 +12,6 @@ ### a revert is in progess ### a cherry-pick is in progess ### a bisect is in progess + +## Supports configurable log levels (debug, info, warn, error) +## Supports logging to a file instead of stderr via --log-file or log_file config diff --git a/app/Main.hs b/app/Main.hs index 249b3c7..5bb1721 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -3,6 +3,7 @@ module Main (main) where import Converge import Data.Maybe (fromMaybe) import Data.Text (Text) +import qualified Data.Text as T import Options.Applicative import System.IO (hPutStrLn, stderr) @@ -17,6 +18,10 @@ data CliArgs = CliArgs -- ^ Branch name (used only in single-repo mode). , cliDebounce :: !(Maybe Int) -- ^ Debounce override for both modes. + , cliLogLevel :: !(Maybe LogLevel) + -- ^ Log level override. + , cliLogFile :: !(Maybe FilePath) + -- ^ Log file path. } cliParser :: Parser CliArgs @@ -62,6 +67,26 @@ cliParser = <> help "Debounce window in milliseconds (overrides config file)" ) ) + <*> optional + ( option + (maybeReader (\s -> case T.toLower (T.pack s) of + "debug" -> Just Debug + "info" -> Just Info + "warn" -> Just Warn + "error" -> Just Error + _ -> Nothing)) + ( long "log-level" + <> metavar "LEVEL" + <> help "Minimum log level: debug, info, warn, or error (default: info)" + ) + ) + <*> optional + ( strOption + ( long "log-file" + <> metavar "FILE" + <> help "Write logs to a file instead of stderr" + ) + ) parserInfo :: ParserInfo CliArgs parserInfo = @@ -79,7 +104,7 @@ main = do (options, configSource) <- case cliConfig cli of Just cfgPath -> do cfg <- loadConfig cfgPath - let opts = applyDebounce mDebounceOverride (configToOptions cfg) + let opts = applyOverrides mDebounceOverride (cliLogLevel cli) (cliLogFile cli) (configToOptions cfg) pure (opts, Just cfgPath) Nothing -> do exists <- configFileExists @@ -87,20 +112,21 @@ main = do then do cfgPath <- defaultConfigPath cfg <- loadConfig cfgPath - let opts = applyDebounce mDebounceOverride (configToOptions cfg) + let opts = applyOverrides mDebounceOverride (cliLogLevel cli) (cliLogFile cli) (configToOptions cfg) pure (opts, Just cfgPath) else pure - ( defaultOptions - { optRepos = - [ defaultRepoConfig - { rcPath = fromMaybe "." (cliRepo cli) - , rcRemote = cliRemote cli - , rcBranch = cliBranch cli - } - ] - , optDebounceMs = fromMaybe 5000 mDebounceOverride - } + ( applyOverrides mDebounceOverride (cliLogLevel cli) (cliLogFile cli) + defaultOptions + { optRepos = + [ defaultRepoConfig + { rcPath = fromMaybe "." (cliRepo cli) + , rcRemote = cliRemote cli + , rcBranch = cliBranch cli + } + ] + , optDebounceMs = fromMaybe 5000 mDebounceOverride + } , Nothing ) case configSource of @@ -118,6 +144,14 @@ main = do mapM_ (\r -> hPutStrLn stderr (" - " <> rcPath r)) (optRepos options) runConverge options -applyDebounce :: Maybe Int -> Options -> Options -applyDebounce (Just ms) opts = opts{optDebounceMs = ms} -applyDebounce Nothing opts = opts + +-- | Apply CLI overrides (debounce, log level, log file) to Options. +applyOverrides :: Maybe Int -> Maybe LogLevel -> Maybe FilePath -> Options -> Options +applyOverrides mDebounce mLogLevel mLogFile opts = + opts + { optDebounceMs = maybe (optDebounceMs opts) id mDebounce + , optLogLevel = fromMaybe (optLogLevel opts) mLogLevel + , optLogFile = case mLogFile of + Just _ -> mLogFile -- CLI --log-file overrides config + Nothing -> optLogFile opts + } diff --git a/converge.example.yaml b/converge.example.yaml index 518a87f..e91fc8a 100644 --- a/converge.example.yaml +++ b/converge.example.yaml @@ -11,3 +11,6 @@ repos: # branch defaults to "main" # debounce_ms: 5000 # optional, defaults to 5000 + +# log_level: info # optional, one of: debug, info, warn, error (default: info) +# log_file: /var/log/converge.log # optional, write logs to a file instead of stderr diff --git a/src/Converge.hs b/src/Converge.hs index 963a5e3..bf4b3dd 100644 --- a/src/Converge.hs +++ b/src/Converge.hs @@ -2,6 +2,7 @@ module Converge ( -- * Core types Options (..), RepoConfig (..), + LogLevel (..), defaultOptions, defaultRepoConfig, @@ -47,12 +48,12 @@ 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 Data.Yaml (FromJSON (..), decodeFileThrow, withObject, withText, (.:), (.:?)) import System.Directory (XdgDirectory (XdgConfig), doesDirectoryExist, doesFileExist, getCurrentDirectory, getXdgDirectory) import System.Exit (ExitCode (..)) import System.FSNotify import System.FilePath (isAbsolute, splitDirectories, ()) -import System.IO (hPutStrLn, stderr) +import System.IO (BufferMode (..), Handle, IOMode (..), hFlush, hPutStrLn, hSetBuffering, openFile, stderr) import System.Process (readProcess, readProcessWithExitCode, spawnProcess) -- | Configuration for a single repository to watch. @@ -66,6 +67,22 @@ data RepoConfig = RepoConfig } deriving (Show, Eq) +-- | Log level controlling verbosity of output. +data LogLevel + = Debug + | Info + | Warn + | Error + deriving (Show, Eq, Ord, Bounded, Enum) + +instance FromJSON LogLevel where + parseJSON = withText "LogLevel" $ \t -> case T.toLower t of + "debug" -> pure Debug + "info" -> pure Info + "warn" -> pure Warn + "error" -> pure Error + other -> fail $ "Unknown log level: " <> T.unpack other <> ". Expected: debug, info, warn, or error" + -- | Top-level options for converge. data Options = Options { optRepos :: ![RepoConfig] @@ -74,6 +91,10 @@ data Options = Options -- ^ Debounce window in milliseconds. , optNotifyCmd :: !Text -- ^ Command used for desktop notifications. + , optLogLevel :: !LogLevel + -- ^ Minimum log level to emit. + , optLogFile :: !(Maybe FilePath) + -- ^ Optional log file path (logs to stderr when Nothing). } deriving (Show, Eq) @@ -93,16 +114,31 @@ defaultOptions = { optRepos = [defaultRepoConfig] , optDebounceMs = 5000 , optNotifyCmd = "notify-send" + , optLogLevel = Info + , optLogFile = Nothing } -{- | Logger that serializes output to stderr so concurrent repo watchers -don't interleave their log lines. +{- | Logger that serializes output so concurrent repo watchers +don't interleave their log lines. Writes to stderr or a file +depending on configuration. -} -newtype Logger = Logger (MVar ()) +data Logger = Logger + { loggerLock :: !(MVar ()) + , loggerLevel :: !LogLevel + , loggerHandle :: !Handle + } -- | Create a new thread-safe logger. -newLogger :: IO Logger -newLogger = Logger <$> newMVar () +newLogger :: LogLevel -> Maybe FilePath -> IO Logger +newLogger lvl mFile = do + lock <- newMVar () + handle <- case mFile of + Nothing -> pure stderr + Just path -> do + h <- openFile path AppendMode + hSetBuffering h LineBuffering + pure h + pure $ Logger lock lvl handle ---------------------------------------------------------------------- -- Config file (YAML) @@ -112,6 +148,8 @@ newLogger = Logger <$> newMVar () data Config = Config { cfgRepos :: ![RepoConfig] , cfgDebounceMs :: !(Maybe Int) + , cfgLogLevel :: !(Maybe LogLevel) + , cfgLogFile :: !(Maybe FilePath) } deriving (Show, Eq) @@ -120,6 +158,8 @@ instance FromJSON Config where Config <$> o .: "repos" <*> o .:? "debounce_ms" + <*> o .:? "log_level" + <*> o .:? "log_file" instance FromJSON RepoConfig where parseJSON = withObject "RepoConfig" $ \o -> @@ -138,6 +178,8 @@ configToOptions cfg = defaultOptions { optRepos = cfgRepos cfg , optDebounceMs = fromMaybe 5000 (cfgDebounceMs cfg) + , optLogLevel = fromMaybe Info (cfgLogLevel cfg) + , optLogFile = cfgLogFile cfg } -- | The default XDG config file path: @$XDG_CONFIG_HOME/converge/config.yaml@. @@ -152,16 +194,37 @@ configFileExists = defaultConfigPath >>= doesFileExist -- Logging ---------------------------------------------------------------------- --- | Log a timestamped message to stderr. -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 timestamped message at a given level. Messages below the +-- Logger's configured minimum level are silently dropped. +logMsg :: Logger -> LogLevel -> Text -> IO () +logMsg (Logger lock lvl handle) level msg = + when (level >= lvl) $ + withMVar lock $ \() -> do + now <- getCurrentTime + let ts = T.pack $ formatTime defaultTimeLocale "%H:%M:%S" now + let levelTag = case level of + Debug -> "DEBUG" + Info -> "INFO " + Warn -> "WARN " + Error -> "ERROR" + hPutStrLn handle $ "[" <> T.unpack ts <> "] " <> levelTag <> " " <> T.unpack msg + hFlush handle --- | Log a message tagged with a repo path. +-- | Log at Debug level. +logDebug :: Logger -> Text -> IO () +logDebug logger msg = logMsg logger Debug msg + +-- | Log at Warn level. +logWarn :: Logger -> Text -> IO () +logWarn logger msg = logMsg logger Warn msg + +-- | Log a message tagged with a repo path (at a given level). +logRepoAt :: Logger -> LogLevel -> RepoConfig -> Text -> IO () +logRepoAt logger level repo msg = logMsg logger level ("[" <> T.pack (rcPath repo) <> "] " <> msg) + +-- | Log a message tagged with a repo path at Info level. logRepo :: Logger -> RepoConfig -> Text -> IO () -logRepo logger repo msg = logInfo logger ("[" <> T.pack (rcPath repo) <> "] " <> msg) +logRepo logger repo msg = logRepoAt logger Info repo msg ---------------------------------------------------------------------- -- Running @@ -170,7 +233,7 @@ logRepo logger repo msg = logInfo logger ("[" <> T.pack (rcPath repo) <> "] " <> -- | Watch all configured repositories concurrently. runConverge :: Options -> IO () runConverge opts = do - logger <- newLogger + logger <- newLogger (optLogLevel opts) (optLogFile opts) mapConcurrently_ (watchRepo opts logger) (optRepos opts) {- | Watch a single repository for changes. @@ -183,7 +246,7 @@ watchRepo :: Options -> Logger -> RepoConfig -> IO () watchRepo opts logger repo = do absPath <- resolvePath (rcPath repo) let debounceUs = optDebounceMs opts * 1000 - logRepo logger 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) [level=" <> T.pack (show (optLogLevel opts)) <> "]") pending <- newEmptyMVar -- Background sync loop: waits for an event signal, debounces, then syncs _ <- forkIO $ forever $ do @@ -246,17 +309,17 @@ merge, rebase, revert, cherry-pick, or bisect. -} syncRepo :: Options -> Logger -> RepoConfig -> IO () syncRepo opts logger repo = do - logRepo logger repo "sync cycle starting" + logRepoAt logger Debug 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 ***" + logRepoAt logger Warn 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" + then logRepoAt logger Debug repo "no changes to commit" else do let count = length changed let preview = T.unlines (take 15 changed) @@ -271,7 +334,7 @@ syncRepo opts logger repo = do || "nothing to commit" `T.isInfixOf` commitErr -> logRepo logger repo "nothing to commit (working tree clean)" | otherwise -> do - logRepo logger repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr)) + logRepoAt logger Error repo ("commit FAILED (exit " <> T.pack (show commitCode) <> "): " <> T.strip (commitOut <> commitErr)) notifyUser opts "Converge: Commit Failed" @@ -286,7 +349,7 @@ syncRepo opts logger repo = do then logRepo logger repo "pull: already up to date" else logRepo logger repo ("pull succeeded:\n" <> trimmed) _ -> do - logRepo logger repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr)) + logRepoAt logger Error repo ("pull FAILED (exit " <> T.pack (show pullCode) <> "): " <> T.strip (pullOut <> pullErr)) notifyUser opts "Converge: Pull Failed" @@ -295,7 +358,7 @@ syncRepo opts logger repo = do conflicted <- hasConflicts (rcPath repo) if conflicted then do - logRepo logger repo "*** MERGE CONFLICT detected! ***" + logRepoAt logger Error repo "*** MERGE CONFLICT detected! ***" notifyUser opts "Converge: Merge Conflict" @@ -308,7 +371,7 @@ syncRepo opts logger repo = do ExitSuccess -> logRepo logger repo "push succeeded" _ -> do - logRepo logger repo ("push FAILED (exit " <> T.pack (show pushCode) <> "): " <> T.strip (pushOut <> pushErr)) + logRepoAt logger Error repo ("push FAILED (exit " <> T.pack (show pushCode) <> "): " <> T.strip (pushOut <> pushErr)) notifyUser opts "Converge: Push Failed" @@ -323,7 +386,7 @@ gitCommitAll :: Logger -> FilePath -> IO (ExitCode, Text, Text) gitCommitAll logger repoPath = do addResult@(addCode, _, addErr) <- loggedGit logger repoPath ["add", "-A"] unless (T.null addErr) $ - logInfo logger ("git add stderr: " <> addErr) + logWarn logger ("git add stderr: " <> addErr) if addCode /= ExitSuccess then pure addResult else do @@ -349,14 +412,17 @@ gitPush logger repo = -- | Run a git command and log the invocation and exit code. loggedGit :: Logger -> FilePath -> [String] -> IO (ExitCode, Text, Text) loggedGit logger repoPath args = do - logInfo logger ("RUN: git -C " <> T.pack repoPath <> " " <> T.intercalate " " (map T.pack args)) + logDebug logger ("RUN: git -C " <> T.pack repoPath <> " " <> T.intercalate " " (map T.pack args)) result@(code, _, err) <- runGitIn repoPath args let msg = "EXIT " <> T.pack (show code) details = if code /= ExitSuccess && not (T.null err) then ": " <> T.strip err else "" - logInfo logger (msg <> details) + let exitLevel = case code of + ExitSuccess -> Debug + _ -> Error + logMsg logger exitLevel (msg <> details) pure result -- | Check if the repository currently has merge conflicts. diff --git a/test/TestHelper.hs b/test/TestHelper.hs index 59a06c7..3aa09a5 100644 --- a/test/TestHelper.hs +++ b/test/TestHelper.hs @@ -16,12 +16,13 @@ module TestHelper ( ) where import Control.Concurrent.MVar (newMVar) -import Converge (Logger (..)) +import Converge (Logger (..), LogLevel (..)) import Data.Text (Text) import qualified Data.Text as T import System.Directory (createDirectory) import System.Exit (ExitCode) import System.FilePath (()) +import System.IO (stderr) import System.IO.Temp (withSystemTempDirectory) import System.Process (readProcessWithExitCode) @@ -37,9 +38,9 @@ rawGit args = do (code, out, err) <- readProcessWithExitCode "git" args "" pure (code, T.pack out, T.pack err) --- | Create a test logger (serialized writes to stderr). +-- | Create a test logger (serialized writes to stderr, Debug level). testLogger :: IO Logger -testLogger = Logger <$> newMVar () +testLogger = Logger <$> newMVar () <*> pure Debug <*> pure stderr {- | Create a temporary git repository, configure a user, make an initial commit on branch "main", run the action with the repo path, then clean up.