baikai-agent (empty) → 0.1.0.0
raw patch · 10 files changed
+5233/−0 lines, 10 filesdep +aesondep +baikaidep +baikai-agent
Dependencies added: aeson, baikai, baikai-agent, baikai-claude, baikai-openai, base, bytestring, containers, directory, filepath, generic-lens, lens, optparse-applicative, process, settei, settei-env, settei-kdl, settei-optparse-applicative, streamly-core, tasty, tasty-hunit, temporary, text, time, unix
Files
- LICENSE +26/−0
- app/Main.hs +48/−0
- baikai-agent.cabal +138/−0
- src/Baikai/Agent/Cli.hs +1236/−0
- src/Baikai/Agent/Config.hs +805/−0
- src/Baikai/Agent/Run.hs +767/−0
- test/CliTests.hs +864/−0
- test/ConfigTests.hs +546/−0
- test/EvidenceTests.hs +466/−0
- test/Main.hs +337/−0
+ LICENSE view
@@ -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.
+ app/Main.hs view
@@ -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
+ baikai-agent.cabal view
@@ -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
+ src/Baikai/Agent/Cli.hs view
@@ -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.\<job\>.\<key\>@ 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.\<job\>.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 = "<prompt supplied at run time>"+ 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+ .~ ["<redacted>" | _ <- 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"+ )+ )+ ]
+ src/Baikai/Agent/Config.hs view
@@ -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 "<no user configuration>" 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)]+ ]+ )
+ src/Baikai/Agent/Run.hs view
@@ -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 <stdin> 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)
+ test/CliTests.hs view
@@ -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)+ ("<redacted>" `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"
+ test/ConfigTests.hs view
@@ -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 ()
+ test/EvidenceTests.hs view
@@ -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)
+ test/Main.hs view
@@ -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)