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
2026-05-14 10:13:36 -04:00
parent d22ea39cde
commit f66dfcbccb
5 changed files with 152 additions and 45 deletions
@@ -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
@@ -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,11 +112,12 @@ 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
+                        ( applyOverrides mDebounceOverride (cliLogLevel cli) (cliLogFile cli)
+                            defaultOptions
                                { optRepos =
                                    [ defaultRepoConfig
                                        { rcPath = fromMaybe "." (cliRepo cli)
@@ -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
+        }
@@ -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
@@ -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
+-- | 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
-    hPutStrLn stderr $ "[" <> T.unpack ts <> "] " <> T.unpack msg
+            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.
@@ -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.