diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,678 @@ ## [Unreleased] +## [baikai 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai`: new exposed module `Baikai.Agent`, the provider-neutral vocabulary + for an **unattended coding-agent run** — a run with no terminal and no human, + which owns its own tool loop, may change files inside directories the caller + authorized, and returns a process result rather than a `Response`. It defines + `AgentRunRequest` (with a required `workingDir`), `AgentRunResult`, the + `AgentCapability` profile (`read-only`, `edit-workspace`, `full-access`), + `AgentSafety`, the `AgentOutputMode` and `AgentCapturedOutput` output + discipline, the `AgentCommand` renderer/runner boundary with an explicit + prompt transport, and the `AgentRenderError` / `AgentRunFailure` taxonomies. + +- `baikai`: the operator policy ceiling — `AgentCeiling`, + `defaultAgentCeiling`, `CeilingViolation`, and the pure `applyAgentCeiling`. + It returns a request unchanged when it is within the ceiling and reports + every violation when it is not; it never clamps an over-broad request to the + permitted value. The default ceiling permits read-only and edit-workspace + authority and refuses full access and raw provider arguments. + + `Baikai.Agent` itself is vocabulary and pure policy algebra only: it spawns no + process and renders no command-line flags. Those live in the vendor packages + and in `baikai-agent`, below. The module is deliberately not re-exported from + the umbrella `Baikai` module, because its field accessors share names with + `Baikai.Interactive`, so `import Baikai` continues to compile unchanged. + +- `baikai`: new exposed module `Baikai.Evidence`, the vocabulary for + **verifiable model-call evidence** — a record of what actually crossed the + boundary to a provider, as opposed to what the process was configured to ask + for. It defines `ModelCallEvidence` and the `evidenceSchemaVersion` string + consumers pin against, `Observed` (a deliberate non-`Maybe` for a value the + provider either did or did not report, with no function that supplies a + default), `ThinkingTranslation` with its `ThinkingMode` and + `ThinkingAdjustment` enumerations describing what a requested + reasoning-effort level actually became on the wire and every clamp, collapse, + or drop applied on the way, `EndpointIdentity` and `TransportKind`, + `CallStatus`, and the ascending `EvidenceStrength` scale. + + It also provides the canonical hashing core: `canonicalEncode` gives a JSON + value exactly one byte representation (object keys sorted, no insignificant + whitespace, numbers normalised so `1`, `1.0`, `1.00`, and `1e0` all encode as + `1`, and a hand-written string escaper so an aeson upgrade cannot silently + invalidate a recorded digest); `commitmentDigest` hashes a full request + envelope, and `configurationDigest` hashes an allow-list projection + (`configurationProjection`) that keeps configuration and replaces content with + structural summaries, so two calls that ask the same model the same way about + different subjects agree. The two digests are separate on purpose: the first + binds a record to a particular request, the second is safe to compare across + runs that legitimately differ in content. + + Nothing constructs a `ModelCallEvidence` from a real call yet, and no existing + behaviour changed. New dependencies: `cryptohash-sha256` and + `base16-bytestring`, both single-purpose packages chosen over a full + cryptographic framework. + +- `baikai`: `Options` gains an `evidence` field carrying an optional + `EvidenceRequest` — the caller's run identifier, retry provenance, and how + strictly they need evidence. A call whose `evidence` is `Nothing`, which is + every call that does not opt in, behaves exactly as it did before: no digest + is computed and no evidence is emitted. + +- `baikai`: model-call evidence is now **produced and emitted**. A caller who + sets `Options.evidence` gets exactly one `call_evidence` line per call from + their trace sink, under every way a call can end: success, provider failure, a + consumer that abandons the stream (status `aborted`, not `failed` — an abort + is the consumer's doing and reporting it as a provider failure would + misattribute it), and dispatch that found no registered handler. + + New exposed module `Baikai.Evidence.Build` bridges the vocabulary to the + `Model` and `Options` records: `minimalEvidence` and `prepareEvidence` build a + record, `dispatchEnvelope` supplies the request envelope for the paths where + no adapter ran, `sanitizeEndpoint` reduces a base URL to scheme/host/port/path + with the query string and any userinfo dropped wholesale, and `onSinkFailure` + is the hook a future release replaces to make a strict caller's call fail when + the trace sink does. + + Every record this release produces has `strength` `requested_only` and every + provider-observed field set to `"unobserved"`. That is not a placeholder: it + is a truthful record for a transport that has not yet been taught to observe + anything. Later releases teach each transport to observe more. + + **A caller who does not opt in pays nothing.** With `Options.evidence` absent + no digest is computed, no call identifier is generated, no evidence event is + emitted, and the request envelope is never even forced — the gate lives inside + the shared builder rather than at each adapter's call site, and the envelope + parameter is deliberately lazy. Both facts are guarded by tests. + +- `baikai`: `TraceEvent` gains a `CallEvidence` constructor, encoded as + `{"kind":"call_evidence", …}`. A consumer whose pattern match over `TraceEvent` + is exhaustive must add a branch; one with a wildcard is unaffected. Filter for + it with `jq 'select(.kind == "call_evidence") | .evidence'`. Note that a trace + line carries its fields alongside the `kind` discriminator rather than nested + under a `data` key, and that the evidence record inside spells its own fields + in snake_case — the two encodings differ deliberately, because an evidence + record must render an absent field as explicit `null` while a trace line drops + it to stay small. + +- `baikai`: `Baikai.Provider.Cli.Internal` — the module the two subprocess + providers share — gains the vocabulary for reading what a coding-agent CLI + reported about its own run. `CodexRunReport` and the new + `parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport` fold the + `codex exec --json` event stream into its assistant text, its thread + identifier, and its token counts, instead of concatenating agent-message text + and discarding everything else. `ClaudeCliReport` and + `decodeClaudeCliResult` do the same for `claude -p --output-format json`. + Every field but the message text is optional, because both tools' event + schemas have changed across versions and an absent field is a genuine absence + rather than a parse failure. **Breaking** for anyone calling + `parseCodexJsonlStream` directly: its result type is no longer `Text`. This is + an internal module and is documented as outside the PVP guarantee. + +- `baikai`: `Baikai.Provider.Cli.Internal` also gains `ExecutableIdentity` and + `executableIdentity`, which resolve a configured executable name to an + absolute path and read the tool's own `--version` line. The probe is cached + per resolved name for the lifetime of the process, because spawning it per + model call would roughly double the process cost of the cheapest possible + call, and it is bounded by a two-second timeout so a tool that hangs on + `--version` cannot wedge a model call. A probe that fails records the version + as absent rather than failing the call. It is only ever called from inside + the evidence branch: a caller who asked for no evidence must not pay for a + process whose only purpose is to describe a tool they were about to run + anyway. + +- `baikai`: `subprocessStrength` and `cliResponseEnvelope`, also in + `Baikai.Provider.Cli.Internal`. The former derives a subprocess call's + evidence strength from what the tool reported and **nothing else** — the exit + status is deliberately not one of its arguments. The latter spells the + response-commitment envelope with the same three keys, in the same shapes, as + the two API transports build by hand, so a verifier holding a response can + recompute the digest without first knowing which transport served it. + +- `baikai`: `Baikai.Agent` gains `AgentRunOutcome` and `agentRunOutcome`. It + pairs what an unattended run did — the existing + `Either AgentRunFailure AgentRunResult` — with the evidence the runner built + for it. The evidence is a sibling of the outcome rather than a field on + `AgentRunResult` because the run that most needs a record is one that did not + produce a result: a run killed by its own timeout reports + `Left (RunTimedOut …)`, so a record hanging off the `Right` would be + unreachable exactly there. + +### Fixed + +- `baikai`: a `call_evidence` event is now emitted **before** its call's + terminal `call_finished` or `call_failed`, rather than after. The + OpenTelemetry sink ends and removes a call's span on the terminal, so under + the old order its evidence-attribute branch was unreachable from any real + call and every backend saw a span with no evidence on it — nothing failed, + the attributes were simply never there. No consumer can have depended on the + old order, because no consumer has ever seen a `call_evidence` line. + +- `baikai`: the `ThinkingFormatOpenAI` Haddock in `Baikai.Compat` listed the + native `reasoning_effort` vocabulary as `minimal | low | medium | high`, which + predates `xhigh` and `max`. It now lists all six and states that this shape + alone sends the canonical baikai level verbatim while the other six clamp + through `compatibleEffort`. No behaviour changed: the native path's exclusion + from that clamp is deliberate and is guarded by two named tests in + `baikai-openai/test/ShapeSpec.hs`. A reader who consulted the comment to + decide whether `xhigh` was safe to use against OpenAI has until now been told + something untrue. + +### Changed + +- **Breaking:** `baikai`: `TerminalPayload` gains an `evidence` field and the two + terminal smart constructors take it as their new first argument: + `doneTerminal :: Maybe ModelCallEvidence -> Maybe Text -> StopReason -> Message -> TerminalPayload` + and `errorTerminal` likewise. `Response` gains the same field. A custom + provider implementation must pass `Nothing` (or a record it builds through + `Baikai.Evidence.Build`); a custom `Response` built with the record + constructor must add `evidence = Nothing`. Code that only pattern-matches on + these types is unaffected. + +- **Breaking:** `baikai`: `CallFinished` gains `cachedInputTokens`, + `cacheWriteTokens`, `reasoningTokens`, and `totalTokens`. The trace path used + to drop counts that `Baikai.Cost.Log.CallLogEntry` kept from the same `Usage` + value, which made the cost log strictly more faithful than the trace. + +- **Breaking:** `baikai`: a computed cost of **zero is now reported as zero** + rather than suppressed, in `CallFinished` and at all three `CallLogEntry` + construction sites. Previously `usd` was omitted whenever the cost came out at + zero, so "this call was free" and "baikai could not price this call" were + indistinguishable — and the subscription-based CLI providers always price at + zero, so that was the common case rather than a corner. **A cost dashboard + that treated an absent `usd` as "unpriced" will now count those calls as + costing zero.** That is the correct reading, but it changes what such a + dashboard shows. + +- **Breaking:** `baikai`: `FromJSON TraceEvent` is written out by hand instead of + derived. The three pre-existing kinds decode exactly as before; a + `call_evidence` line fails to parse with a message saying to read it as a + plain `Data.Aeson.Value`. `ModelCallEvidence` has no `FromJSON` on purpose — + it embeds a `Cost` whose exact `Rational` amounts encode through an + approximating `Scientific`, so a decoder would return a different value than + was encoded — and manufacturing that fidelity would be the precise failure + this vocabulary exists to eliminate. + +- `baikai`: `Baikai.Trace.Sink.renderHuman` renders a `CallEvidence` event as a + single `EVIDENCE run=… call=… strength=…` line rather than the whole record. A + human-readable sink is for watching calls go by; the full record is meant to + be read out of `fileSink` output by a machine. + +- `baikai`: call identifiers on the trace path are now globally unique. + `Baikai.Evidence.newCallId` produces 32 lowercase hexadecimal characters + carrying 128 bits — 48 bits of Unix time in milliseconds, 48 bits of a + per-process random seed drawn once from `/dev/urandom`, and a 32-bit counter. + The previous generator combined the process-start *second* with a + process-local counter into 16 characters, so two processes started within the + same second emitted identical identifier sequences; its own documentation + claimed only per-process uniqueness. Identifiers still sort chronologically + and are still not secrets. + + `Baikai.Trace.newEventId` keeps its name and signature, delegates to + `newCallId`, and is now deprecated. Anything that pinned the 16-character + width — a log parser, a fixture, a column type — must widen to 32. + +- `baikai`: `renderCeilingViolation` no longer prints the raw provider arguments + a `ProviderArgsForbidden` violation carries. It reports how many were + requested and states that their values are not shown. Raw provider arguments + are the one part of a job description that can hold a credential — the + configuration layer classifies the setting secret for that reason — and a + refusal message that quoted them defeated the classification. The constructor + keeps its `[Text]` payload so a programmatic caller can still inspect it. + +## [baikai-claude 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai-claude`: new exposed module `Baikai.Provider.Claude.Agent` with + `ClaudeAgentConfig`, `defaultClaudeAgentConfig`, and `claudeAgentCommand`, a + pure renderer from an unattended `AgentRunRequest` to the `claude` argument + vector. It maps the capability profile onto `--permission-mode` + (`plan` / `acceptEdits` / `bypassPermissions`), joins a tool allow-list into + one `--allowedTools` argument, repeats `--add-dir` per extra directory, always + emits `-p`, and emits `--no-session-persistence` unless `persistSession` is + set. The prompt travels on standard input and appears nowhere in the argument + vector. A request naming a different provider is refused with + `ProviderMismatch`. Nothing is spawned. + +- `baikai-claude`: the Anthropic Messages provider now fills in the evidence + record it previously left blank. It records the model **Anthropic reported + running** (read from the `message_start` event, which the adapter already + decoded for the response id and then discarded), Anthropic's `request-id` + correlation header, the response id, the token counts Anthropic actually + reported, and a commitment digest over the assembled response. A field the + provider did not report stays `"unobserved"` and is never backfilled from the + request — in particular, a stream that fails before `message_start` reports no + observed model at all. `strength` is `model_observed` when both the model and a + correlation identifier arrived, `correlated` when only the identifier did, and + `requested_only` otherwise; a 2xx status never raises it, because a 200 means + the request was accepted, not that any particular model ran. + `fully_observed` is unreachable on this transport, since Anthropic does not + echo the thinking configuration it applied. + +- `baikai-claude`: an evidence record's `thinking` field now describes what the + caller's reasoning-effort preference actually became on the wire, including + three downgrades that were previously invisible everywhere in baikai's output: + asking for thinking on a model that does not advertise `reasoning` + (`thinking_dropped_unsupported_model`); asking for a level whose token budget + does not fit under the resolved output-token ceiling + (`thinking_dropped_budget_exceeded`, carrying both colliding numbers), which is + reachable by lowering `maxTokens` alone; and asking for `high` on an + adaptive-thinking model, which sends no effort field and so is + wire-indistinguishable from taking Anthropic's default depth + (`effort_omitted`). `minimal` on an adaptive model reports `effort_clamped`, + because Anthropic's adaptive vocabulary has no `minimal`. + +- `baikai-claude`: new exports from `Baikai.Provider.Claude.Sse` — + `ResponseMetadata` and `capturedHeaderNames` — and from + `Baikai.Provider.Claude.Api` — `claudeMessagesStreamWith`, `SseDriver`, and + `anthropicStrength`. Response-header capture is an **allow-list** + (`request-id`, `x-request-id`, `cf-ray`, in that preference order), not a + denylist, so a header a future gateway adds is not recorded by default. + +- `baikai-claude` and `baikai-openai`: both subprocess providers now fill in the + evidence record they previously left blank, and both export the translation + function that describes it — `claudeCliThinking` and `codexCliThinking`. They + record the session or thread identifier the tool reported, the token counts it + reported, the model it named when it names one, the resolved executable path + in place of an endpoint URL, the tool's own `--version` string as the + implementation version (for this transport the tool *is* the implementation), + a request commitment over the rendered argument vector, and a response + commitment over the assembled answer. + + **A zero exit status never raises the strength.** A coding-agent CLI that + exits zero has demonstrated that it ran and did not crash; it has not stated + which model served the request. Subprocess calls almost always exit zero, so + encoding that as corroboration would make the weakest evidence in the system + look like the strongest. `strength` is `model_observed` only when the tool + named both an identifier and a model, `correlated` when it named only an + identifier, and `requested_only` otherwise. + + The two transports differ in how far they can get. `claude` names the model + that consumed tokens in its result event's `modelUsage` map, complete with a + context-window variant marker such as `[1m]`, so a Claude CLI run can reach + `model_observed`. `codex-cli 0.146.0` names no model anywhere in its event + stream, so **no** Codex CLI run can exceed `correlated` — backfilling the + `--model` flag baikai passed would report the request as an observation. + +- `baikai-claude`: an evidence record's `thinking` field now describes what a + reasoning-effort request became on the `claude` command line: mode `flag`, + wire field `--effort`, and an `effort_clamped` adjustment recording the + `minimal` → `low` collapse, because the tool's `--effort` flag has no + `minimal`. A caller asking for `minimal` and a caller asking for `low` produce + byte-identical argument vectors — and therefore identical request commitment + digests — so the translation is the only place that difference survives. + +- **Breaking:** `baikai-claude` and `baikai-openai`: `claudeAgentCommand` and + `codexAgentCommand` return `(AgentCommand, ThinkingTranslation)` rather than + `AgentCommand`. The runner deliberately imports no vendor renderer, so it + cannot derive the translation and has to be handed it. A caller that only + wants the command writes `fmap fst`. Both modules also export the translation + function alone — `claudeAgentThinking` and `codexAgentThinking` — for asking + what a level would become without rendering anything. + +### Fixed + +- **Loud:** `baikai-claude` and `baikai-openai`: both subprocess providers + hardcoded `usage = zeroUsage` on every call, so a cost dashboard saw every + `claude -p` and `codex exec` call as consuming no tokens and costing nothing. + Both tools report their own token counts and baikai now carries them through, + normalized into the disjoint `Usage` convention: `claude`'s counts are + Anthropic-shaped and already disjoint, while `codex` reports OpenAI-style + inclusive prompt counts, so its cached tokens are subtracted out of + `inputTokens`. `claude` additionally reports a `total_cost_usd`, which now + populates `Usage.cost` exactly rather than being reported as zero. + + **A dashboard that read these calls as free will now see real tokens and, for + `claude`, a real cost.** That is the correction, not a regression — but it + changes what existing reports show, and totals over historical data will not + match totals over new data. + +- `baikai-claude`: `Response.responseId` was always `Nothing` on the `claude -p` + transport even though `ClaudeCliResult` decoded the tool's `session_id` one + screen earlier and then dropped it. It now carries that identifier, on both + the successful and the failed terminal. `baikai-openai`: the same for + `codex exec`, whose thread identifier was filtered out of the event stream + along with everything that was not an `agent_message`. These are the handles + each vendor's support tooling looks a run up by. + +### Changed + +- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Sse`'s four streaming + entry points — `claudeSseStream`, `claudeSseStreamValue`, + `claudeSseStreamValueWithHeaders`, and `sseFromResponse` — take a new + `ResponseMetadata -> IO ()` callback immediately before the existing per-event + callback. It fires exactly once, before the first event, on both the success + and the non-2xx path. Pass `(\_ -> pure ())` to keep the previous behaviour. + The callback is separate rather than a widening of the per-event one because + the per-event callback runs once per SSE frame and response-level data does not + belong on that path. + +- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Internal.Request`'s + `mapRequest` now returns + `Either Text (Messages.CreateMessage, ThinkingTranslation)` and + `computeThinking` returns `(ThinkingPlan, ThinkingTranslation)`. Take `fst` to + keep the previous value. This module is exposed for provider tests and + debugging and its header states it is not covered by PVP compatibility + guarantees, but the change is recorded here because that is not a licence to + break a consumer silently. + +- **Breaking:** `baikai-claude`: `claudeInteractiveCommand` now returns + `Either AgentRenderError (FilePath, [String])` and `launchClaudeInteractive` + returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request + whose `safety` is a `CodexSandbox` policy — which Claude Code cannot express + — is refused with `SafetyNotExpressible AgentClaude`, naming the rejected + sandbox mode and approval policy and suggesting `ClaudeAllowedTools` or + `DefaultSafety`. Previously the policy was silently discarded and an + **unrestricted** Claude session was started and reported as a success. A + `Left` means no process was started; a `Right` with a non-zero exit code + means the session ran and exited non-zero. `DefaultSafety` and an empty + `ClaudeAllowedTools` list still render no safety flag and are never refused, + and no previously rendered argument vector changed. Callers must handle the + refusal branch. + +## [baikai-openai 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai-openai`: new exposed module `Baikai.Provider.OpenAI.Agent` with + `CodexAgentConfig`, `defaultCodexAgentConfig`, and `codexAgentCommand`, the + same renderer for `codex exec`. It maps the capability profile onto + `--sandbox` (`read-only` / `workspace-write` / `danger-full-access`), emits + `--cd` for the working root, and defaults `--skip-git-repo-check` and + `--ephemeral` on. A request carrying a tool allow-list is **refused** with + `UnsupportedToolRestriction`, because `codex exec` has no such flag and running + it with unrestricted tools would grant more authority than the caller asked + for. Nothing is spawned. + +- `baikai-openai`: an evidence record's `thinking` field now describes what the + caller's reasoning-effort preference became on the wire for the specific host + the call went to, across **all seven** OpenAI-compatible wire shapes. The + OpenAI-native shape sends the canonical level verbatim and records no + adjustment, because it expresses every level exactly. The four shapes that + carry an effort word for a non-native host record `effort_clamped` whenever + the word differs from the canonical name — `minimal` becomes `low`, and both + `xhigh` and `max` become `high`. Z.ai and Qwen accept a bare + `enable_thinking: true` with no depth, so **every** level records + `effort_collapsed_to_toggle`: a caller asking for `max` and a caller asking + for `low` produce byte-identical requests there, and only the evidence record + can tell them apart. A host with no reasoning controls records + `thinking_dropped_unsupported_host` where the option previously vanished with + no trace. A forty-two-row table test pins the translation and the shaped + request body for every shape at every level. + +- `baikai-openai`: the Chat Completions provider now fills in the evidence record + it previously left blank. It records the model **the host reported running** + (read from the first streamed chunk carrying a top-level `model` field and + never overwritten by a later one), the host's `x-request-id` correlation + header, the response id, the token counts the host actually reported, and a + commitment digest over the assembled response. A field the host did not report + stays `"unobserved"` and is never backfilled from the request — in particular, + a call that fails before any chunk arrives reports no observed model at all. + `strength` is `model_observed` when both the model and a correlation + identifier arrived, `correlated` when only the identifier did, and + `requested_only` otherwise; a 2xx status never raises it, because a 200 means + the request was accepted, not that any particular model ran. + `fully_observed` is unreachable on this transport, since no host in this + ecosystem echoes the reasoning configuration it applied. + +- `baikai-openai`: new exports from `Baikai.Provider.OpenAI.Sse` — + `ResponseMetadata` and `capturedHeaderNames` — and from + `Baikai.Provider.OpenAI.Api` — `openaiChatStreamWith` and `SseDriver`. + Response-header capture is an **allow-list** (`x-request-id`, `request-id`, + `x-amzn-requestid`, `x-ms-request-id`, `cf-ray`, in that preference order), + not a denylist, so a header a future gateway adds is not recorded by default. + The list is longer than the Anthropic one because this transport speaks to an + open-ended set of hosts and the gateways commonly in front of them. + +- `baikai-openai`: the same field for `codex exec`: mode `flag`, wire field + `model_reasoning_effort`, and **no** adjustments at any level. Codex is the + only transport in baikai that expresses all six canonical levels exactly, and + a test asserts each one reaches the command line verbatim. + +### Fixed + +- `baikai-openai`: `Response.responseId` was always `Nothing` on the Chat + Completions transport, although every compatible host sends a top-level `id` + on every streamed chunk. It now carries the identifier the host reported, on + both the successful and the failed terminal. + +### Changed + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Sse`'s four streaming + entry points — `openaiSseStream`, `openaiSseStreamValue`, + `openaiSseStreamValueWithHeaders`, and `sseFromResponse` — take a new + `ResponseMetadata -> IO ()` callback immediately before the existing per-chunk + callback. It fires exactly once, before the first chunk, on both the success + and the non-2xx path — a failed call's correlation identifier is if anything + more valuable than a successful one's. Pass `(\_ -> pure ())` to keep the + previous behaviour. The callback is separate rather than a widening of the + per-chunk one because that one runs once per SSE frame and response-level data + does not belong on that path. + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Api`'s `RawChunk` gains + `model` and `responseId` fields, both `Maybe Text`. Code that pattern-matches + on `RawChunk` is unaffected; code that constructs one with record syntax must + add them. + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Shape`'s + `shapeRequestBody`, `streamRequestBody`, and `injectThinkingShape` now return + `(Aeson.Value, ThinkingTranslation)` instead of a bare body. Take `fst` to + keep the previous value. The description has to travel out of the shaping step + because nothing downstream can recompute it: it depends on the host's + `ThinkingFormat`, which only the compat lookup knows. **No request body + changed** — every one of the seven shapes puts exactly the same bytes on the + wire as before. + +- **Breaking:** `baikai-openai`: `codexInteractiveCommand` now returns + `Either AgentRenderError (FilePath, [String])` and `launchCodexInteractive` + returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request + whose `safety` is a non-empty `ClaudeAllowedTools` list — which `codex` has + no flag for — is refused with `SafetyNotExpressible AgentCodex`, quoting the + rejected tools and suggesting `CodexSandbox` or `DefaultSafety`. Previously + the allow-list was silently discarded and Codex was started with its default + sandbox. The same `Left`/`Right` reading applies, `DefaultSafety` and an + empty allow-list are never refused, and no previously rendered argument + vector changed. Callers must handle the refusal branch. + + Both changes make the interactive surface honor the same contract as the new + unattended surface: a safety policy the chosen provider cannot express fails + visibly instead of silently becoming a weaker policy. Downstream consumers + must adapt before upgrading; the known one is `shinzui/seihou`, whose + `Seihou.CLI.AgentLaunchExec` module builds interactive launch requests. + +## [baikai-trace-otel 0.3.0.3] - 2026-08-05 + +### Added + +- `baikai-trace-otel`: the sink attaches an evidence record's salient fields to + the open span as flat attributes (`baikai.evidence.run_id`, + `baikai.evidence.call_id`, `baikai.evidence.strength`, the two digests, and + `gen_ai.response.model` only when the provider actually reported one) rather + than serialising the record into one blob. A `CallEvidence` event neither + opens nor closes a span. + +### Changed + +- `baikai-trace-otel`: widened its `baikai` bound to admit `0.5`. No API change. + +## [baikai-effectful 0.3.0.3] - 2026-08-05 + +### Changed + +- Widened its `baikai` bound to admit `0.5`. No API change; the package's + own surface is untouched. + +## [baikai-kit 0.1.0.4] - 2026-08-05 + +### Changed + +- Widened its `baikai` bound to admit `0.5`. No API change; the package's + own surface is untouched. + +## [baikai-agent 0.1.0.0] - 2026-08-05 + +### Added + +- `baikai-agent`: **new package** (`0.1.0.0`) holding the unattended + coding-agent runner. `Baikai.Agent.Run.runAgentCommand` takes an + `AgentRunRequest` and an already-rendered `AgentCommand` and spawns the tool + with no terminal and no human present. It delivers the prompt on standard + input and closes the handle, drains standard output and standard error + concurrently so a chatty agent cannot deadlock on a full pipe, retains at most + `outputLimit` bytes per stream while reading and discarding the excess, and + honors the three output disciplines. Preconditions run before any spawn: a + missing working directory is `WorkingDirMissing` and unset or empty declared + variables are `MissingEnvironment`, listing all of them at once. On timeout + the child's whole process group is interrupted, given a grace period, and then + terminated, so the agent's own child processes go with it; the failure reports + the configured limit. A non-zero exit code is a successful run carrying that + code, not a failure. The runner consumes an already-rendered `AgentCommand` + and never imports a vendor renderer, so it is exercised entirely with + hand-written argument vectors. Its POSIX-signal escalation is conditional on a + non-Windows build. + +- `baikai-agent`: new exposed module `Baikai.Agent.Config`, the layered + configuration layer. `resolveAgentJob` resolves one named job across five + layers — built-in defaults, the operator file, the repository file, the + environment, then command-line overrides, later layers winning — and returns + the resolved `AgentJob` together with a report attributing every value to the + file, line, and column it came from. `agentJobRequest` converts a job into an + `AgentRunRequest`, taking the prompt at call time. `listAgentJobs` enumerates + configured job names, sorted, each attributed to the highest-precedence scope + defining it. `defaultAgentConfigPaths` locates + `$XDG_CONFIG_HOME/baikai/agents.kdl` (or `$HOME/.config/baikai/agents.kdl`) + and `./.baikai/agents.kdl`, with no upward search through parent directories. + + The **policy ceiling** is loaded by a separate function, `loadAgentCeiling`, + against a separate source list containing the operator file and nothing else: + no repository file, environment variable, or command-line override can raise + it. `applyCeilingToJob` refuses an over-broad request with `CeilingRejected` + rather than clamping it. With no operator file the ceiling is + `defaultAgentCeiling`. `safety.provider-args` is classified secret and renders + as `` in any report or structured error. + + New dependencies: `settei`, `settei-env`, `settei-kdl`, and + `settei-optparse-applicative` (all `^>=0.2`, published on Hackage at + `0.2.0.0`), plus `containers` and `filepath`. `settei-formats` is deliberately + excluded, because it bundles Dhall loading and repository configuration is + untrusted input here. + +- `baikai-agent`: the **`baikai` executable**, with the `agent run`, + `agent show`, and `agent list` commands, and the `Baikai.Agent.Cli` module + that implements them. A shell script now invokes one stable command, supplies + a prompt on standard input, and selects Claude Code or Codex entirely through + configuration. + + `agent run` resolves the named job, caps it against the operator ceiling, + renders it through the vendor renderer for its provider, and spawns it. The + agent's own exit code passes through unchanged; Baikai's own failures use 64 + and above following the `sysexits` convention — 64 for a usage error or an + empty prompt, 69 when the executable could not be started, 70 for malformed + output, 75 for a timeout, 77 for a policy refusal, and 78 for a configuration + problem. The prompt comes from `--prompt-stdin`, `--prompt-file`, or + `--prompt`, which are mutually exclusive, and is decoded as UTF-8 explicitly + rather than through the handle's locale encoding. + + `agent show` performs the whole pipeline except spawning and prints each + resolved value with the file, line, and column it came from, the policy + ceiling in force and where it was read, and the exact argument vector that + would be spawned — with `` in place of any raw provider argument. A + job whose policy is refused prints its configuration first and then the + refusal. `agent list` enumerates configured jobs and the scope each came from. + + Every Baikai diagnostic goes to standard error. The agent's own output follows + the job's output mode, so `response=$(baikai agent run job)` yields the + agent's answer alone for a capturing job. `--set KEY=VALUE` overrides one + setting of the selected job through `settei`'s own command-line source, so an + override is attributed with the same fidelity as a file. `--json` emits + exactly one JSON object per command. + + New dependencies for `baikai-agent`: `baikai-claude`, `baikai-openai`, and + `optparse-applicative`. The provider packages are needed only so that + `renderJobCommand`, the single provider dispatch point in the codebase, can + reach both renderers. This is the first dependency in the workspace from + `baikai-agent` onto the provider packages, so `baikai-agent` now publishes + after all three of `baikai`, `baikai-claude`, and `baikai-openai`. + + The user guide `docs/user/unattended-agent-runs.md` documents the whole + surface: the three commands with their flags, exit codes, and stream + discipline; the KDL job format and layer precedence; the operator ceiling and + redaction; the capability mapping tables for both tools; and a before-and-after + migration of a script that embeds provider flags today. + `docs/user/cli-providers.md` and `docs/user/interactive-launches.md` link to + it, and the capability mapping tables moved there from the latter. + +- `baikai-agent`: **an unattended coding-agent run now produces model-call + evidence.** This surface previously had no observability of any kind: no trace + sink, no `Response`, no usage, no identifiers. An operator could show that a + process started, exited, and took some time; they could not show which model + ran, which reasoning effort was applied, or which agent session the run + corresponds to in the vendor's records. + + A record carries the run and call identifiers, the resolved executable and its + own reported version, digests over the request, the requested model and what + the reasoning-effort request became on the command line, whatever the tool + reported about itself, the outcome, and an honest strength. + + **A zero exit status never raises the strength.** On this surface that rule + matters more than anywhere else, because almost every unattended run exits + zero. A coding agent that exits zero has demonstrated that it ran, not which + model served it. + + Two things gate what a record can prove, and neither is the default. The job + must **capture** output — under `inherit` the agent's bytes went to the + operator's terminal and baikai never held them — and the tool must be + configured to print a structured format, which means `--output-format json` + for `claude` or `--json` for `codex exec` through the job's `provider-args`. + Without both, the tool's session identifier, model, and token counts are + genuinely unavailable and the record says `"unobserved"` rather than inferring + anything. A timed-out run records `aborted`; a run that never started records + nothing at all. + +- **Breaking:** `baikai-agent`: `Baikai.Agent.Run.runAgentCommand` takes two new + leading arguments and returns the new outcome type: + `Maybe EvidenceRequest -> ThinkingTranslation -> AgentRunRequest -> AgentCommand -> IO AgentRunOutcome`. + A caller who wants the previous behaviour passes `Nothing` and + `Baikai.Evidence.noThinkingRequested` and reads the `outcome` field; that path + is byte-for-byte what it was, and costs what it cost — no digest is computed, + no call identifier is generated, and the tool is not invoked a second time to + read its version. + +- `baikai-agent`: `baikai agent run` gains `--evidence-file PATH` and + `--run-id TEXT`. Supplying neither leaves the run on the pre-existing path at + the pre-existing cost; supplying either turns recording on, with the job's own + name standing in as the run identifier when only a destination is given. The + file is written atomically — a staging file beside the destination, then a + rename — so a reader polling the path never sees a half-written object, and it + is never appended to. A failed write is reported on standard error and never + changes the exit code, because the agent's own status is what a calling script + branches on. `docs/user/unattended-agent-runs.md` documents both options and, + more importantly, what the record does and does not prove. + +- `baikai-agent`: `baikai agent run` gains `--require-evidence STRENGTH`, taking + `requested_only`, `correlated`, `model_observed`, or `fully_observed` — the + same words a record's `strength` field spells, so what one record showed can + be passed back as the next run's requirement. A job whose configuration cannot + produce evidence of at least that strength is refused before anything is + spawned, exiting 77 — the code a ceiling violation and an inexpressible safety + policy already use, so a script branching on 77 needs no new case. + +## [baikai-claude 0.4.0.1] - 2026-07-30 + +### Fixed + +- Widened the `crypton` bound from `^>=1.0` to `>=1.0 && <1.2` so consumers can + build `baikai-claude` alongside packages that require `crypton` 1.1.x (for + example `pg-migrate-1.1.0.0`), which previously had no solvable build plan. + The only `crypton` use is `Crypto.Hash` (`Digest`, `SHA256`) in + `Baikai.Provider.Claude.Transport`, whose API is identical across the 1.0/1.1 + boundary. No API change. + ## [baikai 0.4.1.0] - 2026-07-20 ### Changed diff --git a/baikai.cabal b/baikai.cabal --- a/baikai.cabal +++ b/baikai.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai -version: 0.4.1.0 +version: 0.5.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -25,6 +25,21 @@ -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 @@ -37,6 +52,7 @@ hs-source-dirs: src exposed-modules: Baikai + Baikai.Agent Baikai.AgentAssets Baikai.Api Baikai.Auth @@ -49,6 +65,8 @@ Baikai.Cost.Pricing Baikai.Embedding Baikai.Error + Baikai.Evidence + Baikai.Evidence.Build Baikai.Interactive Baikai.Message Baikai.Model @@ -70,15 +88,26 @@ Baikai.Trace.Sink Baikai.Usage + -- The cabal-generated version module. 'Baikai.Evidence.Build' reads + -- it so an evidence record can name the build that produced it, + -- centrally rather than through a literal in each of the five + -- packages that construct evidence. + other-modules: Paths_baikai + autogen-modules: Paths_baikai build-depends: , aeson ^>=2.2 , base >=4.20 && <5 + , base16-bytestring ^>=1.0 , base64-bytestring ^>=1.2 , bytestring ^>=0.12 , containers ^>=0.7 + , cryptohash-sha256 ^>=0.11 + , directory ^>=1.3 + , filepath ^>=1.5 , generic-lens ^>=2.3 , lens ^>=5.3 , openai ^>=2.5 + , process ^>=1.6 , scientific ^>=0.3 , streamly >=0.11 && <0.13 , streamly-core >=0.3 && <0.5 @@ -136,6 +165,7 @@ main-is: Main.hs other-modules: AgentAssetsSpec + AgentSpec CatalogSpec CliInternalSpec ContextSpec @@ -143,6 +173,7 @@ EmbeddingSpec ErrorInfoSpec ErrorSpec + EvidenceSpec FetchModelsCore FetchModelsSpec GenModelsCore @@ -150,6 +181,7 @@ HelpersSpec InteractiveSpec StreamSpec + StrictEvidenceSpec SurfaceSpec ThinkingLevelSpec TraceSpec diff --git a/src/Baikai.hs b/src/Baikai.hs --- a/src/Baikai.hs +++ b/src/Baikai.hs @@ -30,6 +30,8 @@ module Baikai.Usage, module Baikai.Cost, module Baikai.Error, + module Baikai.Evidence, + module Baikai.Evidence.Build, module Baikai.Interactive, -- * Per-API compat shims and call-time options @@ -56,6 +58,8 @@ import Baikai.Context import Baikai.Cost import Baikai.Error +import Baikai.Evidence +import Baikai.Evidence.Build import Baikai.Interactive import Baikai.Message import Baikai.Model diff --git a/src/Baikai/Agent.hs b/src/Baikai/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Agent.hs @@ -0,0 +1,617 @@ +-- | Provider-neutral types for unattended coding-agent runs with +-- local agent CLIs such as Claude Code and Codex. +-- +-- An unattended run starts the coding agent with no terminal and no +-- human present, lets it drive its own internal tool loop, allows it +-- to change files inside directories the caller explicitly authorized, +-- and collects a process result. It is neither a completion (the +-- interesting output is the changed working tree, not the text) nor an +-- interactive launch (nobody is watching). +-- +-- This module deliberately does not implement process spawning, and it +-- renders no command-line flags. The core package owns the shared +-- vocabulary and the pure policy algebra, while vendor packages own the +-- translation into their CLI's arguments and a separate package owns +-- the process runner. +-- +-- This module is not re-exported from "Baikai". Its field accessors +-- deliberately share names with "Baikai.Interactive", so import it +-- directly, qualified if you need both surfaces at once. +module Baikai.Agent + ( -- * Provider identity + AgentProvider (..), + renderAgentProvider, + parseAgentProvider, + + -- * Capability profile + AgentCapability (..), + renderAgentCapability, + parseAgentCapability, + + -- * Requested safety policy + AgentSafety (capability, allowedTools, providerArgs), + agentSafety, + + -- * Output discipline + AgentOutputMode (..), + renderAgentOutputMode, + parseAgentOutputMode, + AgentCapturedOutput (..), + capturedBytes, + + -- * The unattended run request + AgentRunRequest + ( provider, + prompt, + modelId, + effort, + workingDir, + extraDirs, + safety, + timeout, + output, + outputLimit, + envPassthrough + ), + agentRunRequest, + + -- * The operator policy ceiling + AgentCeiling (maxCapability, allowProviderArgs, allowedProviders), + defaultAgentCeiling, + CeilingViolation (..), + renderCeilingViolation, + applyAgentCeiling, + + -- * The rendered command + AgentPromptTransport (..), + AgentCommand (..), + + -- * The run result + AgentRunResult, + agentRunResult, + AgentRunOutcome (..), + agentRunOutcome, + + -- * Failures + AgentRenderError (..), + renderAgentRenderError, + AgentRunFailure (..), + renderAgentRunFailure, + ) +where + +import Baikai.Evidence (ModelCallEvidence) +import Baikai.Prelude +import Baikai.ThinkingLevel (ThinkingLevel) +import Data.ByteString (ByteString) +import Data.Text qualified as Text +import Data.Time.Clock (NominalDiffTime) +import System.Exit (ExitCode) + +-- | Local coding-agent tools Baikai can describe without depending on +-- a vendor package. The names match 'Baikai.Interactive.InteractiveProvider' +-- so both surfaces spell the same tool identically. +data AgentProvider + = AgentClaude + | AgentCodex + deriving stock (Eq, Ord, Show, Generic) + +renderAgentProvider :: AgentProvider -> Text +renderAgentProvider AgentClaude = "claude" +renderAgentProvider AgentCodex = "codex" + +-- | Parse a canonical provider name. Matching is exact and +-- case-sensitive: @\"Claude\"@ is not a provider. +parseAgentProvider :: Text -> Maybe AgentProvider +parseAgentProvider "claude" = Just AgentClaude +parseAgentProvider "codex" = Just AgentCodex +parseAgentProvider _ = Nothing + +-- | How much authority an unattended run gets, expressed +-- provider-neutrally. Constructors ascend in authority, and the +-- 'Ord' instance derived from that order is what 'applyAgentCeiling' +-- compares against an operator's permitted maximum — do not reorder +-- them. +-- +-- * 'AgentReadOnly': the run may read but must not modify anything. +-- * 'AgentEditWorkspace': the run may modify files inside its working +-- directory and its explicit extra directories, and nowhere else. +-- * 'AgentFullAccess': no sandbox at all. This is why an operator +-- ceiling refuses it by default. +data AgentCapability + = AgentReadOnly + | AgentEditWorkspace + | AgentFullAccess + deriving stock (Eq, Ord, Show, Generic) + +renderAgentCapability :: AgentCapability -> Text +renderAgentCapability AgentReadOnly = "read-only" +renderAgentCapability AgentEditWorkspace = "edit-workspace" +renderAgentCapability AgentFullAccess = "full-access" + +-- | Parse a canonical capability name. Matching is exact and +-- case-sensitive. +parseAgentCapability :: Text -> Maybe AgentCapability +parseAgentCapability "read-only" = Just AgentReadOnly +parseAgentCapability "edit-workspace" = Just AgentEditWorkspace +parseAgentCapability "full-access" = Just AgentFullAccess +parseAgentCapability _ = Nothing + +-- | The safety policy a job asks for, as opposed to what an operator +-- permits. +data AgentSafety = AgentSafety + { -- | How much filesystem authority the run requests. + capability :: !AgentCapability, + -- | Optional narrowing of the provider's tool set. An empty list + -- means \"do not restrict tools beyond what the capability + -- implies\"; a non-empty list is rendered where the provider + -- supports a tool allow-list. + allowedTools :: ![Text], + -- | Raw provider arguments Baikai does not model, passed through + -- verbatim. This is a privileged channel: arbitrary vendor flags + -- can widen authority in ways no capability profile can see, so an + -- operator ceiling gates the channel as a whole. Nothing here + -- inspects these strings for dangerous flags, and nothing should: + -- flag spellings change, and a denylist that misses one provides + -- false confidence rather than a security boundary. + providerArgs :: ![Text] + } + deriving stock (Eq, Show, Generic) + +-- | A safety request for the given capability, with no tool narrowing +-- and no raw provider arguments. +agentSafety :: AgentCapability -> AgentSafety +agentSafety cap = + AgentSafety + { capability = cap, + allowedTools = [], + providerArgs = [] + } + +-- | What Baikai does with the child process's output streams. +-- +-- * 'InheritOutput': the child writes straight to the parent's own +-- streams and Baikai captures nothing. +-- * 'CaptureOutput': Baikai collects the bytes and the parent sees +-- nothing. +-- * 'TeeOutput': both. +data AgentOutputMode + = InheritOutput + | CaptureOutput + | TeeOutput + deriving stock (Eq, Ord, Show, Generic) + +renderAgentOutputMode :: AgentOutputMode -> Text +renderAgentOutputMode InheritOutput = "inherit" +renderAgentOutputMode CaptureOutput = "capture" +renderAgentOutputMode TeeOutput = "tee" + +-- | Parse a canonical output-mode name. Matching is exact and +-- case-sensitive. +parseAgentOutputMode :: Text -> Maybe AgentOutputMode +parseAgentOutputMode "inherit" = Just InheritOutput +parseAgentOutputMode "capture" = Just CaptureOutput +parseAgentOutputMode "tee" = Just TeeOutput +parseAgentOutputMode _ = Nothing + +-- | One captured stream of a finished run. The three states are +-- distinct on purpose: under 'InheritOutput' the bytes went to the +-- parent's terminal and none exist to report, which an empty +-- 'ByteString' could not distinguish from a command that legitimately +-- printed nothing. +data AgentCapturedOutput + = -- | The stream was not captured. + OutputNotCaptured + | -- | The stream was captured in full. + OutputCaptured !ByteString + | -- | The stream was captured up to the byte limit; more existed. + OutputTruncated !ByteString + deriving stock (Eq, Show, Generic) + +-- | The captured bytes, if any were captured at all. +capturedBytes :: AgentCapturedOutput -> Maybe ByteString +capturedBytes OutputNotCaptured = Nothing +capturedBytes (OutputCaptured bytes) = Just bytes +capturedBytes (OutputTruncated bytes) = Just bytes + +-- | Everything an unattended coding-agent run needs, expressed +-- provider-neutrally. This is the single source of truth for every +-- process-level setting: the working directory, the timeout, the output +-- discipline, the output limit, and the declared environment +-- variables. +data AgentRunRequest = AgentRunRequest + { -- | Which coding-agent tool to run. + provider :: !AgentProvider, + -- | The instruction handed to the coding agent. + prompt :: !Text, + -- | 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, not optional: + -- the safety contract is that a run gets no filesystem authority + -- beyond this directory and 'extraDirs', and that sentence has no + -- meaning if the root can be absent. + workingDir :: !FilePath, + -- | Directories this run may reach beyond 'workingDir'. The + -- precise authority is provider-dependent: Claude Code's + -- @--add-dir@ grants tool access, while @codex exec@'s @--add-dir@ + -- grants write access alongside the primary workspace. + extraDirs :: ![FilePath], + -- | The safety policy this job asks for. + safety :: !AgentSafety, + -- | 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, not in total. 'Nothing' + -- means unbounded. + outputLimit :: !(Maybe Int), + -- | Names of environment variables this job declares it requires. + -- These are names only, never name\/value pairs, so the list + -- cannot contain a secret by construction. It is not an allow-list + -- and does not restrict the child's environment: the child + -- inherits the parent's environment in full, because both coding + -- agents need @HOME@, @PATH@, and their own credential files to + -- function. What the list buys is a precondition check — a runner + -- fails before spawning when a declared variable is unset or + -- empty, so a misconfigured job produces one clear error instead + -- of a coding agent that starts and then flails. + envPassthrough :: ![Text] + } + deriving stock (Eq, Show, Generic) + +-- | An unattended run of the given provider, rooted in the given +-- working directory, with the given prompt. Everything else defaults +-- to the least-authority, least-surprising value: no model or effort +-- override, no extra directories, read-only capability, no timeout, +-- inherited output, no output limit, and no declared environment +-- variables. +-- +-- The capability default is 'AgentReadOnly': a caller who wants to +-- change files must say so. That is independent of an operator +-- ceiling, which says what a caller is /allowed/ to ask for. +agentRunRequest :: AgentProvider -> FilePath -> Text -> AgentRunRequest +agentRunRequest p dir userPrompt = + AgentRunRequest + { provider = p, + prompt = userPrompt, + modelId = Nothing, + effort = Nothing, + workingDir = dir, + extraDirs = [], + safety = agentSafety AgentReadOnly, + timeout = Nothing, + output = InheritOutput, + outputLimit = Nothing, + envPassthrough = [] + } + +-- | The limit an operator places on what any job may request. +-- +-- A job description can come from a repository the operator did not +-- write, which makes it untrusted input: it could ask for unlimited +-- filesystem access. A ceiling is a separate, operator-owned value +-- that bounds what any job may ask for, and 'applyAgentCeiling' is the +-- pure check. +data AgentCeiling = AgentCeiling + { -- | The highest capability any job may request. + maxCapability :: !AgentCapability, + -- | Whether jobs may pass raw provider arguments at all. The whole + -- channel is privileged, so it is permitted or refused as a unit + -- rather than filtered. + allowProviderArgs :: !Bool, + -- | The providers jobs may select. An empty list permits __no__ + -- provider; it does not mean \"all providers\". + allowedProviders :: ![AgentProvider] + } + deriving stock (Eq, Show, Generic) + +-- | The ceiling in force when an operator has supplied no policy of +-- their own: a job may ask for read-only or edit-workspace authority, +-- may not ask for full access, and may not pass raw provider +-- arguments; both providers are permitted. +-- +-- An edit-capable default is the only one under which a job that +-- changes files works on a fresh machine with no out-of-band setup, +-- while the two things that can widen authority without bound — +-- sandbox-bypassing modes and arbitrary vendor flags — stay opt-in at +-- operator scope. +defaultAgentCeiling :: AgentCeiling +defaultAgentCeiling = + AgentCeiling + { maxCapability = AgentEditWorkspace, + allowProviderArgs = False, + allowedProviders = [AgentClaude, AgentCodex] + } + +-- | One way a request exceeded a ceiling. +data CeilingViolation + = -- | The requested capability, then the permitted maximum. The + -- order matters: reversing the pair produces a message that blames + -- the wrong side. + CapabilityExceeded !AgentCapability !AgentCapability + | -- | The raw provider arguments that were requested while the + -- channel is closed, in the order given. + -- + -- __Do not render these values.__ This is the one field of a job + -- description an operator could write a credential into, which is + -- why the configuration layer classifies it secret; a refusal + -- message that quoted them would defeat that classification, so + -- 'renderCeilingViolation' reports how many were requested and not + -- what they were. The list is retained rather than reduced to a + -- count because a programmatic caller may legitimately need to + -- inspect it. + ProviderArgsForbidden ![Text] + | -- | The requested provider, then the permitted providers. + ProviderForbidden !AgentProvider ![AgentProvider] + deriving stock (Eq, Show, Generic) + +-- | One line of plain English naming what was asked for and what is +-- permitted. +renderCeilingViolation :: CeilingViolation -> Text +renderCeilingViolation (CapabilityExceeded requested permitted) = + "requested capability " + <> renderAgentCapability requested + <> " exceeds the permitted maximum " + <> renderAgentCapability permitted +renderCeilingViolation (ProviderArgsForbidden args) = + "raw provider arguments are not permitted; " + <> Text.pack (show (length args)) + <> " requested, and their values are secret and are not shown" +renderCeilingViolation (ProviderForbidden requested permitted) = + "provider " + <> renderAgentProvider requested + <> " is not permitted; permitted providers: " + <> renderPermittedProviders permitted + where + renderPermittedProviders [] = "none" + renderPermittedProviders ps = Text.intercalate ", " (map renderAgentProvider ps) + +-- | Check a request against a ceiling. Returns the request +-- __unchanged__ when it is within the ceiling, and every violation +-- when it is not. +-- +-- Two properties are deliberate. The request is never modified to fit +-- the ceiling: a job that asked for more authority than it may have is +-- an error to report, not a request to quietly weaken, because silent +-- clamping is how a job that believes it may edit ends up doing +-- nothing and reporting success. And every violation is collected +-- rather than only the first, so an operator fixing a job description +-- sees all of them in one run. +-- +-- This function does not inspect the contents of the requested +-- 'providerArgs'. See that field's documentation for why a denylist of +-- dangerous flags would be false confidence rather than a boundary. +applyAgentCeiling :: AgentCeiling -> AgentRunRequest -> Either [CeilingViolation] AgentRunRequest +applyAgentCeiling limit request + | null violations = Right request + | otherwise = Left violations + where + requestedProvider = request ^. #provider + permittedProviders = limit ^. #allowedProviders + requestedCapability = request ^. #safety . #capability + permittedCapability = limit ^. #maxCapability + requestedArgs = request ^. #safety . #providerArgs + violations = + concat + [ [ ProviderForbidden requestedProvider permittedProviders + | requestedProvider `notElem` permittedProviders + ], + [ CapabilityExceeded requestedCapability permittedCapability + | requestedCapability > permittedCapability + ], + [ ProviderArgsForbidden requestedArgs + | not (null requestedArgs), + not (limit ^. #allowProviderArgs) + ] + ] + +-- | How the prompt reaches the child process. +data AgentPromptTransport + = -- | The prompt is written to the child's standard input and + -- appears nowhere in the argument vector. + PromptOnStdin + | -- | The prompt is already the final element of the argument + -- vector, protected by the provider's @--@ separator, and the + -- child gets no standard input at all. + PromptAsArgument + deriving stock (Eq, Ord, Show, Generic) + +-- | A rendered provider command: the boundary value between a vendor +-- renderer, which produces it, and a process runner, which consumes +-- it. It lives in the core package so that neither side depends on the +-- other. +-- +-- Honor 'promptTransport' exactly. @codex exec@ documents that a piped +-- standard input /and/ a positional prompt are both used, with +-- standard input appended as a @\@ block, so emitting both is +-- a silent corruption of the instruction. Making the transport an +-- explicit choice turns that hazard into a type-level distinction +-- rather than a convention. +-- +-- This type deliberately carries no working directory. Claude Code has +-- no working-directory flag at all, so for one of the two providers the +-- working directory can only ever be a process-level setting; a runner +-- therefore reads it from 'AgentRunRequest' and takes both values. +-- Duplicating it here was rejected because two copies of a working +-- directory can disagree, and that disagreement would be a sandbox +-- escape rather than a cosmetic bug. +data AgentCommand = AgentCommand + { -- | The program to run, either a bare name resolved on @PATH@ or + -- an explicit path. + executable :: !FilePath, + -- | The rendered argument vector, excluding the program name. + arguments :: ![String], + -- | Where the prompt travels. + promptTransport :: !AgentPromptTransport, + -- | The prompt itself, for a runner that must write it to standard + -- input. + promptText :: !Text + } + deriving stock (Eq, Show, Generic) + +-- | The process-level outcome of a finished unattended run. Read it +-- with @generic-lens@ labels, for example @result ^. #exitCode@. +-- +-- A non-zero exit code is a normal result and lives here rather than +-- in a failure type: a coding agent that fails its task and exits 1 +-- has still run. +data AgentRunResult = AgentRunResult + { -- | Which coding-agent tool ran. + provider :: !AgentProvider, + -- | The child's exit status. + exitCode :: !ExitCode, + -- | The child's standard output, per the request's output mode. + stdout :: !AgentCapturedOutput, + -- | The child's standard error, per the request's output mode. + stderr :: !AgentCapturedOutput, + -- | How long the run took. + duration :: !NominalDiffTime + } + deriving stock (Eq, Show, Generic) + +-- | A result with both streams marked 'OutputNotCaptured'. +agentRunResult :: AgentProvider -> ExitCode -> NominalDiffTime -> AgentRunResult +agentRunResult p code elapsed = + AgentRunResult + { provider = p, + exitCode = code, + stdout = OutputNotCaptured, + stderr = OutputNotCaptured, + duration = elapsed + } + +-- | Everything one finished unattended run produced: what happened, and +-- the evidence the runner built for it. +-- +-- The two are siblings rather than the evidence living inside +-- 'AgentRunResult', because the run that most needs a record is one that +-- did not produce a result. A run killed by its own timeout started, ran, +-- consumed tokens, and possibly changed the working tree, and it reports +-- @Left ('RunTimedOut' …)@ — so evidence hanging off the @Right@ would be +-- unreachable in exactly the case an operator most wants it. +-- +-- 'evidence' is 'Nothing' in two situations that must not be confused. +-- The caller asked for none, which is the default and costs nothing. Or +-- nothing ever started — a missing working directory, an unset declared +-- environment variable, an executable that could not be spawned — and +-- there is no run to describe. +data AgentRunOutcome = AgentRunOutcome + { outcome :: !(Either AgentRunFailure AgentRunResult), + evidence :: !(Maybe ModelCallEvidence) + } + deriving stock (Eq, Show, Generic) + +-- | An outcome carrying no evidence, for the paths where none was asked +-- for or none exists. +agentRunOutcome :: Either AgentRunFailure AgentRunResult -> AgentRunOutcome +agentRunOutcome result = AgentRunOutcome {outcome = result, evidence = Nothing} + +-- | A refusal raised before any process is created: the requested +-- policy cannot be expressed honestly for the chosen provider, so the +-- run must not start. +-- +-- Every constructor that reports an inexpressible policy carries a +-- human-readable explanation, because a refusal that does not say +-- /why/ is a dead end rather than an error an operator can act on. +data AgentRenderError + = -- | The provider, the capability it cannot express, and why. + UnsupportedCapability !AgentProvider !AgentCapability !Text + | -- | The provider cannot honor a tool allow-list, and why. + UnsupportedToolRestriction !AgentProvider !Text + | -- | The general case: this provider cannot honor the requested + -- safety policy, and why. It carries no capability, so it also + -- serves surfaces whose safety vocabulary has no capability + -- profile — notably the interactive launchers, which share this + -- refusal type rather than growing a parallel one. + SafetyNotExpressible !AgentProvider !Text + | -- | The provider the renderer implements, then the provider the + -- request named. Each vendor renderer is a separate function in a + -- separate package, so nothing in the type system stops a caller + -- from handing a Codex request to the Claude renderer; without + -- this constructor the renderer's only options would be to + -- silently render the wrong provider's flags or to throw. The + -- order matters: reversing the pair names the wrong culprit. + ProviderMismatch !AgentProvider !AgentProvider + | -- | The request exceeded the operator's policy ceiling. + CeilingRejected ![CeilingViolation] + deriving stock (Eq, Show, Generic) + +renderAgentRenderError :: AgentRenderError -> Text +renderAgentRenderError (UnsupportedCapability p cap why) = + renderAgentProvider p + <> " cannot express the requested capability " + <> renderAgentCapability cap + <> ": " + <> why +renderAgentRenderError (UnsupportedToolRestriction p why) = + renderAgentProvider p + <> " cannot express the requested tool restriction: " + <> why +renderAgentRenderError (SafetyNotExpressible p why) = + renderAgentProvider p + <> " cannot honor the requested safety policy: " + <> why +renderAgentRenderError (ProviderMismatch renderer requested) = + "the " + <> renderAgentProvider renderer + <> " renderer cannot render a request for provider " + <> renderAgentProvider requested +renderAgentRenderError (CeilingRejected violations) = + "the request exceeds the permitted policy ceiling: " + <> Text.intercalate "; " (map renderCeilingViolation violations) + +-- | A failure raised while spawning the child process or waiting for +-- it. +-- +-- There is deliberately no constructor for \"the process exited +-- non-zero\". That is a normal outcome and lives in 'AgentRunResult': +-- a coding agent that fails its task and exits 1 has still run. +data AgentRunFailure + = -- | The executable that could not be started, and the operating + -- system's message. The pair is what distinguishes \"the tool is + -- not installed\" from \"the tool is installed but the working + -- directory does not exist\". + SpawnFailed !FilePath !Text + | -- | The run exceeded this limit and was terminated. + RunTimedOut !NominalDiffTime + | -- | Every variable named in the request's 'envPassthrough' that is + -- unset or empty, checked as a group so an operator sees all of + -- them at once. + MissingEnvironment ![Text] + | -- | The working directory does not exist or is not a directory. + WorkingDirMissing !FilePath + | -- | The run produced output the caller could not interpret. + OutputMalformed !Text + | -- | The caller required evidence this configuration cannot produce, + -- so nothing was started. Carries one rendered explanation per + -- reason, from + -- 'Baikai.Evidence.Build.renderEvidenceRefusal'. + -- + -- Structural rather than predictive: it fires when the requirement + -- is /impossible/ here, never when it merely might not be met. A run + -- that could have reported what the caller needed and did not says + -- so in its own record's @strength@; refusing it after the fact + -- would destroy a report of work that actually happened. + EvidenceRefused ![Text] + deriving stock (Eq, Show, Generic) + +renderAgentRunFailure :: AgentRunFailure -> Text +renderAgentRunFailure (SpawnFailed path message) = + "could not start " <> Text.pack path <> ": " <> message +renderAgentRunFailure (RunTimedOut limit) = + "the run exceeded its timeout of " <> Text.pack (show limit) +renderAgentRunFailure (MissingEnvironment names) = + "required environment variables are unset or empty: " + <> Text.intercalate ", " names +renderAgentRunFailure (WorkingDirMissing path) = + "the working directory does not exist or is not a directory: " + <> Text.pack path +renderAgentRunFailure (OutputMalformed why) = + "the run produced malformed output: " <> why +renderAgentRunFailure (EvidenceRefused reasons) = + "refused before starting, because this run cannot produce the evidence it \ + \required: " + <> Text.intercalate "; " reasons diff --git a/src/Baikai/Compat.hs b/src/Baikai/Compat.hs --- a/src/Baikai/Compat.hs +++ b/src/Baikai/Compat.hs @@ -77,7 +77,16 @@ -- shapes land as new constructors. data ThinkingFormat = -- | OpenAI-native: top-level @reasoning_effort: "minimal" | "low" - -- | "medium" | "high"@. + -- | "medium" | "high" | "xhigh" | "max"@. + -- + -- This shape sends the canonical baikai level verbatim. The other + -- six route through @Baikai.Provider.OpenAI.Shape.compatibleEffort@, + -- which clamps @minimal@ to @low@ and both @xhigh@ and @max@ to + -- @high@ — a lowest-common-denominator vocabulary for hosts that + -- do not accept the full one. The exclusion is deliberate and + -- guarded by @nativeHigherEffortTests@ in + -- @baikai-openai/test/ShapeSpec.hs@: clamping here would silently + -- weaken every high-effort request against a current OpenAI model. ThinkingFormatOpenAI | -- | OpenRouter: nested @reasoning: { effort: "..." }@. ThinkingFormatOpenRouter @@ -91,8 +100,10 @@ ThinkingFormatZai | -- | Qwen chat-template: top-level @enable_thinking: true@. ThinkingFormatQwen - | -- | Host does not expose reasoning controls; the option is - -- silently dropped. + | -- | Host does not expose reasoning controls, so the option is + -- dropped from the request. Nothing about the wire says so — the + -- drop is recorded in the call's evidence as + -- @thinking_dropped_unsupported_host@ rather than left invisible. ThinkingFormatNone deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Baikai/Cost/Log.hs b/src/Baikai/Cost/Log.hs --- a/src/Baikai/Cost/Log.hs +++ b/src/Baikai/Cost/Log.hs @@ -173,7 +173,6 @@ now <- liftIO getCurrentTime let u :: Usage u = (resp ^. #message) ^. #usage - meaningfulCost = (Usage.cost u) ^. #usd > 0 entry = CallLogEntry { timestamp = now, @@ -183,7 +182,12 @@ outputTokens = positive (Usage.outputTokens u), cachedInputTokens = positive (Usage.cacheReadTokens u), reasoningTokens = Usage.reasoningTokens u, - usd = if meaningfulCost then Just (usdAsScientific (Usage.cost u)) else Nothing, + -- A zero cost is reported as zero. The other entry-building + -- site ('Baikai.Trace.runRequestWithRegistry') used to + -- suppress it too; leaving one of the two behind would make + -- the same record type mean different things depending on + -- which entry point produced it. + usd = Just (usdAsScientific (Usage.cost u)), latencyMs = resp ^. #latencyMs, promptSummary = summarizeContext ctx } diff --git a/src/Baikai/Evidence.hs b/src/Baikai/Evidence.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Evidence.hs @@ -0,0 +1,1168 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Verifiable evidence about one completed model call. +-- +-- A trace event answers "what did this call cost?". This module +-- answers a different and harder question: "what actually crossed the +-- boundary between this process and the provider, and how much of that +-- can be corroborated?". +-- +-- Three things are kept strictly apart and are never collapsed into +-- one another: +-- +-- * what the caller __requested__ — the model id and the +-- 'Baikai.ThinkingLevel.ThinkingLevel' they asked for; +-- +-- * what Baikai __translated__ that into for one specific provider — +-- the effort word, token budget, and wire field actually sent, plus +-- every clamp, collapse, or drop applied on the way, recorded in +-- 'ThinkingTranslation'; +-- +-- * what the provider was __observed__ to report back — recorded in +-- 'Observed', where a field the provider stayed silent about is +-- 'Unobserved' and is never backfilled from the request. +-- +-- Nothing in this module reaches a provider or performs a call. It is +-- the vocabulary the provider adapters populate. +module Baikai.Evidence + ( -- * Schema identity + evidenceSchemaVersion, + + -- * The evidence record + ModelCallEvidence (..), + baseEvidence, + + -- * Observation + Observed (..), + observedValue, + + -- * Reasoning-effort translation + ThinkingTranslation (..), + ThinkingMode (..), + ThinkingAdjustment (..), + noThinkingRequested, + + -- * Endpoint and transport + EndpointIdentity (..), + TransportKind (..), + + -- * Outcome and strength + CallStatus (..), + EvidenceStrength (..), + renderEvidenceStrength, + declaredStrength, + + -- * The caller's request + EvidenceRequest (..), + EvidenceStrictness (..), + evidenceRequest, + + -- * Canonical encoding and digests + canonicalEncode, + commitmentDigest, + configurationDigest, + configurationProjection, + + -- * Identifiers + newCallId, + ) +where + +import Baikai.Api (Api (..)) +import Baikai.Error (BaikaiError) +import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Baikai.Usage (Usage) +import Control.Exception (SomeException, try) +import Crypto.Hash.SHA256 qualified as SHA256 +import Data.Aeson + ( FromJSON (parseJSON), + Options (fieldLabelModifier, omitNothingFields), + ToJSON (toJSON), + Value (Array, Bool, Null, Number, Object, String), + camelTo2, + defaultOptions, + genericParseJSON, + genericToJSON, + object, + withText, + (.:), + (.:?), + (.=), + ) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Aeson.Types (typeMismatch) +import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as ByteString +import Data.ByteString.Base16 qualified as Base16 +import Data.ByteString.Builder (Builder) +import Data.ByteString.Builder qualified as Builder +import Data.ByteString.Lazy qualified as LazyByteString +import Data.Char (ord) +import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.List (intersperse) +import Data.Scientific (FPFormat (Fixed), Scientific) +import Data.Scientific qualified as Scientific +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Time (UTCTime, diffUTCTime) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Vector qualified as Vector +import Data.Word (Word64) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import System.IO (IOMode (ReadMode), withBinaryFile) +import System.IO.Unsafe (unsafePerformIO) + +-- ============================================================ +-- Observation +-- ============================================================ + +-- | A value the provider either did or did not report back. +-- +-- This is deliberately not 'Maybe'. A 'Maybe' invites +-- @fromMaybe requested observed@, which is precisely the error this +-- type exists to prevent: a field the provider never reported must +-- never be filled in from what was requested. There is intentionally +-- no function here that supplies a default, no 'Monoid' instance, and +-- no @fromObserved@. +data Observed a + = -- | The provider reported this value. + Observed !a + | -- | The provider did not report this value, or the transport + -- cannot carry it. This is a positive statement about the + -- provider's silence, not a missing field. + Unobserved + deriving stock (Eq, Show, Generic, Functor) + +-- | @Observed x@ encodes as @{"observed": x}@ and 'Unobserved' as the +-- bare JSON string @"unobserved"@. Downstream consumers pattern-match +-- on that literal, so the shape is part of the schema and must not be +-- replaced with a generically derived encoding. +instance (ToJSON a) => ToJSON (Observed a) where + toJSON = \case + Observed a -> object ["observed" .= a] + Unobserved -> String "unobserved" + +instance (FromJSON a) => FromJSON (Observed a) where + parseJSON = \case + String "unobserved" -> pure Unobserved + Object o -> Observed <$> o .: "observed" + v -> typeMismatch "Observed" v + +-- | Branch on whether the provider reported a value. +-- +-- Use this to /report/ what was observed, never to /supply a default/ +-- for it: @fromMaybe requestedModel (observedValue observedModel)@ +-- defeats the entire purpose of this type and produces a record that +-- claims the provider corroborated something it never mentioned. +observedValue :: Observed a -> Maybe a +observedValue = \case + Observed a -> Just a + Unobserved -> Nothing + +-- ============================================================ +-- Reasoning-effort translation +-- ============================================================ + +-- | Which shape a provider's thinking configuration took on the wire. +-- +-- Encodes as a lowercase string: @budget@, @adaptive@, @flag@, +-- @toggle@, @unsupported@, @absent@. +data ThinkingMode + = -- | The provider took an explicit token budget. + ThinkingModeBudget + | -- | The provider chose its own depth, steered by an effort word. + ThinkingModeAdaptive + | -- | The preference travelled as a command-line flag. + ThinkingModeFlag + | -- | The provider accepted a bare on/off toggle with no depth. + ThinkingModeToggle + | -- | The caller requested a level and this transport cannot express + -- any part of it. + ThinkingModeUnsupported + | -- | The caller requested no level at all. + ThinkingModeAbsent + deriving stock (Eq, Show, Generic) + +renderThinkingMode :: ThinkingMode -> Text +renderThinkingMode = \case + ThinkingModeBudget -> "budget" + ThinkingModeAdaptive -> "adaptive" + ThinkingModeFlag -> "flag" + ThinkingModeToggle -> "toggle" + ThinkingModeUnsupported -> "unsupported" + ThinkingModeAbsent -> "absent" + +parseThinkingMode :: Text -> Maybe ThinkingMode +parseThinkingMode = \case + "budget" -> Just ThinkingModeBudget + "adaptive" -> Just ThinkingModeAdaptive + "flag" -> Just ThinkingModeFlag + "toggle" -> Just ThinkingModeToggle + "unsupported" -> Just ThinkingModeUnsupported + "absent" -> Just ThinkingModeAbsent + _ -> Nothing + +instance ToJSON ThinkingMode where + toJSON = String . renderThinkingMode + +instance FromJSON ThinkingMode where + parseJSON = + withText "ThinkingMode" $ \t -> + maybe (fail ("unknown thinking mode: " <> show t)) pure (parseThinkingMode t) + +-- | One thing that happened to the caller's reasoning-effort request +-- between the canonical 'ThinkingLevel' and the wire. +-- +-- This is the type that makes an otherwise silent downgrade visible. +-- Every constructor corresponds to a real site in this repository +-- where a request is weakened, dropped, or made indistinguishable from +-- the provider's own default. +-- +-- Levels are carried as 'ThinkingLevel' rather than text so that +-- strict evidence mode can compare them; they render through +-- 'Baikai.ThinkingLevel.renderThinkingLevel' in JSON. +data ThinkingAdjustment + = -- | The requested level was replaced by a weaker one the transport + -- accepts. Carries the requested level and the wire text sent. + EffortClamped !ThinkingLevel !Text + | -- | The transport expresses no depth, so the level only turned + -- thinking on. Carries the requested level. + EffortCollapsedToToggle !ThinkingLevel + | -- | The transport sends no effort field for this level, so the + -- request is indistinguishable on the wire from the provider's own + -- default. Carries the requested level. + EffortOmitted !ThinkingLevel + | -- | The chosen model does not advertise reasoning support, so the + -- thinking configuration was dropped entirely. + ThinkingDroppedUnsupportedModel !ThinkingLevel + | -- | The host exposes no reasoning controls at all, so the + -- configuration was dropped. + ThinkingDroppedUnsupportedHost !ThinkingLevel + | -- | A computed thinking budget was discarded because it did not + -- fit inside the resolved output-token ceiling. Carries the + -- requested level, the budget that was computed, and the ceiling. + ThinkingDroppedBudgetExceeded !ThinkingLevel !Natural !Natural + deriving stock (Eq, Show, Generic) + +-- | Adjustments encode as a tagged object whose @kind@ names the +-- constructor in snake_case and whose @requested@ field carries the +-- canonical level name. +instance ToJSON ThinkingAdjustment where + toJSON = \case + EffortClamped lvl wire -> + tagged "effort_clamped" lvl ["wire" .= wire] + EffortCollapsedToToggle lvl -> + tagged "effort_collapsed_to_toggle" lvl [] + EffortOmitted lvl -> + tagged "effort_omitted" lvl [] + ThinkingDroppedUnsupportedModel lvl -> + tagged "thinking_dropped_unsupported_model" lvl [] + ThinkingDroppedUnsupportedHost lvl -> + tagged "thinking_dropped_unsupported_host" lvl [] + ThinkingDroppedBudgetExceeded lvl budget maxOut -> + tagged + "thinking_dropped_budget_exceeded" + lvl + ["budget_tokens" .= budget, "max_tokens" .= maxOut] + where + tagged kind lvl extra = + object + ( ["kind" .= (kind :: Text), "requested" .= renderThinkingLevel lvl] + <> extra + ) + +instance FromJSON ThinkingAdjustment where + parseJSON = \case + Object o -> do + kind <- o .: "kind" + lvl <- o .: "requested" >>= parseThinkingLevelText + case kind :: Text of + "effort_clamped" -> EffortClamped lvl <$> o .: "wire" + "effort_collapsed_to_toggle" -> pure (EffortCollapsedToToggle lvl) + "effort_omitted" -> pure (EffortOmitted lvl) + "thinking_dropped_unsupported_model" -> + pure (ThinkingDroppedUnsupportedModel lvl) + "thinking_dropped_unsupported_host" -> + pure (ThinkingDroppedUnsupportedHost lvl) + "thinking_dropped_budget_exceeded" -> + ThinkingDroppedBudgetExceeded lvl <$> o .: "budget_tokens" <*> o .: "max_tokens" + other -> fail ("unknown thinking adjustment: " <> show other) + v -> typeMismatch "ThinkingAdjustment" v + +-- | Parse a canonical level name as produced by +-- 'Baikai.ThinkingLevel.renderThinkingLevel'. The evidence schema +-- spells levels with those names rather than with the constructor +-- names that 'ThinkingLevel'\'s own derived instance uses, because a +-- reader of an evidence record should see the same vocabulary the +-- provider documentation uses. +parseThinkingLevelText :: (MonadFail m) => Text -> m ThinkingLevel +parseThinkingLevelText = \case + "minimal" -> pure ThinkingMinimal + "low" -> pure ThinkingLow + "medium" -> pure ThinkingMedium + "high" -> pure ThinkingHigh + "xhigh" -> pure ThinkingXHigh + "max" -> pure ThinkingMax + other -> fail ("unknown thinking level: " <> show other) + +-- | What a canonical 'ThinkingLevel' actually became on the wire for +-- one specific provider. +-- +-- The provider adapter that built the request owns this value. No +-- downstream layer — trace sink, exporter, or reporting tool — may +-- re-derive it: doing so would mean reimplementing every provider's +-- translation and compatibility lookup, and would silently diverge the +-- first time a translation changed. +data ThinkingTranslation = ThinkingTranslation + { -- | The level the caller asked for, if any. + requested :: !(Maybe ThinkingLevel), + mode :: !ThinkingMode, + -- | The exact effort text placed on the wire, when the transport + -- uses one. + effortText :: !(Maybe Text), + -- | The exact token budget placed on the wire, when the transport + -- uses one. + budgetTokens :: !(Maybe Natural), + -- | The provider-specific field name the configuration travelled + -- in, for example @"thinking"@, @"reasoning_effort"@, or + -- @"--effort"@. 'Nothing' when nothing was sent. + wireField :: !(Maybe Text), + -- | Everything that happened to the request between the canonical + -- level and the wire, in the order it was applied. Empty means the + -- request was expressed exactly. + adjustments :: ![ThinkingAdjustment] + } + deriving stock (Eq, Show, Generic) + +instance ToJSON ThinkingTranslation where + toJSON t = + object + [ "requested" .= fmap renderThinkingLevel (requested t), + "mode" .= mode t, + "effort_text" .= effortText t, + "budget_tokens" .= budgetTokens t, + "wire_field" .= wireField t, + "adjustments" .= adjustments t + ] + +instance FromJSON ThinkingTranslation where + parseJSON = \case + Object o -> do + rawLevel <- o .:? "requested" + lvl <- traverse parseThinkingLevelText rawLevel + ThinkingTranslation lvl + <$> o .: "mode" + <*> o .:? "effort_text" + <*> o .:? "budget_tokens" + <*> o .:? "wire_field" + <*> o .: "adjustments" + v -> typeMismatch "ThinkingTranslation" v + +-- | The translation for a call where the caller set no level at all. +-- Distinct from a call that asked for a level the transport could not +-- express, which is 'ThinkingModeUnsupported' with a non-empty +-- 'adjustments' list. +noThinkingRequested :: ThinkingTranslation +noThinkingRequested = + ThinkingTranslation + { requested = Nothing, + mode = ThinkingModeAbsent, + effortText = Nothing, + budgetTokens = Nothing, + wireField = Nothing, + adjustments = [] + } + +-- ============================================================ +-- Endpoint and transport +-- ============================================================ + +-- | How the call physically reached the provider. The three kinds +-- differ fundamentally in how much they can corroborate: an HTTP call +-- can carry provider response headers, a subprocess can only report +-- what the executable chose to print, and an unattended agent run +-- reports only what its own result envelope contains. +-- +-- Encodes as @http_api@, @subprocess@, or @agent_run@. +data TransportKind + = TransportHttpApi + | TransportSubprocess + | TransportAgentRun + deriving stock (Eq, Show, Generic) + +renderTransportKind :: TransportKind -> Text +renderTransportKind = \case + TransportHttpApi -> "http_api" + TransportSubprocess -> "subprocess" + TransportAgentRun -> "agent_run" + +instance ToJSON TransportKind where + toJSON = String . renderTransportKind + +instance FromJSON TransportKind where + parseJSON = withText "TransportKind" $ \case + "http_api" -> pure TransportHttpApi + "subprocess" -> pure TransportSubprocess + "agent_run" -> pure TransportAgentRun + other -> fail ("unknown transport kind: " <> show other) + +-- | Where the call went, recorded without recording a credential. +data EndpointIdentity = EndpointIdentity + { -- | The provider name as Baikai knows it, e.g. @"anthropic"@. + provider :: !Text, + -- | The wire protocol tag, rendered from 'Baikai.Api.Api'. + api :: !Text, + transport :: !TransportKind, + -- | Scheme, host, port, and path with every query parameter and + -- userinfo component removed. A query string can carry an API key + -- on some gateways, so it is dropped wholesale rather than + -- filtered field by field. + endpoint :: !(Maybe Text), + -- | The version of the @baikai@ package that produced this record. + baikaiVersion :: !Text, + -- | The provider implementation's own version, when it has one: + -- the vendor package version for an API provider, or the + -- executable's reported version for a subprocess. + implementationVersion :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- | Field names render in snake_case, matching 'Baikai.Usage.Usage' +-- and 'Baikai.Error.BaikaiError', which are embedded verbatim in an +-- evidence record. +-- +-- @omitNothingFields@ is 'False' and stated explicitly rather than +-- left to the default, because it is load-bearing here: an evidence +-- record must render an absent field as @null@ rather than dropping +-- it, so that a reader can tell "Baikai recorded nothing here" apart +-- from "this record predates the field". This is the opposite of the +-- choice @Baikai.Trace.Event@ makes for trace events, where dropping +-- absent fields keeps log lines small. The difference is deliberate; +-- do not harmonise them. +evidenceJsonOptions :: Options +evidenceJsonOptions = + defaultOptions + { fieldLabelModifier = camelTo2 '_', + omitNothingFields = False + } + +instance ToJSON EndpointIdentity where + toJSON = genericToJSON evidenceJsonOptions + +instance FromJSON EndpointIdentity where + parseJSON = genericParseJSON evidenceJsonOptions + +-- ============================================================ +-- Outcome and strength +-- ============================================================ + +-- | The terminal outcome of a call. Encodes as @succeeded@, @failed@, +-- or @aborted@. +data CallStatus + = CallSucceeded + | CallFailed + | -- | The consumer stopped reading before the provider finished. + CallAborted + deriving stock (Eq, Show, Generic) + +renderCallStatus :: CallStatus -> Text +renderCallStatus = \case + CallSucceeded -> "succeeded" + CallFailed -> "failed" + CallAborted -> "aborted" + +instance ToJSON CallStatus where + toJSON = String . renderCallStatus + +instance FromJSON CallStatus where + parseJSON = withText "CallStatus" $ \case + "succeeded" -> pure CallSucceeded + "failed" -> pure CallFailed + "aborted" -> pure CallAborted + other -> fail ("unknown call status: " <> show other) + +-- | How much a given evidence record actually proves. +-- +-- The constructors ascend, and the derived 'Ord' instance is what +-- strict evidence mode compares against a caller's stated requirement. +-- __Do not reorder them.__ +-- +-- Encodes as @requested_only@, @correlated@, @model_observed@, or +-- @fully_observed@. +data EvidenceStrength + = -- | Baikai recorded what it requested and what it translated. The + -- provider reported nothing back that corroborates it. A + -- successful process exit does not raise a record to a higher + -- strength. + EvidenceRequestedOnly + | -- | The provider returned a correlation identifier, so this call + -- can be located in the provider's own records, but it did not + -- report the model or the effort it used. + EvidenceCorrelated + | -- | The provider reported the model it ran, in addition to a + -- correlation identifier. + EvidenceModelObserved + | -- | The provider reported both the model and its effective + -- thinking configuration. + EvidenceFullyObserved + deriving stock (Eq, Ord, Show, Generic) + +-- | The canonical name a strength encodes as, also used in the refusal +-- messages strict mode produces. +renderEvidenceStrength :: EvidenceStrength -> Text +renderEvidenceStrength = \case + EvidenceRequestedOnly -> "requested_only" + EvidenceCorrelated -> "correlated" + EvidenceModelObserved -> "model_observed" + EvidenceFullyObserved -> "fully_observed" + +instance ToJSON EvidenceStrength where + toJSON = String . renderEvidenceStrength + +instance FromJSON EvidenceStrength where + parseJSON = withText "EvidenceStrength" $ \case + "requested_only" -> pure EvidenceRequestedOnly + "correlated" -> pure EvidenceCorrelated + "model_observed" -> pure EvidenceModelObserved + "fully_observed" -> pure EvidenceFullyObserved + other -> fail ("unknown evidence strength: " <> show other) + +-- | The highest strength a transport can reach when everything goes +-- well. +-- +-- This is a static property of the transport, not a claim about any +-- particular call: a transport that declares 'EvidenceModelObserved' +-- still produces 'EvidenceRequestedOnly' for a call that failed before +-- the provider said anything. Strict evidence mode compares a caller's +-- requirement against this /before/ dispatch, which is the only point at +-- which refusing is still cheap. +-- +-- __Declaring more than a transport can deliver is the one way to make +-- strict mode lie__, so every value below is justified by a test that +-- actually drives that transport to it. If you raise a declaration, add +-- the test first. +-- +-- The values, and what proved them: +-- +-- * 'AnthropicMessages' and 'OpenAIChatCompletions' reach +-- 'EvidenceModelObserved'. Both echo the model they ran and both carry +-- a correlation header. Neither echoes the thinking configuration it +-- applied, so 'EvidenceFullyObserved' is unreachable on either — a +-- reasoning-token count corroborates output volume and says nothing +-- about which effort setting was in force. No transport in this +-- repository currently declares 'EvidenceFullyObserved'. +-- +-- * 'AnthropicMessagesCli' reaches 'EvidenceModelObserved'. The @claude@ +-- CLI names the model that consumed tokens in its result event's +-- @modelUsage@ map, alongside a session identifier. +-- +-- * 'OpenAICompletionsCli' reaches only 'EvidenceCorrelated'. +-- @codex exec --json@ names a thread identifier but no model anywhere +-- in its event stream, and the model baikai passed on the command line +-- is the request rather than an observation. +-- +-- * 'Custom' declares 'EvidenceRequestedOnly'. Baikai knows nothing +-- about a caller-supplied transport and must not assume on its behalf. +declaredStrength :: Api -> EvidenceStrength +declaredStrength = \case + AnthropicMessages -> EvidenceModelObserved + OpenAIChatCompletions -> EvidenceModelObserved + AnthropicMessagesCli -> EvidenceModelObserved + OpenAICompletionsCli -> EvidenceCorrelated + Custom _ -> EvidenceRequestedOnly + +-- ============================================================ +-- The caller's request +-- ============================================================ + +-- | Whether a caller merely wants evidence or requires it. +data EvidenceStrictness + = -- | Record whatever this transport can supply. Never fails a call + -- for evidence reasons. This is the behaviour every existing + -- caller gets. + EvidenceBestEffort + | -- | Refuse, before dispatch, to run this call on a transport that + -- cannot reach the required strength or that would weaken the + -- requested thinking level. + EvidenceRequired !EvidenceStrength + deriving stock (Eq, Show, Generic) + +-- | Encoded by hand rather than derived, because a generically derived +-- sum encoding for a constructor carrying a payload would put the +-- strength somewhere a reader has to guess at: +-- @{"mode":"best_effort"}@ and +-- @{"mode":"required","strength":"model_observed"}@. +instance ToJSON EvidenceStrictness where + toJSON = \case + EvidenceBestEffort -> object ["mode" .= ("best_effort" :: Text)] + EvidenceRequired s -> + object ["mode" .= ("required" :: Text), "strength" .= s] + +instance FromJSON EvidenceStrictness where + parseJSON = \case + Object o -> do + m <- o .: "mode" + case m :: Text of + "best_effort" -> pure EvidenceBestEffort + "required" -> EvidenceRequired <$> o .: "strength" + other -> fail ("unknown evidence strictness: " <> show other) + v -> typeMismatch "EvidenceStrictness" v + +-- | A caller's per-call request for evidence, set through +-- @Baikai.Options.evidence@. A call whose evidence field is 'Nothing' +-- behaves exactly as it did before this vocabulary existed: no digest +-- is computed, no call identifier is generated for evidence purposes, +-- and no evidence is emitted. +data EvidenceRequest = EvidenceRequest + { -- | The caller's identifier for the logical unit of work this call + -- belongs to. Baikai treats it as opaque text and never parses it. + runId :: !Text, + strictness :: !EvidenceStrictness, + -- | Which attempt this is, when the caller is retrying. One-based. + -- Baikai has no retry or fallback loop of its own, so this is + -- provenance the caller supplies, not something Baikai observes. + attempt :: !Natural, + -- | The call id of the attempt this one supersedes, when the + -- caller is retrying or falling back. + supersedes :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +instance ToJSON EvidenceRequest where + toJSON = genericToJSON evidenceJsonOptions + +instance FromJSON EvidenceRequest where + parseJSON = genericParseJSON evidenceJsonOptions + +-- | Request best-effort evidence for a call belonging to the given +-- run: attempt one, superseding nothing. +evidenceRequest :: Text -> EvidenceRequest +evidenceRequest rid = + EvidenceRequest + { runId = rid, + strictness = EvidenceBestEffort, + attempt = 1, + supersedes = Nothing + } + +-- ============================================================ +-- The evidence record +-- ============================================================ + +-- | The schema identifier for 'ModelCallEvidence'. Consumers pin +-- against this string. +-- +-- Bump the minor component when a field is added in a way that leaves +-- existing readers working; bump the major component when a field is +-- removed, changes meaning, or when 'canonicalEncode' changes, since +-- that invalidates every previously recorded digest. +evidenceSchemaVersion :: Text +evidenceSchemaVersion = "baikai.model-call-evidence/1.0" + +-- | Everything Baikai can say about one completed provider call. +-- +-- The field order is the story the record tells: who ran it, where it +-- went, what was asked, what came back, how it went, and what it costs +-- to believe. +data ModelCallEvidence = ModelCallEvidence + { -- Identity ------------------------------------------------------- + + -- | Always 'evidenceSchemaVersion' for records this build produces. + schemaVersion :: !Text, + -- | The caller's identifier for the logical unit of work. + runId :: !Text, + -- | This call's globally unique identifier, from 'newCallId'. + callId :: !Text, + -- | Which attempt this is, one-based, as supplied by the caller. + attempt :: !Natural, + -- | The 'callId' of the attempt this one supersedes, as supplied + -- by the caller. Baikai has no retry loop and never fills this in + -- itself. + supersedes :: !(Maybe Text), + -- Where it went -------------------------------------------------- + endpoint :: !EndpointIdentity, + -- What was requested --------------------------------------------- + + -- | The model identifier the caller configured. This is what was + -- /asked for/; see 'observedModel' for what the provider said it + -- ran. + requestedModel :: !Text, + -- | What the caller's reasoning-effort preference became on the + -- wire, including every downgrade applied on the way. + thinking :: !ThinkingTranslation, + -- What came back ------------------------------------------------- + + -- | The model identifier the provider reported running. + -- 'Unobserved' when the provider did not echo one or the transport + -- cannot carry it. Never backfilled from 'requestedModel'. + observedModel :: !(Observed Text), + -- | The provider's own description of the thinking configuration + -- it applied, when it reports one. + -- + -- Reasoning-token counts do /not/ belong here. They live in + -- 'usage', and they are corroborating evidence about output + -- volume, not a statement of which effort setting was applied. + observedThinking :: !(Observed Text), + -- | The provider's identifier for this response. + responseId :: !(Observed Text), + -- | The provider's request-correlation identifier, typically from + -- a response header, used to locate this call in the provider's + -- own records. + providerRequestId :: !(Observed Text), + -- | The identifier Baikai put on the outgoing request, when it + -- sent one. Unlike the two fields above this is something Baikai + -- knows by construction rather than observes, so it is 'Maybe' and + -- not 'Observed'. + clientRequestId :: !(Maybe Text), + -- How it went ---------------------------------------------------- + startedAt :: !UTCTime, + endedAt :: !UTCTime, + latencyMs :: !Int, + status :: !CallStatus, + -- | 'Nothing' exactly when 'status' is 'CallSucceeded'. + errorInfo :: !(Maybe BaikaiError), + -- | The token accounting the provider reported. + -- + -- This is 'Observed' rather than a bare 'Baikai.Usage.Usage' + -- because the existing code substitutes + -- 'Baikai.Usage.zeroUsage' when a provider reports nothing. In a + -- cost log that substitution is harmless; in evidence it is a + -- false statement that the call consumed no tokens. + usage :: !(Observed Usage), + -- What it proves ------------------------------------------------- + + -- | This record's honest self-assessment. Derived from which + -- observed fields the transport actually filled in. + strength :: !EvidenceStrength, + -- | 'commitmentDigest' of the request envelope. + requestCommitment :: !Text, + -- | 'configurationDigest' of the request envelope. + requestConfiguration :: !Text, + -- | 'commitmentDigest' of the response envelope. 'Unobserved' when + -- the call failed before any response body arrived: recording an + -- empty-string digest there would be a fabrication. + responseCommitment :: !(Observed Text) + } + deriving stock (Eq, Show, Generic) + +-- | Evidence is emitted as JSON and consumed out of process. There is +-- deliberately no 'FromJSON' instance: 'Baikai.Usage.Usage' embeds a +-- 'Baikai.Cost.Cost', whose exact 'Rational' amounts are encoded +-- through an approximating 'Data.Scientific.Scientific', so a decoder +-- could not round-trip a record faithfully and would be claiming a +-- fidelity it does not have. Read an emitted record as a plain +-- 'Data.Aeson.Value' and match on 'evidenceSchemaVersion'. +instance ToJSON ModelCallEvidence where + toJSON = genericToJSON evidenceJsonOptions + +-- | The evidence any transport can always produce: identity, endpoint, +-- requested model, thinking translation, timing, status, and the two +-- request digests. +-- +-- Every observed field starts 'Unobserved', 'errorInfo' starts +-- 'Nothing', and 'strength' starts at 'EvidenceRequestedOnly'. A +-- transport that learns more overwrites those fields and raises the +-- strength. Construct through this rather than with the record +-- constructor, so that a field added in a later release cannot be left +-- uninitialised at a call site. +baseEvidence :: + EvidenceRequest -> + -- | Call id, from 'newCallId'. + Text -> + EndpointIdentity -> + -- | Requested model id. + Text -> + ThinkingTranslation -> + -- | Started at. + UTCTime -> + -- | Ended at. + UTCTime -> + CallStatus -> + -- | Request commitment digest. + Text -> + -- | Request configuration digest. + Text -> + ModelCallEvidence +baseEvidence + EvidenceRequest {runId = rid, attempt = att, supersedes = prev} + cid + ep + reqModel + translation + started + ended + st + commitment + configuration = + ModelCallEvidence + { schemaVersion = evidenceSchemaVersion, + runId = rid, + callId = cid, + attempt = att, + supersedes = prev, + endpoint = ep, + requestedModel = reqModel, + thinking = translation, + observedModel = Unobserved, + observedThinking = Unobserved, + responseId = Unobserved, + providerRequestId = Unobserved, + clientRequestId = Nothing, + startedAt = started, + endedAt = ended, + latencyMs = millisBetween started ended, + status = st, + errorInfo = Nothing, + usage = Unobserved, + strength = EvidenceRequestedOnly, + requestCommitment = commitment, + requestConfiguration = configuration, + responseCommitment = Unobserved + } + +-- | Whole milliseconds between two instants, rounded. Matches the +-- latency arithmetic @Baikai.Trace@ already uses for @CallFinished@ so +-- the two records agree on the same call. +millisBetween :: UTCTime -> UTCTime -> Int +millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double)) + +-- ============================================================ +-- Canonical encoding +-- ============================================================ + +-- | Encode a JSON value to bytes such that two equal values always +-- produce byte-identical output. +-- +-- The rules, which a later maintainer must preserve: +-- +-- * Object keys are emitted in ascending order by their UTF-8 byte +-- sequence, recursively. Aeson's @Object@ is a @KeyMap@ whose +-- iteration order is unspecified and in practice depends on +-- insertion history, so the order is imposed here rather than +-- inherited. +-- +-- * Array order is preserved, because array order is semantically +-- meaningful. +-- +-- * There is no insignificant whitespace: no space after a colon or a +-- comma, and no trailing newline. +-- +-- * Strings are UTF-8 with the minimal escaping JSON requires: +-- @\\"@, @\\\\@, the five short control escapes, and @\\u@ followed +-- by four /lowercase/ hexadecimal digits for any other character +-- below @U+0020@. Nothing else is escaped. The escaper is written +-- out here rather than borrowed from aeson so that an aeson upgrade +-- cannot silently change a digest. +-- +-- * Numbers are normalised before rendering, so @1@, @1.0@, @1.00@, +-- and @1e0@ all produce the bytes @1@. An integral value renders as +-- a plain integer with no decimal point and no exponent; anything +-- else renders fixed-point with no exponent. +-- +-- Changing any of these rules invalidates every digest recorded by an +-- earlier build. Treat such a change as a major bump of +-- 'evidenceSchemaVersion', not as a bug fix. +canonicalEncode :: Value -> ByteString +canonicalEncode = + LazyByteString.toStrict . Builder.toLazyByteString . buildCanonical + +buildCanonical :: Value -> Builder +buildCanonical = \case + Null -> Builder.byteString "null" + Bool True -> Builder.byteString "true" + Bool False -> Builder.byteString "false" + Number n -> buildNumber n + String t -> buildString t + Array xs -> + Builder.char7 '[' + <> mconcat (intersperse (Builder.char7 ',') (map buildCanonical (Vector.toList xs))) + <> Builder.char7 ']' + Object o -> + Builder.char7 '{' + <> mconcat (intersperse (Builder.char7 ',') (map member (KeyMap.toAscList o))) + <> Builder.char7 '}' + where + member (k, v) = buildString (Key.toText k) <> Builder.char7 ':' <> buildCanonical v + +-- | Render a number with exactly one spelling per mathematical value. +-- 'Scientific.normalize' strips trailing zeros from the coefficient +-- first, without which @1.1@ and @1.100@ — which aeson parses into +-- different 'Scientific' values — would encode to different bytes. +buildNumber :: Scientific -> Builder +buildNumber raw + | Scientific.isInteger n = Builder.integerDec (truncate n) + | otherwise = Builder.string7 (Scientific.formatScientific Fixed Nothing n) + where + n = Scientific.normalize raw + +buildString :: Text -> Builder +buildString t = + Builder.char7 '"' <> Text.foldr (\c acc -> escapeChar c <> acc) mempty t <> Builder.char7 '"' + +escapeChar :: Char -> Builder +escapeChar = \case + '"' -> Builder.byteString "\\\"" + '\\' -> Builder.byteString "\\\\" + '\n' -> Builder.byteString "\\n" + '\r' -> Builder.byteString "\\r" + '\t' -> Builder.byteString "\\t" + '\b' -> Builder.byteString "\\b" + '\f' -> Builder.byteString "\\f" + c + | c < '\x20' -> Builder.byteString "\\u" <> hex4 (ord c) + | otherwise -> Builder.charUtf8 c + +hex4 :: Int -> Builder +hex4 n = mconcat [Builder.char7 (hexDigit (n `shiftR` s)) | s <- [12, 8, 4, 0]] + +-- | The low nibble of a value as a lowercase hexadecimal character. +hexDigit :: (Integral a, Bits a) => a -> Char +hexDigit v = "0123456789abcdef" !! fromIntegral (v .&. 0xF) + +-- | SHA-256 of the canonical encoding, rendered as 64 lowercase +-- hexadecimal characters and prefixed with the algorithm so the string +-- is self-describing: @"sha256:1b4f0e98…"@. +-- +-- @Base16.encode@ emits lowercase ASCII, so decoding it as Latin-1 is +-- total and gives the same characters. +digestOf :: Value -> Text +digestOf v = + "sha256:" + <> TextEncoding.decodeLatin1 (Base16.encode (SHA256.hash (canonicalEncode v))) + +-- ============================================================ +-- The two digests +-- ============================================================ + +-- | A commitment to the exact request body Baikai sent, prompt content +-- included. +-- +-- The digest reveals nothing on its own: publishing it does not +-- disclose the prompt. Anyone who independently holds the request can +-- recompute this value and confirm that a given evidence record +-- describes that request — which is what makes it possible to bind a +-- recorded call to a reviewed artifact. +-- +-- Nothing is redacted here, because credentials travel in HTTP headers +-- and command-line environments, never in a request body, and headers +-- are not part of this function's input. +commitmentDigest :: Value -> Text +commitmentDigest = digestOf + +-- | A digest over the request's configuration only, with all content +-- removed by 'configurationProjection'. +-- +-- Two calls that ask the same model the same way about different +-- subjects produce the same value here. That is the point: this digest +-- is safe to compare across runs that legitimately differ in content. +-- It proves /how/ a call was configured and deliberately proves +-- nothing about /what/ was asked, so it must never be presented as +-- binding a run to any particular input. Use 'commitmentDigest' for +-- that. +configurationDigest :: Value -> Text +configurationDigest = digestOf . configurationProjection + +-- | Reduce a request envelope to the configuration it expresses, +-- discarding everything that carries content. +-- +-- This is an explicit __allow-list__, never a denylist, and the +-- distinction is not stylistic. A denylist over request bodies from +-- the Anthropic Messages API and seven different OpenAI-compatible +-- hosts will miss a field the first time any one of them adds one, and +-- the failure mode is prompt content leaking into a digest that +-- callers were told is content-free. An allow-list fails the other +-- way: a genuinely new configuration field is silently omitted from +-- the digest until someone adds it here, which loses fidelity rather +-- than leaking. +-- +-- Keys outside the list are dropped entirely. Three keys are kept but +-- replaced with structural summaries: @messages@ becomes one object +-- per message carrying its role, its block count, and the total +-- character length of every string inside it; @system@ becomes just +-- that character count; @tools@ becomes each tool's name and nothing +-- else, so descriptions and JSON schemas do not survive. +-- +-- A top-level value that is not an object has no named fields for the +-- allow-list to admit, so it projects to 'Null' rather than passing +-- through. +configurationProjection :: Value -> Value +configurationProjection = \case + Object o -> Object (KeyMap.fromList (concatMap keep (KeyMap.toAscList o))) + _ -> Null + where + keep (k, v) = case Key.toText k of + "messages" -> [(k, summariseMessages v)] + "system" -> [(k, charSummary v)] + "tools" -> [(k, summariseTools v)] + name + | name `Set.member` configurationKeys -> [(k, v)] + | otherwise -> [] + +-- | The request fields that describe how a call is configured rather +-- than what it says. Covers the Anthropic Messages API and the +-- OpenAI-compatible Chat Completions shapes this repository builds. +configurationKeys :: Set Text +configurationKeys = + Set.fromList + [ "cache_control", + "enable_thinking", + "frequency_penalty", + "max_completion_tokens", + "max_tokens", + "model", + "output_config", + "presence_penalty", + "reasoning", + "reasoning_effort", + "response_format", + "seed", + "stop_sequences", + "stream", + "temperature", + "thinking", + "tool_choice", + "top_p" + ] + +summariseMessages :: Value -> Value +summariseMessages = \case + Array xs -> Array (fmap summariseMessage xs) + _ -> Null + +summariseMessage :: Value -> Value +summariseMessage = \case + Object m -> + object + [ "role" .= roleOf (KeyMap.lookup "role" m), + "blocks" .= blockCount (KeyMap.lookup "content" m), + "chars" .= maybe 0 totalStringChars (KeyMap.lookup "content" m) + ] + _ -> Null + where + roleOf = \case + Just (String r) -> String r + _ -> Null + blockCount :: Maybe Value -> Int + blockCount = \case + Just (Array a) -> Vector.length a + Just Null -> 0 + Nothing -> 0 + Just _ -> 1 + +-- | Total characters across every JSON string anywhere inside a value. +-- Recursive on purpose: a content block's text can sit at any depth, +-- and a count is a structural fact that reveals nothing about what was +-- written. +totalStringChars :: Value -> Int +totalStringChars = \case + String t -> Text.length t + Array xs -> sum (fmap totalStringChars xs) + Object o -> sum (fmap totalStringChars (KeyMap.elems o)) + _ -> 0 + +charSummary :: Value -> Value +charSummary v = object ["chars" .= totalStringChars v] + +-- | A tool reduces to its name. The name is configuration — which +-- capabilities the call offered — while the description and input +-- schema are author-written content. Both wire shapes are handled: the +-- Anthropic form with @name@ at the top level, and the OpenAI form +-- that nests it under @function@. +summariseTools :: Value -> Value +summariseTools = \case + Array xs -> Array (fmap summariseTool xs) + _ -> Null + +summariseTool :: Value -> Value +summariseTool = \case + Object t -> object ["name" .= nameOf t] + _ -> Null + where + nameOf t = case KeyMap.lookup "name" t of + Just n@(String _) -> n + _ -> case KeyMap.lookup "function" t of + Just (Object f) -> case KeyMap.lookup "name" f of + Just n@(String _) -> n + _ -> Null + _ -> Null + +-- ============================================================ +-- Identifiers +-- ============================================================ + +-- | A globally unique call identifier: 32 lowercase hexadecimal +-- characters carrying 128 bits, laid out as 48 bits of Unix time in +-- milliseconds, then 48 bits of a per-process random seed drawn once +-- at first use, then a 32-bit process-local counter. +-- +-- The time prefix comes first so that identifiers sort +-- chronologically. The seed is what distinguishes two processes; the +-- counter is what distinguishes two calls within one. The counter +-- wrapping after 2^32 calls is harmless, because the millisecond +-- prefix will have moved on long before. +-- +-- This replaces the previous generator, which combined the process +-- start /second/ with a process-local counter and therefore produced +-- identical identifier sequences in two processes started within the +-- same second. For ordinary tracing that was a minor collision hazard; +-- for evidence that another system correlates into a run, it was a +-- correctness defect. +-- +-- Generating an identifier costs one atomic counter increment and one +-- clock read, and performs no syscall for randomness. That matters +-- because this function sits on the trace path for every call whether +-- or not the caller asked for evidence, and a per-call read from the +-- system random source would charge people who never asked for one. +-- +-- These identifiers are __not secrets__. They are not capabilities, +-- they are not unguessable, and they must not be used as one. Their +-- only job is to correlate records. +newCallId :: IO Text +newCallId = do + n <- atomicModifyIORef' callIdCounter (\k -> (k + 1, k)) + now <- getPOSIXTime + let millis = floor (now * 1000) :: Word64 + seed = callIdSeed .&. 0xFFFFFFFFFFFF + high = ((millis .&. 0xFFFFFFFFFFFF) `shiftL` 16) .|. (seed `shiftR` 32) + low = ((seed .&. 0xFFFFFFFF) `shiftL` 32) .|. (n .&. 0xFFFFFFFF) + pure (hex16 high <> hex16 low) + +hex16 :: Word64 -> Text +hex16 w = Text.pack [hexDigit (w `shiftR` s) | s <- [60, 56 .. 0]] + +callIdCounter :: IORef Word64 +callIdCounter = unsafePerformIO (newIORef 0) +{-# NOINLINE callIdCounter #-} + +-- | Sixty-four bits drawn once from @\/dev\/urandom@, of which +-- 'newCallId' uses the low forty-eight. +-- +-- Read with 'hGet' rather than @ByteString.readFile@: @readFile@ asks +-- for the file's size, gets zero for a character device, and then +-- reads until end of file — which @\/dev\/urandom@ never reaches. +-- +-- If the read fails for any reason, the seed falls back to the current +-- time in nanoseconds. That is weaker — two processes starting within +-- the same nanosecond would share a seed — but it is still far +-- stronger than the per-second base this generator replaced, and it +-- keeps a failure to open a device file from taking down a library +-- that only wanted to name a call. +callIdSeed :: Word64 +callIdSeed = unsafePerformIO $ do + drawn <- + try (withBinaryFile "/dev/urandom" ReadMode (\h -> ByteString.hGet h 8)) :: + IO (Either SomeException ByteString) + case drawn of + Right bytes + | ByteString.length bytes == 8 -> + pure (ByteString.foldl' (\acc b -> (acc `shiftL` 8) .|. fromIntegral b) 0 bytes) + _ -> do + now <- getPOSIXTime + pure (floor (now * 1000000000)) +{-# NOINLINE callIdSeed #-} diff --git a/src/Baikai/Evidence/Build.hs b/src/Baikai/Evidence/Build.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Evidence/Build.hs @@ -0,0 +1,434 @@ +{-# LANGUAGE LambdaCase #-} + +-- | Building a 'ModelCallEvidence' from what every transport already +-- knows. +-- +-- "Baikai.Evidence" is the vocabulary and is deliberately free of any +-- dependency on 'Model' or 'Options'. This module is the bridge: it +-- reads the caller's request out of 'Options', the endpoint out of +-- 'Model', and produces the record a provider adapter attaches to its +-- terminal stream event. +-- +-- Four adapters call 'minimalEvidence' and a fifth path (dispatch that +-- found no registered provider) calls it too. Putting the construction +-- here rather than in each adapter keeps them from drifting, and — more +-- importantly — puts the caller's opt-out gate somewhere an adapter +-- cannot forget it. +module Baikai.Evidence.Build + ( minimalEvidence, + prepareEvidence, + endpointIdentity, + sanitizeEndpoint, + dispatchEnvelope, + transportForModel, + baikaiPackageVersion, + + -- * Trace-sink failure policy + onSinkFailure, + sinkFailureIsFatal, + sinkFailureError, + + -- * The pre-dispatch strictness gate + EvidenceRefusal (..), + renderEvidenceRefusal, + checkEvidenceRequirements, + refusalError, + ) +where + +import Baikai.Api (Api (..), renderApi) +import Baikai.Error (BaikaiError, invalidRequest, providerError) +import Baikai.Evidence + ( CallStatus, + EndpointIdentity (..), + EvidenceStrength, + EvidenceStrictness (..), + ModelCallEvidence (..), + ThinkingAdjustment (..), + ThinkingTranslation (..), + TransportKind (..), + baseEvidence, + commitmentDigest, + configurationDigest, + declaredStrength, + newCallId, + renderEvidenceStrength, + ) +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Prelude +import Baikai.ThinkingLevel (renderThinkingLevel) +import Control.Exception (SomeException, displayException) +import Data.Aeson qualified as Aeson +import Data.Maybe (fromMaybe) +import Data.Text qualified as Text +import Data.Time (UTCTime) +import Data.Version (showVersion) +import Paths_baikai qualified as Paths +import System.IO (hPutStrLn, stderr) + +-- | The version of the @baikai@ package that produced an evidence +-- record, read from the cabal-generated @Paths_baikai@ module. +-- +-- Read once, centrally, rather than hardcoded per adapter. Five +-- packages construct evidence, and a literal in each of them becomes a +-- lie the first time one is missed during a release. +baikaiPackageVersion :: Text +baikaiPackageVersion = Text.pack (showVersion Paths.version) + +-- | Build the evidence every transport can produce without observing +-- anything: identity from the caller's +-- 'Baikai.Evidence.EvidenceRequest', endpoint from the 'Model', the +-- requested model id, the supplied translation, the timings, the +-- status, and the two request digests. Every observed field is +-- 'Baikai.Evidence.Unobserved' and the strength is +-- 'Baikai.Evidence.EvidenceRequestedOnly'. +-- +-- Returns 'Nothing' when the caller set no @evidence@ field in +-- 'Options'. That is the opt-out path and it must stay genuinely free: +-- no digest is computed, no call identifier is generated, and the +-- @envelope@ argument is never forced. The gate lives here rather than +-- at each adapter's call site so that an adapter cannot forget it and a +-- transport added later inherits it. +-- +-- A transport that learns more overwrites the observed fields and +-- raises the strength; it must never overwrite a requested field with +-- an observed one or the reverse. +minimalEvidence :: + Model -> + Options -> + TransportKind -> + ThinkingTranslation -> + -- | The request envelope, used for the two digests. API providers + -- pass the JSON body they are about to send; subprocess providers + -- pass their argument vector rendered as a JSON array. + -- + -- __Deliberately lazy, and deliberately without the bang every other + -- field in this package carries.__ On the opt-out path this thunk is + -- discarded unforced, so an adapter may pass an expression that costs + -- something to evaluate without charging callers who opted out. The + -- missing strictness annotation is load-bearing; a test in + -- @baikai/test/TraceSpec.hs@ passes an envelope that throws when + -- forced and asserts an opted-out call still succeeds, so adding a + -- bang here fails the build rather than silently costing every caller + -- two SHA-256 passes over every prompt. + Aeson.Value -> + -- | Started at. + UTCTime -> + -- | Ended at. + UTCTime -> + CallStatus -> + -- | The normalized error, which must be 'Just' exactly when the + -- status is not 'CallSucceeded'. 'ModelCallEvidence' keeps the status + -- and the error as separate fields because that is the shape the JSON + -- schema needs, and their correlation is stated in the record's own + -- documentation rather than enforced by the type. + Maybe BaikaiError -> + IO (Maybe ModelCallEvidence) +minimalEvidence m opts transport translation envelope started ended st err = do + mk <- prepareEvidence m opts transport translation envelope started + pure (fmap (\finish -> finish ended st err) mk) + +-- | 'minimalEvidence' for a transport that learns its terminal +-- timestamp and status later than it learns everything else. +-- +-- A streaming adapter has the request envelope in hand before the first +-- byte comes back and the outcome only at the last, and the parts of +-- its translator that see the terminal event are usually pure. This +-- does the 'IO' half once — the opt-out check and the call identifier — +-- and hands back a function the adapter applies at the terminal. +-- +-- 'Nothing' is the opt-out path and carries the same guarantees +-- 'minimalEvidence' documents: no identifier is generated and the +-- envelope is never forced. Do not reach for this when the outcome is +-- already known; 'minimalEvidence' says the same thing with less +-- ceremony. +prepareEvidence :: + Model -> + Options -> + TransportKind -> + ThinkingTranslation -> + -- | The request envelope. Lazy, for the reason 'minimalEvidence' + -- documents at length. + Aeson.Value -> + -- | Started at. + UTCTime -> + IO (Maybe (UTCTime -> CallStatus -> Maybe BaikaiError -> ModelCallEvidence)) +prepareEvidence m opts transport translation envelope started = + case opts ^. #evidence of + Nothing -> pure Nothing + Just req -> do + cid <- newCallId + let ep = endpointIdentity m transport + commitment = commitmentDigest envelope + configuration = configurationDigest envelope + pure $ + Just $ \ended st err -> + ( baseEvidence + req + cid + ep + (m ^. #modelId) + translation + started + ended + st + commitment + configuration + ) + { errorInfo = err + } + +-- | Where a call went, without recording a credential. +-- +-- 'implementationVersion' is left 'Nothing' here. An API provider knows +-- its vendor package version and a subprocess provider can probe its +-- executable, but neither fact is available to the core, and inventing +-- one would be worse than admitting the gap. +endpointIdentity :: Model -> TransportKind -> EndpointIdentity +endpointIdentity m transport = + EndpointIdentity + { provider = m ^. #provider, + api = renderApi (m ^. #api), + transport = transport, + endpoint = sanitizeEndpoint (m ^. #baseUrl), + baikaiVersion = baikaiPackageVersion, + implementationVersion = Nothing + } + +-- | Reduce a base URL to scheme, host, port, and path. +-- +-- The query string is dropped __wholesale__ rather than filtered field +-- by field, because some gateways carry an API key in a query +-- parameter and an allow-list of safe parameter names would be wrong +-- the first time a host invented one. Any @userinfo@ component +-- (@https:\/\/user:secret\@host\/@) is dropped for the same reason. A +-- fragment cannot carry a credential to a server but is dropped too, +-- since it is never part of what was requested. +-- +-- An empty base URL yields 'Nothing' rather than an empty string, so a +-- reader can tell "baikai recorded no endpoint" from "the endpoint was +-- the empty string". +sanitizeEndpoint :: Text -> Maybe Text +sanitizeEndpoint raw + | Text.null trimmed = Nothing + | Text.null cleaned = Nothing + | otherwise = Just cleaned + where + trimmed = Text.strip raw + withoutFragment = Text.takeWhile (/= '#') trimmed + withoutQuery = Text.takeWhile (/= '?') withoutFragment + cleaned = dropUserInfo withoutQuery + +-- | Drop a @user:password\@@ prefix from the authority component, +-- keeping the scheme. Splits on the last @\@@ before the first @\/@ of +-- the path so that an @\@@ later in the path is not mistaken for +-- userinfo. +dropUserInfo :: Text -> Text +dropUserInfo url = + let (scheme, rest) = case Text.breakOn "://" url of + (s, r) | not (Text.null r) -> (s <> "://", Text.drop 3 r) + _ -> ("", url) + (authority, path) = Text.break (== '/') rest + in case Text.breakOnEnd "@" authority of + (before, after) | not (Text.null before) -> scheme <> after <> path + _ -> scheme <> authority <> path + +-- | The request envelope for the paths where __no provider adapter ran +-- to completion__, and therefore no wire request body exists for this +-- process to digest. +-- +-- There are three such paths: dispatch that found no registered handler +-- (@Baikai.Stream.streamRequestWith@ and +-- @Baikai.Provider.Registry.completeRequestWith@), a synchronous +-- handler that threw before returning a response +-- (@Baikai.Stream.liftCompleteToStream@), and a consumer that abandoned +-- the event stream before the terminal event +-- (@Baikai.Trace@'s finalizer). +-- +-- What this commits to is baikai's own dispatch parameters, not a +-- provider request body. That distinction matters and the failure mode +-- is deliberately the safe one: a verifier who independently holds the +-- prompt recomputes a different value and concludes the record does not +-- describe their request, which is a false negative. The unsafe +-- direction — a digest that appears to bind a run to an artifact it +-- never saw — cannot arise. On the no-handler paths there is no +-- reduction at all, because no wire body ever existed. +-- +-- Both keys are in the configuration allow-list +-- 'Baikai.Evidence.configurationProjection' recognises, so the +-- configuration digest over this envelope is meaningful rather than +-- degenerate. +dispatchEnvelope :: Model -> Options -> Aeson.Value +dispatchEnvelope m opts = + Aeson.object + [ "model" Aeson..= (m ^. #modelId), + "max_tokens" Aeson..= fromMaybe (m ^. #maxOutputTokens) (opts ^. #maxTokens) + ] + +-- | The transport a model's 'Api' tag implies. +-- +-- Only for the adapter-less paths above, where no implementation is +-- available to state its own transport. A real adapter passes the kind +-- it knows it used rather than calling this. +transportForModel :: Model -> TransportKind +transportForModel m = case m ^. #api of + AnthropicMessagesCli -> TransportSubprocess + OpenAICompletionsCli -> TransportSubprocess + _ -> TransportHttpApi + +-- ============================================================ +-- The pre-dispatch strictness gate +-- ============================================================ + +-- | Why a strict call was refused before anything was sent. +data EvidenceRefusal + = -- | The transport's declared maximum is below what the caller + -- required. Carries the required strength, then the declared one. + StrengthUnreachable !EvidenceStrength !EvidenceStrength + | -- | The request would reach the wire expressing less than the caller + -- asked for. Carries every adjustment that would apply. + ThinkingWouldDowngrade ![ThinkingAdjustment] + deriving stock (Eq, Show, Generic) + +-- | An explanation an operator can act on. Every refusal names both the +-- thing that was required and the thing that is actually available, +-- because a refusal that says only "no" is a dead end. +renderEvidenceRefusal :: EvidenceRefusal -> Text +renderEvidenceRefusal = \case + StrengthUnreachable needed declared -> + "this transport can reach at most " + <> renderEvidenceStrength declared + <> " evidence, and the call required " + <> renderEvidenceStrength needed + ThinkingWouldDowngrade adjustments -> + "the reasoning-effort request would not reach the provider as asked: " + <> Text.intercalate "; " (map describeAdjustment adjustments) + +-- | One downgrade, in words. These are the six places baikai weakens a +-- thinking request, and the whole point of strict mode is that a caller +-- can refuse each of them by name rather than discovering it in a trace +-- afterwards. +describeAdjustment :: ThinkingAdjustment -> Text +describeAdjustment = \case + EffortClamped lvl wire -> + renderThinkingLevel lvl <> " would be sent as " <> wire + EffortCollapsedToToggle lvl -> + renderThinkingLevel lvl + <> " would become a bare on/off toggle, so this host cannot tell it from any other level" + EffortOmitted lvl -> + renderThinkingLevel lvl + <> " would send no effort field at all, so the request is indistinguishable on the wire \ + \from the provider's own default" + ThinkingDroppedUnsupportedModel lvl -> + renderThinkingLevel lvl + <> " would be dropped entirely, because this model does not advertise reasoning support" + ThinkingDroppedUnsupportedHost lvl -> + renderThinkingLevel lvl + <> " would be dropped entirely, because this host exposes no reasoning controls" + ThinkingDroppedBudgetExceeded lvl budget maxOut -> + renderThinkingLevel lvl + <> " would be dropped entirely, because its " + <> Text.pack (show budget) + <> "-token budget does not fit inside the resolved output ceiling of " + <> Text.pack (show maxOut) + +-- | The pre-dispatch gate: every reason this call must not proceed, or +-- an empty list when it may. +-- +-- Every reason rather than the first, matching what +-- 'Baikai.Agent.applyAgentCeiling' already does for policy violations +-- and for the same reason: an operator fixing a configuration should see +-- all of it in one run rather than one thing per attempt. +-- +-- __The translation argument is deliberately lazy and deliberately +-- carries no bang.__ Under 'EvidenceBestEffort' — which is every caller +-- who has not opted into strictness — this returns @[]@ without touching +-- it, so a provider's translation function is never run for them. That +-- matters because computing a translation means a host-compatibility +-- lookup and a model-capability check on every dispatch, for a feature +-- only strict callers use. A test in @baikai/test/StrictEvidenceSpec.hs@ +-- passes a translation that throws when forced and asserts a best-effort +-- call still succeeds, so adding a bang here fails the build rather than +-- silently costing every caller. +-- +-- The downgrade rule needs one judgement stated, because it is not +-- obvious. A caller who requested no level at all is never downgraded — +-- there is nothing to weaken, and 'Baikai.Evidence.noThinkingRequested' +-- carries no adjustments, so this falls out. But /every/ non-empty +-- adjustment list refuses, including +-- 'Baikai.Evidence.EffortOmitted', which is the subtlest: that request +-- is not weaker in effect, it is merely indistinguishable on the wire +-- from the provider's default. A caller who demanded strict evidence and +-- receives a request they cannot later prove asked for @high@ has not +-- got what they demanded. +checkEvidenceRequirements :: + EvidenceStrictness -> Api -> ThinkingTranslation -> [EvidenceRefusal] +checkEvidenceRequirements EvidenceBestEffort _ _ = [] +checkEvidenceRequirements (EvidenceRequired needed) api translation = + [StrengthUnreachable needed declared | declared < needed] + <> [ThinkingWouldDowngrade downgrades | not (null downgrades)] + where + declared = declaredStrength api + downgrades = adjustments translation + +-- | Turn a non-empty refusal list into the error the call fails with. +-- +-- 'invalidRequest' rather than a provider error, because nothing reached +-- a provider: the call is refused on the caller's own terms, and a +-- retry-classifying consumer must not treat it as transient. +refusalError :: [EvidenceRefusal] -> BaikaiError +refusalError refusals = + invalidRequest + ( "strict evidence refused this call before dispatch: " + <> Text.intercalate "; " (map renderEvidenceRefusal refusals) + ) + +-- | Report a trace-sink failure on stderr. +-- +-- Always, under either strictness. A strict caller /additionally/ has +-- their call failed — see 'sinkFailureIsFatal' — but they should still +-- see the operator-facing line, because the two audiences are different: +-- the message is for whoever is watching the process, and the failed +-- call is for the program. +onSinkFailure :: EvidenceStrictness -> SomeException -> IO () +onSinkFailure _ e = + hPutStrLn + stderr + ( "baikai: trace sink failed; trace events for this call were dropped: " + <> displayException e + ) + +-- | Whether a trace-sink failure must fail the call. +-- +-- Under 'EvidenceBestEffort' it must not: reporting once on stderr and +-- letting the call succeed is baikai's long-standing behaviour and is +-- what every caller who has not opted into evidence gets. +-- +-- Under 'EvidenceRequired' it must. A strict caller asked for a record +-- of this call and the record did not survive; the call succeeding +-- anyway would hand them an answer they cannot account for, and they +-- would have no way to notice. __Evidence that can vanish without the +-- caller noticing is not evidence__, which is the whole reason the mode +-- exists. This is the one place in baikai where a call that reached the +-- provider and came back is nevertheless reported as failed, and it is +-- deliberate. +sinkFailureIsFatal :: EvidenceStrictness -> Bool +sinkFailureIsFatal = \case + EvidenceBestEffort -> False + EvidenceRequired _ -> True + +-- | The error a strict call fails with when its trace sink failed. +-- +-- 'invalidRequest' would be wrong — nothing about the request was +-- invalid — and no provider category fits either, because the provider +-- did its job. It is baikai's own machinery that failed the caller, so +-- it is a plain provider-side error naming the sink and carrying the +-- sink's own message. +sinkFailureError :: SomeException -> BaikaiError +sinkFailureError e = + providerError + ( "the trace sink failed and this call required evidence, so its record was \ + \not written: " + <> Text.pack (displayException e) + ) diff --git a/src/Baikai/Options.hs b/src/Baikai/Options.hs --- a/src/Baikai/Options.hs +++ b/src/Baikai/Options.hs @@ -32,6 +32,14 @@ -- for the mappings). EP-2 (shikumi) adds @responseFormat@, the -- provider-agnostic structured-output preference — see -- 'Baikai.ResponseFormat'. +-- +-- 'evidence' is the per-call request for verifiable model-call +-- evidence — see 'Baikai.Evidence.EvidenceRequest'. It carries the +-- caller's run identifier and how strictly they need the evidence. +-- A call whose 'evidence' is 'Nothing', which is every call that does +-- not opt in, behaves exactly as it did before the field existed: no +-- digest is computed, no evidence is emitted, and the trace output is +-- unchanged. module Baikai.Options ( Options, maxTokens, @@ -44,6 +52,7 @@ cacheRetention, thinking, responseFormat, + evidence, topP, stopSequences, seed, @@ -56,6 +65,7 @@ import Baikai.Auth (ApiKeySource) import Baikai.CacheRetention (CacheRetention) +import Baikai.Evidence (EvidenceRequest) import Baikai.ResponseFormat (ResponseFormat) import Baikai.ThinkingLevel (ThinkingLevel) import Baikai.Tool (ToolChoice) @@ -78,6 +88,7 @@ cacheRetention :: !(Maybe CacheRetention), thinking :: !(Maybe ThinkingLevel), responseFormat :: !(Maybe ResponseFormat), + evidence :: !(Maybe EvidenceRequest), topP :: !(Maybe Double), stopSequences :: !(Maybe (Vector Text)), seed :: !(Maybe Integer), @@ -100,6 +111,7 @@ cacheRetention = Nothing, thinking = Nothing, responseFormat = Nothing, + evidence = Nothing, topP = Nothing, stopSequences = Nothing, seed = Nothing, diff --git a/src/Baikai/Provider/Cli/Internal.hs b/src/Baikai/Provider/Cli/Internal.hs --- a/src/Baikai/Provider/Cli/Internal.hs +++ b/src/Baikai/Provider/Cli/Internal.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE LambdaCase #-} + -- | Internal helpers shared by the CLI providers in @baikai-claude@ -- and @baikai-openai@. -- @@ -11,8 +13,23 @@ wrapSystemPrompt, maybeApply, decodeUtf8Lenient, + trySync, + + -- * What a coding-agent CLI reported about its own run extractAgentMessage, + CodexRunReport (..), parseCodexJsonlStream, + ClaudeCliReport (..), + decodeClaudeCliResult, + + -- * What baikai knows about the process it launched + ExecutableIdentity (..), + executableIdentity, + + -- * Evidence envelopes and strength + argvEnvelope, + cliResponseEnvelope, + subprocessStrength, ) where @@ -23,21 +40,41 @@ UserContent (..), ) import Baikai.Context (Context) +import Baikai.Cost (Cost (..), zeroCost, zeroCostBreakdown) +import Baikai.Error (BaikaiError, decodeError) +import Baikai.Evidence (EvidenceStrength (..), Observed (..)) import Baikai.Message ( AssistantPayload (..), Message (..), ToolResultPayload (..), UserPayload (..), ) -import Control.Lens ((^.)) -import Data.Aeson (Value) +import Baikai.StopReason (StopReason (..)) +import Baikai.Usage (Usage (..)) +import Control.Applicative ((<|>)) +import Control.Exception + ( SomeAsyncException (..), + SomeException, + fromException, + throwIO, + try, + ) +import Control.Lens ((%~), (&), (.~), (^.)) +import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap (KeyMap) import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types (parseMaybe, (.:?)) +import Data.Aeson.Types (parseEither, parseMaybe, (.:), (.:?)) import Data.ByteString (ByteString) import Data.ByteString qualified as BS -import Data.Function ((&)) import Data.Generics.Labels () +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Scientific qualified as Scientific import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -45,10 +82,18 @@ import Data.Vector (Vector) import Data.Vector qualified as Vector import Data.Word (Word8) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) import Streamly.Data.Fold qualified as Fold import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream import Streamly.Data.Unfold qualified as Unfold +import System.Directory qualified as Directory +import System.Exit (ExitCode (..)) +import System.FilePath (isPathSeparator) +import System.IO.Unsafe (unsafePerformIO) +import System.Process qualified as Process +import System.Timeout (timeout) -- | Flatten a 'Context'\'s messages into a single prompt string -- suitable for a one-shot CLI invocation. @@ -125,6 +170,119 @@ decodeUtf8Lenient :: ByteString -> Text decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode +-- | 'Control.Exception.try' that catches synchronous failures and lets +-- an asynchronous one through. +-- +-- A subprocess provider turns a failed launch into an error-shaped +-- 'Baikai.Response.Response' rather than an exception, so it has to +-- catch broadly; swallowing a cancellation or a timeout while doing so +-- would make the caller's own control flow unreliable. +trySync :: IO a -> IO (Either SomeException a) +trySync action = do + r <- try action + case r of + Left e + | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) -> + throwIO e + | otherwise -> pure (Left e) + Right a -> pure (Right a) + +-- ============================================================ +-- Codex event-stream parsing +-- ============================================================ + +-- | What a @codex exec --json@ run reported about itself, beyond the +-- assistant text. +-- +-- Every field but 'message' is optional because the tool's event schema +-- has changed across codex versions and a missing field is a genuine +-- absence rather than a parse failure. A field that is 'Nothing' here +-- must be recorded as 'Baikai.Evidence.Unobserved' downstream and must +-- never be filled in from the request. +data CodexRunReport = CodexRunReport + { -- | The concatenated text of every @agent_message@ event. + message :: !Text, + -- | Codex's own handle for the conversation, from the + -- thread-start event. + threadId :: !(Maybe Text), + -- | The model codex named alongside its token accounting. See + -- 'codexTurn' for why it is only ever read from such an event. + reportedModel :: !(Maybe Text), + -- | The token counts codex reported, normalized into baikai's + -- disjoint 'Usage' convention. + usage :: !(Maybe Usage) + } + deriving stock (Eq, Show, Generic) + +-- | The accumulator 'parseCodexJsonlStream' folds events into. +-- +-- Separate from 'CodexRunReport' only because the message text arrives +-- in pieces and is kept reversed until the fold finishes. +data CodexAccumulator = CodexAccumulator + { messages :: ![Text], + threadId :: !(Maybe Text), + reportedModel :: !(Maybe Text), + usage :: !(Maybe Usage) + } + deriving stock (Generic) + +emptyCodexAccumulator :: CodexAccumulator +emptyCodexAccumulator = + CodexAccumulator + { messages = [], + threadId = Nothing, + reportedModel = Nothing, + usage = Nothing + } + +-- | Consume a stream of stdout bytes from @codex exec --json@, split on +-- newlines, decode each line as JSON, and fold the events into what the +-- run reported about itself. +-- +-- A line that is not valid JSON is skipped rather than failing the run: +-- codex writes progress chatter to stderr, but a future version writing +-- a non-JSON line to stdout must not turn a completed model call into a +-- decode error. +parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport +parseCodexJsonlStream chunks = do + let bytes :: Stream IO Word8 + bytes = Stream.unfoldEach Unfold.fromList (fmap BS.unpack chunks) + lineFold = Fold.takeEndBy_ (== newlineByte) (Fold.foldl' BS.snoc BS.empty) + acc <- + Stream.foldMany lineFold bytes + & Stream.mapMaybe Aeson.decodeStrict + & Stream.fold (Fold.foldl' absorbCodexEvent emptyCodexAccumulator) + pure + CodexRunReport + { message = Text.concat (reverse (acc ^. #messages)), + threadId = acc ^. #threadId, + reportedModel = acc ^. #reportedModel, + usage = acc ^. #usage + } + +-- | Fold one decoded codex event into the accumulator. +-- +-- The identifier keeps the __first__ value it sees, because the +-- thread-start event names the conversation and nothing later should +-- rename it. The token accounting keeps the __last__, because codex +-- emits one accounting event per turn and the final one is the one that +-- describes the completed run; summing them would double-count a +-- cumulative counter. +absorbCodexEvent :: CodexAccumulator -> Value -> CodexAccumulator +absorbCodexEvent acc v = + withTurn + ( acc + & #messages %~ maybe id (:) (extractAgentMessage v) + & #threadId %~ (<|> extractThreadId v) + ) + where + withTurn a = case codexTurn v of + Nothing -> a + Just (reported, counted) -> + a + & #usage .~ Just counted + & #reportedModel .~ reported + -- | Best-effort extractor for the assistant text inside a single -- Codex @--json@ event. See the original implementation's -- documentation for the schema variants accepted. @@ -163,21 +321,415 @@ Just (Aeson.String t) -> pure t _ -> fail "no payload" --- | Consume a stream of stdout bytes from @codex exec --json@, --- split on newlines, decode each line as JSON, filter to --- @agent_message@ events, and return the concatenation of their --- payloads. -parseCodexJsonlStream :: Stream IO ByteString -> IO Text -parseCodexJsonlStream chunks = do - let bytes :: Stream IO Word8 - bytes = Stream.unfoldEach Unfold.fromList (fmap BS.unpack chunks) - lineFold = Fold.takeEndBy_ (== newlineByte) (Fold.foldl' BS.snoc BS.empty) - msgs <- - Stream.foldMany lineFold bytes - & Stream.mapMaybe Aeson.decodeStrict - & Stream.mapMaybe extractAgentMessage - & Stream.fold Fold.toList - pure (Text.concat msgs) +-- | Apply a lookup to a codex event object, then to its nested @item@ +-- and @msg@ objects, taking the first hit. +-- +-- Codex has spelled its events all three ways across versions, which is +-- why 'extractAgentMessage' already tolerates each one. Every extractor +-- below inherits the same tolerance from here rather than repeating it. +inCodexEvent :: (KeyMap Value -> Maybe a) -> Value -> Maybe a +inCodexEvent f = \case + Object o -> f o <|> nested o "item" <|> nested o "msg" + _ -> Nothing + where + nested o k = case KeyMap.lookup k o of + Just (Object io) -> f io + _ -> Nothing +-- | Codex's own identifier for the conversation this run belongs to. +-- +-- @codex-cli 0.146.0@ spells it @thread_id@ on a @thread.started@ +-- event; older versions spelled the same thing @session_id@ and +-- @conversation_id@, and all three are accepted because a recorded +-- fixture from any of them must still parse. +extractThreadId :: Value -> Maybe Text +extractThreadId = inCodexEvent (firstString ["thread_id", "session_id", "conversation_id"]) + +-- | The token accounting from one codex event, and the model named on +-- that same event. +-- +-- The model is deliberately read __only__ from an event that also +-- carries token counts. An event naming a model beside its token +-- accounting is saying which model consumed them, which is an +-- observation; an event naming a model anywhere else could just as +-- easily be echoing the @--model@ flag baikai passed in, and recording +-- a request echo as an observation is precisely the conflation this +-- record exists to prevent. At @codex-cli 0.146.0@ no event names a +-- model at all, so this yields 'Nothing' today and will pick one up +-- only if codex starts reporting one where it belongs. +codexTurn :: Value -> Maybe (Maybe Text, Usage) +codexTurn = inCodexEvent $ \o -> case KeyMap.lookup "usage" o of + Just (Object u) + | any (`KeyMap.member` u) codexUsageKeys -> + Just (firstString ["model"] o, codexUsage u) + _ -> Nothing + +codexUsageKeys :: [Key] +codexUsageKeys = + [ "input_tokens", + "cached_input_tokens", + "cache_write_input_tokens", + "output_tokens", + "reasoning_output_tokens" + ] + +-- | Normalize codex's usage block into baikai's disjoint convention. +-- +-- Codex reports OpenAI-style inclusive prompt counts: @input_tokens@ +-- contains @cached_input_tokens@, which is why codex's own display +-- arithmetic subtracts one from the other to show non-cached input. The +-- subtraction is clamped at zero because 'Natural' subtraction throws +-- on underflow. +-- +-- @cache_write_input_tokens@ is carried through unmodified rather than +-- also subtracted. It is not part of the inclusive prompt total in any +-- codex version this repository has observed, and undercounting input +-- would be the worse of the two errors: it silently shrinks a call that +-- actually consumed the tokens. +codexUsage :: KeyMap Value -> Usage +codexUsage u = + let prompt = natField u "input_tokens" + cached = natField u "cached_input_tokens" + written = natField u "cache_write_input_tokens" + out = natField u "output_tokens" + nonCached = if cached >= prompt then 0 else prompt - cached + in Usage + { inputTokens = nonCached, + outputTokens = out, + cacheReadTokens = cached, + cacheWriteTokens = written, + reasoningTokens = natFieldMaybe u "reasoning_output_tokens", + totalTokens = nonCached + out + cached + written, + cost = zeroCost + } + newlineByte :: Word8 newlineByte = 0x0a + +-- ============================================================ +-- Claude CLI result parsing +-- ============================================================ + +-- | What a @claude -p --output-format json@ run reported about itself. +-- +-- The Haskell field is 'isError' where the tool's JSON field is +-- @is_error@: the record follows Haskell naming and the parser does the +-- mapping. 'reportedModel' and 'usage' are optional because the tool's +-- result schema varies by version, and an absent field must degrade to +-- 'Baikai.Evidence.Unobserved' rather than fail the decode. +data ClaudeCliReport = ClaudeCliReport + { -- | The assistant's answer, or the error text when 'isError'. + result :: !Text, + isError :: !Bool, + -- | The tool's own handle for the conversation. + sessionId :: !(Maybe Text), + -- | The model the tool reported as having consumed tokens. See + -- 'soleModelUsageKey'. + reportedModel :: !(Maybe Text), + -- | The token counts and reported cost, when the tool included a + -- usage block. + usage :: !(Maybe Usage) + } + deriving stock (Eq, Show, Generic) + +-- | Decode @claude -p --output-format json@ stdout. +-- +-- The tool emits either a bare result object or — as it does at version +-- 2.1.222 — an array of events from which the one whose @type@ is +-- @result@ is the terminal record. Both shapes are accepted because +-- both have shipped. +decodeClaudeCliResult :: ByteString -> Either BaikaiError ClaudeCliReport +decodeClaudeCliResult bs = case Aeson.eitherDecodeStrict bs of + Left err -> Left (decodeError (Text.pack err)) + Right (Array events) -> case findResultEvent events of + Nothing -> Left (decodeError "claude -p: no result event in stdout array") + Just ev -> parseResultEvent ev + Right v@(Object _) -> parseResultEvent v + Right _ -> Left (decodeError "claude -p: expected JSON object or array") + +findResultEvent :: Vector Value -> Maybe Value +findResultEvent = Vector.find isResult + where + isResult (Object o) = case KeyMap.lookup "type" o of + Just (String "result") -> True + _ -> False + isResult _ = False + +parseResultEvent :: Value -> Either BaikaiError ClaudeCliReport +parseResultEvent v = case parseEither parser v of + Left err -> Left (decodeError (Text.pack err)) + Right r -> Right r + where + parser = Aeson.withObject "claude-cli-result" $ \o -> do + body <- o .: "result" + failed <- o .: "is_error" + session <- o .:? "session_id" + pure + ClaudeCliReport + { result = body, + isError = failed, + sessionId = session, + reportedModel = KeyMap.lookup "modelUsage" o >>= soleModelUsageKey, + usage = claudeUsage o + } + +-- | The model @claude@ reported as having consumed tokens. +-- +-- Read from the keys of the result event's @modelUsage@ map, which +-- names every model that actually billed tokens on this run — and +-- names it as the tool spells it, including a context-window variant +-- marker such as @[1m]@, because truncating that to the canonical name +-- would discard a real distinction between two things baikai can +-- request separately. +-- +-- Exactly one key is an unambiguous statement of which model ran. +-- Several keys means several models did, and 'Baikai.Evidence' has one +-- 'Baikai.Evidence.observedModel' slot; picking one of them arbitrarily +-- would be a fabrication of specificity, so nothing is recorded. +soleModelUsageKey :: Value -> Maybe Text +soleModelUsageKey = \case + Object mu -> case KeyMap.keys mu of + [k] -> Just (Key.toText k) + _ -> Nothing + _ -> Nothing + +-- | The token counts and reported cost from a @claude@ result event. +-- +-- The tool reports Anthropic's already-disjoint prompt classes — +-- @input_tokens@ excludes both cache counters — so nothing is +-- subtracted here, unlike 'codexUsage'. +-- +-- @total_cost_usd@ becomes 'Baikai.Cost.Cost'\'s @usd@ with an empty +-- per-class breakdown, because the tool reports one total and no +-- breakdown. Reporting the tool's own figure is the same correction as +-- reporting its own token counts: a hardcoded zero says the call was +-- free, which is a claim the tool never made. +claudeUsage :: KeyMap Value -> Maybe Usage +claudeUsage o = case KeyMap.lookup "usage" o of + Just (Object u) + | any (`KeyMap.member` u) claudeUsageKeys -> + let i = natField u "input_tokens" + out = natField u "output_tokens" + cr = natField u "cache_read_input_tokens" + cw = natField u "cache_creation_input_tokens" + in Just + Usage + { inputTokens = i, + outputTokens = out, + cacheReadTokens = cr, + cacheWriteTokens = cw, + reasoningTokens = Nothing, + totalTokens = i + out + cr + cw, + cost = reportedCost + } + _ -> Nothing + where + reportedCost = case KeyMap.lookup "total_cost_usd" o of + Just (Number n) | n > 0 -> Cost {usd = toRational n, breakdown = zeroCostBreakdown} + _ -> zeroCost + +claudeUsageKeys :: [Key] +claudeUsageKeys = + [ "input_tokens", + "output_tokens", + "cache_read_input_tokens", + "cache_creation_input_tokens" + ] + +-- ============================================================ +-- Shared JSON field readers +-- ============================================================ + +-- | The first of the named keys whose value is a non-empty JSON string. +firstString :: [Key] -> KeyMap Value -> Maybe Text +firstString keys o = + listToMaybe + [t | k <- keys, Just (String t) <- [KeyMap.lookup k o], not (Text.null t)] + +-- | A non-negative whole number from a JSON field, or zero. +-- +-- A missing, negative, fractional, or absurdly large value reads as +-- zero rather than throwing: a token counter is describing a completed +-- model call, and no shape of counter is worth failing that call over. +natField :: KeyMap Value -> Key -> Natural +natField o k = fromMaybe 0 (natFieldMaybe o k) + +-- | 'natField', but distinguishing an absent field from a reported +-- zero. 'Baikai.Usage.Usage'\'s @reasoningTokens@ needs the +-- distinction; its other counters do not. +natFieldMaybe :: KeyMap Value -> Key -> Maybe Natural +natFieldMaybe o k = case KeyMap.lookup k o of + Just (Number n) -> case Scientific.toBoundedInteger n :: Maybe Int of + Just i | i >= 0 -> Just (fromIntegral i) + _ -> Nothing + _ -> Nothing + +-- ============================================================ +-- Executable identity +-- ============================================================ + +-- | Identity of the executable a subprocess provider ran. +data ExecutableIdentity = ExecutableIdentity + { -- | The name or path as configured. + configured :: !Text, + -- | The absolute path it resolved to on @PATH@, when resolution + -- succeeded. + resolvedPath :: !(Maybe Text), + -- | What the tool prints for @--version@, trimmed to its first + -- non-blank line. 'Nothing' when the probe failed or the tool has + -- no such flag; a failed probe is recorded as absent rather than + -- failing the call, because the call itself may well have + -- succeeded and the absence is itself accurate evidence. + version :: !(Maybe Text) + } + deriving stock (Eq, Show, Generic) + +-- | Resolve and probe an executable, caching the result for the +-- lifetime of the process, keyed by the configured name. +-- +-- Probing runs the tool once with @--version@. A version string is +-- stable for the lifetime of a baikai process in every realistic +-- deployment, and spawning an extra subprocess per model call would +-- roughly double the process cost of the cheapest possible call — so +-- the answer is cached, keyed by the configured name so a caller who +-- configures two different executables gets two correct answers. +-- +-- Call this only from inside the evidence branch. A caller who never +-- asked for evidence must not pay for a process whose only purpose is +-- to describe a tool they were about to run anyway. +-- +-- The probe is bounded by 'versionProbeMicros': a tool that hangs on +-- @--version@ must never be able to wedge a model call. +executableIdentity :: FilePath -> IO ExecutableIdentity +executableIdentity exe = do + cached <- Map.lookup exe <$> readIORef executableIdentityCache + case cached of + Just identity -> pure identity + Nothing -> do + identity <- probeExecutable exe + -- Insert only if still absent: two threads racing on the same + -- executable must agree on one answer, and the first one written + -- is as good as the second. + atomicModifyIORef' + executableIdentityCache + (\m -> (Map.insertWith (\_ old -> old) exe identity m, ())) + pure identity + +probeExecutable :: FilePath -> IO ExecutableIdentity +probeExecutable exe = do + resolved <- resolveExecutable exe + probed <- maybe (pure Nothing) probeVersion resolved + pure + ExecutableIdentity + { configured = Text.pack exe, + resolvedPath = Text.pack <$> resolved, + version = probed + } + +-- | Where a configured executable name actually points. +-- +-- A name containing a path separator is a path and is checked +-- directly; a bare name is looked up on @PATH@. Doing the split here +-- rather than relying on 'Directory.findExecutable' to handle both +-- keeps the behaviour the same across @directory@ versions, which have +-- not always agreed on what a path-shaped argument means. +resolveExecutable :: FilePath -> IO (Maybe FilePath) +resolveExecutable exe + | any isPathSeparator exe = do + here <- Directory.doesFileExist exe + if here then Just <$> Directory.makeAbsolute exe else pure Nothing + | otherwise = Directory.findExecutable exe + +probeVersion :: FilePath -> IO (Maybe Text) +probeVersion path = do + outcome <- trySync (timeout versionProbeMicros (Process.readProcessWithExitCode path ["--version"] "")) + pure $ case outcome of + Right (Just (ExitSuccess, out, _)) -> firstNonBlankLine (Text.pack out) + _ -> Nothing + +-- | Five seconds. +-- +-- The bound exists to stop a tool that /never/ answers from wedging a +-- model call, so any finite value solves the problem it is there for. +-- What a tighter bound buys is nothing; what it costs is a version +-- recorded as absent because the machine was busy when the probe ran. +-- Five seconds is paid at most once per executable per process, and +-- only on the pathological path. +versionProbeMicros :: Int +versionProbeMicros = 5000000 + +firstNonBlankLine :: Text -> Maybe Text +firstNonBlankLine = listToMaybe . filter (not . Text.null) . map Text.strip . Text.lines + +-- | Resolved executable identities, keyed by the configured name. +-- +-- The @unsafePerformIO@-plus-@NOINLINE@ idiom is the one +-- "Baikai.Provider.Registry" already uses for its global registry, so +-- the shape of a process-wide cache is the same wherever it appears in +-- this package. +executableIdentityCache :: IORef (Map FilePath ExecutableIdentity) +executableIdentityCache = unsafePerformIO (newIORef Map.empty) +{-# NOINLINE executableIdentityCache #-} + +-- ============================================================ +-- Evidence envelopes and strength +-- ============================================================ + +-- | The request envelope a subprocess provider hands to +-- 'Baikai.Evidence.Build.minimalEvidence': the rendered argument +-- vector, executable first, as a JSON array of strings. +-- +-- This is the subprocess analogue of an API provider's request body, +-- and it is genuinely what crossed the boundary — there is no other +-- description of a process launch. +-- +-- Both CLI providers place the prompt inside this vector, so +-- 'Baikai.Evidence.commitmentDigest' over it legitimately commits to +-- the prompt. 'Baikai.Evidence.configurationDigest' does not: its +-- projection admits named fields from an object and a JSON array has +-- none, so an argv envelope projects to @null@ and the configuration +-- digest reveals nothing about the command line at all. That is the +-- allow-list failing in the safe direction, which is what it is for. +argvEnvelope :: FilePath -> [String] -> Value +argvEnvelope exe args = + Aeson.toJSON (map Text.pack (exe : args)) + +-- | What a subprocess call's response commitment digest commits to: the +-- assistant content, the stop reason, and the reported usage. +-- +-- Spelled with the same three keys, in the same shapes, as the +-- Anthropic and OpenAI-compatible API transports build by hand in +-- @Baikai.Provider.Claude.Api@ and @Baikai.Provider.OpenAI.Api@. That +-- agreement is what lets a verifier holding a response recompute the +-- digest without first having to know which transport served it, so it +-- must not be allowed to drift. +-- +-- A CLI provider produces exactly one text block and always stops with +-- 'Stop', which is why those two are fixed here rather than passed in. +cliResponseEnvelope :: Text -> Usage -> Value +cliResponseEnvelope body used = + Aeson.object + [ "content" .= Vector.singleton (AssistantText (TextContent body)), + "stop_reason" .= Stop, + "usage" .= used + ] + +-- | How much a subprocess call's evidence proves. +-- +-- A coding-agent CLI that exits zero has demonstrated that it ran and +-- did not crash. It has not stated which model served the request, what +-- effort was applied, or whether the request reached the intended +-- provider at all — so a successful exit never raises the strength, and +-- the exit status is deliberately not an argument to this function. +-- Only a value the tool itself reported can raise it. +subprocessStrength :: + -- | The session or thread identifier the tool reported. + Observed Text -> + -- | The model the tool reported, if it reports one at all. + Observed Text -> + EvidenceStrength +subprocessStrength sessionIdentifier reported = + case (reported, sessionIdentifier) of + (Observed _, Observed _) -> EvidenceModelObserved + (_, Observed _) -> EvidenceCorrelated + _ -> EvidenceRequestedOnly diff --git a/src/Baikai/Provider/Registry.hs b/src/Baikai/Provider/Registry.hs --- a/src/Baikai/Provider/Registry.hs +++ b/src/Baikai/Provider/Registry.hs @@ -22,6 +22,7 @@ registerApiProvider, assertRegistered, lookupApiProviderWith, + evidenceRefusals, lookupApiProvider, completeRequestWith, completeRequest, @@ -35,10 +36,14 @@ import Baikai.Content (AssistantContent (..), ToolCall) import Baikai.Context (Context, appendToolResult, contextOf) import Baikai.Error (providerUnavailable) +import Baikai.Evidence (ThinkingTranslation, noThinkingRequested) +import Baikai.Evidence qualified as Evidence +import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), ToolResult, toolResultErrorText, user) import Baikai.Model (Model) import Baikai.Model qualified as Model import Baikai.Options (Options, emptyOptions) +import Baikai.Options qualified as Options import Baikai.Response (Response (..), errorResponse, flattenAssistantBlocks, flattenAssistantText, responseError) import Baikai.StopReason (StopReason (..)) import Baikai.Stream.Event (AssistantMessageEvent) @@ -61,7 +66,21 @@ data ApiProvider = ApiProvider { apiTag :: !Api, stream :: !(Model -> Context -> Options -> Stream IO AssistantMessageEvent), - complete :: !(Model -> Context -> Options -> IO Response) + complete :: !(Model -> Context -> Options -> IO Response), + -- | Describe, without sending anything, what this provider would do + -- with the caller's reasoning-effort request. + -- + -- Used only by the pre-dispatch strictness gate, which has to be + -- able to refuse /before/ any request is built — so it cannot wait + -- for the translation a provider returns alongside its mapped + -- request. Implement it by calling the same function that builds + -- that translation, never by writing a second one: two descriptions + -- of one mapping diverge the first time either changes, and the + -- divergence is silent. + -- + -- Never called for a caller who set no @evidence@ request or who + -- asked for best-effort evidence, which is every existing caller. + describeThinking :: !(Model -> Options -> ThinkingTranslation) } -- | A mutable provider registry handle. Each handle owns its own handler map, @@ -136,15 +155,73 @@ completeRequestWith reg m ctx opts = do mProvider <- lookupApiProviderWith reg (Model.api m) case mProvider of - Just p -> complete p m ctx opts + Just p -> case evidenceRefusals p m opts of + [] -> complete p m ctx opts + refusals -> refusedResponse m opts (describeThinking p m opts) refusals Nothing -> do now <- getCurrentTime - pure $ - errorResponse + -- "No provider was registered" is a fact about the call, so a + -- caller who asked for evidence gets a record of it. Nothing was + -- sent, so the digests are over 'Build.dispatchEnvelope'. + let detail = "No provider registered for API: " <> renderApi (Model.api m) + err = providerUnavailable detail + ev <- + Build.minimalEvidence m + opts + (Build.transportForModel m) + noThinkingRequested + (Build.dispatchEnvelope m opts) now - 0 - (providerUnavailable ("No provider registered for API: " <> renderApi (Model.api m))) + now + Evidence.CallFailed + (Just err) + let resp = errorResponse m now 0 err + pure resp {evidence = ev} + +-- | Every reason strict evidence mode must refuse this call before it +-- is dispatched, or an empty list. +-- +-- Short-circuits on the caller's own request twice over. A caller who +-- set no @evidence@ request pays one 'Maybe' test and never reaches the +-- gate; a caller who asked for best-effort evidence reaches it and the +-- gate returns @[]@ without forcing the translation, so +-- 'describeThinking' is not run for them either. Between them that is +-- every caller who existed before strict mode. +evidenceRefusals :: ApiProvider -> Model -> Options -> [Build.EvidenceRefusal] +evidenceRefusals p m opts = case Options.evidence opts of + Nothing -> [] + Just req -> + Build.checkEvidenceRequirements + (Evidence.strictness req) + (Model.api m) + (describeThinking p m opts) + +-- | The error-shaped response a refused call returns. +-- +-- The evidence it carries records the very translation that caused the +-- refusal, rather than 'Evidence.noThinkingRequested': a caller told +-- their request would be downgraded should be able to read exactly which +-- downgrade in the record, not just in the message. Nothing was sent, so +-- the digests are over 'Build.dispatchEnvelope'. +refusedResponse :: + Model -> Options -> Evidence.ThinkingTranslation -> [Build.EvidenceRefusal] -> IO Response +refusedResponse m opts translation refusals = do + now <- getCurrentTime + let err = Build.refusalError refusals + ev <- + Build.minimalEvidence + m + opts + (Build.transportForModel m) + translation + (Build.dispatchEnvelope m opts) + now + now + Evidence.CallFailed + (Just err) + let resp = errorResponse m now 0 err + pure resp {evidence = ev} -- | Dispatch a synchronous request through the process-global registry. completeRequest :: Model -> Context -> Options -> IO Response diff --git a/src/Baikai/Response.hs b/src/Baikai/Response.hs --- a/src/Baikai/Response.hs +++ b/src/Baikai/Response.hs @@ -26,6 +26,7 @@ import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Error (BaikaiError, providerError) import Baikai.Error qualified as Error +import Baikai.Evidence (ModelCallEvidence) import Baikai.Message (AssistantPayload (..), Message (..)) import Baikai.Model (Model, emptyModel) import Baikai.Model qualified as Model @@ -52,7 +53,18 @@ -- error-shaped responses and 'Nothing' on success. Use -- 'responseError' for the normalized failure view; it synthesizes -- an 'OtherError' if a nonconforming provider omits this field. - errorInfo :: !(Maybe BaikaiError) + errorInfo :: !(Maybe BaikaiError), + -- | The evidence the provider adapter built for this call, when the + -- caller asked for evidence and the provider builds it. + -- + -- This is a convenience for synchronous callers. A caller who needs + -- evidence should prefer reading it from their + -- 'Baikai.Trace.Sink.TraceSink': the trace path emits exactly one + -- record per call under every way a call can end, whereas this + -- field is 'Nothing' on every path that never assembles a full + -- response — a consumer that abandoned the stream early, or a + -- dispatch that failed before any provider ran. + evidence :: !(Maybe ModelCallEvidence) } deriving stock (Eq, Show, Generic) @@ -75,7 +87,8 @@ provider = "", responseId = Nothing, latencyMs = 0, - errorInfo = Nothing + errorInfo = Nothing, + evidence = Nothing } -- | Wrap the response payload as a conversation 'AssistantMessage'. @@ -124,7 +137,8 @@ provider = Model.provider m, responseId = Nothing, latencyMs = latency, - errorInfo = Just err + errorInfo = Just err, + evidence = Nothing } {-# DEPRECATED _Response "Use emptyResponse instead." #-} diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -36,6 +36,9 @@ import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Error (BaikaiError, providerError, providerUnavailable) +import Baikai.Evidence (ModelCallEvidence, noThinkingRequested) +import Baikai.Evidence qualified as Evidence +import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), Message (AssistantMessage)) import Baikai.Message qualified as Msg import Baikai.Model (Model) @@ -43,6 +46,7 @@ import Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, + evidenceRefusals, globalProviderRegistry, lookupApiProviderWith, ) @@ -101,8 +105,11 @@ Stream.concatEffect $ do mProvider <- lookupApiProviderWith reg (m ^. #api) case mProvider of - Just p -> pure (stream p m ctx opts) - Nothing -> Stream.fromList <$> noProviderEvents m + Nothing -> Stream.fromList <$> noProviderEvents m opts + Just p -> case evidenceRefusals p m opts of + [] -> pure (stream p m ctx opts) + refusals -> + Stream.fromList <$> refusedEvents m opts (describeThinking p m opts) refusals -- | Stream a request through the process-global registry, invoking the -- callback once per event, then return the same reassembled 'Response' @@ -195,6 +202,9 @@ { reason :: !StopReason, message :: !Message, errorInfo :: !(Maybe BaikaiError), + -- | The evidence the provider adapter attached to its terminal + -- event, copied onto the assembled 'Response' by 'finalizeState'. + evidence :: !(Maybe ModelCallEvidence), failed :: !Bool } deriving stock (Show, Generic) @@ -244,15 +254,29 @@ s & #blocks %~ IntMap.insert i (AssistantToolCall tc) & #toolArgsBuf %~ IntMap.delete i - EventDone TerminalPayload {reason = r, message = msg, responseId = rid} -> + EventDone TerminalPayload {reason = r, message = msg, responseId = rid, evidence = ev} -> s & #terminal - .~ Just TerminalSeen {reason = r, message = msg, errorInfo = Nothing, failed = False} + .~ Just + TerminalSeen + { reason = r, + message = msg, + errorInfo = Nothing, + evidence = ev, + failed = False + } & #responseId %~ (\old -> rid <|> old) - EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei} -> + EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei, evidence = ev} -> s & #terminal - .~ Just TerminalSeen {reason = r, message = msg, errorInfo = ei, failed = True} + .~ Just + TerminalSeen + { reason = r, + message = msg, + errorInfo = ei, + evidence = ev, + failed = True + } & #responseId %~ (\old -> rid <|> old) finalizeState :: ReassemblyState -> IO Response @@ -266,6 +290,7 @@ Just TerminalSeen {reason = r, message = msg, errorInfo = ei, failed = failed'} -> (msg, r, ei, failed', True) Nothing -> (synthesizeTerminal now assembled, Stop, Nothing, False, False) + terminalEvidence = s ^. #terminal >>= \TerminalSeen {evidence = ev} -> ev terminalContent = messageContent terminalMsg normalizedError = case (terminalReason, terminalError) of (ErrorReason, Nothing) -> Just (providerError (messageErrorText terminalMsg)) @@ -287,7 +312,8 @@ provider = m ^. #provider, responseId = s ^. #responseId, latencyMs = latency, - errorInfo = normalizedError + errorInfo = normalizedError, + evidence = terminalEvidence } -- | Project the event-assembled content in 'contentIndex' order, @@ -422,7 +448,7 @@ er <- trySync (f m ctx opts) case er of Right resp -> pure (Stream.fromList (eventsFor startTs resp)) - Left e -> Stream.fromList <$> errorEvents e + Left e -> Stream.fromList <$> errorEvents m opts startTs e -- | 'try' for synchronous exceptions only. Anything delivered -- asynchronously (wrapped in 'Control.Exception.SomeAsyncException' by @@ -465,9 +491,14 @@ ] reason = payload ^. #stopReason rid = resp ^. #responseId + -- Carry the wrapped response's evidence onto the synthetic + -- terminal event. Without this the two subprocess providers, + -- which reach the stream surface only through this function, + -- would build evidence and then drop it on the floor. + ev = resp ^. #evidence terminalEvent = case responseError resp of - Just be -> EventError (errorTerminal rid reason msg be) - Nothing -> EventDone (doneTerminal rid reason msg) + Just be -> EventError (errorTerminal ev rid reason msg be) + Nothing -> EventDone (doneTerminal ev rid reason msg) in [EventStart StartPayload {partial = skeleton, responseId = rid}] <> blockEvents <> [terminalEvent] @@ -492,8 +523,15 @@ ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} ] -errorEvents :: Control.Exception.SomeException -> IO [AssistantMessageEvent] -errorEvents e = do +-- | The synthetic error stream for a @complete@ handler that threw +-- instead of returning an error-shaped 'Response'. +-- +-- The handler may well have sent a request before it threw, but it +-- never returned one for this layer to digest, so the digests are over +-- 'Build.dispatchEnvelope' — see its documentation. +errorEvents :: + Model -> Options -> UTCTime -> Control.Exception.SomeException -> IO [AssistantMessageEvent] +errorEvents m opts startTs e = do now <- getCurrentTime -- When a @complete@ handler threw a typed 'BaikaiError' (the CLI, -- 'Baikai.Auth', and registry paths do), preserve it structurally so a @@ -513,16 +551,78 @@ Msg.timestamp = Just now } err = maybe (providerError errText) id mErr + ev <- + Build.minimalEvidence + m + opts + (Build.transportForModel m) + noThinkingRequested + (Build.dispatchEnvelope m opts) + startTs + now + Evidence.CallFailed + (Just err) pure [ EventStart StartPayload {partial = msg, responseId = Nothing}, - EventError (errorTerminal Nothing ErrorReason msg err) + EventError (errorTerminal ev Nothing ErrorReason msg err) ] -- | The synthetic error stream used when no provider is registered for -- the model's API tag. -noProviderEvents :: Model -> IO [AssistantMessageEvent] -noProviderEvents m = do +-- +-- This carries evidence when the caller asked for it. "No provider was +-- registered" is a fact about the call, and a run record that silently +-- omits it is worse than one that records the failure. There is no wire +-- request body to digest here because nothing was ever sent, so the +-- digests are over 'Build.dispatchEnvelope'. +-- | The one-event error stream a strict call refused before dispatch +-- returns. +-- +-- Shaped exactly like 'noProviderEvents', because from a consumer's +-- point of view both are the same thing: a call that produced a terminal +-- error without a provider ever running. The evidence carries the very +-- translation that caused the refusal rather than +-- 'noThinkingRequested', so a caller told their request would be +-- downgraded can read which downgrade in the record and not only in the +-- message. +refusedEvents :: + Model -> + Options -> + Evidence.ThinkingTranslation -> + [Build.EvidenceRefusal] -> + IO [AssistantMessageEvent] +refusedEvents m opts translation refusals = do now <- getCurrentTime + let be = Build.refusalError refusals + detail = be ^. #message + msg = + AssistantMessage + AssistantPayload + { Msg.content = Vector.empty, + Msg.usage = zeroUsage, + Msg.stopReason = ErrorReason, + Msg.errorMessage = Just detail, + Msg.timestamp = Just now + } + ev <- + Build.minimalEvidence + m + opts + (Build.transportForModel m) + translation + (Build.dispatchEnvelope m opts) + now + now + Evidence.CallFailed + (Just be) + pure + [ EventStart StartPayload {partial = msg, responseId = Nothing}, + EventError (errorTerminal ev Nothing ErrorReason msg be) + ] + +noProviderEvents :: Model -> Options -> IO [AssistantMessageEvent] +noProviderEvents m opts = do + now <- getCurrentTime let detail = "No provider registered for API: " <> renderApi (m ^. #api) be = providerUnavailable detail msg = @@ -534,7 +634,18 @@ Msg.errorMessage = Just detail, Msg.timestamp = Just now } + ev <- + Build.minimalEvidence + m + opts + (Build.transportForModel m) + noThinkingRequested + (Build.dispatchEnvelope m opts) + now + now + Evidence.CallFailed + (Just be) pure [ EventStart StartPayload {partial = msg, responseId = Nothing}, - EventError (errorTerminal Nothing ErrorReason msg be) + EventError (errorTerminal ev Nothing ErrorReason msg be) ] diff --git a/src/Baikai/Stream/Event.hs b/src/Baikai/Stream/Event.hs --- a/src/Baikai/Stream/Event.hs +++ b/src/Baikai/Stream/Event.hs @@ -44,6 +44,7 @@ import Baikai.Content (ThinkingContent, ToolCall) import Baikai.Error (BaikaiError) +import Baikai.Evidence (ModelCallEvidence) import Baikai.Message (Message) import Baikai.StopReason (StopReason) import Data.Aeson (ToJSON) @@ -180,7 +181,20 @@ -- | Structured error detail. Always 'Nothing' on 'EventDone' and -- always 'Just' on 'EventError'; use 'errorTerminal' to enforce the -- error-side invariant at construction sites. - errorInfo :: !(Maybe BaikaiError) + errorInfo :: !(Maybe BaikaiError), + -- | The evidence the provider adapter built for this call, when the + -- adapter produced any. This is the channel a provider uses to + -- report what it actually put on the wire back to + -- "Baikai.Trace", which otherwise only sees the caller's own + -- 'Baikai.Model.Model' and 'Baikai.Options.Options'. + -- + -- 'Nothing' means one of two things and a consumer must not try to + -- tell them apart: the caller set no + -- 'Baikai.Options.evidence' request, or this provider has not been + -- taught to build evidence. Both are distinct from evidence whose + -- observed fields are 'Baikai.Evidence.Unobserved', which is a + -- positive statement that the provider reported nothing back. + evidence :: !(Maybe ModelCallEvidence) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) @@ -188,16 +202,43 @@ -- | Build a success terminal payload ('errorInfo' is always 'Nothing'). -- Prefer this over the raw 'TerminalPayload' constructor so a new field -- can never be left uninitialised at a construction site. -doneTerminal :: Maybe Text -> StopReason -> Message -> TerminalPayload -doneTerminal rid r m = - TerminalPayload {reason = r, message = m, responseId = rid, errorInfo = Nothing} +-- +-- The evidence comes first because it is the argument most likely to be +-- supplied from a @let@-bound value at the call site; pass 'Nothing' +-- from a provider that does not build evidence. +doneTerminal :: + Maybe ModelCallEvidence -> Maybe Text -> StopReason -> Message -> TerminalPayload +doneTerminal ev rid r m = + TerminalPayload + { reason = r, + message = m, + responseId = rid, + errorInfo = Nothing, + evidence = ev + } -- | Build an error terminal payload carrying structured error detail. -- Prefer this over the raw 'TerminalPayload' constructor so an -- 'EventError' cannot be constructed without 'errorInfo'. -errorTerminal :: Maybe Text -> StopReason -> Message -> BaikaiError -> TerminalPayload -errorTerminal rid r m e = - TerminalPayload {reason = r, message = m, responseId = rid, errorInfo = Just e} +-- +-- A failed call still carries evidence when the caller asked for it: a +-- call that failed is a fact about the call, and a run record that +-- omits it is worse than one that records the failure. +errorTerminal :: + Maybe ModelCallEvidence -> + Maybe Text -> + StopReason -> + Message -> + BaikaiError -> + TerminalPayload +errorTerminal ev rid r m e = + TerminalPayload + { reason = r, + message = m, + responseId = rid, + errorInfo = Just e, + evidence = ev + } -- | 'True' when the event terminates the stream — exactly one -- 'EventDone' or 'EventError' is emitted per call. diff --git a/src/Baikai/Trace.hs b/src/Baikai/Trace.hs --- a/src/Baikai/Trace.hs +++ b/src/Baikai/Trace.hs @@ -43,19 +43,32 @@ import Baikai.Context (Context) import Baikai.Cost (usdAsScientific) -import Baikai.Cost qualified as Cost import Baikai.Cost.Log ( CallLogEntry (..), CallLogHandle, appendEntry, summarizeContext, ) +import Baikai.Error (BaikaiError, providerError) +-- 'Baikai.Evidence.CallStatus' has a @CallFailed@ constructor and so +-- does 'Baikai.Trace.Event.TraceEvent'. They mean different things and +-- both belong in this module, so the status constructors stay behind +-- the @Evidence.@ qualifier. +import Baikai.Evidence + ( EvidenceStrictness (..), + ModelCallEvidence, + newCallId, + noThinkingRequested, + ) +import Baikai.Evidence qualified as Evidence +import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), Message (..)) import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Prelude import Baikai.Provider.Registry (ProviderRegistry, globalProviderRegistry) import Baikai.Response (Response) +import Baikai.StopReason (StopReason (ErrorReason)) import Baikai.Stream (reassembleResponse, streamRequestWith) import Baikai.Stream.Event (AssistantMessageEvent (..), TerminalPayload (..)) import Baikai.Trace.Event (TraceEvent (..)) @@ -65,22 +78,15 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Exception (SomeException, displayException, try) -import Control.Monad (forM_, unless) +import Control.Exception (SomeException, try) +import Control.Monad (forM_, unless, void) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) -import Data.Bits (unsafeShiftL, (.&.), (.|.)) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) -import Data.Text qualified as Text import Data.Time (UTCTime, diffUTCTime, getCurrentTime) -import Data.Time.Clock.POSIX (getPOSIXTime) -import Data.Word (Word64) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) -import Numeric (showHex) import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream -import System.IO (hPutStrLn, stderr) -import System.IO.Unsafe (unsafePerformIO) -- ============================================================ -- Stream-shaped trace bridge @@ -133,7 +139,7 @@ Left e -> writeIORef (state ^. #sinkError) (Just e) Right () -> pure () putMVar d () - eid <- newEventId + eid <- newCallId start <- getCurrentTime writeChan c $ Just @@ -147,8 +153,12 @@ } pure $ Stream.finallyIO - (finalizeTrace state eid start m) - (Stream.mapM (traceEvent state eid start m) (streamRequestWith reg m ctx opts)) + -- The cleanup path cannot change a call's outcome — the stream + -- is already over — so a fatal sink failure discovered here has + -- nowhere to go but the stderr line 'reportSinkError' already + -- wrote. The terminal event below is where it can still matter. + (void (finalizeTrace state eid start m opts)) + (Stream.mapM (traceEvent state eid start m opts) (streamRequestWith reg m ctx opts)) -- | Synchronous trace wrapper. Drains 'withTraceStream' into a -- 'Response' through 'reassembleResponse'. @@ -211,56 +221,147 @@ writeIORef root (Just sp) pure state -finalizeTrace :: TraceState -> Text -> UTCTime -> Model -> IO () -finalizeTrace s eid start m = do +-- | Close the trace for a call and report whether its sink failure must +-- fail the call. +-- +-- 'Nothing' is the ordinary outcome, including a best-effort call whose +-- sink threw: that is reported on stderr and the call succeeds, which is +-- baikai's long-standing behaviour. 'Just' happens only for a caller who +-- required evidence and did not get it. +-- +-- Runs at most once per call — the second caller sees 'closed' already +-- set and returns 'Nothing' — which is why the terminal event calls it +-- before the 'Stream.finallyIO' cleanup does. The terminal is where the +-- answer can still change the call's outcome; by cleanup time the +-- stream is over. +finalizeTrace :: + TraceState -> Text -> UTCTime -> Model -> Options -> IO (Maybe BaikaiError) +finalizeTrace s eid start m opts = do alreadyClosed <- atomicModifyIORef' (s ^. #closed) (\b -> (True, b)) - unless alreadyClosed $ do - sent <- readIORef (s ^. #terminalSent) - unless sent $ do - now <- getCurrentTime - writeChan (s ^. #chan) $ - Just - CallFailed - { eventId = eid, - timestamp = now, - provider = m ^. #provider, - model = m ^. #modelId, - latencyMs = millisBetween start now, - errorMessage = "aborted: stream consumer stopped before the terminal event" - } - writeChan (s ^. #chan) Nothing - takeMVar (s ^. #done) - reportSinkError s - releaseStableRoot s + if alreadyClosed + then pure Nothing + else do + sent <- readIORef (s ^. #terminalSent) + unless sent $ do + now <- getCurrentTime + let abortText = "aborted: stream consumer stopped before the terminal event" + aborted = + CallFailed + { eventId = eid, + timestamp = now, + provider = m ^. #provider, + model = m ^. #modelId, + latencyMs = millisBetween start now, + errorMessage = abortText + } + -- The consumer stopped before the terminal event, so no adapter + -- ever handed evidence back and this layer has to build it. The + -- status is 'CallAborted' rather than 'CallFailed': an abort is + -- the consumer's doing, and reporting it as a provider failure + -- would misattribute it. The digests are over + -- 'Build.dispatchEnvelope' — see its documentation for what that + -- does and does not commit to. + mev <- + Build.minimalEvidence + m + opts + (Build.transportForModel m) + noThinkingRequested + (Build.dispatchEnvelope m opts) + start + now + Evidence.CallAborted + -- 'errorInfo' is 'Just' whenever the status is not + -- 'CallSucceeded', so an abort needs one. Its category is + -- 'OtherError' rather than any provider-failure category, + -- because nothing about the provider went wrong: the consumer + -- stopped reading. The message says exactly that. + (Just (providerError abortText)) + pushEvidence s eid now m mev + writeChan (s ^. #chan) (Just aborted) + writeChan (s ^. #chan) Nothing + takeMVar (s ^. #done) + fatal <- reportSinkError s opts + releaseStableRoot s + pure fatal +-- | Push the 'CallEvidence' event for a call, when there is one. +-- +-- An absent evidence value means one of two things and this layer must +-- not try to tell them apart: the caller opted out, or a provider has +-- not been taught to build evidence. In both cases the correct +-- behaviour is identical — push nothing. Synthesising a record from +-- what this layer knows would reintroduce exactly the cost the opt-out +-- gate exists to remove on the first path, and would attribute a record +-- to a transport that did not make it on the second. +-- +-- The event's 'eventId' is the /trace/ identifier, the same one on this +-- call's @call_started@ and terminal lines, so all four kinds join. The +-- evidence's own @callId@ is a separate identifier in a separate +-- namespace and travels inside @data.evidence@; this event is what ties +-- the two together. +pushEvidence :: + TraceState -> Text -> UTCTime -> Model -> Maybe ModelCallEvidence -> IO () +pushEvidence s eid now m mev = + forM_ mev $ \ev -> + writeChan (s ^. #chan) $ + Just + CallEvidence + { eventId = eid, + timestamp = now, + provider = m ^. #provider, + model = m ^. #modelId, + evidence = ev + } + releaseStableRoot :: TraceState -> IO () releaseStableRoot s = do msp <- atomicModifyIORef' (s ^. #stableRoot) (\sp -> (Nothing, sp)) forM_ msp freeStablePtr -reportSinkError :: TraceState -> IO () -reportSinkError s = do +-- | Report a sink failure on stderr, and say whether it must also fail +-- the call. +-- +-- The strictness comes from the caller's evidence request; a caller who +-- asked for no evidence is 'EvidenceBestEffort'. Both audiences are +-- served: the stderr line is for whoever is watching the process, and +-- the returned error is for the program. +reportSinkError :: TraceState -> Options -> IO (Maybe BaikaiError) +reportSinkError s opts = do merr <- readIORef (s ^. #sinkError) - forM_ merr $ \e -> - hPutStrLn - stderr - ("baikai: trace sink failed; trace events for this call were dropped: " <> displayException e) + case merr of + Nothing -> pure Nothing + Just e -> do + Build.onSinkFailure strictness e + pure + ( if Build.sinkFailureIsFatal strictness + then Just (Build.sinkFailureError e) + else Nothing + ) + where + strictness = strictnessOf opts +-- | The strictness a call was dispatched under. A call with no evidence +-- request is best-effort. +strictnessOf :: Options -> EvidenceStrictness +strictnessOf opts = + maybe EvidenceBestEffort (^. #strictness) (opts ^. #evidence) + traceEvent :: TraceState -> Text -> UTCTime -> Model -> + Options -> AssistantMessageEvent -> IO AssistantMessageEvent -traceEvent state eid start m ev = do +traceEvent state eid start m opts ev = do case ev of - EventDone TerminalPayload {message = msg} -> do + EventDone TerminalPayload {message = msg, evidence = mev} -> do now <- getCurrentTime let latency = millisBetween start now mu = assistantUsageFromMsg msg - meaningfulCost = maybe False (\u -> usdRat (Usage.cost u) > 0) mu finished = CallFinished { eventId = eid, @@ -270,15 +371,38 @@ latencyMs = latency, inputTokens = fmap Usage.inputTokens mu, outputTokens = fmap Usage.outputTokens mu, - usd = - if meaningfulCost - then fmap (usdAsScientific . Usage.cost) mu - else Nothing + -- Every count here is 'Just' exactly when the terminal + -- message carried a 'Usage' at all. A zero is reported + -- as zero, for the same reason the cost below is: an + -- absent field must mean "baikai has no usage for this + -- call", never "the count happened to be zero". + cachedInputTokens = fmap Usage.cacheReadTokens mu, + cacheWriteTokens = fmap Usage.cacheWriteTokens mu, + reasoningTokens = mu >>= Usage.reasoningTokens, + totalTokens = fmap Usage.totalTokens mu, + -- Report the computed cost whether or not it is zero. It + -- used to be suppressed at zero, which made a genuinely + -- free call indistinguishable from a call whose cost + -- baikai could not compute — and the subscription-based + -- CLI providers always compute zero, so that was the + -- common case rather than a corner. + usd = fmap (usdAsScientific . Usage.cost) mu } + -- Evidence goes out *before* the terminal, so a sink that keys + -- per-call state off the started/terminal pair still has the + -- call's state open when it arrives. The OpenTelemetry sink ends + -- and removes its span on the terminal, so the other order left + -- its evidence branch unreachable from a live stream. + pushEvidence state eid now m mev writeChan (state ^. #chan) (Just finished) writeIORef (state ^. #terminalSent) True - finalizeTrace state eid start m - EventError TerminalPayload {message = msg} -> do + fatal <- finalizeTrace state eid start m opts + -- A strict caller whose record did not survive gets a failed call + -- rather than an answer they cannot account for. This is the only + -- place in baikai where a call that reached the provider and came + -- back is nevertheless reported as failed. + pure (maybe ev (failTerminal ev) fatal) + EventError TerminalPayload {message = msg, evidence = mev} -> do now <- getCurrentTime let latency = millisBetween start now errMsg = case msg of @@ -293,12 +417,40 @@ latencyMs = latency, errorMessage = errMsg } + pushEvidence state eid now m mev writeChan (state ^. #chan) (Just failed) writeIORef (state ^. #terminalSent) True - finalizeTrace state eid start m - _ -> pure () - pure ev + -- Already an error: a sink failure on top changes nothing the + -- caller can act on, and overwriting the provider's own error with + -- baikai's would lose the more useful of the two. + _ <- finalizeTrace state eid start m opts + pure ev + _ -> pure ev +-- | Rewrite a successful terminal into a failed one carrying baikai's +-- own error, preserving everything else about it — including the +-- evidence, which is exactly what a caller investigating this failure +-- wants to read. +failTerminal :: AssistantMessageEvent -> BaikaiError -> AssistantMessageEvent +failTerminal ev be = case ev of + EventDone p -> + EventError + ( p + & #reason + .~ ErrorReason + & #errorInfo + .~ Just be + & #message + %~ markFailed + ) + other -> other + where + markFailed = \case + AssistantMessage p -> + AssistantMessage + (p & #stopReason .~ ErrorReason & #errorMessage .~ Just (be ^. #message)) + other -> other + -- ============================================================ -- Cost-log convenience wrapper -- ============================================================ @@ -331,7 +483,6 @@ resp <- withTraceWith reg sink m ctx opts now <- liftIO getCurrentTime let mu = assistantUsage resp - meaningfulCost = maybe False (\u -> usdRat (Usage.cost u) > 0) mu entry = CallLogEntry { timestamp = now, @@ -341,10 +492,11 @@ outputTokens = mu >>= positiveNat . Usage.outputTokens, cachedInputTokens = mu >>= positiveNat . Usage.cacheReadTokens, reasoningTokens = mu >>= Usage.reasoningTokens, - usd = - if meaningfulCost - then fmap (usdAsScientific . Usage.cost) mu - else Nothing, + -- Report a zero cost as zero. Suppressing it made "this + -- call was free" indistinguishable from "baikai could not + -- price this call", and the CLI providers always price at + -- zero. + usd = fmap (usdAsScientific . Usage.cost) mu, latencyMs = resp ^. #latencyMs, promptSummary = summarizeContext ctx } @@ -364,9 +516,6 @@ AssistantMessage AssistantPayload {usage = u} -> Just u _ -> Nothing -usdRat :: Cost.Cost -> Rational -usdRat = Cost.usd - positiveNat :: Natural -> Maybe Natural positiveNat 0 = Nothing positiveNat n = Just n @@ -381,27 +530,14 @@ -- Event id -- ============================================================ --- | Generate a 16-character lowercase hexadecimal event id. The high --- 32 bits are derived from process-start POSIX seconds and the low --- 32 bits are a process-local counter, so ids are unique within a --- process for 2^32 calls. +-- | Generate an identifier for one traced call. +-- +-- Delegates to 'newCallId'. The previous implementation combined the +-- process-start POSIX /second/ with a process-local counter and +-- produced 16 hexadecimal characters, which meant two processes +-- started within the same second emitted identical identifier +-- sequences. 'newCallId' produces 32 characters and is unique across +-- processes. newEventId :: IO Text -newEventId = do - n <- atomicModifyIORef' eventCounter (\k -> (k + 1, k)) - let raw :: Word64 - raw = - (fromIntegral eventBase .&. 0xFFFFFFFF) `unsafeShiftL` 32 - .|. (fromIntegral n .&. 0xFFFFFFFF) - hex = showHex raw "" - padded = replicate (16 - length hex) '0' <> hex - pure (Text.pack padded) - -eventCounter :: IORef Word -eventCounter = unsafePerformIO (newIORef 0) -{-# NOINLINE eventCounter #-} - -eventBase :: Word -eventBase = unsafePerformIO $ do - t <- getPOSIXTime - pure (fromIntegral (floor t :: Integer)) -{-# NOINLINE eventBase #-} +newEventId = newCallId +{-# DEPRECATED newEventId "Use Baikai.Evidence.newCallId; newEventId's ids were only unique within one process." #-} diff --git a/src/Baikai/Trace/Event.hs b/src/Baikai/Trace/Event.hs --- a/src/Baikai/Trace/Event.hs +++ b/src/Baikai/Trace/Event.hs @@ -1,27 +1,32 @@ +{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -Wno-partial-fields #-} -- | The 'TraceEvent' sum and its JSON encoding. -- --- A trace event is one of three discriminated cases: 'CallStarted' fires +-- A trace event is one of four discriminated cases: 'CallStarted' fires -- when a provider call begins, 'CallFinished' when it returns a response, --- and 'CallFailed' when it throws. The 'sumEncoding' tag field is @kind@, --- so a JSON-Lines stream of these can be filtered with --- @jq 'select(.kind == "call_finished")'@. +-- 'CallFailed' when it throws, and 'CallEvidence' carries the full +-- 'ModelCallEvidence' record for callers who asked for one. The +-- 'sumEncoding' tag field is @kind@, so a JSON-Lines stream of these can +-- be filtered with @jq 'select(.kind == "call_finished")'@. module Baikai.Trace.Event ( TraceEvent (..), traceEventOptions, ) where +import Baikai.Evidence (ModelCallEvidence) import Data.Aeson ( FromJSON (parseJSON), Options (..), SumEncoding (..), ToJSON (..), defaultOptions, - genericParseJSON, genericToEncoding, genericToJSON, + withObject, + (.:), + (.:?), ) import Data.Char (toLower) import Data.Scientific (Scientific) @@ -33,10 +38,17 @@ -- | One observable event from a provider call. -- -- Every event carries an 'eventId' that correlates the @started@ event --- with its matching @finished@ or @failed@ event within a single process --- run. Token counts and dollar cost are 'Maybe' because subscription-based +-- with its matching @finished@, @failed@, or @evidence@ event within a +-- single process run. Token counts are 'Maybe' because subscription-based -- providers (the CLIs) do not report them; 'omitNothingFields' keeps the -- absent fields out of the rendered JSON. +-- +-- 'usd' is deliberately /not/ 'Maybe'-shaped as an "unknown" marker: it +-- was until this release, and a computed cost of zero was suppressed, so +-- a genuinely free call and a call whose cost baikai could not compute +-- looked identical in a trace. The field is still 'Maybe' because a +-- non-assistant terminal has no usage at all, but a zero cost now +-- renders as @0@. data TraceEvent = CallStarted { eventId :: !Text, @@ -54,6 +66,14 @@ latencyMs :: !Int, inputTokens :: !(Maybe Natural), outputTokens :: !(Maybe Natural), + -- | Cache-read, cache-write, reasoning, and total token counts. + -- 'Baikai.Cost.Log.CallLogEntry' has always kept the first and + -- the third; a trace that dropped them was strictly less + -- faithful than the cost log built from the same 'Usage' value. + cachedInputTokens :: !(Maybe Natural), + cacheWriteTokens :: !(Maybe Natural), + reasoningTokens :: !(Maybe Natural), + totalTokens :: !(Maybe Natural), usd :: !(Maybe Scientific) } | CallFailed @@ -64,13 +84,37 @@ latencyMs :: !Int, errorMessage :: !Text } + | -- | The complete evidence record for one terminal provider call. + -- + -- Emitted exactly once per call, immediately after the matching + -- 'CallFinished' or 'CallFailed', and only when the caller set + -- 'Baikai.Options.evidence' and the provider built a record. A + -- consumer that wants only evidence can filter on this kind alone, + -- and a consumer written before this constructor existed is + -- unaffected as long as its pattern match is not exhaustive over + -- the sum. + CallEvidence + { eventId :: !Text, + timestamp :: !UTCTime, + provider :: !Text, + model :: !Text, + evidence :: !ModelCallEvidence + } deriving stock (Eq, Show, Generic) --- | Aeson options shared by 'ToJSON' and 'FromJSON' instances. +-- | Aeson options used by the 'ToJSON' instance, and the shape the +-- hand-written 'FromJSON' instance parses. -- --- * Sum encoding: @{"kind":"","data":{...}}@. +-- * Sum encoding: a @kind@ discriminator alongside the constructor's +-- own fields. Every constructor here has named fields, and aeson's +-- 'TaggedObject' merges those into the tagged object rather than +-- nesting them, so a line reads +-- @{"kind":"call_finished","eventId":…,"latencyMs":…}@ and not +-- @{"kind":…,"data":{…}}@. The @contentsFieldName@ below would only +-- take effect for a positional constructor, of which there are none. +-- Filter with @jq 'select(.kind == "call_finished") | .latencyMs'@. -- * Constructor tags: snake-case (@call_started@, @call_finished@, --- @call_failed@). +-- @call_failed@, @call_evidence@). -- * Field labels: kept as-is (camelCase). -- * Nothing fields are dropped from the encoded JSON. traceEventOptions :: Options @@ -91,5 +135,53 @@ toJSON = genericToJSON traceEventOptions toEncoding = genericToEncoding traceEventOptions +-- | Written out rather than derived, and it decodes only the three +-- non-evidence cases. +-- +-- 'ModelCallEvidence' deliberately has no 'FromJSON' instance: it embeds +-- a 'Baikai.Cost.Cost' whose exact 'Rational' amounts encode through an +-- approximating 'Data.Scientific.Scientific', so a decoder would return +-- a different value than was encoded. Rather than manufacture that +-- fidelity, a @call_evidence@ line fails to parse with a message saying +-- to read it as a plain 'Data.Aeson.Value'. That is the honest +-- behaviour, and it is what a consumer wants anyway — the JSON, not a +-- Haskell mirror of it, is the contract other systems pin against. instance FromJSON TraceEvent where - parseJSON = genericParseJSON traceEventOptions + parseJSON = withObject "TraceEvent" $ \d -> do + kind <- d .: "kind" + case kind :: Text of + "call_started" -> + CallStarted + <$> d .: "eventId" + <*> d .: "timestamp" + <*> d .: "provider" + <*> d .: "model" + <*> d .: "maxTokens" + <*> d .: "promptSummary" + "call_finished" -> + CallFinished + <$> d .: "eventId" + <*> d .: "timestamp" + <*> d .: "provider" + <*> d .: "model" + <*> d .: "latencyMs" + <*> d .:? "inputTokens" + <*> d .:? "outputTokens" + <*> d .:? "cachedInputTokens" + <*> d .:? "cacheWriteTokens" + <*> d .:? "reasoningTokens" + <*> d .:? "totalTokens" + <*> d .:? "usd" + "call_failed" -> + CallFailed + <$> d .: "eventId" + <*> d .: "timestamp" + <*> d .: "provider" + <*> d .: "model" + <*> d .: "latencyMs" + <*> d .: "errorMessage" + "call_evidence" -> + fail + "TraceEvent: a call_evidence line carries a ModelCallEvidence, \ + \which has no faithful decoder; read it as a Data.Aeson.Value" + other -> fail ("TraceEvent: unknown kind " <> show other) diff --git a/src/Baikai/Trace/Sink.hs b/src/Baikai/Trace/Sink.hs --- a/src/Baikai/Trace/Sink.hs +++ b/src/Baikai/Trace/Sink.hs @@ -17,6 +17,7 @@ ) where +import Baikai.Evidence qualified as Evidence import Baikai.Trace.Event (TraceEvent (..)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BSL @@ -94,7 +95,34 @@ tshow latencyMs <> "ms:", errorMessage ] + -- One line, and deliberately not the whole record. A human-readable + -- sink is for watching calls go by; an evidence record is several + -- hundred bytes of structured detail meant to be read out of + -- 'fileSink' output by a machine. What belongs on a terminal is the + -- fact that evidence exists, which run and call it names, and how + -- much it proves. + CallEvidence {timestamp, provider, model, evidence} -> + Text.unwords + [ "[" <> fmtTime timestamp <> "]", + provider, + model, + "EVIDENCE", + evidenceSummary evidence + ] where tshow :: (Show a) => a -> Text tshow x = Text.pack (show x) fmtTime t = Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" t) + +-- | Read through a record pattern rather than bare selectors: +-- 'Evidence.ModelCallEvidence' and 'Evidence.EvidenceRequest' both +-- carry @runId@, so under @DuplicateRecordFields@ a bare +-- @Evidence.runId ev@ is an ambiguous occurrence. +evidenceSummary :: Evidence.ModelCallEvidence -> Text +evidenceSummary + Evidence.ModelCallEvidence {Evidence.runId, Evidence.callId, Evidence.strength} = + Text.unwords + [ "run=" <> runId, + "call=" <> callId, + "strength=" <> Text.pack (show strength) + ] diff --git a/test/AgentSpec.hs b/test/AgentSpec.hs new file mode 100644 --- /dev/null +++ b/test/AgentSpec.hs @@ -0,0 +1,255 @@ +module AgentSpec (tests) where + +import Baikai.Agent +import Baikai.Prelude +import Data.Text qualified as Text +import System.Exit (ExitCode (..)) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Agent" + [ requestDefaultTest, + canonicalRenderingTest, + ceilingAcceptanceTest, + ceilingRefusalTest, + multipleViolationTest, + emptyAllowedProvidersTest, + providerArgsCeilingTest, + violationRenderingTest, + capturedOutputTest, + failureRenderingTest, + resultConstructorTest + ] + +-- | A request built by the smart constructor must default every +-- optional field to the least-authority value. Asserting all of them +-- means a later plan adding a field has to decide its default +-- consciously rather than inherit an accident. +requestDefaultTest :: TestTree +requestDefaultTest = + testCase "agentRunRequest defaults to read-only, inherited output, and no limits" $ do + let req = agentRunRequest AgentClaude "/tmp/work" "do the thing" + req ^. #provider @?= AgentClaude + req ^. #prompt @?= "do the thing" + req ^. #workingDir @?= "/tmp/work" + req ^. #modelId @?= Nothing + req ^. #effort @?= Nothing + req ^. #extraDirs @?= [] + req ^. #safety . #capability @?= AgentReadOnly + req ^. #safety . #allowedTools @?= [] + req ^. #safety . #providerArgs @?= [] + req ^. #timeout @?= Nothing + req ^. #output @?= InheritOutput + req ^. #outputLimit @?= Nothing + req ^. #envPassthrough @?= [] + +canonicalRenderingTest :: TestTree +canonicalRenderingTest = + testCase "provider, capability, and output-mode names round-trip exactly" $ do + renderAgentProvider AgentClaude @?= "claude" + renderAgentProvider AgentCodex @?= "codex" + parseAgentProvider "claude" @?= Just AgentClaude + parseAgentProvider "codex" @?= Just AgentCodex + parseAgentProvider "Claude" @?= Nothing + parseAgentProvider "" @?= Nothing + + renderAgentCapability AgentReadOnly @?= "read-only" + renderAgentCapability AgentEditWorkspace @?= "edit-workspace" + renderAgentCapability AgentFullAccess @?= "full-access" + parseAgentCapability "read-only" @?= Just AgentReadOnly + parseAgentCapability "edit-workspace" @?= Just AgentEditWorkspace + parseAgentCapability "full-access" @?= Just AgentFullAccess + parseAgentCapability "Read-Only" @?= Nothing + parseAgentCapability "readonly" @?= Nothing + + renderAgentOutputMode InheritOutput @?= "inherit" + renderAgentOutputMode CaptureOutput @?= "capture" + renderAgentOutputMode TeeOutput @?= "tee" + parseAgentOutputMode "inherit" @?= Just InheritOutput + parseAgentOutputMode "capture" @?= Just CaptureOutput + parseAgentOutputMode "tee" @?= Just TeeOutput + parseAgentOutputMode "Tee" @?= Nothing + +-- | Accepting a request must return it byte-identical. The equality +-- assertion against the original value is what proves no clamping +-- happened. +ceilingAcceptanceTest :: TestTree +ceilingAcceptanceTest = + testCase "the default ceiling accepts read-only and edit-workspace unchanged" $ do + let readOnly = agentRunRequest AgentClaude "/tmp/work" "look around" + editing = readOnly & #safety .~ agentSafety AgentEditWorkspace + applyAgentCeiling defaultAgentCeiling readOnly @?= Right readOnly + applyAgentCeiling defaultAgentCeiling editing @?= Right editing + +ceilingRefusalTest :: TestTree +ceilingRefusalTest = + testCase "the ceiling refuses with the exact violation for each closed channel" $ do + let base = agentRunRequest AgentClaude "/tmp/work" "rewrite everything" + greedy = base & #safety .~ agentSafety AgentFullAccess + rawArgs = + base + & #safety + . #providerArgs + .~ ["--dangerously-skip-permissions", "--verbose"] + claudeOnly = defaultAgentCeiling & #allowedProviders .~ [AgentClaude] + codexRequest = agentRunRequest AgentCodex "/tmp/work" "rewrite everything" + applyAgentCeiling defaultAgentCeiling greedy + @?= Left [CapabilityExceeded AgentFullAccess AgentEditWorkspace] + applyAgentCeiling defaultAgentCeiling rawArgs + @?= Left + [ProviderArgsForbidden ["--dangerously-skip-permissions", "--verbose"]] + applyAgentCeiling claudeOnly codexRequest + @?= Left [ProviderForbidden AgentCodex [AgentClaude]] + +-- | Every violation is reported, not just the first one, so an +-- operator fixing a job description sees all of them in one run. +multipleViolationTest :: TestTree +multipleViolationTest = + testCase "a request that breaks three rules reports all three violations" $ do + let restrictive = + defaultAgentCeiling + & #maxCapability + .~ AgentReadOnly + & #allowProviderArgs + .~ False + & #allowedProviders + .~ [AgentClaude] + req = + agentRunRequest AgentCodex "/tmp/work" "rewrite everything" + & #safety + .~ ( agentSafety AgentFullAccess + & #providerArgs + .~ ["--dangerously-bypass-approvals-and-sandbox"] + ) + applyAgentCeiling restrictive req + @?= Left + [ ProviderForbidden AgentCodex [AgentClaude], + CapabilityExceeded AgentFullAccess AgentReadOnly, + ProviderArgsForbidden ["--dangerously-bypass-approvals-and-sandbox"] + ] + +-- | An empty permitted-provider list means no provider is permitted. +-- The opposite reading would be a security hole, so it is pinned. +emptyAllowedProvidersTest :: TestTree +emptyAllowedProvidersTest = + testCase "an empty allowedProviders list permits no provider" $ do + let closed = defaultAgentCeiling & #allowedProviders .~ [] + claudeRequest = agentRunRequest AgentClaude "/tmp/work" "hello" + codexRequest = agentRunRequest AgentCodex "/tmp/work" "hello" + applyAgentCeiling closed claudeRequest + @?= Left [ProviderForbidden AgentClaude []] + applyAgentCeiling closed codexRequest + @?= Left [ProviderForbidden AgentCodex []] + +providerArgsCeilingTest :: TestTree +providerArgsCeilingTest = + testCase "raw provider arguments pass only when the operator opens the channel" $ do + let req = + agentRunRequest AgentClaude "/tmp/work" "hello" + & #safety + . #providerArgs + .~ ["--some-vendor-flag"] + permissive = defaultAgentCeiling & #allowProviderArgs .~ True + applyAgentCeiling defaultAgentCeiling req + @?= Left [ProviderArgsForbidden ["--some-vendor-flag"]] + applyAgentCeiling permissive req @?= Right req + +-- | Pin that both the requested and the permitted value appear, not +-- the exact sentence, so wording can improve without breaking tests. +violationRenderingTest :: TestTree +violationRenderingTest = + testCase "violation text names both the requested and the permitted value" $ do + let message = renderCeilingViolation (CapabilityExceeded AgentFullAccess AgentEditWorkspace) + assertBool + ("expected the requested capability in: " <> Text.unpack message) + ("full-access" `Text.isInfixOf` message) + assertBool + ("expected the permitted maximum in: " <> Text.unpack message) + ("edit-workspace" `Text.isInfixOf` message) + -- Raw provider arguments are the one part of a job description an + -- operator could write a credential into, so the refusal says how + -- many were requested and never what they were. Asserting the + -- absence is the point: a "helpful" edit that quoted them would + -- defeat the secret classification the configuration layer applies. + let argsMessage = + renderCeilingViolation (ProviderArgsForbidden ["--api-key", "sk-not-a-real-key"]) + assertBool + ("expected the count in: " <> Text.unpack argsMessage) + ("2" `Text.isInfixOf` argsMessage) + assertBool + ("expected no argument value in: " <> Text.unpack argsMessage) + (not ("sk-not-a-real-key" `Text.isInfixOf` argsMessage)) + let providerMessage = renderCeilingViolation (ProviderForbidden AgentCodex [AgentClaude]) + assertBool + ("expected both providers in: " <> Text.unpack providerMessage) + ("codex" `Text.isInfixOf` providerMessage && "claude" `Text.isInfixOf` providerMessage) + +capturedOutputTest :: TestTree +capturedOutputTest = + testCase "capturedBytes distinguishes uncaptured output from empty output" $ do + capturedBytes OutputNotCaptured @?= Nothing + capturedBytes (OutputCaptured "all of it") @?= Just "all of it" + capturedBytes (OutputTruncated "the first part") @?= Just "the first part" + capturedBytes (OutputCaptured "") @?= Just "" + +failureRenderingTest :: TestTree +failureRenderingTest = + testCase "every render error and run failure produces actionable text" $ do + let renderErrors = + [ UnsupportedCapability AgentCodex AgentFullAccess "the sandbox cannot be disabled here", + UnsupportedToolRestriction AgentCodex "codex exec has no tool allow-list flag", + SafetyNotExpressible AgentClaude "claude has no sandbox mode", + ProviderMismatch AgentClaude AgentCodex, + CeilingRejected [CapabilityExceeded AgentFullAccess AgentReadOnly] + ] + runFailures = + [ SpawnFailed "/usr/local/bin/claude" "no such file or directory", + RunTimedOut 90, + MissingEnvironment ["KEIRO_PATH", "ANTHROPIC_API_KEY"], + WorkingDirMissing "/tmp/gone", + OutputMalformed "expected JSON, got a banner" + ] + mapM_ + ( \e -> + assertBool + ("expected non-empty text for " <> show e) + (not (Text.null (renderAgentRenderError e))) + ) + renderErrors + mapM_ + ( \f -> + assertBool + ("expected non-empty text for " <> show f) + (not (Text.null (renderAgentRunFailure f))) + ) + runFailures + + let mismatch = renderAgentRenderError (ProviderMismatch AgentClaude AgentCodex) + assertBool + ("expected both providers in: " <> Text.unpack mismatch) + ("claude" `Text.isInfixOf` mismatch && "codex" `Text.isInfixOf` mismatch) + + let unsupported = + renderAgentRenderError + (UnsupportedCapability AgentCodex AgentFullAccess "the sandbox cannot be disabled here") + assertBool + ("expected the supplied explanation in: " <> Text.unpack unsupported) + ("the sandbox cannot be disabled here" `Text.isInfixOf` unsupported) + + let missing = renderAgentRunFailure (MissingEnvironment ["KEIRO_PATH", "ANTHROPIC_API_KEY"]) + assertBool + ("expected every missing variable in: " <> Text.unpack missing) + ("KEIRO_PATH" `Text.isInfixOf` missing && "ANTHROPIC_API_KEY" `Text.isInfixOf` missing) + +resultConstructorTest :: TestTree +resultConstructorTest = + testCase "agentRunResult records the process outcome and captures nothing" $ do + let result = agentRunResult AgentCodex (ExitFailure 3) 1.5 + result ^. #provider @?= AgentCodex + result ^. #exitCode @?= ExitFailure 3 + result ^. #duration @?= 1.5 + result ^. #stdout @?= OutputNotCaptured + result ^. #stderr @?= OutputNotCaptured diff --git a/test/CliInternalSpec.hs b/test/CliInternalSpec.hs --- a/test/CliInternalSpec.hs +++ b/test/CliInternalSpec.hs @@ -1,16 +1,50 @@ +-- | Tests for the helpers the two subprocess providers share. +-- +-- The two parser fixtures under @test/fixtures@ are trimmed recordings +-- of real output from @claude 2.1.222@ and @codex-cli 0.146.0@, +-- captured by running each tool once against a trivial prompt. They +-- keep the exact field spellings and nesting those versions emit; +-- identifiers are scrubbed and the local configuration the @claude@ +-- init event carries is dropped, because none of it is what the parsers +-- read. module CliInternalSpec (tests) where import Baikai import Baikai.Provider.Cli.Internal -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), (^.)) +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Char8 qualified as BS8 +import Data.Generics.Labels () +import Data.List (isInfixOf) +import Data.Text qualified as Text import Data.Vector qualified as Vector +import Streamly.Data.Stream qualified as Stream +import System.Directory (doesFileExist, getPermissions, setOwnerExecutable, setPermissions) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) tests :: TestTree tests = testGroup "CLI internal helpers" + [ promptTests, + codexParserTests, + claudeParserTests, + executableIdentityTests, + evidenceHelperTests + ] + +-- ============================================================ +-- Prompt rendering +-- ============================================================ + +promptTests :: TestTree +promptTests = + testGroup + "prompt rendering" [ testCase "renderPrompt returns a single user text message verbatim" $ do let ctx = emptyContext & #messages .~ Vector.singleton (user "hello") renderPrompt ctx @?= "hello", @@ -29,4 +63,270 @@ testCase "wrapSystemPrompt prefixes nonblank system instructions" $ wrapSystemPrompt (Just "Be terse.") "hi" @?= "System instructions:\nBe terse.\n\nUser request:\nhi" + ] + +-- ============================================================ +-- The codex event stream +-- ============================================================ + +parseCodex :: [ByteString] -> IO CodexRunReport +parseCodex = parseCodexJsonlStream . Stream.fromList + +codexParserTests :: TestTree +codexParserTests = + testGroup + "codex exec --json event stream" + [ testCase "a recorded run yields its text, thread id, and token counts" $ do + recorded <- BS.readFile "test/fixtures/codex-events.jsonl" + report <- parseCodex [recorded] + report ^. #message @?= "ok" + report ^. #threadId @?= Just "019fd471-4a48-7c83-be67-6b7c49646e43" + case report ^. #usage of + Nothing -> assertFailure "the turn.completed event reports usage" + Just u -> do + -- codex reports OpenAI-style inclusive prompt counts, so + -- the cached tokens come out of inputTokens: 16071 - 6912. + u ^. #inputTokens @?= 9159 + u ^. #cacheReadTokens @?= 6912 + u ^. #cacheWriteTokens @?= 0 + u ^. #outputTokens @?= 5 + u ^. #reasoningTokens @?= Just 0 + u ^. #totalTokens @?= 9159 + 5 + 6912, + -- codex-cli 0.146.0 names no model anywhere in its event stream. + -- Recording the model baikai passed on the command line would be + -- reporting the request as an observation. + testCase "a recorded run reports no model, rather than the requested one" $ do + recorded <- BS.readFile "test/fixtures/codex-events.jsonl" + report <- parseCodex [recorded] + report ^. #reportedModel @?= Nothing, + testCase "a model is read only from an event that also counts tokens" $ do + withModel <- + parseCodex + [ "{\"type\":\"turn.started\",\"model\":\"gpt-5.6-configured\"}\n\ + \{\"type\":\"turn.completed\",\"model\":\"gpt-5.6-ran\",\ + \\"usage\":{\"input_tokens\":10,\"output_tokens\":2}}\n" + ] + withModel ^. #reportedModel @?= Just "gpt-5.6-ran", + testCase "a stream with no thread and no usage reports absence, not zeroes" $ do + report <- + parseCodex + ["{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"hi\"}}\n"] + report ^. #message @?= "hi" + report ^. #threadId @?= Nothing + report ^. #usage @?= Nothing, + testCase "a non-JSON line is skipped rather than failing the run" $ do + report <- + parseCodex + [ "not json at all\n\ + \{\"type\":\"thread.started\",\"thread_id\":\"t-1\"}\n\ + \{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"hi\"}}\n" + ] + report ^. #message @?= "hi" + report ^. #threadId @?= Just "t-1", + testCase "the older msg-nested and flat event schemas still parse" $ do + nested <- + parseCodex + [ "{\"msg\":{\"type\":\"session.created\",\"session_id\":\"s-1\"}}\n\ + \{\"msg\":{\"type\":\"agent_message\",\"message\":\"nested\"}}\n" + ] + nested ^. #message @?= "nested" + nested ^. #threadId @?= Just "s-1" + flat <- parseCodex ["{\"type\":\"agent_message\",\"message\":\"flat\"}\n"] + flat ^. #message @?= "flat", + testCase "the first identifier wins and the last token count wins" $ do + report <- + parseCodex + [ "{\"type\":\"thread.started\",\"thread_id\":\"first\"}\n\ + \{\"type\":\"turn.completed\",\"usage\":{\"input_tokens\":1,\"output_tokens\":1}}\n\ + \{\"type\":\"thread.started\",\"thread_id\":\"second\"}\n\ + \{\"type\":\"turn.completed\",\"usage\":{\"input_tokens\":50,\"output_tokens\":7}}\n" + ] + report ^. #threadId @?= Just "first" + fmap (^. #outputTokens) (report ^. #usage) @?= Just 7, + testCase "a cached count larger than the prompt total clamps at zero" $ do + report <- + parseCodex + [ "{\"type\":\"turn.completed\",\ + \\"usage\":{\"input_tokens\":5,\"cached_input_tokens\":9,\"output_tokens\":1}}\n" + ] + fmap (^. #inputTokens) (report ^. #usage) @?= Just 0 + ] + +-- ============================================================ +-- The claude result document +-- ============================================================ + +claudeParserTests :: TestTree +claudeParserTests = + testGroup + "claude -p --output-format json result" + [ testCase "a recorded run yields its text, session id, model, usage, and cost" $ do + recorded <- BS.readFile "test/fixtures/claude-cli-result.json" + case decodeClaudeCliResult recorded of + Left err -> assertFailure ("expected the recording to decode: " <> show err) + Right r -> do + r ^. #result @?= "ok" + r ^. #isError @?= False + r ^. #sessionId @?= Just "01890000-0000-4000-8000-000000000001" + -- The context-window variant marker is kept: baikai can + -- request the 1m variant separately, so truncating it to + -- the canonical name would discard a real distinction. + r ^. #reportedModel @?= Just "claude-opus-5[1m]" + case r ^. #usage of + Nothing -> assertFailure "the result event reports usage" + Just u -> do + -- Anthropic's prompt classes are already disjoint, so + -- nothing is subtracted here. + u ^. #inputTokens @?= 2 + u ^. #outputTokens @?= 6 + u ^. #cacheReadTokens @?= 15185 + u ^. #cacheWriteTokens @?= 7455 + u ^. #totalTokens @?= 2 + 6 + 15185 + 7455 + -- The tool's total_cost_usd, carried exactly. Written + -- as a ratio rather than @toRational (0.0823025 :: + -- Double)@ because that would be the binary-float + -- approximation, and the whole reason 'Cost' holds a + -- 'Rational' is that it does not have to be. + (u ^. #cost) ^. #usd @?= 823025 / 10000000, + testCase "the older bare-object shape still decodes" $ + case decodeClaudeCliResult "{\"result\":\"pong\",\"is_error\":false}" of + Left err -> assertFailure ("expected a bare object to decode: " <> show err) + Right r -> do + r ^. #result @?= "pong" + r ^. #sessionId @?= Nothing + r ^. #reportedModel @?= Nothing + r ^. #usage @?= Nothing, + testCase "an error-shaped result keeps its session id" $ + case decodeClaudeCliResult + "{\"type\":\"result\",\"result\":\"boom\",\"is_error\":true,\"session_id\":\"s-9\"}" of + Left err -> assertFailure ("expected an error result to decode: " <> show err) + Right r -> do + r ^. #isError @?= True + r ^. #sessionId @?= Just "s-9", + -- Several models means several models ran, and evidence has one + -- observedModel slot. Picking one would fabricate specificity. + testCase "two modelUsage keys report no model rather than one of them" $ + case decodeClaudeCliResult + "{\"result\":\"ok\",\"is_error\":false,\ + \\"modelUsage\":{\"claude-opus-5\":{},\"claude-haiku-4-5\":{}}}" of + Left err -> assertFailure ("expected the document to decode: " <> show err) + Right r -> r ^. #reportedModel @?= Nothing, + testCase "a result event is found inside an array of events" $ + case decodeClaudeCliResult + "[{\"type\":\"system\"},{\"type\":\"result\",\"result\":\"found\",\"is_error\":false}]" of + Left err -> assertFailure ("expected the array to decode: " <> show err) + Right r -> r ^. #result @?= "found", + testCase "an array with no result event is a decode error" $ + case decodeClaudeCliResult "[{\"type\":\"system\"}]" of + Left _ -> pure () + Right r -> assertFailure ("expected a decode error, got: " <> show r), + testCase "malformed stdout is a decode error rather than an exception" $ + case decodeClaudeCliResult "not json" of + Left _ -> pure () + Right r -> assertFailure ("expected a decode error, got: " <> show r) + ] + +-- ============================================================ +-- Executable identity +-- ============================================================ + +-- | Write a shell script into a directory and make it executable. +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 + +executableIdentityTests :: TestTree +executableIdentityTests = + testGroup + "executable identity" + [ testCase "a resolvable tool reports its path and its --version line" $ + withSystemTempDirectory "baikai-cli-identity" $ \dir -> do + exe <- writeFakeExecutable dir "faketool" "#!/bin/sh\necho 'faketool 9.9.9'\n" + identity <- executableIdentity exe + identity ^. #configured @?= Text.pack exe + identity ^. #resolvedPath @?= Just (Text.pack exe) + identity ^. #version @?= Just "faketool 9.9.9", + testCase "a missing tool records absence rather than failing" $ + withSystemTempDirectory "baikai-cli-identity" $ \dir -> do + let absent = dir "not-installed" + identity <- executableIdentity absent + identity ^. #configured @?= Text.pack absent + identity ^. #resolvedPath @?= Nothing + identity ^. #version @?= Nothing, + testCase "a tool with no --version flag records absence rather than failing" $ + withSystemTempDirectory "baikai-cli-identity" $ \dir -> do + exe <- writeFakeExecutable dir "grumpy" "#!/bin/sh\necho 'unknown flag' >&2\nexit 2\n" + identity <- executableIdentity exe + identity ^. #resolvedPath @?= Just (Text.pack exe) + identity ^. #version @?= Nothing, + -- The whole reason for the cache: a version probe spawns a + -- process, and paying that per model call would roughly double + -- the process cost of the cheapest possible call. + -- + -- The assertion that carries the weight is that the second call + -- left the ledger untouched. Asserting "exactly one line" instead + -- would also fail when the first probe was killed by its own + -- timeout on a loaded machine, which says nothing about caching. + testCase "the version is probed once per executable, not once per call" $ + withSystemTempDirectory "baikai-cli-identity" $ \dir -> do + let ledger = dir "probes" + probeCount = length . lines <$> readFileIfPresent ledger + exe <- + writeFakeExecutable + dir + "counted" + ("#!/bin/sh\necho x >> '" <> ledger <> "'\necho 'counted 1.0'\n") + first <- executableIdentity exe + afterFirst <- probeCount + second <- executableIdentity exe + afterSecond <- probeCount + second @?= first + afterSecond @?= afterFirst + assertBool + ("the first call must probe at most once, saw " <> show afterFirst) + (afterFirst <= 1) + ] + +readFileIfPresent :: FilePath -> IO String +readFileIfPresent path = do + here <- doesFileExist path + if here then readFile path else pure "" + +-- ============================================================ +-- Evidence helpers +-- ============================================================ + +evidenceHelperTests :: TestTree +evidenceHelperTests = + testGroup + "evidence helpers" + [ testCase "strength rises only with what the tool reported" $ do + subprocessStrength (Observed "s-1") (Observed "m-1") @?= EvidenceModelObserved + subprocessStrength (Observed "s-1") Unobserved @?= EvidenceCorrelated + subprocessStrength Unobserved Unobserved @?= EvidenceRequestedOnly + -- A model without a correlation identifier cannot be located in + -- the vendor's records, so it does not reach 'correlated'. + subprocessStrength Unobserved (Observed "m-1") @?= EvidenceRequestedOnly, + -- The API transports spell their response envelope with these + -- three keys by hand. A verifier holding a response must be able + -- to recompute the digest without knowing which transport served + -- it, so the subprocess spelling has to agree. + testCase "the response envelope spells the same three keys the API transports do" $ do + let encoded = BS8.unpack (canonicalEncode (cliResponseEnvelope "pong" zeroUsage)) + mapM_ + (\k -> assertBool (k <> " must appear in the envelope") (k `isInfixOf` encoded)) + ["\"content\"", "\"stop_reason\"", "\"usage\""] + assertBool + "the assistant text must be committed to" + ("pong" `isInfixOf` encoded), + testCase "an argv envelope commits to the prompt and its projection keeps nothing" $ do + let argv = argvEnvelope "claude" ["-p", "--effort", "low", "--", "PROMPT-BODY-MARKER"] + assertBool + "the commitment input must contain the prompt" + ("PROMPT-BODY-MARKER" `isInfixOf` BS8.unpack (canonicalEncode argv)) + BS8.unpack (canonicalEncode (configurationProjection argv)) @?= "null" ] diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -12,6 +12,7 @@ withCallLog, ) import Baikai.Cost.Pricing (attachCost, computeCost) +import Baikai.Evidence (noThinkingRequested) import Baikai.Message (AssistantPayload (..), user) import Baikai.Model (Model (..), ModelCost (..), emptyModel) import Baikai.Options (Options, emptyOptions) @@ -142,7 +143,8 @@ provider = "claude-api", responseId = Nothing, latencyMs = 100, - errorInfo = Nothing + errorInfo = Nothing, + evidence = Nothing } -- Register a handler under a private API tag that returns a canned @@ -167,7 +169,8 @@ provider = "canned", responseId = Nothing, latencyMs = 7, - errorInfo = Nothing + errorInfo = Nothing, + evidence = Nothing } registerCanned :: Response -> IO () @@ -177,7 +180,8 @@ ApiProvider { apiTag = cannedApi, stream = liftCompleteToStream handler, - complete = handler + complete = handler, + describeThinking = \_ _ -> noThinkingRequested } cannedModel :: Model diff --git a/test/ErrorInfoSpec.hs b/test/ErrorInfoSpec.hs --- a/test/ErrorInfoSpec.hs +++ b/test/ErrorInfoSpec.hs @@ -37,6 +37,7 @@ term = errorTerminal Nothing + Nothing ErrorReason (AssistantMessage payload) (rateLimited (Just 5) "rate limited, slow down") @@ -53,7 +54,8 @@ ApiProvider { apiTag = errApi, stream = errStream, - complete = streamingComplete errStream + complete = streamingComplete errStream, + describeThinking = \_ _ -> noThinkingRequested } tests :: TestTree @@ -92,6 +94,7 @@ .~ Just "legacy unclassified failure" terminal = doneTerminal + Nothing Nothing ErrorReason (AssistantMessage payload) diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/EvidenceSpec.hs @@ -0,0 +1,344 @@ +-- | Tests for "Baikai.Evidence": that the canonical encoding really is +-- canonical, that the two digests differ in exactly the way they are +-- documented to, and that the configuration projection lets no content +-- through. +module EvidenceSpec (tests) where + +import Baikai.Evidence +import Baikai.Provider.Cli.Internal qualified as Internal +import Control.Concurrent (threadDelay) +import Control.Monad (replicateM) +import Data.Aeson (Value (Number, Object, String), object, (.=)) +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.Set qualified as Set +import Data.Text qualified as Text +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Evidence" + [ canonicalTests, + digestTests, + redactionTests, + observedTests, + callIdTests + ] + +-- ============================================================ +-- Canonical encoding +-- ============================================================ + +-- | The same logical object built by inserting keys in two different +-- orders. Built by folding inserts over two differently ordered lists +-- rather than with 'object', because aeson's 'KeyMap' may or may not +-- preserve insertion order depending on its size and build flags, and +-- the test must be meaningful either way. +canonicalTests :: TestTree +canonicalTests = + testGroup + "canonical encoding" + [ testCase "is stable across map insertion order" $ do + let values = map (Number . fromIntegral) [1 :: Int ..] + keys = ["zulu", "alpha", "mike", "bravo", "yankee", "charlie"] + pairs = zip keys values + forwards = fromPairs pairs + backwards = fromPairs (reverse pairs) + canonicalEncode forwards @?= canonicalEncode backwards + commitmentDigest forwards @?= commitmentDigest backwards, + testCase "sorts keys ascending and emits no whitespace" $ do + let v = fromPairs [("b", Number 2), ("a", Number 1)] + canonicalEncode v @?= BS8.pack "{\"a\":1,\"b\":2}", + testCase "nested objects are sorted too" $ do + let inner = fromPairs [("z", Number 1), ("y", Number 2)] + v = fromPairs [("outer", inner)] + canonicalEncode v @?= BS8.pack "{\"outer\":{\"y\":2,\"z\":1}}", + testCase "array order is preserved" $ + canonicalEncode (Aeson.toJSON [3 :: Int, 1, 2]) + @?= BS8.pack "[3,1,2]", + testCase "normalises integral and fractional number spellings" $ do + -- Every spelling on the left is the same mathematical value as + -- the one it is compared against; aeson parses them into + -- different Scientific values. + encodeJson "1" @?= "1" + encodeJson "1.0" @?= "1" + encodeJson "1.00" @?= "1" + encodeJson "1e0" @?= "1" + encodeJson "1e2" @?= "100" + encodeJson "0.1" @?= "0.1" + encodeJson "1e-1" @?= "0.1" + encodeJson "1.100" @?= "1.1" + encodeJson "-0.50" @?= "-0.5", + testCase "escapes only what JSON requires" $ do + canonicalEncode (String "a\"b\\c") @?= BS8.pack "\"a\\\"b\\\\c\"" + canonicalEncode (String "line\nbreak") @?= BS8.pack "\"line\\nbreak\"" + canonicalEncode (String "bell\a") @?= BS8.pack "\"bell\\u0007\"" + -- Non-ASCII travels as UTF-8, not as a \u escape. + canonicalEncode (String "\28450\23383") + @?= BS8.pack "\"\230\188\162\229\173\151\"" + ] + where + encodeJson :: String -> String + encodeJson src = case Aeson.decodeStrict (BS8.pack src) of + Just (v :: Value) -> BS8.unpack (canonicalEncode v) + Nothing -> " src <> ">" + +-- | Build an object by folding inserts in the given order, so that a +-- caller can control insertion history. 'Data.Aeson.object' would not +-- do: the point of the ordering test is that two different insertion +-- histories still encode identically. +fromPairs :: [(Text.Text, Value)] -> Value +fromPairs = Object . foldl' step KeyMap.empty + where + step acc (k, v) = KeyMap.insert (Key.fromText k) v acc + +-- ============================================================ +-- The two digests +-- ============================================================ + +digestTests :: TestTree +digestTests = + testGroup + "digests" + [ testCase "a digest is sha256: plus 64 lowercase hex characters" $ do + env <- loadFixture + let d = commitmentDigest env + assertBool ("expected a sha256: prefix, got " <> Text.unpack d) $ + "sha256:" `Text.isPrefixOf` d + Text.length (Text.drop 7 d) @?= 64 + assertBool + ("digest must be lowercase hex: " <> Text.unpack d) + (Text.all (`elem` ("0123456789abcdef" :: String)) (Text.drop 7 d)), + -- The golden values below pin the canonicalisation rule. If one + -- of these fails and the fixture has not changed, the encoding + -- changed, and every digest recorded by an earlier build has + -- become unverifiable. That is a major bump of + -- evidenceSchemaVersion, not a value to paste over. + testCase "the request commitment matches the golden value" $ do + env <- loadFixture + commitmentDigest env + @?= "sha256:ee1baf81dad750bb61bbcd6a737b8266c206a4288403510be5e10cace20b5798", + testCase "the configuration digest matches the golden value" $ do + env <- loadFixture + configurationDigest env + @?= "sha256:858f0d5ec35ba6f8bac39140c6523785abcbf4e8007c770c1ba2e13f0e72d6b5", + testCase "the configuration digest ignores content, the commitment does not" $ do + let ask subject = + object + [ "model" .= ("m" :: Text.Text), + "messages" + .= [ object + [ "role" .= ("user" :: Text.Text), + "content" .= (subject :: Text.Text) + ] + ] + ] + -- Same length on purpose: the projection keeps a character + -- count, so differing lengths would change the digest for + -- a reason unrelated to content. + q1 = ask "hello" + q2 = ask "world" + configurationDigest q1 @?= configurationDigest q2 + assertBool + "the commitment digest must distinguish different content" + (commitmentDigest q1 /= commitmentDigest q2), + testCase "the configuration digest still separates different configurations" $ do + let withModel m = object ["model" .= (m :: Text.Text)] + assertBool + "different models must produce different configuration digests" + (configurationDigest (withModel "a") /= configurationDigest (withModel "b")), + testCase "a non-object envelope projects to null" $ + configurationProjection (String "not an envelope") @?= Aeson.Null + ] + +-- ============================================================ +-- Redaction +-- ============================================================ + +-- | The four markers below are the API key, the prompt body, the +-- reasoning text, and a tool-call argument payload planted in the +-- fixture. The assertion is on the encoded bytes rather than on the +-- projected structure, because the claim being tested is that none of +-- them survives into the output no matter how it got there. +redactionTests :: TestTree +redactionTests = + testGroup + "redaction" + [ testCase "the configuration projection drops all content" $ do + env <- loadFixture + let encoded = BS8.unpack (canonicalEncode (configurationProjection env)) + mapM_ + ( \marker -> + assertBool + (marker <> " survived into the configuration projection: " <> encoded) + (not (marker `isInfix` encoded)) + ) + [ "sk-baikai-fixture-secret-key", + "PROMPT-BODY-MARKER", + "SYSTEM-PROMPT-BODY-MARKER", + "REASONING-TEXT-MARKER", + "TOOL-PAYLOAD-MARKER", + "Fetch a quarterly report by identifier." + ], + testCase "the projection keeps the configuration it is supposed to" $ do + env <- loadFixture + let encoded = BS8.unpack (canonicalEncode (configurationProjection env)) + mapM_ + ( \kept -> + assertBool + (kept <> " should have been kept, but was not: " <> encoded) + (kept `isInfix` encoded) + ) + [ "claude-opus-4-6", + "budget_tokens", + "max_tokens", + "temperature", + -- A tool's name is configuration; its description is not. + "fetch_report" + ], + testCase "the commitment digest does see the content" $ do + env <- loadFixture + let encoded = BS8.unpack (canonicalEncode env) + assertBool + "the commitment input must contain the prompt body" + ("PROMPT-BODY-MARKER" `isInfix` encoded), + -- The subprocess providers pass their rendered argument vector as + -- the request envelope, and both of them place the prompt inside + -- it. The commitment digest therefore covers the prompt, which is + -- correct; the configuration projection must not. + -- + -- It does not, for a structural reason worth stating: the + -- projection admits named fields from an object, and a JSON array + -- has none, so an argv envelope projects to @null@ wholesale. That + -- is the allow-list failing in the safe direction. + testCase "an argv envelope's configuration projection keeps nothing" $ do + let argv = Internal.argvEnvelope "codex" ["exec", "--model", "gpt-5.6", "--", "PROMPT-BODY-MARKER"] + projected = BS8.unpack (canonicalEncode (configurationProjection argv)) + committed = BS8.unpack (canonicalEncode argv) + projected @?= "null" + assertBool + "the commitment input must contain the argv prompt" + ("PROMPT-BODY-MARKER" `isInfix` committed) + assertBool + "the configuration projection must not contain the argv prompt" + (not ("PROMPT-BODY-MARKER" `isInfix` projected)) + ] + where + isInfix needle haystack = + Text.isInfixOf (Text.pack needle) (Text.pack haystack) + +-- ============================================================ +-- Observed +-- ============================================================ + +observedTests :: TestTree +observedTests = + testGroup + "observed" + [ testCase "encodes Unobserved as the string \"unobserved\"" $ + Aeson.toJSON (Unobserved :: Observed Text.Text) @?= String "unobserved", + testCase "encodes an observed value under an observed key" $ + Aeson.toJSON (Observed ("claude-opus-4-6" :: Text.Text)) + @?= object ["observed" .= ("claude-opus-4-6" :: Text.Text)], + testCase "round-trips through JSON in both directions" $ do + roundTrip (Observed ("m" :: Text.Text)) + roundTrip (Unobserved :: Observed Text.Text), + testCase "observedValue reports absence rather than defaulting" $ do + observedValue (Observed ("m" :: Text.Text)) @?= Just "m" + observedValue (Unobserved :: Observed Text.Text) @?= Nothing, + -- Strict evidence mode compares a record's strength against the + -- caller's requirement with (>=), so this ordering is load-bearing + -- rather than cosmetic. + testCase "evidence strength ascends in the order strict mode compares" $ do + let ascending = + [ EvidenceRequestedOnly, + EvidenceCorrelated, + EvidenceModelObserved, + EvidenceFullyObserved + ] + assertBool + "EvidenceStrength constructors must ascend as declared" + (and (zipWith (<) ascending (drop 1 ascending))), + testCase "noThinkingRequested records absence, not an unsupported level" $ do + requested noThinkingRequested @?= Nothing + mode noThinkingRequested @?= ThinkingModeAbsent + adjustments noThinkingRequested @?= [], + -- Destructured rather than accessed by selector: 'runId', + -- 'attempt', and 'supersedes' name a field on both + -- 'EvidenceRequest' and 'ModelCallEvidence', and under + -- DuplicateRecordFields a bare selector is ambiguous. Library + -- code reaches these through the generic-lens labels + -- (@r ^. #runId@) that the rest of this codebase uses. + testCase "evidenceRequest defaults to best effort, attempt one" $ + case evidenceRequest "run-42" of + EvidenceRequest + { runId = rid, + strictness = strict, + attempt = att, + supersedes = prev + } -> do + rid @?= "run-42" + strict @?= EvidenceBestEffort + att @?= 1 + prev @?= Nothing + ] + where + roundTrip :: Observed Text.Text -> IO () + roundTrip v = case Aeson.fromJSON (Aeson.toJSON v) of + Aeson.Success v' -> v' @?= v + Aeson.Error e -> assertFailure ("round trip failed: " <> e) + +-- ============================================================ +-- Identifiers +-- ============================================================ + +callIdTests :: TestTree +callIdTests = + testGroup + "call ids" + [ -- Generated in a tight loop, so most of these share a + -- millisecond. If the counter were dropped from the layout, this + -- would collapse to a handful of distinct values. + testCase "70000 ids generated back to back are all distinct" $ do + ids <- replicateM 70000 newCallId + length (nub' ids) @?= 70000, + testCase "an id is 32 lowercase hex characters" $ do + cid <- newCallId + Text.length cid @?= 32 + assertBool + ("expected lowercase hex, got " <> Text.unpack cid) + (Text.all (`elem` ("0123456789abcdef" :: String)) cid), + -- The millisecond prefix occupies the high bits, so ids minted + -- later never sort before ids minted earlier. + testCase "ids sort chronologically" $ do + earlier <- newCallId + threadDelay 2000 + later <- newCallId + assertBool + (Text.unpack earlier <> " should sort before " <> Text.unpack later) + (earlier < later) + ] + where + nub' = Set.toList . Set.fromList + +-- ============================================================ +-- Fixture loading +-- ============================================================ + +fixturePath :: FilePath +fixturePath = "test/fixtures/evidence-request.json" + +-- | The recorded request envelope both golden tests hash. It carries +-- an API key in a header-shaped field, a prompt body, reasoning text, +-- and a tool-call argument payload, so one fixture serves the digest +-- tests and the redaction tests. +loadFixture :: IO Value +loadFixture = do + raw <- Aeson.eitherDecodeFileStrict' fixturePath + case raw of + Left err -> assertFailure ("could not read " <> fixturePath <> ": " <> err) + Right v -> pure v diff --git a/test/HelpersSpec.hs b/test/HelpersSpec.hs --- a/test/HelpersSpec.hs +++ b/test/HelpersSpec.hs @@ -180,7 +180,8 @@ ApiProvider { apiTag = helpersApi, complete = scriptedComplete responsesRef callsRef, - stream = \_ _ _ -> Stream.fromList events + stream = \_ _ _ -> Stream.fromList events, + describeThinking = \_ _ -> noThinkingRequested } pure Scripted {scriptRegistry = reg, scriptCallRef = callsRef} @@ -206,7 +207,8 @@ ApiProvider { apiTag, complete = \model _ctx _opts -> pure (stampModel model resp), - stream = \_ _ _ -> Stream.fromList [] + stream = \_ _ _ -> Stream.fromList [], + describeThinking = \_ _ -> noThinkingRequested } oneShotProvider :: Api -> Text -> ApiProvider @@ -214,7 +216,8 @@ ApiProvider { apiTag, complete = \model _ctx _opts -> pure (stampModel model (textResponse body)), - stream = \_ _ _ -> Stream.fromList [] + stream = \_ _ _ -> Stream.fromList [], + describeThinking = \_ _ -> noThinkingRequested } errorProvider :: Api -> BaikaiError -> ApiProvider @@ -222,7 +225,8 @@ ApiProvider { apiTag, complete = \model _ctx _opts -> pure (errorResponse model epoch 0 err), - stream = \_ _ _ -> Stream.fromList [] + stream = \_ _ _ -> Stream.fromList [], + describeThinking = \_ _ -> noThinkingRequested } stampModel :: Model -> Response -> Response @@ -321,7 +325,7 @@ TextStart IndexPayload {contentIndex = 0}, TextDelta DeltaPayload {contentIndex = 0, delta = body}, TextEnd BlockEndPayload {contentIndex = 0, content = body}, - EventDone (doneTerminal (Just rid) Stop msg) + EventDone (doneTerminal Nothing (Just rid) Stop msg) ] withUnsetEnv :: String -> IO a -> IO a diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,7 @@ module Main (main) where import AgentAssetsSpec qualified +import AgentSpec qualified import Baikai import Baikai.Models.Generated import Baikai.Prelude @@ -16,12 +17,14 @@ import EmbeddingSpec qualified import ErrorInfoSpec qualified import ErrorSpec qualified +import EvidenceSpec qualified import FetchModelsSpec qualified import GenModelsSpec qualified import HelpersSpec qualified import InteractiveSpec qualified import StreamSpec qualified import Streamly.Data.Stream qualified as Stream +import StrictEvidenceSpec qualified import SurfaceSpec qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) @@ -78,7 +81,8 @@ in ApiProvider { apiTag = testApi, stream = liftCompleteToStream handler, - complete = handler + complete = handler, + describeThinking = \_ _ -> noThinkingRequested } main :: IO () @@ -89,6 +93,7 @@ "baikai" [ tests, AgentAssetsSpec.tests, + AgentSpec.tests, CatalogSpec.tests, CliInternalSpec.tests, ContextSpec.tests, @@ -96,11 +101,13 @@ EmbeddingSpec.tests, ErrorInfoSpec.tests, ErrorSpec.tests, + EvidenceSpec.tests, FetchModelsSpec.tests, GenModelsSpec.tests, HelpersSpec.tests, InteractiveSpec.tests, StreamSpec.tests, + StrictEvidenceSpec.tests, SurfaceSpec.tests, ThinkingLevelSpec.tests, TraceSpec.tests, diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs --- a/test/StreamSpec.hs +++ b/test/StreamSpec.hs @@ -71,7 +71,7 @@ doneEvent :: Maybe Text -> [AssistantContent] -> AssistantMessageEvent doneEvent rid blocks = - EventDone (doneTerminal rid Stop (assistantMessage blocks)) + EventDone (doneTerminal Nothing rid Stop (assistantMessage blocks)) signedThinking :: ThinkingContent signedThinking = diff --git a/test/StrictEvidenceSpec.hs b/test/StrictEvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/StrictEvidenceSpec.hs @@ -0,0 +1,436 @@ +-- | The pre-dispatch strictness gate. +-- +-- Strict evidence mode is the only place in baikai that refuses to make +-- a call the caller asked for, so these cases split cleanly in two. The +-- first half proves it refuses what it must: every place baikai weakens +-- a reasoning request, and every transport that cannot reach a demanded +-- strength. The second half proves it refuses nothing else — which is +-- the harder guarantee, because it is the one every existing caller +-- depends on without knowing the feature exists. +module StrictEvidenceSpec (tests) where + +import Baikai +import Control.Exception (evaluate, try) +import Control.Exception qualified as Exception +import Control.Lens ((&), (.~), (^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as Vector +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "StrictEvidenceSpec: pre-dispatch strict evidence" + [ declaredStrengthTests, + strengthGateTests, + downgradeGateTests, + bestEffortIsNeverRefusedTests, + lazinessTests, + dispatchTests + ] + +-- ============================================================ +-- Declared strength +-- ============================================================ + +declaredStrengthTests :: TestTree +declaredStrengthTests = + testGroup + -- Each of these is separately proved reachable by a test that drives + -- that transport to it: the Anthropic and OpenAI-compatible API + -- cases live in each vendor package's EvidenceSpec, and the two CLI + -- cases in its CliEvidenceSpec. This group pins the declarations + -- themselves so a change to one is a change someone had to mean. + "declared strength" + [ testCase "the two API transports declare model_observed" $ do + declaredStrength AnthropicMessages @?= EvidenceModelObserved + declaredStrength OpenAIChatCompletions @?= EvidenceModelObserved, + testCase "the claude CLI declares model_observed, the codex CLI correlated" $ do + -- Not symmetry: claude names the model that consumed tokens in + -- its result event, and codex-cli 0.146.0 names no model + -- anywhere in its event stream. + declaredStrength AnthropicMessagesCli @?= EvidenceModelObserved + declaredStrength OpenAICompletionsCli @?= EvidenceCorrelated, + testCase "a custom transport declares requested_only" $ + -- Baikai knows nothing about a caller-supplied transport and + -- must not assume on its behalf. + declaredStrength (Custom "someone-elses-gateway") @?= EvidenceRequestedOnly, + testCase "NO TRANSPORT DECLARES fully_observed" $ + -- Reaching it would need a provider that echoes the thinking + -- configuration it applied, and none of them does. A + -- reasoning-token count corroborates output volume and says + -- nothing about which effort setting was in force. + assertBool + "fully_observed must stay unreachable until a provider echoes its thinking config" + ( all + ((< EvidenceFullyObserved) . declaredStrength) + [ AnthropicMessages, + OpenAIChatCompletions, + AnthropicMessagesCli, + OpenAICompletionsCli, + Custom "x" + ] + ) + ] + +-- ============================================================ +-- The strength half of the gate +-- ============================================================ + +strengthGateTests :: TestTree +strengthGateTests = + testGroup + "a transport that cannot reach the required strength is refused" + [ testCase "a custom transport cannot supply model_observed" $ + case checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + (Custom "someone-elses-gateway") + noThinkingRequested of + [StrengthUnreachable needed declared] -> do + needed @?= EvidenceModelObserved + declared @?= EvidenceRequestedOnly + other -> assertFailure ("expected one StrengthUnreachable, got: " <> show other), + testCase "the codex CLI cannot supply model_observed, because it names no model" $ + case checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + OpenAICompletionsCli + noThinkingRequested of + [StrengthUnreachable _ declared] -> declared @?= EvidenceCorrelated + other -> assertFailure ("expected one StrengthUnreachable, got: " <> show other), + testCase "the codex CLI can supply correlated" $ + checkEvidenceRequirements + (EvidenceRequired EvidenceCorrelated) + OpenAICompletionsCli + noThinkingRequested + @?= [], + testCase "an exactly-met requirement is not a refusal" $ + -- The comparison is >=, not >. A transport that declares exactly + -- what was asked for satisfies it. + checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + AnthropicMessages + noThinkingRequested + @?= [], + testCase "both halves of the gate report together, not one per attempt" $ + -- An operator fixing a configuration should see all of it in one + -- run, which is what Baikai.Agent.applyAgentCeiling already does + -- for policy violations. + length + ( checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + (Custom "gateway") + (downgradedBy (EffortClamped ThinkingMax "high")) + ) + @?= 2 + ] + +-- ============================================================ +-- The downgrade half: one named case per site +-- ============================================================ + +-- | A translation carrying one adjustment, standing in for what a +-- provider's own translation function would produce at that site. The +-- provider-side proof that each site really produces its adjustment +-- lives in that provider's own test suite; this file proves the gate +-- refuses each one. +downgradedBy :: ThinkingAdjustment -> ThinkingTranslation +downgradedBy adjustment = + noThinkingRequested + & #requested .~ Just ThinkingMax + & #adjustments .~ [adjustment] + +-- | Assert the gate refuses this translation and names the adjustment. +refusesDowngrade :: String -> ThinkingAdjustment -> Text -> TestTree +refusesDowngrade name adjustment expectedPhrase = + testCase name $ + case checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + AnthropicMessages + (downgradedBy adjustment) of + [ThinkingWouldDowngrade [reported]] -> do + reported @?= adjustment + let message = renderEvidenceRefusal (ThinkingWouldDowngrade [adjustment]) + assertBool + ("the refusal must explain itself, got: " <> Text.unpack message) + (expectedPhrase `Text.isInfixOf` message) + other -> assertFailure ("expected one ThinkingWouldDowngrade, got: " <> show other) + +downgradeGateTests :: TestTree +downgradeGateTests = + testGroup + -- Six separate named cases rather than one parameterised test: when + -- one breaks later, its name should say which site regressed. + -- + -- The requirement used throughout is EvidenceRequestedOnly, the + -- weakest there is, so each case proves the downgrade alone refuses + -- rather than the strength check doing the work. + "every site where baikai weakens a thinking request refuses a strict call" + [ refusesDowngrade + "compatibleEffort clamps a level to a weaker word" + (EffortClamped ThinkingMax "high") + "would be sent as high", + refusesDowngrade + "a Z.ai or Qwen host collapses every level to a bare toggle" + (EffortCollapsedToToggle ThinkingMax) + "bare on/off toggle", + refusesDowngrade + "an adaptive high sends no effort field at all" + (EffortOmitted ThinkingHigh) + "indistinguishable on the wire", + refusesDowngrade + "a model that does not advertise reasoning drops the whole configuration" + (ThinkingDroppedUnsupportedModel ThinkingMax) + "does not advertise reasoning support", + refusesDowngrade + "a host with no reasoning controls drops the whole configuration" + (ThinkingDroppedUnsupportedHost ThinkingMax) + "exposes no reasoning controls", + refusesDowngrade + "a thinking budget that will not fit the output ceiling is discarded" + (ThinkingDroppedBudgetExceeded ThinkingMax 32000 8192) + "does not fit inside the resolved output ceiling", + testCase "several downgrades on one call are reported together" $ + case checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + AnthropicMessages + ( noThinkingRequested + & #requested .~ Just ThinkingMax + & #adjustments + .~ [EffortClamped ThinkingMax "high", EffortOmitted ThinkingMax] + ) of + [ThinkingWouldDowngrade reported] -> length reported @?= 2 + other -> assertFailure ("expected one ThinkingWouldDowngrade, got: " <> show other), + testCase "REQUESTING NO LEVEL IS NOT A DOWNGRADE" $ + -- The judgement that is not obvious. A caller who asked for + -- nothing has had nothing weakened, so a strict call that names + -- no thinking level must still run. + checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + AnthropicMessages + noThinkingRequested + @?= [], + testCase "a level expressed exactly is not a downgrade" $ + -- The native OpenAI shape sends every canonical level verbatim + -- and codex accepts all six. Refusing those would reject the + -- configurations that honour the caller in full. + checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + OpenAIChatCompletions + ( noThinkingRequested + & #requested .~ Just ThinkingXHigh + & #mode .~ ThinkingModeAdaptive + & #effortText .~ Just "xhigh" + ) + @?= [] + ] + +-- ============================================================ +-- The guarantee every existing caller depends on +-- ============================================================ + +bestEffortIsNeverRefusedTests :: TestTree +bestEffortIsNeverRefusedTests = + testGroup + -- Exhaustive rather than representative on purpose. This is the + -- "no existing caller is affected" promise, and a promise proved by + -- a sample is a promise about the sample. + "a best-effort caller is never refused, on any transport at any level" + [ testCase (Text.unpack (renderApi api) <> " / " <> label) $ + checkEvidenceRequirements EvidenceBestEffort api translation @?= [] + | api <- + [ AnthropicMessages, + OpenAIChatCompletions, + AnthropicMessagesCli, + OpenAICompletionsCli, + Custom "someone-elses-gateway" + ], + (label, translation) <- + ("no level requested", noThinkingRequested) + : [ ( Text.unpack (renderThinkingLevel lvl) <> " / " <> adjustmentName adjustment, + downgradedBy adjustment + ) + | lvl <- + [ ThinkingMinimal, + ThinkingLow, + ThinkingMedium, + ThinkingHigh, + ThinkingXHigh, + ThinkingMax + ], + adjustment <- + [ EffortClamped lvl "low", + EffortCollapsedToToggle lvl, + EffortOmitted lvl, + ThinkingDroppedUnsupportedModel lvl, + ThinkingDroppedUnsupportedHost lvl, + ThinkingDroppedBudgetExceeded lvl 32000 8192 + ] + ] + ] + +-- | A short name for one adjustment, so each case in the exhaustive +-- group above is separately identifiable when it fails. +adjustmentName :: ThinkingAdjustment -> String +adjustmentName = \case + EffortClamped {} -> "clamped" + EffortCollapsedToToggle {} -> "collapsed" + EffortOmitted {} -> "omitted" + ThinkingDroppedUnsupportedModel {} -> "dropped-model" + ThinkingDroppedUnsupportedHost {} -> "dropped-host" + ThinkingDroppedBudgetExceeded {} -> "dropped-budget" + +-- ============================================================ +-- The gate does no work on the default path +-- ============================================================ + +lazinessTests :: TestTree +lazinessTests = + testGroup + -- Computing a translation means a host-compatibility lookup and a + -- model-capability check. Doing that on every dispatch, for a + -- feature only strict callers use, would put the cost of strict mode + -- on the people who declined it. + "the gate never computes a translation it does not need" + [ testCase "A BEST-EFFORT CALL NEVER FORCES THE TRANSLATION" $ do + outcome <- + try (evaluate (length (checkEvidenceRequirements EvidenceBestEffort AnthropicMessages explodes))) + case outcome :: Either Exception.SomeException Int of + Right n -> n @?= 0 + Left e -> assertFailure ("the translation was forced: " <> show e), + testCase "a strict call does force it, so the test above means something" $ do + outcome <- + try + ( evaluate + ( length + ( checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + AnthropicMessages + explodes + ) + ) + ) + case outcome :: Either Exception.SomeException Int of + Right n -> assertFailure ("expected the translation to be forced, got " <> show n) + Left _ -> pure () + ] + where + explodes = error "the strictness gate forced a translation it should not have" + +-- ============================================================ +-- End to end through both dispatch points +-- ============================================================ + +dispatchTests :: TestTree +dispatchTests = + testGroup + "dispatch refuses before the provider runs" + [ testCase "THE REFUSAL ARRIVES WITHOUT THE PROVIDER BEING CALLED" $ do + -- The economic point of a pre-dispatch gate: a caller who cannot + -- get the evidence they require wants to know before paying. + -- The provider here throws if it is reached at all, so a + -- returned error-shaped response is proof it was not. + reg <- newProviderRegistry + registerApiProviderWith reg explodingProvider + resp <- completeRequestWith reg customModel testContext (strictly EvidenceModelObserved) + case responseError resp of + Nothing -> assertFailure "expected a refusal" + Just err -> do + err ^. #category @?= InvalidRequest + assertBool + ("the message names both strengths: " <> Text.unpack (err ^. #message)) + ( "model_observed" `Text.isInfixOf` (err ^. #message) + && "requested_only" `Text.isInfixOf` (err ^. #message) + ), + testCase "the streaming path refuses identically" $ do + reg <- newProviderRegistry + registerApiProviderWith reg explodingProvider + events <- + Stream.toList + (streamRequestWith reg customModel testContext (strictly EvidenceModelObserved)) + case events of + [EventStart _, EventError p] -> (p ^. #errorInfo) /= Nothing @?= True + other -> assertFailure ("expected a start and one terminal error, got: " <> show other), + testCase "a refused call still records the evidence explaining itself" $ do + -- A caller told their call was refused should be able to read + -- which requirement failed out of the record, not only out of + -- the message. + reg <- newProviderRegistry + registerApiProviderWith reg explodingProvider + resp <- completeRequestWith reg customModel testContext (strictly EvidenceModelObserved) + case resp ^. #evidence of + Nothing -> assertFailure "a strict caller opted into evidence and must get a record" + Just ev -> do + ev ^. #status @?= CallFailed + ev ^. #strength @?= EvidenceRequestedOnly, + testCase "a best-effort caller reaches the provider unchanged" $ do + -- Same registry, same model, same everything but the strictness. + reg <- newProviderRegistry + registerApiProviderWith reg countingProvider + resp <- completeRequestWith reg customModel testContext bestEffortOptions + responseError resp @?= Nothing + flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran", + testCase "a caller who asked for no evidence reaches the provider unchanged" $ do + reg <- newProviderRegistry + registerApiProviderWith reg countingProvider + resp <- completeRequestWith reg customModel testContext emptyOptions + responseError resp @?= Nothing + flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran" + ] + +-- ============================================================ +-- Fixtures +-- ============================================================ + +customApi :: Api +customApi = Custom "someone-elses-gateway" + +customModel :: Model +customModel = + emptyModel + & #modelId .~ "gateway-model" + & #api .~ customApi + & #provider .~ "someone-else" + +testContext :: Context +testContext = emptyContext & #messages .~ Vector.singleton (user "ping") + +strictly :: EvidenceStrength -> Options +strictly needed = + emptyOptions + & #evidence .~ Just (evidenceRequest "run-57" & #strictness .~ EvidenceRequired needed) + +bestEffortOptions :: Options +bestEffortOptions = emptyOptions & #evidence .~ Just (evidenceRequest "run-57") + +-- | A provider that fails loudly if it is reached. Used to prove the +-- gate refuses /before/ dispatch rather than annotating afterwards. +explodingProvider :: ApiProvider +explodingProvider = + ApiProvider + { apiTag = customApi, + stream = \_ _ _ -> error "the provider was dispatched despite a strict refusal", + complete = \_ _ _ -> error "the provider was dispatched despite a strict refusal", + describeThinking = \_ _ -> noThinkingRequested + } + +-- | The same shape, but it answers. +countingProvider :: ApiProvider +countingProvider = + ApiProvider + { apiTag = customApi, + stream = liftCompleteToStream handler, + complete = handler, + describeThinking = \_ _ -> noThinkingRequested + } + where + handler m _ _ = + pure + ( emptyResponse + & #model .~ m + & #message . #content + .~ Vector.singleton (AssistantText (TextContent "the provider ran")) + ) diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -1,27 +1,50 @@ +-- This module deliberately exercises 'newEventId', which is deprecated +-- in favour of 'Baikai.Evidence.newCallId'. The alias is still part of +-- the public surface, so it keeps a test; suppressing the warning here +-- is narrower than dropping the coverage. +{-# OPTIONS_GHC -Wno-deprecations #-} + module TraceSpec (tests) where import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext) import Baikai.Error (BaikaiError, providerError) +import Baikai.Evidence + ( ModelCallEvidence, + TransportKind (..), + evidenceRequest, + noThinkingRequested, + ) +import Baikai.Evidence qualified as Ev +import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), user) import Baikai.Model (Model (..), emptyModel) import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider (ApiProvider (..), registerApiProvider) -import Baikai.Response (Response (..)) +import Baikai.Response (Response (..), responseError) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) +import Baikai.Stream.Event (AssistantMessageEvent (..)) import Baikai.Trace (newEventId, withTrace, withTraceStream) import Baikai.Trace.Event (TraceEvent (..)) import Baikai.Trace.Sink (TraceSink (..), silent) -import Baikai.Usage (zeroUsage) +import Baikai.Usage (Usage, zeroUsage) import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) import Control.Exception (throwIO) import Control.Monad (replicateM) +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.Lazy.Char8 qualified as BL8 import Data.Set qualified as Set import Data.Text qualified as Text +import Data.Text.Encoding qualified as TextEncoding +import Data.Text.IO qualified as Text.IO +import Data.Time (UTCTime, getCurrentTime) import Data.Vector qualified as V import Streamly.Data.Fold qualified as Fold import Streamly.Data.Stream qualified as Stream @@ -39,7 +62,10 @@ memoryFailTest, throwingSinkTest, eventIdUniquenessTest, - earlyAbortTest + earlyAbortTest, + fidelityTest, + evidenceTests, + encodingTests ] -- | Each test uses its own private 'Api' tag so tasty's parallel @@ -79,7 +105,8 @@ provider = "stub.trace", responseId = Nothing, latencyMs = 0, - errorInfo = Nothing + errorInfo = Nothing, + evidence = Nothing } registerOk :: Api -> IO () @@ -89,7 +116,8 @@ ApiProvider { apiTag = a, stream = liftCompleteToStream handler, - complete = handler + complete = handler, + describeThinking = \_ _ -> noThinkingRequested } registerFail :: Api -> BaikaiError -> IO () @@ -99,7 +127,8 @@ ApiProvider { apiTag = a, stream = liftCompleteToStream handler, - complete = handler + complete = handler, + describeThinking = \_ _ -> noThinkingRequested } memorySink :: IO (TVar [TraceEvent], TraceSink) @@ -186,12 +215,19 @@ let AssistantPayload {stopReason = sr} = resp ^. #message sr @?= Stop +-- | The length assertion here used to read +-- @assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids)@. +-- It now reads 32, because 'newEventId' delegates to +-- 'Baikai.Evidence.newCallId', which carries 128 bits rather than 64. +-- The widening is the point of the replacement: the old generator +-- packed a process-start /second/ into its high half and so repeated +-- itself across processes started in the same second. eventIdUniquenessTest :: TestTree eventIdUniquenessTest = - testCase "newEventId yields 70000 distinct 16-char ids" $ do + testCase "newEventId yields 70000 distinct 32-char ids" $ do ids <- replicateM 70000 newEventId Set.size (Set.fromList ids) @?= 70000 - assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids) + assertBool "every id is 32 chars" (all ((== 32) . Text.length) ids) earlyAbortTest :: TestTree earlyAbortTest = @@ -225,3 +261,537 @@ if length evs >= n then pure (reverse evs) else threadDelay 50000 >> go (k - 1) + +-- ============================================================ +-- Usage and cost fidelity +-- ============================================================ + +-- | Usage with every disjoint token class populated, so a trace event +-- that drops one is visible rather than merely zero. +richUsage :: Usage +richUsage = + zeroUsage + & #inputTokens + .~ 11 + & #outputTokens + .~ 7 + & #cacheReadTokens + .~ 5 + & #cacheWriteTokens + .~ 3 + & #reasoningTokens + .~ Just 4 + & #totalTokens + .~ 26 + +registerWithUsage :: Api -> Usage -> IO () +registerWithUsage a u = + let resp = stubResponse a & #message . #usage .~ u + handler _m _ctx _opts = pure resp + in registerApiProvider + ApiProvider + { apiTag = a, + stream = liftCompleteToStream handler, + complete = handler, + describeThinking = \_ _ -> noThinkingRequested + } + +fidelityTest :: TestTree +fidelityTest = + testGroup + "CallFinished fidelity" + [ testCase "carries the full disjoint token breakdown" $ do + let a = Custom "baikai-trace-usage-fidelity" + registerWithUsage a richUsage + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext stubOptions + events <- reverse <$> readTVarIO ref + -- Read through record patterns, not '#field' labels: + -- generic-lens only resolves a label present on every + -- constructor of the sum, and these five are on 'CallFinished' + -- alone. + case [f | f@CallFinished {} <- events] of + [ CallFinished + { inputTokens, + outputTokens, + cachedInputTokens, + cacheWriteTokens, + reasoningTokens, + totalTokens + } + ] -> do + inputTokens @?= Just 11 + outputTokens @?= Just 7 + cachedInputTokens @?= Just 5 + cacheWriteTokens @?= Just 3 + reasoningTokens @?= Just 4 + totalTokens @?= Just 26 + other -> assertFailure ("expected one CallFinished, got: " <> show other), + -- A zero cost used to be suppressed, which made "this call was + -- free" indistinguishable from "baikai could not price this + -- call". The CLI providers always price at zero, so that was the + -- common case rather than a corner. + testCase "reports a zero cost as zero rather than omitting it" $ do + let a = Custom "baikai-trace-zero-cost" + registerOk a + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext stubOptions + events <- reverse <$> readTVarIO ref + case [f | f@CallFinished {} <- events] of + [f@CallFinished {usd}] -> do + usd @?= Just 0 + assertBool + "usd must be present in the encoded JSON, not dropped by omitNothingFields" + (KeyMap.member "usd" (asObject (Aeson.toJSON f))) + other -> assertFailure ("expected one CallFinished, got: " <> show other) + ] + +-- ============================================================ +-- Evidence emission +-- ============================================================ + +-- | The same options every other test in this module uses, plus an +-- evidence request. A call that emits no evidence cannot prove an +-- exactly-once guarantee about evidence, so every emission case below +-- opts in. +evidenceOptions :: Options +evidenceOptions = stubOptions & #evidence .~ Just (evidenceRequest "run-52") + +-- | A fixture provider that builds evidence the way a real adapter +-- does: it hands 'Build.minimalEvidence' the envelope it would have +-- sent and attaches the result to its 'Response', which +-- 'liftCompleteToStream' then carries onto the terminal event. +-- +-- 'registerOk' deliberately does not, because most of this module's +-- tests are about the trace path rather than the evidence path, and a +-- provider that builds no evidence is the honest model of one that has +-- not been taught to. +registerOkWithEvidence :: Api -> IO () +registerOkWithEvidence a = + let handler m _ctx opts = do + now <- getCurrentTime + ev <- + Build.minimalEvidence + m + opts + TransportHttpApi + noThinkingRequested + (Aeson.object ["model" Aeson..= (m ^. #modelId :: Text)]) + now + now + Ev.CallSucceeded + Nothing + pure (stubResponse a & #evidence .~ ev) + in registerApiProvider + ApiProvider + { apiTag = a, + stream = liftCompleteToStream handler, + complete = handler, + describeThinking = \_ _ -> noThinkingRequested + } + +evidencesIn :: [TraceEvent] -> [ModelCallEvidence] +evidencesIn events = [ev | CallEvidence {evidence = ev} <- events] + +asObject :: Value -> Aeson.Object +asObject = \case + Object o -> o + _ -> KeyMap.empty + +-- | Read one field out of an encoded evidence record. +-- +-- Deliberately through the JSON rather than through a Haskell record +-- pattern: the encoded form is the contract other systems pin against, +-- and it is the thing that must not drift. It also spells fields in +-- snake_case, which a Haskell mirror would silently paper over. +evidenceField :: Text -> ModelCallEvidence -> Maybe Value +evidenceField k ev = KeyMap.lookup (Key.fromText k) (asObject (Aeson.toJSON ev)) + +evidenceTests :: TestTree +evidenceTests = + testGroup + "model-call evidence" + [ successEvidenceTest, + failureEvidenceTest, + abortEvidenceTest, + noProviderEvidenceTest, + sinkFailureEvidenceTest, + strictSinkFailureTest, + strictSinkFailureIsStillOneTerminalTest, + optOutSilentTest, + optOutGoldenTest, + envelopeNotForcedTest + ] + +-- | Assert the shape every record this plan produces must have: the +-- channel works, and nothing was backfilled from the request. +assertMinimalShape :: ModelCallEvidence -> IO () +assertMinimalShape ev = do + evidenceField "schema_version" ev @?= Just (String Ev.evidenceSchemaVersion) + evidenceField "run_id" ev @?= Just (String "run-52") + evidenceField "requested_model" ev @?= Just (String "stub-1") + evidenceField "strength" ev @?= Just (String "requested_only") + evidenceField "observed_model" ev @?= Just (String "unobserved") + evidenceField "response_id" ev @?= Just (String "unobserved") + evidenceField "provider_request_id" ev @?= Just (String "unobserved") + assertDigest "request_commitment" ev + assertDigest "request_configuration" ev + where + assertDigest k e = case evidenceField k e of + Just (String d) -> + assertBool + (Text.unpack k <> " must be a sha256 digest, got: " <> show d) + ("sha256:" `Text.isPrefixOf` d && Text.length d == 71) + other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other) + +-- | Exactly one evidence record per call, joined to the rest of the +-- call's lines by the trace @eventId@. +exactlyOneEvidence :: [TraceEvent] -> IO ModelCallEvidence +exactlyOneEvidence events = case evidencesIn events of + [ev] -> do + let ids = Set.fromList [e ^. #eventId :: Text | e <- events] + Set.size ids @?= 1 + assertMinimalShape ev + pure ev + other -> + assertFailure + ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show events) + +successEvidenceTest :: TestTree +successEvidenceTest = + testCase "a successful call emits one evidence record with status succeeded" $ do + let a = Custom "baikai-evidence-success" + registerOkWithEvidence a + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext evidenceOptions + events <- reverse <$> readTVarIO ref + ev <- exactlyOneEvidence events + evidenceField "status" ev @?= Just (String "succeeded") + evidenceField "error_info" ev @?= Just Null + -- Purely additive: the pre-existing contract is untouched. + length [e | e@CallStarted {} <- events] @?= 1 + length [e | e@CallFinished {} <- events] @?= 1 + length [e | e@CallFailed {} <- events] @?= 0 + +failureEvidenceTest :: TestTree +failureEvidenceTest = + testCase "a failed call emits one evidence record with status failed" $ do + let a = Custom "baikai-evidence-failure" + registerFail a (providerError "stub-failure") + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext evidenceOptions + events <- reverse <$> readTVarIO ref + ev <- exactlyOneEvidence events + evidenceField "status" ev @?= Just (String "failed") + case evidenceField "error_info" ev of + Just (Object o) -> + assertBool + ("expected error_info to mention stub-failure, got: " <> show o) + (maybe False (Text.isInfixOf "stub-failure" . renderString) (KeyMap.lookup "message" o)) + other -> assertFailure ("expected a populated error_info, got: " <> show other) + length [e | e@CallStarted {} <- events] @?= 1 + length [e | e@CallFailed {} <- events] @?= 1 + where + renderString = \case + String t -> t + v -> Text.pack (show v) + +abortEvidenceTest :: TestTree +abortEvidenceTest = + testCase "an abandoned stream emits one evidence record with status aborted" $ do + let a = Custom "baikai-evidence-abort" + registerOk a + (ref, sink) <- memorySink + emitted <- + Stream.toList + (Stream.take 1 (withTraceStream sink (stubModel a) stubContext evidenceOptions)) + length emitted @?= 1 + events <- awaitEvents ref 3 + ev <- exactlyOneEvidence events + -- 'aborted', not 'failed'. The consumer stopped reading; reporting + -- that as a provider failure would misattribute it. + evidenceField "status" ev @?= Just (String "aborted") + +noProviderEvidenceTest :: TestTree +noProviderEvidenceTest = + testCase "an unregistered provider emits one evidence record with status failed" $ do + let a = Custom "baikai-evidence-no-provider" + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext evidenceOptions + events <- reverse <$> readTVarIO ref + ev <- exactlyOneEvidence events + evidenceField "status" ev @?= Just (String "failed") + +sinkFailureEvidenceTest :: TestTree +sinkFailureEvidenceTest = + testCase "a throwing sink does not fail an opted-in best-effort call" $ do + let a = Custom "baikai-evidence-throwing-sink" + registerOk a + result <- + timeout 5000000 (withTrace throwingSink (stubModel a) stubContext evidenceOptions) + case result of + Nothing -> assertFailure "withTrace hung on a throwing sink" + Just resp -> do + -- Unchanged, and it is the guarantee every existing caller + -- depends on: the exception does not propagate and the call + -- succeeds. Only a strict caller gets the opposite; see + -- 'strictSinkFailureTest' below. + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + +-- | The one place in baikai where a call that reached the provider and +-- came back is nevertheless reported as failed. +strictSinkFailureTest :: TestTree +strictSinkFailureTest = + testCase "A STRICT CALL WHOSE SINK THREW FAILS, RATHER THAN SUCCEEDING SILENTLY" $ do + -- A strict caller asked for a record of this call and the record did + -- not survive. Handing them the answer anyway would give them + -- something they cannot account for, with no way to notice: evidence + -- that can vanish without the caller noticing is not evidence. + let a = Custom "baikai-evidence-strict-throwing-sink" + registerOk a + result <- + timeout 5000000 (withTrace throwingSink (stubModel a) stubContext strictOptions) + case result of + Nothing -> assertFailure "withTrace hung on a throwing sink" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= ErrorReason + case responseError resp of + Nothing -> assertFailure "expected the sink failure to reach the response" + Just be -> + assertBool + ("the error names the sink: " <> Text.unpack (be ^. #message)) + ("trace sink failed" `Text.isInfixOf` (be ^. #message)) + +-- | The exactly-once guarantee still holds when the terminal is +-- rewritten. +strictSinkFailureIsStillOneTerminalTest :: TestTree +strictSinkFailureIsStillOneTerminalTest = + testCase "a rewritten terminal is still exactly one terminal event" $ do + let a = Custom "baikai-evidence-strict-sink-terminal" + -- The evidence-building fixture, so the "survives the rewrite" + -- assertion below has something to survive. + registerOkWithEvidence a + events <- + Stream.toList (withTraceStream throwingSink (stubModel a) stubContext strictOptions) + length [e | e@(EventDone _) <- events] @?= 0 + length [e | e@(EventError _) <- events] @?= 1 + -- The evidence the provider built survives the rewrite. It is + -- exactly what a caller investigating this failure wants to read. + case [p | EventError p <- events] of + [p] -> assertBool "the evidence survives" (p ^. #evidence /= Nothing) + other -> assertFailure ("expected one terminal, got: " <> show (length other)) + +strictOptions :: Options +strictOptions = + stubOptions + & #evidence + .~ Just + ( evidenceRequest "run-57" + & #strictness + .~ Ev.EvidenceRequired Ev.EvidenceRequestedOnly + ) + +-- | The criterion that protects every existing user of this library. +optOutSilentTest :: TestTree +optOutSilentTest = + testCase "a call with no evidence request emits no evidence and traces identically" $ do + let a = Custom "baikai-evidence-opt-out" + registerOkWithEvidence a + (outRef, outSink) <- memorySink + _ <- withTrace outSink (stubModel a) stubContext stubOptions + optedOut <- reverse <$> readTVarIO outRef + (inRef, inSink) <- memorySink + _ <- withTrace inSink (stubModel a) stubContext evidenceOptions + optedIn <- reverse <$> readTVarIO inRef + evidencesIn optedOut @?= [] + length (evidencesIn optedIn) @?= 1 + -- Asking for evidence adds an event and changes nothing else. + map redact optedOut @?= map redact [e | e <- optedIn, notEvidence e] + where + notEvidence = \case + CallEvidence {} -> False + _ -> True + +-- | Encode an event the way a sink does, then blank the fields that +-- legitimately differ between two runs of the same call. +-- +-- Deliberately textual rather than a rewrite of the decoded +-- 'Aeson.Value': 'Aeson.toJSON' produces a 'KeyMap' whose re-encoding +-- sorts keys, and field /order/ is part of what an existing consumer +-- sees. Comparing sorted objects would hide exactly the drift this is +-- here to catch. +-- +-- The three redacted values are a hex identifier, an ISO-8601 +-- timestamp, and an integer; none can contain a @,@ or @}@, so scanning +-- to the next one is a safe way to find the end of the value. +redact :: TraceEvent -> Text +redact = + redactField "latencyMs" "0" + . redactField "timestamp" "\"\"" + . redactField "eventId" "\"\"" + . TextEncoding.decodeUtf8 + . BL8.toStrict + . Aeson.encode + +redactField :: Text -> Text -> Text -> Text +redactField key replacement line + | Text.null rest = line + | otherwise = before <> needle <> replacement <> Text.dropWhile isValueChar after + where + needle = "\"" <> key <> "\":" + (before, rest) = Text.breakOn needle line + after = Text.drop (Text.length needle) rest + isValueChar c = c /= ',' && c /= '}' + +-- | The golden fixture is the encoded event sequence an opted-out call +-- produces, recorded against +-- @baikai\/test\/fixtures\/trace-opt-out.jsonl@. +-- +-- Its content was checked against the pre-plan code rather than +-- asserted from memory: the same fixture provider was run at commit +-- @0acbad8@ (the last commit before this plan touched the trace path) +-- and the two @call_started@ lines match exactly, while @call_finished@ +-- differs only by the four token fields and the @usd@ field this plan +-- deliberately added. Nothing else moved, and no @call_evidence@ line +-- appears. +-- +-- If this test fails, an opted-out caller's trace output changed. That +-- is a breaking change for every existing user of this library and +-- needs a changelog entry, not a new fixture pasted over the old one. +optOutGoldenTest :: TestTree +optOutGoldenTest = + testCase "an opted-out call's trace bytes match the golden fixture" $ do + let a = Custom "baikai-evidence-golden" + registerOk a + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext stubOptions + events <- reverse <$> readTVarIO ref + expected <- Text.lines <$> Text.IO.readFile "test/fixtures/trace-opt-out.jsonl" + map redact events @?= filter (not . Text.null) expected + +-- | An opted-out call must do no work, not merely produce no output. +-- +-- The fixture provider hands 'Build.minimalEvidence' an envelope that +-- throws when forced. If someone later adds a strictness annotation to +-- that parameter, or moves the opt-out check below the digest +-- computation, this test fails and says why. +envelopeNotForcedTest :: TestTree +envelopeNotForcedTest = + testCase "an opted-out call never forces the request envelope" $ do + let a = Custom "baikai-evidence-lazy-envelope" + handler m _ctx opts = do + now <- getCurrentTime + ev <- + Build.minimalEvidence + m + opts + TransportHttpApi + noThinkingRequested + (error "envelope forced on the opt-out path") + now + now + Ev.CallSucceeded + Nothing + pure (stubResponse a & #evidence .~ ev) + registerApiProvider + ApiProvider + { apiTag = a, + stream = liftCompleteToStream handler, + complete = handler, + describeThinking = \_ _ -> noThinkingRequested + } + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext stubOptions + events <- reverse <$> readTVarIO ref + evidencesIn events @?= [] + +-- ============================================================ +-- Wire encoding +-- ============================================================ + +-- | 'FromJSON' is hand-written and therefore can drift from the derived +-- 'ToJSON' without the compiler noticing. It already did once during +-- this plan: the decoder read a nested @data@ object, which aeson's +-- 'TaggedObject' does not produce for a record constructor, so it could +-- not have parsed a single line this package emits. +encodingTests :: TestTree +encodingTests = + testGroup + "TraceEvent JSON" + [ testCase "the three decodable kinds round-trip" $ + mapM_ roundTrip [sampleStarted, sampleFinished, sampleFailed], + -- A trace line carries its fields alongside the discriminator, + -- not nested under one. Consumers filter on this shape. + testCase "fields sit alongside the kind discriminator" $ do + let o = asObject (Aeson.toJSON sampleFinished) + KeyMap.lookup "kind" o @?= Just (String "call_finished") + KeyMap.lookup "latencyMs" o @?= Just (Number 12) + assertBool "no data wrapper" (not (KeyMap.member "data" o)), + -- Not a limitation to route around: 'ModelCallEvidence' embeds a + -- cost whose exact Rational cannot survive the Scientific it + -- encodes through, so a decoder would return a different value + -- than was encoded. Failing loudly beats claiming a fidelity the + -- type does not have. + testCase "a call_evidence line refuses to decode, with an explanation" $ do + let a = Custom "baikai-evidence-decode" + registerOkWithEvidence a + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext evidenceOptions + events <- reverse <$> readTVarIO ref + case [e | e@CallEvidence {} <- events] of + [e] -> case Aeson.eitherDecode (Aeson.encode e) :: Either String TraceEvent of + Right decoded -> assertFailure ("expected a decode failure, got: " <> show decoded) + Left err -> + assertBool + ("expected the message to point at Data.Aeson.Value, got: " <> err) + ("Data.Aeson.Value" `Text.isInfixOf` Text.pack err) + other -> assertFailure ("expected one CallEvidence, got: " <> show other) + ] + where + roundTrip e = case Aeson.eitherDecode (Aeson.encode e) of + Right decoded -> decoded @?= e + Left err -> assertFailure ("failed to decode " <> show e <> ": " <> err) + +fixedTime :: UTCTime +fixedTime = read "2026-05-14 00:00:00 UTC" + +sampleStarted :: TraceEvent +sampleStarted = + CallStarted + { eventId = "abc", + timestamp = fixedTime, + provider = "stub.trace", + model = "stub-1", + maxTokens = 16, + promptSummary = "hello" + } + +sampleFinished :: TraceEvent +sampleFinished = + CallFinished + { eventId = "abc", + timestamp = fixedTime, + provider = "stub.trace", + model = "stub-1", + latencyMs = 12, + inputTokens = Just 11, + outputTokens = Just 7, + cachedInputTokens = Just 5, + cacheWriteTokens = Just 3, + reasoningTokens = Just 4, + totalTokens = Just 26, + usd = Just 0 + } + +sampleFailed :: TraceEvent +sampleFailed = + CallFailed + { eventId = "abc", + timestamp = fixedTime, + provider = "stub.trace", + model = "stub-1", + latencyMs = 12, + errorMessage = "boom" + }