diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2026 Nadeem Bitar + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,48 @@ +-- | The @baikai@ executable. +-- +-- Deliberately thin. Everything real lives in "Baikai.Agent.Cli", which +-- returns an 'AgentCliRun' rather than writing to streams or exiting, so +-- the whole command-line surface is reachable from the test suite +-- without spawning this binary. This module's only job is to interpret +-- that record into real streams and a real exit code. +module Main (main) where + +import Baikai.Agent.Cli + ( AgentCliRun, + agentCliParserInfo, + runAgentCli, + ) +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Options.Applicative qualified as Options +import Settei.Env (EnvSnapshot, envSnapshot) +import System.Environment (getEnvironment) +import System.Exit (ExitCode (..), exitWith) +import System.IO (stderr, stdout) + +main :: IO () +main = do + options <- Options.execParser agentCliParserInfo + snapshot <- captureEnvironment + finished <- runAgentCli snapshot options + emit finished + exitWith (exitCodeFrom (finished ^. #exitCode)) + +-- | Snapshot the real environment once. @settei@ takes the snapshot as +-- a value rather than reading the environment itself, which is what +-- makes the layer testable without mutating the process. +captureEnvironment :: IO EnvSnapshot +captureEnvironment = do + values <- getEnvironment + pure (envSnapshot [(Text.pack name, Text.pack value) | (name, value) <- values]) + +emit :: AgentCliRun -> IO () +emit finished = do + TextIO.hPutStr stdout (finished ^. #standardOutput) + TextIO.hPutStr stderr (finished ^. #standardError) + +exitCodeFrom :: Int -> ExitCode +exitCodeFrom 0 = ExitSuccess +exitCodeFrom code = ExitFailure code diff --git a/baikai-agent.cabal b/baikai-agent.cabal new file mode 100644 --- /dev/null +++ b/baikai-agent.cabal @@ -0,0 +1,138 @@ +cabal-version: 3.4 +name: baikai-agent +version: 0.1.0.0 +synopsis: Unattended coding-agent runs for the Baikai abstraction +description: + Runs a local coding-agent command-line tool with no terminal and no + human present: delivers the prompt on standard input, drains both + output streams concurrently within a byte limit, and on timeout + terminates the child's whole process group. The provider-neutral + vocabulary lives in @Baikai.Agent@ in the core package, and vendor + packages own the translation into each tool's argument vector. + +category: AI +license: BSD-3-Clause +license-file: LICENSE +author: Nadeem Bitar +maintainer: nadeem@gmail.com +copyright: (c) 2026 Nadeem Bitar +build-type: Simple + +common common-options + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wredundant-constraints + -fhide-source-paths -Wmissing-export-lists -Wpartial-fields + -Wmissing-deriving-strategies + + -- Exhaustiveness is an error, not a warning. A non-exhaustive match + -- is a crash the compiler already found: it fails at runtime, on + -- whichever input reaches the missing branch, usually in front of a + -- user. This is not hypothetical here — adding a constructor to + -- AgentRunFailure left `failureExitCode` non-exhaustive and shipped a + -- pattern-match failure on `baikai agent run --require-evidence`, + -- because the warning scrolled past in a build log. + -- + -- Promoted individually rather than through -Werror, which would also + -- fail the build on warnings that are stylistic or that a future GHC + -- invents, and would push people toward blanket suppression. + ghc-options: + -Werror=incomplete-patterns -Werror=incomplete-uni-patterns + -Werror=incomplete-record-updates + + default-language: GHC2024 + default-extensions: + DeriveAnyClass + DuplicateRecordFields + OverloadedLabels + OverloadedStrings + +library + import: common-options + hs-source-dirs: src + exposed-modules: + Baikai.Agent.Cli + Baikai.Agent.Config + Baikai.Agent.Run + + build-depends: + , aeson ^>=2.2 + , baikai ^>=0.5.0 + , baikai-claude ^>=0.5 + , baikai-openai ^>=0.5 + , base >=4.20 && <5 + , bytestring ^>=0.12 + , containers ^>=0.7 + , directory ^>=1.3 + , filepath ^>=1.5 + , generic-lens ^>=2.3 + , lens ^>=5.3 + , optparse-applicative ^>=0.19 + , process ^>=1.6 + , settei ^>=0.2 + , settei-env ^>=0.2 + , settei-kdl ^>=0.2 + , settei-optparse-applicative ^>=0.2 + , streamly-core >=0.3 && <0.5 + , text ^>=2.1 + , time ^>=1.14 + + -- The process package offers a group-wide interrupt but no group-wide + -- terminate, which a timeout needs to reach a coding agent's own + -- children. Where POSIX signals exist, use them. + if !os(windows) + build-depends: unix ^>=2.8 + cpp-options: -DBAIKAI_POSIX_SIGNALS + +executable baikai + import: common-options + hs-source-dirs: app + main-is: Main.hs + + -- Deliberately thin: everything real lives in Baikai.Agent.Cli so the + -- whole command-line surface is reachable from the test suite without + -- spawning the built binary. + build-depends: + , baikai-agent + , base >=4.20 && <5 + , generic-lens ^>=2.3 + , lens ^>=5.3 + , optparse-applicative ^>=0.19 + , settei-env ^>=0.2 + , text ^>=2.1 + +test-suite baikai-agent-test + import: common-options + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + CliTests + ConfigTests + EvidenceTests + + -- -threaded is not optional here: the runner forks threads to drain + -- pipes and relies on System.Timeout interrupting a blocking wait. + ghc-options: -threaded -with-rtsopts=-N + build-depends: + , aeson + , baikai + , baikai-agent + , base + , bytestring + , containers + , directory + , filepath + , generic-lens + , lens + , optparse-applicative + , process + , settei + , settei-env + , settei-kdl + , settei-optparse-applicative + , tasty + , tasty-hunit + , temporary + , text + , time diff --git a/src/Baikai/Agent/Cli.hs b/src/Baikai/Agent/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Agent/Cli.hs @@ -0,0 +1,1236 @@ +-- | The @baikai agent@ command-line surface: @run@, @show@, and +-- @list@. +-- +-- This module is where the five earlier pieces of the unattended +-- surface meet. It resolves a named job from layered KDL configuration, +-- caps it against the operator's policy ceiling, dispatches it to the +-- vendor renderer for its provider, and hands the rendered command to +-- the process runner. It is also the only place in the codebase that +-- knows both providers. +-- +-- Everything real lives here rather than in @app\/Main.hs@ so the whole +-- surface is reachable from a test without spawning the built binary. +-- 'runAgentCli' returns an 'AgentCliRun' — an exit code and two captured +-- streams — and the executable's only job is to interpret that record. +-- +-- __Stream discipline__, because a shell script depends on it. Baikai's +-- own diagnostics always go to standard error. The agent's own output +-- follows the job's configured output mode: under @inherit@ it goes +-- straight to the real streams and never enters 'AgentCliRun' at all, +-- under @capture@ Baikai holds it and returns it, and under @tee@ both +-- happen. That is what makes @response=$(baikai agent run job)@ yield +-- the agent's answer and nothing else for a capturing job, while a human +-- watching still sees diagnostics. +module Baikai.Agent.Cli + ( -- * The parsed command line + AgentCliCommand (..), + PromptSource (..), + AgentCliOptions (..), + agentCliParser, + agentCliParserInfo, + + -- * Running it + AgentCliRun (..), + runAgentCli, + runAgentCliWithPaths, + + -- * Provider dispatch + renderJobCommand, + + -- * Exit codes + usageExitCode, + unavailableExitCode, + internalExitCode, + timeoutExitCode, + refusedExitCode, + configExitCode, + + -- * Exposed for testing + readPromptSource, + renderEffectiveConfig, + ) +where + +import Baikai.Agent + ( AgentCapturedOutput (..), + AgentCeiling, + AgentCommand, + AgentOutputMode (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRenderError, + AgentRunFailure (..), + AgentRunRequest, + AgentRunResult, + renderAgentCapability, + renderAgentProvider, + renderAgentRenderError, + renderAgentRunFailure, + ) +import Baikai.Agent.Config + ( AgentConfigPaths (..), + AgentJob, + agentJobRequest, + applyCeilingToJob, + defaultAgentConfigPaths, + listAgentJobs, + loadAgentCeiling, + renderAgentConfigError, + renderAgentConfigScope, + resolveAgentJob, + ) +import Baikai.Agent.Run (runAgentCommand) +import Baikai.Evidence + ( EvidenceRequest (..), + EvidenceStrength (..), + EvidenceStrictness (..), + ModelCallEvidence, + ThinkingTranslation, + evidenceRequest, + ) +import Baikai.Provider.Claude.Agent + ( ClaudeAgentConfig, + claudeAgentCommand, + defaultClaudeAgentConfig, + ) +import Baikai.Provider.OpenAI.Agent + ( CodexAgentConfig, + codexAgentCommand, + defaultCodexAgentConfig, + ) +import Control.Applicative ((<|>)) +import Control.Exception (IOException, displayException, try) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Char (isControl, ord) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import GHC.Generics (Generic) +import Numeric (showHex) +import Options.Applicative (Parser, ParserInfo) +import Options.Applicative qualified as Options +import Settei.Env (EnvSnapshot) +import Settei.Key (keySegments, mkKey, parseKey, renderKey) +import Settei.Optparse (CliOverride, cliOverride, cliOverrideKey, cliOverrideValue) +import Settei.Origin (Origin, SourceKind (..), SourceLocation) +import Settei.Provenance (renderReportedValue) +import Settei.Render (renderErrorsText, renderResolutionJson, renderWarningsText) +import Settei.Report + ( ResolutionOutcome (..), + ResolutionReport, + reportNodes, + ) +import Settei.Value (RawValue (..)) +import System.Directory (doesFileExist, renameFile) +import System.Exit (ExitCode (..)) +import System.IO (stdin) + +-- | Which of the three commands was asked for. +data AgentCliCommand + = -- | Run a named job, taking the prompt from the given source. + AgentRun !Text !PromptSource + | -- | Explain a named job without starting anything. + AgentShow !Text + | -- | Enumerate the configured jobs. + AgentList + deriving stock (Eq, Show, Generic) + +-- | Where the prompt comes from. The three are mutually exclusive on +-- the command line, so supplying two is a usage error rather than a +-- silent precedence puzzle. +data PromptSource + = PromptStdin + | PromptFile !FilePath + | PromptInline !Text + deriving stock (Eq, Show, Generic) + +-- | The parsed command line, before any file is opened. +data AgentCliOptions = AgentCliOptions + { command :: !AgentCliCommand, + -- | Parsed @--set@ overrides, __with keys as the operator wrote + -- them__. A key that does not already begin with the @jobs@ segment + -- is job-relative and is rewritten to @jobs.\.\@ before + -- resolution; the job name is not known while parsing, so the + -- rewrite cannot happen here. + overrides :: ![CliOverride], + -- | Explicit operator-scope file, overriding discovery. + userConfig :: !(Maybe FilePath), + -- | Explicit repository-scope file, overriding discovery. + repoConfig :: !(Maybe FilePath), + jsonOutput :: !Bool, + -- | Where to write the run's evidence record, from + -- @--evidence-file@. Only @run@ accepts it; the other two commands + -- start nothing and so have nothing to record. + evidenceFile :: !(Maybe FilePath), + -- | The caller's identifier for the logical run this invocation + -- belongs to, from @--run-id@. + runId :: !(Maybe Text), + -- | The evidence strength this run must reach, from + -- @--require-evidence@. Setting it turns recording on and makes the + -- run refuse rather than start when the configuration cannot + -- produce it. + requiredEvidence :: !(Maybe EvidenceStrength) + } + deriving stock (Generic) + +-- | One capturable run of the command-line surface. +-- +-- 'standardOutput' and 'standardError' are __Baikai's__ output. Under +-- the @inherit@ and @tee@ output modes the agent's own output goes +-- straight to the real process streams and bypasses this record +-- entirely, which is correct and is what the motivating consumer wants. +data AgentCliRun = AgentCliRun + { exitCode :: !Int, + standardOutput :: !Text, + standardError :: !Text + } + deriving stock (Eq, Show, Generic) + +usageExitCode, + unavailableExitCode, + internalExitCode, + timeoutExitCode, + refusedExitCode, + configExitCode :: + Int + +-- | The command line could not be parsed, or the prompt was empty. +-- +-- Baikai's own failures start at 64 and follow the @sysexits@ +-- convention, because the coding agent's own exit code passes through +-- unchanged and the two must stay separable. Coding agents +-- conventionally exit 0 or 1, so in practice they do; the residual +-- ambiguity when a provider exits 64 or above is documented rather than +-- hidden, and @--json@ carries the unambiguous answer. +usageExitCode = 64 + +-- | The coding-agent executable could not be started. +unavailableExitCode = 69 + +-- | The agent produced output the caller could not interpret. +internalExitCode = 70 + +-- | The run exceeded its timeout and its process group was terminated. +timeoutExitCode = 75 + +-- | Policy refused the run: the ceiling was exceeded, or the provider +-- cannot express the requested policy. Nothing was started. +refusedExitCode = 77 + +-- | Configuration was missing, unreadable, or invalid. +configExitCode = 78 + +-- -------------------------------------------------------------------- +-- Parsing +-- -------------------------------------------------------------------- + +-- | Complete parser metadata, including the usage-error exit code. +-- +-- Without 'Options.failureCode' a mistyped flag would exit 1, which is +-- indistinguishable from a coding agent that ran and exited 1. +agentCliParserInfo :: ParserInfo AgentCliOptions +agentCliParserInfo = + Options.info + (agentCliParser Options.<**> Options.helper) + ( Options.fullDesc + <> Options.progDesc "Run unattended coding-agent jobs from configuration" + <> Options.header "baikai - unattended coding-agent runs" + <> Options.failureCode usageExitCode + ) + +-- | The top level takes one subcommand group, @agent@, leaving room for +-- future groups without minting a new executable. +agentCliParser :: Parser AgentCliOptions +agentCliParser = + Options.hsubparser + ( Options.command + "agent" + ( Options.info + agentGroupParser + (Options.progDesc "Inspect and run unattended coding-agent jobs") + ) + ) + +agentGroupParser :: Parser AgentCliOptions +agentGroupParser = + Options.hsubparser + ( Options.command + "run" + ( Options.info + runOptionsParser + (Options.progDesc "Run a configured job, propagating the agent's exit code") + ) + <> Options.command + "show" + ( Options.info + showOptionsParser + (Options.progDesc "Print a job's effective configuration and rendered command") + ) + <> Options.command + "list" + ( Options.info + listOptionsParser + (Options.progDesc "List the configured jobs and the scope each came from") + ) + ) + +runOptionsParser :: Parser AgentCliOptions +runOptionsParser = + assemble + <$> jobArgument + <*> promptSourceParser + <*> Options.many overrideOption + <*> Options.optional userConfigOption + <*> Options.optional repoConfigOption + <*> jsonSwitch + <*> Options.optional evidenceFileOption + <*> Options.optional runIdOption + <*> Options.optional requireEvidenceOption + where + assemble + jobName + promptSource + overrides + userConfig + repoConfig + jsonOutput + evidenceFile + runId + requiredEvidence = + AgentCliOptions + { command = AgentRun jobName promptSource, + overrides, + userConfig, + repoConfig, + jsonOutput, + evidenceFile, + runId, + requiredEvidence + } + +showOptionsParser :: Parser AgentCliOptions +showOptionsParser = + assemble + <$> jobArgument + <*> Options.many overrideOption + <*> Options.optional userConfigOption + <*> Options.optional repoConfigOption + <*> jsonSwitch + where + assemble jobName overrides userConfig repoConfig jsonOutput = + AgentCliOptions + { command = AgentShow jobName, + overrides, + userConfig, + repoConfig, + jsonOutput, + evidenceFile = Nothing, + runId = Nothing, + requiredEvidence = Nothing + } + +listOptionsParser :: Parser AgentCliOptions +listOptionsParser = + assemble + <$> Options.optional userConfigOption + <*> Options.optional repoConfigOption + <*> jsonSwitch + where + assemble userConfig repoConfig jsonOutput = + AgentCliOptions + { command = AgentList, + overrides = [], + userConfig, + repoConfig, + jsonOutput, + evidenceFile = Nothing, + runId = Nothing, + requiredEvidence = Nothing + } + +jobArgument :: Parser Text +jobArgument = + Options.strArgument + (Options.metavar "JOB" <> Options.help "Name of the configured job") + +-- | The three prompt sources are alternatives, so supplying two is a +-- usage error. @run@ requires one: an unattended agent with no +-- instruction is not a meaningful run. +promptSourceParser :: Parser PromptSource +promptSourceParser = + Options.flag' + PromptStdin + ( Options.long "prompt-stdin" + <> Options.help "Read the prompt from standard input" + ) + <|> ( PromptFile + <$> Options.strOption + ( Options.long "prompt-file" + <> Options.metavar "PATH" + <> Options.help "Read the prompt from PATH" + ) + ) + <|> ( PromptInline + <$> Options.strOption + ( Options.long "prompt" + <> Options.metavar "TEXT" + <> Options.help "Use TEXT as the prompt" + ) + ) + +overrideOption :: Parser CliOverride +overrideOption = + Options.option + overrideReader + ( Options.long "set" + <> Options.metavar "KEY=VALUE" + <> Options.help + "Override one setting of the selected job; KEY is relative to the job \ + \unless it already starts with jobs." + ) + +-- | Parse @KEY=VALUE@ into a @settei@ override, keeping the key exactly +-- as written. +-- +-- This duplicates the shape of @settei@'s own @overrideOptions@ rather +-- than calling it, because the key here is normally job-relative and the +-- job name is not available while parsing. The value still becomes a +-- 'CliOverride' through @settei@'s own constructor, so it stays inside +-- the same provenance machinery as every other layer and its spelling +-- never carries the value. +overrideReader :: Options.ReadM CliOverride +overrideReader = Options.eitherReader $ \input -> + let rendered = Text.pack input + (keyText, assignment) = Text.breakOn "=" rendered + in if Text.null assignment + then Left "expected KEY=VALUE" + else case parseKey keyText of + Left problem -> Left ("invalid configuration key: " <> show problem) + Right key -> Right (cliOverride key (Text.drop 1 assignment)) + +userConfigOption :: Parser FilePath +userConfigOption = + Options.strOption + ( Options.long "user-config" + <> Options.metavar "PATH" + <> Options.help "Read operator-scope configuration from PATH" + ) + +repoConfigOption :: Parser FilePath +repoConfigOption = + Options.strOption + ( Options.long "config" + <> Options.metavar "PATH" + <> Options.help "Read repository-scope configuration from PATH" + ) + +jsonSwitch :: Parser Bool +jsonSwitch = + Options.switch + (Options.long "json" <> Options.help "Emit machine-readable JSON") + +evidenceFileOption :: Parser FilePath +evidenceFileOption = + Options.strOption + ( Options.long "evidence-file" + <> Options.metavar "PATH" + <> Options.help "Write the run's evidence record to PATH as one JSON object" + ) + +runIdOption :: Parser Text +runIdOption = + Options.strOption + ( Options.long "run-id" + <> Options.metavar "TEXT" + <> Options.help "Identifier for the logical run this invocation belongs to" + ) + +-- | @--require-evidence@ takes a strength name and refuses the run when +-- the configuration cannot reach it. +-- +-- The names are the ones an evidence record spells, so an operator reads +-- a record's @strength@ and passes that word back verbatim. +requireEvidenceOption :: Parser EvidenceStrength +requireEvidenceOption = + Options.option + (Options.eitherReader parse) + ( Options.long "require-evidence" + <> Options.metavar "STRENGTH" + <> Options.help + "Refuse to start unless the run can produce evidence of at least this \ + \strength: requested_only, correlated, model_observed, or fully_observed" + ) + where + parse = \case + "requested_only" -> Right EvidenceRequestedOnly + "correlated" -> Right EvidenceCorrelated + "model_observed" -> Right EvidenceModelObserved + "fully_observed" -> Right EvidenceFullyObserved + other -> + Left + ( "unknown evidence strength: " + <> other + <> " (expected requested_only, correlated, model_observed, or fully_observed)" + ) + +-- -------------------------------------------------------------------- +-- Provider dispatch +-- -------------------------------------------------------------------- + +-- | Turn a resolved job into a rendered command, or refuse. +-- +-- __This is the only place in the codebase that knows both +-- providers.__ It is the answer to the improvement request's first +-- acceptance criterion — that a script select Claude Code or Codex +-- entirely through configuration — and if provider knowledge spreads to +-- a second site, adding a third provider later becomes a hunt. +-- +-- Both the job and the request are taken even though the request was +-- built from the job. The renderers consume the request; the job carries +-- the executable override, for which 'AgentRunRequest' has no field +-- because it is a configuration concern rather than a run description. +-- The redundancy looks like an accident and is not. +-- +-- The translation half of the pair says what the request's reasoning +-- effort became on that provider's command line. It is threaded through +-- rather than discarded here, because the runner cannot derive it: it +-- deliberately imports no vendor renderer. +renderJobCommand :: + AgentJob -> + AgentRunRequest -> + Either AgentRenderError (AgentCommand, ThinkingTranslation) +renderJobCommand job request = case request ^. #provider of + AgentClaude -> claudeAgentCommand (claudeConfigFor job) request + AgentCodex -> codexAgentCommand (codexConfigFor job) request + +claudeConfigFor :: AgentJob -> ClaudeAgentConfig +claudeConfigFor job = + maybe + defaultClaudeAgentConfig + (\exe -> defaultClaudeAgentConfig & #executable .~ exe) + (job ^. #executable) + +codexConfigFor :: AgentJob -> CodexAgentConfig +codexConfigFor job = + maybe + defaultCodexAgentConfig + (\exe -> defaultCodexAgentConfig & #executable .~ exe) + (job ^. #executable) + +-- -------------------------------------------------------------------- +-- Running +-- -------------------------------------------------------------------- + +-- | Run the command line against the real configuration file +-- locations, with any explicit path overriding the discovered one. +runAgentCli :: EnvSnapshot -> AgentCliOptions -> IO AgentCliRun +runAgentCli snapshot options = do + paths <- effectiveConfigPaths options + runAgentCliWithPaths paths snapshot options + +-- | Run the command line against explicitly supplied configuration +-- paths. +-- +-- Tests use this rather than 'runAgentCli': a developer with a real +-- @~\/.config\/baikai\/agents.kdl@ would otherwise get different results +-- from a clean machine, and the failure would be baffling. +runAgentCliWithPaths :: + AgentConfigPaths -> EnvSnapshot -> AgentCliOptions -> IO AgentCliRun +runAgentCliWithPaths paths snapshot options = case options ^. #command of + AgentList -> listCommand paths options + AgentShow jobName -> showCommand paths snapshot options jobName + AgentRun jobName promptSource -> + runCommand paths snapshot options jobName promptSource + +-- | Discovery, with explicit paths winning per scope. When both scopes +-- are explicit nothing is discovered at all, so a fully specified +-- invocation never reads @HOME@ or @XDG_CONFIG_HOME@. +effectiveConfigPaths :: AgentCliOptions -> IO AgentConfigPaths +effectiveConfigPaths options = + case (options ^. #userConfig, options ^. #repoConfig) of + (Just user, Just repo) -> + pure AgentConfigPaths {userConfig = Just user, repoConfig = Just repo} + (user, repo) -> do + discovered <- defaultAgentConfigPaths + pure + AgentConfigPaths + { userConfig = user <|> discovered ^. #userConfig, + repoConfig = repo <|> discovered ^. #repoConfig + } + +successfulRun :: Text -> Text -> AgentCliRun +successfulRun out err = + AgentCliRun {exitCode = 0, standardOutput = out, standardError = err} + +failedRun :: Int -> Text -> AgentCliRun +failedRun code message = + AgentCliRun {exitCode = code, standardOutput = "", standardError = message} + +-- -------------------------------------------------------------------- +-- agent list +-- -------------------------------------------------------------------- + +listCommand :: AgentConfigPaths -> AgentCliOptions -> IO AgentCliRun +listCommand paths options = do + listed <- listAgentJobs paths + pure $ case listed of + Left problem -> failedRun configExitCode (renderAgentConfigError problem <> "\n") + Right entries + | options ^. #jsonOutput -> successfulRun (jsonArray (map entryJson entries) <> "\n") "" + -- An empty list is a normal state, not an error, and the note + -- saying so goes to standard error so that a script piping the + -- list never has to filter prose out of its data. + | null entries -> successfulRun "" "no jobs are configured\n" + | otherwise -> + successfulRun + (Text.unlines (map (entryLine (nameWidth entries)) entries)) + "" + where + nameWidth entries = maximum (0 : map (Text.length . (^. #name)) entries) + entryLine width entry = + Text.justifyLeft (width + 2) ' ' (entry ^. #name) + <> renderAgentConfigScope (entry ^. #scope) + <> ( if entry ^. #definingScopes > 1 + then " (also defined in another scope)" + else "" + ) + entryJson entry = + jsonObject + [ ("name", jsonString (entry ^. #name)), + ("scope", jsonString (renderAgentConfigScope (entry ^. #scope))), + ("definingScopes", Text.pack (show (entry ^. #definingScopes))) + ] + +-- -------------------------------------------------------------------- +-- Shared resolution +-- -------------------------------------------------------------------- + +-- | Everything both @show@ and @run@ need before they diverge. +data StagedJob = StagedJob + { job :: !AgentJob, + report :: !ResolutionReport, + warnings :: !Text, + ceiling :: !AgentCeiling, + ceilingSource :: !Text + } + deriving stock (Generic) + +-- | A stage that ended before a job was ready. +data StageFailure = StageFailure + { exitCode :: !Int, + message :: !Text, + -- | A failed resolution still carries a report, and for an explain + -- command that provenance is exactly what the operator needs. + report :: !(Maybe ResolutionReport), + warnings :: !Text + } + deriving stock (Generic) + +stageJob :: + AgentConfigPaths -> + EnvSnapshot -> + AgentCliOptions -> + Text -> + IO (Either StageFailure StagedJob) +stageJob paths snapshot options jobName = do + loaded <- resolveAgentJob paths snapshot (map (scopeOverride jobName) (options ^. #overrides)) jobName + case loaded of + Left problem -> pure (Left (configFailure (renderAgentConfigError problem))) + Right resolved -> do + let warningsText = renderWarningsText (resolved ^. #warnings) + case resolved ^. #answer of + Left problems -> + pure + ( Left + StageFailure + { exitCode = configExitCode, + message = renderErrorsText problems, + report = Just (resolved ^. #report), + warnings = warningsText + } + ) + Right job -> do + -- The ceiling is a separate load with a deliberately different + -- source list, and this command must not introduce a second + -- path to it. It calls loadAgentCeiling and adds no override + -- of its own. + loadedCeiling <- loadAgentCeiling paths + pure $ case loadedCeiling of + Left problem -> + Left + StageFailure + { exitCode = configExitCode, + message = renderAgentConfigError problem, + report = Nothing, + warnings = warningsText + } + Right ceiling' -> + Right + StagedJob + { job, + report = resolved ^. #report, + warnings = warningsText, + ceiling = ceiling', + ceilingSource = ceilingSourceLabel paths + } + where + configFailure text = + StageFailure + { exitCode = configExitCode, + message = text, + report = Nothing, + warnings = "" + } + +ceilingSourceLabel :: AgentConfigPaths -> Text +ceilingSourceLabel paths = case paths ^. #userConfig of + Nothing -> "built-in default (no operator configuration file)" + Just path -> Text.pack path + +-- | Rewrite a job-relative override key to its absolute form. +-- +-- A key already beginning with @jobs@ is absolute and passes through +-- untouched, which keeps @--set jobs.demo.provider=codex@ meaning what +-- it says. Everything else names a setting of the selected job, so +-- @--set output=capture@ addresses @jobs.\.output@. The rewrite +-- cannot happen while parsing, because the job name is parsed by the +-- same applicative. +-- The last guard is unreachable by construction — 'cliOverride' always +-- builds a 'RawText', and 'RawValue' has no 'Show' instance precisely so +-- that a possibly-secret value cannot be rendered — so a shape this +-- function cannot rewrite is passed through unchanged rather than +-- reported with its value inlined. +scopeOverride :: Text -> CliOverride -> CliOverride +scopeOverride jobName original + | firstSegment == "jobs" = original + | RawText value <- cliOverrideValue original, + Right scoped <- mkKey ("jobs" NonEmpty.:| (jobName : segments)) = + cliOverride scoped value + | otherwise = original + where + segments = NonEmpty.toList (keySegments (cliOverrideKey original)) + firstSegment = NonEmpty.head (keySegments (cliOverrideKey original)) + +-- -------------------------------------------------------------------- +-- agent show +-- -------------------------------------------------------------------- + +showCommand :: + AgentConfigPaths -> EnvSnapshot -> AgentCliOptions -> Text -> IO AgentCliRun +showCommand paths snapshot options jobName = do + staged <- stageJob paths snapshot options jobName + pure $ case staged of + Left failure -> + AgentCliRun + { exitCode = failure ^. #exitCode, + -- A failed resolution's provenance is exactly what an explain + -- command is for, so the report is printed when there is one. + standardOutput = maybe "" (renderReport options) (failure ^. #report), + standardError = failure ^. #warnings <> failure ^. #message <> "\n" + } + Right stagedJob -> explain options jobName stagedJob + +-- | Print the effective configuration, the ceiling, and the command +-- that would be spawned — or the refusal, after the configuration, so +-- the operator sees both what was asked for and why it was refused. +explain :: AgentCliOptions -> Text -> StagedJob -> AgentCliRun +explain options jobName staged = + case rendered of + Left refusal + | options ^. #jsonOutput -> + AgentCliRun + { exitCode = refusedExitCode, + standardOutput = jsonShow (Just (renderAgentRenderError refusal)) Nothing <> "\n", + standardError = staged ^. #warnings + } + | otherwise -> + AgentCliRun + { exitCode = refusedExitCode, + standardOutput = textSections, + standardError = + staged ^. #warnings <> "refused: " <> renderAgentRenderError refusal <> "\n" + } + Right command + | options ^. #jsonOutput -> + successfulRun (jsonShow Nothing (Just command) <> "\n") (staged ^. #warnings) + | otherwise -> + successfulRun + (textSections <> "\n" <> renderCommandSection command) + (staged ^. #warnings) + where + -- `show` takes no prompt, so a clearly artificial placeholder stands + -- in for it and is labelled as such wherever it could be mistaken + -- for a configured value. + placeholder = "" + request = agentJobRequest (staged ^. #job) placeholder + -- The argument vector is printed, so it must not carry the one + -- setting that can hold a credential. The ceiling is checked against + -- the real request; only the request the display is rendered from + -- has its raw provider arguments replaced, so each one still shows + -- in its true position without showing its value. + displayRequest = + request + & #safety + . #providerArgs + .~ ["" | _ <- staged ^. #job . #providerArgs] + rendered = do + _ <- applyCeilingToJob (staged ^. #ceiling) request + fst <$> renderJobCommand (staged ^. #job) displayRequest + textSections = + "job \"" + <> jobName + <> "\"\n\neffective configuration\n" + <> renderEffectiveConfig (staged ^. #report) + <> "\npolicy ceiling, from " + <> staged ^. #ceilingSource + <> "\n" + <> renderCeiling (staged ^. #ceiling) + jsonShow refusal command = + jsonObject + ( [ ("job", jsonString jobName), + ("configuration", renderResolutionJson (staged ^. #report)), + ("ceiling", ceilingJson (staged ^. #ceilingSource) (staged ^. #ceiling)) + ] + <> maybe [] (\message -> [("refused", jsonString message)]) refusal + <> maybe [] (\value -> [("command", commandJson value)]) command + ) + +renderReport :: AgentCliOptions -> ResolutionReport -> Text +renderReport options report + | options ^. #jsonOutput = renderResolutionJson report <> "\n" + | otherwise = renderEffectiveConfig report + +-- | Render every resolved value with the file, line, and column it came +-- from. +-- +-- @settei@'s own @renderResolutionText@ names a value's source but drops +-- its location; only the JSON rendering carries path, line, and column. +-- Improvement-request acceptance criterion 5 requires the position, so +-- this walks the report itself rather than delegating. +renderEffectiveConfig :: ResolutionReport -> Text +renderEffectiveConfig report = + Text.concat (map renderNode (reportNodes report)) + where + renderNode node = case node ^. #outcome of + NotSelected -> "" + MissingValue -> + " " <> renderKey (node ^. #key) <> " = (unset)\n" + Resolved value -> + " " + <> renderKey (node ^. #key) + <> " = " + <> renderReportedValue value + <> "\n" + <> renderSource node + renderSource node = + case (node ^. #origin, node ^. #derivation) of + (Just origin, _) -> " from " <> renderOrigin origin <> "\n" + (Nothing, Just derivation) -> + " from default rule " + <> derivation ^. #rule + <> " (" + <> derivation ^. #explanation + <> ")\n" + (Nothing, Nothing) -> "" + +-- | A value produced by a named default rule carries a 'DerivedSource' +-- origin whose name is the rule, which reads as a bare word without the +-- prefix — @no-provider-args@ rather than +-- @default rule no-provider-args@. +renderOrigin :: Origin -> Text +renderOrigin origin = + prefix + <> origin ^. #name + <> maybe "" ((" at " <>) . renderLocation) (origin ^. #location) + where + prefix = case origin ^. #kind of + DerivedSource -> "default rule " + _ -> "" + +renderLocation :: SourceLocation -> Text +renderLocation location = + location + ^. #path + <> maybe "" (\line -> ":" <> Text.pack (show line)) (location ^. #line) + <> maybe "" (\column -> ":" <> Text.pack (show column)) (location ^. #column) + +renderCeiling :: AgentCeiling -> Text +renderCeiling ceiling' = + Text.unlines + [ " max-capability " <> renderAgentCapability (ceiling' ^. #maxCapability), + " allow-provider-args " <> renderBool (ceiling' ^. #allowProviderArgs), + " allowed-providers " <> renderProviders (ceiling' ^. #allowedProviders) + ] + where + renderBool True = "true" + renderBool False = "false" + renderProviders [] = "none" + renderProviders providers = + Text.intercalate ", " (map renderAgentProvider providers) + +-- | The rendered command, one flag per line. +-- +-- A flag and the value that follows it are shown together purely as a +-- display convenience; the argument vector itself is the flat list. +renderCommandSection :: AgentCommand -> Text +renderCommandSection command = + "rendered command\n" + <> " " + <> Text.pack (command ^. #executable) + <> "\n" + <> Text.concat [" " <> Text.pack line <> "\n" | line <- groupArguments (command ^. #arguments)] + <> " prompt transport: " + <> renderTransport (command ^. #promptTransport) + <> "\n" + +renderTransport :: AgentPromptTransport -> Text +renderTransport PromptOnStdin = + "standard input (the prompt appears nowhere in the argument vector)" +renderTransport PromptAsArgument = + "the final argument (the child gets no standard input)" + +groupArguments :: [String] -> [String] +groupArguments [] = [] +groupArguments [single] = [single] +groupArguments (flag : value : rest) + | isFlag flag && not (isFlag value) = (flag <> " " <> value) : groupArguments rest + | otherwise = flag : groupArguments (value : rest) + where + isFlag ('-' : _) = True + isFlag _ = False + +-- -------------------------------------------------------------------- +-- agent run +-- -------------------------------------------------------------------- + +runCommand :: + AgentConfigPaths -> + EnvSnapshot -> + AgentCliOptions -> + Text -> + PromptSource -> + IO AgentCliRun +runCommand paths snapshot options jobName promptSource = do + staged <- stageJob paths snapshot options jobName + case staged of + Left failure -> + pure + ( failedRun + (failure ^. #exitCode) + (failure ^. #warnings <> failure ^. #message <> "\n") + ) + Right stagedJob -> do + promptRead <- readPromptSource promptSource + case promptRead of + Left problem -> pure (failedRun usageExitCode (problem <> "\n")) + Right promptBody + | Text.null promptBody -> + pure + ( failedRun + usageExitCode + ( "the prompt read from " + <> promptSourceLabel promptSource + <> " is empty; an unattended agent given no instruction \ + \does something unpredictable and expensive\n" + ) + ) + | otherwise -> execute options stagedJob promptBody + +execute :: AgentCliOptions -> StagedJob -> Text -> IO AgentCliRun +execute options staged promptBody = + case prepared of + Left refusal -> pure (refusedRun (renderAgentRenderError refusal)) + Right (request, command, translation) -> do + ran <- runAgentCommand (evidenceRequestFor options) translation request command + written <- writeEvidenceFile (options ^. #evidenceFile) (ran ^. #evidence) + pure (interpret options staged request (ran ^. #outcome) written) + where + request0 = agentJobRequest (staged ^. #job) promptBody + prepared = do + permitted <- applyCeilingToJob (staged ^. #ceiling) request0 + (command, translation) <- renderJobCommand (staged ^. #job) permitted + pure (permitted, command, translation) + refusedRun message + | options ^. #jsonOutput = + AgentCliRun + { exitCode = refusedExitCode, + standardOutput = + jsonObject + [ ("outcome", jsonString "refused"), + ("exitCode", Text.pack (show refusedExitCode)), + ("message", jsonString message) + ] + <> "\n", + standardError = staged ^. #warnings + } + | otherwise = + failedRun refusedExitCode (staged ^. #warnings <> "refused: " <> message <> "\n") + +interpret :: + AgentCliOptions -> + StagedJob -> + AgentRunRequest -> + Either AgentRunFailure AgentRunResult -> + -- | Whatever went wrong writing the evidence file, appended to + -- standard error. A failed write never changes the exit code: the + -- agent's own status is what a calling script branches on, and + -- silently turning a successful run into a failure because a log could + -- not be written would be the worse surprise. + Text -> + AgentCliRun +interpret options staged request result evidenceNote = case result of + Left failure + | options ^. #jsonOutput -> + AgentCliRun + { exitCode = failureExitCode failure, + standardOutput = + jsonObject + [ ("outcome", jsonString "failed"), + ("exitCode", Text.pack (show (failureExitCode failure))), + ("message", jsonString (renderAgentRunFailure failure)) + ] + <> "\n", + standardError = staged ^. #warnings <> evidenceNote + } + | otherwise -> + failedRun + (failureExitCode failure) + (staged ^. #warnings <> evidenceNote <> renderAgentRunFailure failure <> "\n") + Right ran + | options ^. #jsonOutput -> + AgentCliRun + { exitCode = resultExitCode ran, + standardOutput = resultJson ran <> "\n", + standardError = staged ^. #warnings <> evidenceNote <> truncationNotes ran + } + | otherwise -> + AgentCliRun + { exitCode = resultExitCode ran, + -- Only a captured stream reaches this record. Under `tee` + -- the runner already echoed the bytes to the real streams + -- while draining, so re-emitting them here would print + -- everything twice. + standardOutput = if capturing then decoded (ran ^. #stdout) else "", + standardError = + staged ^. #warnings + <> evidenceNote + <> (if capturing then decoded (ran ^. #stderr) else "") + <> truncationNotes ran + } + where + -- Only a captured stream is Baikai's to re-emit. `tee` already wrote + -- the bytes to the real streams while draining, and `inherit` + -- captured nothing at all. + capturing = request ^. #output == CaptureOutput + +-- | The caller's evidence request, or 'Nothing' when they asked for +-- none. +-- +-- Evidence is built exactly when the operator named a destination for it +-- or an outer run to correlate it with. Anyone who supplies neither gets +-- the behaviour they had before evidence existed, at the cost they had +-- before it existed: no digest, no call identifier, and no @--version@ +-- probe of the tool. +-- +-- With @--evidence-file@ but no @--run-id@ the job's own name stands in. +-- It is opaque text baikai never parses, and the alternative — an empty +-- string — would be a field a consumer has to special-case. +evidenceRequestFor :: AgentCliOptions -> Maybe EvidenceRequest +evidenceRequestFor options = + case (options ^. #evidenceFile, options ^. #runId, options ^. #requiredEvidence) of + (Nothing, Nothing, Nothing) -> Nothing + (_, _, strictness) -> + Just + ( (evidenceRequest (fromMaybe (jobNameOf (options ^. #command)) (options ^. #runId))) + { strictness = maybe EvidenceBestEffort EvidenceRequired strictness + } + ) + where + jobNameOf = \case + AgentRun name _ -> name + AgentShow name -> name + AgentList -> "agent" + +-- | Write one evidence record to the operator's chosen path, returning +-- whatever went wrong. +-- +-- The write is atomic — a temporary file beside the destination, then a +-- rename — so a reader polling the path never sees a half-written +-- record. It never appends: each run writes one complete object, and an +-- operator wanting a log of many runs points each at its own path. +-- +-- Nothing is written when the operator named no path, and nothing is +-- written when the run produced no evidence, which is the case where the +-- tool never started. An empty file would claim a run happened. +writeEvidenceFile :: Maybe FilePath -> Maybe ModelCallEvidence -> IO Text +writeEvidenceFile Nothing _ = pure "" +writeEvidenceFile (Just _) Nothing = pure "" +writeEvidenceFile (Just path) (Just record) = do + let staging = path <> ".partial" + written <- + try + ( do + BSL.writeFile staging (Aeson.encode record) + renameFile staging path + ) :: + IO (Either IOException ()) + pure $ case written of + Right () -> "" + Left problem -> + "could not write the evidence record to " + <> Text.pack path + <> ": " + <> Text.pack (displayException problem) + <> "\n" + +resultExitCode :: AgentRunResult -> Int +resultExitCode result = case result ^. #exitCode of + ExitSuccess -> 0 + ExitFailure code -> code + +failureExitCode :: AgentRunFailure -> Int +failureExitCode = \case + RunTimedOut _ -> timeoutExitCode + SpawnFailed _ _ -> unavailableExitCode + WorkingDirMissing _ -> configExitCode + MissingEnvironment _ -> configExitCode + OutputMalformed _ -> internalExitCode + -- Policy said no and nothing was started, which is exactly what + -- 'refusedExitCode' means for a ceiling violation or a provider that + -- cannot express a safety policy. A script that already branches on + -- 77 for those needs no new case for this one. + EvidenceRefused _ -> refusedExitCode + +-- | Announce truncation. A silently truncated response that a script +-- then parses is a bug waiting to happen. +truncationNotes :: AgentRunResult -> Text +truncationNotes result = + note "standard output" (result ^. #stdout) <> note "standard error" (result ^. #stderr) + where + note label (OutputTruncated _) = + "the agent's " <> label <> " was truncated at the configured output limit\n" + note _ _ = "" + +decoded :: AgentCapturedOutput -> Text +decoded captured = case captured of + OutputNotCaptured -> "" + OutputCaptured bytes -> Text.decodeUtf8Lenient bytes + OutputTruncated bytes -> Text.decodeUtf8Lenient bytes + +resultJson :: AgentRunResult -> Text +resultJson result = + jsonObject + ( [ ("outcome", jsonString "ran"), + ("exitCode", Text.pack (show (resultExitCode result))), + ("provider", jsonString (renderAgentProvider (result ^. #provider))), + ("durationSeconds", Text.pack (show (realToFrac (result ^. #duration) :: Double))) + ] + <> streamFields "stdout" (result ^. #stdout) + <> streamFields "stderr" (result ^. #stderr) + ) + where + streamFields _ OutputNotCaptured = [] + streamFields label captured = + [ (label, jsonString (decoded captured)), + ( label <> "Truncated", + case captured of + OutputTruncated _ -> "true" + _ -> "false" + ) + ] + +-- -------------------------------------------------------------------- +-- Prompts +-- -------------------------------------------------------------------- + +-- | Read the prompt, decoding UTF-8 explicitly. +-- +-- Explicit decoding rather than @getContents@ on purpose: the latter's +-- behavior depends on the handle's locale encoding, and the motivating +-- consumer's prompt contains interpolated paths and could contain any +-- character, so a locale-dependent read would corrupt it on a machine +-- without a UTF-8 locale. +readPromptSource :: PromptSource -> IO (Either Text Text) +readPromptSource = \case + PromptStdin -> decodeFrom "standard input" <$> BS.hGetContents stdin + PromptFile path -> do + present <- doesFileExist path + if not present + then pure (Left ("the prompt file does not exist: " <> Text.pack path)) + else decodeFrom (Text.pack path) <$> BS.readFile path + PromptInline value -> pure (Right value) + where + decodeFrom label bytes = case Text.decodeUtf8' bytes of + Left problem -> + Left + ( "the prompt read from " + <> label + <> " is not valid UTF-8: " + <> Text.pack (show problem) + ) + Right value -> Right value + +promptSourceLabel :: PromptSource -> Text +promptSourceLabel PromptStdin = "standard input" +promptSourceLabel (PromptFile path) = Text.pack path +promptSourceLabel (PromptInline _) = "--prompt" + +-- -------------------------------------------------------------------- +-- A very small JSON writer +-- -------------------------------------------------------------------- + +-- | Hand-rolled rather than pulled from @aeson@: the package needs +-- exactly three shapes, and the alternative is a dependency the library +-- otherwise has no use for. +jsonObject :: [(Text, Text)] -> Text +jsonObject fields = + "{" <> Text.intercalate "," [jsonString name <> ":" <> value | (name, value) <- fields] <> "}" + +jsonArray :: [Text] -> Text +jsonArray values = "[" <> Text.intercalate "," values <> "]" + +jsonString :: Text -> Text +jsonString value = "\"" <> Text.concatMap escape value <> "\"" + where + escape '"' = "\\\"" + escape '\\' = "\\\\" + escape '\n' = "\\n" + escape '\r' = "\\r" + escape '\t' = "\\t" + escape character + | isControl character = + "\\u" <> Text.justifyRight 4 '0' (Text.pack (showHex (ord character) "")) + | otherwise = Text.singleton character + +ceilingJson :: Text -> AgentCeiling -> Text +ceilingJson sourceLabel ceiling' = + jsonObject + [ ("source", jsonString sourceLabel), + ("maxCapability", jsonString (renderAgentCapability (ceiling' ^. #maxCapability))), + ( "allowProviderArgs", + if ceiling' ^. #allowProviderArgs then "true" else "false" + ), + ( "allowedProviders", + jsonArray (map (jsonString . renderAgentProvider) (ceiling' ^. #allowedProviders)) + ) + ] + +commandJson :: AgentCommand -> Text +commandJson command = + jsonObject + [ ("executable", jsonString (Text.pack (command ^. #executable))), + ("arguments", jsonArray (map (jsonString . Text.pack) (command ^. #arguments))), + ( "promptTransport", + jsonString + ( case command ^. #promptTransport of + PromptOnStdin -> "stdin" + PromptAsArgument -> "argument" + ) + ) + ] diff --git a/src/Baikai/Agent/Config.hs b/src/Baikai/Agent/Config.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Agent/Config.hs @@ -0,0 +1,805 @@ +-- | Resolve an unattended coding-agent job from layered KDL +-- configuration. +-- +-- A repository owns @.baikai\/agents.kdl@, which names jobs; an operator +-- owns @~\/.config\/baikai\/agents.kdl@, which supplies defaults __and__ +-- the safety ceiling. A caller asks for a job by name and receives a +-- fully resolved description together with a report saying, for every +-- value, which file and which line it came from. +-- +-- Two loads with deliberately different rules live here, and the +-- asymmetry between them is the security property of this module. +-- 'resolveAgentJob' layers five sources, later ones winning. +-- 'loadAgentCeiling' reads the operator's own file and __nothing else__, +-- so no repository file, environment variable, or command-line override +-- can raise the ceiling. They are two functions rather than one function +-- with a flag precisely so the difference is visible in the code. +-- +-- A repository configuration file is untrusted input: an automation +-- daemon that encounters a checkout is reading a file somebody else +-- wrote, and that file could ask for unrestricted filesystem access. +-- 'applyCeilingToJob' is where that ask is refused. +module Baikai.Agent.Config + ( -- * The configured shape of one job + AgentJob (..), + agentJobConfig, + agentJobRequest, + + -- * Where configuration lives + AgentConfigPaths (..), + AgentConfigScope (..), + renderAgentConfigScope, + defaultAgentConfigPaths, + + -- * Layered resolution + resolveAgentJob, + + -- * The operator policy ceiling + agentCeilingConfig, + loadAgentCeiling, + applyCeilingToJob, + + -- * Enumeration + AgentJobEntry (..), + listAgentJobs, + + -- * Failures + AgentConfigError (..), + renderAgentConfigError, + + -- * Exposed for testing + parseDuration, + agentEnvBindings, + defaultOutputLimit, + scalarOrListDecoder, + validateJobName, + ) +where + +import Baikai.Agent + ( AgentCapability, + AgentCeiling, + AgentOutputMode (..), + AgentProvider, + AgentRenderError (..), + AgentRunRequest, + AgentSafety, + agentRunRequest, + agentSafety, + applyAgentCeiling, + defaultAgentCeiling, + parseAgentCapability, + parseAgentOutputMode, + parseAgentProvider, + renderAgentCapability, + renderAgentOutputMode, + renderAgentProvider, + ) +import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Control.Lens ((&), (.~), (^.)) +import Data.Generics.Labels () +import Data.List.NonEmpty qualified as NonEmpty +import Data.Map.Strict qualified as Map +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Read qualified as TextRead +import Data.Time.Clock (NominalDiffTime) +import GHC.Generics (Generic) +import Settei.Config (Config, optional, required, withDefault) +import Settei.Default (Default, RuleName (..), constantDefault) +import Settei.Env + ( Bindings, + EnvName (..), + EnvSnapshot, + binding, + bindings, + environmentSource, + renderEnvErrorsText, + ) +import Settei.Kdl + ( kdlSourceOptions, + readKdlSource, + renderKdlErrorsText, + withKdlSourcePath, + ) +import Settei.Key (Key, keySegments, parseKey) +import Settei.Optparse (CliOverride, cliSources) +import Settei.Resolve (ResolveResult, defaultResolveOptions, resolve) +import Settei.Setting + ( Setting, + publicSetting, + publicSettingWithRenderer, + publicShowSetting, + secretSetting, + ) +import Settei.Source (Source, sourceLeaves) +import Settei.Value + ( Decoder, + RawValue (..), + boolDecoder, + boundedIntegralDecoder, + decodeFailure, + decoder, + enumDecoder, + parsedDecoder, + runDecoder, + textDecoder, + ) +import System.Directory (doesFileExist) +import System.Environment (lookupEnv) +import System.FilePath (()) + +-- | The configured shape of one named job. +-- +-- The safety fields are flattened here rather than nested as an +-- 'AgentSafety', even though the KDL document nests them under a +-- @safety@ node. A @settei@ setting is addressed by a dotted key, not by +-- a nested record, so a flat record maps one-to-one onto the +-- declaration; 'agentJobRequest' reassembles the nested value. +-- +-- There is deliberately no @name@ field. The name is how the job was +-- looked up, not a property of it, and storing it would invite a +-- mismatch between the two. +data AgentJob = AgentJob + { -- | Which coding-agent tool to run. Required. + provider :: !AgentProvider, + -- | Where the tool lives, for an operator whose installation is not + -- on @PATH@ under its canonical name. 'AgentRunRequest' has no field + -- for this, so it stays a configuration concern. + executable :: !(Maybe FilePath), + -- | Model override, or 'Nothing' to leave the tool's default. + modelId :: !(Maybe Text), + -- | Reasoning-effort override, or 'Nothing' to leave the tool's + -- default. + effort :: !(Maybe ThinkingLevel), + -- | The directory the run is rooted in. Required. + workingDir :: !FilePath, + -- | Directories the run may reach beyond 'workingDir'. + extraDirs :: ![FilePath], + -- | How much filesystem authority the job asks for. Required: a job + -- that forgot to state its authority must not silently receive + -- some. + capability :: !AgentCapability, + -- | Optional narrowing of the provider's tool set. + allowedTools :: ![Text], + -- | Raw provider arguments passed through verbatim. Classified + -- __secret__, because it is the one field an operator could write a + -- credential into. + providerArgs :: ![Text], + -- | Wall-clock limit for the whole run, or 'Nothing' for no limit. + timeout :: !(Maybe NominalDiffTime), + -- | What to do with the child's output streams. + output :: !AgentOutputMode, + -- | Maximum captured bytes per stream. 'Nothing' means unbounded. + outputLimit :: !(Maybe Int), + -- | Names of environment variables the job declares it requires. + -- Names only, never values, so the list cannot carry a secret. + envRequires :: ![Text] + } + deriving stock (Eq, Show, Generic) + +-- | Which configuration file a value or a job name came from. +-- +-- This is Baikai's own vocabulary rather than @settei@'s 'SourceKind', +-- which cannot serve: @settei-kdl@ tags every document it reads +-- @FileSource \"KDL v2\"@ — naming the /format/, not the file — so the +-- user and repository documents are indistinguishable by kind. +data AgentConfigScope + = UserScope + | RepositoryScope + deriving stock (Eq, Ord, Show, Generic) + +renderAgentConfigScope :: AgentConfigScope -> Text +renderAgentConfigScope UserScope = "user configuration" +renderAgentConfigScope RepositoryScope = "repository configuration" + +-- | One configured job name and the scope that supplied the winning +-- definition of it. +data AgentJobEntry = AgentJobEntry + { -- | The job name, as it appears after the @jobs@ segment. + name :: !Text, + -- | The highest-precedence scope defining the name. + scope :: !AgentConfigScope, + -- | How many scopes define this name. A bare name with no + -- indication that two files define it hides a real source of + -- confusion, so the count is reported rather than dropped. + definingScopes :: !Int + } + deriving stock (Eq, Show, Generic) + +-- | The two configuration files, each absent when it does not exist. +-- +-- An explicit record with a pure resolution path underneath is what lets +-- a test point at a temporary directory. Nothing below this record reads +-- the real @HOME@ or @XDG_CONFIG_HOME@. +data AgentConfigPaths = AgentConfigPaths + { userConfig :: !(Maybe FilePath), + repoConfig :: !(Maybe FilePath) + } + deriving stock (Eq, Show, Generic) + +-- | A failure loading configuration, as distinct from a resolution +-- failure, which @settei@ reports through 'ResolveResult'. +data AgentConfigError + = -- | The file that could not be read or parsed, and the rendered + -- @settei-kdl@ diagnosis. The diagnosis never contains the file's + -- contents: @settei-kdl@ errors carry a category, a name, a path, a + -- span, and a concise message, and appending the document \"for + -- context\" would defeat that redaction. + ConfigFileUnreadable !FilePath !Text + | -- | The job name, and why it cannot address a configuration key. + InvalidJobName !Text !Text + deriving stock (Eq, Show, Generic) + +renderAgentConfigError :: AgentConfigError -> Text +renderAgentConfigError (ConfigFileUnreadable path message) = + "could not read the configuration file " <> Text.pack path <> ": " <> message +renderAgentConfigError (InvalidJobName jobName why) = + "invalid job name " <> jobName <> ": " <> why + +-- | Bytes per stream captured when no layer states a limit. +-- +-- Concrete rather than unbounded on purpose: an operator who never +-- mentions a limit should not be one runaway agent away from exhausting +-- memory. Four mebibytes is far more than a normal run prints, and any +-- layer may raise it, lower it, or write @output-limit \"unlimited\"@ to +-- remove it. +defaultOutputLimit :: Int +defaultOutputLimit = 4194304 + +-- | Accept a scalar, an array, or an absent value as a list. +-- +-- @settei@'s own @listDecoder@ accepts only an array, which cannot serve +-- here: a KDL node's raw shape depends on how many arguments it has, so +-- @extra-dirs@ with no arguments is a null, with one argument is a +-- scalar, and only with two or more is it an array. A command-line +-- override is always a scalar, because @cliOverride@ builds a +-- @RawText@. Requiring an array would make the one-directory spelling +-- and every list-valued @--set@ undecodable. +scalarOrListDecoder :: Decoder a -> Decoder [a] +scalarOrListDecoder elementDecoder = + decoder $ \key raw -> case raw of + RawNull -> Right [] + RawArray values -> traverse (runDecoder elementDecoder key) values + scalar -> fmap pure (runDecoder elementDecoder key scalar) + +-- | Parse a duration written with a unit suffix, or a bare number of +-- seconds. +-- +-- @\"90s\"@ is ninety seconds, @\"45m\"@ is forty-five minutes, +-- @\"2h\"@ is two hours, and @\"45\"@ is forty-five seconds. Zero and +-- negative values are rejected: a timeout of zero would mean \"kill +-- every run immediately\", which no operator intends and which would be +-- baffling to diagnose. Omitting the setting is how a run goes +-- untimed. +parseDuration :: Text -> Maybe NominalDiffTime +parseDuration raw = + case TextRead.decimal (Text.strip raw) of + Right (magnitude :: Integer, rest) + | magnitude > 0 -> + fmap + (\multiplier -> fromInteger (magnitude * multiplier)) + (unitMultiplier (Text.strip rest)) + _ -> Nothing + where + unitMultiplier "" = Just 1 + unitMultiplier "s" = Just 1 + unitMultiplier "m" = Just 60 + unitMultiplier "h" = Just 3600 + unitMultiplier _ = Nothing + +renderDuration :: NominalDiffTime -> Text +renderDuration value = Text.pack (show value) + +-- | The configuration key addressing one leaf of one named job. +-- +-- Calling 'error' on an unparseable key is safe only because the leaf +-- names are compile-time constants and the job name has already passed +-- 'validateJobName'; a failure here is a programming error, not bad +-- input. This mirrors the @validKey@ helper in @settei@'s own reference +-- application. +jobKey :: Text -> Text -> Key +jobKey jobName leaf = validKey ("jobs." <> jobName <> "." <> leaf) + +validKey :: Text -> Key +validKey value = either (error . show) id (parseKey value) + +-- | Reject a job name that cannot address a configuration key. +-- +-- A name containing a dot would silently nest one level deeper than the +-- operator wrote, and an empty name would address the @jobs@ node +-- itself. Both are refused here so 'jobKey' is only ever reached with a +-- good name. +validateJobName :: Text -> Either AgentConfigError () +validateJobName jobName + | Text.null jobName = Left (InvalidJobName jobName "the name is empty") + | Text.any (== '.') jobName = + Left (InvalidJobName jobName "a job name may not contain a dot") + | otherwise = case parseKey ("jobs." <> jobName <> ".provider") of + Left problem -> Left (InvalidJobName jobName (Text.pack (show problem))) + Right _ -> Right () + +providerDecoder :: Decoder AgentProvider +providerDecoder = + parsedDecoder + "one of: claude, codex" + (maybe (Left "unknown provider") Right . parseAgentProvider) + +capabilityDecoder :: Decoder AgentCapability +capabilityDecoder = + parsedDecoder + "one of: read-only, edit-workspace, full-access" + (maybe (Left "unknown capability") Right . parseAgentCapability) + +outputModeDecoder :: Decoder AgentOutputMode +outputModeDecoder = + parsedDecoder + "one of: inherit, capture, tee" + (maybe (Left "unknown output mode") Right . parseAgentOutputMode) + +-- | The six canonical reasoning-effort names. The list lives in +-- @baikai\/src\/Baikai\/ThinkingLevel.hs@, which has a renderer but no +-- parser, so a future level must be added in both places. +effortDecoder :: Decoder ThinkingLevel +effortDecoder = + enumDecoder + [ ("minimal", ThinkingMinimal), + ("low", ThinkingLow), + ("medium", ThinkingMedium), + ("high", ThinkingHigh), + ("xhigh", ThinkingXHigh), + ("max", ThinkingMax) + ] + +pathDecoder :: Decoder FilePath +pathDecoder = fmap Text.unpack textDecoder + +-- | A duration written with a unit, or a bare positive number of +-- seconds. The unquoted form @timeout 2700@ is accepted too, because a +-- KDL number is a @RawNumber@ rather than a @RawText@. +durationDecoder :: Decoder NominalDiffTime +durationDecoder = + decoder $ \key raw -> + let reject = Left (decodeFailure key durationExpectation) + in case raw of + RawText value -> maybe reject Right (parseDuration value) + _ -> case runDecoder boundedIntegralDecoder key raw of + Right (seconds :: Int) | seconds > 0 -> Right (fromIntegral seconds) + _ -> reject + where + durationExpectation = + "a positive duration such as 90s, 45m, or 2h, or a bare number of seconds" + +-- | A positive byte count, or the word @unlimited@ for no bound. +outputLimitDecoder :: Decoder (Maybe Int) +outputLimitDecoder = + decoder $ \key raw -> case raw of + RawText "unlimited" -> Right Nothing + _ -> case runDecoder boundedIntegralDecoder key raw of + Right (bytes :: Int) | bytes > 0 -> Right (Just bytes) + _ -> Left (decodeFailure key "a positive number of bytes, or the word unlimited") + +providerSetting :: Text -> Setting AgentProvider +providerSetting jobName = + publicSettingWithRenderer + (jobKey jobName "provider") + "Coding-agent tool to run" + providerDecoder + renderAgentProvider + +executableSetting :: Text -> Setting FilePath +executableSetting jobName = + publicShowSetting + (jobKey jobName "executable") + "Path to the coding-agent executable, overriding PATH lookup" + pathDecoder + +modelSetting :: Text -> Setting Text +modelSetting jobName = + publicSetting (jobKey jobName "model") "Model override" textDecoder + +effortSetting :: Text -> Setting ThinkingLevel +effortSetting jobName = + publicSettingWithRenderer + (jobKey jobName "effort") + "Reasoning-effort override" + effortDecoder + renderThinkingLevel + +workingDirSetting :: Text -> Setting FilePath +workingDirSetting jobName = + publicShowSetting + (jobKey jobName "working-dir") + "Directory the run is rooted in" + pathDecoder + +extraDirsSetting :: Text -> Setting [FilePath] +extraDirsSetting jobName = + publicShowSetting + (jobKey jobName "extra-dirs") + "Directories the run may reach beyond its working directory" + (scalarOrListDecoder pathDecoder) + +capabilitySetting :: Text -> Setting AgentCapability +capabilitySetting jobName = + publicSettingWithRenderer + (jobKey jobName "safety.capability") + "Filesystem authority the job requests" + capabilityDecoder + renderAgentCapability + +allowedToolsSetting :: Text -> Setting [Text] +allowedToolsSetting jobName = + publicShowSetting + (jobKey jobName "safety.allowed-tools") + "Narrowing of the provider's tool set" + (scalarOrListDecoder textDecoder) + +-- | Raw provider arguments, classified __secret__. +-- +-- This is the only setting in the schema that can carry a credential — +-- nothing stops an operator from writing @--api-key sk-…@ here — and +-- @settei@ converts a secret-classified value to an opaque redacted form +-- before it can be retained in a resolution report or in a structural +-- error. Every other setting is structurally incapable of holding a +-- secret: environment variables are referenced by name and never by +-- value, and both coding agents keep their credentials in their own +-- stores. +providerArgsSetting :: Text -> Setting [Text] +providerArgsSetting jobName = + secretSetting + (jobKey jobName "safety.provider-args") + "Raw provider arguments passed through verbatim" + (scalarOrListDecoder textDecoder) + +timeoutSetting :: Text -> Setting NominalDiffTime +timeoutSetting jobName = + publicSettingWithRenderer + (jobKey jobName "timeout") + "Wall-clock limit for the whole run" + durationDecoder + renderDuration + +outputSetting :: Text -> Setting AgentOutputMode +outputSetting jobName = + publicSettingWithRenderer + (jobKey jobName "output") + "What to do with the child's output streams" + outputModeDecoder + renderAgentOutputMode + +outputLimitSetting :: Text -> Setting (Maybe Int) +outputLimitSetting jobName = + publicShowSetting + (jobKey jobName "output-limit") + "Maximum captured bytes per stream" + outputLimitDecoder + +envRequiresSetting :: Text -> Setting [Text] +envRequiresSetting jobName = + publicShowSetting + (jobKey jobName "env-requires") + "Environment variable names the job requires; names only, never values" + (scalarOrListDecoder textDecoder) + +emptyListDefault :: Text -> Default [a] +emptyListDefault ruleName = + constantDefault (RuleName ruleName) "nothing configured" [] + +-- | The declaration for one named job. +-- +-- The keys are built from the job name because @settei@'s 'Config' +-- describes a statically known set of keys while a document holds an +-- unknown number of jobs. A 'Config' is an ordinary value, so one is +-- built per name; decoding the whole document into an opaque map would +-- work too but would lose per-value provenance, and provenance is the +-- point. +-- +-- Defaults are named rules rather than a synthetic built-in source +-- because a source would have to be rebuilt for every job name — every +-- key contains it — while a rule is name-independent, keeps this +-- declaration complete on its own, and is reported with its own name and +-- rationale. +agentJobConfig :: Text -> Config AgentJob +agentJobConfig jobName = + AgentJob + <$> required (providerSetting jobName) + <*> optional (executableSetting jobName) + <*> optional (modelSetting jobName) + <*> optional (effortSetting jobName) + <*> required (workingDirSetting jobName) + <*> withDefault (extraDirsSetting jobName) (emptyListDefault "no-extra-dirs") + <*> required (capabilitySetting jobName) + <*> withDefault (allowedToolsSetting jobName) (emptyListDefault "no-tool-restriction") + <*> withDefault (providerArgsSetting jobName) (emptyListDefault "no-provider-args") + <*> optional (timeoutSetting jobName) + <*> withDefault + (outputSetting jobName) + (constantDefault (RuleName "inherit-output") "no output discipline configured" InheritOutput) + <*> withDefault + (outputLimitSetting jobName) + ( constantDefault + (RuleName "default-output-limit") + "no output limit configured" + (Just defaultOutputLimit) + ) + <*> withDefault (envRequiresSetting jobName) (emptyListDefault "no-required-environment") + +-- | Convert a resolved job into a run request, with the prompt supplied +-- at call time because a job describes where the text comes from rather +-- than carrying it. +-- +-- The ceiling is deliberately __not__ applied here. Burying the check +-- inside a conversion would make it bypassable by calling the conversion +-- directly; 'applyCeilingToJob' is a separate, explicitly named step. +agentJobRequest :: AgentJob -> Text -> AgentRunRequest +agentJobRequest job promptBody = + agentRunRequest (job ^. #provider) (job ^. #workingDir) promptBody + & #modelId .~ (job ^. #modelId) + & #effort .~ (job ^. #effort) + & #extraDirs .~ (job ^. #extraDirs) + & #safety .~ requestedSafety + & #timeout .~ (job ^. #timeout) + & #output .~ (job ^. #output) + & #outputLimit .~ (job ^. #outputLimit) + & #envPassthrough .~ (job ^. #envRequires) + where + requestedSafety :: AgentSafety + requestedSafety = + agentSafety (job ^. #capability) + & #allowedTools .~ (job ^. #allowedTools) + & #providerArgs .~ (job ^. #providerArgs) + +-- | Environment variables that may influence a job, bound explicitly. +-- +-- The set is small and deliberately chosen: the provider, the model, the +-- executable, and the timeout. The capability, the tool list, and the +-- raw provider arguments are __not__ bound. An environment variable is +-- easy to set accidentally and is inherited by every child process, so +-- letting one widen a job's authority would create exactly the ambient +-- influence the ceiling exists to prevent. +-- +-- The binding list is a function of the job name rather than a module +-- constant, because every key contains the name. Forcing it for any name +-- validates the whole list, which the test suite does so an invalid edit +-- fails in tests rather than at start-up. +agentEnvBindings :: Text -> Bindings +agentEnvBindings jobName = + either + (error . Text.unpack . renderEnvErrorsText) + id + ( bindings + [ binding (EnvName "BAIKAI_AGENT_PROVIDER") (jobKey jobName "provider"), + binding (EnvName "BAIKAI_AGENT_MODEL") (jobKey jobName "model"), + binding (EnvName "BAIKAI_AGENT_EXECUTABLE") (jobKey jobName "executable"), + binding (EnvName "BAIKAI_AGENT_TIMEOUT") (jobKey jobName "timeout") + ] + ) + +-- | Locate the two configuration files, treating a missing file as a +-- normal state rather than an error. +-- +-- The user path is @$XDG_CONFIG_HOME\/baikai\/agents.kdl@ when that +-- variable is set and non-empty, otherwise +-- @$HOME\/.config\/baikai\/agents.kdl@. The repository path is +-- @.\/.baikai\/agents.kdl@ relative to the current working directory and +-- __nothing else__: an upward search would make the effective +-- configuration depend on where the process happened to start, and a job +-- could silently pick up a file from a parent directory outside the +-- repository it believes it is working in. For an untrusted file that +-- grants filesystem authority that is an unacceptable surprise. A caller +-- wanting a different file passes an explicit path. +defaultAgentConfigPaths :: IO AgentConfigPaths +defaultAgentConfigPaths = do + xdgHome <- lookupEnv "XDG_CONFIG_HOME" + homeDir <- lookupEnv "HOME" + let configBase = case xdgHome of + Just dir | not (null dir) -> Just dir + _ -> fmap ( ".config") (nonEmptyPath =<< homeDir) + userPath = fmap (\base -> base "baikai" "agents.kdl") configBase + userConfig <- maybe (pure Nothing) whenPresent userPath + repoConfig <- whenPresent (".baikai" "agents.kdl") + pure AgentConfigPaths {userConfig, repoConfig} + where + nonEmptyPath dir = if null dir then Nothing else Just dir + whenPresent path = do + present <- doesFileExist path + pure (if present then Just path else Nothing) + +-- | Read one scope's document, if it is configured at all. +loadScope :: AgentConfigScope -> Maybe FilePath -> IO (Either AgentConfigError [Source]) +loadScope _ Nothing = pure (Right []) +loadScope scope (Just path) = do + outcome <- + readKdlSource + (withKdlSourcePath path (kdlSourceOptions (renderAgentConfigScope scope))) + path + pure $ case outcome of + Left problems -> Left (ConfigFileUnreadable path (renderKdlErrorsText problems)) + Right loaded -> Right [loaded] + +-- | Both documents in ascending precedence order, each tagged with the +-- scope that produced it. +loadScopeSources :: AgentConfigPaths -> IO (Either AgentConfigError [(AgentConfigScope, Source)]) +loadScopeSources paths = do + userLoaded <- loadScope UserScope (paths ^. #userConfig) + repoLoaded <- loadScope RepositoryScope (paths ^. #repoConfig) + pure $ do + userSources <- userLoaded + repoSources <- repoLoaded + Right (map ((,) UserScope) userSources <> map ((,) RepositoryScope) repoSources) + +-- | Resolve one named job across all five layers. +-- +-- The environment snapshot is a parameter rather than the real +-- environment so the layer is testable without mutating the process, and +-- the command-line overrides arrive already parsed so this module needs +-- no @optparse-applicative@ wiring. +resolveAgentJob :: + AgentConfigPaths -> + EnvSnapshot -> + [CliOverride] -> + Text -> + IO (Either AgentConfigError (ResolveResult AgentJob)) +resolveAgentJob paths snapshot overrides jobName = do + loaded <- loadScopeSources paths + pure $ do + validateJobName jobName + scoped <- loaded + Right + ( resolve + defaultResolveOptions + -- Lowest precedence first: built-in defaults (named rules + -- inside `agentJobConfig`), the user file, the repository + -- file, the environment, then explicit command-line + -- overrides. This list is the only place the order is + -- expressed, so reordering it is a silent behavior change. + ( map snd scoped + <> [environmentSource (agentEnvBindings jobName) snapshot] + <> cliSources "arguments" overrides + ) + (agentJobConfig jobName) + ) + +-- | The declaration for the operator's policy ceiling. +-- +-- Each setting defaults to the corresponding field of +-- 'defaultAgentCeiling', so an operator file that sets only one of the +-- three still yields a complete ceiling. 'AgentCeiling' hides its +-- constructor, so the value is built by updating the default through +-- its generic field lenses rather than by a record literal. +agentCeilingConfig :: Config AgentCeiling +agentCeilingConfig = + buildCeiling + <$> withDefault + maxCapabilitySetting + ( constantDefault + (RuleName "default-max-capability") + "no operator policy configured" + (defaultAgentCeiling ^. #maxCapability) + ) + <*> withDefault + allowProviderArgsSetting + ( constantDefault + (RuleName "default-allow-provider-args") + "no operator policy configured" + (defaultAgentCeiling ^. #allowProviderArgs) + ) + <*> withDefault + allowedProvidersSetting + ( constantDefault + (RuleName "default-allowed-providers") + "no operator policy configured" + (defaultAgentCeiling ^. #allowedProviders) + ) + where + buildCeiling cap rawArgs providers = + defaultAgentCeiling + & #maxCapability .~ cap + & #allowProviderArgs .~ rawArgs + & #allowedProviders .~ providers + maxCapabilitySetting = + publicSettingWithRenderer + (validKey "policy.max-capability") + "Highest capability any job may request" + capabilityDecoder + renderAgentCapability + allowProviderArgsSetting = + publicShowSetting + (validKey "policy.allow-provider-args") + "Whether jobs may pass raw provider arguments at all" + boolDecoder + allowedProvidersSetting = + publicShowSetting + (validKey "policy.allowed-providers") + "Providers jobs may select" + (scalarOrListDecoder providerDecoder) + +-- | Load the operator's policy ceiling. +-- +-- __The source list below is the entire mechanism.__ It resolves against +-- the user file and nothing else. It must never include the repository +-- file, the environment source, or command-line overrides: a ceiling any +-- lower layer could raise is not a ceiling. If the repository file could +-- set @policy.max-capability@ an untrusted checkout would grant itself +-- whatever it liked, and if a command-line override could, then +-- @--set policy.max-capability=full-access@ would defeat the mechanism +-- outright — which is exactly the flag a compromised automation script +-- would add. Someone \"fixing an inconsistency\" by adding the +-- repository source here would silently remove the security property +-- while every test that does not specifically check it kept passing. +-- +-- With no user file the ceiling is 'defaultAgentCeiling': read-only and +-- edit-workspace are permitted, full access is refused, and raw provider +-- arguments are refused. +loadAgentCeiling :: AgentConfigPaths -> IO (Either AgentConfigError AgentCeiling) +loadAgentCeiling paths = do + userLoaded <- loadScope UserScope (paths ^. #userConfig) + pure $ do + userSources <- userLoaded + let resolved = resolve defaultResolveOptions userSources agentCeilingConfig + case resolved ^. #answer of + Left problems -> + Left + ( ConfigFileUnreadable + (maybe "" id (paths ^. #userConfig)) + (renderCeilingProblems problems) + ) + Right ceiling' -> Right ceiling' + where + renderCeilingProblems problems = + Text.intercalate "; " (map (Text.pack . show) (NonEmpty.toList problems)) + +-- | Refuse a request that exceeds the operator's ceiling. +-- +-- The comparison itself is 'applyAgentCeiling', which is pure and +-- already tested in the core package. This wrapper only converts the +-- violation list into the 'AgentRenderError' the command-line tool +-- reports through, so there is one error type on the path from +-- configuration to rendered command. The request is never clamped to +-- fit. +applyCeilingToJob :: AgentCeiling -> AgentRunRequest -> Either AgentRenderError AgentRunRequest +applyCeilingToJob ceiling' request = + case applyAgentCeiling ceiling' request of + Left violations -> Left (CeilingRejected violations) + Right permitted -> Right permitted + +-- | Every configured job name, sorted, each attributed to the +-- highest-precedence scope defining it. +-- +-- Sorting matters because a script may diff the output. The names come +-- from parsed keys, so they are already valid key segments and cannot +-- contain a dot; 'validateJobName' guards the other direction, where a +-- caller supplies a name. +listAgentJobs :: AgentConfigPaths -> IO (Either AgentConfigError [AgentJobEntry]) +listAgentJobs paths = do + loaded <- loadScopeSources paths + pure (fmap entriesFrom loaded) + where + entriesFrom scoped = + [ AgentJobEntry {name, scope, definingScopes} + | (name, (scope, definingScopes)) <- Map.toAscList (foldl' absorb Map.empty scoped) + ] + absorb seen (scope, loadedSource) = + foldl' + (\acc jobName -> Map.insertWith laterScopeWins jobName (scope, 1) acc) + seen + (jobNamesIn loadedSource) + -- Map.insertWith applies its function as @f new old@, so the later + -- source's scope replaces the earlier one and the count accumulates. + laterScopeWins (newScope, _) (_, count) = (newScope, count + 1) + +-- | The distinct job names one document defines. +-- +-- Distinct per source, not per leaf: one job contributes many leaf keys, +-- and counting them would inflate the defining-scope count. +jobNamesIn :: Source -> [Text] +jobNamesIn loadedSource = + Set.toList + ( Set.fromList + [ jobName + | (key, _) <- sourceLeaves loadedSource, + "jobs" : jobName : _ <- [NonEmpty.toList (keySegments key)] + ] + ) diff --git a/src/Baikai/Agent/Run.hs b/src/Baikai/Agent/Run.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Agent/Run.hs @@ -0,0 +1,767 @@ +{-# LANGUAGE CPP #-} + +-- | Spawn an unattended coding-agent process from a request and an +-- already-rendered command. +-- +-- An unattended run has no terminal and no human present: the coding +-- agent drives its own tool loop, changes files inside directories the +-- caller explicitly authorized, and finishes with a process result. +-- +-- This module renders no command-line flags. Vendor packages own that +-- translation and produce the 'AgentCommand' this module consumes, so +-- the runner never imports a vendor renderer and can be exercised +-- entirely with hand-written argument vectors. +-- +-- A non-zero exit code is a __successful__ run, reported in +-- 'AgentRunResult'. The distinction a caller needs is between \"the tool +-- never started or never finished\" and \"the tool ran and this is what +-- happened\"; a coding agent that attempts its task and fails has run. +module Baikai.Agent.Run + ( runAgentCommand, + + -- * Evidence envelopes + agentRequestEnvelope, + agentConfigurationEnvelope, + + -- * Exposed for testing + timeoutMicros, + ) +where + +import Baikai.Agent + ( AgentCapturedOutput (..), + AgentCommand, + AgentOutputMode (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRunFailure (..), + AgentRunOutcome (..), + AgentRunRequest, + AgentRunResult, + agentRunOutcome, + agentRunResult, + renderAgentProvider, + renderAgentRunFailure, + ) +import Baikai.Api (Api (..)) +import Baikai.Error (BaikaiError, processError, providerError) +import Baikai.Evidence + ( CallStatus (..), + EndpointIdentity (..), + EvidenceRequest, + EvidenceStrength (..), + EvidenceStrictness (..), + ModelCallEvidence (..), + Observed (..), + ThinkingTranslation (..), + TransportKind (..), + baseEvidence, + commitmentDigest, + configurationDigest, + declaredStrength, + newCallId, + ) +import Baikai.Evidence.Build (baikaiPackageVersion, renderEvidenceRefusal) +import Baikai.Evidence.Build qualified as Build +import Baikai.Provider.Cli.Internal + ( ExecutableIdentity (..), + cliResponseEnvelope, + decodeClaudeCliResult, + executableIdentity, + parseCodexJsonlStream, + subprocessStrength, + ) +import Baikai.Usage (Usage) +import Control.Concurrent (forkIO) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Exception + ( SomeAsyncException (..), + SomeException, + displayException, + fromException, + throwIO, + try, + ) +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (void) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.ByteString qualified as BS +import Data.Generics.Labels () +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime) +import Streamly.Data.Stream qualified as Stream +import System.Directory (doesDirectoryExist) +import System.Environment (lookupEnv) +import System.Exit (ExitCode (..)) +import System.IO (Handle, hClose, hFlush, stderr, stdout) +import System.Process qualified as P +import System.Timeout qualified as Timeout +#if defined(BAIKAI_POSIX_SIGNALS) +import System.Posix.Signals qualified as Signals +#endif + +-- | Run one unattended coding-agent command. +-- +-- The request supplies every process-level setting — working directory, +-- timeout, output discipline, output limit, and declared environment +-- variables — while the command supplies the executable, the argument +-- vector, and the prompt transport. 'AgentCommand' deliberately carries +-- no working directory, because Claude Code has no working-directory +-- flag and two copies of a working directory could disagree, which would +-- be a sandbox escape rather than a cosmetic bug. +-- +-- The outcomes: +-- +-- * ran, whatever its exit code — @Right@ carrying that code +-- * working directory absent — @Left WorkingDirMissing@, nothing spawned +-- * a declared variable unset or empty — @Left MissingEnvironment@ +-- * executable not startable — @Left SpawnFailed@ +-- * still running at the deadline — @Left RunTimedOut@, whole process +-- group terminated +-- +-- __Evidence.__ The first argument is the caller's request for a +-- verifiable record of the run. 'Nothing' means they want none, which is +-- what every caller got before this existed and what costs exactly +-- nothing: no digest is computed, no call identifier is generated, no +-- @--version@ probe is spawned, and the returned 'AgentRunOutcome' +-- carries 'Nothing'. That gate matters more here than on a model call, +-- because an unattended run can be a single short invocation and a +-- version probe would double its process count to describe a tool it is +-- about to run anyway. +-- +-- The second argument is what the vendor renderer said it did with the +-- request's reasoning effort. This module never imports a vendor +-- renderer — that independence is why it can be tested with hand-written +-- argument vectors — so it cannot derive the translation and takes it. +-- +-- __What evidence from this surface can and cannot prove.__ The tool's +-- own session identifier, model, and token counts are read out of +-- captured standard output, so they are available only when the run +-- captured output /and/ the tool was configured to print a structured +-- format — @--output-format json@ for @claude@, @--json@ for +-- @codex exec@, neither of which the vendor renderers emit by default. +-- Under 'InheritOutput' there is nothing to read at all. Absent those, +-- every tool-reported field stays 'Unobserved' and the strength stays at +-- 'Baikai.Evidence.EvidenceRequestedOnly'. An operator who needs +-- correlated evidence from an unattended run has to arrange both, and +-- that is a real constraint rather than something to discover from an +-- empty record. +-- +-- A zero exit status never raises the strength. A coding agent that +-- exits zero has demonstrated that it ran; it has not said which model +-- served it. +runAgentCommand :: + Maybe EvidenceRequest -> + ThinkingTranslation -> + AgentRunRequest -> + AgentCommand -> + IO AgentRunOutcome +runAgentCommand evidenceReq translation req cmd + | not (null refusals) = + pure (agentRunOutcome (Left (EvidenceRefused (map renderEvidenceRefusal refusals)))) + | otherwise = do + -- Preconditions first, cheapest and most informative before costliest. + -- Without the directory check a missing directory surfaces as an + -- opaque spawn failure that appears to blame the coding-agent + -- binary. + -- + -- A precondition that fails means nothing started, so there is no + -- run to describe and no evidence is built — which is also why the + -- opt-in check below sits after them rather than before. + dirExists <- doesDirectoryExist (req ^. #workingDir) + if not dirExists + then pure (agentRunOutcome (Left (WorkingDirMissing (req ^. #workingDir)))) + else do + missing <- missingEnvironment (req ^. #envPassthrough) + if not (null missing) + then pure (agentRunOutcome (Left (MissingEnvironment missing))) + else do + start <- getCurrentTime + result <- spawn req cmd + end <- getCurrentTime + case evidenceReq of + Nothing -> pure (agentRunOutcome result) + Just wanted -> do + built <- buildEvidence wanted translation req cmd start end result + pure AgentRunOutcome {outcome = result, evidence = built} + where + refusals = agentEvidenceRefusals evidenceReq translation req + +-- | Every declared variable that is unset or empty, collected rather +-- than short-circuited so an operator fixing a job configuration sees +-- all of them in one run. +missingEnvironment :: [Text] -> IO [Text] +missingEnvironment names = do + states <- traverse check names + pure [name | (name, absent) <- states, absent] + where + check name = do + value <- lookupEnv (Text.unpack name) + pure (name, maybe True null value) + +-- ==================================================================== +-- Strict evidence: the pre-dispatch gate for this surface +-- ==================================================================== + +-- | Every reason this run cannot produce the evidence it was required +-- to, or an empty list. +-- +-- The agent surface never touches 'Baikai.Provider.Registry.ApiProvider' +-- and has no trace sink, so neither of the gates +-- 'Baikai.Evidence.Build.checkEvidenceRequirements' is wired into +-- reaches it. This is its own, built from the same two halves. +-- +-- __Structural, never predictive.__ It refuses when the requirement is +-- impossible with this configuration — an @inherit@ job can observe +-- nothing at all, and a @codex@ job can never learn a model — and stays +-- silent when the requirement is merely uncertain. A run that could have +-- reported what the caller needed and did not says so in its own +-- record's @strength@; failing it after the fact would destroy a report +-- of work that really happened, and the caller has the record to check. +agentEvidenceRefusals :: + Maybe EvidenceRequest -> ThinkingTranslation -> AgentRunRequest -> [Build.EvidenceRefusal] +agentEvidenceRefusals Nothing _ _ = [] +agentEvidenceRefusals (Just wanted) translation req = case wanted ^. #strictness of + EvidenceBestEffort -> [] + EvidenceRequired needed -> + [Build.StrengthUnreachable needed reachable | reachable < needed] + <> [Build.ThinkingWouldDowngrade downgrades | not (null downgrades)] + where + reachable = agentReachableStrength req + downgrades = translation ^. #adjustments + +-- | The highest strength an unattended run with this configuration +-- could reach. +-- +-- Under 'InheritOutput' the agent's bytes go to the operator's terminal +-- and baikai never holds them, so nothing the tool says can be observed +-- and the ceiling is 'EvidenceRequestedOnly' whatever the tool is. That +-- is the single most useful refusal on this surface: an operator who +-- wants a correlated record from an @inherit@ job has misconfigured it, +-- and finding out before the run rather than from an empty record is the +-- whole point. +-- +-- Otherwise it is the tool's own ceiling, the same one +-- 'Baikai.Evidence.declaredStrength' states for that tool's completion +-- transport — read from there rather than restated, so the two surfaces +-- that drive the same binary cannot disagree about what it can tell you. +agentReachableStrength :: AgentRunRequest -> EvidenceStrength +agentReachableStrength req = case req ^. #output of + InheritOutput -> EvidenceRequestedOnly + CaptureOutput -> toolCeiling + TeeOutput -> toolCeiling + where + toolCeiling = declaredStrength $ case req ^. #provider of + AgentClaude -> AnthropicMessagesCli + AgentCodex -> OpenAICompletionsCli + +-- ==================================================================== +-- Evidence +-- ==================================================================== + +-- | Everything that determines what the tool was asked to do, prompt +-- included. This is what 'Baikai.Evidence.commitmentDigest' commits to. +-- +-- The prompt is a named field rather than being left to the argument +-- vector, and that is the whole point. Under 'PromptAsArgument' the +-- prompt is in the vector; under 'PromptOnStdin' — which is what both +-- vendor renderers produce today — it is not in the vector at all. A +-- commitment over the vector alone would give two runs with identical +-- flags and completely different instructions the same digest, which +-- would quietly defeat the one thing this digest exists to do. +agentRequestEnvelope :: AgentCommand -> Value +agentRequestEnvelope cmd = + Aeson.object + [ "argv" Aeson..= argvOf cmd, + "prompt" Aeson..= (cmd ^. #promptText) + ] + +-- | The same request minus its content, for +-- 'Baikai.Evidence.configurationDigest'. +-- +-- The prompt is removed by /value/ rather than by position: under +-- 'PromptAsArgument' it is documented as the last element, but matching +-- on the text cannot be wrong if a renderer ever appends something after +-- it. +-- +-- Note that 'Baikai.Evidence.configurationProjection' currently reduces +-- this to @{}@, because @argv@ is not a name its allow-list admits — so +-- every agent run shares one configuration digest today. That is the +-- allow-list failing in the safe direction and matches what the two +-- subprocess completion providers already do. Building the value +-- prompt-free anyway costs nothing and means that if the projection ever +-- learns about argument vectors, it cannot start leaking the prompt on +-- the transport that puts it there. +agentConfigurationEnvelope :: AgentCommand -> Value +agentConfigurationEnvelope cmd = + Aeson.object ["argv" Aeson..= filter (/= promptArgument) (argvOf cmd)] + where + promptArgument = cmd ^. #promptText + +-- | The executable and its arguments, as a JSON-ready list of strings. +argvOf :: AgentCommand -> [Text] +argvOf cmd = map Text.pack ((cmd ^. #executable) : (cmd ^. #arguments)) + +-- | Assemble the run's evidence, or 'Nothing' when nothing ran. +-- +-- Reached only when the caller opted in, which is what makes the +-- executable probe and the two digests affordable here. +buildEvidence :: + EvidenceRequest -> + ThinkingTranslation -> + AgentRunRequest -> + AgentCommand -> + UTCTime -> + UTCTime -> + Either AgentRunFailure AgentRunResult -> + IO (Maybe ModelCallEvidence) +buildEvidence wanted translation req cmd start end result = + case evidenceStatus result of + Nothing -> pure Nothing + Just (st, failure) -> do + cid <- newCallId + identity <- executableIdentity (cmd ^. #executable) + (session, model, tokens) <- observeToolOutput (req ^. #provider) result + pure . Just $ + baseEvidence + wanted + cid + (agentEndpoint req cmd identity) + (requestedModelOf req) + translation + start + end + st + (commitmentDigest (agentRequestEnvelope cmd)) + (configurationDigest (agentConfigurationEnvelope cmd)) + & #errorInfo .~ failure + & #responseId .~ session + & #observedModel .~ model + & #usage .~ tokens + & #responseCommitment .~ responseCommitmentOf st result tokens + & #strength .~ subprocessStrength session model + +-- | The call status for a run, and the normalized error that must +-- accompany a non-successful one. +-- +-- 'Nothing' means no process ever started, so there is nothing to +-- describe. A timeout is not that case: the tool started, ran, consumed +-- tokens, and may well have changed the working tree before it was +-- killed, which is precisely the run an operator most wants a record of. +evidenceStatus :: + Either AgentRunFailure AgentRunResult -> Maybe (CallStatus, Maybe BaikaiError) +evidenceStatus = \case + Left failure@(RunTimedOut _) -> + Just (CallAborted, Just (providerError (renderAgentRunFailure failure))) + Left _ -> Nothing + Right ran -> case ran ^. #exitCode of + ExitSuccess -> Just (CallSucceeded, Nothing) + ExitFailure code -> + Just + ( CallFailed, + Just (processError code (capturedText (ran ^. #stderr))) + ) + +-- | Where the run went, recorded without a URL, because there is no +-- request and no server. +-- +-- @api@ names this surface rather than a wire protocol. An unattended +-- run speaks none: it writes to a pipe. Leaving the field empty would +-- read as "unknown" when it is in fact "not applicable", and borrowing a +-- 'Baikai.Api.Api' tag would claim an HTTP shape that was never used. +-- +-- @implementationVersion@ is the tool's own reported version rather than +-- this package's, because for this surface the tool /is/ the +-- implementation. +agentEndpoint :: AgentRunRequest -> AgentCommand -> ExecutableIdentity -> EndpointIdentity +agentEndpoint req cmd identity = + EndpointIdentity + { provider = renderAgentProvider (req ^. #provider), + api = "agent_run", + transport = TransportAgentRun, + endpoint = Just (fromMaybe (Text.pack (cmd ^. #executable)) (identity ^. #resolvedPath)), + baikaiVersion = baikaiPackageVersion, + implementationVersion = identity ^. #version + } + +-- | The model the caller asked for. +-- +-- An unattended request may leave the model unset, which means "whatever +-- the tool defaults to". 'Baikai.Evidence.ModelCallEvidence' spells its +-- requested model as plain 'Text' with no way to say "none", so that +-- case is the empty string, and a reader of an agent-run record should +-- take an empty @requested_model@ to mean the tool's own default applied +-- rather than that an empty model id was sent — no @--model@ flag is +-- rendered at all in that case. +requestedModelOf :: AgentRunRequest -> Text +requestedModelOf req = fromMaybe "" (req ^. #modelId) + +-- | What the tool said about its own run, read out of captured standard +-- output. +-- +-- Best-effort by necessity. Neither vendor renderer asks its tool for a +-- structured format — @claude@ gets no @--output-format json@ and +-- @codex exec@ gets no @--json@ — because that would change what an +-- operator watching the run sees. So this parses if the operator +-- configured one through the job's extra arguments, and reports honest +-- silence if not. Under 'InheritOutput' there are no bytes at all. +-- +-- Truncated output is still parsed: @codex@\'s newline-delimited stream +-- yields every complete line, which is more than nothing. Only the +-- response commitment insists on complete output, because a digest of a +-- truncated stream would stand for a response that was never seen whole. +observeToolOutput :: + AgentProvider -> + Either AgentRunFailure AgentRunResult -> + IO (Observed Text, Observed Text, Observed Usage) +observeToolOutput provider result = case capturedBytes result of + Nothing -> pure (Unobserved, Unobserved, Unobserved) + Just bytes -> case provider of + AgentClaude -> pure $ case decodeClaudeCliResult bytes of + Left _ -> (Unobserved, Unobserved, Unobserved) + Right report -> + ( observedOf (report ^. #sessionId), + observedOf (report ^. #reportedModel), + observedOf (report ^. #usage) + ) + AgentCodex -> do + report <- parseCodexJsonlStream (Stream.fromList [bytes]) + pure + ( observedOf (report ^. #threadId), + observedOf (report ^. #reportedModel), + observedOf (report ^. #usage) + ) + +observedOf :: Maybe a -> Observed a +observedOf = maybe Unobserved Observed + +-- | A commitment to what the run produced, on a run that produced it +-- whole. +-- +-- Deliberately over the complete captured standard output rather than +-- over a parsed answer: that is unambiguously what the tool emitted, and +-- anyone holding the run's log can recompute it without knowing whether +-- the tool was configured for a structured format. 'Unobserved' when the +-- output was inherited, truncated, or the run did not finish — a digest +-- of a partial stream is a real-looking value standing for something +-- nobody saw whole. +responseCommitmentOf :: + CallStatus -> + Either AgentRunFailure AgentRunResult -> + Observed Usage -> + Observed Text +responseCommitmentOf CallSucceeded (Right ran) tokens = case ran ^. #stdout of + OutputCaptured bytes -> + Observed + ( commitmentDigest + (cliResponseEnvelope (Text.decodeUtf8Lenient bytes) (usageOr tokens)) + ) + _ -> Unobserved + where + usageOr = \case + Observed u -> u + Unobserved -> mempty +responseCommitmentOf _ _ _ = Unobserved + +-- | The standard output bytes a run captured, complete or truncated. +capturedBytes :: Either AgentRunFailure AgentRunResult -> Maybe BS.ByteString +capturedBytes = \case + Right ran -> case ran ^. #stdout of + OutputCaptured bytes -> Just bytes + OutputTruncated bytes -> Just bytes + OutputNotCaptured -> Nothing + Left _ -> Nothing + +-- | Captured bytes as text, for an error message. Absent capture yields +-- the empty string rather than a claim about what the tool said. +capturedText :: AgentCapturedOutput -> Text +capturedText = \case + OutputCaptured bytes -> Text.decodeUtf8Lenient bytes + OutputTruncated bytes -> Text.decodeUtf8Lenient bytes + OutputNotCaptured -> "" + +spawn :: + AgentRunRequest -> AgentCommand -> IO (Either AgentRunFailure AgentRunResult) +spawn req cmd = do + let spec = + (P.proc (cmd ^. #executable) (cmd ^. #arguments)) + { P.cwd = Just (req ^. #workingDir), + P.std_in = stdinSpec, + P.std_out = outSpec, + P.std_err = outSpec, + -- A coding agent runs shell commands as its own children. + -- Its own group is what lets a timeout reach them. + P.create_group = True, + -- The child inherits the parent's environment in full. Both + -- tools need HOME, PATH, and their own credential files; + -- envPassthrough is a precondition check, not a filter. + P.env = Nothing + } + stdinSpec = case cmd ^. #promptTransport of + PromptOnStdin -> P.CreatePipe + -- The prompt is already the last element of the argument vector. + -- Supplying standard input as well is specifically harmful for + -- Codex, which appends piped input as a separate block, + -- so the agent would receive the prompt twice. + PromptAsArgument -> P.NoStream + outSpec = case req ^. #output of + InheritOutput -> P.Inherit + CaptureOutput -> P.CreatePipe + TeeOutput -> P.CreatePipe + start <- getCurrentTime + outcome <- trySync (P.withCreateProcess spec (consume req cmd start)) + case outcome of + Right result -> pure result + Left e -> + pure + ( Left + ( SpawnFailed + (cmd ^. #executable) + (Text.pack (displayException e)) + ) + ) + +consume :: + AgentRunRequest -> + AgentCommand -> + UTCTime -> + Maybe Handle -> + Maybe Handle -> + Maybe Handle -> + P.ProcessHandle -> + IO (Either AgentRunFailure AgentRunResult) +consume req cmd start mIn mOut mErr ph = do + case (cmd ^. #promptTransport, mIn) of + (PromptOnStdin, Just hIn) -> writePromptAsync hIn (cmd ^. #promptText) + _ -> pure () + -- Start draining both streams *before* waiting for the process. An + -- operating-system pipe holds a bounded amount of data, typically 64 + -- kilobytes; if the parent waits for the child to exit before reading, + -- a child that writes more than that blocks on write while the parent + -- blocks on wait and neither proceeds. Waiting first looks more + -- natural and is the classic deadlock — do not "simplify" it. + -- + -- Both drains are forked, rather than one of them running here, so + -- that the timeout below can fire while a stream is still open. A + -- drain on this thread would block until the child exits, which would + -- make the timeout unreachable in the two capturing modes. + outVar <- forkDrain limit teeOut mOut + errVar <- forkDrain limit teeErr mErr + waited <- waitWithTimeout (timeoutMicros (req ^. #timeout)) ph + case waited of + Nothing -> do + terminateGroup ph + -- Report the configured limit rather than the measured elapsed + -- time: the caller asked for a limit and wants to be told which + -- one was hit, and the elapsed time is slightly larger because of + -- the grace period. + pure (Left (RunTimedOut (maybe 0 id (req ^. #timeout)))) + Just code -> do + capturedOut <- takeMVar outVar + capturedErr <- takeMVar errVar + end <- getCurrentTime + pure + ( Right + ( agentRunResult (req ^. #provider) code (diffUTCTime end start) + & #stdout .~ capturedOut + & #stderr .~ capturedErr + ) + ) + where + limit = req ^. #outputLimit + (teeOut, teeErr) = case req ^. #output of + TeeOutput -> (Just stdout, Just stderr) + InheritOutput -> (Nothing, Nothing) + CaptureOutput -> (Nothing, Nothing) + +-- | Write the prompt and close the handle, on its own thread. +-- +-- Closing is what signals end-of-input: without it both tools wait for +-- more prompt text and the run hangs until its timeout, a failure that +-- looks like a slow model rather than a bug. +-- +-- The write is forked because a child that never reads its standard +-- input would otherwise block this thread before it could reach the +-- timeout. Failures are ignored: a child that exits without reading its +-- prompt makes the write fail, and that is the child's business, not a +-- reason to report the run as unstartable. +writePromptAsync :: Handle -> Text -> IO () +writePromptAsync h promptBody = + void . forkIO . void $ + (try :: IO () -> IO (Either SomeException ())) $ do + -- Encode explicitly rather than using hPutStr, whose behavior + -- depends on the handle's locale encoding and would corrupt a + -- non-ASCII prompt on a machine with a non-UTF-8 locale. + BS.hPut h (Text.encodeUtf8 promptBody) + hClose h + +-- | Drain one stream on its own thread, delivering the result through +-- an 'MVar'. A stream that was inherited rather than piped has no +-- handle and yields 'OutputNotCaptured' immediately. +forkDrain :: + Maybe Int -> Maybe Handle -> Maybe Handle -> IO (MVar AgentCapturedOutput) +forkDrain limit tee source = do + var <- newEmptyMVar + case source of + Nothing -> putMVar var OutputNotCaptured + Just h -> + void . forkIO $ do + -- A plain 'try' rather than 'trySync' here on purpose: nothing + -- delivers an asynchronous exception to this thread, and + -- re-throwing one would leave the MVar empty and hang whoever + -- takes it. A drain that fails yields no capture rather than + -- propagating; the handles are closed under us on timeout, and + -- that is a normal end rather than an error. + result <- try (drain limit tee h) :: IO (Either SomeException AgentCapturedOutput) + putMVar var (either (const OutputNotCaptured) id result) + pure var + +-- | Read a stream to the end, retaining at most the byte limit. +-- +-- Once the retained bytes reach the limit the excess is read and +-- discarded rather than the pipe being closed early: closing the read +-- end makes the child's next write fail, which for a coding agent +-- usually means a crash and a confusing error attributed to the tool +-- rather than to the limit. +-- +-- A 'Nothing' limit retains everything. That is unbounded by request; +-- the configuration layer supplies a default limit so an operator who +-- says nothing still gets a bound. +drain :: Maybe Int -> Maybe Handle -> Handle -> IO AgentCapturedOutput +drain limit tee h = go [] 0 False + where + go chunks retained dropped = do + chunk <- BS.hGetSome h chunkSize + if BS.null chunk + then + let bytes = BS.concat (reverse chunks) + in pure (if dropped then OutputTruncated bytes else OutputCaptured bytes) + else do + echo chunk + case limit of + Nothing -> go (chunk : chunks) (retained + BS.length chunk) dropped + Just cap + | retained >= cap -> go chunks retained True + | otherwise -> do + let kept = BS.take (cap - retained) chunk + go + (kept : chunks) + (retained + BS.length kept) + (dropped || BS.length kept < BS.length chunk) + -- Flush per chunk: an unattended run can take many minutes, and an + -- operator watching a log wants progress rather than a silent block + -- that appears all at once at the end. + echo chunk = case tee of + Nothing -> pure () + Just target -> BS.hPut target chunk >> hFlush target + +-- | Chunk size for pipe reads, matching the batch CLI provider in +-- @baikai-openai@. +chunkSize :: Int +chunkSize = 4096 + +-- | Convert a timeout in seconds to the microseconds +-- 'System.Timeout.timeout' expects. +-- +-- Zero and negative durations mean __no timeout__ rather than \"expire +-- immediately\": a configuration file saying @timeout 0@ almost +-- certainly means unset, and immediately killing every run would be a +-- baffling failure. A duration too large to fit an 'Int' likewise means +-- no timeout, because a saturated deadline would be indistinguishable +-- from a much shorter one. +timeoutMicros :: Maybe NominalDiffTime -> Maybe Int +timeoutMicros Nothing = Nothing +timeoutMicros (Just seconds) + | seconds <= 0 = Nothing + | micros > toInteger (maxBound :: Int) = Nothing + | otherwise = Just (fromInteger micros) + where + micros = ceiling (seconds * 1000000) + +-- | Wait for the child, bounded by the timeout when there is one. +-- +-- Only the wait is wrapped, never the whole spawn: a timeout firing +-- mid-drain would lose the output collected so far and the chance to +-- terminate cleanly. +waitWithTimeout :: Maybe Int -> P.ProcessHandle -> IO (Maybe ExitCode) +waitWithTimeout Nothing ph = Just <$> P.waitForProcess ph +waitWithTimeout (Just micros) ph = Timeout.timeout micros (P.waitForProcess ph) + +-- | How long a timed-out run is given to clean up after the interrupt +-- before it is terminated outright. Long enough for a coding agent to +-- flush its state, short enough that an automated pipeline is not left +-- waiting on a tool that is not going to stop. +gracePeriodMicros :: Int +gracePeriodMicros = 2000000 + +-- | Signal the child's whole process group, escalating from interrupt +-- to terminate. +-- +-- Signalling the group rather than the child is the point: a coding +-- agent runs shell commands as its own children, and terminating only +-- the agent leaves those grandchildren running, holding the working tree +-- open and possibly still writing to it — which for an unattended run a +-- script is about to inspect and commit is a correctness problem rather +-- than untidiness. +-- +-- The escalation to a group-wide terminate happens whether or not the +-- interrupt stopped the agent itself, and that is not belt-and-braces. +-- POSIX requires a non-interactive shell to set @SIGINT@ to /ignored/ in +-- the background commands it starts, so an interrupt that kills the +-- agent outright can leave the very children this is meant to reach +-- still running. Only a group-wide terminate collects them. +-- +-- Every signal is wrapped because a process that has already exited +-- makes these throw, and a race between the timeout firing and the +-- process exiting on its own is normal rather than exceptional. The +-- final wait always runs so the child is reaped instead of lingering as +-- a zombie. +terminateGroup :: P.ProcessHandle -> IO () +terminateGroup ph = do + -- Read the identifier before any wait: 'P.getPid' yields 'Nothing' + -- once the process has been reaped, and the group is named after its + -- leader. + leader <- P.getPid ph + _ <- trySync (P.interruptProcessGroupOf ph) + stopped <- Timeout.timeout gracePeriodMicros (P.waitForProcess ph) + _ <- trySync (terminateProcessGroup leader) + case stopped of + Just _ -> pure () + Nothing -> do + _ <- trySync (P.terminateProcess ph) + _ <- trySync (P.waitForProcess ph) + pure () + +-- | Send @SIGTERM@ to a whole process group, named by its leader. +-- +-- The @process@ package offers a group-wide /interrupt/ but no +-- group-wide /terminate/, so this reaches for the POSIX signal API +-- directly. On a platform without it the group's leader has already +-- been interrupted and is terminated by the caller; only survivors that +-- ignored the interrupt are missed. +terminateProcessGroup :: Maybe P.Pid -> IO () +#if defined(BAIKAI_POSIX_SIGNALS) +terminateProcessGroup Nothing = pure () +terminateProcessGroup (Just leader) = + Signals.signalProcessGroup Signals.sigTERM leader +#else +terminateProcessGroup _ = pure () +#endif + +-- | Catch synchronous exceptions while re-throwing asynchronous ones. +-- +-- Swallowing an asynchronous exception would break the timeout, whose +-- own exception is delivered asynchronously to this thread. +trySync :: IO a -> IO (Either SomeException a) +trySync action = do + result <- try action + case result of + Left e + | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) -> + throwIO e + | otherwise -> pure (Left e) + Right a -> pure (Right a) diff --git a/test/CliTests.hs b/test/CliTests.hs new file mode 100644 --- /dev/null +++ b/test/CliTests.hs @@ -0,0 +1,864 @@ +-- | Tests for the @baikai agent@ command-line surface. +-- +-- The centerpiece is the @sync-keiro-dsl@ fixture: a fake @claude@ +-- executable, a real KDL job file, and the real command-line entry +-- point, asserting the exact argument vector and the exact bytes the +-- fake received on standard input. No model is ever called and no +-- coding-agent binary is ever required. +-- +-- Every test builds an 'AgentConfigPaths' explicitly and drives +-- 'runAgentCliWithPaths' rather than 'runAgentCli'. A developer with a +-- real @~\/.config\/baikai\/agents.kdl@ would otherwise get different +-- results from a clean machine, and the failure would be baffling. +module CliTests (cliTests) where + +import Baikai.Agent (AgentCommand, agentRunRequest) +import Baikai.Agent.Cli + ( AgentCliCommand (..), + AgentCliOptions (..), + AgentCliRun, + PromptSource (..), + agentCliParserInfo, + configExitCode, + readPromptSource, + refusedExitCode, + renderJobCommand, + runAgentCliWithPaths, + usageExitCode, + ) +import Baikai.Agent.Config (AgentConfigPaths (..), AgentJob, resolveAgentJob) +import Baikai.Evidence (EvidenceStrength (..), evidenceSchemaVersion) +import Control.Lens ((^.)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import GHC.IO.Handle (hDuplicate, hDuplicateTo) +import Options.Applicative qualified as Options +import Settei.Env (EnvSnapshot, envSnapshot) +import Settei.Key (parseKey) +import Settei.Optparse (cliOverride) +import System.Directory + ( doesFileExist, + getPermissions, + setOwnerExecutable, + setPermissions, + ) +import System.Environment (setEnv) +import System.FilePath (()) +import System.IO (IOMode (..), hClose, openFile, stdin) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +cliTests :: TestTree +cliTests = + testGroup + "Baikai.Agent.Cli" + [ testGroup + "provider dispatch" + [ dispatchesToClaudeTest, + dispatchesToCodexTest, + honorsExecutableOverrideTest + ], + testGroup + "agent list" + [ listsNothingWhenUnconfiguredTest, + listsConfiguredJobsTest + ], + testGroup + "agent show" + [ showExplainsWithProvenanceTest, + showRedactsProviderArgumentsTest, + showPrintsConfigurationBeforeRefusalTest, + showReportsAnUnreadableFileTest + ], + testGroup + "the sync-keiro-dsl fixture" + [ syncKeiroDslRunsTest, + swappingTheProviderIsAConfigurationChangeTest, + swappingTheProviderRefusesATheToolListTest, + theCeilingRefusesBeforeAnythingIsStartedTest + ], + testGroup + "agent run" + [ propagatesTheAgentExitCodeTest, + inheritModeCapturesNothingTest, + reportsAMissingExecutableTest, + refusesAnEmptyPromptTest, + writesTheEvidenceFileTest, + writesNoEvidenceFileByDefaultTest, + refusesAnImpossibleEvidenceRequirementTest + ], + testGroup + "prompts" + [ readsThePromptFromStandardInputTest, + readsThePromptFromAFileTest, + rejectsAMissingPromptFileTest + ], + testGroup + "the parser" + [ twoPromptSourcesAreAUsageErrorTest, + parsesTheMotivatingInvocationTest + ] + ] + +-- -------------------------------------------------------------------- +-- Harness +-- -------------------------------------------------------------------- + +noEnvironment :: EnvSnapshot +noEnvironment = envSnapshot [] + +-- | Options naming one command, with no overrides and neither +-- configuration scope. Tests supply the paths separately, so the two +-- path fields stay 'Nothing' here and are never consulted. +options :: AgentCliCommand -> AgentCliOptions +options command = + AgentCliOptions + { command, + overrides = [], + userConfig = Nothing, + repoConfig = Nothing, + jsonOutput = False, + evidenceFile = Nothing, + runId = Nothing, + requiredEvidence = Nothing + } + +withOverride :: Text -> Text -> AgentCliOptions -> AgentCliOptions +withOverride key value opts = + opts + { overrides = + (opts ^. #overrides) <> [cliOverride (either (error . show) id (parseKey key)) value] + } + +-- | Demand a strength the run must reach, or be refused. +requiringEvidence :: EvidenceStrength -> AgentCliOptions -> AgentCliOptions +requiringEvidence needed opts = opts {requiredEvidence = Just needed} + +-- | Ask for evidence, naming both a destination and an outer run. +withEvidence :: FilePath -> Text -> AgentCliOptions -> AgentCliOptions +withEvidence path outerRun opts = + opts {evidenceFile = Just path, runId = Just outerRun} + +-- | Paths naming only a repository document, which is the normal state +-- for an operator who has written no policy file. +repositoryOnly :: FilePath -> AgentConfigPaths +repositoryOnly path = AgentConfigPaths {userConfig = Nothing, repoConfig = Just path} + +-- | Write a KDL document into a temporary directory and hand back the +-- workspace directory and the document's path. +withWorkspace :: (FilePath -> IO a) -> IO a +withWorkspace = withSystemTempDirectory "baikai-agent-cli" + +writeDocument :: FilePath -> String -> Text -> IO FilePath +writeDocument dir name body = do + let path = dir name + TextIO.writeFile path body + pure path + +-- | Write a tiny shell script and make it executable. Every behavior +-- these tests need from a coding agent is a few lines of @sh@, which is +-- what keeps the suite free of any coding-agent binary, any +-- authentication, and any model. +writeFakeAgent :: FilePath -> String -> Text -> IO FilePath +writeFakeAgent dir name body = do + path <- writeDocument dir name body + perms <- getPermissions path + setPermissions path (setOwnerExecutable True perms) + pure path + +-- | A fake agent that records its argument vector and its standard +-- input into the files named by two environment variables, then behaves +-- like a coding agent that succeeded. +recordingAgent :: Text -> Text -> Text +recordingAgent argvVariable stdinVariable = + Text.unlines + [ "#!/bin/sh", + "printf '%s\\n' \"$@\" > \"$" <> argvVariable <> "\"", + "cat > \"$" <> stdinVariable <> "\"", + "echo 'reconciled the lexical surface'" + ] + +-- | The recorded argument vector, one element per line. +recordedArgv :: FilePath -> IO [Text] +recordedArgv path = Text.lines <$> TextIO.readFile path + +run :: AgentConfigPaths -> AgentCliOptions -> IO AgentCliRun +run paths = runAgentCliWithPaths paths noEnvironment + +-- | The prompt the fixture sends: multi-line, with a dash-leading line +-- and a non-ASCII character, because the transport decision exists to +-- make exactly that safe. +fixturePrompt :: Text +fixturePrompt = + Text.unlines + [ "--reconcile the lexical surface against the grammar", + "réconcilier la grammaire — 文法", + "leave the test gate to the script" + ] + +-- -------------------------------------------------------------------- +-- Provider dispatch +-- -------------------------------------------------------------------- + +-- | Resolve one job from a document, failing the test with the real +-- diagnosis. +resolveOne :: Text -> Text -> IO AgentJob +resolveOne document jobName = + withWorkspace $ \dir -> do + path <- writeDocument dir "repo.kdl" document + loaded <- resolveAgentJob (repositoryOnly path) noEnvironment [] jobName + case loaded of + Left problem -> assertFailure ("loading failed: " <> show problem) + Right resolved -> case resolved ^. #answer of + Left problems -> assertFailure ("resolution failed: " <> show problems) + Right job -> pure job + +minimalJob :: Text -> Text -> Text +minimalJob provider extra = + Text.unlines + [ "jobs {", + " demo {", + " provider \"" <> provider <> "\"", + " working-dir \"/tmp\"", + extra, + " safety { capability \"edit-workspace\" }", + " }", + "}" + ] + +renderedFor :: Text -> Text -> IO AgentCommand +renderedFor provider extra = do + job <- resolveOne (minimalJob provider extra) "demo" + let request = agentRunRequest (job ^. #provider) (job ^. #workingDir) "a prompt" + case renderJobCommand job request of + Left refusal -> assertFailure ("expected a rendered command: " <> show refusal) + Right (command, _) -> pure command + +dispatchesToClaudeTest :: TestTree +dispatchesToClaudeTest = + testCase "a claude job renders a claude argument vector" $ do + command <- renderedFor "claude" "" + take 1 (command ^. #arguments) @?= ["-p"] + command ^. #executable @?= "claude" + +dispatchesToCodexTest :: TestTree +dispatchesToCodexTest = + testCase "a codex job renders a codex argument vector" $ do + command <- renderedFor "codex" "" + take 1 (command ^. #arguments) @?= ["exec"] + command ^. #executable @?= "codex" + +honorsExecutableOverrideTest :: TestTree +honorsExecutableOverrideTest = + testCase "the job's executable override becomes the program" $ do + command <- renderedFor "claude" " executable \"/opt/bin/claude\"" + command ^. #executable @?= "/opt/bin/claude" + +-- -------------------------------------------------------------------- +-- agent list +-- -------------------------------------------------------------------- + +listsNothingWhenUnconfiguredTest :: TestTree +listsNothingWhenUnconfiguredTest = + testCase "an empty list exits 0 and keeps standard output empty" $ do + -- An empty list is a normal state, not an error, and a script + -- piping the output should never have to filter prose out of data. + finished <- run AgentConfigPaths {userConfig = Nothing, repoConfig = Nothing} (options AgentList) + finished ^. #exitCode @?= 0 + finished ^. #standardOutput @?= "" + assertBool + ("the note explains the empty list: " <> Text.unpack (finished ^. #standardError)) + ("no jobs are configured" `Text.isInfixOf` (finished ^. #standardError)) + +listsConfiguredJobsTest :: TestTree +listsConfiguredJobsTest = + testCase "configured jobs are listed, sorted, with their scope" $ + withWorkspace $ \dir -> do + path <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " zebra { provider \"claude\" }", + " alpha { provider \"codex\" }", + "}" + ] + ) + finished <- run (repositoryOnly path) (options AgentList) + finished ^. #exitCode @?= 0 + let listed = Text.lines (finished ^. #standardOutput) + map (take 1 . Text.words) listed @?= [["alpha"], ["zebra"]] + assertBool + ("the scope is named: " <> Text.unpack (finished ^. #standardOutput)) + ("repository configuration" `Text.isInfixOf` (finished ^. #standardOutput)) + +-- -------------------------------------------------------------------- +-- agent show +-- -------------------------------------------------------------------- + +showExplainsWithProvenanceTest :: TestTree +showExplainsWithProvenanceTest = + testCase "show names each value's file and line, and the rendered command" $ + -- Improvement-request acceptance criterion 5. settei's own + -- renderResolutionText drops the location, so this is also the test + -- that the command-line layer walks the report itself. + withWorkspace $ \dir -> do + path <- writeDocument dir "repo.kdl" (minimalJob "claude" "") + finished <- run (repositoryOnly path) (options (AgentShow "demo")) + let output = finished ^. #standardOutput + finished ^. #exitCode @?= 0 + assertBool + ("the provider is named: " <> Text.unpack output) + ("jobs.demo.provider" `Text.isInfixOf` output && "claude" `Text.isInfixOf` output) + assertBool + ("the file is cited: " <> Text.unpack output) + (Text.pack path `Text.isInfixOf` output) + assertBool + ("a line and column follow the path: " <> Text.unpack output) + ((Text.pack path <> ":3:") `Text.isInfixOf` output) + assertBool + ("the ceiling is shown: " <> Text.unpack output) + ("max-capability" `Text.isInfixOf` output) + assertBool + ("the rendered vector is shown: " <> Text.unpack output) + ("--permission-mode acceptEdits" `Text.isInfixOf` output) + assertBool + ("the prompt transport is shown: " <> Text.unpack output) + ("prompt transport: standard input" `Text.isInfixOf` output) + +showRedactsProviderArgumentsTest :: TestTree +showRedactsProviderArgumentsTest = + testCase "show never prints a raw provider argument" $ + -- provider-args is the one setting an operator could write a + -- credential into. It must not appear in the effective + -- configuration and it must not appear in the rendered argument + -- vector either, which is the easier of the two to overlook. + withWorkspace $ + \dir -> do + userPath <- + writeDocument + dir + "user.kdl" + (Text.unlines ["policy {", " allow-provider-args #true", "}"]) + repoPath <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " demo {", + " provider \"claude\"", + " working-dir \"/tmp\"", + " safety {", + " capability \"edit-workspace\"", + " provider-args \"--api-key\" \"sk-not-a-real-key\"", + " }", + " }", + "}" + ] + ) + finished <- + run + AgentConfigPaths {userConfig = Just userPath, repoConfig = Just repoPath} + (options (AgentShow "demo")) + let output = finished ^. #standardOutput <> finished ^. #standardError + finished ^. #exitCode @?= 0 + assertBool + ("the credential does not appear: " <> Text.unpack output) + (not ("sk-not-a-real-key" `Text.isInfixOf` output)) + assertBool + ("the redaction marker appears: " <> Text.unpack output) + ("" `Text.isInfixOf` output) + assertBool + ("the setting is still named: " <> Text.unpack output) + ("jobs.demo.safety.provider-args" `Text.isInfixOf` output) + +showPrintsConfigurationBeforeRefusalTest :: TestTree +showPrintsConfigurationBeforeRefusalTest = + testCase "a refused job still shows its configuration" $ + -- A job the ceiling refuses is precisely the case an operator most + -- needs `show` for; printing nothing would hide it. + withWorkspace $ \dir -> do + path <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " demo {", + " provider \"claude\"", + " working-dir \"/tmp\"", + " safety { capability \"full-access\" }", + " }", + "}" + ] + ) + finished <- run (repositoryOnly path) (options (AgentShow "demo")) + finished ^. #exitCode @?= refusedExitCode + assertBool + ("the configuration was printed: " <> Text.unpack (finished ^. #standardOutput)) + ("jobs.demo.safety.capability" `Text.isInfixOf` (finished ^. #standardOutput)) + assertBool + ("the refusal names both values: " <> Text.unpack (finished ^. #standardError)) + ( "full-access" `Text.isInfixOf` (finished ^. #standardError) + && "edit-workspace" `Text.isInfixOf` (finished ^. #standardError) + ) + +showReportsAnUnreadableFileTest :: TestTree +showReportsAnUnreadableFileTest = + testCase "a malformed document exits with the configuration code" $ + withWorkspace $ \dir -> do + path <- writeDocument dir "repo.kdl" "jobs {\n demo {\n provider \"claude\"\n" + finished <- run (repositoryOnly path) (options (AgentShow "demo")) + finished ^. #exitCode @?= configExitCode + assertBool + ("the file is named: " <> Text.unpack (finished ^. #standardError)) + (Text.pack path `Text.isInfixOf` (finished ^. #standardError)) + +-- -------------------------------------------------------------------- +-- The sync-keiro-dsl fixture +-- -------------------------------------------------------------------- + +-- | The translation of the motivating script's launch into +-- configuration. +-- +-- The real consumer would use @inherit@, and the migration guide shows +-- it that way; this fixture uses @capture@ so the test can observe the +-- output. The extra directory is deliberately __not__ here: it arrives +-- on the command line as a single @--set@, which is what makes the +-- "no provider flags in the script" claim testable. +syncKeiroDslDocument :: FilePath -> FilePath -> Text +syncKeiroDslDocument workingDir executable = + Text.unlines + [ "jobs {", + " sync-keiro-dsl {", + " provider \"claude\"", + " working-dir \"" <> Text.pack workingDir <> "\"", + " executable \"" <> Text.pack executable <> "\"", + " output \"capture\"", + " env-requires \"BAIKAI_TEST_CLAUDE_ARGV\" \"BAIKAI_TEST_CLAUDE_STDIN\"", + " safety {", + " capability \"edit-workspace\"", + " allowed-tools \"Read\" \"Write\" \"Edit\" \"Glob\" \"Grep\" \"Bash\" \"Skill\" \"TodoWrite\"", + " }", + " }", + "}" + ] + +syncKeiroDslRunsTest :: TestTree +syncKeiroDslRunsTest = + testCase "THE MOTIVATING LAUNCH RUNS WITH NO PROVIDER FLAGS IN THE INVOCATION" $ + -- The initiative's central acceptance criterion. The invocation + -- below names a job and one --set and nothing else; every Claude + -- flag in the asserted vector came from configuration. + withWorkspace $ \dir -> do + let argvRecord = dir "argv" + stdinRecord = dir "stdin" + keiroPath = dir "keiro" + setEnv "BAIKAI_TEST_CLAUDE_ARGV" argvRecord + setEnv "BAIKAI_TEST_CLAUDE_STDIN" stdinRecord + executable <- + writeFakeAgent + dir + "claude" + (recordingAgent "BAIKAI_TEST_CLAUDE_ARGV" "BAIKAI_TEST_CLAUDE_STDIN") + promptPath <- writeDocument dir "prompt.txt" fixturePrompt + configPath <- writeDocument dir "repo.kdl" (syncKeiroDslDocument dir executable) + finished <- + run + (repositoryOnly configPath) + ( withOverride + "extra-dirs" + (Text.pack keiroPath) + (options (AgentRun "sync-keiro-dsl" (PromptFile promptPath))) + ) + finished ^. #exitCode @?= 0 + argv <- recordedArgv argvRecord + -- The whole vector, not individual members: a test that checks + -- only membership would pass with an extra flag nobody asked for. + argv + @?= [ "-p", + "--no-session-persistence", + "--permission-mode", + "acceptEdits", + "--allowedTools", + "Read,Write,Edit,Glob,Grep,Bash,Skill,TodoWrite", + "--add-dir", + Text.pack keiroPath + ] + delivered <- TextIO.readFile stdinRecord + delivered @?= fixturePrompt + assertBool + ("the agent's answer is on standard output: " <> Text.unpack (finished ^. #standardOutput)) + ("reconciled the lexical surface" `Text.isInfixOf` (finished ^. #standardOutput)) + +swappingTheProviderIsAConfigurationChangeTest :: TestTree +swappingTheProviderIsAConfigurationChangeTest = + testCase "changing only the provider line moves the run to codex" $ + -- The initiative's headline claim. The tool allow-list is removed + -- too, because codex exec has no such flag; the next test covers + -- what happens when it is left in. + withWorkspace $ \dir -> do + let argvRecord = dir "argv" + stdinRecord = dir "stdin" + setEnv "BAIKAI_TEST_CODEX_ARGV" argvRecord + setEnv "BAIKAI_TEST_CODEX_STDIN" stdinRecord + executable <- + writeFakeAgent + dir + "codex" + (recordingAgent "BAIKAI_TEST_CODEX_ARGV" "BAIKAI_TEST_CODEX_STDIN") + promptPath <- writeDocument dir "prompt.txt" fixturePrompt + configPath <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " sync-keiro-dsl {", + " provider \"codex\"", + " working-dir \"" <> Text.pack dir <> "\"", + " executable \"" <> Text.pack executable <> "\"", + " output \"capture\"", + " safety { capability \"edit-workspace\" }", + " }", + "}" + ] + ) + finished <- + run + (repositoryOnly configPath) + (options (AgentRun "sync-keiro-dsl" (PromptFile promptPath))) + finished ^. #exitCode @?= 0 + argv <- recordedArgv argvRecord + argv + @?= [ "exec", + "--sandbox", + "workspace-write", + "--cd", + Text.pack dir, + "--skip-git-repo-check", + "--ephemeral" + ] + delivered <- TextIO.readFile stdinRecord + delivered @?= fixturePrompt + +swappingTheProviderRefusesATheToolListTest :: TestTree +swappingTheProviderRefusesATheToolListTest = + testCase "keeping the tool allow-list on codex is refused, loudly" $ + -- The honest half of "switching providers is a configuration + -- change": where it is not, you are told rather than silently given + -- weaker isolation. + withWorkspace $ \dir -> do + let argvRecord = dir "argv" + executable <- writeFakeAgent dir "codex" "#!/bin/sh\ntouch \"$1\"\n" + promptPath <- writeDocument dir "prompt.txt" fixturePrompt + configPath <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " sync-keiro-dsl {", + " provider \"codex\"", + " working-dir \"" <> Text.pack dir <> "\"", + " executable \"" <> Text.pack executable <> "\"", + " safety {", + " capability \"edit-workspace\"", + " allowed-tools \"Read\" \"Write\"", + " }", + " }", + "}" + ] + ) + finished <- + run + (repositoryOnly configPath) + (options (AgentRun "sync-keiro-dsl" (PromptFile promptPath))) + finished ^. #exitCode @?= refusedExitCode + assertBool + ("the message names the sandbox alternative: " <> Text.unpack (finished ^. #standardError)) + ("sandbox" `Text.isInfixOf` (finished ^. #standardError)) + started <- doesFileExist argvRecord + assertBool "nothing was started" (not started) + +theCeilingRefusesBeforeAnythingIsStartedTest :: TestTree +theCeilingRefusesBeforeAnythingIsStartedTest = + testCase "A REFUSED JOB NEVER REACHES PROCESS CREATION" $ + -- Improvement-request acceptance criterion 6. The assertion that + -- carries the weight is the last one: the fake's record file does + -- not exist, so the fake was never run. + withWorkspace $ \dir -> do + let argvRecord = dir "argv" + executable <- + writeFakeAgent dir "claude" ("#!/bin/sh\ntouch '" <> Text.pack argvRecord <> "'\n") + promptPath <- writeDocument dir "prompt.txt" fixturePrompt + configPath <- + writeDocument + dir + "repo.kdl" + ( Text.unlines + [ "jobs {", + " sync-keiro-dsl {", + " provider \"claude\"", + " working-dir \"" <> Text.pack dir <> "\"", + " executable \"" <> Text.pack executable <> "\"", + " safety { capability \"full-access\" }", + " }", + "}" + ] + ) + finished <- + run + (repositoryOnly configPath) + (options (AgentRun "sync-keiro-dsl" (PromptFile promptPath))) + finished ^. #exitCode @?= refusedExitCode + assertBool + ("the refusal names both values: " <> Text.unpack (finished ^. #standardError)) + ( "full-access" `Text.isInfixOf` (finished ^. #standardError) + && "edit-workspace" `Text.isInfixOf` (finished ^. #standardError) + ) + started <- doesFileExist argvRecord + assertBool "the executable was never invoked" (not started) + +-- -------------------------------------------------------------------- +-- agent run +-- -------------------------------------------------------------------- + +-- | A job rooted in the workspace, running the given script, capturing +-- output unless told otherwise. +scriptedJob :: FilePath -> FilePath -> Text -> Text +scriptedJob dir executable outputMode = + Text.unlines + [ "jobs {", + " demo {", + " provider \"claude\"", + " working-dir \"" <> Text.pack dir <> "\"", + " executable \"" <> Text.pack executable <> "\"", + " output \"" <> outputMode <> "\"", + " safety { capability \"edit-workspace\" }", + " }", + "}" + ] + +propagatesTheAgentExitCodeTest :: TestTree +propagatesTheAgentExitCodeTest = + testCase "the agent's own exit code passes through unchanged" $ + -- The motivating script ends its launch with `|| die`, and a script + -- that wants to tell "the agent failed the task" from "the tool + -- could not start" needs the codes to stay separate. + withWorkspace $ \dir -> do + executable <- writeFakeAgent dir "claude" "#!/bin/sh\ncat > /dev/null\nexit 3\n" + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "capture") + finished <- + run (repositoryOnly configPath) (options (AgentRun "demo" (PromptInline "do the thing"))) + finished ^. #exitCode @?= 3 + -- Nothing extra is narrated: the agent has already explained + -- itself on its own standard error. + finished ^. #standardError @?= "" + +inheritModeCapturesNothingTest :: TestTree +inheritModeCapturesNothingTest = + testCase "inherit mode leaves the record empty" $ + -- The agent's line goes to the test runner's own output, which is + -- expected: under inherit the child writes to the real streams and + -- bypasses AgentCliRun entirely. + withWorkspace $ \dir -> do + executable <- + writeFakeAgent dir "claude" "#!/bin/sh\ncat > /dev/null\necho 'inherited line'\n" + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "inherit") + finished <- + run (repositoryOnly configPath) (options (AgentRun "demo" (PromptInline "do the thing"))) + finished ^. #exitCode @?= 0 + finished ^. #standardOutput @?= "" + finished ^. #standardError @?= "" + +reportsAMissingExecutableTest :: TestTree +reportsAMissingExecutableTest = + testCase "a missing coding-agent binary exits 69" $ + withWorkspace $ \dir -> do + configPath <- + writeDocument dir "repo.kdl" (scriptedJob dir (dir "not-installed") "capture") + finished <- + run (repositoryOnly configPath) (options (AgentRun "demo" (PromptInline "do the thing"))) + finished ^. #exitCode @?= 69 + assertBool + ("the missing program is named: " <> Text.unpack (finished ^. #standardError)) + ("not-installed" `Text.isInfixOf` (finished ^. #standardError)) + +writesTheEvidenceFileTest :: TestTree +writesTheEvidenceFileTest = + testCase "--evidence-file writes one schema-valid record for the run" $ + -- The point of the option: an automation job gets a reviewable + -- record as a side effect of running, without the script having to + -- know anything about evidence. + withWorkspace $ \dir -> do + let evidencePath = dir "evidence.json" + executable <- + writeFakeAgent + dir + "claude" + "#!/bin/sh\ncat > /dev/null\necho 'the task is done'\n" + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "capture") + finished <- + run + (repositoryOnly configPath) + (withEvidence evidencePath "outer-run-7" (options (AgentRun "demo" (PromptInline "do the thing")))) + finished ^. #exitCode @?= 0 + -- Nothing about the evidence file leaks onto the agent's own + -- output, which a script may be capturing. + finished ^. #standardOutput @?= "the task is done\n" + recorded <- Aeson.eitherDecodeFileStrict evidencePath + case recorded of + Left problem -> assertFailure ("the record did not parse as JSON: " <> problem) + Right (Aeson.Object o) -> do + KeyMap.lookup "schema_version" o @?= Just (Aeson.String evidenceSchemaVersion) + KeyMap.lookup "run_id" o @?= Just (Aeson.String "outer-run-7") + KeyMap.lookup "status" o @?= Just (Aeson.String "succeeded") + -- The fake reports nothing about itself, so the record says so + -- rather than inferring anything from its clean exit. + KeyMap.lookup "strength" o @?= Just (Aeson.String "requested_only") + assertBool + ("a call id was generated: " <> show (KeyMap.lookup "call_id" o)) + (KeyMap.lookup "call_id" o /= Nothing) + Right other -> assertFailure ("expected one JSON object, got: " <> show other) + -- The write is atomic through a staging file, which must not be + -- left behind. + leftover <- doesFileExist (evidencePath <> ".partial") + assertBool "the staging file was renamed away" (not leftover) + +writesNoEvidenceFileByDefaultTest :: TestTree +writesNoEvidenceFileByDefaultTest = + testCase "a run that named no evidence destination writes nothing" $ + withWorkspace $ \dir -> do + let evidencePath = dir "evidence.json" + executable <- + writeFakeAgent dir "claude" "#!/bin/sh\ncat > /dev/null\necho 'the task is done'\n" + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "capture") + finished <- + run (repositoryOnly configPath) (options (AgentRun "demo" (PromptInline "do the thing"))) + finished ^. #exitCode @?= 0 + written <- doesFileExist evidencePath + assertBool "no evidence file appeared" (not written) + +-- | A run whose evidence requirement cannot be met is refused through +-- the command surface, with the refusal exit code. +-- +-- This case exists because its absence let a crash ship: adding the +-- 'EvidenceRefused' constructor left `failureExitCode`'s match +-- non-exhaustive, and no test drove a refused run through the command, +-- so the only symptom was a pattern-match failure on a real invocation. +refusesAnImpossibleEvidenceRequirementTest :: TestTree +refusesAnImpossibleEvidenceRequirementTest = + testCase "a run demanding evidence an inherit job cannot produce is refused" $ + withWorkspace $ \dir -> do + let argvRecord = dir "argv" + executable <- + writeFakeAgent dir "claude" ("#!/bin/sh\ntouch '" <> Text.pack argvRecord <> "'\n") + -- `inherit` sends the agent's bytes to the terminal, so baikai + -- holds nothing and can observe nothing however the run goes. + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "inherit") + finished <- + run + (repositoryOnly configPath) + ( requiringEvidence + EvidenceCorrelated + (options (AgentRun "demo" (PromptInline "do the thing"))) + ) + finished ^. #exitCode @?= refusedExitCode + assertBool + ("the refusal explains itself: " <> Text.unpack (finished ^. #standardError)) + -- The whole phrase, not a prefix: a mis-escaped string gap once + -- turned "it required" into a carriage return plus "equired", + -- and an assertion that stopped before the word did not notice. + ( "cannot produce the evidence it required" + `Text.isInfixOf` (finished ^. #standardError) + && "correlated" `Text.isInfixOf` (finished ^. #standardError) + ) + started <- doesFileExist argvRecord + assertBool "nothing was started" (not started) + +refusesAnEmptyPromptTest :: TestTree +refusesAnEmptyPromptTest = + testCase "an empty prompt is a usage error, not an expensive run" $ + withWorkspace $ \dir -> do + executable <- writeFakeAgent dir "claude" "#!/bin/sh\nexit 0\n" + configPath <- writeDocument dir "repo.kdl" (scriptedJob dir executable "capture") + emptyPrompt <- writeDocument dir "empty.txt" "" + finished <- + run (repositoryOnly configPath) (options (AgentRun "demo" (PromptFile emptyPrompt))) + finished ^. #exitCode @?= usageExitCode + assertBool + ("the empty source is named: " <> Text.unpack (finished ^. #standardError)) + (Text.pack emptyPrompt `Text.isInfixOf` (finished ^. #standardError)) + +-- -------------------------------------------------------------------- +-- Prompts +-- -------------------------------------------------------------------- + +readsThePromptFromStandardInputTest :: TestTree +readsThePromptFromStandardInputTest = + testCase "the standard-input reader decodes UTF-8 explicitly" $ + -- The fixture above uses a file, because standard input cannot be + -- piped in-process; this is the narrow test of the transport the + -- motivating script actually uses. The real handle is duplicated + -- and restored so no other test is affected. + withWorkspace $ \dir -> do + path <- writeDocument dir "prompt.txt" fixturePrompt + saved <- hDuplicate stdin + source <- openFile path ReadMode + hDuplicateTo source stdin + hClose source + outcome <- readPromptSource PromptStdin + hDuplicateTo saved stdin + hClose saved + outcome @?= Right fixturePrompt + +readsThePromptFromAFileTest :: TestTree +readsThePromptFromAFileTest = + testCase "a prompt file is read byte for byte" $ + withWorkspace $ \dir -> do + path <- writeDocument dir "prompt.txt" fixturePrompt + outcome <- readPromptSource (PromptFile path) + outcome @?= Right fixturePrompt + +rejectsAMissingPromptFileTest :: TestTree +rejectsAMissingPromptFileTest = + testCase "a missing prompt file is named rather than read as empty" $ + withWorkspace $ \dir -> do + outcome <- readPromptSource (PromptFile (dir "absent.txt")) + case outcome of + Right value -> assertFailure ("expected a failure, got: " <> show value) + Left message -> + assertBool + ("the path is named: " <> Text.unpack message) + (Text.pack (dir "absent.txt") `Text.isInfixOf` message) + +-- -------------------------------------------------------------------- +-- The parser +-- -------------------------------------------------------------------- + +parse :: [String] -> Options.ParserResult AgentCliOptions +parse = Options.execParserPure Options.defaultPrefs agentCliParserInfo + +twoPromptSourcesAreAUsageErrorTest :: TestTree +twoPromptSourcesAreAUsageErrorTest = + testCase "supplying two prompt sources is a usage error" $ + case parse ["agent", "run", "demo", "--prompt-stdin", "--prompt", "also this"] of + Options.Success _ -> assertFailure "expected two prompt sources to be refused" + _ -> pure () + +parsesTheMotivatingInvocationTest :: TestTree +parsesTheMotivatingInvocationTest = + testCase "the motivating invocation parses to a job, a prompt source, and one override" $ + case parse ["agent", "run", "sync-keiro-dsl", "--prompt-stdin", "--set", "extra-dirs=/keiro"] of + Options.Success parsed -> do + parsed ^. #command @?= AgentRun "sync-keiro-dsl" PromptStdin + length (parsed ^. #overrides) @?= 1 + _ -> assertFailure "expected the motivating invocation to parse" diff --git a/test/ConfigTests.hs b/test/ConfigTests.hs new file mode 100644 --- /dev/null +++ b/test/ConfigTests.hs @@ -0,0 +1,546 @@ +-- | Tests for layered KDL job resolution and the operator policy +-- ceiling. +-- +-- Every test constructs an 'AgentConfigPaths' explicitly and points it +-- at a temporary directory. None of them reads the real @HOME@ or +-- @XDG_CONFIG_HOME@: a developer with a real +-- @~\/.config\/baikai\/agents.kdl@ would otherwise get different results +-- from a clean machine, and the failure would be baffling. +module ConfigTests (configTests) where + +import Baikai.Agent + ( AgentOutputMode (..), + AgentProvider (..), + renderAgentRenderError, + ) +import Baikai.Agent.Config + ( AgentConfigPaths (..), + AgentConfigScope (..), + AgentJob, + agentEnvBindings, + agentJobRequest, + applyCeilingToJob, + defaultOutputLimit, + listAgentJobs, + loadAgentCeiling, + parseDuration, + renderAgentConfigError, + resolveAgentJob, + ) +import Control.Lens ((^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Settei.Env (EnvSnapshot, envSnapshot) +import Settei.Key (parseKey) +import Settei.Optparse (CliOverride, cliOverride) +import Settei.Render (renderErrorsText, renderResolutionJson, renderResolutionText) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +configTests :: TestTree +configTests = + testGroup + "Baikai.Agent.Config" + [ testGroup + "layering" + [ repositoryBeatsUserTest, + commandLineBeatsBothTest, + environmentLayerTest, + defaultsTest, + singleArgumentListTest, + missingFileTest + ], + testGroup + "provenance and secrecy" + [ provenanceTest, + redactionTest + ], + testGroup + "malformed input" + [ noSilentFallbackTest, + kdlSyntaxErrorTest, + durationTests, + invalidJobNameTest + ], + testGroup + "the operator policy ceiling" + [ defaultCeilingRefusesFullAccessTest, + defaultCeilingPermitsEditWorkspaceTest, + userFileRaisesCeilingTest, + repositoryFileCannotRaiseTheCeilingTest, + commandLineCannotRaiseTheCeilingTest + ], + testGroup + "enumeration" + [ listJobsTest + ], + environmentBindingsValidateTest + ] + +-- | Write the supplied documents into a temporary directory and hand +-- back paths pointing at them. Either scope may be absent, which is the +-- normal state for an operator who has written no policy file. +withConfigs :: Maybe Text -> Maybe Text -> (AgentConfigPaths -> IO a) -> IO a +withConfigs userDoc repoDoc action = + withSystemTempDirectory "baikai-agent-config" $ \dir -> do + userConfig <- traverse (writeDoc dir "user.kdl") userDoc + repoConfig <- traverse (writeDoc dir "repo.kdl") repoDoc + action AgentConfigPaths {userConfig, repoConfig} + where + writeDoc dir fileName body = do + let path = dir fileName + TextIO.writeFile path body + pure path + +noEnvironment :: EnvSnapshot +noEnvironment = envSnapshot [] + +-- | An override as the command line would supply it. +override :: Text -> Text -> CliOverride +override key value = + cliOverride (either (error . show) id (parseKey key)) value + +-- | Resolve a job, failing the test with the real diagnosis when either +-- loading or resolution fails. +resolveJob :: AgentConfigPaths -> EnvSnapshot -> [CliOverride] -> Text -> IO AgentJob +resolveJob paths snapshot overrides jobName = do + loaded <- resolveAgentJob paths snapshot overrides jobName + case loaded of + Left problem -> + assertFailure ("loading failed: " <> Text.unpack (renderAgentConfigError problem)) + Right resolved -> case resolved ^. #answer of + Left problems -> + assertFailure ("resolution failed: " <> Text.unpack (renderErrorsText problems)) + Right job -> pure job + +-- | The rendered resolution failure, for tests that expect one. +resolutionFailure :: AgentConfigPaths -> Text -> IO Text +resolutionFailure paths jobName = do + loaded <- resolveAgentJob paths noEnvironment [] jobName + case loaded of + Left problem -> pure (renderAgentConfigError problem) + Right resolved -> case resolved ^. #answer of + Left problems -> pure (renderErrorsText problems) + Right job -> assertFailure ("expected a failure, got: " <> show job) + +-- | A complete job that asks for the given capability. +jobDoc :: Text -> Text +jobDoc capability = + Text.unlines + [ "jobs {", + " demo {", + " provider \"claude\"", + " working-dir \"/tmp\"", + " safety {", + " capability \"" <> capability <> "\"", + " }", + " }", + "}" + ] + +repositoryBeatsUserTest :: TestTree +repositoryBeatsUserTest = + testCase "a repository value beats a user value" + $ withConfigs + (Just (Text.unlines ["jobs {", " demo {", " provider \"codex\"", " }", "}"])) + (Just (jobDoc "edit-workspace")) + $ \paths -> do + job <- resolveJob paths noEnvironment [] "demo" + job ^. #provider @?= AgentClaude + +commandLineBeatsBothTest :: TestTree +commandLineBeatsBothTest = + testCase "a command-line override beats both files" + $ withConfigs + (Just (Text.unlines ["jobs {", " demo {", " provider \"codex\"", " }", "}"])) + (Just (jobDoc "edit-workspace")) + $ \paths -> do + job <- + resolveJob paths noEnvironment [override "jobs.demo.provider" "codex"] "demo" + job ^. #provider @?= AgentCodex + +environmentLayerTest :: TestTree +environmentLayerTest = + testCase "the environment beats a file but loses to the command line" $ + withConfigs Nothing (Just (jobDoc "read-only")) $ \paths -> do + fromEnvironment <- + resolveJob paths (envSnapshot [("BAIKAI_AGENT_PROVIDER", "codex")]) [] "demo" + fromEnvironment ^. #provider @?= AgentCodex + fromCommandLine <- + resolveJob + paths + (envSnapshot [("BAIKAI_AGENT_PROVIDER", "codex")]) + [override "jobs.demo.provider" "claude"] + "demo" + fromCommandLine ^. #provider @?= AgentClaude + +defaultsTest :: TestTree +defaultsTest = + testCase "a minimal job resolves with the built-in defaults" $ + -- The counterpart to the runner's own defaults test: this is what + -- makes a terse configuration file usable. + withConfigs Nothing (Just (jobDoc "read-only")) $ \paths -> do + job <- resolveJob paths noEnvironment [] "demo" + job ^. #output @?= InheritOutput + job ^. #outputLimit @?= Just defaultOutputLimit + job ^. #extraDirs @?= [] + job ^. #allowedTools @?= [] + job ^. #providerArgs @?= [] + job ^. #envRequires @?= [] + job ^. #timeout @?= Nothing + job ^. #executable @?= Nothing + +singleArgumentListTest :: TestTree +singleArgumentListTest = + testCase "a list setting accepts none, one, or many arguments" + $ + -- A KDL node's raw shape depends on its argument count: none is a + -- null, one is a scalar, and only two or more is an array. settei's + -- own listDecoder accepts an array alone, so without the + -- scalar-tolerant decoder the one-directory spelling below — the + -- form the user guide documents — would fail to decode. + withConfigs + Nothing + ( Just + ( Text.unlines + [ "jobs {", + " one { provider \"claude\"; working-dir \"/tmp\"", + " extra-dirs \"/only\"", + " safety { capability \"read-only\" }", + " }", + " many { provider \"claude\"; working-dir \"/tmp\"", + " extra-dirs \"/first\" \"/second\"", + " safety { capability \"read-only\" }", + " }", + " none { provider \"claude\"; working-dir \"/tmp\"", + " extra-dirs", + " safety { capability \"read-only\" }", + " }", + "}" + ] + ) + ) + $ \paths -> do + one <- resolveJob paths noEnvironment [] "one" + one ^. #extraDirs @?= ["/only"] + many <- resolveJob paths noEnvironment [] "many" + many ^. #extraDirs @?= ["/first", "/second"] + none <- resolveJob paths noEnvironment [] "none" + none ^. #extraDirs @?= [] + -- A command-line override is always a scalar too. + overridden <- + resolveJob paths noEnvironment [override "jobs.none.extra-dirs" "/from-flag"] "none" + overridden ^. #extraDirs @?= ["/from-flag"] + +missingFileTest :: TestTree +missingFileTest = + testCase "with no configuration at all the required settings are named" $ + withConfigs Nothing Nothing $ \paths -> do + message <- resolutionFailure paths "demo" + assertBool + ("the provider key is named: " <> Text.unpack message) + (Text.isInfixOf "jobs.demo.provider" message) + assertBool + ("the working directory key is named: " <> Text.unpack message) + (Text.isInfixOf "jobs.demo.working-dir" message) + assertBool + ("the capability key is named: " <> Text.unpack message) + (Text.isInfixOf "jobs.demo.safety.capability" message) + +provenanceTest :: TestTree +provenanceTest = + testCase "the report attributes each value to its own file, with a line number" + $ + -- The headline capability of this plan, and improvement-request + -- acceptance criterion 5. + withConfigs + (Just (Text.unlines ["jobs {", " demo {", " timeout \"45m\"", " }", "}"])) + (Just (jobDoc "edit-workspace")) + $ \paths -> do + loaded <- resolveAgentJob paths noEnvironment [] "demo" + resolved <- case loaded of + Left problem -> + assertFailure ("loading failed: " <> Text.unpack (renderAgentConfigError problem)) + Right value -> pure value + let asText = renderResolutionText (resolved ^. #report) + asJson = renderResolutionJson (resolved ^. #report) + assertBool + ("the text report names the repository scope: " <> Text.unpack asText) + (Text.isInfixOf "repository configuration" asText) + assertBool + ("the text report names the user scope: " <> Text.unpack asText) + (Text.isInfixOf "user configuration" asText) + -- renderResolutionText names the source but drops the location, + -- so the line number is asserted against the JSON rendering, + -- which carries path, line, and column. Without this the test + -- would pass even if settei-kdl's span preservation were + -- silently dropped on the way into the report. + userPath <- maybe (assertFailure "expected a user file") pure (paths ^. #userConfig) + repoPath <- maybe (assertFailure "expected a repository file") pure (paths ^. #repoConfig) + assertBool + ("the JSON report cites the repository file: " <> Text.unpack asJson) + (Text.isInfixOf (Text.pack repoPath) asJson) + assertBool + ("the JSON report cites the user file: " <> Text.unpack asJson) + (Text.isInfixOf (Text.pack userPath) asJson) + assertBool + ("the JSON report carries a line number: " <> Text.unpack asJson) + (Text.isInfixOf "\"line\":" asJson) + +redactionTest :: TestTree +redactionTest = + testCase "raw provider arguments never reach a report" + $ + -- This is what makes the secret classification real rather than + -- decorative: provider-args is the one field an operator could write + -- a credential into. + withConfigs + Nothing + ( Just + ( Text.unlines + [ "jobs {", + " demo {", + " provider \"claude\"", + " working-dir \"/tmp\"", + " safety {", + " capability \"read-only\"", + " provider-args \"--api-key\" \"sk-not-a-real-key\"", + " }", + " }", + "}" + ] + ) + ) + $ \paths -> do + loaded <- resolveAgentJob paths noEnvironment [] "demo" + resolved <- case loaded of + Left problem -> + assertFailure ("loading failed: " <> Text.unpack (renderAgentConfigError problem)) + Right value -> pure value + let asText = renderResolutionText (resolved ^. #report) + asJson = renderResolutionJson (resolved ^. #report) + assertBool + "the text report does not contain the credential" + (not (Text.isInfixOf "sk-not-a-real-key" asText)) + assertBool + "the JSON report does not contain the credential" + (not (Text.isInfixOf "sk-not-a-real-key" asJson)) + -- Redacting the value must not hide that the setting was set. + assertBool + ("the key name still appears: " <> Text.unpack asText) + (Text.isInfixOf "jobs.demo.safety.provider-args" asText) + -- The resolved job still carries the real value; only reports redact. + job <- resolveJob paths noEnvironment [] "demo" + job ^. #providerArgs @?= ["--api-key", "sk-not-a-real-key"] + +noSilentFallbackTest :: TestTree +noSilentFallbackTest = + testCase "a misspelled value fails rather than falling back to a valid one" + $ + -- Pins settei's no-silent-fallback behavior, which this module + -- depends on and which a dependency upgrade could regress: a typo in + -- an untrusted repository file must not quietly activate an + -- operator's default. + withConfigs + (Just (jobDoc "read-only")) + ( Just + ( Text.unlines + [ "jobs {", + " demo {", + " safety { capability \"edit-worksapce\" }", + " }", + "}" + ] + ) + ) + $ \paths -> do + message <- resolutionFailure paths "demo" + assertBool + ("the offending key is named: " <> Text.unpack message) + (Text.isInfixOf "jobs.demo.safety.capability" message) + +kdlSyntaxErrorTest :: TestTree +kdlSyntaxErrorTest = + testCase "a syntax error is reported without echoing the document" $ + withConfigs Nothing (Just "jobs {\n demo {\n provider \"secret-looking-value\"\n") $ \paths -> do + loaded <- resolveAgentJob paths noEnvironment [] "demo" + case loaded of + Right _ -> assertFailure "expected the malformed document to be refused" + Left problem -> do + let message = renderAgentConfigError problem + -- settei-kdl errors carry a category, a name, a path, and a + -- span, never an excerpt. Appending the document "for context" + -- would defeat that redaction, so assert it was not. + assertBool + ("the message does not echo the document: " <> Text.unpack message) + (not (Text.isInfixOf "secret-looking-value" message)) + +durationTests :: TestTree +durationTests = + testGroup + "durations" + [ testCase "seconds" $ parseDuration "90s" @?= Just 90, + testCase "minutes" $ parseDuration "45m" @?= Just 2700, + testCase "hours" $ parseDuration "2h" @?= Just 7200, + testCase "a bare number means seconds" $ parseDuration "45" @?= Just 45, + -- Zero is refused rather than treated as "no timeout": it would + -- mean "kill every run immediately", which no operator intends. + testCase "zero is refused" $ parseDuration "0" @?= Nothing, + testCase "a negative duration is refused" $ parseDuration "-5m" @?= Nothing, + testCase "unparseable text is refused" $ parseDuration "soon" @?= Nothing, + testCase "an unknown unit is refused" $ parseDuration "5d" @?= Nothing + ] + +invalidJobNameTest :: TestTree +invalidJobNameTest = + testCase "a job name that cannot address a key is refused" $ + withConfigs Nothing (Just (jobDoc "read-only")) $ \paths -> do + loaded <- resolveAgentJob paths noEnvironment [] "has.a.dot" + case loaded of + Right _ -> assertFailure "expected a dotted job name to be refused" + Left problem -> + assertBool + "the message explains the dot" + (Text.isInfixOf "dot" (renderAgentConfigError problem)) + +-- | Load the ceiling, failing the test with the real diagnosis. +ceilingFor :: AgentConfigPaths -> IO (Either Text Text) +ceilingFor paths = do + loaded <- loadAgentCeiling paths + case loaded of + Left problem -> + assertFailure ("loading the ceiling failed: " <> Text.unpack (renderAgentConfigError problem)) + Right ceiling' -> pure (Right (Text.pack (show ceiling'))) + +-- | Resolve a job, apply the ceiling, and report the refusal message if +-- there was one. +runAgainstCeiling :: AgentConfigPaths -> [CliOverride] -> Text -> IO (Either Text ()) +runAgainstCeiling paths overrides jobName = do + job <- resolveJob paths noEnvironment overrides jobName + loaded <- loadAgentCeiling paths + ceiling' <- case loaded of + Left problem -> + assertFailure ("loading the ceiling failed: " <> Text.unpack (renderAgentConfigError problem)) + Right value -> pure value + pure $ case applyCeilingToJob ceiling' (agentJobRequest job "a prompt") of + Left refusal -> Left (renderAgentRenderError refusal) + Right _ -> Right () + +-- | A user document that raises the ceiling, and a repository document +-- that tries to. +raisingPolicyDoc :: Text +raisingPolicyDoc = Text.unlines ["policy {", " max-capability \"full-access\"", "}"] + +defaultCeilingRefusesFullAccessTest :: TestTree +defaultCeilingRefusesFullAccessTest = + testCase "with no user file, full access is refused naming both values" $ + withConfigs Nothing (Just (jobDoc "full-access")) $ \paths -> do + outcome <- runAgainstCeiling paths [] "demo" + case outcome of + Right () -> assertFailure "expected full access to be refused" + Left message -> do + assertBool + ("the requested value is named: " <> Text.unpack message) + (Text.isInfixOf "full-access" message) + assertBool + ("the permitted maximum is named: " <> Text.unpack message) + (Text.isInfixOf "edit-workspace" message) + +defaultCeilingPermitsEditWorkspaceTest :: TestTree +defaultCeilingPermitsEditWorkspaceTest = + testCase "with no user file, editing the workspace is permitted" $ + -- The zero-configuration path the first consumer depends on: a job + -- that changes files must work on a fresh machine with no + -- out-of-band setup step. + withConfigs Nothing (Just (jobDoc "edit-workspace")) $ \paths -> do + outcome <- runAgainstCeiling paths [] "demo" + outcome @?= Right () + +userFileRaisesCeilingTest :: TestTree +userFileRaisesCeilingTest = + testCase "the operator's own file may raise the ceiling" $ + withConfigs (Just raisingPolicyDoc) (Just (jobDoc "full-access")) $ \paths -> do + outcome <- runAgainstCeiling paths [] "demo" + outcome @?= Right () + +repositoryFileCannotRaiseTheCeilingTest :: TestTree +repositoryFileCannotRaiseTheCeilingTest = + testCase "A REPOSITORY FILE CANNOT RAISE THE CEILING" $ + -- The central security property of this module. A repository + -- configuration file is untrusted input; if it could set + -- policy.max-capability an untrusted checkout would grant itself + -- whatever it liked. If this test fails, the repository source has + -- leaked into loadAgentCeiling's source list. + withConfigs Nothing (Just (jobDoc "full-access" <> raisingPolicyDoc)) $ \paths -> do + shown <- ceilingFor paths + case shown of + Left problem -> assertFailure (Text.unpack problem) + Right rendered -> + assertBool + ("the ceiling is unchanged: " <> Text.unpack rendered) + (Text.isInfixOf "AgentEditWorkspace" rendered) + outcome <- runAgainstCeiling paths [] "demo" + case outcome of + Right () -> assertFailure "the repository file raised the ceiling" + Left message -> + assertBool + ("the refusal names the permitted maximum: " <> Text.unpack message) + (Text.isInfixOf "edit-workspace" message) + +commandLineCannotRaiseTheCeilingTest :: TestTree +commandLineCannotRaiseTheCeilingTest = + testCase "A COMMAND-LINE OVERRIDE CANNOT RAISE THE CEILING" $ + -- The other half of the central security property. + -- `--set policy.max-capability=full-access` is exactly the flag a + -- compromised automation script would add, and it must change + -- nothing. Note that loadAgentCeiling takes no overrides at all, + -- which is the structural reason this holds; the test pins the + -- behavior so a later signature change cannot quietly undo it. + withConfigs Nothing (Just (jobDoc "full-access")) $ \paths -> do + outcome <- + runAgainstCeiling paths [override "policy.max-capability" "full-access"] "demo" + case outcome of + Right () -> assertFailure "a command-line override raised the ceiling" + Left message -> + assertBool + ("the refusal names the permitted maximum: " <> Text.unpack message) + (Text.isInfixOf "edit-workspace" message) + +listJobsTest :: TestTree +listJobsTest = + testCase "job names are sorted and attributed to the winning scope" + $ withConfigs + ( Just + ( Text.unlines + [ "jobs {", + " demo { provider \"codex\" }", + " user-only { provider \"codex\" }", + "}" + ] + ) + ) + (Just (jobDoc "read-only")) + $ \paths -> do + listed <- listAgentJobs paths + case listed of + Left problem -> + assertFailure ("listing failed: " <> Text.unpack (renderAgentConfigError problem)) + Right entries -> do + map (^. #name) entries @?= ["demo", "user-only"] + map (^. #scope) entries @?= [RepositoryScope, UserScope] + -- A name defined in two files is reported once, with the + -- count, because a bare name hides a real source of + -- confusion. + map (^. #definingScopes) entries @?= [2, 1] + +environmentBindingsValidateTest :: TestTree +environmentBindingsValidateTest = + testCase "the environment binding list is valid" $ + -- The binding list calls `error` on an invalid entry, so forcing it + -- here makes a bad edit fail in tests rather than at start-up. + agentEnvBindings "probe" `seq` + pure () diff --git a/test/EvidenceTests.hs b/test/EvidenceTests.hs new file mode 100644 --- /dev/null +++ b/test/EvidenceTests.hs @@ -0,0 +1,466 @@ +-- | Model-call evidence for an unattended coding-agent run. +-- +-- Every case here spawns a real child process — a few lines of @sh@ +-- written into a temporary directory — and reads the evidence back off +-- the 'AgentRunOutcome' the real runner returns. Nothing is stubbed: the +-- process is spawned, drained, and timed by production code, and the +-- record is assembled by it too. No credential and no coding-agent +-- binary is required. +-- +-- Assertions go through the encoded JSON rather than through Haskell +-- record accessors, because the JSON is the contract other systems pin +-- against, and it spells its fields in snake_case where a Haskell mirror +-- would silently paper over a rename. +module EvidenceTests (evidenceTests) where + +import Baikai.Agent + ( AgentCommand (..), + AgentOutputMode (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRunFailure (..), + AgentRunOutcome (..), + AgentRunRequest, + agentRunRequest, + ) +import Baikai.Agent.Run + ( agentConfigurationEnvelope, + agentRequestEnvelope, + runAgentCommand, + ) +import Baikai.Evidence + ( EvidenceRequest, + EvidenceStrength (..), + EvidenceStrictness (..), + ModelCallEvidence, + ThinkingTranslation, + canonicalEncode, + evidenceRequest, + noThinkingRequested, + ) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString.Char8 qualified as BS8 +import Data.Generics.Labels () +import Data.List (isInfixOf) +import Data.Text (Text) +import Data.Text qualified as Text +import System.Directory + ( doesFileExist, + getPermissions, + setOwnerExecutable, + setPermissions, + ) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +evidenceTests :: TestTree +evidenceTests = + testGroup + "unattended run evidence" + [ reportedRunTest, + silentToolTest, + nonZeroExitTest, + timedOutRunTest, + inheritedOutputTest, + nothingStartedTest, + optOutTest, + strictRefusalTests, + digestTests + ] + +-- ==================================================================== +-- The cases +-- ==================================================================== + +reportedRunTest :: TestTree +reportedRunTest = + testCase "a tool that reports a session and a model is recorded as saying so" $ + -- Neither vendor renderer asks its tool for structured output, so + -- this is the shape an operator gets only after configuring + -- `--output-format json` through the job's extra arguments. That is + -- a real constraint and the runner's documentation states it. + withFake "#!/bin/sh\ncat > /dev/null\necho '" claudeResultJson "'\n" $ \dir exe -> do + ev <- oneEvidence =<< run (wanted "run-56") dir exe [] + field "status" ev @?= Just (String "succeeded") + field "run_id" ev @?= Just (String "run-56") + field "response_id" ev @?= Just (observedJson "sess-abc123") + field "observed_model" ev @?= Just (observedJson "claude-opus-5[1m]") + field "strength" ev @?= Just (String "model_observed") + case observedObject "usage" ev of + Nothing -> assertFailure ("expected an observed usage, got: " <> show (field "usage" ev)) + Just u -> do + KeyMap.lookup "input_tokens" u @?= Just (Number 11) + KeyMap.lookup "output_tokens" u @?= Just (Number 5) + -- A subprocess has no endpoint URL and no wire protocol; the + -- resolved executable path and this surface's own name stand in. + case field "endpoint" ev of + Just (Object o) -> do + KeyMap.lookup "transport" o @?= Just (String "agent_run") + KeyMap.lookup "api" o @?= Just (String "agent_run") + KeyMap.lookup "provider" o @?= Just (String "claude") + KeyMap.lookup "endpoint" o @?= Just (String (Text.pack exe)) + other -> assertFailure ("expected an endpoint object, got: " <> show other) + assertDigest "request_commitment" ev + assertDigest "request_configuration" ev + assertObservedDigest "response_commitment" ev + +silentToolTest :: TestTree +silentToolTest = + testCase "A ZERO EXIT WITH NO IDENTIFIER AND NO MODEL STAYS AT requested_only" $ + -- IR-3's rule, and the one this surface is most likely to violate by + -- accident: almost every unattended run exits zero. A coding agent + -- that exits zero has demonstrated that it ran, not which model + -- served it. + withFake "#!/bin/sh\ncat > /dev/null\necho '" "the task is done" "'\n" $ \dir exe -> do + ev <- oneEvidence =<< run (wanted "run-56") dir exe [] + field "status" ev @?= Just (String "succeeded") + field "strength" ev @?= Just (String "requested_only") + field "response_id" ev @?= Just (String "unobserved") + field "observed_model" ev @?= Just (String "unobserved") + field "usage" ev @?= Just (String "unobserved") + -- The run still produced output, so the commitment to it is real. + assertObservedDigest "response_commitment" ev + +nonZeroExitTest :: TestTree +nonZeroExitTest = + testCase "a non-zero exit is recorded as failed, and the exit code changes no strength" $ + withFake "#!/bin/sh\ncat > /dev/null\necho '" claudeResultJson "'\nexit 3\n" $ \dir exe -> do + ev <- oneEvidence =<< run (wanted "run-56") dir exe [] + field "status" ev @?= Just (String "failed") + case field "error_info" ev of + Just (Object o) -> + assertBool + ("expected a populated error_info, got: " <> show o) + (KeyMap.member "message" o) + other -> assertFailure ("expected a populated error_info, got: " <> show other) + -- The tool named itself before it failed, so the strength is what + -- it reported — not something derived from exiting 3. + field "response_id" ev @?= Just (observedJson "sess-abc123") + field "strength" ev @?= Just (String "model_observed") + -- No successful run means nothing complete to commit to. + field "response_commitment" ev @?= Just (String "unobserved") + +timedOutRunTest :: TestTree +timedOutRunTest = + testCase "A RUN KILLED BY ITS OWN TIMEOUT STILL PRODUCES A RECORD" $ + -- The reason evidence travels beside the outcome rather than inside + -- AgentRunResult. A timed-out run started, consumed tokens, and may + -- have changed the working tree; it reports Left RunTimedOut, so a + -- record hanging off the Right would be unreachable exactly here. + withFake "#!/bin/sh\n" "sleep 30" "\n" $ \dir exe -> do + outcome <- runWith (wanted "run-56") dir exe [] (\req -> req & #timeout .~ Just 1) + case outcome ^. #outcome of + Right ran -> assertFailure ("expected a timeout, the run finished: " <> show ran) + Left _ -> pure () + ev <- oneEvidence outcome + field "status" ev @?= Just (String "aborted") + field "strength" ev @?= Just (String "requested_only") + field "response_commitment" ev @?= Just (String "unobserved") + case field "error_info" ev of + Just (Object o) -> assertBool ("names the timeout: " <> show o) (KeyMap.member "message" o) + other -> assertFailure ("expected a populated error_info, got: " <> show other) + +inheritedOutputTest :: TestTree +inheritedOutputTest = + testCase "an inherited run observes nothing, because there are no bytes to read" $ + -- Under `inherit` the agent's output went to this process's own + -- terminal and baikai never held it. Every tool-reported field is + -- therefore Unobserved — which is the honest answer, and is why the + -- runner's documentation tells an operator who needs correlated + -- evidence to capture output. + withFake "#!/bin/sh\necho '" claudeResultJson "'\n" $ \dir exe -> do + outcome <- runWith (wanted "run-56") dir exe [] (\req -> req & #output .~ InheritOutput) + ev <- oneEvidence outcome + field "status" ev @?= Just (String "succeeded") + field "response_id" ev @?= Just (String "unobserved") + field "observed_model" ev @?= Just (String "unobserved") + field "usage" ev @?= Just (String "unobserved") + field "response_commitment" ev @?= Just (String "unobserved") + field "strength" ev @?= Just (String "requested_only") + +nothingStartedTest :: TestTree +nothingStartedTest = + testCase "a run that never started produces no evidence at all" $ + -- There is nothing to describe. An evidence record for a process + -- that was never created would assert a run happened. + withSystemTempDirectory "baikai-agent-evidence" $ \dir -> do + let missing = dir "not-installed" + outcome <- run (wanted "run-56") dir missing [] + case outcome ^. #outcome of + Right ran -> assertFailure ("expected a spawn failure, got: " <> show ran) + Left _ -> pure () + outcome ^. #evidence @?= Nothing + +optOutTest :: TestTree +optOutTest = + testCase "A RUN THAT ASKED FOR NO EVIDENCE SPAWNS EXACTLY ONE PROCESS" $ + -- The absent field is the easy half. The process count is the half + -- that catches a --version probe firing on a path it must never + -- reach: the probe is a whole extra subprocess, and an unattended + -- run can be one short invocation. + withSystemTempDirectory "baikai-agent-evidence" $ \dir -> do + let ledger = dir "invocations" + exe <- + writeFakeExecutable + dir + "counted" + ("#!/bin/sh\ncat > /dev/null\necho x >> '" <> ledger <> "'\necho done\n") + optedOut <- run Nothing dir exe [] + optedOut ^. #evidence @?= Nothing + afterOptOut <- invocationCount ledger + afterOptOut @?= 1 + + -- And the contrast, so the assertion above cannot pass because + -- the fake was never run at all: opting in probes the executable + -- as well as running it. + optedIn <- run (wanted "run-56") dir exe [] + assertBool "the opted-in run built evidence" (optedIn ^. #evidence /= Nothing) + afterOptIn <- invocationCount ledger + assertBool + ("the opted-in run also probed the executable, saw " <> show afterOptIn) + (afterOptIn > afterOptOut + 1) + +-- ==================================================================== +-- Strict evidence on this surface +-- ==================================================================== + +strictRefusalTests :: TestTree +strictRefusalTests = + testGroup + -- The agent surface never touches ApiProvider and has no trace + -- sink, so neither of the gates the completion path uses reaches + -- it. These prove its own. + "a run that cannot produce the required evidence is refused before it starts" + [ testCase "AN INHERIT JOB DEMANDING A CORRELATED RECORD IS REFUSED" $ + -- The most useful refusal on this surface. Under inherit the + -- agent's bytes go to the operator's terminal and baikai never + -- holds them, so nothing the tool says can be observed however + -- well the run goes. Finding that out before the run rather than + -- from an empty record is the point. + withFake "#!/bin/sh\ncat > /dev/null\necho '" "ok" "'\n" $ \dir exe -> do + let ledger = dir "invocations" + recording <- writeFakeExecutable dir "counted" ("#!/bin/sh\necho x >> '" <> ledger <> "'\n") + outcome <- + runWith + (requiring EvidenceCorrelated) + dir + recording + [] + (\req -> req & #output .~ InheritOutput) + case outcome ^. #outcome of + Right ran -> assertFailure ("expected a refusal, the run started: " <> show ran) + Left failure -> case failure of + EvidenceRefused reasons -> + assertBool + ("the refusal explains itself: " <> show reasons) + (any ("requested_only" `Text.isInfixOf`) reasons) + other -> assertFailure ("expected EvidenceRefused, got: " <> show other) + outcome ^. #evidence @?= Nothing + started <- invocationCount ledger + started @?= 0 + -- `exe` is unused on this path; naming it keeps withFake's + -- shape rather than adding a second helper. + assertBool "the fixture executable exists" (not (null exe)), + testCase "a codex job demanding a model is refused, because codex names none" $ + withFake "#!/bin/sh\n" "exit 0" "\n" $ \dir exe -> do + outcome <- + runWith + (requiring EvidenceModelObserved) + dir + exe + [] + (\req -> req & #provider .~ AgentCodex) + case outcome ^. #outcome of + Left (EvidenceRefused _) -> pure () + other -> assertFailure ("expected EvidenceRefused, got: " <> show other), + testCase "a capturing claude job demanding a model is allowed to try" $ + -- Structural, not predictive: this run may or may not report a + -- model, and the gate must not pretend to know. The record's own + -- strength is where the caller reads what actually happened. + withFake "#!/bin/sh\ncat > /dev/null\necho '" claudeResultJson "'\n" $ \dir exe -> do + outcome <- run (requiring EvidenceModelObserved) dir exe [] + case outcome ^. #outcome of + Left failure -> assertFailure ("expected the run to start: " <> show failure) + Right _ -> pure () + ev <- oneEvidence outcome + field "strength" ev @?= Just (String "model_observed"), + testCase "a best-effort caller is never refused, whatever the configuration" $ + withFake "#!/bin/sh\n" "exit 0" "\n" $ \dir exe -> do + outcome <- + runWith (wanted "run-56") dir exe [] (\req -> req & #output .~ InheritOutput) + case outcome ^. #outcome of + Left failure -> assertFailure ("a best-effort run must not be refused: " <> show failure) + Right _ -> pure () + ] + +requiring :: EvidenceStrength -> Maybe EvidenceRequest +requiring needed = + Just (evidenceRequest "run-57" & #strictness .~ EvidenceRequired needed) + +-- ==================================================================== +-- The digests +-- ==================================================================== + +digestTests :: TestTree +digestTests = + testGroup + -- The subtlest part of this surface. Both vendor renderers put the + -- prompt on standard input, so a commitment computed over the + -- argument vector alone would give two runs with identical flags and + -- completely different instructions the same digest. + "the prompt is committed to under both transports and excluded from the configuration" + [ testCase (label transport) $ do + let one = command transport "first instruction" + two = command transport "second instruction" + assertBool + "two prompts must not share a request commitment" + (encoded (agentRequestEnvelope one) /= encoded (agentRequestEnvelope two)) + encoded (agentConfigurationEnvelope one) @?= encoded (agentConfigurationEnvelope two) + assertBool + "the commitment input must contain the prompt" + ("PROMPT-BODY-MARKER" `isInfixOf` encoded (agentRequestEnvelope (command transport marker))) + assertBool + "the configuration input must not contain the prompt" + ( not + ( "PROMPT-BODY-MARKER" + `isInfixOf` encoded (agentConfigurationEnvelope (command transport marker)) + ) + ) + | transport <- [PromptOnStdin, PromptAsArgument] + ] + where + marker = "PROMPT-BODY-MARKER" + label PromptOnStdin = "prompt on standard input" + label PromptAsArgument = "prompt as an argument" + encoded = BS8.unpack . canonicalEncode + -- Under PromptAsArgument the prompt is in the vector too, which is + -- what makes excluding it from the configuration a real operation + -- rather than a no-op. + command transport promptBody = + AgentCommand + { executable = "/bin/agent", + arguments = + ["-p", "--effort", "high"] + <> case transport of + PromptAsArgument -> ["--", Text.unpack promptBody] + PromptOnStdin -> [], + promptTransport = transport, + promptText = promptBody + } + +-- ==================================================================== +-- Harness +-- ==================================================================== + +-- | Run one command against a fake executable rooted in a directory. +run :: Maybe EvidenceRequest -> FilePath -> FilePath -> [String] -> IO AgentRunOutcome +run evidenceReq dir exe args = runWith evidenceReq dir exe args id + +runWith :: + Maybe EvidenceRequest -> + FilePath -> + FilePath -> + [String] -> + (AgentRunRequest -> AgentRunRequest) -> + IO AgentRunOutcome +runWith evidenceReq dir exe args adjust = + runAgentCommand evidenceReq translation (adjust request) command + where + request = + agentRunRequest AgentClaude dir "PROMPT-BODY-MARKER" & #output .~ CaptureOutput + command = + AgentCommand + { executable = exe, + arguments = args, + promptTransport = PromptOnStdin, + promptText = "PROMPT-BODY-MARKER" + } + +-- | Every case here drives the runner directly rather than through a +-- vendor renderer, so there is no translation to carry. The renderers' +-- own translations are asserted in each vendor package's test suite. +translation :: ThinkingTranslation +translation = noThinkingRequested + +wanted :: Text -> Maybe EvidenceRequest +wanted = Just . evidenceRequest + +-- | Write a fake tool from three pieces, so a case can wrap recorded +-- JSON in shell quoting without escaping it twice. +withFake :: String -> String -> String -> (FilePath -> FilePath -> IO a) -> IO a +withFake before body after action = + withSystemTempDirectory "baikai-agent-evidence" $ \dir -> do + exe <- writeFakeExecutable dir "fake-agent" (before <> body <> after) + action dir exe + +writeFakeExecutable :: FilePath -> String -> String -> IO FilePath +writeFakeExecutable dir name body = do + let path = dir name + writeFile path body + perms <- getPermissions path + setPermissions path (setOwnerExecutable True perms) + pure path + +invocationCount :: FilePath -> IO Int +invocationCount path = do + here <- doesFileExist path + if here then length . lines <$> readFile path else pure 0 + +-- | A @claude -p --output-format json@ result, as the tool emits one +-- when an operator has configured that format through the job's extra +-- arguments. Single-quote-free so it survives the shell wrapping above. +claudeResultJson :: String +claudeResultJson = + "{\"type\":\"result\",\"is_error\":false,\"result\":\"done\",\ + \\"session_id\":\"sess-abc123\",\ + \\"usage\":{\"input_tokens\":11,\"output_tokens\":5},\ + \\"modelUsage\":{\"claude-opus-5[1m]\":{\"inputTokens\":11}}}" + +-- ==================================================================== +-- Assertions on the encoded record +-- ==================================================================== + +oneEvidence :: AgentRunOutcome -> IO ModelCallEvidence +oneEvidence outcome = case outcome ^. #evidence of + Just ev -> pure ev + Nothing -> assertFailure "expected the run to produce evidence" + +field :: Text -> ModelCallEvidence -> Maybe Value +field k ev = case Aeson.toJSON ev of + Object o -> KeyMap.lookup (Key.fromText k) o + _ -> Nothing + +-- | How 'Baikai.Evidence.Observed' encodes a present value. +observedJson :: Text -> Value +observedJson v = Object (KeyMap.singleton "observed" (String v)) + +observedObject :: Text -> ModelCallEvidence -> Maybe (KeyMap.KeyMap Value) +observedObject k ev = case field k ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (Object inner) -> Just inner + _ -> Nothing + _ -> Nothing + +assertDigest :: Text -> ModelCallEvidence -> IO () +assertDigest k ev = case field k ev of + Just (String d) -> assertSha256 k d + other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other) + +assertObservedDigest :: Text -> ModelCallEvidence -> IO () +assertObservedDigest k ev = case field k ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (String d) -> assertSha256 k d + other -> assertFailure (Text.unpack k <> " not a digest: " <> show other) + other -> assertFailure ("expected an observed " <> Text.unpack k <> ", got: " <> show other) + +assertSha256 :: Text -> Text -> IO () +assertSha256 k d = + assertBool + (Text.unpack k <> " must be a sha256 digest, got: " <> show d) + ("sha256:" `Text.isPrefixOf` d && Text.length d == 71) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,337 @@ +module Main (main) where + +import Baikai.Agent + ( AgentCapturedOutput (..), + AgentCommand (..), + AgentOutputMode (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRunFailure (..), + AgentRunRequest, + AgentRunResult, + agentRunRequest, + capturedBytes, + ) +import Baikai.Agent.Run (runAgentCommand, timeoutMicros) +import Baikai.Evidence (noThinkingRequested) +import CliTests (cliTests) +import ConfigTests (configTests) +import Control.Concurrent (threadDelay) +import Control.Lens ((&), (.~), (^.)) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Generics.Labels () +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import EvidenceTests (evidenceTests) +import System.Directory + ( doesFileExist, + getPermissions, + setOwnerExecutable, + setPermissions, + ) +import System.Exit (ExitCode (..)) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +main :: IO () +main = + defaultMain $ + testGroup + "baikai-agent" + [ runTests, + configTests, + cliTests + ] + +runTests :: TestTree +runTests = + testGroup + "Baikai.Agent.Run" + [ promptRoundTripTest, + streamSeparationTest, + workingDirectoryTest, + nonZeroExitTest, + spawnFailureTest, + missingWorkingDirectoryTest, + missingEnvironmentTest, + timeoutTest, + processGroupTest, + outputLimitTest, + inheritOutputTest, + promptAsArgumentTest, + timeoutMicrosTests, + evidenceTests + ] + +-- | Write a tiny shell script into a temporary directory, make it +-- executable, and hand its path to the action. Every process-level +-- behavior this package implements can be reproduced by a few lines of +-- @sh@, which is what keeps the suite free of any coding-agent binary, +-- any authentication, and any model. +withFakeExecutable :: String -> String -> (FilePath -> FilePath -> IO a) -> IO a +withFakeExecutable name body action = + withSystemTempDirectory "baikai-agent-test" $ \dir -> do + let path = dir name + writeFile path body + perms <- getPermissions path + setPermissions path (setOwnerExecutable True perms) + action dir path + +-- | A request rooted in the given directory, capturing output. +capturingRequest :: FilePath -> Text.Text -> AgentRunRequest +capturingRequest dir promptBody = + agentRunRequest AgentClaude dir promptBody & #output .~ CaptureOutput + +-- | A command that delivers the prompt on standard input, the transport +-- both shipped vendor renderers select. +stdinCommand :: FilePath -> [String] -> Text.Text -> AgentCommand +stdinCommand exe args promptBody = + AgentCommand + { executable = exe, + arguments = args, + promptTransport = PromptOnStdin, + promptText = promptBody + } + +-- | Unwrap a run that was expected to start, reporting the failure's own +-- message when it did not. +expectRan :: + Either AgentRunFailure AgentRunResult -> IO AgentRunResult +expectRan (Left failure) = + assertFailure ("expected the run to start: " <> show failure) +expectRan (Right result) = pure result + +-- | The runner as every case in this module uses it: no evidence +-- requested, and therefore no reasoning-effort translation to describe. +-- +-- The evidence path has its own module. Keeping it out of here means +-- these cases still assert exactly what they asserted before evidence +-- existed, which is what makes them a regression guard for it. +runPlain :: + AgentRunRequest -> AgentCommand -> IO (Either AgentRunFailure AgentRunResult) +runPlain req cmd = + (^. #outcome) <$> runAgentCommand Nothing noThinkingRequested req cmd + +promptRoundTripTest :: TestTree +promptRoundTripTest = + testCase "delivers the prompt on stdin and captures stdout" $ + -- A non-ASCII prompt on purpose: a locale-dependent write would + -- corrupt it, so this also pins the explicit UTF-8 encoding. + withFakeExecutable "echo-stdin" "#!/bin/sh\nexec cat\n" $ \dir exe -> do + let promptBody = "réconcilier la grammaire — 文法" :: Text.Text + result <- + runPlain + (capturingRequest dir promptBody) + (stdinCommand exe [] promptBody) + >>= expectRan + result ^. #exitCode @?= ExitSuccess + capturedBytes (result ^. #stdout) @?= Just (Text.encodeUtf8 promptBody) + +streamSeparationTest :: TestTree +streamSeparationTest = + testCase "separates stdout from stderr" + $ withFakeExecutable + "two-streams" + "#!/bin/sh\nprintf 'to-stdout' \nprintf 'to-stderr' >&2\n" + $ \dir exe -> do + result <- + runPlain (capturingRequest dir "ignored") (stdinCommand exe [] "ignored") + >>= expectRan + capturedBytes (result ^. #stdout) @?= Just "to-stdout" + capturedBytes (result ^. #stderr) @?= Just "to-stderr" + +workingDirectoryTest :: TestTree +workingDirectoryTest = + testCase "honors the request working directory" $ + -- AgentCommand carries no working directory, so this is the only + -- evidence that the request's one reaches the child. + withFakeExecutable "print-cwd" "#!/bin/sh\nexec pwd\n" $ \dir exe -> do + result <- + runPlain (capturingRequest dir "ignored") (stdinCommand exe [] "ignored") + >>= expectRan + let reported = maybe "" (BS8.unpack . stripTrailingNewline) (capturedBytes (result ^. #stdout)) + -- Compare on the basename: macOS resolves /var to /private/var, so + -- the child's pwd is the same directory by a different path. + basename reported @?= basename dir + +nonZeroExitTest :: TestTree +nonZeroExitTest = + testCase "reports a non-zero exit as a successful run, intentionally" $ + -- Intentional, and the behavior most likely to be "fixed" into a + -- Left by someone who has not read the plan: a coding agent that + -- attempts its task and fails has still run. + withFakeExecutable "exit-three" "#!/bin/sh\nexit 3\n" $ \dir exe -> do + result <- + runPlain (capturingRequest dir "ignored") (stdinCommand exe [] "ignored") + >>= expectRan + result ^. #exitCode @?= ExitFailure 3 + +spawnFailureTest :: TestTree +spawnFailureTest = + testCase "reports a missing executable as SpawnFailed" $ + withSystemTempDirectory "baikai-agent-test" $ \dir -> do + let missing = dir "not-installed" + outcome <- + runPlain (capturingRequest dir "ignored") (stdinCommand missing [] "ignored") + case outcome of + Left (SpawnFailed path _) -> path @?= missing + other -> assertFailure ("expected SpawnFailed, got: " <> show other) + +missingWorkingDirectoryTest :: TestTree +missingWorkingDirectoryTest = + testCase "checks the working directory before spawning" $ + withSystemTempDirectory "baikai-agent-test" $ \dir -> do + -- The executable is missing too, so a spawn attempt would have + -- produced SpawnFailed. Getting WorkingDirMissing proves the + -- precondition ran first. + let absentDir = dir "no-such-directory" + absentExe = dir "no-such-executable" + outcome <- + runPlain + (capturingRequest absentDir "ignored") + (stdinCommand absentExe [] "ignored") + case outcome of + Left (WorkingDirMissing path) -> path @?= absentDir + other -> assertFailure ("expected WorkingDirMissing, got: " <> show other) + +missingEnvironmentTest :: TestTree +missingEnvironmentTest = + testCase "reports every missing declared variable at once" $ + withSystemTempDirectory "baikai-agent-test" $ \dir -> do + -- Names chosen to be absent rather than unset here, so the test + -- never mutates the suite's own environment. + let names = ["BAIKAI_AGENT_TEST_ABSENT_ONE", "BAIKAI_AGENT_TEST_ABSENT_TWO"] + req = capturingRequest dir "ignored" & #envPassthrough .~ names + outcome <- runPlain req (stdinCommand (dir "unused") [] "ignored") + case outcome of + Left (MissingEnvironment missing) -> missing @?= names + other -> assertFailure ("expected MissingEnvironment, got: " <> show other) + +timeoutTest :: TestTree +timeoutTest = + testCase "times out and terminates rather than waiting the script out" $ + withFakeExecutable "sleeper" "#!/bin/sh\nsleep 5\n" $ \dir exe -> do + let req = capturingRequest dir "ignored" & #timeout .~ Just 1 + start <- getCurrentTime + outcome <- runPlain req (stdinCommand exe [] "ignored") + end <- getCurrentTime + case outcome of + Left (RunTimedOut limit) -> limit @?= 1 + other -> assertFailure ("expected RunTimedOut, got: " <> show other) + -- Without this assertion the test would pass just as well by + -- waiting for the script to finish, which proves nothing about + -- termination. + assertBool + "returned well before the script would have finished" + (diffUTCTime end start < 4) + +processGroupTest :: TestTree +processGroupTest = + testCase "kills grandchildren when the group is terminated" + $ + -- The most valuable test here and the easiest to omit: it is what + -- proves a coding agent's own child processes die with it. + withFakeExecutable + "spawns-a-child" + "#!/bin/sh\n(sleep 3; touch \"$1\") &\nsleep 5\n" + $ \dir exe -> do + let marker = dir "grandchild-survived" + req = capturingRequest dir "ignored" & #timeout .~ Just 1 + outcome <- runPlain req (stdinCommand exe [marker] "ignored") + case outcome of + Left (RunTimedOut _) -> pure () + other -> assertFailure ("expected RunTimedOut, got: " <> show other) + -- Wait past the grandchild's delay before checking, or the file + -- would be absent merely because it is early. + waitSeconds 4 + survived <- doesFileExist marker + assertBool "the grandchild was terminated with its group" (not survived) + +outputLimitTest :: TestTree +outputLimitTest = + testCase "truncates captured output at the byte limit" + $ withFakeExecutable + "flood" + "#!/bin/sh\ni=0\nwhile [ $i -lt 2000 ]; do printf '0123456789'; i=$((i+1)); done\n" + $ \dir exe -> do + let req = capturingRequest dir "ignored" & #outputLimit .~ Just 1024 + result <- + runPlain req (stdinCommand exe [] "ignored") >>= expectRan + case result ^. #stdout of + OutputTruncated bytes -> BS.length bytes @?= 1024 + other -> assertFailure ("expected OutputTruncated, got: " <> show other) + -- Proves the excess was discarded rather than the pipe closed: + -- closing it would have made the child's next write fail. + result ^. #exitCode @?= ExitSuccess + +inheritOutputTest :: TestTree +inheritOutputTest = + testCase "captures nothing in inherit mode" $ + withFakeExecutable "chatty" "#!/bin/sh\nprintf 'inherited line\\n'\n" $ \dir exe -> do + -- The line goes to the test runner's own output, which is expected. + let req = agentRunRequest AgentClaude dir "ignored" + result <- runPlain req (stdinCommand exe [] "ignored") >>= expectRan + result ^. #stdout @?= OutputNotCaptured + result ^. #stderr @?= OutputNotCaptured + result ^. #exitCode @?= ExitSuccess + +promptAsArgumentTest :: TestTree +promptAsArgumentTest = + testCase "supports the prompt-as-argument transport" + $ + -- No shipped renderer selects this transport, so a fixture is the + -- only place the two-sided contract can be observed. The script + -- echoes its argument and appends whatever standard input it can + -- read, which must be nothing. + withFakeExecutable + "echo-arg" + -- Shift past the -- separator the way a real tool's own argument + -- parser would, then echo the prompt and append whatever standard + -- input can be read, which must be nothing. Reading fails outright + -- because this transport gives the child no standard input at all, + -- and that failure is tolerated so the script's own exit code + -- still reports success. + "#!/bin/sh\n[ \"$1\" = \"--\" ] && shift\nprintf '%s' \"$1\"\ncat 2>/dev/null || true\n" + $ \dir exe -> do + let promptBody = "the prompt is an argument" :: Text.Text + cmd = + AgentCommand + { executable = exe, + arguments = ["--", Text.unpack promptBody], + promptTransport = PromptAsArgument, + promptText = promptBody + } + result <- + runPlain (capturingRequest dir promptBody) cmd >>= expectRan + capturedBytes (result ^. #stdout) @?= Just (Text.encodeUtf8 promptBody) + result ^. #exitCode @?= ExitSuccess + +timeoutMicrosTests :: TestTree +timeoutMicrosTests = + testGroup + "timeout conversion" + [ testCase "no timeout stays absent" $ timeoutMicros Nothing @?= Nothing, + testCase "zero means no timeout, not expire immediately" $ + timeoutMicros (Just 0) @?= Nothing, + testCase "a negative duration means no timeout" $ + timeoutMicros (Just (-5)) @?= Nothing, + testCase "an ordinary duration converts to microseconds" $ + timeoutMicros (Just 1.5) @?= Just 1500000, + testCase "a duration too large for an Int means no timeout" $ + timeoutMicros (Just 1e30) @?= Nothing + ] + +stripTrailingNewline :: BS.ByteString -> BS.ByteString +stripTrailingNewline bytes + | not (BS.null bytes) && BS.last bytes == 10 = BS.init bytes + | otherwise = bytes + +basename :: FilePath -> FilePath +basename = reverse . takeWhile (/= '/') . reverse + +waitSeconds :: Int -> IO () +waitSeconds seconds = threadDelay (seconds * 1000000)