packages feed

baikai 0.4.1.0 → 0.7.0.0

raw patch · 72 files changed

Files

CHANGELOG.md view
@@ -7,6 +7,2105 @@  ## [Unreleased] +## [baikai 0.7.0.0] - 2026-09-08++### Added++- `BaikaiError.refusalCategory` preserves an Anthropic refusal's+  provider category. JSON adds `refusal_category`; older errors still decode.+  Evidence schema 2.5 records the addition without changing digest inputs.+  __Breaking__ to construct a `BaikaiError` from its full field list.++- `Speed`, `Options.speed`, catalog-owned fast rates and+  `computeCostAtSpeed`. Anthropic gates fast mode by model capability, adds the+  beta header and records unsupported drops. Terminal pricing uses observed+  speed, including cache duration; unreported speed is an explicit estimate.+  Older `Model` JSON defaults the new fields safely. __Breaking__: public+  records and sum types gain fields and constructors.++- API usage now records observed service tiers, inference speed and server-tool+  use in optional billing facts covered by evidence schema 2.2. Missing service+  information and uncurated products produce explicit standard-rate estimates.+  `computeCostForService` separates requested and observed service, while+  `computeCostAtRates` prices a resolved rate set once for future speed policies.+  Empty billing facts preserve legacy availability JSON; a CLI-reported zero+  cost retains its reported-total source. __Breaking__: the public vocabulary+  and records gain members.++- Failed trace terminals now retain partial response token counts, cost basis,+  usage availability and USD totals. Synthetic aborts leave unreported billing+  absent; legacy failed trace JSON still decodes. __Breaking__: `TraceEvent`'s+  `CallFailed` gains fields. See `baikai-trace-otel 0.4.0.1` for the export.++- Successful trace terminals and call-log records carry optional cost basis and+  usage availability; call logs also carry cache-write counts. Old JSON decodes+  with absent metadata and empty additive-zero bases stay omitted from traces.+  __Breaking__: `CallFinished` and the call-log record gain fields.++- Optional `Usage.availability` and shared inclusive/exclusive billing+  normalization, in the new `Baikai.Usage.Normalize`. OpenAI Chat/Responses and+  Claude preserve missing cache counters as explicit estimation reasons,+  distinguish reported zeroes, and merge cumulative usage without+  double-counting. Schema 2.2 commits provider availability while preserving+  legacy usage digests. __Breaking__: `Usage` gains a field.++- Optional `Model.pricingPolicy`, exact whole-request context tiers,+  and an explicit cache-duration rate resolver. Generated Astra pricing changes+  above 272000 input tokens; Fable exposes its one-hour write price. `Cost.basis`+  preserves calculation sources and estimation reasons when summed. Evidence+  schema 2.2 serializes the local basis without including local pricing metadata+  in provider commitments. __Breaking__: `Model` and `Cost` gain fields.++- Separate `OpenAIResponses` dispatch and compatibility types, and+  optional provider/model-scoped `ThinkingContent.replayState` with opaque+  diagnostic output and backward-compatible JSON decoding. Evidence schema 2.2+  includes replay state and optional billing facts in commitments while preserving+  legacy encodings when those fields are absent. __Breaking__ for a `case` over+  `Api` that is exhaustive without a wildcard.++- `Baikai.Evidence.ThinkingTranslation` gains `displayText` and+  `ThinkingAdjustment` gains `ThinkingSummaryUnavailable`, so a transport can+  record the thinking display setting it asked for and diagnose a successful+  response whose thinking blocks carry no readable summary. `Baikai.Compat`+  gains `supportsForcedToolChoice`; legacy JSON defaults it to True.+  __Breaking__ for an exhaustive `case` over `ThinkingAdjustment`.++- GPT-6 Astra and Claude Fable 5.1 catalog bindings, with verified+  pricing, token limits, and Anthropic thinking/sampling compatibility.++- Repository `update-models` skill for verifying provider releases and refreshing+  the curated JSON and generated Haskell catalog.++### Fixed++- Preserve OpenAI endpoint capability facts through catalog refreshes.++- Chat and Claude reject provider-scoped reasoning replay they cannot encode.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++## [baikai-claude 0.7.0.0] - 2026-09-08++### Changed++- Refusal messages include the reported category and explanation,+  retaining the original message when neither exists. Classification remains+  non-retryable `ContentFiltered`. Server-side fallbacks remain deliberately+  unsupported, as recorded in ADR 0005.++- Adaptive reasoning requests explicitly ask for summarized+  thinking. Evidence schema 2.4 records the display setting and diagnoses+  successful responses whose thinking blocks contain no readable summary.+  Budget and absent-thinking request shapes, signed empty blocks, redacted+  content and multi-turn replay are preserved.++- Fast mode is gated by the generated model capability: it adds the Anthropic+  beta header for a model that advertises it and records an evidence adjustment+  for one that does not.++### Fixed++- Price Fable cache writes using the TTL in the shaped request,+  including compatibility downgrades. Missing write-duration context is explicit+  in the cost basis.++- Reject forced tool choices locally on Fable 5.1, using the+  generated `supportsForcedToolChoice` capability. Automatic tool rounds retain+  signed empty/visible thinking, redacted blocks and prior-message order.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`.++## [baikai-openai 0.7.0.0] - 2026-09-08++### Added++- Explicit `Baikai.Provider.OpenAI.Responses` registration and+  stream/complete provider with stateless reasoning replay, function tool turns,+  structured output and bounded worker cleanup, across the new+  `Baikai.Provider.OpenAI.Responses.{Request,Stream,Assembler}` modules. Astra+  now selects this provider through a per-model catalog override; callers must+  register it explicitly. Cache writes, billing availability and context pricing+  are integrated.++- `Baikai.Provider.OpenAI.Internal.Usage`, the shared usage mapping both the+  Chat Completions and Responses transports read.++### Fixed++- Reject tools locally for models whose Chat Completions endpoint+  disallows them, including GPT-6 Astra. Respect generated effort policies and+  sampling restrictions, with matching translation evidence and strict refusal.++- Validate Responses terminals and enforce the stream contracts.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`.++## [baikai-trace-otel 0.4.0.1] - 2026-09-08++### Added++- Successful and failed spans export `baikai.cost.basis` and+  `baikai.usage.availability` as canonically encoded JSON. A failed span now+  also carries the input/output token counts and USD total that+  `baikai 0.7.0.0` retains on `CallFailed`, alongside its error status.++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`, and now depends on `aeson ^>=2.2` to encode the+  two new attributes.++## [baikai-effectful 0.4.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`. No API change.++## [baikai-kit 0.2.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`. No API change.++## [baikai-agent 0.2.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`, `baikai-claude ^>=0.7` and+  `baikai-openai ^>=0.7`. No API change.++## [baikai 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4. The 0.4 API retains the+  manager functions this package uses and belongs to the same TLS 2.x / Crypton+  1.1 dependency cohort as baikai 0.6; the old `^>=0.3` cap made baikai 0.6+  impossible to solve in applications that require Crypton 1.1.++## [baikai-claude 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4, allowing applications that+  require Crypton 1.1 to solve the dependency set.++## [baikai-openai 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4, allowing applications that+  require Crypton 1.1 to solve the dependency set.++## [baikai 0.6.0.0] - 2026-08-28++### Added++- `baikai`: `Baikai.ThinkingLevel.parseThinkingLevel :: Text -> Maybe+  ThinkingLevel` and `Baikai.Evidence.parseEvidenceStrength :: Text -> Maybe+  EvidenceStrength`, each beside its renderer. Three hand-copied tables — the+  evidence schema's level parser, `baikai-agent`'s KDL `effort` decoder, and its+  `--require-evidence` parser — now read them instead, so a level or strength+  added later cannot be added in one place and missed in three. (REV-2 G.6.)++- `baikai`: `Baikai.Agent.AgentRunResult` exports its selectors (`provider`,+  `exitCode`, `stdout`, `stderr`, `duration`). It exported neither them nor its+  constructor, so a consumer without generic-lens could not read a run's exit+  code at all. (REV-2 G.6.)++- `baikai`: `Baikai.Api.normaliseApi :: Api -> Api`, which collapses a `Custom`+  tag that spells a built-in API onto that constructor. The registry applies it+  to the key it stores and to the tag it is asked for, so a handler registered+  under `Custom "anthropic-messages"` answers a model tagged `AnthropicMessages`+  and the reverse; the two used to be separate entries and dispatch depended on+  which spelling the model happened to carry. Derived `Eq`/`Ord` on `Api` are+  deliberately unchanged: altering them would silently rearrange every+  `Map Api` a consumer holds. (REV-2 G.4.)++- `baikai`: `Baikai.Header`, a new module exporting `HeaderName` with+  `headerName` and `renderHeaderName`. See the `headers` retype under Changed.++- `baikai`: `Baikai.Error.ErrorCategory` gains `ContentFiltered` (wire tag+  `content_filtered`, never retryable) with the smart constructor+  `contentFiltered`. OpenAI's `finish_reason: "content_filter"` and Anthropic's+  `refusal` stop now carry it. Both used to be `OtherError`, so the only way to+  tell a filtered response from any other non-retryable failure was to match on+  the message text. __Breaking__ for a consumer whose `case` over+  `ErrorCategory` is exhaustive without a wildcard. (REV-1 1.7 residual.)++- `baikai` (breaking to construct, not to read): every record that can still+  grow a field is now built from an exported base value and refined by record+  update, and its constructor is no longer exported —+  `Baikai.Provider.Registry.ApiProvider` (`apiProvider` /`apiProviderWith`),+  `Baikai.Evidence.ModelCallEvidence` (`baseEvidence`),+  `Baikai.Evidence.EvidenceRequest` (`evidenceRequest`), `Baikai.Tool.Tool`+  (`mkTool`, with `emptyTool` kept for fixtures),+  `Baikai.Embedding.EmbeddingModel` (`emptyEmbeddingModel`),+  `Baikai.Cost.Log.CallLogConfig` (`callLogConfig`),+  `baikai-trace-otel`'s `OtelSinkOptions` (`defaultOtelSinkOptions`), and+  `baikai-agent`'s `AgentCliOptions` (`agentCliOptions`), `AgentCliRun`+  (`agentCliRun`), `AgentJob` (`agentJob`) and `AgentConfigPaths`+  (`emptyAgentConfigPaths`). Selectors, record update, `OverloadedRecordDot`+  reads and generic-lens labels all keep working; only construction from the+  constructor stops. Adding `describeThinking` to `ApiProvider` in 0.5.0.0 broke+  every third-party registration site, and `strengthCeiling` would have broken+  them again; from this release such an addition is a minor bump. (REV-2 G.1.)++- `baikai`: `Baikai.Provider.apiProvider`, which builds an `ApiProvider` from an+  `Api` tag and a streaming producer, deriving `complete` with+  `streamingComplete`; and `Baikai.Provider.Registry.apiProviderWith`, which+  takes the completer explicitly. Both default `describeThinking` to+  "nothing requested, nothing translated" and `strengthCeiling` to+  `EvidenceRequestedOnly`, matching `declaredStrength (Custom _)`.++- `baikai`: `Baikai.Tool.mkTool` — a tool from its name, description and JSON+  Schema. A tool built from `emptyTool` and sent unchanged reaches the wire with+  `input_schema: null`; `mkTool` has no such shape.++- `baikai`: `Baikai.Agent.AgentOutputFormat` (`TextFormat`, `JsonFormat`) with+  `renderAgentOutputFormat` and `parseAgentOutputFormat`, and+  `AgentRunRequest.outputFormat`, defaulting to `TextFormat`. `baikai-claude`+  renders `--output-format json` and `baikai-openai` renders `--json`, both+  right after the effort flags; `baikai-agent` reads it from+  `jobs.<name>.output-format`. This is the one setting an evidence record needs+  in order to observe a run's session, model and usage, and asking for it used+  to require the `provider-args` channel that an operator ceiling closes by+  default — an operator should not have to open a privileged channel to get a+  record. (REV-2 F.14.)++- `baikai`: `Baikai.Agent.AgentCeiling` gains three fields and the module gains+  the vocabulary they need. `allowedTools :: [Text]` names tool grants the+  operator permits beyond the ones `toolGrantsImpliedBy` (also new) says a+  capability implies on its own; `maxTimeout :: Maybe NominalDiffTime` and+  `maxOutputLimit :: Maybe Int` bound what any job may request, the second+  defaulting to the new `defaultMaxOutputLimit` (67108864, sixty-four+  mebibytes). `Baikai.Agent.ceilingViolations` is `applyAgentCeiling`'s violation+  list on its own, so a caller can concatenate it with violations of its own.+  (REV-2 F.3.)++- `baikai`: `Baikai.Content.toolArgumentsFromText` and+  `Baikai.Content.isCutOffToolCall`. The first is the single rule that turns a+  tool call's accumulated argument text into its `arguments` value — empty text+  is an empty object, non-empty text that does not decode is kept verbatim as a+  `String` — and both provider assemblers and core's stream-recovery path now+  use it, so the second means the same thing at every layer.++- `baikai`: new exposed module `Baikai.Provider.Internal.StreamWorker` — the+  bounded hand-off both HTTP providers now use between their SSE worker thread+  and the consumer draining the stream. `FrameQueue` is a 64-slot `TBQueue` plus+  a closed flag; `forkFrameWorker` closes the queue however the body ends, and+  `withFrameWorker` runs the consumer under `Stream.bracketIO` so the worker is+  killed when the stream stops. The module is exposed like+  `Baikai.Provider.Cli.Internal`, outside the PVP promise. See+  [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md).++- `baikai`: every Anthropic model in the generated catalog now carries an+  explicit `CompatAnthropicMessages` record stating the two request-shaping+  facts of its generation: `AnthropicMessagesCompat.thinkingStyle` (which+  extended-thinking wire shape it accepts) and the new+  `AnthropicMessagesCompat.supportsSamplingParameters` (whether it accepts+  `temperature`, `top_p` and `top_k`). Both are sourced from+  `baikai/data/models/anthropic.json`, which the fetcher writes from its+  curated `anthropicInclude` table, and `baikai-gen-models` now refuses an+  `anthropic-messages` entry that reaches it without a `compat` block rather+  than falling back to host auto-detection, which cannot know a generation.+  This is what fixes `claude-sonnet-5`, whose thinking requests were shaped by+  a prefix table that did not know the id. See+  [docs/adr/0009](docs/adr/0009-provider-capability-facts-live-in-the-generated-catalog-record.md).++- `baikai`: two new `Baikai.Evidence.ThinkingAdjustment` constructors,+  `SamplingDroppedUnsupportedModel` and `SamplingDroppedUnsupportedApi`, encoding as+  `{"kind":"sampling_dropped_unsupported_model","fields":["temperature","top_p"]}` and+  `{"kind":"sampling_dropped_unsupported_api","fields":["seed"]}`. They record sampling+  parameters removed because the model generation rejects them, or because the API has no+  such field on any generation. Both carry a `fields` array and no `requested` level, so+  they can appear on a call whose thinking mode is `absent`.++- `baikai`: `Baikai.Evidence.weakensThinking`, which says whether an adjustment weakens the+  thinking the caller asked for. Strict evidence mode filters through it, so a dropped+  sampling parameter is recorded without refusing the call — the documented contract is+  refusing a call that would weaken the requested *thinking level*.++- `baikai`: new exposed module `Baikai.Url` — the one place baikai turns a URL+  into a host name. `parseUrl` yields a `UrlParts` record with the scheme, host,+  port and path, plus flags saying whether userinfo, a query string or a+  fragment were present; it never holds their text, so the value cannot carry a+  secret into a log line. Alongside it: `urlHost`, `hostMatchesSuffix` (moved+  from `Baikai.Compat`, which now re-exports both), `renderEndpoint`,+  `stripApiVersion`, and `baseUrlProblem`, which says why a URL is unusable as a+  `Model.baseUrl` and what to do instead. See+  [docs/adr/0008](docs/adr/0008-one-url-host-parser-and-every-consumer-uses-it.md).++- `baikai`: new exposed module `Baikai.Provider.Transport.Classify` — the one+  rule every HTTP provider uses to classify a transport failure, exporting+  `classifyTransportException` plus the per-type functions it composes. The rule+  is *where* the failure happened, not what type it is: anything that breaks or+  ends the connection after the request went out is `TransientError`, anything+  that says the request or the configuration is wrong is not retryable, and a+  programming error stays `OtherError`. It understands all three shapes+  `http-client` can deliver — an `HttpException` of any constructor, a raw socket+  `IOException`, and a raw or wrapped `TLSException` — because the manager wraps+  the connect phase but not the body reader. Core gains direct `build-depends` on+  `http-types` and `tls`, both already in its install plan. Written for+  third-party `Custom` providers built on `http-client` as much as for baikai's+  own two. See+  [docs/adr/0011](docs/adr/0011-core-owns-transport-failure-classification.md).++- `baikai`: `Baikai.Error.parseHttpDate` and `Baikai.Error.retryAfterSecondsAt`.+  The first parses an HTTP-date in the IMF-fixdate form servers must send plus+  the two obsolete forms a recipient must accept; the second converts a+  `Retry-After` header in either of its forms to seconds against a reference+  instant, clamping a date already in the past to `0`.+  `parseRetryAfterSeconds` keeps its integer-only contract, now a deliberate+  division of labour rather than a limitation.++- `baikai`: new exposed module `Baikai.Http` — `canonicalBaseUrl`,+  `getClientEnvCached` and `cachedClientEnvCount`, the process-global+  `ClientEnv` cache that both HTTP provider packages now share instead of each+  keeping its own. Core gains direct `build-depends` on `servant-client`,+  `http-client` and `http-client-tls`, which were already in its install plan+  through the `openai` SDK.++- `baikai`: `Baikai.Evidence.ThinkingModeNotTranslated`, encoded as+  `"not_translated"`, and `Baikai.Evidence.untranslatedThinking`; and+  `Baikai.Evidence.Build.requestedTranslation`. A path where no adapter ran to+  translate the caller's level now records the level and says the translation is+  unknown, instead of saying nothing was asked. (REV-2 D.2.)++- `baikai`: `Baikai.Evidence.Build.missingEvidenceError`,+  `Baikai.Evidence.Build.strictnessOf` (moved here from `Baikai.Trace`, where it+  was private), `Baikai.Stream.requireEvidenceOnTerminal` and+  `Baikai.Provider.Registry.requireEvidenceOnResponse`. (REV-2 D.3.)++- `baikai`: `Baikai.Evidence.usageEnvelope`, and+  `Baikai.Evidence.Build.endpointIdentityAt`, `prepareEvidenceAt` and+  `minimalEvidenceAt`, which take the base URL the adapter actually resolved.+  The three unsuffixed functions remain and pass the model's own field.+  (REV-2 D.8, D.11.)++- `baikai`: `Baikai.Evidence.deriveStrength`, the single rule that turns an+  observed model, a provider request id and a response id into an+  `EvidenceStrength`. (REV-2 D.10.)++### Changed++- `baikai`: catalog refresh. `claude-opus-5` joins the curated Anthropic include+  set (adaptive thinking, sampling parameters rejected — the facts+  `docs/plans/60-make-anthropic-thinking-style-and-sampling-support-catalog-driven.md`+  said whoever curated it in would have to state), and the `gpt-5.6` family+  picks up its price cut: `gpt-5.6` and `gpt-5.6-sol` to $4.00/$20.00,+  `gpt-5.6-terra` to $2.00/$12.00, `gpt-5.6-luna` to $0.20/$1.20 per Mtok, cache+  rates in step. `Baikai.Models.Generated` gains `anthropic_claude_opus_5` and+  now carries 36 enabled models. No OpenAI id was added: the `gpt-5.6` family is+  still the newest one models.dev reports that speaks+  `openai-chat-completions`.++- `baikai` (breaking): `ResponseFormat`'s `JsonSchema` carries a+  `JsonSchemaFormat` record — `name`, `schema`, `strict`, exported+  selector-only with the base `jsonSchemaFormat name schema` — instead of+  holding the three fields directly. As fields of a sum they were partial+  selectors: `name f` on a `JsonObject` crashed at runtime rather than failing to+  typecheck, which contradicted the module's own documentation.+  `-Wno-partial-fields` is dropped from the module. The JSON encoding is+  deliberately unchanged (`{"tag":"JsonSchema","name":…,"schema":…,"strict":…}`)+  and is now pinned by a test, because `Options` derives `ToJSON` through it and+  at least one consumer keys a cache on the result. (REV-2 G.2.)++- `baikai`: `Baikai.Context.appendToolResult` returns its input context+  unchanged, and runs no dispatcher, when the response is error-shaped. A failed+  call has no assistant turn worth replaying and no tool calls to answer;+  appending its empty message put a turn into the transcript the model never+  took. `runToolLoop` has always stopped on such a response — the documented+  direct round trip in `docs/user/tools.md` reaches `appendToolResult` instead,+  and now behaves the same way. Its Haddock also stops claiming multi-call+  concurrency lives in the dispatcher: the calls are traversed in order.+  (REV-2 G.7.)++- Release metadata (REV-2 G.8): every publishable package now declares+  `tested-with: GHC ==9.12.4` and ships its `CHANGELOG.md` (a symlink to the+  root one, as `baikai` already did) via `extra-doc-files`, so Hackage shows a+  changelog and a tested compiler for all seven. `baikai-claude` and+  `baikai-openai` describe what they actually contain — four surfaces each, not+  "wraps package X" — and `baikai-trace-otel`'s `streamly-core` bound is+  `>=0.3 && <0.5`, matching every other package in the workspace rather than+  excluding the 0.4 series the others accept.++- `baikai` (breaking): `Options.headers` and `Model.headers` are keyed on+  `Baikai.Header.HeaderName` — a newtype over a case-insensitive `CI Text` that+  keeps the original spelling — instead of `Text`. A header name is+  case-insensitive on the wire, so a `Map Text Text` holding both+  `Authorization` and `authorization` sent whichever the assembling fold reached+  last; the map now holds one entry per header and the last write wins, as a+  caller writing two spellings would expect. `HeaderName` has an `IsString`+  instance, so `Map.singleton "x-test" "1"` and `#headers` updates keep+  compiling; the spelling given is what goes out on the wire and into JSON.+  (REV-2 G.5.)++- `baikai` (breaking): `Options.stopSequences` is `[Text]`, where empty means+  "send nothing", instead of `Maybe (Vector Text)` — `Nothing` and `Just []`+  were indistinguishable on the wire and only one of them could be right. Plan+  43's rule is lists for caller-side configuration and `Vector` for+  provider-bound sequences; this was the one field breaking it. `Options.seed`+  is `Maybe Int` rather than `Maybe Integer`: a seed is a machine integer at+  every provider that accepts one, and it now sits beside+  `timeoutMs :: Maybe Int`. (REV-2 G.5, R14.)++- `baikai` (breaking): `StopReason.Aborted` is removed. Nothing produced it —+  timeouts are `ErrorReason`/`TransientError`, and a consumer abort is recorded+  as evidence `CallAborted` — while `responseError`, `eventsFor` and+  `runToolLoop` all treated it as a *success*, so a value that reached any of+  them would have been silently mishandled. Since 0.6.0.0 a stream consumer that+  stops cancels the producer, so no consumer is left to receive such a terminal+  either. (REV-2 B.6.)++- `baikai`: dispatching a model whose `api` is still `emptyModel`'s+  `Custom ""` says so — `No provider registered for API: <blank Custom tag —+  emptyModel.api was never set>` — where the message used to end after the+  colon. `emptyModel`'s Haddock says the same thing. (REV-2 G.4.)++- `baikai`: `withTrace` and `withTraceStream` wait at most one second for the+  trace sink after writing the shutdown sentinel. On expiry the worker is+  abandoned — not killed, which would abort the sink's fold mid-step and lose+  its end-of-stream action — the call proceeds, and one stderr line reports+  `the trace sink did not confirm delivery within 1000 ms; its worker was+  abandoned, and events already queued may still be delivered later`. A sink+  that blocked forever used to hold the call forever and swallow the first+  attempt to cancel it. A caller under `EvidenceRequired` whose sink did not+  confirm delivery gets a failed call, through the same path a throwing sink+  takes; `Baikai.Evidence.Build.sinkFailureError` now says "its record was not+  confirmed written" rather than "not written", which is the honest claim for+  an abandoned worker whose events are still queued. The synthetic terminal a+  consumer's abort produces is delivered from a garbage-collection hook and is+  not guaranteed before process exit; that was always true and is now stated in+  `docs/user/model-call-evidence.md`, `docs/capabilities/call-tracing.md` and+  the `Baikai.Trace` module documentation, with the pattern for callers who need+  the record. See+  [docs/adr/0015](docs/adr/0015-trace-cleanup-is-bounded-and-abort-cleanup-is-gc-eventual.md).+  (REV-2 D.5, Theme 7.3.)++- `baikai`: `Baikai.Trace.Sink.multiSink` runs each member on its own drain+  thread behind its own unbounded channel, instead of folding `Fold.tee` across+  the list. `Fold.tee` runs one member then the other and lets either's+  exception escape, so a single throwing member stopped delivery to every+  sibling for the rest of the call and skipped their end-of-stream actions — an+  OpenTelemetry span paired with an unwritable file sink was opened and never+  ended, and nothing was exported. The step never blocks; the final action sends+  every member the sentinel, waits for every member, and reports one aggregate+  failure naming each failed member by zero-based index+  (`1 of 2 member sinks failed: member 0: …`). (REV-2 D.6.)++- `baikai`: `AgentSafety.allowedTools` is documented as the __grant__ it is.+  On Claude Code it renders `--allowedTools`, whose help reads "list of tool+  names to allow": it pre-approves tools the permission mode would otherwise+  raise a request for, and in an unattended run a request nobody answers is+  denied. The old Haddock called it "optional narrowing of the provider's tool+  set", which was the opposite, and `applyAgentCeiling` never looked at it. It+  is now bounded: a grant passes when the maximum capability implies it+  (`read-only` implies `Read`, `Glob`, `Grep`, `NotebookRead`, `TodoWrite`;+  `edit-workspace` adds `Edit`, `MultiEdit`, `Write`, `NotebookEdit`;+  `full-access` implies every grant) or when the operator named it in+  `policy.allowed-tools`. Matching is exact, so `Bash(git *)` is not `Bash`.+  A repository job that grants itself `Bash` under `edit-workspace` — which+  passed unexamined before — is now refused with exit 77 before any process is+  created. (REV-2 F.3.)++- `baikai` (breaking): `Baikai.Agent.CeilingViolation` gains five constructors:+  `ToolGrantForbidden`, `TimeoutExceeded`, `OutputLimitExceeded`,+  `RepositoryScopeForbidden` and `WorkingDirOutsideRepository`. A `case` over+  the type that was exhaustive is no longer.++- `baikai` (behaviour): the default ceiling has a finite `maxOutputLimit`, so+  `applyAgentCeiling defaultAgentCeiling` now refuses a request whose+  `outputLimit` is `Nothing` — capture without bound is exactly what the+  maximum exists to refuse. Jobs resolved through `baikai-agent` are unaffected:+  that layer's own default supplies a finite limit, and only an explicit+  `output-limit "unlimited"` reaches the ceiling as `Nothing`.++- `baikai`: a tool call cut off by the output cap is no longer executed.+  `runToolLoop` stops with the response and its tool calls intact when any call+  is cut off, and `appendToolResult` appends a `ToolResultMessage` with+  `isError = True` explaining why instead of calling the dispatcher. Previously+  both assemblers replaced truncated arguments with `{}` and a tool loop+  happily ran the call with no arguments at all. (REV-2 B.2.)++- `baikai`: `Baikai.Model.anthropicMessagesCompatFor` no longer overlays a+  thinking style guessed from the model id onto a model whose `compat` is+  `CompatNone`. `CompatNone` now means host auto-detection alone — the budget+  thinking shape, sampling parameters supported. Every catalog model carries an+  explicit record, so this changes nothing for them; a **hand-rolled** model+  naming an adaptive-era id (`claude-sonnet-5`, `claude-opus-4-7`,+  `claude-opus-4-8`, `claude-fable-5`) must now carry+  `CompatAnthropicMessages (defaultAnthropicMessagesCompat {thinkingStyle = AnthropicThinkingAdaptive, supportsSamplingParameters = False})`+  or start from the catalog value.++- `baikai`: `Baikai.Evidence.evidenceSchemaVersion` is now+  `baikai.model-call-evidence/1.1`. A minor bump: the two sampling adjustment kinds are a+  compatible addition, and no previously recorded digest changes.++- `baikai`: HTTP 413 classifies as `ContextOverflow` rather than `OtherError`,+  from the status alone and whatever the body says. 413 *is* the size-limit+  status and the caller's remedy — shrink the input — is the same either way;+  making the category depend on body wording would recreate for 413 the+  inconsistency this release fixes for connection resets. (REV-2 A.7.)++- `baikai`, `baikai-claude`, `baikai-openai`: an HTTP-date `Retry-After` is+  converted to seconds instead of ignored. Both transports use the response's own+  `Date` header as the reference instant, falling back to the local clock, so a+  CDN-fronted `429` — the common case for a date-valued `Retry-After` — now+  carries a hint rather than leaving the caller to guess. (REV-2 A.9.)++- `baikai`: **breaking.** `Baikai.Embedding.EmbeddingModel.apiKey` is now+  `Maybe ApiKeySource` rather than `ApiKeySource`. `Nothing` means the+  conventional environment variable for the model's host, from+  `defaultApiKeyEnvForBaseUrl` — the same table the chat providers use — and a+  host that table does not know refuses with an `AuthError` naming+  `EmbeddingModel.apiKey`. Migration: `apiKey = source` becomes+  `apiKey = Just source`. `EmbeddingModel` also derives `Eq` and `Generic`, so+  the `#field .~ value` idiom works on it as it does on every other record.+  (REV-2 E.3.)++- `baikai`: **breaking.** `AgentRunFailure`'s `RunTimedOut` constructor now+  carries a new record `AgentTimedOut` — the configured `limit` plus the+  `stdout` and `stderr` a timed-out run drained before its process group was+  killed — instead of a bare `NominalDiffTime`. A caller matching+  `RunTimedOut limit` becomes `RunTimedOut timedOut` and reads `timedOut ^.+  #limit`; `renderAgentRunFailure` is unchanged in what it says. The bytes were+  always there, drained from the moment the child was spawned, and were simply+  dropped on the timeout path — which is the run an operator most wants an+  account of, because the tool started, may have consumed tokens, and may+  already have changed the working tree.++- `baikai`: under `EvidenceRequired`, a successful terminal that carries no+  evidence record fails the call with `missingEvidenceError` rather than+  returning a silent success with zero `call_evidence` lines. Strict mode+  guaranteed that a record which was built and then lost fails the call; it did+  not guarantee that one was built. The rule is applied at both dispatch points,+  so `completeRequest` with no sink gets the same guarantee as a streaming call;+  a failed call keeps the provider's own error, and best effort is unchanged.+  See `docs/adr/0014-strict-evidence-means-a-record-exists.md`. (REV-2 D.3.)++- `baikai`: a caller's thinking level is recorded on every evidence path — the+  consumer abort, an unregistered provider, a `complete` handler that threw, and+  each provider's `immediateError`. The abort path asks the registered adapter's+  own `describeThinking`; the others record `not_translated`. All four used to+  record the caller's request as `absent`, which+  `docs/adr/0002-requested-translated-observed-are-never-collapsed.md` forbids.+  (REV-2 D.2.)++- **`baikai.model-call-evidence/2.0`.** Two digests cover different bytes, so a+  verifier must now select its rules by `schema_version`. `response_commitment`+  covers the provider-reported token counts and never baikai's computed cost:+  the cost comes from the caller's catalog rates rather than from the response,+  so the digest used to change whenever a price was edited and a verifier+  holding only the response could not recompute it. `request_configuration`+  summarises `output_config` and `response_format` as it already summarised+  `tools`, because a structured-output JSON schema carries author-written+  `description` strings and is content wherever it appears — the same schema was+  stripped from `tools[].input_schema` and survived verbatim through the other+  two keys. `thinking.mode` may also now be `"not_translated"`, which is a+  compatible addition. (REV-2 D.7, D.11.)++- **Breaking.** `baikai`: `Baikai.Provider.Registry.ApiProvider` gains a fifth+  field, `strengthCeiling :: EvidenceStrength`, and+  `Baikai.Evidence.Build.checkEvidenceRequirements` takes that ceiling where it+  took an `Api`. The gate compared against `declaredStrength`, a table keyed by+  the API tag, which necessarily answered `EvidenceRequestedOnly` for every+  `Custom` transport — so a gateway that genuinely observes a model could never+  satisfy a strict caller who required that it did. Only a provider knows what+  its evidence reaches. `EvidenceRequestedOnly` reproduces the old behaviour for+  any custom provider; the four built-in providers fill the field from+  `declaredStrength`, which is unchanged in value and still used by the+  unattended-agent surface. (REV-2 D.10, G.1.)++- `baikai`, `baikai-claude`, `baikai-openai`: one strength derivation replaces+  three. An observed **response id** now counts as correlation alongside a+  captured request-id header, so a host that names its model and its response id+  on every chunk but sends no header reaches `model_observed` instead of+  `requested_only` — which had put it *below* a host that sent only a header and+  named nothing. `anthropicStrength` and `openaiStrength` are removed;+  `Baikai.Provider.Cli.Internal.subprocessStrength` keeps its signature and+  delegates. (REV-2 D.10.)++### Removed++- `baikai` **0.6.0.0** (breaking): the sixteen `_Type` base-value aliases deprecated in+  0.3.0.0 — `_Options`, `_Context`, `_Model`, `_ModelCost`, `_Response`,+  `_Usage`, `_Cost`, `_CostBreakdown`, `_Tool`, `_TextContent`,+  `_ThinkingContent`, `_ToolCall`, `_ImageContent`, `_EmbeddingModel`,+  `_InteractiveLaunchRequest` and `_InteractiveLaunchResult`. Each has an+  `empty…` or `zero…` replacement of the same value, named in the pragma that+  has been on it since 0.3.0.0. The 0.3.0.0 entry said they remained "for this+  release"; 0.4.0.0 and 0.5.0.0 shipped without removing them because no entry+  named a version.+  `docs/adr/0016-deprecated-names-are-removed-at-the-next-major.md` now fixes+  the rule: a name deprecated in `A.B.0.0` is removed in `A.(B+1).0.0`, and+  every pragma says so. (REV-2 G.3.)++- `baikai` **0.6.0.0** (breaking): `Baikai.Trace.newEventId`. It has delegated to+  `Baikai.Evidence.newCallId` since 0.5.0.0; call that. (REV-2 G.3.)++- `baikai` **0.6.0.0** (breaking): `Baikai.Compat.defaultAnthropicThinkingStyle`, deprecated+  earlier in this cycle. Nothing in baikai consults it — the thinking style of a+  first-party Anthropic model is a field of its generated catalog record+  (`Baikai.Models.Generated`); start from that value, or set+  `CompatAnthropicMessages` explicitly.++- `baikai` (breaking): `AgentRunRequest.envPassthrough` is renamed `envRequires`.+  The field is a list of variables the job declares it requires, checked as a+  precondition; it has never passed anything through, and the KDL key has said+  `env-requires` since the setting existed.++- `baikai` (breaking): `AgentRunFailure.OutputMalformed`, and with it+  `baikai-agent`'s exit code 70 and its `internalExitCode` export. Nothing ever+  constructed the constructor, and giving it a producer would have been wrong:+  the runner treats the tool's output as best-effort observation and its+  deliverable is the changed working tree, so a run that edited files correctly+  and then printed an unparseable final line would have been reported as a+  failure with its exit code and output discarded. A record's `strength` and+  `unobserved` fields already say when output could not be read. (REV-2 F.13.)++### Fixed++- `baikai`: the terminal event and its evidence record are pushed to the trace+  sink exactly once under asynchronous exceptions. The terminal path pushed the+  evidence record, pushed the terminal event and only then set the+  already-sent flag; an exception delivered between the last two made the+  stream finaliser read the flag as unset and push a second `CallEvidence` and+  an `aborted` `CallFailed` after the real `CallFinished`, so a sink saw two+  records and two contradictory terminals for one call. All three writes now+  run inside one `uninterruptibleMask_` with the flag first. (REV-2 D.4.)++- `baikai`: `Baikai.Cost.Log.closeCallLog` is idempotent. The first caller+  claims the handle and waits for the worker; a second returns at once instead+  of blocking forever on an `MVar` the worker had already emptied — a shape+  `withCallLog` makes easy to reach, since its bracket closes a handle the body+  may also have closed. An `appendEntry` after the close enqueues nothing.++- `baikai`: `reassembleResponse` is total under duplicated, late and+  timestamp-less input. The first `EventStart` wins the skeleton and+  `responseId` merges with `<|>`, so a later `Nothing` cannot erase an id an+  earlier event supplied; events after the first terminal are ignored, so a+  producer that keeps talking cannot rewrite the answer; and `latencyMs` falls+  back to the reassembler's own wall clock when neither the skeleton nor the+  terminal carries a provider timestamp, instead of reporting a zero that reads+  as "instant". (REV-2 B.7.)++- `baikai`: an `EmbeddingModel` pointed at a non-OpenAI host no longer sends+  `OPENAI_API_KEY` to it. The default key source was that variable whatever the+  base URL said, so pointing the client at DeepSeek handed DeepSeek an OpenAI+  credential. It now resolves per host, and refuses an unknown one. New+  `resolveEmbeddingKey` and `embeddingClientEnv` expose both decisions without+  making a request. (REV-2 E.3.)++- `baikai`: `Baikai.Embedding.embed` no longer allocates a TLS manager per call.+  It used the `openai` SDK's own `getClientEnv`, which builds a fresh manager+  every time; it now takes one from `Baikai.Http`'s process-global cache, the+  same one the chat providers use, so an embedding call and a chat call to one+  host share a connection pool.++- `baikai`: **a credential in a header is no longer printed.** `Options.headers`+  and `Model.headers` went through derived `Show` and `ToJSON` instances that+  rendered every value verbatim — while `Baikai.Options`' own documentation+  invites callers to put a gateway's `Authorization` header there and the+  getting-started guide tells them to `print resp`, which renders the embedded+  `Model`. Both types now have hand-written instances that render exactly what+  the derived ones did, except that the value of a header whose name looks+  credential-carrying (`authorization`, `api-key`, `apikey`, `token`, `secret`,+  `cookie`, `password`, or any name ending in `-key`, case-insensitively) prints+  as `<redacted>`. `Baikai.Auth` exports the three pieces — `redactedMarker`,+  `isCredentialHeader`, `redactHeaderValues` — so a caller can apply the same+  rule to its own logging. Only the rendering changes: the field is untouched,+  `Eq` is untouched, and the header is still sent as written. A JSON round trip+  of a `Model` is deliberately lossy, since a serialised `Model` is exactly the+  thing that should not carry a key. (REV-2 E.2.)++- `baikai`: an API-key environment variable set to the empty string, or to+  nothing but whitespace, now counts as **unset**. `ApiKeyEnv` fails with an+  `AuthError` naming the variable and saying it is not set or is empty;+  `ApiKeyEnvChain` skips it and continues, and reports every name when none+  yields a key. Previously an empty variable resolved to an empty key, which+  short-circuited a chain and produced `Authorization: Bearer ` and a provider+  401 that said nothing about the cause. A key with real content is still passed+  through untrimmed. (REV-2 E.6.)++- `baikai`: **the host parse no longer lets a base URL choose which key baikai+  sends.** `urlHost` took the text after the *last* `@` anywhere in a URL, so+  `https://proxy.example.com/v1?u=@api.openai.com` named the host+  `api.openai.com`: `defaultApiKeyEnvForBaseUrl` resolved `OPENAI_API_KEY`,+  `autoDetectOpenAICompletions` returned OpenAI's own compatibility record, and+  the bearer token went to `proxy.example.com`. Anyone who could set `baseUrl` —+  a `Model` decoded from JSON, a proxy override — could pick which provider's+  credential to be handed. The same defect broke the benign direction:+  `https://api.openai.com/v1/@x` named the host `x` and resolved no key at all.+  The authority now ends at the first `/`, `?` or `#`, and userinfo is only ever+  the last `@` inside it. (REV-2 A.1 / E.1.)++- `baikai`: `Baikai.Evidence.Build.sanitizeEndpoint` was a second, separately+  written parser that bounded the authority at the first `/` only, so a URL with+  a query and no path recorded the wrong host. It is now `renderEndpoint <$>+  parseUrl`, which also means a recorded endpoint has a lower-cased scheme and+  host; the path keeps its case and trailing slash.++- `baikai`: `parseCodexJsonlStream` assembles lines in **linear time**. It+  previously unpacked every chunk into a stream of bytes and appended them one+  at a time with `BS.snoc`, copying the whole accumulator per byte — quadratic+  in line length, so one codex event carrying a two-million-character message+  cost on the order of a trillion byte moves and in practice never finished.+  Lines are now cut out of each chunk with `BS.elemIndex` and `BS.splitAt`, and+  the pieces of a line that spans a chunk boundary are joined once. Behaviour is+  unchanged: a non-JSON line is still skipped, and a last line without a+  trailing newline is still parsed.++- `baikai`: a Codex custom agent's instructions body renders as a TOML+  **literal** multi-line string (`'''`), which interprets nothing, instead of a+  basic one (`"""`), which interprets backslash escapes. As a basic string an+  instruction as ordinary as "match `\d+`" made Codex refuse to load the file;+  `tomllib` rejects the old output with `Unescaped '\' in a string`. A body a+  literal string cannot hold — one containing three apostrophes, a bare carriage+  return, or a control character other than tab and newline — falls back to a+  fully escaped basic string. `tomlString`, which renders `name` and+  `description`, now escapes every control character as TOML 1.0 requires+  instead of only the five it happened to name.++- Documentation: `baikai`'s Haddock no longer describes behaviour the code left+  behind. The trace event's token counts are `Maybe` because a non-assistant+  terminal has no usage, not because the CLI providers report nothing — since+  0.5.0.0 both carry what the tool reported. `EventStart`'s `partial` is a+  message skeleton with empty content, zero usage and no stop reason; the api,+  provider and model id live on the `Response`. A lifted stream's `EventStart`+  carries the final usage and stop reason already filled in, because the+  response is complete before the stream begins. `Baikai.CacheRetention` no+  longer mentions an OpenAI Responses 24-hour bucket no code emits. System+  prompts are documented as living on `Context.systemPrompt` rather than on a+  `Baikai.Request` module that no longer exists, `emptyModel`'s `compat` is+  described as auto-detection rather than a placeholder, tool dispatch says+  calls run one at a time in order, and every reference to a plan number is+  gone. (REV-2 H.4.)++## [baikai-claude 0.6.0.0] - 2026-08-28++### Added++- `baikai-claude`: `Baikai.Provider.Claude.Internal.Request` exports `planRequest`,+  `SamplingPlan`, `uncappedMaxTokensFloor` and `normalizeToolCallId` as test seams.+  `planThinking` and `describeThinkingFor` are now projections of `planRequest`, so the+  strict gate, the request builder and the evidence record read one answer.++### Changed++- `baikai-claude`, `baikai-openai` (breaking): each provider's streaming+  machinery moved from `Baikai.Provider.<P>.Api` to+  `Baikai.Provider.<P>.Internal.Stream` — the `SseDriver` seam, `liveSseDriver`,+  `<p>StreamWith`, `Assembler`, `emptyAssembler`, `translate`, and on the OpenAI+  side `RawChunk`, `RawToolDelta`, `parseChunk`, `parseFrame`, `TagScanState`,+  `scanThinkTags`, `closeOpenStream`, `RawUsage`, `parseUsage` and+  `rawUsageToUsage`. `Api` now exports exactly `register`, the provider value+  and the live stream function. The `.Internal` module is exposed for the test+  suites and sibling packages and, like every `.Internal` module, may change in+  any release without a major bump — so changing the assembler stops being a+  documented break. `Shape`, `Sse` and `Transport` keep their names and gain the+  same no-guarantees header. `_TagScanState` is renamed `emptyTagScanState`.+  (REV-2 G.1.)++- `baikai-claude`, `baikai-openai`: a consumer that stops reading now stops the+  provider. Both packages fork their SSE worker under `Stream.bracketIO` and+  hand frames through the bounded `FrameQueue` above instead of an unbounded+  `Chan`. A consumer that cancels — `Ctrl-C`, `System.Timeout.timeout`,+  `cancel` — releases the HTTP connection immediately; a consumer that abandons+  the stream (`Stream.take 3`) stops the socket read within 64 further frames+  and releases the connection at the next major garbage collection. Previously+  the worker read the entire generation into memory for a consumer that would+  never look at it, and the provider billed all of it. The three cleanup+  strengths are stated in+  [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md)+  and in caller terms in `docs/user/streaming.md`.++- `baikai-claude`: `anthropic_claude_sonnet_4_6` now sends the adaptive+  thinking shape rather than `budget_tokens`. The budget shape is deprecated+  for that generation; baikai sends the shape Anthropic documents as current.++- `baikai-claude`, `baikai-openai`: **behaviour change.** `Options.timeoutMs` of+  `Just n` with `n <= 0` is refused as `InvalidRequest` before the action runs, so+  no connection is opened. `System.Timeout.timeout` returns immediately at zero+  and runs unbounded below it, and the previous `max 0` clamp made both spellings+  fail instantly as a *retryable* `TransientError` — a classification a caller's+  retry loop re-issues forever for what is a configuration mistake. `Nothing`+  remains the only spelling of "no bound". (REV-2 A.10.)++- `baikai-claude`, `baikai-openai`: an evidence record's `endpoint` names the+  host the call actually went to. Both adapters substitute a vendor default for+  an empty `Model.baseUrl` inside `prepareCall`, so a call with a perfectly+  definite destination recorded `endpoint: null`. Where no adapter ran, `null`+  remains the truthful answer. (REV-2 D.8.)++- `baikai-claude`: the `claude` dependency moves from `^>=1.4` to `^>=1.5`.+  1.5.0 adds a `Pause_Turn` constructor to `Claude.V1.Messages.StopReason`, and+  `mapStopReason` matches that type with no wildcard under+  `-Werror=incomplete-patterns`, so the bump forced a decision. A paused turn+  maps to `Stop`: Anthropic suspends the turn mid-flight for a long-running+  server-side tool and expects the caller to send the message back to continue+  it, so nothing failed, and `Baikai.StopReason` has no constructor that says+  "resume me". Widening that public sum is a breaking change for every consumer+  who matches on it exhaustively, and it is not this bump's to make. The general+  rule is+  [ADR 0018](docs/adr/0018-a-provider-stop-reason-with-no-baikai-equivalent-maps-to-the-nearest-truthful-one.md):+  a provider stop reason with no baikai equivalent maps to the constructor that+  is truthful about whether the call failed, and the sum widens only when baikai+  would behave differently for it.++- `baikai-claude`: `Messages.StreamUsage` lost its `Generic` instance in `claude`+  1.5.0, so the `message_delta` usage is read through `OverloadedRecordDot`+  rather than a generic-lens label. `Messages.max_tokens` and+  `Messages.output_config` became ambiguous selectors — `Messages.Fallback`+  carries both names — so the provider's tests read them through `^. #max_tokens`+  and `^. #output_config` instead.++### Removed++- `baikai-claude`, `baikai-openai` **0.6.0.0** (breaking): the eight registration shims —+  `registerWith`, `registerWithRegistry` and `registerWithRegistryAndConfig` in+  both `Cli` modules, and `registerWithRegistry` in both `Api` modules. Register+  the exported provider value instead:+  `registerApiProvider (claudeCliProvider cfg)`,+  `registerApiProviderWith reg (codexCliProvider cfg)`,+  `registerApiProviderWith reg claudeMessagesProvider`. The batch-mode note that+  had accumulated on `registerWith` — why `complete` stays on the direct path+  rather than going through `streamingComplete` — moves to the provider value it+  describes. (REV-2 G.3.)++- `baikai-claude`, `baikai-openai`: `responseToError` and `classifyErrorText`+  (and its private `classifySdkHttpText` half) from both+  `.Internal.ErrorClass` modules. Neither package runs a `servant-client` client+  on the chat path any more, so the `ClientError` branch was unreachable, and the+  text classifiers parsed a string shape the local SSE transports stopped+  producing in July. The phrase table `classifyErrorText` held survives as the+  message fallback inside `classifyErrorFrame`, pinned through the entry point the+  runtime actually uses. Both modules are documented as outside the PVP-stable+  surface, so this is not a major bump; version bumps are recorded once, later.++- **Breaking.** `baikai-claude`: `Baikai.Provider.Claude.Api.anthropicStrength`+  and `baikai-openai`: `Baikai.Provider.OpenAI.Api.openaiStrength`, both replaced+  by `Baikai.Evidence.deriveStrength`.++### Fixed++- `baikai-claude`, `baikai-openai`: a failure that lands while the response body+  is streaming is classified as the transient failure it is. A connection reset,+  a server closing the socket mid-chunk, a body shorter than its declared length+  and a TLS session torn down after the handshake all now terminate the stream+  with `TransientError` and `isRetryable = True`, carrying whatever text had+  already been drained. Every one of them used to be `OtherError` with+  `isRetryable = False`, while the identical failure at connect time was+  transient — because `http-client` wraps the connect phase with the manager's+  exception wrapper and the body reader with nothing that converts a socket+  `IOException` or a `TLSException`, so those reached the worker raw and missed+  the `HttpException` branch entirely. (REV-2 A.2.)++- `baikai-claude`, `baikai-openai`: a transport failure mid-stream now closes+  the blocks that were open when it arrived, on both providers, so a consumer+  reading raw events and a consumer reassembling them see the same partial+  output. Both providers built their terminal from the closed blocks alone and+  silently dropped open text, thinking and tool arguments. On the Claude side+  this covers `translate (Left …)`, the in-band `error` frame, and the+  unexpected end of stream. (REV-2 B.3.)++- `baikai-claude`: an SSE frame whose event `type` — or whose+  `content_block_delta` `delta.type` — the SDK has no constructor for is now+  skipped instead of ending the stream with a decode error. The SDK decodes both+  with no unknown-tag fallback, so a new frame type from Anthropic used to be a+  terminal fault. A frame of a *known* type that still fails to decode remains+  one. `Baikai.Provider.Claude.Sse` exports the new `decodeFrame`. (REV-2 B.5.)++- `baikai-claude`, `baikai-openai`: an empty `data:` heartbeat is ignored, and+  on the OpenAI side `[DONE]` is compared after trailing whitespace is trimmed,+  so `data: [DONE] ` and `data: [DONE]\r` end the stream rather than failing to+  decode. (REV-2 A.8.)++- `baikai-claude`: every failing stream now begins with `EventStart`. The+  producer pre-seeds the start event before the first wire read, exactly as the+  OpenAI producer already did, and `message_start` updates the assembler without+  emitting a second one. Previously a 401, a rate limit, an in-band `error`+  frame or an EOF arriving before `message_start` produced a lone `EventError`,+  breaking the protocol `Baikai.Stream.Event` documents. `StartPayload.responseId`+  is consequently `Nothing` on both HTTP providers; the provider's message id+  rides `TerminalPayload.responseId`, which `reassembleResponse` already prefers.+  (REV-2 A.4, REV-1 Theme 1.1.)++- `baikai-claude`, `baikai-openai`: an asynchronous exception delivered to the+  stream worker can no longer strand its consumer. End-of-frames is a flag set+  by the worker fork's own `finally` rather than a sentinel value pushed onto+  the channel, so a worker that dies without running its normal exit path still+  ends the stream in an `EventError`. Previously the consumer blocked until the+  runtime's deadlock detector noticed.++- `baikai-smoke`: two keyed cases against `claude-sonnet-5` — one asking for+  thinking (which is a 400 before this release) and one setting `temperature` — plus+  `deepseek-chat` and `openrouter/openai/gpt-4o-mini` in `apiCases`, so the tool and+  structured-output smokes run against a compatible host that is not OpenAI.+  `CompatSmoke` now asserts DeepSeek honoured the output cap rather than only that it+  answered, and `CacheSmoke` asserts the cached token classes cost something.++- `baikai-claude`: a thinking request on `claude-sonnet-5` no longer 400s. It sends+  `"thinking":{"type":"adaptive"}` and no `budget_tokens`, because the shape is read off+  the model's catalog record rather than guessed from its id. (REV-2 C.1.)++- `baikai-claude`: `temperature` and `top_p` are no longer sent to a model generation that+  rejects them with a 400. They are omitted and the omission is recorded as+  `sampling_dropped_unsupported_model` in the call's evidence. `seed`, `frequencyPenalty`+  and `presencePenalty`, which the Anthropic Messages API has no field for on any+  generation, are recorded as `sampling_dropped_unsupported_api`. (REV-2 C.1, C.5.)++- `baikai-claude`: a model whose `maxOutputTokens` is `0` no longer sends+  `"max_tokens":0`, which Anthropic rejects — and, with thinking set, no longer had its+  whole thinking plan discarded for not fitting inside a ceiling of zero. It sends+  `uncappedMaxTokensFloor` (1024, the SDK's own default) instead. An explicit+  `maxTokens = Just 0` is still forwarded as written. (REV-2 C.2.)++- `baikai-claude`: replay no longer sends an empty text block or an empty `content` array,+  both of which Anthropic rejects. An empty text block is dropped; an assistant turn left+  with nothing is dropped whole (it is baikai's own artifact — a block that closed with no+  deltas, or only unsigned thinking, which replay already omits); a user turn left with+  nothing is refused locally with a message naming the turn. (REV-2 C.3.)++- `baikai-claude`: tool-call ids that differ only in characters the alphabet forbids, or+  only past character 64, no longer normalise onto the same id and misroute a tool result.+  A conforming id passes through unchanged — every id Anthropic and OpenAI actually mint+  does — and any other is truncated to 51 characters and suffixed with twelve hex+  characters of its SHA-256. Two `tool_use` blocks in one turn that still collide are+  refused rather than sent. (REV-2 C.7.)++- Documentation: `baikai-claude`'s and `baikai-openai`'s Haddock point at the+  functions that exist. `Baikai.Compat` named+  `Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat`,+  `…Api.applyThinkingFormat` and `…Api.translateTextLikeDelta`; the first two+  moved to `…Internal.Request` and the third is+  `…Internal.Stream.scanThinkTags`. `ThinkingFormat`'s note said the six+  non-native shapes all clamp through `compatibleEffort`; three do, Z.ai and+  Qwen send a bare toggle, and `ThinkingFormatNone` drops the control.+  `immediateError` carried two `-- |` headers where one was intended.+  (REV-2 H.4.)++- `baikai-claude`: an Anthropic call reports its thinking tokens. `Usage.reasoningTokens`+  was hard-coded to `Nothing` on this provider because `claude` 1.4.0's+  `Messages.Usage` had no breakdown to read; 1.5.0 adds+  `output_tokens_details.thinking_tokens`, and both `message_start` and+  `message_delta` now fill the field from it. `reasoningTokens` is an+  informational subset of `outputTokens`, so no total and no cost moves.++- `baikai-claude`: the prompt-side token counts survive a server-side tool run.+  The final `message_delta` used to contribute only `output_tokens`, and+  `inputTokens`, `cacheReadTokens` and `cacheWriteTokens` kept whatever+  `message_start` had reported — which is wrong for a call whose prompt grew+  mid-stream. `claude` 1.5.0 exposes those three on `Messages.StreamUsage`, and+  each is now taken when present. An absent field still keeps the+  `message_start` figure rather than zeroing it, so a model that sends only+  `output_tokens` is accounted for exactly as before.++## [baikai-openai 0.6.0.0] - 2026-08-28++### Added++- `baikai-openai`: `Baikai.Provider.OpenAI.Internal.ErrorClass.classifyErrorFrame`+  and `Baikai.Provider.OpenAI.Api.parseFrame`, which sort a decoded SSE payload+  into a classified in-band error or a completion chunk.++### Changed++- `baikai-openai`: **breaking.** `Baikai.Provider.OpenAI.Shape`'s+  `injectThinkingShape`, `describeThinkingShape`, `shapeRequestBody` and+  `streamRequestBody` take a `Bool` after the compat record — whether the model+  advertises reasoning support (`Model.reasoning`). A level on a `reasoning = False`+  model now sends no `reasoning_effort`, `reasoning`, `thinking` or `enable_thinking`+  key on any host, and records `thinking_dropped_unsupported_model` instead. The model+  check runs before the host-format check. This is what stops `gpt-4o-mini` plus a+  level from 400ing. (REV-2 C.4.)++### Fixed++- `baikai-openai`: an in-band `{"error": …}` frame on a `2xx` stream terminates+  the call with the frame's own classification, status and message. Compatible+  hosts (OpenRouter, DeepSeek, Together) report an upstream failure they only+  learned about after committing to a `200` this way, and `parseChunk` never+  looked at `error`. The pre-fix behaviour was worse than a bad category:+  OpenRouter's frame carries `choices[0].finish_reason = "error"`, which mapped+  to `Stop`, so the call ended as `EventDone` with `errorInfo = Nothing` — a+  consumer switching on the terminal saw a *completed* call. A frame with no+  `choices` beside the error ended as+  `OtherError "openai stream ended without finish_reason"`. (REV-2 A.3.)++- `baikai-openai`: reasoning that arrives after visible text closes the open+  text block before opening the thinking block, so at most one of the two is+  open at a time, every `_End` precedes the next `_Start`, and no `contentIndex`+  is revisited after a later one. (REV-2 B.4.)++- `baikai-openai`, `baikai-claude`: **a provider POST no longer follows+  redirects.** `http-client`'s default is to follow up to ten with every header+  intact, so a 3xx would have re-sent the bearer token (or `x-api-key`) to+  whatever host the `Location` header named. `redirectCount` is now zero and the+  3xx is delivered as the one in-band terminal error carrying its status. Each+  transport's request builder is exported as `buildRequest`, so the method, the+  composed path and the redirect policy are assertable without a connection.+  (REV-2 A.5 / E.4.)++- `baikai-openai`, `baikai-claude`, `baikai`: **the base-URL convention is+  stated and enforced.** `Model.baseUrl` and `EmbeddingModel.baseUrl` are the+  API *root* — the host, or the prefix a host mounts the API under — because+  baikai appends `/v1/chat/completions`, `/v1/messages` or `/v1/embeddings`+  itself. A trailing `/v1` is accepted and removed rather than doubled, so+  `https://api.deepseek.com/v1` now requests `/v1/chat/completions` instead of+  `/v1/v1/chat/completions`. A base URL with no scheme, a scheme other than+  `http`/`https`, credentials, a query string, a fragment, or a path that is+  already an endpoint is refused as an `InvalidRequest` naming the problem —+  and refused *before* a key is read, so an unusable base URL never causes a+  credential to be looked up. The message renders the URL without its userinfo+  or query, so it is safe to log. `docs/user/models-and-providers.md` gains a+  **Base URLs** section stating all of it. (REV-2 A.6.)++- `baikai-openai`, `baikai-claude`: the `ClientEnv` cache was duplicated in each+  package and keyed on the raw base-URL text, so `https://h` and `https://h/`+  were two TLS managers and two connection pools to one host. There is now one+  cache, in `Baikai.Http`, keyed on the canonical rendering of the parsed base+  URL. `Transport.getClientEnvCached` and `Transport.cachedClientEnvCount` are+  re-exports of the core functions and keep their signatures.++- `baikai-openai`: the Codex interactive launcher now **refuses the two approval+  policies the installed CLI rejects**. `codex --help` at `codex-cli 0.149.1`+  lists exactly `on-request` and `never` for `--ask-for-approval`;+  `CodexApprovalUntrusted` and `CodexApprovalOnFailure` are older spellings the+  CLI answers with `error: invalid value 'untrusted' for+  '--ask-for-approval'`. Rendering them made a launch return `Right` carrying a+  non-zero exit code — a session that ran and failed — instead of the `Left+  SafetyNotExpressible` this module promises for a policy that cannot be+  honoured. They are refused before any process is created, and refused rather+  than quietly mapped onto `on-request`, because substituting a different+  approval policy would change what the caller asked for. The constructors and+  their spellings are unchanged, so code that matches on `CodexApprovalPolicy`+  keeps compiling.++## [baikai-trace-otel 0.4.0.0] - 2026-08-28++### Added++- `baikai-trace-otel`: `OtelSinkOptions` derives `Generic`, so `#spanName`+  resolves on it. No `Eq` or `Show`: `OpenTelemetry.Context.Context` has neither,+  and an instance that ignored `parentContext` would be a lie. (REV-2 G.6.)++- `baikai-trace-otel`: `OtelSinkOptions.parentContext :: Maybe Context`, default+  `Nothing`. When set, every span the sink opens becomes a child of the span in+  that context instead of a root, so a call can be nested under the caller's own+  request span. It is a value fixed when the sink is built rather than an action+  run per call, because the fold runs on baikai's trace worker thread where the+  caller's thread-local context is invisible: capture the context on your own+  thread (`ctx <- getContext`, or `Context.insertSpan mySpan Context.empty`) and+  build the sink for that request. __Breaking for positional construction__ of+  `OtelSinkOptions`; the documented path is a record update on+  `defaultOtelSinkOptions`. (REV-2 D.9.)++### Changed++- `baikai-trace-otel`: the `baikai.evidence.strength` span attribute is rendered+  by `Baikai.Evidence.renderEvidenceStrength`, the function the JSON encoding+  uses, instead of a second spelling local to the sink that could drift from it.++- `baikai-trace-otel`: `gen_ai.response.model` is set only by the evidence+  branch, from the model the provider reported. The terminal branch set it from+  the *requested* id, and since evidence is pushed before the terminal and+  `addAttributes` replaces a key, that both labelled a request as an observation+  on every call without evidence and overwrote the genuinely observed value on+  every call with one. (REV-2 D.1.)++## [baikai-effectful 0.4.0.0] - 2026-08-28++### Changed++- `baikai-effectful` (breaking): the version is a **major** bump although this+  package's own exports are unchanged. Its `baikai` bound moves to `^>=0.6.0`,+  and the `Baikai` effect's three operations are typed in `Model`, `Context`,+  `Options` and `Response` — every one of which baikai 0.6.0.0 changes+  breakingly. A consumer therefore meets a break through this package even+  though nothing in it was renamed, so the number says so rather than making+  `0.3.0.4` look like a safe upgrade.++- `baikai-effectful`: no longer depends on `streamly`. Both stanzas listed it+  while every module imports only `Streamly.Data.Fold` and+  `Streamly.Data.Stream`, which are `streamly-core`. (REV-2 minor.)++## [baikai-kit 0.2.0.0] - 2026-08-28++### Added++- `baikai-kit`: `Baikai.Kit.Error` with the closed `KitError` sum, its+  `Exception` instance and `renderKitError`; `Baikai.Kit.Path.safeSourcePath`,+  which resolves an untrusted relative source below the kit checkout and refuses+  a symbolic link in any component or a canonical path outside the checkout;+  `Baikai.Kit.Manifest.itemSources`/`ItemSources`, the one pure derivation of an+  item's source list, and `supportedManifestVersions`;+  `Baikai.Kit.Sidecar.hashEntries`; `Baikai.Kit.Repo.KitRepo`/`RepoRefresh`;+  `Baikai.Kit.Install.installFrom`, `renderAvailable` and `UpdateReport`;+  `Baikai.Kit.Status.StatusReport`, `UpstreamAvailability` and the now-pure+  `renderStatusTable`; `Baikai.Kit.Command.runKitCommand`. `KitState` gains+  `KitUpstreamRefused`, rendered `refused`. (REV-2 E.5, F.10, F.11.)++- `baikai-kit`: `Baikai.Kit.Install.OverwritePolicy` (`KeepLocalEdits`,+  `OverwriteLocalEdits`), `reinstallPresent` (the network-free half of+  `updateKit`), and `PlannedWrite`/`WriteContent`/`executePlan`/`executePlanWith`+  as a test seam. `SidecarMeta` gains `installedFiles` and `installedHash`,+  which record what this tool wrote for one provider and the hash of exactly+  those bytes; `newSidecarMeta` takes both. `kit update` gains `--force`.+  (REV-2 F.12, Theme 8.2.)++### Changed++- **Breaking.** `baikai-kit`: every library function returns+  `Either KitError a` and prints nothing; only+  `Baikai.Kit.Command.runKit` prints `Error: …` and exits 1. `loadManifest`,+  `loadManifestMaybe`, `installItem`, `listAvailable`, `uninstallItem`,+  `updateKit` and `ensureKitRepo` change shape accordingly, `computeKitHash`+  takes the kit root, a base and relative file names, `kitStatus` returns a+  `StatusReport` instead of printing, and `KitUpdate`'s report is rendered by+  the caller. See `docs/adr/0013-library-code-never-calls-exitfailure.md`. A+  consumer that only calls `runKit` and `kitCommandParser` needs no change; one+  that calls the library directly binds `Right`. (REV-2 F.11.)++- `baikai-kit`: a kit is plain files. Install, the content hash and `kit status`+  resolve every listed source through `safeSourcePath`, so a kit repository that+  commits a symbolic link can no longer have a file read through it and copied+  into a provider directory. `kit status` shows such an item as `refused`.+  (REV-2 E.5 = F.10.)++- `baikai-kit`: a manifest whose `version` is not 1 or 2 is refused with+  `KitManifestVersionUnsupported` instead of being decoded and installed.+  (REV-2 F.12.)++- `baikai-kit`: an agent that lists several `files` installs all of them. The+  first becomes the provider's agent file as before, and each remaining file+  goes into a resource directory named after the agent beside it+  (`<agents dir>/<name>/<file>`), which uninstall removes with the agent. Only+  the first file used to be installed. (REV-2 F.12.)++- `baikai-kit`: `kit update` skips an item whose installed files no longer hash+  to what its sidecar recorded, printing the `--force` invocation that would+  overwrite them; `kit update --force` reinstalls anyway. Sidecars written+  before this release carry no such hash and are updated without the check.+  (REV-2 Theme 8.2.)++### Removed++- **Breaking.** `baikai-kit`: `Baikai.Kit.Path.safeUnder` (exported and unused),+  `Baikai.Kit.Manifest.agentSources` (replaced by `itemSources`) and+  `Baikai.Kit.Install.uninstallOutcomes` (absorbed by `uninstallItem`, which now+  returns the outcomes for the caller to render). The internal `requireSafe` and+  `Baikai.Kit.Status.resolveCacheOrEmpty` are gone with the exits they wrapped.++### Fixed++- `baikai-kit`: `kit status` with no cache and no network prints+  `No kit items installed.` and exits 0. It used to exit 1: the guard around+  `ensureKitRepo` caught `IOException`, which is not what `exitFailure` throws.+  (REV-2 F.11.)++- `baikai-kit`: `Baikai.Kit.Status.upstreamHash` joined the manifest `path`+  without validating it, a second unsanitised join that grew after the July+  hardening pass validated the first. Both now go through `itemSources` and+  `safeSourcePath`. (REV-2 Theme 8.1.)++- `baikai-kit`: an install that fails while renaming files into place now+  restores what was there before, or names the paths it could not restore.+  Phase two was a bare loop of renames, so a failure part-way left earlier+  renames in place while the message said "no changes were made". Temporary+  files are also created with `openTempFile`, so two concurrent installs of one+  item no longer clobber each other's staging file, and a destination that is a+  directory is refused before anything is written. (REV-2 F.12.)++- `baikai-kit`: `Baikai.Kit.Install.stripYamlFrontmatter` normalises line+  endings to LF on every branch. Input without frontmatter, and input whose+  frontmatter is never closed, used to keep their `\r` characters and leak them+  into the Codex agent TOML. (REV-2 Theme 8.7.)++- `baikai-kit`: an `IOException` raised while reinstalling during `kit update`+  is returned as `KitWriteFailed` instead of escaping as an uncaught exception.+  (REV-2 Theme 8.4.)++## [baikai-agent 0.2.0.0] - 2026-08-28++### Added++- `baikai-agent`: three operator-only `policy` keys — `policy.allowed-tools`,+  `policy.max-timeout` (a duration or `"unlimited"`) and+  `policy.max-output-limit` (a byte count or `"unlimited"`) — each defaulting+  from `defaultAgentCeiling`, and all six ceiling fields now printed by+  `agent show` and carried in its `--json` object.++- `baikai-agent`: `Baikai.Agent.Config.repositoryScopeViolations`, which reads+  the resolution report to say which values the untrusted repository file was+  not allowed to supply at all. `Baikai.Agent.Cli` concatenates its answer with+  the pure ceiling's, so an operator sees one refusal naming every problem.++### Changed++- `baikai-agent` (breaking): `AgentConfigScope`'s constructors are+  `AgentUserScope` and `AgentRepositoryScope`. `UserScope` collided with+  `baikai-kit`'s `KitScope` constructor of the same name, the one clash between+  two baikai-family packages. (REV-2 G.5.)++- `baikai-agent` (breaking): a relative `working-dir` resolves against the+  repository root rather than the process's own directory, so `working-dir "."`+  means the checkout whichever file declared it. Resolving against the process+  directory made `"."` mean two places when two documents defined one job, since+  which one it was depended on which layer won. An absolute path is unchanged.+  (REV-2 F.14.)++- `baikai-agent` (breaking): every `--json` output is now built with `aeson`+  rather than a hand-rolled writer, and `agent show --json` always emits one+  object with the same seven keys — `job`, `outcome` (`shown`, `refused` or+  `failed`), `exitCode`, `message`, `configuration`, `ceiling`, `command` —+  with `null` for the parts that do not apply. Previously a refusal emitted a+  different shape from a success and a document that would not parse emitted a+  bare resolution report or nothing at all, so a reader had to know which+  failure mode it was looking at before it could find the exit code. `run --json`+  keeps its `outcome` values and `list --json` is unchanged. (REV-2 F.14.)++- `baikai-agent` (breaking): `--run-id` or `--require-evidence` without either+  `--evidence-file` or `--json` is now a usage error (64) naming both fixes.+  Before, the record was built — a `--version` probe of the tool and two digests+  — and then dropped. Under `--json` the record now travels in the envelope as+  `evidence`, encoded by the same `ToJSON` `--evidence-file` writes.++- `baikai-agent`: `agent show` and `agent run` no longer print another job's+  unknown-key warnings, or the operator file's `policy` keys. The declaration+  describes one job and the ceiling is a separate declaration, so `settei` warns+  about both; neither is a mistake and a document with four jobs printed three+  jobs' worth of noise on every run. A misspelled key inside the selected job+  still warns, and a `policy` node in the *repository* document earns exactly one+  notice saying it has no effect. `Baikai.Agent.Config` exports the two filters,+  `relevantWarnings` and `repositoryPolicyNotice`. (REV-2 F.13.)++- `baikai-agent`: an evidence record's `endpoint` resolves a relative executable+  against the job's working directory before probing it, because that is what+  the child execs. A job whose `executable` is `./bin/agent` previously reported+  a path resolved against the parent's own directory, which does not exist.+  `Baikai.Agent.Run` exports `executableForEvidence`. (REV-2 F.13.)++- `baikai-agent`: a failed run's `error_info.message` keeps the last+  `errorInfoStderrTailBytes` (4096) bytes of standard error, prefixed with how+  many earlier bytes were dropped, instead of the whole captured stream — which+  the output limit allows to reach four mebibytes by default. `Baikai.Agent.Run`+  exports the constant. (REV-2 F.13.)++- `baikai-agent`: `--evidence-file` stages through a uniquely named temporary+  file created with `O_EXCL` beside the destination, instead of the destination+  plus `.partial`. A symbolic link planted at the old, guessable name was+  followed, which let an unattended run overwrite a file of the planter's+  choosing. (REV-2 F.13.)++- `baikai-agent` (breaking): an operator configuration file that lies inside the+  repository root is refused with exit 78, naming the file and the root, and no+  ceiling is established. The source list already refused the repository+  *document*; this closes the shape where the repository supplies the *operator*+  document, which both `--user-config .baikai/policy.kdl` and+  `XDG_CONFIG_HOME=$PWD/.baikai` produce. `--user-config`, `XDG_CONFIG_HOME` and+  `HOME` remain the operator's own inputs: the ceiling is exactly as trustworthy+  as the process environment that selects it, and the guide now says so.+  (REV-2 F.4.)++- `baikai-agent` (breaking): an unrecognised key under the operator file's+  `policy` node is an error rather than a warning, naming the file and every+  such key. Everywhere else a forward-compatible file should not stop an older+  binary; under `policy` a misspelling would silently leave the default ceiling+  in force, which for the one node whose purpose is limiting authority is+  indefensible. Two `AgentConfigError` constructors are added,+  `CeilingFileInsideRepository` and `UnknownPolicySetting`.++- `baikai-agent` (breaking): `AgentConfigPaths` gains `repositoryRoot`, the+  directory the process runs in. `--config PATH` chooses which file supplies+  repository-scope settings and does not move the root, because the root is what+  confines a repository-supplied `working-dir`.++- `baikai-agent` (breaking): a repository configuration file may no longer set+  `executable` or a non-empty `extra-dirs`, and its `working-dir` must resolve —+  after following symbolic links — inside the repository root. Each is refused+  with exit 77 naming the setting, or naming both directories. The operator's+  own file and `--set` may still set all three. `executable` turns configuration+  into code execution with the operator's environment and the prompt on standard+  input; `extra-dirs` inside the root adds nothing the working directory does not+  already give, so the only ones a checkout would ask for are outside it.+  (REV-2 F.3.)++### Removed++- `baikai-agent` (breaking): the `BAIKAI_AGENT_EXECUTABLE` environment binding.+  An environment variable is inherited by every child process and is easy to set+  by accident, and naming the program to run is the widest widening there is.+  An operator whose installation is not on `PATH` writes `executable` in their+  own configuration file or passes `--set`.++### Fixed++- `baikai-agent`: a timed-out run now **escalates to `SIGKILL`**. The runner+  interrupts the child's whole process group, then terminates it, then kills it,+  each of the first two stages bounded by the grace period and ended early once+  the leader has been reaped and no member of the group is left. Previously the+  last resort was `terminateProcess` followed by an *unbounded* wait, so a+  coding agent that ignored `SIGTERM` — or a grandchild holding the output pipe+  — hung the run for as long as it chose to live, with the deadline already+  past. Polling the group rather than waiting on the leader alone is also what+  gives a grandchild the same grace the agent gets.++- `baikai-agent`: a timed-out run **reports the output it drained**. `baikai+  agent run` prints it under the same stream discipline a finished run gets, so+  `response=$(baikai agent run job)` under `capture` receives the partial answer+  with `$?` set to 75, and `--json`'s failure envelope carries the same+  `stdout`, `stdoutTruncated`, `stderr` and `stderrTruncated` fields. A drain+  interrupted because something outside the process group still held the pipe+  open keeps its bytes too, reported as truncated.++- `baikai-agent`: the `baikai` command writes its output as **UTF-8 bytes**+  rather than through the locale encoding. Where an unattended run actually+  happens — cron, a systemd unit, a container — the environment says `LANG=C`,+  and on a platform whose locale encoding follows it a single accented character+  in the agent's answer made the write throw after the run had already finished:+  exit 1, answer lost. This mirrors what the prompt read and the prompt write+  have always done.++- `baikai-agent`: the `baikai` executable now links the **threaded runtime**+  (`ghc-options: -threaded` on the `executable baikai` stanza). Without it a+  blocking operating-system call — the `waitpid` inside+  `System.Process.waitForProcess` — stopped every Haskell thread in the+  installed binary, so a job's configured `timeout` could never fire and a+  coding agent that wrote more than one pipe buffer deadlocked against the+  runner's drain threads. Both defects existed only in the shipped executable:+  the test suite was already compiled `-threaded`, so every runner test passed+  under a runtime the binary did not have.++  The suite now proves the runtime the binary ships with rather than its own.+  `baikai-agent/test/BinaryTests.hs` spawns the built executable — cabal builds+  it first and puts it on the suite's `PATH` through+  `build-tool-depends: baikai-agent:baikai` — asserts that `baikai +RTS --info`+  reports `rts_thr`, and runs `baikai agent run` against a stub agent that+  outlives its deadline, requiring exit 75 within seconds and the whole process+  group gone. See+  [docs/adr/0006](docs/adr/0006-a-process-spawning-executable-ships-on-the-threaded-runtime.md).++## [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.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`: **strict+  evidence mode**. `EvidenceStrictness` is `EvidenceBestEffort` or+  `EvidenceRequired !EvidenceStrength`, and a caller who asks for the second+  gets a call that **refuses to start** — before any request is built or any+  connection opened — when the configuration cannot reach the strength asked+  for: `Baikai.Evidence.Build.checkEvidenceRequirements` compares the+  requirement against what the provider can deliver and against the thinking+  translation, and `completeRequest` / `streamRequest` return an error-shaped+  response or a terminal `EventError` instead of dispatching. The gate is+  pre-dispatch by design; that is the only point at which refusing is still+  free.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`:+  **sink-failure semantics under strict mode**. `Baikai.Evidence.Build`+  exports `onSinkFailure`, `sinkFailureIsFatal` and `sinkFailureError`: a trace+  sink that throws fails an `EvidenceRequired` caller's call, because a record+  the sink did not confirm written is not a record, while a best-effort caller's+  call succeeds with the failure reported on stderr.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) **Breaking.**+  `baikai`: `Baikai.Provider.Registry.ApiProvider` gained a fourth field,+  `describeThinking :: Model -> Options -> ThinkingTranslation`, which the+  pre-dispatch strictness gate calls to learn what a provider would do with the+  caller's reasoning-effort request without sending anything. Every third-party+  provider constructed with the `ApiProvider` constructor stopped compiling.+  This was not recorded at the time; it is the defect that made 0.6.0.0 hide the+  constructor behind `apiProvider` so that the next field addition is a minor+  release.++- `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.++  (Correction added 2026-08-27: the two paragraphs above describe the release+  inaccurately and are kept as shipped rather than rewritten. `onSinkFailure`+  did not await a future release — it shipped in 0.5.0.0 together with+  `sinkFailureIsFatal` and `sinkFailureError`, which already fail a strict+  caller's call when the sink throws. And not every 0.5.0.0 record has `strength`+  `requested_only`: the provider entries below describe what each transport+  reports, and the HTTP adapters reach `correlated` and `model_observed`.)++  **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 five-second timeout so a tool that hangs on+  `--version` cannot wedge a model call. (Corrected 2026-08-27: the entry said+  two seconds; `versionProbeMicros` has always been five.) 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 `<redacted>` 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 `<redacted>` 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
baikai.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.4 name:            baikai-version:         0.4.1.0+version:         0.7.0.0 synopsis:        Unified Haskell interface for multiple AI providers description:   baikai provides a unified, provider-agnostic Haskell interface for working@@ -16,6 +16,7 @@ maintainer:      nadeem@gmail.com copyright:       (c) 2026 Nadeem Bitar build-type:      Simple+tested-with:     GHC ==9.12.4 extra-doc-files: CHANGELOG.md  common common-options@@ -25,6 +26,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 +53,7 @@   hs-source-dirs:  src   exposed-modules:     Baikai+    Baikai.Agent     Baikai.AgentAssets     Baikai.Api     Baikai.Auth@@ -49,6 +66,10 @@     Baikai.Cost.Pricing     Baikai.Embedding     Baikai.Error+    Baikai.Evidence+    Baikai.Evidence.Build+    Baikai.Header+    Baikai.Http     Baikai.Interactive     Baikai.Message     Baikai.Model@@ -57,9 +78,12 @@     Baikai.Prelude     Baikai.Provider     Baikai.Provider.Cli.Internal+    Baikai.Provider.Internal.StreamWorker     Baikai.Provider.Registry+    Baikai.Provider.Transport.Classify     Baikai.Response     Baikai.ResponseFormat+    Baikai.Speed     Baikai.StopReason     Baikai.Stream     Baikai.Stream.Event@@ -68,22 +92,42 @@     Baikai.Trace     Baikai.Trace.Event     Baikai.Trace.Sink+    Baikai.Url     Baikai.Usage+    Baikai.Usage.Normalize +  -- 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+    , case-insensitive   ^>=1.2     , containers         ^>=0.7+    , cryptohash-sha256  ^>=0.11+    , directory          ^>=1.3+    , filepath           ^>=1.5     , generic-lens       ^>=2.3+    , http-client        ^>=0.7+    , http-client-tls    >=0.3   && <0.5+    , http-types         ^>=0.12     , lens               ^>=5.3     , openai             ^>=2.5+    , process            ^>=1.6     , scientific         ^>=0.3+    , servant-client     ^>=0.20+    , stm                ^>=2.5     , streamly           >=0.11  && <0.13     , streamly-core      >=0.3   && <0.5     , text               ^>=2.1     , time               ^>=1.14+    , tls                >=2.2   && <2.5     , unliftio-core      ^>=0.2     , vector             ^>=0.13 @@ -123,7 +167,7 @@     , filepath         ^>=1.5     , generic-lens     ^>=2.3     , http-client      ^>=0.7-    , http-client-tls  ^>=0.3+    , http-client-tls  >=0.3   && <0.5     , lens             ^>=5.3     , scientific       ^>=0.3     , text             ^>=2.1@@ -136,6 +180,7 @@   main-is:            Main.hs   other-modules:     AgentAssetsSpec+    AgentSpec     CatalogSpec     CliInternalSpec     ContextSpec@@ -143,16 +188,23 @@     EmbeddingSpec     ErrorInfoSpec     ErrorSpec+    EvidenceSpec     FetchModelsCore     FetchModelsSpec     GenModelsCore     GenModelsSpec     HelpersSpec     InteractiveSpec+    PricingPolicySpec+    PublicSurfaceSpec     StreamSpec+    StreamWorkerSpec+    StrictEvidenceSpec     SurfaceSpec     ThinkingLevelSpec     TraceSpec+    TransportClassifySpec+    UrlSpec     UsageSpec    build-tool-depends: baikai:baikai-gen-models@@ -161,14 +213,18 @@     , baikai     , base     , bytestring+    , case-insensitive     , containers     , directory     , filepath     , generic-lens+    , http-client+    , http-types     , lens     , openai     , process     , scientific+    , servant-client     , stm     , streamly-core     >=0.3 && <0.5     , tasty@@ -177,4 +233,5 @@     , temporary     , text     , time+    , tls     , vector
fetch/FetchModelsCore.hs view
@@ -16,7 +16,8 @@ -- emitted, and only if upstream marks them @tool_call: true@. For -- @openai@ this excludes Responses-API-only ids (@*-pro@, @*-codex@, -- @*-deep-research@) because @baikai/data/models/openai.json@ speaks--- @openai-chat-completions@ and 'Baikai.Api' has no Responses tag.+-- @openai-chat-completions@ by default. Per-model API overrides allow+-- explicitly curated Responses models without changing the older routes. -- -- == Override philosophy --@@ -40,6 +41,8 @@     -- * Output catalog shape     CatalogModel (..),     CatalogCost (..),+    CatalogModelCompat (..),+    AnthropicGenerationFacts (..),     Catalog (..),      -- * Provider specs and normalization@@ -62,8 +65,11 @@   ) where +import Baikai.Compat (AnthropicThinkingStyle (..), OpenAICompletionsCompat (..), OpenAIResponsesCompat (..), defaultOpenAIResponsesCompat) import Baikai.Model (InputModality (..))+import Baikai.Model qualified as Model import Baikai.Prelude+import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) import Data.Aeson (Value (String), eitherDecode, encode, withObject, (.!=), (.:), (.:?)) import Data.Aeson.Types (Parser) import Data.ByteString (ByteString)@@ -74,8 +80,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe)-import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific)-import Data.Set (Set)+import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific, fromRationalRepetendUnlimited) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8)@@ -188,6 +193,28 @@   }   deriving stock (Eq, Show, Generic) +-- | The two request-shaping facts every curated Anthropic model must+-- state before it can enter the catalog. Which extended-thinking wire+-- shape a generation accepts, and whether it accepts the sampling+-- parameters @temperature@, @top_p@ and @top_k@, are facts about the+-- generation that no amount of inspecting the model id or the base URL+-- can recover; they are curated here and travel through the catalog+-- JSON into the generated 'Baikai.Compat.AnthropicMessagesCompat'.+data AnthropicGenerationFacts = AnthropicGenerationFacts+  { thinkingStyle :: !AnthropicThinkingStyle,+    supportsSamplingParameters :: !Bool,+    supportsForcedToolChoice :: !Bool,+    fastModeCost :: !(Maybe CatalogCost)+  }+  deriving stock (Eq, Show, Generic)++-- | Per-model endpoint facts preserved through catalog refreshes.+data CatalogModelCompat+  = CatalogAnthropicCompat !AnthropicGenerationFacts+  | CatalogOpenAICompat !OpenAICompletionsCompat+  | CatalogResponsesCompat !OpenAIResponsesCompat+  deriving stock (Eq, Show, Generic)+ -- | One emitted catalog model. @enabled@ is always @true@ for emitted -- models, so it is not stored here; the renderer writes it literally. data CatalogModel = CatalogModel@@ -196,8 +223,12 @@     reasoning :: !Bool,     input :: ![InputModality],     cost :: !CatalogCost,+    fastModeCost :: !(Maybe CatalogCost),+    pricingPolicy :: !(Maybe Model.PricingPolicy),     contextWindow :: !Integer,-    maxOutputTokens :: !Integer+    maxOutputTokens :: !Integer,+    apiOverride :: !(Maybe Text),+    compat :: !(Maybe CatalogModelCompat)   }   deriving stock (Eq, Show, Generic) @@ -219,63 +250,132 @@   { provider :: !Text,     baseUrl :: !Text,     api :: !Text,-    include :: !(Text -> Bool)+    include :: !(Text -> Bool),+    -- | The per-model @compat@ block to render, if this provider needs+    -- one. 'const Nothing' for a provider whose file-level+    -- @"compat": "auto"@ directive says everything.+    apiFor :: !(Text -> Maybe Text),+    compatFor :: !(Text -> Maybe CatalogModelCompat)   }   deriving stock (Generic)  -- | Curation include set for OpenAI: the chat-completions-compatible -- current line. Responses-API-only ids (@*-pro@, @*-codex@, -- @*-deep-research@) are deliberately absent.-openaiInclude :: Set Text+openaiInclude :: Map Text (Maybe CatalogModelCompat) openaiInclude =-  Set.fromList-    [ "gpt-5.6",-      "gpt-5.6-luna",-      "gpt-5.6-sol",-      "gpt-5.6-terra",-      "gpt-5.5",-      "gpt-5.4",-      "gpt-5.4-mini",-      "gpt-5.4-nano",-      "gpt-5.2",-      "gpt-5.1",-      "gpt-5",-      "gpt-5-mini",-      "gpt-5-nano",-      "gpt-4.1",-      "gpt-4.1-mini",-      "gpt-4.1-nano",-      "gpt-4o",-      "gpt-4o-mini",-      "o3",-      "o3-mini",-      "o4-mini",-      "o1"-    ]+  Map.insert "gpt-6-astra" (Just (CatalogResponsesCompat astraResponsesFacts)) $+    Map.fromList+      [ (model, Nothing)+      | model <-+          [ "gpt-5.6",+            "gpt-5.6-luna",+            "gpt-5.6-sol",+            "gpt-5.6-terra",+            "gpt-5.5",+            "gpt-5.4",+            "gpt-5.4-mini",+            "gpt-5.4-nano",+            "gpt-5.2",+            "gpt-5.1",+            "gpt-5",+            "gpt-5-mini",+            "gpt-5-nano",+            "gpt-4.1",+            "gpt-4.1-mini",+            "gpt-4.1-nano",+            "gpt-4o",+            "gpt-4o-mini",+            "o3",+            "o3-mini",+            "o4-mini",+            "o1"+          ]+      ]+  where+    -- 2026-09-07: native tools require Responses; only modern 30m cache TTL.+    -- https://developers.openai.com/api/docs/guides/latest-model+    astraResponsesFacts =+      defaultOpenAIResponsesCompat+        { supportsPromptCacheOptions = True,+          supportsLongCacheRetention = False,+          supportsSamplingParameters = False,+          supportedReasoningEfforts = Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax]+        } --- | Curation include set for Anthropic: the current generations.-anthropicInclude :: Set Text+-- | Curation include set for Anthropic: the current generations, each+-- keyed to the request-shaping facts of its generation.+--+-- This is the one place a human vets an Anthropic id, so it is also the+-- one place the facts are stated: no id can be curated in without them,+-- and a wholesale refresh cannot lose them. Each entry MUST carry a+-- dated comment naming its source, exactly as 'overrides' does. The+-- generator refuses an @anthropic-messages@ entry that reaches it+-- without a @compat@ block, so a hand edit cannot quietly drop one+-- back to host auto-detection.+anthropicInclude :: Map Text AnthropicGenerationFacts anthropicInclude =-  Set.fromList-    [ "claude-opus-4-8",-      "claude-opus-4-7",-      "claude-opus-4-6",-      "claude-opus-4-5",-      "claude-sonnet-5",-      "claude-sonnet-4-6",-      "claude-sonnet-4-5",-      "claude-haiku-4-5",-      "claude-fable-5"+  Map.fromList+    [ -- 2026-08-27: adaptive-only, sampling parameters rejected with a+      -- 400 — Anthropic API reference cached 2026-06-24, as consulted+      -- by REV-2 C.1 (docs/reviews/correctness-and-api-review-follow-up.md).+      -- docs/plans/60-... named this id as the one the include set did not+      -- yet carry, and stated the facts it would have to arrive with.+      ("claude-opus-5", fastAdaptive),+      -- 2026-08-27: adaptive-only, sampling parameters rejected with a+      -- 400 — same source.+      ("claude-opus-4-8", fastAdaptive),+      -- 2026-08-27: adaptive-only, sampling parameters rejected — same source.+      ("claude-opus-4-7", adaptiveNoSampling),+      -- 2026-08-27: accepts both thinking shapes, but the budget shape is+      -- deprecated for this generation, so baikai sends the adaptive one;+      -- sampling parameters still accepted — same source.+      ("claude-opus-4-6", adaptiveWithSampling),+      -- 2026-08-27: budget shape, sampling parameters accepted — same source.+      ("claude-opus-4-5", budgetWithSampling),+      -- 2026-08-27: adaptive-only, sampling parameters rejected with a 400.+      -- This is the finding: the retired prefix table did not know this id+      -- and sent it budget_tokens — same source.+      ("claude-sonnet-5", adaptiveNoSampling),+      -- 2026-08-27: as claude-opus-4-6 — budget deprecated but functional,+      -- sampling accepted; baikai prefers the non-deprecated shape — same+      -- source. Plan 40 left this membership to a live check that never+      -- happened; docs/plans/60-... M4 is where it meets a real key.+      ("claude-sonnet-4-6", adaptiveWithSampling),+      -- 2026-08-27: budget shape, sampling parameters accepted — same source.+      ("claude-sonnet-4-5", budgetWithSampling),+      -- 2026-08-27: budget shape, sampling parameters accepted — same source.+      ("claude-haiku-4-5", budgetWithSampling),+      -- 2026-08-27: adaptive-only, sampling parameters rejected — same source.+      ("claude-fable-5", adaptiveNoSampling),+      -- 2026-09-07: always-on adaptive thinking; omit sampling parameters.+      -- https://platform.claude.com/docs/en/models/fable-5-1/whats-new-fable-5-1+      ("claude-fable-5-1", adaptiveNoSampling & #supportsForcedToolChoice .~ False)     ]+  where+    -- 2026-09-07: all curated predecessors accept forced choice (subject to+    -- their separate manual-thinking constraint); only Fable 5.1 rejects it.+    -- https://platform.claude.com/docs/en/api/errors+    -- https://platform.claude.com/docs/en/models/fable-5-1/migration-guide+    -- 2026-09-07: Opus 5 and 4.8 only; cache multipliers stack on fast rates.+    -- https://platform.claude.com/docs/en/build-with-claude/fast-mode+    fastAdaptive = adaptiveNoSampling & #fastModeCost ?~ CatalogCost 10 50 1 12.5+    adaptiveNoSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive False True Nothing+    adaptiveWithSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive True True Nothing+    budgetWithSampling = AnthropicGenerationFacts AnthropicThinkingBudget True True Nothing --- | Provider spec for OpenAI's first-party chat-completions endpoint.+-- | OpenAI curation with a Chat default and explicit Responses overrides. openaiSpec :: ProviderSpec openaiSpec =   ProviderSpec     { provider = "openai",       baseUrl = "https://api.openai.com",       api = "openai-chat-completions",-      include = (`Set.member` openaiInclude)+      include = (`Map.member` openaiInclude),+      apiFor = \mid -> case Map.lookup mid openaiInclude >>= id of+        Just (CatalogResponsesCompat _) -> Just "openai-responses"+        _ -> Nothing,+      compatFor = \mid -> Map.lookup mid openaiInclude >>= id     }  -- | Provider spec for Anthropic's first-party messages endpoint.@@ -285,7 +385,9 @@     { provider = "anthropic",       baseUrl = "https://api.anthropic.com",       api = "anthropic-messages",-      include = (`Set.member` anthropicInclude)+      include = (`Map.member` anthropicInclude),+      apiFor = const Nothing,+      compatFor = fmap CatalogAnthropicCompat . (`Map.lookup` anthropicInclude)     }  -- | Normalize one provider's upstream models into a 'Catalog'. Keeps@@ -324,8 +426,14 @@                 cacheReadCost = fromMaybe 0 (m ^. #cacheReadCost),                 cacheWriteCost = fromMaybe 0 (m ^. #cacheWriteCost)               },+          fastModeCost = case (spec ^. #compatFor) (m ^. #modelId) of+            Just (CatalogAnthropicCompat facts) -> facts ^. #fastModeCost+            _ -> Nothing,+          pricingPolicy = Map.lookup (spec ^. #provider, m ^. #modelId) pricingPolicies,           contextWindow = fromMaybe 0 (m ^. #contextWindow),-          maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens)+          maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens),+          apiOverride = (spec ^. #apiFor) (m ^. #modelId),+          compat = (spec ^. #compatFor) (m ^. #modelId)         }  -- | Strip a trailing @" (latest)"@ display-name suffix that models.dev@@ -500,13 +608,84 @@     "        \"cacheWrite\": " <> renderNum (c ^. #cacheWriteCost),     "      },",     "      \"contextWindow\": " <> Text.pack (show (m ^. #contextWindow)) <> ",",-    "      \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> ",",-    "      \"enabled\": true",-    "    }"+    "      \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> ","   ]+    ++ maybe [] (\a -> ["      \"api\": " <> jsonString a <> ","]) (m ^. #apiOverride)+    ++ maybe [] (\r -> ["      \"fastModeCost\": " <> renderFastCost r <> ","]) (m ^. #fastModeCost)+    ++ maybe [] (\p -> ["      \"pricingPolicy\": " <> renderPricingPolicy p <> ","]) (m ^. #pricingPolicy)+    ++ renderModelCompat (m ^. #compat)+    ++ [ "      \"enabled\": true",+         "    }"+       ]   where     c = m ^. #cost +-- | Provider documentation verified 2026-09-07. These rules supplement base+-- models.dev rates, which do not describe the full request billing policy.+-- https://developers.openai.com/api/docs/models/gpt-6-astra+-- https://platform.claude.com/docs/en/models/fable-5-1/overview+-- https://platform.claude.com/docs/en/build-with-claude/fast-mode+pricingPolicies :: Map (Text, Text) Model.PricingPolicy+pricingPolicies =+  Map.fromList+    [ (("anthropic", "claude-opus-5"), Model.PricingPolicy [] (Just 10)),+      (("anthropic", "claude-opus-4-8"), Model.PricingPolicy [] (Just 10)),+      (("openai", "gpt-6-astra"), Model.PricingPolicy [Model.InputPriceTier 272000 (Model.ModelCost 20 75 2 25)] Nothing),+      (("anthropic", "claude-fable-5-1"), Model.PricingPolicy [] (Just 20))+    ]++renderPricingPolicy :: Model.PricingPolicy -> Text+renderPricingPolicy p = "{\"inputTiers\": [" <> Text.intercalate ", " (map tier (Model.inputTiers p)) <> "]" <> maybe "" (\r -> ", \"longCacheWriteCost\": " <> num r) (Model.longCacheWriteCost p) <> "}"+  where+    num = renderNum . fst . fromRationalRepetendUnlimited+    tier t = "{\"inputAbove\": " <> Text.pack (show (Model.inputAbove t)) <> ", \"rates\": " <> rates (Model.rates t) <> "}"+    rates c = "{\"input\": " <> num (Model.inputCost c) <> ", \"output\": " <> num (Model.outputCost c) <> ", \"cacheRead\": " <> num (Model.cacheReadCost c) <> ", \"cacheWrite\": " <> num (Model.cacheWriteCost c) <> "}"++-- | Render the per-model @compat@ block, if the provider spec supplied+-- one. The block sits between @maxOutputTokens@ and @enabled@ so a+-- @git diff@ over the catalog shows a generation's wire facts next to+-- its limits.+renderModelCompat :: Maybe CatalogModelCompat -> [Text]+renderModelCompat Nothing = []+renderModelCompat (Just (CatalogAnthropicCompat facts)) =+  [ "      \"compat\": {",+    "        \"kind\": \"anthropic-messages\",",+    "        \"thinkingStyle\": "+      <> jsonString (renderThinkingStyle (facts ^. #thinkingStyle))+      <> ",",+    "        \"supportsSamplingParameters\": "+      <> jsonBool (facts ^. #supportsSamplingParameters)+      <> ",",+    "        \"supportsFastMode\": " <> jsonBool (maybe False (const True) (facts ^. #fastModeCost)) <> ",",+    "        \"supportsForcedToolChoice\": " <> jsonBool (facts ^. #supportsForcedToolChoice),+    "      },"+  ]+renderModelCompat (Just (CatalogOpenAICompat facts)) =+  [ "      \"compat\": {",+    "        \"kind\": \"openai-completions\",",+    "        \"supportsToolCalls\": " <> jsonBool (facts ^. #supportsToolCalls) <> ",",+    "        \"supportsSamplingParameters\": " <> jsonBool (facts ^. #supportsSamplingParameters) <> ",",+    "        \"supportedReasoningEfforts\": " <> maybe "null" (\xs -> "[" <> Text.intercalate ", " (map (jsonString . renderThinkingLevel) xs) <> "]") (facts ^. #supportedReasoningEfforts),+    "      },"+  ]+renderModelCompat (Just (CatalogResponsesCompat facts)) =+  [ "      \"compat\": {",+    "        \"kind\": \"openai-responses\",",+    "        \"supportsSamplingParameters\": " <> jsonBool (facts ^. #supportsSamplingParameters) <> ",",+    "        \"supportsLongCacheRetention\": " <> jsonBool (facts ^. #supportsLongCacheRetention) <> ",",+    "        \"supportsPromptCacheOptions\": " <> jsonBool (facts ^. #supportsPromptCacheOptions) <> ",",+    "        \"supportedReasoningEfforts\": " <> maybe "null" (\xs -> "[" <> Text.intercalate ", " (map (jsonString . renderThinkingLevel) xs) <> "]") (facts ^. #supportedReasoningEfforts),+    "      },"+  ]++-- | The catalog dialect spells the thinking style as a word, as every+-- other catalog enum does. The derived JSON instance on+-- 'Baikai.Compat.AnthropicThinkingStyle' is part of 'Baikai.Model.Model'\'s+-- pinned round trip and is deliberately not reused here.+renderThinkingStyle :: AnthropicThinkingStyle -> Text+renderThinkingStyle AnthropicThinkingBudget = "budget"+renderThinkingStyle AnthropicThinkingAdaptive = "adaptive"+ renderInput :: [InputModality] -> Text renderInput ms = "[" <> Text.intercalate ", " (map one ms) <> "]"   where@@ -527,3 +706,6 @@ -- control characters, quotes, and backslashes follow the JSON encoder exactly. jsonString :: Text -> Text jsonString = decodeUtf8 . LBS.toStrict . encode . String++renderFastCost :: CatalogCost -> Text+renderFastCost c = "{\"input\": " <> renderNum (c ^. #inputCost) <> ", \"output\": " <> renderNum (c ^. #outputCost) <> ", \"cacheRead\": " <> renderNum (c ^. #cacheReadCost) <> ", \"cacheWrite\": " <> renderNum (c ^. #cacheWriteCost) <> "}"
gen/GenModels.hs view
@@ -34,7 +34,8 @@ import Data.Text qualified as Text import Data.Text.IO qualified as TIO import GenModelsCore-  ( checkIdentifierCollisions,+  ( checkAnthropicCompat,+    checkIdentifierCollisions,     flattenEntries,     renderModule,   )@@ -56,6 +57,9 @@       Right c -> pure c   let allEntries = concatMap flattenEntries catalogs   case checkIdentifierCollisions allEntries of+    Left err -> die (Text.unpack err)+    Right () -> pure ()+  case checkAnthropicCompat allEntries of     Left err -> die (Text.unpack err)     Right () -> pure ()   let sorted = sortOn fst allEntries
gen/GenModelsCore.hs view
@@ -14,6 +14,8 @@     GeneratedEntry (..),     flattenEntries,     checkIdentifierCollisions,+    checkAnthropicCompat,+    parseAnthropicThinkingStyle,     sanitizeIdentifier,     renderModule,   )@@ -24,7 +26,10 @@   ( AnthropicMessagesCompat       ( sendSessionAffinityHeaders,         supportsCacheControlOnTools,+        supportsFastMode,+        supportsForcedToolChoice,         supportsLongCacheRetention,+        supportsSamplingParameters,         thinkingStyle       ),     AnthropicThinkingStyle (..),@@ -34,19 +39,27 @@       ( cacheControlFormat,         maxTokensField,         requiresThinkingAsText,+        supportedReasoningEfforts,         supportsLongCacheRetention,+        supportsSamplingParameters,         supportsStrictMode,+        supportsToolCalls,         supportsUsageInStreaming,         thinkingFormat       ),+    OpenAIResponsesCompat (..),     ThinkingFormat (..),     defaultAnthropicMessagesCompat,     defaultOpenAICompletionsCompat,+    defaultOpenAIResponsesCompat,   ) import Baikai.Model (InputModality (..))+import Baikai.Model qualified as Model+import Baikai.ThinkingLevel (parseThinkingLevel) import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types (Parser, typeMismatch)+import Data.List (nub, sort) import Data.Map.Strict qualified as Map import Data.Ratio (denominator, numerator) import Data.Scientific (Scientific)@@ -74,12 +87,14 @@       <*> o .: "compat"       <*> o .: "models" --- | A compat directive in the catalog. @"auto"@ defers to EP-5's--- @baseUrl@-driven auto-detection (rendered as 'CompatNone'). The two+-- | A compat directive in the catalog. @"auto"@ defers to the+-- provider's @baseUrl@-driven auto-detection (rendered as+-- 'CompatNone'). The two -- structured constructors carry a full override record. data CatalogCompat   = CatalogCompatAuto   | CatalogCompatOpenAI !OpenAICompletionsCompat+  | CatalogCompatResponses !OpenAIResponsesCompat   | CatalogCompatAnthropic !AnthropicMessagesCompat   deriving stock (Show) @@ -91,12 +106,26 @@       case kind of         "openai-completions" ->           CatalogCompatOpenAI <$> parseOpenAICompat o+        "openai-responses" -> CatalogCompatResponses <$> parseResponsesCompat o         "anthropic-messages" ->           CatalogCompatAnthropic <$> parseAnthropicCompat o         _ ->           fail $ "CatalogCompat: unknown kind " <> show kind     v -> typeMismatch "CatalogCompat (expected \"auto\" or {\"kind\": ...})" v +parseResponsesCompat :: Aeson.Object -> Parser OpenAIResponsesCompat+parseResponsesCompat o = do+  let d = defaultOpenAIResponsesCompat+  raw <- o .:? "supportedReasoningEfforts"+  efforts <- traverse (traverse (\t -> maybe (fail "Unknown reasoning effort") pure (parseThinkingLevel t))) raw+  case efforts of+    Just xs | null xs || xs /= sort (nub xs) -> fail "supportedReasoningEfforts must be nonempty, unique and ordered"+    _ -> pure ()+  sampling <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters+  long <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention+  modern <- o .:? "supportsPromptCacheOptions" .!= d.supportsPromptCacheOptions+  pure d {supportedReasoningEfforts = efforts, supportsSamplingParameters = sampling, supportsLongCacheRetention = long, supportsPromptCacheOptions = modern}+ parseOpenAICompat :: Aeson.Object -> Parser OpenAICompletionsCompat parseOpenAICompat o = do   let d = defaultOpenAICompletionsCompat@@ -107,9 +136,19 @@   ccf <- optionalMaybeField o "cacheControlFormat" parseCacheControlFormat (cacheControlFormat d)   sus <- o .:? "supportsUsageInStreaming" .!= d.supportsUsageInStreaming   slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention+  stc <- o .:? "supportsToolCalls" .!= d.supportsToolCalls+  ssp <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters+  rawEfforts <- o .:? "supportedReasoningEfforts"+  efforts <- traverse (traverse (\t -> maybe (fail "Unknown reasoning effort") pure (parseThinkingLevel t))) rawEfforts+  case efforts of+    Just xs | null xs || xs /= sort (nub xs) -> fail "supportedReasoningEfforts must be nonempty, unique and ordered"+    _ -> pure ()   pure     d-      { maxTokensField = mtf,+      { supportsToolCalls = stc,+        supportsSamplingParameters = ssp,+        supportedReasoningEfforts = efforts,+        maxTokensField = mtf,         supportsStrictMode = sst,         requiresThinkingAsText = rtat,         thinkingFormat = tf,@@ -124,15 +163,32 @@   slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention   scot <- o .:? "supportsCacheControlOnTools" .!= d.supportsCacheControlOnTools   ssah <- o .:? "sendSessionAffinityHeaders" .!= d.sendSessionAffinityHeaders-  ts <- o .:? "thinkingStyle" .!= d.thinkingStyle+  ts <- optionalField o "thinkingStyle" parseAnthropicThinkingStyle d.thinkingStyle+  ssp <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters+  fast <- o .:? "supportsFastMode" .!= False+  forced <- o .:? "supportsForcedToolChoice" .!= d.supportsForcedToolChoice   pure     d       { supportsLongCacheRetention = slcr,         supportsCacheControlOnTools = scot,         sendSessionAffinityHeaders = ssah,-        thinkingStyle = ts+        thinkingStyle = ts,+        supportsSamplingParameters = ssp,+        supportsFastMode = fast,+        supportsForcedToolChoice = forced       } +-- | The catalog dialect spells the extended-thinking wire shape as a+-- word, as every other catalog enum does, rather than through the+-- derived instance on 'AnthropicThinkingStyle' (which is part of+-- 'Baikai.Model.Model'\'s pinned JSON round trip and names the Haskell+-- constructor).+parseAnthropicThinkingStyle :: Text -> Parser AnthropicThinkingStyle+parseAnthropicThinkingStyle = \case+  "budget" -> pure AnthropicThinkingBudget+  "adaptive" -> pure AnthropicThinkingAdaptive+  t -> fail $ "unknown thinkingStyle: " <> Text.unpack t+ parseMaxTokensField :: Text -> Parser MaxTokensField parseMaxTokensField = \case   "max_tokens" -> pure MaxTokensField@@ -187,10 +243,13 @@     entryReasoning :: !Bool,     entryInput :: ![InputModality],     entryCost :: !CostEntry,+    entryFastModeCost :: !(Maybe CostEntry),+    entryPricingPolicy :: !(Maybe Model.PricingPolicy),     entryContextWindow :: !Natural,     entryMaxOutputTokens :: !Natural,     entryEnabled :: !Bool,-    entryCompatOverride :: !(Maybe CatalogCompat)+    entryCompatOverride :: !(Maybe CatalogCompat),+    entryApiOverride :: !(Maybe Api)   }  instance FromJSON ModelEntry where@@ -201,10 +260,13 @@       <*> o .:? "reasoning" .!= False       <*> (o .: "input" >>= traverse parseInputModality)       <*> o .: "cost"+      <*> o .:? "fastModeCost"+      <*> (o .:? "pricingPolicy" >>= traverse parsePricingPolicy)       <*> o .: "contextWindow"       <*> o .: "maxOutputTokens"       <*> o .:? "enabled" .!= True       <*> o .:? "compat"+      <*> (fmap parseApi <$> o .:? "api")  parseInputModality :: Text -> Parser InputModality parseInputModality = \case@@ -223,13 +285,33 @@   }  instance FromJSON CostEntry where-  parseJSON = Aeson.withObject "CostEntry" $ \o ->-    CostEntry-      <$> o .: "input"-      <*> o .: "output"-      <*> o .:? "cacheRead" .!= 0-      <*> o .:? "cacheWrite" .!= 0+  parseJSON = Aeson.withObject "CostEntry" $ \o -> do+    c <-+      CostEntry+        <$> o .: "input"+        <*> o .: "output"+        <*> o .:? "cacheRead" .!= 0+        <*> o .:? "cacheWrite" .!= 0+    if all (>= 0) [costInput c, costOutput c, costCacheRead c, costCacheWrite c]+      then pure c+      else fail "Cost rates must be nonnegative" +-- | Catalog prices use decimal numbers; runtime policy rates are exact rationals.+parsePricingPolicy :: Aeson.Value -> Parser Model.PricingPolicy+parsePricingPolicy = Aeson.withObject "PricingPolicy" $ \o -> do+  tiers <- o .:? "inputTiers" .!= [] >>= traverse parseTier+  long <- fmap toRational <$> (o .:? "longCacheWriteCost" :: Parser (Maybe Scientific))+  let policy = Model.PricingPolicy tiers long+  either (fail . Text.unpack) (const (pure policy)) (Model.validatePricingPolicy policy)+  where+    parseTier = Aeson.withObject "InputPriceTier" $ \o ->+      Model.InputPriceTier <$> o .: "inputAbove" <*> (o .: "rates" >>= parseCompleteRates)+    parseCompleteRates = Aeson.withObject "Complete tier rates" $ \o ->+      toModelCost <$> (CostEntry <$> o .: "input" <*> o .: "output" <*> o .: "cacheRead" <*> o .: "cacheWrite")++toModelCost :: CostEntry -> Model.ModelCost+toModelCost c = Model.ModelCost (toRational (costInput c)) (toRational (costOutput c)) (toRational (costCacheRead c)) (toRational (costCacheWrite c))+ -- * Flattening ---------------------------------------------------------  -- | One generated Haskell identifier plus the 'Model'-shaped record@@ -245,6 +327,8 @@     reasoning :: !Bool,     input :: ![InputModality],     cost :: !CostEntry,+    fastModeCost :: !(Maybe CostEntry),+    pricingPolicy :: !(Maybe Model.PricingPolicy),     contextWindow :: !Natural,     maxOutputTokens :: !Natural,     compat :: !CatalogCompat@@ -261,12 +345,14 @@                 sanitizeIdentifier (c.provider <> "_" <> entryId m),               modelId = entryId m,               name = entryName m,-              api = c.api,+              api = maybe c.api id (entryApiOverride m),               provider = c.provider,               baseUrl = c.baseUrl,               reasoning = entryReasoning m,               input = entryInput m,               cost = entryCost m,+              fastModeCost = entryFastModeCost m,+              pricingPolicy = entryPricingPolicy m,               contextWindow = entryContextWindow m,               maxOutputTokens = entryMaxOutputTokens m,               compat =@@ -299,6 +385,37 @@         <> Text.intercalate ", " (map origin (reverse es))     origin e = e.provider <> "/" <> e.modelId +-- | Every @anthropic-messages@ entry must state its thinking style and+-- sampling support explicitly. An entry left at the file-level+-- @"compat": "auto"@ directive would fall through to host+-- auto-detection, which knows the host but cannot know the model+-- generation — the drift that sent @claude-sonnet-5@ a @budget_tokens@+-- request the generation rejects. The generator refuses rather than+-- guessing, so a hand edit to @baikai/data/models/anthropic.json@ that+-- drops a block fails the build instead of shipping.+checkAnthropicCompat :: [(Text, GeneratedEntry)] -> Either Text ()+checkAnthropicCompat entries =+  case [e | (_, e) <- entries, e.api == AnthropicMessages, not (stated e.compat)] of+    [] -> case [e | (_, e) <- entries, fastSupported e /= maybe False (const True) e.fastModeCost] of+      [] -> Right ()+      bad -> Left ("fast-mode capability and rates disagree: " <> Text.intercalate ", " (map modelId bad))+    missing -> Left (Text.intercalate "; " (map complain missing))+  where+    fastSupported e = case e.compat of+      CatalogCompatAnthropic c -> c.supportsFastMode+      _ -> False+    stated = \case+      CatalogCompatAnthropic _ -> True+      _ -> False+    complain e =+      "anthropic-messages entry "+        <> e.provider+        <> "/"+        <> e.modelId+        <> " has no compat block; add {\"kind\":\"anthropic-messages\""+        <> ",\"thinkingStyle\":\"budget\"|\"adaptive\""+        <> ",\"supportsSamplingParameters\":true|false}"+ -- | Replace any non-identifier character with @_@. Haskell allows -- letters, digits, underscore, and apostrophe; everything else -- (slash, dash, dot, colon, ...) becomes an underscore.@@ -342,32 +459,60 @@         "",         "import Baikai.Api (Api (..))",         "import Baikai.Compat",-        "  ( AnthropicThinkingStyle (..),",+        "  ( AnthropicMessagesCompat",+        "      ( sendSessionAffinityHeaders,",+        "        supportsCacheControlOnTools,",+        "        supportsFastMode,",+        "        supportsForcedToolChoice,",+        "        supportsLongCacheRetention,",+        "        supportsSamplingParameters,",+        "        thinkingStyle",+        "      ),",+        "    AnthropicThinkingStyle (..),",         "    CacheControlFormat (..),",         "    MaxTokensField (..),",+        "    OpenAICompletionsCompat",+        "      ( cacheControlFormat,",+        "        maxTokensField,",+        "        requiresThinkingAsText,",+        "        supportedReasoningEfforts,",+        "        supportsLongCacheRetention,",+        "        supportsSamplingParameters,",+        "        supportsStrictMode,",+        "        supportsToolCalls,",+        "        supportsUsageInStreaming,",+        "        thinkingFormat",+        "      ),",+        "    OpenAIResponsesCompat (..),",         "    ThinkingFormat (..),",         "    defaultAnthropicMessagesCompat,",         "    defaultOpenAICompletionsCompat,",+        "    defaultOpenAIResponsesCompat,",         "  )",         "import Baikai.Model",         "  ( Compat (..),",         "    InputModality (..),",+        "    InputPriceTier (..),",         "    Model,",         "    ModelCost (..),",+        "    PricingPolicy (..),",         "    api,",         "    baseUrl,",         "    compat,",         "    contextWindow,",         "    cost,",         "    emptyModel,",+        "    fastModeCost,",         "    headers,",         "    input,",         "    maxOutputTokens,",         "    modelId,",         "    name,",+        "    pricingPolicy,",         "    provider,",         "    reasoning,",         "  )",+        "import Baikai.ThinkingLevel (ThinkingLevel (..))",         "import Data.Map.Strict qualified as Map",         "import Data.Ratio ((%))",         ""@@ -406,13 +551,16 @@     "      input = " <> renderInputList g.input <> ",",     "      cost =",     renderCost g.cost <> ",",+    renderFastCost g.fastModeCost,+    "      pricingPolicy = " <> renderPolicy g.pricingPolicy <> ",",     "      contextWindow = " <> Text.pack (show g.contextWindow) <> ",",     "      maxOutputTokens = " <> Text.pack (show g.maxOutputTokens) <> ",",-    "      headers = Map.empty,",-    "      compat = " <> renderCompat g.compat,-    "    }",-    ""+    "      headers = Map.empty,"   ]+    ++ renderCompat g.compat+    ++ [ "    }",+         ""+       ]  renderText :: Text -> Text renderText t =@@ -434,6 +582,7 @@ renderApiCtor :: Api -> Text renderApiCtor = \case   OpenAIChatCompletions -> "OpenAIChatCompletions"+  OpenAIResponses -> "OpenAIResponses"   AnthropicMessages -> "AnthropicMessages"   OpenAICompletionsCli -> "OpenAICompletionsCli"   AnthropicMessagesCli -> "AnthropicMessagesCli"@@ -451,38 +600,66 @@       "          }"     ] +renderPolicy :: Maybe Model.PricingPolicy -> Text+renderPolicy Nothing = "Nothing"+renderPolicy (Just p) = "Just (PricingPolicy [" <> Text.intercalate ", " (map tier (Model.inputTiers p)) <> "] " <> maybe "Nothing" (\r -> "(Just (" <> renderRational r <> "))") (Model.longCacheWriteCost p) <> ")"+  where+    tier t = "InputPriceTier " <> Text.pack (show (Model.inputAbove t)) <> " (" <> rates (Model.rates t) <> ")"+    rates c = "ModelCost " <> Text.unwords (map (\r -> "(" <> renderRational r <> ")") [Model.inputCost c, Model.outputCost c, Model.cacheReadCost c, Model.cacheWriteCost c])+ renderRational :: Rational -> Text renderRational r =   Text.pack (show (numerator r)) <> " % " <> Text.pack (show (denominator r)) -renderCompat :: CatalogCompat -> Text+-- | The @compat@ field of one rendered entry, as source lines.+--+-- The layout is the one @ormolu@ produces, because the repository+-- formatter runs over the generated module and @CatalogSpec@ demands+-- the generator's output be byte-identical to the committed file: a+-- layout the formatter would rewrite makes those two checks+-- contradict each other.+renderCompat :: CatalogCompat -> [Text] renderCompat = \case-  CatalogCompatAuto -> "CompatNone"+  CatalogCompatAuto -> ["      compat = CompatNone"]   CatalogCompatOpenAI c ->-    Text.intercalate-      "\n"-      [ "CompatOpenAICompletions",-        "        defaultOpenAICompletionsCompat",-        "          { maxTokensField = " <> renderMaxTokensField c.maxTokensField <> ",",-        "            supportsStrictMode = " <> renderBool c.supportsStrictMode <> ",",-        "            requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",",-        "            thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",",-        "            cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",",-        "            supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",",-        "            supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention,-        "          }"-      ]+    [ "      compat =",+      "        CompatOpenAICompletions",+      "          defaultOpenAICompletionsCompat",+      "            { maxTokensField = " <> renderMaxTokensField c.maxTokensField <> ",",+      "              supportsStrictMode = " <> renderBool c.supportsStrictMode <> ",",+      "              requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",",+      "              thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",",+      "              cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",",+      "              supportsToolCalls = " <> renderBool c.supportsToolCalls <> ",",+      "              supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",",+      "              supportedReasoningEfforts = " <> maybe "Nothing" (\xs -> "Just [" <> Text.intercalate ", " (map (Text.pack . show) xs) <> "]") c.supportedReasoningEfforts <> ",",+      "              supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",",+      "              supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention,+      "            }"+    ]+  CatalogCompatResponses c ->+    [ "      compat =",+      "        CompatOpenAIResponses",+      "          defaultOpenAIResponsesCompat",+      "            { supportedReasoningEfforts = " <> maybe "Nothing" (\xs -> "Just [" <> Text.intercalate ", " (map (Text.pack . show) xs) <> "]") c.supportedReasoningEfforts <> ",",+      "              supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",",+      "              supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",",+      "              supportsPromptCacheOptions = " <> renderBool c.supportsPromptCacheOptions,+      "            }"+    ]   CatalogCompatAnthropic c ->-    Text.intercalate-      "\n"-      [ "CompatAnthropicMessages",-        "        defaultAnthropicMessagesCompat",-        "          { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",",-        "            supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",",-        "            sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",",-        "            thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle,-        "          }"-      ]+    [ "      compat =",+      "        CompatAnthropicMessages",+      "          defaultAnthropicMessagesCompat",+      "            { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",",+      "              supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",",+      "              sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",",+      "              thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle <> ",",+      "              supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",",+      "              supportsFastMode = " <> renderBool c.supportsFastMode <> ",",+      "              supportsForcedToolChoice = " <> renderBool c.supportsForcedToolChoice,+      "            }"+    ]  renderMaxTokensField :: MaxTokensField -> Text renderMaxTokensField = \case@@ -508,3 +685,19 @@ renderMaybeCacheControl = \case   Nothing -> "Nothing"   Just CacheControlFormatAnthropic -> "Just CacheControlFormatAnthropic"++renderFastCost :: Maybe CostEntry -> Text+renderFastCost Nothing = "      fastModeCost = Nothing,"+renderFastCost (Just c) =+  Text.intercalate+    "\n"+    [ "      fastModeCost =",+      "        Just",+      "          ( ModelCost",+      "              { inputCost = " <> renderRational (toRational (costInput c)) <> ",",+      "                outputCost = " <> renderRational (toRational (costOutput c)) <> ",",+      "                cacheReadCost = " <> renderRational (toRational (costCacheRead c)) <> ",",+      "                cacheWriteCost = " <> renderRational (toRational (costCacheWrite c)),+      "              }",+      "          ),"+    ]
src/Baikai.hs view
@@ -19,6 +19,7 @@     module Baikai.AgentAssets,     module Baikai.Api,     module Baikai.Auth,+    module Baikai.Header,     module Baikai.Model,     module Baikai.Content,     module Baikai.StopReason,@@ -30,10 +31,13 @@     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     module Baikai.Compat,+    module Baikai.Speed,     module Baikai.CacheRetention,     module Baikai.ResponseFormat,     module Baikai.ThinkingLevel,@@ -56,6 +60,9 @@ import Baikai.Context import Baikai.Cost import Baikai.Error+import Baikai.Evidence+import Baikai.Evidence.Build+import Baikai.Header import Baikai.Interactive import Baikai.Message import Baikai.Model@@ -63,6 +70,7 @@ import Baikai.Provider import Baikai.Response import Baikai.ResponseFormat+import Baikai.Speed import Baikai.StopReason import Baikai.Stream import Baikai.Stream.Event
+ src/Baikai/Agent.hs view
@@ -0,0 +1,872 @@+-- | 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,+    AgentOutputFormat (..),+    renderAgentOutputFormat,+    parseAgentOutputFormat,+    AgentCapturedOutput (..),+    capturedBytes,++    -- * The unattended run request+    AgentRunRequest+      ( provider,+        prompt,+        modelId,+        effort,+        workingDir,+        extraDirs,+        safety,+        timeout,+        output,+        outputFormat,+        outputLimit,+        envRequires+      ),+    agentRunRequest,++    -- * The operator policy ceiling+    AgentCeiling+      ( maxCapability,+        allowProviderArgs,+        allowedProviders,+        allowedTools,+        maxTimeout,+        maxOutputLimit+      ),+    defaultAgentCeiling,+    defaultMaxOutputLimit,+    toolGrantsImpliedBy,+    CeilingViolation (..),+    renderCeilingViolation,+    applyAgentCeiling,+    ceilingViolations,++    -- * The rendered command+    AgentPromptTransport (..),+    AgentCommand (..),++    -- * The run result+    AgentRunResult (provider, exitCode, stdout, stderr, duration),+    agentRunResult,+    AgentRunOutcome (..),+    agentRunOutcome,++    -- * Failures+    AgentRenderError (..),+    renderAgentRenderError,+    AgentRunFailure (..),+    AgentTimedOut (..),+    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,+    -- | Tools this run is __granted__ — pre-approved — beyond what the+    -- capability's permission mode approves on its own. This is a+    -- widening, not a narrowing: on Claude Code the list renders as+    -- @--allowedTools@, whose help reads \"list of tool names to+    -- allow\", so @allowedTools = [\"Bash\"]@ under an+    -- @edit-workspace@ capability pre-approves shell access that the+    -- permission mode would otherwise have raised a request for, and in+    -- an unattended run a request nobody answers is denied. An empty+    -- list grants nothing beyond the mode, which is the default. Codex+    -- has no equivalent flag and its renderer refuses a non-empty list.+    --+    -- Because a grant is authority, an operator ceiling bounds it: see+    -- 'toolGrantsImpliedBy' and 'AgentCeiling.allowedTools'. The+    -- narrowing flags Claude Code also has, @--tools@ and+    -- @--disallowedTools@, are not modelled here.+    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 grants+-- beyond what the capability implies 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++-- | What shape the coding agent should print its final answer in.+--+-- Distinct from 'AgentOutputMode', which says /where/ the bytes go. This+-- says what they are.+--+-- * 'TextFormat': whatever the tool prints by default, meant for a+--   person. Both tools default to it and Baikai renders no flag.+-- * 'JsonFormat': one machine-readable result. Claude Code renders+--   @--output-format json@ and @codex exec@ renders @--json@; both are+--   the shapes Baikai's own output readers already parse, so this is+--   the setting that lets an evidence record observe the session+--   identifier, the model and the token usage of a run.+--+-- Asking for it through the raw-argument channel used to be the only+-- way, which meant an operator had to open a privileged channel to get+-- a record — the opposite of what the ceiling is for.+data AgentOutputFormat+  = TextFormat+  | JsonFormat+  deriving stock (Eq, Ord, Show, Generic)++renderAgentOutputFormat :: AgentOutputFormat -> Text+renderAgentOutputFormat TextFormat = "text"+renderAgentOutputFormat JsonFormat = "json"++-- | Parse a canonical output-format name. Matching is exact and+-- case-sensitive.+parseAgentOutputFormat :: Text -> Maybe AgentOutputFormat+parseAgentOutputFormat "text" = Just TextFormat+parseAgentOutputFormat "json" = Just JsonFormat+parseAgentOutputFormat _ = 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,+    -- | What shape the tool should print its final answer in.+    outputFormat :: !AgentOutputFormat,+    -- | 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.+    envRequires :: ![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 in the tool's own text format, 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,+      outputFormat = TextFormat,+      outputLimit = Nothing,+      envRequires = []+    }++-- | 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],+    -- | Tool grants the operator permits beyond the ones+    -- 'toolGrantsImpliedBy' the maximum capability already allows.+    -- Matching is exact on the whole string, so granting @\"Bash\"@+    -- does not permit @\"Bash(git *)\"@ and vice versa: a job asks for+    -- exactly the spelling the operator wrote, or it is refused.+    allowedTools :: ![Text],+    -- | The longest wall-clock limit any job may request. 'Nothing'+    -- permits an unlimited run, which is the default. A finite maximum+    -- also refuses a job that requests __no__ timeout at all, because a+    -- maximum defeated by omitting the setting is not a maximum.+    maxTimeout :: !(Maybe NominalDiffTime),+    -- | The largest per-stream output capture any job may request.+    -- 'Nothing' permits @output-limit \"unlimited\"@.+    maxOutputLimit :: !(Maybe Int)+  }+  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],+      allowedTools = [],+      maxTimeout = Nothing,+      maxOutputLimit = Just defaultMaxOutputLimit+    }++-- | The largest per-stream output capture the default ceiling permits:+-- sixty-four mebibytes, sixteen times the per-stream default a job gets+-- when it mentions no limit at all.+--+-- Concrete rather than unbounded because the memory belongs to the host+-- the operator owns, not to the repository that wrote the job: a+-- checkout writing @output-limit \"unlimited\"@ is asking to buffer an+-- entire runaway agent in the operator's address space, and it should+-- have to ask the operator rather than help itself. Sixty-four+-- mebibytes is far more than any real run prints, so a job that hits+-- it has gone wrong.+defaultMaxOutputLimit :: Int+defaultMaxOutputLimit = 67108864++-- | The tool grants a capability implies on its own, or 'Nothing' when+-- the capability implies every grant.+--+-- The names are Claude Code's built-in tools at version 2.1.247. The+-- lists are deliberately short and fail closed: a tool name that is not+-- listed here can only ever be refused unless the maximum capability is+-- 'AgentFullAccess' or the operator names it in+-- 'AgentCeiling.allowedTools', so a coding agent that grows a new tool+-- can never widen an existing ceiling by accident.+--+-- @Bash@ is absent from every finite list on purpose. It runs arbitrary+-- commands, which is what 'AgentFullAccess' means; a job that wants it+-- under a lesser capability needs the operator to say so.+toolGrantsImpliedBy :: AgentCapability -> Maybe [Text]+toolGrantsImpliedBy AgentReadOnly = Just readTools+toolGrantsImpliedBy AgentEditWorkspace = Just (readTools <> editTools)+toolGrantsImpliedBy AgentFullAccess = Nothing++-- | Grants that read but change nothing.+readTools :: [Text]+readTools = ["Read", "Glob", "Grep", "NotebookRead", "TodoWrite"]++-- | Grants that change files, which 'AgentEditWorkspace' adds to+-- 'readTools'.+editTools :: [Text]+editTools = ["Edit", "MultiEdit", "Write", "NotebookEdit"]++-- | 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]+  | -- | The requested tool grants that are not permitted, then the+    -- maximum capability in force. A grant is authority, so the+    -- capability is named: it is what decides which grants are implied+    -- without the operator writing anything.+    ToolGrantForbidden ![Text] !AgentCapability+  | -- | The requested wall-clock limit ('Nothing' is \"no limit\"),+    -- then the permitted maximum.+    TimeoutExceeded !(Maybe NominalDiffTime) !NominalDiffTime+  | -- | The requested per-stream capture ('Nothing' is @unlimited@),+    -- then the permitted maximum in bytes.+    OutputLimitExceeded !(Maybe Int) !Int+  | -- | The leaf name of a setting only operator scope may supply, for+    -- example @executable@, that a repository file supplied.+    --+    -- Unlike every other violation this one is about /where/ a value+    -- came from rather than what it was, so 'applyAgentCeiling' cannot+    -- produce it: that function sees a request, not the provenance of+    -- each field. It is produced by the configuration layer, which+    -- reads provenance from the resolution report, and is carried in+    -- the same list so an operator sees one refusal.+    RepositoryScopeForbidden !Text+  | -- | The working directory a repository file asked for, after+    -- resolving symbolic links, then the repository root it must lie+    -- inside.+    WorkingDirOutsideRepository !FilePath !FilePath+  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)+renderCeilingViolation (ToolGrantForbidden grants permitted) =+  "tool grants "+    <> Text.intercalate ", " grants+    <> " are not permitted under the maximum capability "+    <> renderAgentCapability permitted+    <> "; add them to policy.allowed-tools in the operator file or raise \+       \policy.max-capability"+renderCeilingViolation (TimeoutExceeded Nothing permitted) =+  "the job sets no timeout, and the permitted maximum is "+    <> renderCeilingDuration permitted+renderCeilingViolation (TimeoutExceeded (Just requested) permitted) =+  "the requested timeout "+    <> renderCeilingDuration requested+    <> " exceeds the permitted maximum "+    <> renderCeilingDuration permitted+renderCeilingViolation (OutputLimitExceeded Nothing permitted) =+  "output-limit unlimited exceeds the permitted maximum "+    <> Text.pack (show permitted)+    <> " bytes"+renderCeilingViolation (OutputLimitExceeded (Just requested) permitted) =+  "the requested output-limit "+    <> Text.pack (show requested)+    <> " exceeds the permitted maximum "+    <> Text.pack (show permitted)+    <> " bytes"+renderCeilingViolation (RepositoryScopeForbidden name) =+  "the repository configuration set "+    <> name+    <> ", which only the operator file or the command line may set"+renderCeilingViolation (WorkingDirOutsideRepository resolved root) =+  "the working directory "+    <> Text.pack resolved+    <> " lies outside the repository "+    <> Text.pack root++-- | A duration in one of the spellings the configuration layer's+-- @timeout@ parser accepts, so a refusal names a value an operator can+-- paste straight back into @policy.max-timeout@. @show@ on a+-- 'NominalDiffTime' prints @7200s@, which that parser does accept but+-- which no operator writes.+renderCeilingDuration :: NominalDiffTime -> Text+renderCeilingDuration value+  | seconds > 0, seconds `mod` 3600 == 0 = spell (seconds `div` 3600) "h"+  | seconds > 0, seconds `mod` 60 == 0 = spell (seconds `div` 60) "m"+  | otherwise = spell seconds "s"+  where+    seconds :: Integer+    seconds = truncate value+    spell magnitude unit = Text.pack (show magnitude) <> unit++-- | 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.+--+-- Two violations this function never produces are+-- 'RepositoryScopeForbidden' and 'WorkingDirOutsideRepository'. Both+-- depend on which configuration file supplied a value, and a request+-- carries no provenance; the configuration layer produces them and+-- concatenates them with this function's list, so a caller sees one+-- refusal naming everything at once.+applyAgentCeiling :: AgentCeiling -> AgentRunRequest -> Either [CeilingViolation] AgentRunRequest+applyAgentCeiling limit request+  | null violations = Right request+  | otherwise = Left violations+  where+    violations = ceilingViolations limit request++-- | Every way a request exceeds a ceiling, as a list a caller can+-- concatenate with the provenance-dependent violations the+-- configuration layer produces. 'applyAgentCeiling' is this function+-- plus the decision to return the request unchanged when the list is+-- empty.+ceilingViolations :: AgentCeiling -> AgentRunRequest -> [CeilingViolation]+ceilingViolations limit request =+  concat+    [ [ ProviderForbidden requestedProvider permittedProviders+      | requestedProvider `notElem` permittedProviders+      ],+      [ CapabilityExceeded requestedCapability permittedCapability+      | requestedCapability > permittedCapability+      ],+      [ ProviderArgsForbidden requestedArgs+      | not (null requestedArgs),+        not (limit ^. #allowProviderArgs)+      ],+      [ ToolGrantForbidden forbiddenGrants permittedCapability+      | not (null forbiddenGrants)+      ],+      [ TimeoutExceeded requestedTimeout permittedTimeout+      | Just permittedTimeout <- [limit ^. #maxTimeout],+        maybe True (> permittedTimeout) requestedTimeout+      ],+      [ OutputLimitExceeded requestedOutputLimit permittedLimit+      | Just permittedLimit <- [limit ^. #maxOutputLimit],+        maybe True (> permittedLimit) requestedOutputLimit+      ]+    ]+  where+    requestedProvider = request ^. #provider+    permittedProviders = limit ^. #allowedProviders+    requestedCapability = request ^. #safety . #capability+    permittedCapability = limit ^. #maxCapability+    requestedArgs = request ^. #safety . #providerArgs+    requestedTimeout = request ^. #timeout+    requestedOutputLimit = request ^. #outputLimit+    -- A capability implying every grant permits the whole list; any+    -- other capability permits its implied names plus whatever the+    -- operator granted, matched exactly.+    forbiddenGrants = case toolGrantsImpliedBy permittedCapability of+      Nothing -> []+      Just implied ->+        [ grant+        | grant <- request ^. #safety . #allowedTools,+          grant `notElem` implied,+          grant `notElem` (limit ^. #allowedTools)+        ]++-- | 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 @\<stdin\>@ 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.+-- Construction: the constructor is deliberately not exported. Start+-- from 'agentRunResult' and override fields by record update.+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)++-- | What a run that hit its deadline left behind.+--+-- The limit is the one that was configured, not the slightly larger+-- elapsed time, because the caller asked for a limit and wants to be+-- told which one was hit.+--+-- The two streams are whatever was drained before the process group was+-- killed. A timed-out run is precisely the run an operator most wants to+-- read: the tool started, may have consumed tokens, and may already have+-- changed the working tree, and the bytes it printed on the way are the+-- only account of that. Under 'InheritOutput' those bytes went to the+-- parent's terminal and both fields are 'OutputNotCaptured'.+data AgentTimedOut = AgentTimedOut+  { -- | The configured limit the run exceeded.+    limit :: !NominalDiffTime,+    -- | Standard output drained before the group was killed.+    stdout :: !AgentCapturedOutput,+    -- | Standard error drained before the group was killed.+    stderr :: !AgentCapturedOutput+  }+  deriving stock (Eq, Show, Generic)++-- | 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 its limit. Its whole process group was+    -- interrupted, then terminated, then killed; what each stream+    -- drained before the kill is carried along.+    RunTimedOut !AgentTimedOut+  | -- | Every variable named in the request's 'envRequires' 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 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 timedOut) =+  "the run exceeded its timeout of " <> Text.pack (show (timedOut ^. #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 (EvidenceRefused reasons) =+  "refused before starting, because this run cannot produce the evidence it \+  \required: "+    <> Text.intercalate "; " reasons
src/Baikai/AgentAssets.hs view
@@ -26,6 +26,7 @@   ) import Baikai.Prelude import Data.Text qualified as Text+import Text.Printf (printf)  -- | Asset helpers use the same provider vocabulary as interactive -- launchers: Claude Code and Codex are the local provider families.@@ -129,17 +130,56 @@   where     appendSegment acc segment = acc <> "/" <> segment +-- | A TOML /basic/ string: quotation mark, backslash, and every control+-- character escaped, as TOML 1.0 requires. A basic string interprets+-- backslash escapes, so an unescaped control character in one is a+-- parse error rather than a stray byte. tomlString :: Text -> Text-tomlString t =-  "\"" <> Text.concatMap escape t <> "\""-  where-    escape '"' = "\\\""-    escape '\\' = "\\\\"-    escape '\n' = "\\n"-    escape '\r' = "\\r"-    escape '\t' = "\\t"-    escape c = Text.singleton c+tomlString t = "\"" <> Text.concatMap escapeBasic t <> "\"" +-- | One character inside a TOML basic string.+--+-- The six named escapes are the ones TOML spells; everything else below+-- U+0020, and U+007F, takes the @\\uXXXX@ form. Nothing above that is+-- escaped: TOML basic strings are Unicode, and escaping more would only+-- make the file harder to read.+escapeBasic :: Char -> Text+escapeBasic = \case+  '"' -> "\\\""+  '\\' -> "\\\\"+  '\b' -> "\\b"+  '\t' -> "\\t"+  '\n' -> "\\n"+  '\f' -> "\\f"+  '\r' -> "\\r"+  c+    | c < ' ' || c == '\DEL' -> Text.pack (printf "\\u%04X" (fromEnum c))+    | otherwise -> Text.singleton c++-- | The instructions body of a Codex custom agent.+--+-- Rendered as a TOML /literal/ multi-line string — three apostrophes,+-- interpreting nothing — so the Markdown a human opens in+-- @.codex\/agents\/*.toml@ is the Markdown that was written, backslashes+-- intact. Rendered as a /basic/ string instead, every backslash in the+-- body starts an escape sequence, so a body containing @\\d+@ made Codex+-- refuse to load the file.+--+-- A literal string cannot contain three apostrophes, a bare carriage+-- return, or any control character other than tab and newline, so such a+-- body falls back to a fully escaped basic string rather than being+-- refused. Escaping every quotation mark there guarantees the closing+-- delimiter cannot appear inside, and escaping every backslash means no+-- line-ending backslash can silently swallow the next line's+-- indentation. tomlMultilineString :: Text -> Text-tomlMultilineString t =-  "\"\"\"\n" <> Text.replace "\"\"\"" "\\\"\\\"\\\"" t <> "\n\"\"\""+tomlMultilineString t+  | literalSafe = "\'\'\'\n" <> t <> "\n\'\'\'"+  | otherwise = "\"\"\"\n" <> Text.concatMap escapeMultiline t <> "\n\"\"\""+  where+    literalSafe = not ("\'\'\'" `Text.isInfixOf` t) && Text.all literalChar t+    literalChar c = c == '\t' || c == '\n' || (c >= ' ' && c /= '\DEL')+    -- A raw newline is allowed inside a multi-line basic string and+    -- keeps the body readable; everything else follows the basic rules.+    escapeMultiline '\n' = "\n"+    escapeMultiline c = escapeBasic c
src/Baikai/Api.hs view
@@ -17,6 +17,7 @@   ( Api (..),     renderApi,     parseApi,+    normaliseApi,   ) where @@ -27,6 +28,7 @@ -- | The supported upstream API surfaces, plus an open escape hatch. data Api   = OpenAIChatCompletions+  | OpenAIResponses   | AnthropicMessages   | OpenAICompletionsCli   | AnthropicMessagesCli@@ -36,6 +38,7 @@ -- | Render an 'Api' tag as its canonical kebab-cased wire string. renderApi :: Api -> Text renderApi = \case+  OpenAIResponses -> "openai-responses"   OpenAIChatCompletions -> "openai-chat-completions"   AnthropicMessages -> "anthropic-messages"   OpenAICompletionsCli -> "openai-completions-cli"@@ -46,11 +49,24 @@ -- 'Custom' values so callers can use the same tag space. parseApi :: Text -> Api parseApi = \case+  "openai-responses" -> OpenAIResponses   "openai-chat-completions" -> OpenAIChatCompletions   "anthropic-messages" -> AnthropicMessages   "openai-completions-cli" -> OpenAICompletionsCli   "anthropic-messages-cli" -> AnthropicMessagesCli   t -> Custom t++-- | Collapse a 'Custom' tag that spells a built-in API onto that+-- constructor, so @Custom "anthropic-messages"@ and 'AnthropicMessages'+-- are one registry key. Every other value is returned unchanged.+--+-- The registry normalises both the key it stores and the tag it is asked+-- for, so a handler registered under either spelling answers a model+-- tagged with the other. Derived 'Eq' and 'Ord' are deliberately left+-- alone: changing them would silently rearrange every @Map Api@ a+-- consumer holds.+normaliseApi :: Api -> Api+normaliseApi = parseApi . renderApi  instance ToJSON Api where   toJSON = toJSON . renderApi
src/Baikai/Auth.hs view
@@ -11,21 +11,32 @@     defaultApiKeyEnvForBaseUrl,     renderApiKeySourceForDebug,     resolveApiKey,++    -- * Redacting credentials that travel in headers+    redactedMarker,+    isCredentialHeader,+    redactHeaderValues,   ) where -import Baikai.Compat (hostMatchesSuffix, urlHost) import Baikai.Error (authError)+import Baikai.Header (HeaderName, renderHeaderName)+import Baikai.Url (hostMatchesSuffix, urlHost) import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (ToJSON (toJSON), object, (.=))+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text import System.Environment qualified as Environment  data ApiKeySource   = ApiKeyLiteral !Text-  | ApiKeyEnv !String+  | -- | 'String' rather than 'Text' because+    -- 'System.Environment.lookupEnv' takes one; converting here would+    -- only move the conversion to every call site.+    ApiKeyEnv !String   | ApiKeyEnvChain ![String]   deriving stock (Eq) @@ -71,35 +82,95 @@       | hostMatchesSuffix host "fireworks.ai" = Just "FIREWORKS_API_KEY"       | otherwise = Nothing +-- | What baikai prints where a credential would otherwise appear.+--+-- One marker everywhere, so a reader who has seen it once in an+-- @ApiKeyLiteral@ recognises it in a header map.+redactedMarker :: Text+redactedMarker = "<redacted>"++-- | Whether a header name carries a credential, by convention.+--+-- Case-insensitive, and deliberately generous: it matches+-- @authorization@, @api-key@, @apikey@, @token@, @secret@, @cookie@ and+-- @password@ anywhere in the name, and any name ending in @-key@. That+-- over-matches — a header called @x-idempotency-key@ prints as the+-- marker — and over-matching is the safe direction, because this only+-- decides what is /printed/. The header itself is untouched and is still+-- sent exactly as the caller wrote it.+isCredentialHeader :: Text -> Bool+isCredentialHeader name =+  any (`Text.isInfixOf` lowered) needles || "-key" `Text.isSuffixOf` lowered+  where+    lowered = Text.toLower (Text.strip name)+    needles =+      [ "authorization",+        "api-key",+        "apikey",+        "token",+        "secret",+        "cookie",+        "password"+      ]++-- | Replace the value of every credential-carrying header with+-- 'redactedMarker', leaving the names and every other value alone.+redactHeaderValues :: Map HeaderName Text -> Map HeaderName Text+redactHeaderValues =+  Map.mapWithKey+    ( \name value ->+        if isCredentialHeader (renderHeaderName name) then redactedMarker else value+    )+ -- | Render a credential source for logs, test failures, and debugging without -- exposing literal secret material. renderApiKeySourceForDebug :: ApiKeySource -> Text-renderApiKeySourceForDebug (ApiKeyLiteral _) = "ApiKeyLiteral <redacted>"+renderApiKeySourceForDebug (ApiKeyLiteral _) = "ApiKeyLiteral " <> redactedMarker renderApiKeySourceForDebug (ApiKeyEnv name) =   "ApiKeyEnv " <> Text.pack (show name) renderApiKeySourceForDebug (ApiKeyEnvChain names) =   "ApiKeyEnvChain " <> Text.pack (show names)  -- | Resolve a key source to a plain 'Text'. Throws a 'BaikaiError' in the--- 'Baikai.Error.AuthError' category if 'ApiKeyEnv' is used and the named variable--- is unset.+-- 'Baikai.Error.AuthError' category when no variable yields a key.+--+-- A variable whose value is empty, or is only whitespace, counts as+-- __unset__. An empty key can never authenticate, so reporting it here+-- as an error that names the variable is strictly better than sending+-- @Authorization: Bearer @ and reading a provider's 401 back. A+-- non-empty value is passed through exactly as it was set, whitespace+-- and all: trimming a real key would be a different behaviour change,+-- and one that could silently break a key with a meaningful edge+-- character. resolveApiKey :: (MonadIO m) => ApiKeySource -> m Text resolveApiKey (ApiKeyLiteral t) = pure t resolveApiKey (ApiKeyEnv name) =   liftIO $-    Environment.lookupEnv name >>= \case-      Just v -> pure (Text.pack v)-      Nothing -> throwIO (authError ("env var " <> Text.pack name <> " is not set"))+    lookupNonEmptyEnv name >>= \case+      Just v -> pure v+      Nothing ->+        throwIO+          (authError ("env var " <> Text.pack name <> " is not set or is empty")) resolveApiKey (ApiKeyEnvChain names) =   liftIO (go names)   where     go [] =       throwIO-        (authError ("none of the env vars " <> renderedNames <> " are set"))-    go (name : rest) =-      Environment.lookupEnv name >>= \case-        Just v -> pure (Text.pack v)-        Nothing -> go rest+        ( authError+            ( "none of the env vars "+                <> renderedNames+                <> " are set (an empty value counts as unset)"+            )+        )+    go (name : rest) = lookupNonEmptyEnv name >>= maybe (go rest) pure     renderedNames = case names of       [] -> "<empty>"       _ -> Text.intercalate ", " (Text.pack <$> names)++-- | 'Environment.lookupEnv' that treats a blank value as absent.+lookupNonEmptyEnv :: String -> IO (Maybe Text)+lookupNonEmptyEnv name = do+  found <- Environment.lookupEnv name+  pure $ case found of+    Just raw | not (Text.null (Text.strip (Text.pack raw))) -> Just (Text.pack raw)+    _ -> Nothing
src/Baikai/CacheRetention.hs view
@@ -1,10 +1,12 @@ -- | Provider-agnostic prompt-cache retention preference. ----- Each provider maps the value to its own primitive: Anthropic's--- 'long' becomes @cache_control.ttl: "1h"@, 'short' becomes the--- ephemeral marker with no TTL; OpenAI Responses API's 'long' would--- become 24h. Hosts that do not advertise prompt caching ignore the--- preference.+-- Each provider maps the value to its own primitive: on Anthropic,+-- 'CacheRetentionLong' becomes @cache_control.ttl: "1h"@ and+-- 'CacheRetentionShort' the ephemeral marker with no TTL. The+-- OpenAI-compatible provider emits Anthropic-style markers only where+-- the host's compat record sets+-- 'Baikai.Compat.cacheControlFormat'; hosts that do not advertise+-- prompt caching under a marker ignore the preference. module Baikai.CacheRetention   ( CacheRetention (..),   )@@ -19,9 +21,9 @@     CacheRetentionNone   | -- | Provider-default ephemeral retention (Anthropic: 5 minutes).     CacheRetentionShort-  | -- | Long-retention bucket (Anthropic: @ttl: "1h"@; OpenAI-    --   Responses: 24h). Downgrades to short on hosts that report-    --   'supportsLongCacheRetention' as 'False'.+  | -- | Long-retention bucket (Anthropic: @ttl: "1h"@). Downgrades to+    --   short on hosts that report 'supportsLongCacheRetention' as+    --   'False'.     CacheRetentionLong   deriving stock (Eq, Show, Generic)   deriving anyclass (FromJSON, ToJSON)
src/Baikai/Compat.hs view
@@ -21,7 +21,10 @@ -- -- Auto-detection from a 'Baikai.Model.Model' @baseUrl@ provides -- reasonable defaults so callers rarely need to spell out a full--- compat record.+-- compat record. The host it detects on comes from "Baikai.Url", the+-- only place in baikai that turns a URL into a host name; 'urlHost' and+-- 'hostMatchesSuffix' are re-exported from here so a caller reasoning+-- about auto-detection has them to hand. module Baikai.Compat   ( -- * OpenAI Chat Completions compat     OpenAICompletionsCompat@@ -30,6 +33,9 @@         requiresThinkingAsText,         thinkingFormat,         cacheControlFormat,+        supportsToolCalls,+        supportsSamplingParameters,+        supportedReasoningEfforts,         supportsUsageInStreaming,         supportsLongCacheRetention       ),@@ -38,16 +44,22 @@     ThinkingFormat (..),     CacheControlFormat (..), +    -- * OpenAI Responses compat+    OpenAIResponsesCompat (supportedReasoningEfforts, supportsSamplingParameters, supportsLongCacheRetention, supportsPromptCacheOptions),+    defaultOpenAIResponsesCompat,+     -- * Anthropic Messages compat     AnthropicMessagesCompat       ( supportsLongCacheRetention,         supportsCacheControlOnTools,         sendSessionAffinityHeaders,-        thinkingStyle+        thinkingStyle,+        supportsFastMode,+        supportsForcedToolChoice,+        supportsSamplingParameters       ),     AnthropicThinkingStyle (..),     defaultAnthropicMessagesCompat,-    defaultAnthropicThinkingStyle,      -- * Auto-detection from baseUrl     urlHost,@@ -57,9 +69,10 @@   ) where -import Data.Aeson (FromJSON, ToJSON)+import Baikai.ThinkingLevel (ThinkingLevel)+import Baikai.Url (hostMatchesSuffix, urlHost)+import Data.Aeson (FromJSON (parseJSON), ToJSON, withObject, (.!=), (.:), (.:?)) import Data.Text (Text)-import Data.Text qualified as Text import GHC.Generics (Generic)  -- | Where the OpenAI-compatible host expects the max-output-tokens@@ -77,7 +90,20 @@ -- 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 level unless the model declares+    --   a restricted supportedReasoningEfforts vocabulary. Three of+    --   the other six — OpenRouter, DeepSeek and Together — 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. Z.ai and Qwen send a bare toggle with no+    --   depth, and 'ThinkingFormatNone' drops the control. Excluding+    --   this shape from the clamp is deliberate and is 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 +117,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)@@ -127,7 +155,7 @@     maxTokensField :: !MaxTokensField,     -- | Whether the host accepts @strict: true@ on function tool     --   definitions. Consumed by-    --   @Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat@ and+    --   @Baikai.Provider.OpenAI.Internal.Request.mkOpenAIResponseFormat@ and     --   @Baikai.Provider.OpenAI.Shape.dropUnsupportedStrict@ to     --   omit JSON-schema @strict@ on hosts that reject it.     supportsStrictMode :: !Bool,@@ -136,12 +164,12 @@     --   @\<thinking\>...\</thinking\>@ markers. Field-based reasoning     --   extraction (for @reasoning_content@ / @reasoning@ deltas) is     --   unconditional; this flag enables the incremental tag scanner-    --   in @Baikai.Provider.OpenAI.Api.translateTextLikeDelta@ for+    --   in @Baikai.Provider.OpenAI.Internal.Stream.scanThinkTags@ for     --   hosts that do not split reasoning into a separate field.     requiresThinkingAsText :: !Bool,     -- | The wire shape the host accepts for reasoning-effort     --   preferences. Consumed by-    --   @Baikai.Provider.OpenAI.Api.applyThinkingFormat@ for the+    --   @Baikai.Provider.OpenAI.Internal.Request.applyThinkingFormat@ for the     --   OpenAI-native field and by     --   @Baikai.Provider.OpenAI.Shape.injectThinkingShape@ for     --   OpenAI-compatible host-specific JSON keys.@@ -156,6 +184,12 @@     --   @Baikai.Provider.OpenAI.Shape.streamRequestBody@ to include     --   or omit @stream_options.include_usage@.     supportsUsageInStreaming :: !Bool,+    -- | Whether this endpoint accepts function tools for the model.+    supportsToolCalls :: !Bool,+    -- | Whether this model accepts sampling controls.+    supportsSamplingParameters :: !Bool,+    -- | Accepted effort levels in increasing order; Nothing is unconstrained.+    supportedReasoningEfforts :: !(Maybe [ThinkingLevel]),     -- | Whether the host honours long (1h) cache TTLs through the     --   Anthropic-style cache_control marker. Consumed by     --   @Baikai.Provider.OpenAI.Shape.injectCacheControl@ when@@ -175,15 +209,39 @@       thinkingFormat = ThinkingFormatOpenAI,       cacheControlFormat = Nothing,       supportsUsageInStreaming = True,+      supportsToolCalls = True,+      supportsSamplingParameters = True,+      supportedReasoningEfforts = Nothing,       supportsLongCacheRetention = True     } +-- | Model and endpoint facts for native Responses. This is separate+-- from Chat Completions: a host implementing one need not implement both.+data OpenAIResponsesCompat = OpenAIResponsesCompat+  { supportedReasoningEfforts :: !(Maybe [ThinkingLevel]),+    supportsSamplingParameters :: !Bool,+    supportsLongCacheRetention :: !Bool,+    -- | Use prompt_cache_options rather than legacy prompt_cache_retention.+    supportsPromptCacheOptions :: !Bool+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++defaultOpenAIResponsesCompat :: OpenAIResponsesCompat+defaultOpenAIResponsesCompat =+  OpenAIResponsesCompat+    { supportedReasoningEfforts = Nothing,+      supportsSamplingParameters = True,+      supportsLongCacheRetention = True,+      supportsPromptCacheOptions = False+    }+ -- | Feature flags for one Anthropic Messages-compatible host. data AnthropicMessagesCompat = AnthropicMessagesCompat   { -- | Whether the host honours Anthropic's     --   @cache_control.ttl: "1h"@ long-retention marker. When 'False',     --   long-retention preferences silently downgrade to ephemeral.-    --   Consumed by @Baikai.Provider.Claude.Api.computeCacheControl@+    --   Consumed by @Baikai.Provider.Claude.Internal.Request.computeCacheControl@     --   for top-level cache markers and by     --   @Baikai.Provider.Claude.Shape.injectToolCacheControl@ for     --   tool cache markers.@@ -198,12 +256,30 @@     --   @Baikai.Provider.Claude.Transport.requestHeaders@.     sendSessionAffinityHeaders :: !Bool,     -- | Which extended-thinking request shape to send for the-    --   selected model generation. Consumed by-    --   @Baikai.Provider.Claude.Api.computeThinking@.-    thinkingStyle :: !AnthropicThinkingStyle+    --   selected model generation. Which shape a generation accepts+    --   is a fact of the generated catalog record+    --   ("Baikai.Models.Generated"), not something to be guessed from+    --   the model id. Consumed by+    --   @Baikai.Provider.Claude.Internal.Request.computeThinking@.+    thinkingStyle :: !AnthropicThinkingStyle,+    -- | Whether the model generation accepts the sampling parameters+    --   @temperature@, @top_p@ and @top_k@. Adaptive-era generations+    --   from Opus 4.7 and Sonnet 5 onward reject them with a 400, so+    --   the Anthropic adapter drops them and records+    --   'Baikai.Evidence.SamplingDroppedUnsupportedModel'. Which+    --   generations accept them is a fact of the generated catalog+    --   record, not of this type. Consumed by+    --   @Baikai.Provider.Claude.Internal.Request.planRequest@.+    supportsSamplingParameters :: !Bool,+    -- | Whether this model accepts fast inference. Defaults to False;+    -- curated availability and premium rates must agree.+    supportsFastMode :: !Bool,+    -- | Whether this generation accepts required or named tool choice.+    -- Defaults to True; explicit catalog facts disable unsupported choices.+    supportsForcedToolChoice :: !Bool   }   deriving stock (Eq, Show, Generic)-  deriving anyclass (FromJSON, ToJSON)+  deriving anyclass (ToJSON)  -- | Anthropic's own host: every flag at its default. defaultAnthropicMessagesCompat :: AnthropicMessagesCompat@@ -212,21 +288,23 @@     { supportsLongCacheRetention = True,       supportsCacheControlOnTools = True,       sendSessionAffinityHeaders = False,-      thinkingStyle = AnthropicThinkingBudget+      thinkingStyle = AnthropicThinkingBudget,+      supportsSamplingParameters = True,+      supportsFastMode = False,+      supportsForcedToolChoice = True     } --- | The thinking style a first-party Anthropic model id defaults to--- when the model carries no explicit compat record. Unknown ids--- default to the budget style used by earlier model generations.-defaultAnthropicThinkingStyle :: Text -> AnthropicThinkingStyle-defaultAnthropicThinkingStyle modelId-  | adaptive "claude-opus-4-6" = AnthropicThinkingAdaptive-  | adaptive "claude-opus-4-7" = AnthropicThinkingAdaptive-  | adaptive "claude-opus-4-8" = AnthropicThinkingAdaptive-  | adaptive "claude-fable-5" = AnthropicThinkingAdaptive-  | otherwise = AnthropicThinkingBudget-  where-    adaptive prefix = prefix `Text.isPrefixOf` modelId+-- | Older persisted models predate fast-mode and forced-choice capabilities.+instance FromJSON AnthropicMessagesCompat where+  parseJSON = withObject "AnthropicMessagesCompat" $ \o ->+    AnthropicMessagesCompat+      <$> o .: "supportsLongCacheRetention"+      <*> o .: "supportsCacheControlOnTools"+      <*> o .: "sendSessionAffinityHeaders"+      <*> o .: "thinkingStyle"+      <*> o .: "supportsSamplingParameters"+      <*> o .:? "supportsFastMode" .!= False+      <*> o .:? "supportsForcedToolChoice" .!= True  -- | Pick a sensible compat record for an unknown OpenAI-compatible -- host based on its @baseUrl@. Falls back to@@ -287,27 +365,3 @@   where     host = urlHost url     matches suffix = maybe False (`hostMatchesSuffix` suffix) host---- | Extract a hostname from a URL-ish value. This is intentionally--- small and total rather than a validating URI parser: it drops an--- optional scheme, optional userinfo, then stops at '/', ':', '?', or--- '#'. Empty results return 'Nothing'.-urlHost :: Text -> Maybe Text-urlHost raw =-  let noScheme = case Text.breakOn "://" raw of-        (_, rest) | not (Text.null rest) -> Text.drop 3 rest-        _ -> raw-      noUser = last (Text.splitOn "@" noScheme)-      host = Text.toLower (Text.strip (Text.takeWhile hostChar noUser))-   in if Text.null host then Nothing else Just host-  where-    hostChar c = c /= '/' && c /= ':' && c /= '?' && c /= '#'---- | Match a hostname against a suffix at a label boundary.-hostMatchesSuffix :: Text -> Text -> Bool-hostMatchesSuffix host suffix =-  let h = Text.toLower (Text.strip host)-      s = Text.toLower (Text.strip suffix)-   in not (Text.null h)-        && not (Text.null s)-        && (h == s || ("." <> s) `Text.isSuffixOf` h)
src/Baikai/Content.hs view
@@ -9,8 +9,7 @@ -- invocation. For tool-result messages (a caller-supplied reply to a -- model-issued tool call) blocks can be text or image. ----- EP-1 introduces the types; EP-3 streams them, and EP-4 wires tool--- round-tripping through the providers. Image content is restricted to+-- Image content is restricted to -- inline base64 with an explicit @mimeType@: the caller is responsible -- for the (small, reversible) work of base64-encoding bytes once, and -- every provider can consume the same shape without a URL-fetch path@@ -19,6 +18,7 @@   ( -- * Block primitives     TextContent (..),     ThinkingContent (..),+    ThinkingReplay (..),     ToolCall (..),     ImageContent (..), @@ -27,18 +27,19 @@     AssistantContent (..),     ToolResultContent (..), +    -- * Tool-call arguments+    toolArgumentsFromText,+    isCutOffToolCall,+     -- * Smart defaults     emptyTextContent,     emptyThinkingContent,     emptyToolCall,     emptyImageContent,-    _TextContent,-    _ThinkingContent,-    _ToolCall,-    _ImageContent,   ) where +import Baikai.Api (Api) import Data.Aeson   ( FromJSON (parseJSON),     Options (..),@@ -52,14 +53,17 @@     object,     withObject,     (.:),+    (.:?),     (.=),   )+import Data.Aeson qualified as Aeson import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base64 qualified as Base64 import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text+import Data.Vector (Vector) import GHC.Generics (Generic)  -- | A plain-text block. The wire form is @{"text": "..."}@.@@ -80,13 +84,45 @@ data ThinkingContent = ThinkingContent   { thinking :: !Text,     signature :: !(Maybe Text),-    redacted :: !Bool+    redacted :: !Bool,+    -- | Provider-owned continuation, persisted but never rendered as text.+    replayState :: !(Maybe ThinkingReplay)   }   deriving stock (Eq, Show, Generic) +-- | Ordered opaque provider items needed to continue a reasoning turn.+-- The API and model identify where these items may be replayed. Providers+-- validate that scope before sending them. JSON persistence is lossless;+-- Show deliberately omits the opaque item payloads.+data ThinkingReplay = ThinkingReplay+  { replayApi :: !Api,+    replayModel :: !Text,+    replayItems :: !(Vector Value)+  }+  deriving stock (Eq, Generic)++instance Show ThinkingReplay where+  show _ = "ThinkingReplay <opaque>"++instance FromJSON ThinkingReplay where+  parseJSON = genericParseJSON snakeOptions++instance ToJSON ThinkingReplay where+  toJSON = genericToJSON snakeOptions+ -- | A model-issued tool invocation. @id_@ has a trailing underscore in -- Haskell to dodge a clash with @Prelude.id@; the JSON encoding strips -- it back to @id@.+--+-- @arguments@ is the decoded JSON value the model sent — normally an+-- object. A bare 'Data.Aeson.String' is the __cut-off marker__: the+-- model's argument stream was truncated (by the output cap, or by a+-- transport failure mid-call) and the raw text is kept verbatim rather+-- than replaced by something well-formed that the model never asked+-- for. 'isCutOffToolCall' is the predicate; 'toolArgumentsFromText' is+-- the one rule that produces it. A cut-off call must not be dispatched:+-- 'Baikai.Provider.Registry.runToolLoop' stops on one and+-- 'Baikai.Context.appendToolResult' reports it as a tool-result error. data ToolCall = ToolCall   { id_ :: !Text,     name :: !Text,@@ -94,6 +130,32 @@   }   deriving stock (Eq, Show, Generic) +-- | Turn a tool call's accumulated argument text into its @arguments@+-- value.+--+-- Empty text is an empty object: Anthropic opens a @tool_use@ block with+-- no input and streams no delta, and an empty object is exactly what the+-- model asked for. Non-empty text that does not decode is kept verbatim+-- as a 'Data.Aeson.String' — the call was cut off, and no byte of what+-- the model did send is dropped.+--+-- Both provider assemblers and core's stream-recovery path use this one+-- rule, so 'isCutOffToolCall' means the same thing at every layer.+-- Before it, the assemblers replaced malformed arguments with @{}@ and a+-- tool loop happily executed the call with no arguments at all.+toolArgumentsFromText :: Text -> Value+toolArgumentsFromText raw+  | Text.null (Text.strip raw) = Aeson.Object mempty+  | otherwise = case Aeson.eitherDecodeStrict (Text.encodeUtf8 raw) of+      Right v -> v+      Left _ -> Aeson.String raw++-- | 'True' when the call's argument stream was cut off: @arguments@ is+-- the raw text rather than a decoded value. See 'ToolCall'.+isCutOffToolCall :: ToolCall -> Bool+isCutOffToolCall ToolCall {arguments = Aeson.String _} = True+isCutOffToolCall _ = False+ -- | An inline image block. Bytes are stored decoded; the JSON encoding -- emits base64 under @data@ and the @mimeType@ camel-snakes to -- @mime_type@.@@ -130,7 +192,8 @@   ThinkingContent     { thinking = Text.empty,       signature = Nothing,-      redacted = False+      redacted = False,+      replayState = Nothing     }  emptyToolCall :: ToolCall@@ -154,10 +217,14 @@ snakeOptions = defaultOptions {fieldLabelModifier = camelTo2 '_'}  instance FromJSON ThinkingContent where-  parseJSON = genericParseJSON snakeOptions+  parseJSON = withObject "ThinkingContent" $ \o ->+    ThinkingContent <$> o .: "thinking" <*> o .:? "signature" <*> o .: "redacted" <*> o .:? "replay_state"  instance ToJSON ThinkingContent where-  toJSON = genericToJSON snakeOptions+  toJSON c =+    object $+      ["thinking" .= thinking c, "signature" .= signature c, "redacted" .= redacted c]+        <> maybe [] (\r -> ["replay_state" .= r]) (replayState c)  -- Strip the trailing underscore on @id_@ so the wire form is @id@; the -- other fields keep their natural names.@@ -216,19 +283,3 @@  instance ToJSON ToolResultContent where   toJSON = genericToJSON contentSumOptions--{-# DEPRECATED _TextContent "Use emptyTextContent instead." #-}-_TextContent :: TextContent-_TextContent = emptyTextContent--{-# DEPRECATED _ThinkingContent "Use emptyThinkingContent instead." #-}-_ThinkingContent :: ThinkingContent-_ThinkingContent = emptyThinkingContent--{-# DEPRECATED _ToolCall "Use emptyToolCall instead." #-}-_ToolCall :: ToolCall-_ToolCall = emptyToolCall--{-# DEPRECATED _ImageContent "Use emptyImageContent instead." #-}-_ImageContent :: ImageContent-_ImageContent = emptyImageContent
src/Baikai/Context.hs view
@@ -2,14 +2,14 @@ -- conversation: the optional system prompt, the message vector, and -- the declared tools the model may invoke. ----- 'Context' replaces the prior 'Baikai.Request.Request' record's--- conversation-related fields. The per-call knobs that previously--- lived alongside the messages (max tokens, temperature, API key)--- now live on 'Baikai.Options.Options' instead.+-- The per-call knobs — max tokens, temperature, API key — live on+-- 'Baikai.Options.Options' instead, so a conversation and the settings+-- it is dispatched with are separate values. ----- EP-4 adds the @tools@ field and the 'appendToolResult' helper--- that builds the follow-up request after the model invoked one or--- more tools. The helper lives here rather than in 'Baikai.Tool' so+-- The @tools@ field is on the context because the same tool set applies+-- to every turn, and so is 'appendToolResult', which builds the+-- follow-up request after the model invoked one or more tools. The+-- helper lives here rather than in 'Baikai.Tool' so -- that 'Baikai.Tool' can stay imports-light (the 'Tool' type is -- referenced by the @tools@ field, so 'Baikai.Tool' cannot itself -- depend on 'Context').@@ -19,7 +19,6 @@     messages,     tools,     emptyContext,-    _Context,     contextOf,     systemUser,     addUser,@@ -30,9 +29,9 @@   ) where -import Baikai.Content (AssistantContent (..), ToolCall (..))-import Baikai.Message (Message (..), ToolResult, toolResultFromCallNow, toolResultText, user)-import Baikai.Response (Response (..), responseMessage)+import Baikai.Content (AssistantContent (..), ToolCall (..), isCutOffToolCall)+import Baikai.Message (Message (..), ToolResult, toolResultErrorText, toolResultFromCallNow, toolResultText, user)+import Baikai.Response (Response (..), responseError, responseMessage) import Baikai.Tool (Tool) import Control.Applicative ((<|>)) import Control.Lens ((&), (.~), (^.))@@ -102,15 +101,36 @@ -- returned 'Context' is ready to drive the follow-up request that -- gives the model the tool results. ----- The dispatcher receives one 'ToolCall' at a time and returns a rich--- 'ToolResult' carrying text blocks, image blocks, and an error flag.--- Any error handling (timeouts, sandboxing, multi-call concurrency)--- lives in the dispatcher.+-- Calls are dispatched one at a time, in the order they appear, and the+-- dispatcher returns a rich 'ToolResult' carrying text blocks, image+-- blocks, and an error flag. Any timeout or sandboxing lives in the+-- dispatcher.+--+-- An __error-shaped response__ (one whose 'Baikai.Response.responseError'+-- is 'Just') appends nothing and dispatches nothing: the context comes+-- back unchanged. A failed call has no assistant turn worth replaying+-- and no tool calls to answer, and appending its empty message would put+-- a turn into the transcript that the model never took.+-- 'Baikai.Provider.Registry.runToolLoop' has always stopped on such a+-- response; the documented direct round trip in @docs\/user\/tools.md@+-- reaches here instead, and now behaves the same way.+--+-- A tool call cut off by the output cap+-- ('Baikai.Content.isCutOffToolCall') is __never dispatched__: its+-- arguments are the raw text the model got as far as sending, not a+-- request it finished making. It still gets a+-- 'Baikai.Message.ToolResultMessage', with @isError = True@ explaining+-- why, because a caller driving the exchange by hand expects one result+-- per call and must not silently lose the turn.+-- 'Baikai.Provider.Registry.runToolLoop' stops on such a response+-- instead of reaching here. appendToolResult ::   Context ->   Response ->   (ToolCall -> IO ToolResult) ->   IO Context+appendToolResult ctx resp _dispatcher+  | Just _ <- responseError resp = pure ctx appendToolResult ctx resp dispatcher = do   let respPayload = resp ^. #message       respMsg = responseMessage resp@@ -118,7 +138,10 @@   results <-     traverse       ( \tc -> do-          result <- dispatcher tc+          result <-+            if isCutOffToolCall tc+              then pure cutOffToolResult+              else dispatcher tc           toolResultFromCallNow tc result       )       toolCalls@@ -130,6 +153,13 @@                <> V.fromList results            ) +-- | What 'appendToolResult' reports instead of dispatching a call the+-- model never finished asking for.+cutOffToolResult :: ToolResult+cutOffToolResult =+  toolResultErrorText+    "tool call arguments were cut off by the output limit; the call was not dispatched — raise maxTokens and retry"+ -- | Text-only convenience wrapper for the common case where every -- tool call returns one successful text block. appendToolResultText ::@@ -139,7 +169,3 @@   IO Context appendToolResultText ctx resp dispatcher =   appendToolResult ctx resp (fmap toolResultText . dispatcher)--{-# DEPRECATED _Context "Use emptyContext instead." #-}-_Context :: Context-_Context = emptyContext
src/Baikai/Cost.hs view
@@ -1,18 +1,91 @@ module Baikai.Cost   ( Cost (..),     CostBreakdown (..),+    CostBasis (..),+    CostSource (..),+    CostEstimateReason (..),+    standardCostBasis,+    providerReportedBasis,+    estimateCost,+    nonEmptyBasis,     zeroCost,     zeroCostBreakdown,-    _Cost,-    _CostBreakdown,     usdAsScientific,   ) where -import Data.Aeson (ToJSON (toJSON), object, (.=))+import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, (.=))+import Data.Aeson qualified as Aeson import Data.Scientific (Scientific, fromRationalRepetendUnlimited)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text) import GHC.Generics (Generic) +-- | What the number represents; a standard token calculation is not an invoice.+data CostSource = StandardTokenRates | ResolvedTokenRates | ProviderReportedTotal+  deriving stock (Eq, Ord, Show, Generic)++data CostEstimateReason+  = UsageNotReported+  | InputUsageNotReported+  | OutputUsageNotReported+  | CacheReadUsageNotReported+  | CacheWriteUsageNotReported+  | InconsistentUsage+  | ServiceTierNotReported+  | UnsupportedServiceTier Text+  | SpeedNotReported+  | UnsupportedSpeed Text+  | ServiceTierMismatch Text Text+  | PricingUnavailable+  | InvalidPricingPolicy+  | CacheDurationNotReported+  | AdditionalChargesExcluded+  deriving stock (Eq, Ord, Show, Generic)++-- | Sources and estimation reasons survive aggregation by set union.+-- An empty basis belongs to the additive zero, not to an observed free call.+data CostBasis = CostBasis+  { sources :: !(Set CostSource),+    estimateReasons :: !(Set CostEstimateReason)+  }+  deriving stock (Eq, Show, Generic)++basisOptions :: Aeson.Options+basisOptions = Aeson.defaultOptions {Aeson.fieldLabelModifier = Aeson.camelTo2 '_', Aeson.constructorTagModifier = Aeson.camelTo2 '_'}++instance ToJSON CostSource where toJSON = Aeson.genericToJSON basisOptions++instance FromJSON CostSource where parseJSON = Aeson.genericParseJSON basisOptions++instance ToJSON CostEstimateReason where toJSON = Aeson.genericToJSON basisOptions++instance FromJSON CostEstimateReason where parseJSON = Aeson.genericParseJSON basisOptions++instance ToJSON CostBasis where toJSON = Aeson.genericToJSON basisOptions++instance FromJSON CostBasis where parseJSON = Aeson.genericParseJSON basisOptions++instance Semigroup CostBasis where+  a <> b = CostBasis (sources a <> sources b) (estimateReasons a <> estimateReasons b)++instance Monoid CostBasis where mempty = CostBasis Set.empty Set.empty++standardCostBasis :: CostBasis+standardCostBasis = CostBasis (Set.singleton StandardTokenRates) Set.empty++providerReportedBasis :: CostBasis+providerReportedBasis = CostBasis (Set.singleton ProviderReportedTotal) Set.empty++estimateCost :: [CostEstimateReason] -> Cost -> Cost+estimateCost reasons c = c {basis = basis c <> CostBasis Set.empty (Set.fromList reasons)}++-- | The additive zero carries no calculation facts. Omit that empty basis+-- when adding optional metadata to existing trace and log formats.+nonEmptyBasis :: Cost -> Maybe CostBasis+nonEmptyBasis c = if basis c == mempty then Nothing else Just (basis c)+ data CostBreakdown = CostBreakdown   { inputUsd :: !Rational,     outputUsd :: !Rational,@@ -23,7 +96,8 @@  data Cost = Cost   { usd :: !Rational,-    breakdown :: !CostBreakdown+    breakdown :: !CostBreakdown,+    basis :: !CostBasis   }   deriving stock (Eq, Show, Generic) @@ -37,7 +111,7 @@     }  zeroCost :: Cost-zeroCost = Cost {usd = 0, breakdown = zeroCostBreakdown}+zeroCost = Cost {usd = 0, breakdown = zeroCostBreakdown, basis = mempty}  -- Field-wise combination so callers can total per-call costs with -- '(<>)'/'mconcat'. 'mempty' reuses the existing zero value, so the@@ -56,7 +130,7 @@   mempty = zeroCostBreakdown  instance Semigroup Cost where-  a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b}+  a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b, basis = basis a <> basis b}  instance Monoid Cost where   mempty = zeroCost@@ -74,7 +148,8 @@   toJSON c =     object       [ "usd" .= ratToSci (usd c),-        "breakdown" .= breakdown c+        "breakdown" .= breakdown c,+        "basis" .= basis c       ]  usdAsScientific :: Cost -> Scientific@@ -82,11 +157,3 @@  ratToSci :: Rational -> Scientific ratToSci = fst . fromRationalRepetendUnlimited--{-# DEPRECATED _CostBreakdown "Use zeroCostBreakdown instead." #-}-_CostBreakdown :: CostBreakdown-_CostBreakdown = zeroCostBreakdown--{-# DEPRECATED _Cost "Use zeroCost instead." #-}-_Cost :: Cost-_Cost = zeroCost
src/Baikai/Cost/Log.hs view
@@ -8,15 +8,26 @@ -- The usual pattern is 'withCallLog', which opens a handle, runs -- the body, and flushes pending entries on the way out: ----- > withCallLog (CallLogConfig "/tmp/baikai.jsonl" True) $ \h -> do+-- > withCallLog (callLogConfig "/tmp/baikai.jsonl") $ \h -> do -- >   _ <- runRequestWithLog h model context options -- >   pure () -- -- If the worker cannot open or write the log file, the close path -- reports one warning on stderr and returns. Logging failures do not -- mask the request body or hang release actions.+--+-- 'closeCallLog' is idempotent: the first caller claims the handle,+-- writes the sentinel and waits for the worker; a second caller returns+-- at once rather than blocking forever on a worker that has already+-- finished. An 'appendEntry' after the close is a no-op, because the+-- worker that would have drained it is gone. The close wait itself is+-- unbounded, unlike the trace bridge's: the call log's purpose is+-- durability, its close runs once per process rather than once per+-- call, and its writer is a local file the operator chose rather than a+-- third-party fold. module Baikai.Cost.Log-  ( CallLogConfig (..),+  ( CallLogConfig (path, enabled),+    callLogConfig,     CallLogEntry (..),     CallLogHandle,     openCallLog,@@ -31,7 +42,8 @@  import Baikai.Content (TextContent (..), UserContent (..)) import Baikai.Context (Context)-import Baikai.Cost (usdAsScientific)+import Baikai.Cost (CostBasis, usdAsScientific)+import Baikai.Cost qualified as Cost import Baikai.Message   ( Message (..),     UserPayload (..),@@ -48,10 +60,10 @@ import Baikai.Usage qualified as Usage import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) import Control.Exception (SomeException, bracket, displayException, try) import Control.Lens ((^.))-import Control.Monad (forM_)+import Control.Monad (forM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON, ToJSON)@@ -60,7 +72,7 @@ import Data.Foldable (find) import Data.Function ((&)) import Data.Generics.Labels ()-import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Text qualified as Text@@ -73,15 +85,21 @@ import System.IO (BufferMode (LineBuffering), IOMode (AppendMode), hPutStrLn, hSetBuffering, stderr, withFile)  -- | Where (and whether) to write the call log.+--+-- Construction: the constructor is deliberately not exported. Start+-- from 'callLogConfig' and override fields by record update. data CallLogConfig = CallLogConfig   { path :: !FilePath,     enabled :: !Bool   }   deriving stock (Eq, Show, Generic) --- | One line of the JSONL call log. Wire shape preserved from EP-0:--- @cachedInputTokens@ keeps its name so existing log readers keep--- parsing.+-- | A call log at the given path, enabled.+callLogConfig :: FilePath -> CallLogConfig+callLogConfig logPath = CallLogConfig {path = logPath, enabled = True}++-- | One line of the JSONL call log. @cachedInputTokens@ keeps the name+-- it has always had on the wire, so existing log readers keep parsing. data CallLogEntry = CallLogEntry   { timestamp :: !UTCTime,     provider :: !Text,@@ -89,6 +107,9 @@     inputTokens :: !(Maybe Natural),     outputTokens :: !(Maybe Natural),     cachedInputTokens :: !(Maybe Natural),+    cacheWriteTokens :: !(Maybe Natural),+    costBasis :: !(Maybe CostBasis),+    usageAvailability :: !(Maybe Usage.UsageAvailability),     reasoningTokens :: !(Maybe Natural),     usd :: !(Maybe Scientific),     latencyMs :: !Int,@@ -102,7 +123,10 @@   { chan :: !(Chan (Maybe CallLogEntry)),     done :: !(MVar ()),     cfg :: !CallLogConfig,-    workerError :: !(IORef (Maybe SomeException))+    workerError :: !(IORef (Maybe SomeException)),+    -- | Claimed by the first 'closeCallLog'. A second close returns+    -- immediately and an 'appendEntry' after it enqueues nothing.+    closed :: !(IORef Bool)   }  -- | Open a handle. When @enabled = True@, fork the worker thread@@ -112,26 +136,36 @@   ch <- newChan   d <- newEmptyMVar   e <- newIORef Nothing+  cl <- newIORef False   case enabled c of     False -> putMVar d ()     True -> do       _ <- forkIO (worker (path c) ch d e)       pure ()-  pure CallLogHandle {chan = ch, done = d, cfg = c, workerError = e}+  pure CallLogHandle {chan = ch, done = d, cfg = c, workerError = e, closed = cl}  -- | Signal shutdown and block until the worker has drained every -- pending entry to disk.+--+-- Idempotent. The first caller claims the handle and does the work; a+-- second returns at once. Before the claim existed, a second close+-- blocked forever on an 'MVar' the worker had already emptied — which+-- 'withCallLog' made easy to hit, since its bracket closes a handle a+-- body may also have closed. 'readMVar' rather than 'takeMVar' for the+-- same reason: the slot stays filled. closeCallLog :: (MonadIO m) => CallLogHandle -> m () closeCallLog h = liftIO $ do-  case enabled (cfg h) of-    True -> writeChan (chan h) Nothing-    False -> pure ()-  takeMVar (done h)-  merr <- readIORef (workerError h)-  forM_ merr $ \e ->-    hPutStrLn-      stderr-      ("baikai: call log worker failed; pending entries were dropped: " <> displayException e)+  alreadyClosed <- atomicModifyIORef' (closed h) (\b -> (True, b))+  unless alreadyClosed $ do+    case enabled (cfg h) of+      True -> writeChan (chan h) Nothing+      False -> pure ()+    readMVar (done h)+    merr <- readIORef (workerError h)+    forM_ merr $ \e ->+      hPutStrLn+        stderr+        ("baikai: call log worker failed; pending entries were dropped: " <> displayException e)  -- | Bracketed lifetime: open the handle, run the body, close -- exactly once on every path (including exceptions).@@ -140,12 +174,16 @@   withRunInIO $ \run ->     bracket (openCallLog c) closeCallLog (run . body) --- | Non-blocking enqueue. When the handle is disabled, returns--- immediately without touching the channel.+-- | Non-blocking enqueue. When the handle is disabled, or has already+-- been closed, returns immediately without touching the channel — the+-- worker that would have drained the entry is gone, so enqueuing it+-- would only grow a channel nobody reads. appendEntry :: (MonadIO m) => CallLogHandle -> CallLogEntry -> m () appendEntry h entry   | not (enabled (cfg h)) = pure ()-  | otherwise = liftIO (writeChan (chan h) (Just entry))+  | otherwise = liftIO $ do+      isClosed <- readIORef (closed h)+      unless isClosed (writeChan (chan h) (Just entry))  -- | Dispatch through the registry, then (if logging is enabled) -- enqueue a single JSONL record summarizing the call.@@ -173,7 +211,6 @@   now <- liftIO getCurrentTime   let u :: Usage       u = (resp ^. #message) ^. #usage-      meaningfulCost = (Usage.cost u) ^. #usd > 0       entry =         CallLogEntry           { timestamp = now,@@ -182,8 +219,16 @@             inputTokens = positive (Usage.inputTokens u),             outputTokens = positive (Usage.outputTokens u),             cachedInputTokens = positive (Usage.cacheReadTokens u),+            cacheWriteTokens = Just (Usage.cacheWriteTokens u),+            costBasis = Cost.nonEmptyBasis (Usage.cost u),+            usageAvailability = Usage.availability 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           }
src/Baikai/Cost/Pricing.hs view
@@ -1,30 +1,102 @@ -- | Cost computation from a 'Baikai.Model.Model' and a 'Usage'. ----- The previous map-based lookup (@Map Text PricingRate@) is gone.--- Pricing rates live on 'Baikai.Model.Model.cost' directly, so the--- computation collapses to a record-field access. Models without--- published pricing carry a zero 'Baikai.Model.ModelCost' (the--- default in 'emptyModel'), producing a zero 'Cost'.+-- Base prices and optional context/duration policies live on the model.+-- Arithmetic stays exact, and unavailable pricing carries an estimate reason. module Baikai.Cost.Pricing   ( computeCost,+    computeCostAtSpeed,     attachCost,+    resolveRates,+    computeCostWith,+    computeCostForService,+    computeCostAtRates,   ) where -import Baikai.Cost (Cost (..), CostBreakdown (..))+import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Cost (Cost (..), CostBreakdown (..), CostEstimateReason (..), CostSource (..), estimateCost, standardCostBasis) import Baikai.Message (AssistantPayload (..))-import Baikai.Model (Model, ModelCost (..))+import Baikai.Model (InputPriceTier (..), Model, ModelCost (..), PricingPolicy (..), validatePricingPolicy, zeroModelCost) import Baikai.Prelude import Baikai.Response (Response (..))-import Baikai.Usage (Usage (..))+import Baikai.Speed (Speed (..))+import Baikai.Usage (BillingFact (..), Usage (..), UsageAvailability (..), UsageCategory (..))+import Data.Set qualified as Set  -- | Compute a 'Cost' from a model's per-million-token rates and a--- 'Usage'. Returns a zero 'Cost' when the model carries zero rates,--- which is the truthful signal for providers without published--- pricing (CLI providers, custom hosts).+-- 'Usage'. Zero rates retain the old numeric total and now mark pricing+-- unavailable. This entry point assumes the standard cache duration.+-- Use 'computeCostAtSpeed' to select premium speed rates explicitly. computeCost :: Model -> Usage -> Cost-computeCost m u =-  let rates = m ^. #cost+computeCost = computeCostWith Nothing++-- | Duration must be the value selected by request shaping, not merely+-- requested by the caller. Service-tier and usage availability are supplied+-- by adapters as estimation reasons on the resulting cost.+computeCostWith :: Maybe CacheRetention -> Model -> Usage -> Cost+computeCostWith duration m u = priceUsage (resolveRates duration m u) u++-- | Shared terminal pricing entry point. Observed tiers and speed come from+-- Usage availability, never from the caller's preference. Uncurated products+-- retain a standard-rate estimate with a specific reason.+computeCostForService :: Maybe CacheRetention -> Maybe Text -> Model -> Usage -> Cost+computeCostForService duration requested m u =+  let facts = maybe [] (Set.toList . billingFacts) (u ^. #availability)+      tiers = [t | BillingServiceTier t <- facts]+      speeds = [s | BillingSpeed s <- facts]+      reasons =+        [ServiceTierNotReported | null tiers]+          <> [AdditionalChargesExcluded | BillingServerToolUse `elem` facts]+          <> [UnsupportedServiceTier t | t <- tiers, t `notElem` ["default", "standard"]]+          <> [UnsupportedSpeed s | s <- speeds, s /= "standard", s /= "fast" || m ^. #fastModeCost == Nothing]+          <> [InconsistentUsage | length speeds > 1]+          <> [ServiceTierMismatch wanted actual | Just wanted <- [requested], wanted /= "auto", actual <- tiers, not (matches wanted actual)]+   in estimateCost reasons (if speeds == ["fast"] then priceAtSpeed duration m SpeedFast u else computeCostWith duration m u)+  where+    matches wanted actual = wanted == actual || (wanted == "standard_only" && actual == "standard") || (wanted == "fast" && actual == "priority")++-- | Price an explicitly selected speed with the standard cache duration.+-- Standard agrees exactly with 'computeCost'. Missing fast rates retain a+-- standard-rate estimate with 'UnsupportedSpeed', never a fabricated zero.+-- This helper does not claim the provider observed the selected speed.+computeCostAtSpeed :: Model -> Speed -> Usage -> Cost+computeCostAtSpeed = priceAtSpeed Nothing++priceAtSpeed :: Maybe CacheRetention -> Model -> Speed -> Usage -> Cost+priceAtSpeed duration m SpeedStandard u = computeCostWith duration m u+priceAtSpeed duration m SpeedFast u = case m ^. #fastModeCost of+  Nothing -> estimateCost [UnsupportedSpeed "fast"] (computeCostWith duration m u)+  Just fast ->+    let resolved = do+          validatePricingPolicy (PricingPolicy [InputPriceTier 0 fast] Nothing)+          standard <- resolveRates duration m u+          let base = m ^. #cost+              -- Apply each premium rate's ratio to the resolved policy once.+              -- A zero base cannot define a ratio for a nonzero policy rate.+              scale b f r+                | b > 0 = Right (r * f / b)+                | r == 0 = Right f+                | otherwise = Left "Cannot apply fast rates to a zero-base pricing policy"+          ModelCost+            <$> scale (inputCost base) (inputCost fast) (inputCost standard)+            <*> scale (outputCost base) (outputCost fast) (outputCost standard)+            <*> scale (cacheReadCost base) (cacheReadCost fast) (cacheReadCost standard)+            <*> scale (cacheWriteCost base) (cacheWriteCost fast) (cacheWriteCost standard)+        computed = priceUsage resolved u+     in computed & #basis . #sources .~ Set.singleton ResolvedTokenRates++-- | Price one resolved rate record exactly once.+computeCostAtRates :: ModelCost -> Usage -> Cost+computeCostAtRates rates u =+  let resolved = validatePricingPolicy (PricingPolicy [InputPriceTier 0 rates] Nothing) >> pure rates+      computed = priceUsage resolved u+   in computed & #basis . #sources .~ Set.singleton ResolvedTokenRates++priceUsage :: Either Text ModelCost -> Usage -> Cost+priceUsage resolved u =+  let selected = either (const zeroModelCost) id resolved+      problems = [InvalidPricingPolicy | Left _ <- [resolved]] <> [PricingUnavailable | selected == ModelCost 0 0 0 0]+      rates = selected       inRate = inputCost rates       outRate = outputCost rates       crRate = cacheReadCost rates@@ -34,16 +106,50 @@       cachedUsd = toRational (u ^. #cacheReadTokens) * crRate / 1_000_000       cacheWriteUsd = toRational (u ^. #cacheWriteTokens) * cwRate / 1_000_000       total = inUsd + outUsd + cachedUsd + cacheWriteUsd-   in Cost-        { usd = total,-          breakdown =-            CostBreakdown-              { inputUsd = inUsd,-                outputUsd = outUsd,-                cachedInputUsd = cachedUsd,-                cachedWriteUsd = cacheWriteUsd-              }-        }+   in estimateCost+        (problems <> usageProblems u)+        Cost+          { usd = total,+            basis = standardCostBasis,+            breakdown =+              CostBreakdown+                { inputUsd = inUsd,+                  outputUsd = outUsd,+                  cachedInputUsd = cachedUsd,+                  cachedWriteUsd = cacheWriteUsd+                }+          }++-- | Legacy, manually constructed usages have no availability annotation.+-- Normalized provider usages always carry one, even for an entirely absent body.+usageProblems :: Usage -> [CostEstimateReason]+usageProblems u = case u ^. #availability of+  Nothing -> []+  Just facts ->+    [InconsistentUsage | inconsistent facts]+      <> if Set.size (missingCategories facts) == 4+        then [UsageNotReported]+        else map reason (Set.toList (missingCategories facts))+  where+    reason InputUsage = InputUsageNotReported+    reason OutputUsage = OutputUsageNotReported+    reason CacheReadUsage = CacheReadUsageNotReported+    reason CacheWriteUsage = CacheWriteUsageNotReported++-- | Choose one complete rate record. Thresholds are exclusive and use+-- disjoint normalized input categories, including both cache counters.+resolveRates :: Maybe CacheRetention -> Model -> Usage -> Either Text ModelCost+resolveRates duration m u = do+  validatePricingPolicy (PricingPolicy [InputPriceTier 0 (m ^. #cost)] Nothing)+  case m ^. #pricingPolicy of+    Nothing -> pure (m ^. #cost)+    Just policy -> do+      validatePricingPolicy policy+      let totalInput = (u ^. #inputTokens) + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens)+          selected = foldl' (\current tier -> if totalInput > inputAbove tier then rates tier else current) (m ^. #cost) (inputTiers policy)+      pure $ case (duration, longCacheWriteCost policy) of+        (Just CacheRetentionLong, Just price) -> selected {cacheWriteCost = price}+        _ -> selected  -- | Replace the assistant response payload's embedded 'Cost' with one -- computed from the supplied model.
src/Baikai/Embedding.hs view
@@ -1,12 +1,16 @@ -- | A small, provider-neutral embeddings client over an OpenAI-compatible--- @\/v1\/embeddings@ endpoint (EP-15).+-- @\/v1\/embeddings@ endpoint. ----- baikai shipped no embeddings client; this is the first. It reuses the same--- @openai@ SDK path the OpenAI /chat/ provider already uses--- ('OpenAI.V1.getClientEnv' + 'OpenAI.V1.makeMethods') and the sibling--- 'OpenAI.V1.createEmbeddings' method, plus baikai's own 'Baikai.Auth' for key--- resolution. It is policy-free (a plain @IO@ client, no effect binding) — the--- effect interpreter lives one layer up in shikumi, exactly as @baikai-effectful@+-- baikai shipped no embeddings client; this is the first. It reuses the+-- @openai@ SDK's 'OpenAI.V1.makeMethods' and the sibling+-- 'OpenAI.V1.createEmbeddings' method, baikai's own 'Baikai.Auth' for key+-- resolution — the same per-host table the chat providers use — and+-- baikai's own 'Baikai.Http' connection cache, which the chat providers+-- share, so two calls to one host reuse one TLS manager rather than+-- allocating one per call as the SDK's own @getClientEnv@ does.+--+-- It is policy-free (a plain @IO@ client, no effect binding) — the effect+-- interpreter lives one layer up in shikumi, exactly as @baikai-effectful@ -- relates to the transport. -- -- An embedding model is named by a bare provider model-id string (e.g.@@ -15,29 +19,39 @@ -- fields (context window, output tokens, chat pricing, modalities) are meaningful -- for embeddings. module Baikai.Embedding-  ( EmbeddingModel (..),+  ( EmbeddingModel (modelId, baseUrl, dimensions, apiKey),     emptyEmbeddingModel,-    _EmbeddingModel,     openAIEmbeddingModel,     mkEmbeddingRequest,     firstEmbedding,+    resolveEmbeddingKey,+    embeddingClientEnv,     embed,     embedOne,   ) where  import Baikai.Auth (ApiKeySource (..), resolveApiKey)-import Baikai.Error (BaikaiError, decodeError)+import Baikai.Auth qualified as Auth+import Baikai.Error (BaikaiError, authError, decodeError, invalidRequest)+import Baikai.Http qualified as Http+import Baikai.Url qualified as Url import Control.Exception (throwIO) import Data.Text (Text) import Data.Vector (Vector) import Data.Vector qualified as V+import GHC.Generics (Generic) import Numeric.Natural (Natural) import OpenAI.V1 qualified as OpenAI import OpenAI.V1.Embeddings qualified as Emb import OpenAI.V1.Models qualified as OpenAIModels+import Servant.Client qualified as Client  -- | How to reach an embeddings endpoint and which model to ask for.+--+-- Construction: the constructor is deliberately not exported. Start+-- from 'emptyEmbeddingModel' (or 'openAIEmbeddingModel') and override+-- fields by record update. data EmbeddingModel = EmbeddingModel   { -- | e.g. @\"text-embedding-3-small\"@     modelId :: !Text,@@ -45,31 +59,38 @@     baseUrl :: !Text,     -- | request a reduced dimensionality, or 'Nothing' for the model default     dimensions :: !(Maybe Natural),-    -- | how to resolve the API key (from "Baikai.Auth")-    apiKey :: !ApiKeySource+    -- | How to resolve the API key (from "Baikai.Auth"). 'Nothing' means+    -- the conventional variable for this host, from+    -- 'Auth.defaultApiKeyEnvForBaseUrl' — the same table the chat+    -- providers consult — and a host that table does not know refuses+    -- with an 'Baikai.Error.AuthError' rather than falling back to+    -- another provider's credential. This mirrors+    -- 'Baikai.Options.apiKey', which has meant exactly that all along.+    apiKey :: !(Maybe ApiKeySource)   }-  deriving stock (Show)+  deriving stock (Eq, Show, Generic)  -- | A blank embedding model; a record-update target for hand-built models. Keyed--- on @OPENAI_API_KEY@ by default.+-- per host by default, so @api.openai.com@ resolves @OPENAI_API_KEY@ and+-- @api.deepseek.com@ resolves @DEEPSEEK_API_KEY@. emptyEmbeddingModel :: EmbeddingModel emptyEmbeddingModel =   EmbeddingModel     { modelId = "",       baseUrl = "",       dimensions = Nothing,-      apiKey = ApiKeyEnv "OPENAI_API_KEY"+      apiKey = Nothing     } --- | The OpenAI default: @api.openai.com@, key from @OPENAI_API_KEY@, model-default--- dimensionality.+-- | The OpenAI default: @api.openai.com@, whose conventional key variable is+-- @OPENAI_API_KEY@, and model-default dimensionality. openAIEmbeddingModel :: Text -> EmbeddingModel openAIEmbeddingModel mid =   emptyEmbeddingModel     { modelId = mid,       baseUrl = "https://api.openai.com",       dimensions = Nothing,-      apiKey = ApiKeyEnv "OPENAI_API_KEY"+      apiKey = Nothing     }  -- | Build the OpenAI @\/v1\/embeddings@ request for a single input text. Pure and@@ -94,6 +115,40 @@     Just (obj, _) ->       Right (Emb.embedding obj) +-- | The key 'embed' will send: the explicit source when the model names+-- one, otherwise the conventional variable for the model's host.+--+-- A host with no conventional variable is an 'Baikai.Error.AuthError'+-- naming the host and telling the caller to set the field, rather than a+-- silent fallback to @OPENAI_API_KEY@ — which is what this did before,+-- and which sent an OpenAI key to whatever host the base URL named.+--+-- Exported so a caller can see which key a model resolves without+-- making a request.+resolveEmbeddingKey :: EmbeddingModel -> IO Text+resolveEmbeddingKey m = case apiKey m of+  Just source -> resolveApiKey source+  Nothing -> case Auth.defaultApiKeyEnvForBaseUrl url of+    Just name -> resolveApiKey (ApiKeyEnv name)+    Nothing ->+      throwIO+        ( authError+            ( "no default API key env is known for "+                <> url+                <> "; set EmbeddingModel.apiKey explicitly"+            )+        )+  where+    url = urlOf m++-- | The cached connection 'embed' will use, from "Baikai.Http" — the+-- same process-global cache the chat providers use, so an embeddings+-- call and a chat call to one host share a TLS manager.+--+-- Exported so the sharing is observable without a network call.+embeddingClientEnv :: EmbeddingModel -> IO Client.ClientEnv+embeddingClientEnv = Http.getClientEnvCached . urlOf+ -- | Embed a batch of texts: one vector per input text, in input order. The SDK's -- @CreateEmbeddings.input@ is a single 'Text', so this loops one call per text. The -- transport exception (a Servant client error) is let propagate — error remapping@@ -101,8 +156,17 @@ embed :: EmbeddingModel -> [Text] -> IO (Vector (Vector Double)) embed _ [] = pure V.empty embed m texts = do-  key <- resolveApiKey (apiKey m)-  env <- OpenAI.getClientEnv (urlOf m)+  -- Checked before the key is resolved, so a base URL baikai will not+  -- send to never causes a credential to be read out of the+  -- environment. The base URL is the API root — baikai appends+  -- @\/v1\/embeddings@ itself, and a trailing @\/v1@ is removed rather+  -- than doubled.+  case Url.baseUrlProblem (urlOf m) of+    Just problem ->+      throwIO (invalidRequest ("EmbeddingModel.baseUrl is not usable: " <> problem))+    Nothing -> pure ()+  key <- resolveEmbeddingKey m+  env <- embeddingClientEnv m   let create = OpenAI.createEmbeddings (OpenAI.makeMethods env key Nothing Nothing)   V.fromList <$> traverse (embedText create) texts   where@@ -123,7 +187,3 @@ urlOf m = case baseUrl m of   "" -> "https://api.openai.com"   u -> u--{-# DEPRECATED _EmbeddingModel "Use emptyEmbeddingModel instead." #-}-_EmbeddingModel :: EmbeddingModel-_EmbeddingModel = emptyEmbeddingModel
src/Baikai/Error.hs view
@@ -5,6 +5,7 @@     -- * Smart constructors     providerError,     invalidRequest,+    contentFiltered,     decodeError,     processError,     rateLimited,@@ -17,12 +18,15 @@     -- * Pure classification helpers for provider packages     httpError,     parseRetryAfterSeconds,+    parseHttpDate,+    retryAfterSecondsAt,     classifyHttpStatus,     classifyHttpStatusWithBody,     bodyIndicatesOverflow,   ) where +import Control.Applicative ((<|>)) import Control.Exception (Exception (displayException)) import Data.Aeson   ( FromJSON (parseJSON),@@ -33,8 +37,10 @@     genericParseJSON,     genericToJSON,   )+import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as Text+import Data.Time (UTCTime, defaultTimeLocale, diffUTCTime, parseTimeM) import GHC.Generics (Generic) import Text.Read (readMaybe) @@ -50,11 +56,17 @@     -- retryable after a delay; see 'retryAfterSeconds'.     RateLimited   | -- | The request exceeded the model's context window or a related-    -- size limit. Not retryable as-is; the caller must shrink input.+    -- size limit: HTTP 413, or a 400\/422 whose body names the context+    -- window. Not retryable as-is; the caller must shrink input.     ContextOverflow   | -- | The request was malformed or otherwise rejected as invalid     -- (HTTP 400/404/422). Not retryable without changes.     InvalidRequest+  | -- | The provider refused or filtered the content — OpenAI's+    -- @finish_reason: "content_filter"@, Anthropic's @refusal@ stop.+    -- The content, not the transport, is the problem, so it is not+    -- retryable as-is: the caller must change what it sent.+    ContentFiltered   | -- | A transient server-side or network failure (HTTP 408/5xx, or a     -- connection error). Safe to retry, ideally with backoff.     TransientError@@ -91,10 +103,13 @@     -- | The HTTP status code, when the failure came from an HTTP call.     httpStatus :: !(Maybe Int),     -- | Seconds to wait before retrying, parsed from a @Retry-After@-    -- header when present and integer-valued.+    -- header in either its integer or its HTTP-date form.     retryAfterSeconds :: !(Maybe Int),     -- | The subprocess exit code, for 'ProcessFailure'.-    exitCode :: !(Maybe Int)+    exitCode :: !(Maybe Int),+    -- | Provider-reported refusal category, an open vocabulary. Present only+    -- when a content refusal names one; never inferred from message text.+    refusalCategory :: !(Maybe Text)   }   deriving stock (Eq, Show, Generic) @@ -121,7 +136,8 @@       message = m,       httpStatus = Nothing,       retryAfterSeconds = Nothing,-      exitCode = Nothing+      exitCode = Nothing,+      refusalCategory = Nothing     }  -- Smart constructors. These keep call sites close to the old API: an@@ -135,6 +151,10 @@ invalidRequest :: Text -> BaikaiError invalidRequest = baseError InvalidRequest +-- | Content the provider refused or filtered.+contentFiltered :: Text -> BaikaiError+contentFiltered = baseError ContentFiltered+ -- | A response that failed to decode. decodeError :: Text -> BaikaiError decodeError = baseError DecodeFailure@@ -166,13 +186,43 @@   TransientError -> True   _ -> False --- | Parse an integer-valued @Retry-After@ header as seconds. HTTP-date--- values and malformed values yield 'Nothing'.+-- | Parse an integer-valued @Retry-After@ header as seconds. The+-- integer form only: an HTTP-date yields 'Nothing' here, deliberately,+-- because converting one needs a reference instant. See+-- 'retryAfterSecondsAt' for the form that accepts either. parseRetryAfterSeconds :: Text -> Maybe Int parseRetryAfterSeconds raw = do   n <- readMaybe (Text.unpack (Text.strip raw))   if n >= 0 then Just n else Nothing +-- | Parse an HTTP-date (RFC 7231 section 7.1.1.1). Accepts the+-- IMF-fixdate form servers must send, plus the obsolete RFC 850 and+-- asctime forms a recipient must still accept.+parseHttpDate :: Text -> Maybe UTCTime+parseHttpDate raw = listToMaybe (mapMaybe attempt formats)+  where+    s = Text.unpack (Text.strip raw)+    attempt fmt = parseTimeM True defaultTimeLocale fmt s+    formats =+      [ "%a, %d %b %Y %H:%M:%S GMT", -- Sun, 06 Nov 1994 08:49:37 GMT+        "%A, %d-%b-%y %H:%M:%S GMT", -- Sunday, 06-Nov-94 08:49:37 GMT+        "%a %b %e %H:%M:%S %Y" -- Sun Nov  6 08:49:37 1994+      ]++-- | Seconds to wait, from a @Retry-After@ value in either of its two+-- forms, relative to a reference instant.+--+-- The reference should be the response's own @Date@ header when it+-- parses, which takes the caller's clock skew out of the computation;+-- the local time is the fallback. A date already in the past yields+-- @Just 0@ — the server is saying "now" — and text in neither form+-- yields 'Nothing'.+retryAfterSecondsAt :: UTCTime -> Text -> Maybe Int+retryAfterSecondsAt reference raw =+  parseRetryAfterSeconds raw <|> (secondsUntil <$> parseHttpDate raw)+  where+    secondsUntil t = max 0 (ceiling (diffUTCTime t reference))+ -- | Build a classified error from an HTTP failure's status, optional -- parsed @Retry-After@ seconds, and response body text. httpError :: Int -> Maybe Int -> Text -> BaikaiError@@ -195,12 +245,15 @@ -- -- The body of a 400 may indicate a context-window overflow, but this -- helper only sees the status code; callers that can inspect the body--- should special-case overflow before falling back here.+-- should special-case overflow before falling back here. 413 needs no+-- such help: it /is/ the size-limit status, and the caller's remedy —+-- shrink the input — is the same whatever the body says. classifyHttpStatus :: Int -> Maybe Int -> ErrorCategory classifyHttpStatus status _retryAfter   | status == 401 || status == 403 = AuthError   | status == 429 = RateLimited   | status == 408 = TransientError+  | status == 413 = ContextOverflow   | status == 400 || status == 404 || status == 422 = InvalidRequest   | status >= 500 = TransientError   | otherwise = OtherError
+ src/Baikai/Evidence.hs view
@@ -0,0 +1,1488 @@+{-# 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+      ( schemaVersion,+        runId,+        callId,+        attempt,+        supersedes,+        endpoint,+        requestedModel,+        thinking,+        observedModel,+        observedThinking,+        responseId,+        providerRequestId,+        clientRequestId,+        startedAt,+        endedAt,+        latencyMs,+        status,+        errorInfo,+        usage,+        strength,+        requestCommitment,+        requestConfiguration,+        responseCommitment+      ),+    baseEvidence,++    -- * Observation+    Observed (..),+    observedValue,++    -- * Reasoning-effort translation+    ThinkingTranslation (..),+    ThinkingMode (..),+    ThinkingAdjustment (..),+    weakensThinking,+    noThinkingRequested,+    untranslatedThinking,++    -- * Endpoint and transport+    EndpointIdentity (..),+    TransportKind (..),++    -- * Outcome and strength+    CallStatus (..),+    EvidenceStrength (..),+    renderEvidenceStrength,+    parseEvidenceStrength,+    declaredStrength,+    deriveStrength,++    -- * The caller's request+    EvidenceRequest (runId, strictness, attempt, supersedes),+    EvidenceStrictness (..),+    evidenceRequest,++    -- * Canonical encoding and digests+    usageEnvelope,+    canonicalEncode,+    commitmentDigest,+    configurationDigest,+    configurationProjection,++    -- * Identifiers+    newCallId,+  )+where++import Baikai.Api (Api (..))+import Baikai.Error (BaikaiError)+import Baikai.ThinkingLevel (ThinkingLevel (..), parseThinkingLevel, renderThinkingLevel)+import Baikai.Usage (Usage)+import Baikai.Usage qualified as 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 (Parser, 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@, @not_translated@, @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 a level and no provider adapter ran to+    -- translate it: the call was refused, never dispatched, or+    -- abandoned before the adapter could describe what it did. The+    -- request is recorded; the translation is unknown. Distinct from+    -- 'ThinkingModeAbsent' (nothing requested) and from+    -- 'ThinkingModeUnsupported' (an adapter looked and could not).+    ThinkingModeNotTranslated+  | -- | 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"+  ThinkingModeNotTranslated -> "not_translated"+  ThinkingModeAbsent -> "absent"++parseThinkingMode :: Text -> Maybe ThinkingMode+parseThinkingMode = \case+  "budget" -> Just ThinkingModeBudget+  "adaptive" -> Just ThinkingModeAdaptive+  "flag" -> Just ThinkingModeFlag+  "toggle" -> Just ThinkingModeToggle+  "unsupported" -> Just ThinkingModeUnsupported+  "not_translated" -> Just ThinkingModeNotTranslated+  "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.+-- Request adjustments correspond to sites where a request is weakened,+-- dropped, or made indistinguishable from the provider's own default.+-- 'ThinkingSummaryUnavailable' is instead a response-only diagnostic.+--+-- Levels are carried as 'ThinkingLevel' rather than text so that+-- strict evidence mode can compare them; they render through+-- 'Baikai.ThinkingLevel.renderThinkingLevel' in JSON.+--+-- Sampling and speed drops are not about thinking: sampling drops record+-- that @temperature@, @top_p@, @seed@ and their kind were removed+-- because the model generation or the API rejects them. They carry no+-- requested level and 'weakensThinking' is 'False' for them, so strict+-- evidence mode does not refuse a call over one. Fast-mode drops follow+-- the same rule: losing speed does not weaken reasoning.+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+  | -- | Sampling parameters the caller set were removed because the+    -- chosen model generation rejects them. Carries the wire names+    -- removed, in wire order, for example+    -- @["temperature","top_p"]@. Carries no requested level: it is+    -- not about thinking, and it happens on calls that asked for no+    -- thinking at all.+    SamplingDroppedUnsupportedModel ![Text]+  | -- | Sampling parameters the caller set were removed because this+    -- API has no field for them on any generation — the Anthropic+    -- Messages API has no @seed@, @frequency_penalty@ or+    -- @presence_penalty@. Carries the wire names removed, in wire+    -- order.+    SamplingDroppedUnsupportedApi ![Text]+  | -- | Fast speed was requested but the model does not support it.+    FastModeDroppedUnsupportedModel+  | -- | Response-only diagnostic: completed thinking blocks carried no+    -- readable summary. This says nothing about reasoning depth or billing.+    ThinkingSummaryUnavailable+  deriving stock (Eq, Show, Generic)++-- | Whether an adjustment weakens the /thinking/ the caller asked for.+--+-- Strict evidence mode refuses a call whose translation would weaken+-- the requested thinking level; it must not refuse one merely because+-- a sampling parameter had nowhere to go. The six level-carrying+-- constructors weaken thinking; the sampling and speed ones do not.+weakensThinking :: ThinkingAdjustment -> Bool+weakensThinking = \case+  EffortClamped {} -> True+  EffortCollapsedToToggle {} -> True+  EffortOmitted {} -> True+  ThinkingDroppedUnsupportedModel {} -> True+  ThinkingDroppedUnsupportedHost {} -> True+  ThinkingDroppedBudgetExceeded {} -> True+  SamplingDroppedUnsupportedModel {} -> False+  SamplingDroppedUnsupportedApi {} -> False+  FastModeDroppedUnsupportedModel -> False+  ThinkingSummaryUnavailable -> False++-- | 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]+    SamplingDroppedUnsupportedModel fields ->+      untagged "sampling_dropped_unsupported_model" fields+    SamplingDroppedUnsupportedApi fields ->+      untagged "sampling_dropped_unsupported_api" fields+    ThinkingSummaryUnavailable ->+      object ["kind" .= ("thinking_summary_unavailable" :: Text)]+    FastModeDroppedUnsupportedModel ->+      object ["kind" .= ("fast_mode_dropped_unsupported_model" :: Text)]+    where+      tagged kind lvl extra =+        object+          ( ["kind" .= (kind :: Text), "requested" .= renderThinkingLevel lvl]+              <> extra+          )+      untagged kind fields =+        object ["kind" .= (kind :: Text), "fields" .= (fields :: [Text])]++-- | @kind@ is read first, because only the six level-carrying kinds+-- have a @requested@ field to read: the two sampling kinds carry a+-- @fields@ array instead.+instance FromJSON ThinkingAdjustment where+  parseJSON = \case+    Object o -> do+      kind <- o .: "kind"+      let withLevel :: (ThinkingLevel -> Parser ThinkingAdjustment) -> Parser ThinkingAdjustment+          withLevel k = o .: "requested" >>= parseThinkingLevelText >>= k+      case kind :: Text of+        "effort_clamped" -> withLevel $ \lvl -> EffortClamped lvl <$> o .: "wire"+        "effort_collapsed_to_toggle" -> withLevel (pure . EffortCollapsedToToggle)+        "effort_omitted" -> withLevel (pure . EffortOmitted)+        "thinking_dropped_unsupported_model" ->+          withLevel (pure . ThinkingDroppedUnsupportedModel)+        "thinking_dropped_unsupported_host" ->+          withLevel (pure . ThinkingDroppedUnsupportedHost)+        "thinking_dropped_budget_exceeded" ->+          withLevel $ \lvl ->+            ThinkingDroppedBudgetExceeded lvl <$> o .: "budget_tokens" <*> o .: "max_tokens"+        "sampling_dropped_unsupported_model" ->+          SamplingDroppedUnsupportedModel <$> o .: "fields"+        "sampling_dropped_unsupported_api" ->+          SamplingDroppedUnsupportedApi <$> o .: "fields"+        "thinking_summary_unavailable" -> pure ThinkingSummaryUnavailable+        "fast_mode_dropped_unsupported_model" -> pure FastModeDroppedUnsupportedModel+        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.+--+-- The table itself lives beside its renderer, in+-- 'Baikai.ThinkingLevel.parseThinkingLevel'; this is the parser-monad+-- wrapper that turns a miss into a decode failure naming the input.+parseThinkingLevelText :: (MonadFail m) => Text -> m ThinkingLevel+parseThinkingLevelText t =+  maybe (fail ("unknown thinking level: " <> show t)) pure (parseThinkingLevel t)++-- | 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),+    -- | Exact display setting sent, such as Anthropic's @summarized@.+    -- Nothing means no display setting was sent, not a provider observation.+    displayText :: !(Maybe Text),+    -- | Everything that happened to the request between the canonical+    -- level and the wire, in the order it was applied, followed by any+    -- response diagnostics. Empty means no adjustment or diagnostic was recorded.+    -- The provider may append ThinkingSummaryUnavailable after successful+    -- assembly; it never changes the request fields or observed effort.+    --+    -- Reasoning /and/ sampling changes travel here: a+    -- 'SamplingDroppedUnsupportedModel' entry can appear on a call+    -- whose 'mode' is 'ThinkingModeAbsent', because nothing about+    -- thinking was asked and something about sampling was dropped.+    -- 'mode' describes the thinking configuration only.+    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+        ]+          <> maybe [] (\d -> ["display_text" .= d]) (displayText 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 .:? "display_text"+        <*> 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.+--+-- This value's 'adjustments' list is empty, but a real call that asked+-- for no thinking may still carry adjustments: a dropped sampling+-- parameter is recorded whatever the thinking mode. Build such a+-- translation by adding to this one rather than by assuming+-- @mode = absent@ implies nothing happened.+noThinkingRequested :: ThinkingTranslation+noThinkingRequested =+  ThinkingTranslation+    { requested = Nothing,+      mode = ThinkingModeAbsent,+      effortText = Nothing,+      budgetTokens = Nothing,+      wireField = Nothing,+      displayText = Nothing,+      adjustments = []+    }++-- | The translation for a path where no adapter ran: the caller's+-- level exactly, and no claim about the wire. 'noThinkingRequested'+-- when no level was set, so the two statements stay distinct.+--+-- The 'adjustments' list is empty on purpose: an untranslated request+-- has not been downgraded, it has not been looked at, and strict+-- evidence mode refuses a call over a non-empty list.+untranslatedThinking :: Maybe ThinkingLevel -> ThinkingTranslation+untranslatedThinking = \case+  Nothing -> noThinkingRequested+  Just lvl ->+    ThinkingTranslation+      { requested = Just lvl,+        mode = ThinkingModeNotTranslated,+        effortText = Nothing,+        budgetTokens = Nothing,+        wireField = Nothing,+        displayText = Nothing,+        adjustments = []+      }++-- | The usage a response digest commits to: the token counts the+-- provider reported, and never the cost.+--+-- 'Usage.cost' is computed here from the caller's own catalog rates,+-- not reported by the provider, so including it made+-- @response_commitment@ change whenever pricing was edited and left a+-- verifier holding only the response unable to recompute it. The six+-- counts and optional availability facts are listed through record selectors rather than encoded+-- wholesale, so a field added to 'Usage' later does not silently join+-- the digest.+usageEnvelope :: Usage -> Value+usageEnvelope u =+  object $+    [ "input_tokens" .= Usage.inputTokens u,+      "output_tokens" .= Usage.outputTokens u,+      "cache_read_tokens" .= Usage.cacheReadTokens u,+      "cache_write_tokens" .= Usage.cacheWriteTokens u,+      "reasoning_tokens" .= Usage.reasoningTokens u,+      "total_tokens" .= Usage.totalTokens u+    ]+      <> maybe [] (\facts -> ["availability" .= facts]) (Usage.availability u)++-- ============================================================+-- 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"++-- | The inverse of 'renderEvidenceStrength'. Beside its renderer, so+-- the two cannot drift when a level is added; the 'FromJSON' instance+-- and @baikai-agent@'s @--require-evidence@ parser both go through it.+parseEvidenceStrength :: Text -> Maybe EvidenceStrength+parseEvidenceStrength = \case+  "requested_only" -> Just EvidenceRequestedOnly+  "correlated" -> Just EvidenceCorrelated+  "model_observed" -> Just EvidenceModelObserved+  "fully_observed" -> Just EvidenceFullyObserved+  _ -> Nothing++instance ToJSON EvidenceStrength where+  toJSON = String . renderEvidenceStrength++instance FromJSON EvidenceStrength where+  parseJSON = withText "EvidenceStrength" $ \t ->+    maybe (fail ("unknown evidence strength: " <> show t)) pure (parseEvidenceStrength t)++-- | 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.+-- | The one rule that turns observations into a strength.+--+-- A __correlation identifier__ is the provider's request id (typically a+-- response header) or its response id; either locates the call in the+-- provider's own records, which is what 'EvidenceCorrelated' means.+--+-- A model is 'EvidenceModelObserved' only /in addition to/ one, because+-- the scale is cumulative by its own documentation. An unlocatable model+-- claim does not climb it — it stays recorded in @observed_model@, where+-- a reader can see it — and no shipped transport produces that+-- combination. Nothing reaches 'EvidenceFullyObserved'.+--+-- A successful status is deliberately not an argument. A 200 means the+-- request was accepted, not that any particular model ran.+--+-- Three copies of this rule had drifted apart: the subprocess one+-- counted a session or thread id as correlation while the two API ones+-- looked only at a captured header, so a host reporting @model@ and @id@+-- on every chunk but no header landed at 'EvidenceRequestedOnly',+-- /below/ a host that sent only a header.+deriveStrength ::+  -- | The model the provider reported serving.+  Observed Text ->+  -- | The provider's request id, typically from a response header.+  Observed Text ->+  -- | The provider's response id.+  Observed Text ->+  EvidenceStrength+deriveStrength observedModel providerRequestId responseId =+  case (observedModel, correlated) of+    (Observed _, True) -> EvidenceModelObserved+    (_, True) -> EvidenceCorrelated+    _ -> EvidenceRequestedOnly+  where+    correlated = case (providerRequestId, responseId) of+      (Observed _, _) -> True+      (_, Observed _) -> True+      _ -> False++declaredStrength :: Api -> EvidenceStrength+declaredStrength = \case+  AnthropicMessages -> EvidenceModelObserved+  OpenAIChatCompletions -> EvidenceModelObserved+  OpenAIResponses -> 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.+--+-- Construction: the constructor is deliberately not exported. Start+-- from 'evidenceRequest' and override fields by record update.+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.+-- The @1.1@ minor bump added the @sampling_dropped_unsupported_model@+-- and @sampling_dropped_unsupported_api@ adjustment kinds. They are a+-- compatible addition: a reader that switches on @kind@ and ignores+-- what it does not know keeps working, and no existing digest changes.+--+-- The @2.0@ major bump changed what two digests cover, so a verifier+-- must select its rules by @schema_version@ rather than assume:+--+-- * @response_commitment@ covers @{"content", "stop_reason", "usage"}@+--   where @usage@ is the provider-reported token counts only+--   ('usageEnvelope'). Under @1.x@ it also covered baikai's computed+--   @cost@, which comes from the caller's catalog rates rather than+--   from the response, so the digest changed whenever pricing was+--   edited and a verifier holding only the response could not+--   recompute it.+-- * @request_configuration@ additionally summarises @output_config@ and+--   @response_format@ ('configurationProjection'), because a+--   structured-output JSON schema is author-written content wherever it+--   appears. Under @1.x@ both survived verbatim.+--+-- A @1.x@ record's digests are recomputed under @1.x@ rules. One+-- further compatible addition rides along: @thinking.mode@ may now be+-- @"not_translated"@.+evidenceSchemaVersion :: Text+-- Version 2.1 adds optional provider-scoped replay_state to thinking+-- content. It participates in content commitments, but is omitted when+-- absent, preserving every pre-existing content encoding and digest.+-- Version 2.2 adds the local cost calculation basis to serialized usage.+-- Like the local numeric cost, this basis is excluded from response commitments.+-- Optional provider availability facts do join usage commitments. Their absence+-- preserves the six-field envelope and every legacy usage digest.+-- Version 2.3 adds fast-mode drops and speed-unreported cost estimates.+-- Newly emitted speed fields join the configuration projection; envelopes+-- without speed retain their existing digests.+-- Version 2.4 adds optional thinking.display_text and a response-only+-- thinking_summary_unavailable diagnostic; existing digest rules are unchanged.+-- Version 2.5 adds error_info.refusal_category, an optional provider fact.+-- Older error objects decode with Nothing; digest inputs are unchanged.+evidenceSchemaVersion = "baikai.model-call-evidence/2.5"++-- | 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.+--+-- Construction: the constructor is deliberately not exported. Start+-- from 'baseEvidence' and override fields by record update, so that a+-- field added in a later release cannot break a construction site.+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. Five 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; @output_config@ keeps its effort and reduces its @format@ to a+-- type and a character count; and @response_format@ keeps its type and+-- reduces its @json_schema@ to a name, a strictness flag and a+-- character count.+--+-- The rule the last three share: __a JSON schema is content wherever it+-- appears.__ A schema carries author-written @description@ strings that+-- describe the caller's domain as freely as a prompt does.+-- @tools[].input_schema@ was already stripped on that ground while the+-- same kind of schema, reached through @output_config.format.schema@ or+-- @response_format.json_schema@, survived verbatim into a digest+-- callers were told is content-free. The names, types and flags around+-- it are configuration in the sense a tool's name is.+--+-- 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)]+      "output_config" -> [(k, summariseOutputConfig v)]+      "response_format" -> [(k, summariseResponseFormat 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",+      "presence_penalty",+      "reasoning",+      "reasoning_effort",+      "seed",+      "speed",+      "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@.+-- | Anthropic's @output_config@: @{"effort": <text>, "format":+-- {"type": ..., "schema": ...}}@ at claude 0.6 (@Claude.V1.Messages@,+-- @OutputConfig@ and @OutputFormat@). Every key is kept as it is except+-- @format@, whose schema is content.+summariseOutputConfig :: Value -> Value+summariseOutputConfig = \case+  Object o -> Object (KeyMap.mapWithKey summarise o)+  _ -> Null+  where+    summarise k v+      | Key.toText k == "format" =+          object+            [ "type" .= formatType v,+              "chars" .= totalStringChars v+            ]+      | otherwise = v+    formatType = \case+      Object f -> case KeyMap.lookup "type" f of+        Just t@(String _) -> t+        _ -> Null+      _ -> Null++-- | The OpenAI-compatible @response_format@: @{"type": "json_schema",+-- "json_schema": {"name": ..., "strict": ..., "schema": ...}}@. The+-- type, the schema's name and its strictness are configuration; the+-- schema itself is content.+summariseResponseFormat :: Value -> Value+summariseResponseFormat = \case+  Object o ->+    object+      [ "type" .= lookupString "type" o,+        "json_schema" .= schemaSummary (KeyMap.lookup "json_schema" o)+      ]+  _ -> Null+  where+    lookupString k o = case KeyMap.lookup (Key.fromText k) o of+      Just t@(String _) -> t+      _ -> Null+    schemaSummary = \case+      Just v@(Object js) ->+        object+          [ "name" .= lookupString "name" js,+            "strict" .= strictOf js,+            "chars" .= totalStringChars v+          ]+      _ -> Null+    strictOf js = case KeyMap.lookup "strict" js of+      Just b@(Bool _) -> b+      _ -> Null++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 #-}
+ src/Baikai/Evidence/Build.hs view
@@ -0,0 +1,548 @@+{-# 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,+    minimalEvidenceAt,+    prepareEvidence,+    prepareEvidenceAt,+    endpointIdentity,+    endpointIdentityAt,+    sanitizeEndpoint,+    dispatchEnvelope,+    requestedTranslation,+    transportForModel,+    baikaiPackageVersion,++    -- * Trace-sink failure policy+    onSinkFailure,+    sinkFailureIsFatal,+    sinkFailureError,++    -- * Strict mode+    strictnessOf,+    missingEvidenceError,++    -- * 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,+    newCallId,+    renderEvidenceStrength,+    untranslatedThinking,+    weakensThinking,+  )+import Baikai.Model (Model)+import Baikai.Options (Options)+import Baikai.Prelude+import Baikai.ThinkingLevel (renderThinkingLevel)+import Baikai.Url qualified as Url+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 =+  minimalEvidenceAt (m ^. #baseUrl) m opts++-- | 'minimalEvidence' against the base URL the adapter actually+-- resolved, rather than the possibly-empty one on the 'Model'.+--+-- Both API adapters substitute a vendor default for an empty+-- @baseUrl@ inside their own @prepareCall@, so the call goes to a+-- definite host while the model still says @""@ — and+-- 'sanitizeEndpoint' then recorded @null@ for a call whose destination+-- was perfectly well known. The core cannot know a vendor default, so+-- where no adapter ran @null@ remains the truthful answer and the+-- unsuffixed functions keep passing @m ^. #baseUrl@.+minimalEvidenceAt ::+  -- | The resolved base URL.+  Text ->+  Model ->+  Options ->+  TransportKind ->+  ThinkingTranslation ->+  -- | The request envelope. Lazy, for the reason 'minimalEvidence'+  -- documents at length.+  Aeson.Value ->+  UTCTime ->+  UTCTime ->+  CallStatus ->+  Maybe BaikaiError ->+  IO (Maybe ModelCallEvidence)+minimalEvidenceAt baseUrl m opts transport translation envelope started ended st err = do+  mk <- prepareEvidenceAt baseUrl 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 =+  prepareEvidenceAt (m ^. #baseUrl) m opts++-- | 'prepareEvidence' against the base URL the adapter actually+-- resolved. See 'minimalEvidenceAt'.+prepareEvidenceAt ::+  -- | The resolved base URL.+  Text ->+  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))+prepareEvidenceAt baseUrl m opts transport translation envelope started =+  case opts ^. #evidence of+    Nothing -> pure Nothing+    Just req -> do+      cid <- newCallId+      let ep = endpointIdentityAt baseUrl 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+            }++-- | 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)++-- | The error a strict call fails with when its provider produced a+-- successful terminal and attached no evidence record to it.+--+-- Built with 'providerError' for the reason 'sinkFailureError' is:+-- nothing about the request was invalid and the provider did its job,+-- and 'Baikai.Error.ErrorCategory' is closed. The message prefix is the+-- contract until the surface freeze decides on a category.+missingEvidenceError :: BaikaiError+missingEvidenceError =+  providerError+    "this call required evidence, but the provider attached no evidence record to its \+    \terminal event; the response is reported failed rather than left unaccounted for"++-- | The translation to record where no provider adapter ran: an+-- unregistered provider, and a @complete@ handler that threw before+-- returning.+--+-- It carries the caller's level and says @not_translated@, so the+-- record states the request without claiming a wire shape that was+-- never built. Where an adapter /did/ run — the consumer-abort path in+-- "Baikai.Trace", and each adapter's own @immediateError@ — call that+-- adapter's @describeThinking@ instead; re-deriving a description in+-- the core is what+-- @docs\/adr\/0003-the-adapter-owns-the-translation-description.md@+-- forbids.+requestedTranslation :: Options -> ThinkingTranslation+requestedTranslation opts = untranslatedThinking (opts ^. #thinking)++-- | 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 = endpointIdentityAt (m ^. #baseUrl) m++-- | 'endpointIdentity' against the base URL the adapter actually+-- resolved. See 'minimalEvidenceAt'.+endpointIdentityAt :: Text -> Model -> TransportKind -> EndpointIdentity+endpointIdentityAt baseUrl m transport =+  EndpointIdentity+    { provider = m ^. #provider,+      api = renderApi (m ^. #api),+      transport = transport,+      endpoint = sanitizeEndpoint baseUrl,+      baikaiVersion = baikaiPackageVersion,+      implementationVersion = Nothing+    }++-- | Reduce a base URL to scheme, host, port, and path.+--+-- This is "Baikai.Url" applied to the recording problem: 'Url.parseUrl'+-- never holds the userinfo, the query string or the fragment in the+-- first place, and 'Url.renderEndpoint' can only put back what it has.+-- The query string is therefore dropped __wholesale__ rather than+-- filtered field by field, which is the right behaviour rather than a+-- convenient one: 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. Userinfo+-- (@https:\/\/user:secret\@host\/@) goes for the same reason; a+-- fragment cannot carry a credential to a server but is never part of+-- what was requested either.+--+-- The scheme and host come back lower-cased, because that is what+-- "Baikai.Url" says a host is; the path is kept verbatim.+--+-- 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 = fmap Url.renderEndpoint . Url.parseUrl++-- | 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 adjustment, in words. Six of these are 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. The two sampling entries are rendered here as well, so a+-- record printed for a human reads completely, even though+-- 'Baikai.Evidence.weakensThinking' keeps them out of the refusal+-- list.+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)+  SamplingDroppedUnsupportedModel fields ->+    Text.intercalate ", " fields+      <> " would be dropped, because this model generation rejects sampling parameters"+  ThinkingSummaryUnavailable -> "the response contained thinking blocks but no readable summary"+  FastModeDroppedUnsupportedModel -> "fast mode would be dropped, because this model does not support it"+  SamplingDroppedUnsupportedApi fields ->+    Text.intercalate ", " fields+      <> " would be dropped, because this API has no such field on any generation"++-- | 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 adjustment that+-- weakens the thinking request 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.+--+-- The adjustment list is filtered through+-- 'Baikai.Evidence.weakensThinking' rather than tested for emptiness,+-- because it also carries the sampling drops. The documented contract is+-- refusing a call that would /weaken the requested thinking level/; a+-- caller who set @seed@ on a Claude model, where the API has no such+-- field on any generation, must not have every strict call refused over+-- it. The drop is still in the record, where they can see it.+checkEvidenceRequirements ::+  EvidenceStrictness ->+  -- | The provider's own ceiling+  -- ('Baikai.Provider.Registry.strengthCeiling'), not a value looked up+  -- by 'Baikai.Api.Api': only the provider knows what its evidence can+  -- reach, and a tag-keyed table capped every caller-supplied transport+  -- at 'EvidenceRequestedOnly'.+  EvidenceStrength ->+  ThinkingTranslation ->+  [EvidenceRefusal]+checkEvidenceRequirements EvidenceBestEffort _ _ = []+checkEvidenceRequirements (EvidenceRequired needed) declared translation =+  [StrengthUnreachable needed declared | declared < needed]+    <> [ThinkingWouldDowngrade downgrades | not (null downgrades)]+  where+    downgrades = filter weakensThinking (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.+--+-- "Not confirmed written" rather than "not written": this covers a+-- sink that threw, whose record certainly was not written, and a sink+-- that stalled past "Baikai.Trace"'s drain bound, whose worker was+-- abandoned with the events still queued and may yet deliver them. What+-- the strict caller is told in both cases is the same and is the honest+-- claim — the call returned without the record's delivery being+-- confirmed.+sinkFailureError :: SomeException -> BaikaiError+sinkFailureError e =+  providerError+    ( "the trace sink failed and this call required evidence, so its record was \+      \not confirmed written: "+        <> Text.pack (displayException e)+    )
+ src/Baikai/Header.hs view
@@ -0,0 +1,77 @@+-- | HTTP header names as a type that carries the case-insensitivity+-- rule.+--+-- A header name is case-insensitive on the wire, so @Authorization@ and+-- @authorization@ are one header. A @Map Text Text@ of header overrides+-- does not know that: it holds both, and which one reaches the provider+-- is decided by the fold order of whatever code assembles the request.+-- 'HeaderName' puts the rule in the key type, so a @Map HeaderName Text@+-- holds at most one value per header and the last write wins, as a+-- caller writing two spellings would expect.+--+-- The original spelling is preserved and is what goes out on the wire+-- and into JSON, so a host that (wrongly) cares about case still sees+-- what the caller wrote.+--+-- The type is baikai's own rather than a bare+-- 'Data.CaseInsensitive.CI' 'Data.Text.Text' because the aeson+-- instances would then be orphans, which two packages can define+-- incompatibly.+module Baikai.Header+  ( HeaderName,+    headerName,+    renderHeaderName,+  )+where++import Data.Aeson+  ( FromJSON (parseJSON),+    FromJSONKey (fromJSONKey),+    FromJSONKeyFunction (FromJSONKeyText),+    ToJSON (toJSON),+    ToJSONKey (toJSONKey),+    withText,+  )+import Data.Aeson.Types (toJSONKeyText)+import Data.CaseInsensitive (CI)+import Data.CaseInsensitive qualified as CI+import Data.String (IsString (fromString))+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)++-- | A case-insensitive HTTP header name that remembers its original+-- spelling.+newtype HeaderName = HeaderName (CI Text)+  deriving stock (Eq, Ord, Generic)++-- | Shows the original spelling, so a header map prints as it was+-- written.+instance Show HeaderName where+  showsPrec d = showsPrec d . renderHeaderName++-- | So that @Map.singleton "x-test" "1" :: Map HeaderName Text@ keeps+-- compiling and reading naturally.+instance IsString HeaderName where+  fromString = headerName . Text.pack++instance ToJSON HeaderName where+  toJSON = toJSON . renderHeaderName++instance FromJSON HeaderName where+  parseJSON = withText "HeaderName" (pure . headerName)++instance ToJSONKey HeaderName where+  toJSONKey = toJSONKeyText renderHeaderName++instance FromJSONKey HeaderName where+  fromJSONKey = FromJSONKeyText headerName++-- | A header name from its text. Comparison ignores case from here on;+-- the spelling given is what 'renderHeaderName' returns.+headerName :: Text -> HeaderName+headerName = HeaderName . CI.mk++-- | The name as it was originally written.+renderHeaderName :: HeaderName -> Text+renderHeaderName (HeaderName n) = CI.original n
+ src/Baikai/Http.hs view
@@ -0,0 +1,135 @@+-- | The one HTTP client cache, and the one place a base URL becomes+-- something baikai will actually connect to.+--+-- Building a @ClientEnv@ — @servant-client@'s pairing of a parsed base+-- URL with an @http-client@ 'HTTP.Manager', which owns the connection+-- pool and the TLS state — costs a TLS manager setup, so baikai keeps+-- one per base URL for the life of the process. That cache used to be+-- duplicated in each provider package and keyed on the raw base-URL+-- text, which meant @https:\/\/h@ and @https:\/\/h\/@ were two managers+-- and two connection pools to one host, and that the three copies could+-- disagree about what "the same host" means. There is one cache here+-- now, and its key is the canonical rendering of "Baikai.Url"'s parse.+--+-- The cache is unbounded on purpose. The set of distinct base URLs a+-- process talks to is configuration-sized rather than request-sized;+-- normalisation removes the one unbounded source (textual variants of a+-- single host); and how long a connection lives is already the+-- 'HTTP.Manager''s idle timeout. A fleet of per-tenant base URLs is not+-- a supported use of @Model.baseUrl@.+module Baikai.Http+  ( canonicalBaseUrl,+    getClientEnvCached,+    cachedClientEnvCount,+  )+where++import Baikai.Error (invalidRequest)+import Baikai.Url qualified as Url+import Control.Concurrent.MVar (MVar, modifyMVar, newMVar)+import Control.Exception (throwIO)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Client.TLS qualified as TLS+import Servant.Client qualified as Client+import System.IO.Unsafe (unsafePerformIO)++-- | Parse a base URL into the @servant-client@ 'Client.BaseUrl' baikai+-- will send to, normalised so that every spelling of one target is one+-- value: the host lower-cased by 'Url.parseUrl', the port made explicit+-- from the scheme's default when none was given, trailing slashes+-- removed from the path, and one trailing @\/v1@ segment removed.+--+-- That last rule is the base-URL convention: @Model.baseUrl@ is the API+-- __root__ — the host, or the prefix a host mounts the API under —+-- without the version segment, because baikai appends+-- @\/v1\/chat\/completions@, @\/v1\/messages@ or @\/v1\/embeddings@+-- itself. A @\/v1@ suffix is nevertheless accepted and removed rather+-- than refused, because @https:\/\/api.deepseek.com\/v1@ is what every+-- OpenAI SDK teaches and refusing it would break a working configuration+-- for no security gain. Without the rule that base URL composed to+-- @\/v1\/v1\/chat\/completions@.+--+-- Built from 'Url.parseUrl' directly rather than by handing the raw text+-- to @servant-client@'s own @parseBaseUrl@, so that the host baikai+-- resolves a key for and the host it opens a connection to are decided+-- by the same function. (@parseBaseUrl@ also silently prepends+-- @http:\/\/@ to a scheme-less URL, which would send a bearer token in+-- plaintext, and rejects userinfo and query strings with an exception+-- that says nothing useful.)+--+-- 'Left' carries a reason fit to show a caller.+canonicalBaseUrl :: Text -> Either Text Client.BaseUrl+canonicalBaseUrl raw = case Url.parseUrl raw of+  Nothing -> Left "no host could be found in it"+  Just parts -> case Url.scheme parts of+    Nothing ->+      Left+        ( Url.renderEndpoint parts+            <> " has no scheme; start it with https:// or http://"+        )+    Just s+      | s /= "http",+        s /= "https" ->+          Left+            ( Url.renderEndpoint parts+                <> " uses the scheme "+                <> s+                <> "; only http and https are sent"+            )+      | otherwise ->+          let secure = s == "https"+           in Right+                Client.BaseUrl+                  { Client.baseUrlScheme = if secure then Client.Https else Client.Http,+                    Client.baseUrlHost = Text.unpack (Url.host parts),+                    Client.baseUrlPort =+                      maybe (if secure then 443 else 80) id (Url.port parts),+                    Client.baseUrlPath =+                      Text.unpack (Url.stripApiVersion (Url.path parts))+                  }++-- | The cached 'Client.ClientEnv' for a base URL, building one on first+-- use. Two spellings of one target share an entry, because the key is+-- 'canonicalBaseUrl''s rendering rather than the caller's text.+--+-- Throws a 'Baikai.Error.BaikaiError' in the+-- 'Baikai.Error.InvalidRequest' category when the base URL is not one+-- baikai can send to.+getClientEnvCached :: Text -> IO Client.ClientEnv+getClientEnvCached raw = case canonicalBaseUrl raw of+  Left problem ->+    throwIO (invalidRequest ("Model.baseUrl is not usable: " <> problem))+  Right base -> do+    let key = Text.pack (Client.showBaseUrl base)+    modifyMVar clientEnvCache $ \cache ->+      case Map.lookup key cache of+        Just env -> pure (cache, env)+        Nothing -> do+          env <- newClientEnv base+          pure (Map.insert key env cache, env)++-- | How many distinct targets the cache holds. Exposed so a test can+-- observe that two spellings of one host are one entry.+cachedClientEnvCount :: IO Int+cachedClientEnvCount =+  modifyMVar clientEnvCache $ \cache -> pure (cache, Map.size cache)++-- | A fresh manager with no per-response timeout: a streaming response+-- is open for as long as the model is thinking, and @Options.timeoutMs@+-- bounds the whole call from outside.+newClientEnv :: Client.BaseUrl -> IO Client.ClientEnv+newClientEnv base = do+  manager <-+    TLS.newTlsManagerWith+      TLS.tlsManagerSettings+        { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone+        }+  pure (Client.mkClientEnv manager base)++{-# NOINLINE clientEnvCache #-}+clientEnvCache :: MVar (Map Text Client.ClientEnv)+clientEnvCache = unsafePerformIO (newMVar Map.empty)
src/Baikai/Interactive.hs view
@@ -22,8 +22,6 @@     InteractiveLaunchResult (..),     interactiveLaunchRequest,     interactiveLaunchResult,-    _InteractiveLaunchRequest,-    _InteractiveLaunchResult,     renderInteractiveProvider,     renderInteractiveScope,     renderCodexSandboxMode,@@ -78,11 +76,26 @@   | CodexDangerFullAccess   deriving stock (Eq, Ord, Show, Generic) +-- | When Codex asks a human before running a command.+--+-- The first two are spellings older Codex generations accepted and+-- current ones reject. They are kept so the type stays stable for a+-- caller that matches on it, and the Codex launcher in @baikai-openai@+-- refuses a request carrying one with 'Baikai.Agent.SafetyNotExpressible'+-- before starting anything, rather than letting the CLI fail with a+-- usage error after a process was created. data CodexApprovalPolicy-  = CodexApprovalUntrusted-  | CodexApprovalOnFailure-  | CodexApprovalOnRequest-  | CodexApprovalNever+  = -- | Spelled @untrusted@. Rejected by current Codex releases; the+    -- Codex launcher refuses a request carrying it.+    CodexApprovalUntrusted+  | -- | Spelled @on-failure@. Rejected by current Codex releases; the+    -- Codex launcher refuses a request carrying it.+    CodexApprovalOnFailure+  | -- | Spelled @on-request@: the model decides when to ask.+    CodexApprovalOnRequest+  | -- | Spelled @never@: execution failures go straight back to the+    -- model.+    CodexApprovalNever   deriving stock (Eq, Ord, Show, Generic)  -- | Process-level outcome after the interactive CLI exits.@@ -111,14 +124,6 @@     { provider = p,       exitCode = code     }--{-# DEPRECATED _InteractiveLaunchRequest "Use interactiveLaunchRequest instead." #-}-_InteractiveLaunchRequest :: Text -> InteractiveLaunchRequest-_InteractiveLaunchRequest = interactiveLaunchRequest--{-# DEPRECATED _InteractiveLaunchResult "Use interactiveLaunchResult instead." #-}-_InteractiveLaunchResult :: InteractiveProvider -> ExitCode -> InteractiveLaunchResult-_InteractiveLaunchResult = interactiveLaunchResult  renderInteractiveProvider :: InteractiveProvider -> Text renderInteractiveProvider InteractiveClaude = "claude"
src/Baikai/Message.hs view
@@ -15,9 +15,10 @@ --   answers, the tool's name, the result 'content' (text or image), an --   'isError' flag, and an optional timestamp). ----- The 'system' constructor from prior versions is removed: system--- prompts live on 'Baikai.Request.Request.systemPrompt'. The 'Role'--- enum is also removed — pattern-match on the constructor instead.+-- There is no 'system' constructor: a system prompt lives on+-- 'Baikai.Context.Context.systemPrompt', not in the message vector.+-- There is no 'Role' enum either — pattern-match on the constructor+-- instead. -- -- Each constructor wraps a dedicated single-constructor payload record -- ('UserPayload', 'AssistantPayload', 'ToolResultPayload') rather than
src/Baikai/Model.hs view
@@ -3,12 +3,13 @@ -- front to talk to a provider: the 'Api' tag (used to look up the -- registered handler), the provider name, the base URL, the -- per-million-token pricing rates, the context window and max output--- cap, default per-call headers, and a per-API 'Compat' record (a--- placeholder until EP-5 populates the real shims).+-- cap, default per-call headers, and a per-API 'Compat' record+-- ('CompatNone' lets the provider auto-detect the record from the base+-- URL; see "Baikai.Compat"). ----- The previous newtype @Model = Model Text@ — a thin tag for the--- model id — is retired. Use 'modelId' to read the selected upstream--- model identifier, or 'mkModel' to build a dispatchable record.+-- Use 'modelId' to read the selected upstream model identifier, or+-- 'mkModel' to build a dispatchable record from the three+-- discriminators. module Baikai.Model   ( -- * Model     Model,@@ -20,18 +21,21 @@     reasoning,     input,     cost,+    fastModeCost,+    pricingPolicy,     contextWindow,     maxOutputTokens,     headers,     compat,     emptyModel,-    _Model,     mkModel,      -- * Cost rates     ModelCost (..),     zeroModelCost,-    _ModelCost,+    PricingPolicy (..),+    InputPriceTier (..),+    validatePricingPolicy,      -- * Capabilities     InputModality (..),@@ -39,28 +43,42 @@     -- * Compatibility shim     Compat (..),     openaiCompletionsCompatFor,+    openaiResponsesCompatFor,     anthropicMessagesCompatFor,   ) where  import Baikai.Api (Api (..), renderApi)+import Baikai.Auth qualified as Auth import Baikai.Compat-  ( AnthropicMessagesCompat (..),+  ( AnthropicMessagesCompat,     OpenAICompletionsCompat,+    OpenAIResponsesCompat,     autoDetectAnthropicMessages,     autoDetectOpenAICompletions,-    defaultAnthropicThinkingStyle,+    defaultOpenAIResponsesCompat,   )-import Data.Aeson (FromJSON, ToJSON)+import Baikai.Header (HeaderName)+import Control.Monad (unless)+import Data.Aeson+  ( FromJSON (parseJSON),+    ToJSON (toEncoding, toJSON),+    defaultOptions,+    genericToEncoding,+    genericToJSON,+    withObject,+    (.!=),+    (.:?),+  )+import Data.List (nub, sort) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) --- | What kinds of input a model accepts. EP-1 introduced the typed--- content blocks; this field documents which of them the chosen--- 'Model' is allowed to consume.+-- | What kinds of input a model accepts: which typed content blocks+-- ("Baikai.Content") the chosen 'Model' may be given. data InputModality   = InputText   | InputImage@@ -77,6 +95,37 @@   deriving stock (Eq, Show, Generic)   deriving anyclass (FromJSON, ToJSON) +-- | An exclusive input-context threshold. Its complete rate record+-- applies to every token category in the call once total input exceeds it.+data InputPriceTier = InputPriceTier+  { inputAbove :: !Natural,+    rates :: !ModelCost+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)++-- | Optional catalog policy layered over Model.cost. Long cache-write+-- pricing is an absolute per-million rate, selected only for a shaped+-- long-duration request. It overrides the selected tier's write rate.+data PricingPolicy = PricingPolicy+  { inputTiers :: ![InputPriceTier],+    longCacheWriteCost :: !(Maybe Rational)+  }+  deriving stock (Eq, Show, Generic)+  deriving anyclass (ToJSON)++instance FromJSON PricingPolicy where+  parseJSON = withObject "PricingPolicy" $ \o -> do+    p <- PricingPolicy <$> o .:? "inputTiers" .!= [] <*> o .:? "longCacheWriteCost"+    either (fail . show) (const (pure p)) (validatePricingPolicy p)++validatePricingPolicy :: PricingPolicy -> Either Text ()+validatePricingPolicy p = do+  let thresholds = map inputAbove (inputTiers p)+      validRates r = all (>= 0) [inputCost r, outputCost r, cacheReadCost r, cacheWriteCost r]+  unless (thresholds == sort (nub thresholds)) (Left "Pricing thresholds must be strictly increasing")+  unless (all (validRates . rates) (inputTiers p) && maybe True (>= 0) (longCacheWriteCost p)) (Left "Pricing rates must be nonnegative")+ -- | Per-API compatibility shim. 'CompatNone' tells the provider to -- pick a sensible record by inspecting 'baseUrl'; the two real -- constructors carry an explicit per-host record that overrides the@@ -85,6 +134,7 @@ -- dependency. data Compat   = CompatNone+  | CompatOpenAIResponses !OpenAIResponsesCompat   | CompatOpenAICompletions !OpenAICompletionsCompat   | CompatAnthropicMessages !AnthropicMessagesCompat   deriving stock (Eq, Show, Generic)@@ -98,17 +148,31 @@   CompatOpenAICompletions c -> c   _ -> autoDetectOpenAICompletions (baseUrl m) +-- | Explicit Responses facts or the native Responses defaults.+openaiResponsesCompatFor :: Model -> OpenAIResponsesCompat+openaiResponsesCompatFor m = case compat m of+  CompatOpenAIResponses c -> c+  _ -> defaultOpenAIResponsesCompat+ -- | Project the 'AnthropicMessagesCompat' that applies to a 'Model': -- the explicit one if 'compat' is 'CompatAnthropicMessages', -- otherwise the result of inspecting 'baseUrl' via -- 'autoDetectAnthropicMessages'.+--+-- An explicit record always wins. 'CompatNone' means host+-- auto-detection alone: the budget thinking style and sampling+-- parameters supported, which is what every generation before Opus 4.7+-- and every known compatible host accepts. The model id is never+-- consulted, because a generation's wire quirks are a fact of the+-- catalog record, not of its id — every Anthropic model in+-- "Baikai.Models.Generated" carries an explicit+-- 'CompatAnthropicMessages'. A hand-rolled model naming an+-- adaptive-era id must set its own record or start from the catalog+-- value. anthropicMessagesCompatFor :: Model -> AnthropicMessagesCompat anthropicMessagesCompatFor m = case compat m of   CompatAnthropicMessages c -> c-  _ ->-    (autoDetectAnthropicMessages (baseUrl m))-      { thinkingStyle = defaultAnthropicThinkingStyle (modelId m)-      }+  _ -> autoDetectAnthropicMessages (baseUrl m)  -- | The data record baikai dispatches on. data Model = Model@@ -120,14 +184,79 @@     reasoning :: !Bool,     input :: ![InputModality],     cost :: !ModelCost,+    -- | Optional premium speed rates, in USD per million tokens.+    fastModeCost :: !(Maybe ModelCost),+    pricingPolicy :: !(Maybe PricingPolicy),     contextWindow :: !Natural,+    -- | The provider's cap on output tokens for this model, or @0@+    -- when it is unknown (a hand-rolled model built from+    -- 'emptyModel', or a catalog entry upstream published no limit+    -- for). @0@ is not a request for zero output: the OpenAI adapter+    -- omits the cap entirely, and the Anthropic adapter — whose API+    -- requires the field and rejects @0@ — sends+    -- @Baikai.Provider.Claude.Internal.Request.uncappedMaxTokensFloor@+    -- instead. An explicit 'Baikai.Options.maxTokens' always wins,+    -- including an explicit @Just 0@.     maxOutputTokens :: !Natural,-    headers :: !(Map Text Text),+    headers :: !(Map HeaderName Text),     compat :: !Compat   }-  deriving stock (Eq, Show, Generic)-  deriving anyclass (FromJSON, ToJSON)+  deriving stock (Eq, Generic)+  deriving anyclass (FromJSON) +-- | Rendered field by field rather than derived, so that the value of a+-- credential-carrying header prints as 'Auth.redactedMarker'. A 'Model'+-- is the record most likely to reach a log: it is embedded in every+-- 'Baikai.Response.Response', and the guides tell people to @print@+-- one.+--+-- The format is exactly what @deriving stock Show@ produces — the same+-- record syntax, field order and precedence — because the point is to+-- redact one value, not to invent a rendering. A test in+-- @baikai\/test\/Main.hs@ walks the 'Generic' representation and asserts+-- that every field name appears here, so a field added later cannot+-- silently vanish from 'show'.+--+-- 'Eq' is untouched, and so is 'FromJSON': the field itself still holds+-- what the caller put there and the header is still sent. The one lossy+-- path is a JSON round trip — 'toJSON' writes the marker, so decoding+-- the result gives a 'Model' whose credential header /is/ the marker.+-- That is deliberate; a serialised 'Model' is exactly the thing that+-- should not carry a key.+instance Show Model where+  showsPrec d m =+    showParen (d >= 11) $+      showString "Model {"+        . field "modelId" (modelId m)+        . next "name" (name m)+        . next "api" (api m)+        . next "provider" (provider m)+        . next "baseUrl" (baseUrl m)+        . next "reasoning" (reasoning m)+        . next "input" (input m)+        . next "cost" (cost m)+        . next "fastModeCost" (fastModeCost m)+        . next "pricingPolicy" (pricingPolicy m)+        . next "contextWindow" (contextWindow m)+        . next "maxOutputTokens" (maxOutputTokens m)+        . next "headers" (Auth.redactHeaderValues (headers m))+        . next "compat" (compat m)+        . showChar '}'+    where+      field label v = showString label . showString " = " . showsPrec 0 v+      next label v = showString ", " . field label v++-- | Encoded through the 'Generic' representation of a copy whose+-- credential headers have been replaced, so the output is byte-identical+-- to the derived instance's for every model that carries none, and there+-- is no recursion back into this instance.+instance ToJSON Model where+  toJSON = genericToJSON defaultOptions . redactModel+  toEncoding = genericToEncoding defaultOptions . redactModel++redactModel :: Model -> Model+redactModel m = m {headers = Auth.redactHeaderValues (headers m)}+ -- | A zero 'ModelCost' across all rates. Useful as a default for -- models without published pricing (CLI providers, custom hosts). zeroModelCost :: ModelCost@@ -141,6 +270,11 @@  -- | A blank 'Model'. Useful as a record-update base for hand-rolled -- 'Model' values in tests and one-shot scripts.+--+-- Its @api@ is @Custom ""@, which no handler can be registered under+-- meaningfully: dispatching a model that still carries it fails with+-- @No provider registered for API: \<blank Custom tag …\>@. Set @api@+-- (and @modelId@) before calling anything. emptyModel :: Model emptyModel =   Model@@ -152,6 +286,8 @@       reasoning = False,       input = [InputText],       cost = zeroModelCost,+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 0,       maxOutputTokens = 0,       headers = Map.empty,@@ -171,11 +307,3 @@       provider = renderApi apiTag,       baseUrl = baseUrl_     }--{-# DEPRECATED _ModelCost "Use zeroModelCost instead." #-}-_ModelCost :: ModelCost-_ModelCost = zeroModelCost--{-# DEPRECATED _Model "Use emptyModel instead." #-}-_Model :: Model-_Model = emptyModel
src/Baikai/Models/Generated.hs view
@@ -8,32 +8,60 @@  import Baikai.Api (Api (..)) import Baikai.Compat-  ( AnthropicThinkingStyle (..),+  ( AnthropicMessagesCompat+      ( sendSessionAffinityHeaders,+        supportsCacheControlOnTools,+        supportsFastMode,+        supportsForcedToolChoice,+        supportsLongCacheRetention,+        supportsSamplingParameters,+        thinkingStyle+      ),+    AnthropicThinkingStyle (..),     CacheControlFormat (..),     MaxTokensField (..),+    OpenAICompletionsCompat+      ( cacheControlFormat,+        maxTokensField,+        requiresThinkingAsText,+        supportedReasoningEfforts,+        supportsLongCacheRetention,+        supportsSamplingParameters,+        supportsStrictMode,+        supportsToolCalls,+        supportsUsageInStreaming,+        thinkingFormat+      ),+    OpenAIResponsesCompat (..),     ThinkingFormat (..),     defaultAnthropicMessagesCompat,     defaultOpenAICompletionsCompat,+    defaultOpenAIResponsesCompat,   ) import Baikai.Model   ( Compat (..),     InputModality (..),+    InputPriceTier (..),     Model,     ModelCost (..),+    PricingPolicy (..),     api,     baseUrl,     compat,     contextWindow,     cost,     emptyModel,+    fastModeCost,     headers,     input,     maxOutputTokens,     modelId,     name,+    pricingPolicy,     provider,     reasoning,   )+import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.Map.Strict qualified as Map import Data.Ratio ((%)) @@ -54,12 +82,59 @@             cacheReadCost = 1 % 1,             cacheWriteCost = 25 % 2           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     } +anthropic_claude_fable_5_1 :: Model+anthropic_claude_fable_5_1 =+  emptyModel+    { modelId = "claude-fable-5-1",+      name = "Claude Fable 5.1",+      api = AnthropicMessages,+      provider = "anthropic",+      baseUrl = "https://api.anthropic.com",+      reasoning = True,+      input = [InputText, InputImage],+      cost =+        ModelCost+          { inputCost = 10 % 1,+            outputCost = 50 % 1,+            cacheReadCost = 1 % 4,+            cacheWriteCost = 25 % 2+          },+      fastModeCost = Nothing,+      pricingPolicy = Just (PricingPolicy [] (Just (20 % 1))),+      contextWindow = 1000000,+      maxOutputTokens = 128000,+      headers = Map.empty,+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = False,+              supportsForcedToolChoice = False+            }+    }+ anthropic_claude_haiku_4_5 :: Model anthropic_claude_haiku_4_5 =   emptyModel@@ -77,10 +152,22 @@             cacheReadCost = 1 % 10,             cacheWriteCost = 5 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 64000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingBudget,+              supportsSamplingParameters = True,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_opus_4_5 :: Model@@ -100,10 +187,22 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 25 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 64000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingBudget,+              supportsSamplingParameters = True,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_opus_4_6 :: Model@@ -123,10 +222,22 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 25 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = True,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_opus_4_7 :: Model@@ -146,10 +257,22 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 25 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_opus_4_8 :: Model@@ -169,12 +292,75 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 25 % 4           },+      fastModeCost =+        Just+          ( ModelCost+              { inputCost = 10 % 1,+                outputCost = 50 % 1,+                cacheReadCost = 1 % 1,+                cacheWriteCost = 25 % 2+              }+          ),+      pricingPolicy = Just (PricingPolicy [] (Just (10 % 1))),       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = True,+              supportsForcedToolChoice = True+            }     } +anthropic_claude_opus_5 :: Model+anthropic_claude_opus_5 =+  emptyModel+    { modelId = "claude-opus-5",+      name = "Claude Opus 5",+      api = AnthropicMessages,+      provider = "anthropic",+      baseUrl = "https://api.anthropic.com",+      reasoning = True,+      input = [InputText, InputImage],+      cost =+        ModelCost+          { inputCost = 5 % 1,+            outputCost = 25 % 1,+            cacheReadCost = 1 % 2,+            cacheWriteCost = 25 % 4+          },+      fastModeCost =+        Just+          ( ModelCost+              { inputCost = 10 % 1,+                outputCost = 50 % 1,+                cacheReadCost = 1 % 1,+                cacheWriteCost = 25 % 2+              }+          ),+      pricingPolicy = Just (PricingPolicy [] (Just (10 % 1))),+      contextWindow = 1000000,+      maxOutputTokens = 128000,+      headers = Map.empty,+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = True,+              supportsForcedToolChoice = True+            }+    }+ anthropic_claude_sonnet_4_5 :: Model anthropic_claude_sonnet_4_5 =   emptyModel@@ -192,10 +378,22 @@             cacheReadCost = 3 % 10,             cacheWriteCost = 15 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 64000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingBudget,+              supportsSamplingParameters = True,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_sonnet_4_6 :: Model@@ -215,10 +413,22 @@             cacheReadCost = 3 % 10,             cacheWriteCost = 15 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = True,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  anthropic_claude_sonnet_5 :: Model@@ -238,10 +448,22 @@             cacheReadCost = 1 % 5,             cacheWriteCost = 5 % 2           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1000000,       maxOutputTokens = 128000,       headers = Map.empty,-      compat = CompatNone+      compat =+        CompatAnthropicMessages+          defaultAnthropicMessagesCompat+            { supportsLongCacheRetention = True,+              supportsCacheControlOnTools = True,+              sendSessionAffinityHeaders = False,+              thinkingStyle = AnthropicThinkingAdaptive,+              supportsSamplingParameters = False,+              supportsFastMode = False,+              supportsForcedToolChoice = True+            }     }  deepseek_deepseek_chat :: Model@@ -261,6 +483,8 @@             cacheReadCost = 7 % 100,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 64000,       maxOutputTokens = 8192,       headers = Map.empty,@@ -284,6 +508,8 @@             cacheReadCost = 7 % 50,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 64000,       maxOutputTokens = 8192,       headers = Map.empty,@@ -307,6 +533,8 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1047576,       maxOutputTokens = 32768,       headers = Map.empty,@@ -330,6 +558,8 @@             cacheReadCost = 1 % 10,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1047576,       maxOutputTokens = 32768,       headers = Map.empty,@@ -353,6 +583,8 @@             cacheReadCost = 1 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1047576,       maxOutputTokens = 32768,       headers = Map.empty,@@ -376,6 +608,8 @@             cacheReadCost = 5 % 4,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 128000,       maxOutputTokens = 16384,       headers = Map.empty,@@ -399,6 +633,8 @@             cacheReadCost = 3 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 128000,       maxOutputTokens = 16384,       headers = Map.empty,@@ -422,6 +658,8 @@             cacheReadCost = 1 % 8,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -445,6 +683,8 @@             cacheReadCost = 1 % 8,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -468,6 +708,8 @@             cacheReadCost = 7 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -491,6 +733,8 @@             cacheReadCost = 1 % 4,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -514,6 +758,8 @@             cacheReadCost = 3 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -537,6 +783,8 @@             cacheReadCost = 1 % 50,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -560,6 +808,8 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -578,11 +828,13 @@       input = [InputText, InputImage],       cost =         ModelCost-          { inputCost = 5 % 1,-            outputCost = 30 % 1,-            cacheReadCost = 1 % 2,-            cacheWriteCost = 25 % 4+          { inputCost = 4 % 1,+            outputCost = 20 % 1,+            cacheReadCost = 2 % 5,+            cacheWriteCost = 5 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -601,11 +853,13 @@       input = [InputText, InputImage],       cost =         ModelCost-          { inputCost = 1 % 1,-            outputCost = 6 % 1,-            cacheReadCost = 1 % 10,-            cacheWriteCost = 5 % 4+          { inputCost = 1 % 5,+            outputCost = 6 % 5,+            cacheReadCost = 1 % 50,+            cacheWriteCost = 1 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -624,11 +878,13 @@       input = [InputText, InputImage],       cost =         ModelCost-          { inputCost = 5 % 1,-            outputCost = 30 % 1,-            cacheReadCost = 1 % 2,-            cacheWriteCost = 25 % 4+          { inputCost = 4 % 1,+            outputCost = 20 % 1,+            cacheReadCost = 2 % 5,+            cacheWriteCost = 5 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -647,11 +903,13 @@       input = [InputText, InputImage],       cost =         ModelCost-          { inputCost = 5 % 2,-            outputCost = 15 % 1,-            cacheReadCost = 1 % 4,-            cacheWriteCost = 25 % 8+          { inputCost = 2 % 1,+            outputCost = 12 % 1,+            cacheReadCost = 1 % 5,+            cacheWriteCost = 5 % 2           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 1050000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -675,6 +933,8 @@             cacheReadCost = 1 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,@@ -698,12 +958,46 @@             cacheReadCost = 1 % 200,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 400000,       maxOutputTokens = 128000,       headers = Map.empty,       compat = CompatNone     } +openai_gpt_6_astra :: Model+openai_gpt_6_astra =+  emptyModel+    { modelId = "gpt-6-astra",+      name = "GPT-6 Astra",+      api = OpenAIResponses,+      provider = "openai",+      baseUrl = "https://api.openai.com",+      reasoning = True,+      input = [InputText, InputImage],+      cost =+        ModelCost+          { inputCost = 10 % 1,+            outputCost = 50 % 1,+            cacheReadCost = 1 % 1,+            cacheWriteCost = 25 % 2+          },+      fastModeCost = Nothing,+      pricingPolicy = Just (PricingPolicy [InputPriceTier 272000 (ModelCost (20 % 1) (75 % 1) (2 % 1) (25 % 1))] Nothing),+      contextWindow = 1050000,+      maxOutputTokens = 128000,+      headers = Map.empty,+      compat =+        CompatOpenAIResponses+          defaultOpenAIResponsesCompat+            { supportedReasoningEfforts = Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax],+              supportsSamplingParameters = False,+              supportsLongCacheRetention = False,+              supportsPromptCacheOptions = True+            }+    }+ openai_o1 :: Model openai_o1 =   emptyModel@@ -721,6 +1015,8 @@             cacheReadCost = 15 % 2,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 100000,       headers = Map.empty,@@ -744,6 +1040,8 @@             cacheReadCost = 1 % 2,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 100000,       headers = Map.empty,@@ -767,6 +1065,8 @@             cacheReadCost = 11 % 20,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 100000,       headers = Map.empty,@@ -790,6 +1090,8 @@             cacheReadCost = 11 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 100000,       headers = Map.empty,@@ -813,6 +1115,8 @@             cacheReadCost = 3 % 10,             cacheWriteCost = 15 % 4           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 200000,       maxOutputTokens = 8192,       headers = Map.empty,@@ -836,6 +1140,8 @@             cacheReadCost = 3 % 40,             cacheWriteCost = 0 % 1           },+      fastModeCost = Nothing,+      pricingPolicy = Nothing,       contextWindow = 128000,       maxOutputTokens = 16384,       headers = Map.empty,@@ -846,11 +1152,13 @@ allModels :: [Model] allModels =   [ anthropic_claude_fable_5,+    anthropic_claude_fable_5_1,     anthropic_claude_haiku_4_5,     anthropic_claude_opus_4_5,     anthropic_claude_opus_4_6,     anthropic_claude_opus_4_7,     anthropic_claude_opus_4_8,+    anthropic_claude_opus_5,     anthropic_claude_sonnet_4_5,     anthropic_claude_sonnet_4_6,     anthropic_claude_sonnet_5,@@ -874,6 +1182,7 @@     openai_gpt_5_6_terra,     openai_gpt_5_mini,     openai_gpt_5_nano,+    openai_gpt_6_astra,     openai_o1,     openai_o3,     openai_o3_mini,
src/Baikai/Options.hs view
@@ -19,19 +19,32 @@ -- in the OpenAI and Claude providers: connection setup, response -- headers, and full stream drain. On expiry the stream terminates -- in-band with a retryable transient 'Baikai.Error.BaikaiError'.+-- @Just n@ with @n <= 0@ is refused as+-- 'Baikai.Error.InvalidRequest' before any connection is opened;+-- 'Nothing' is the only spelling of \"no bound\". -- -- 'headers' are per-call HTTP header overrides for API providers. -- Provider defaults are built first, then 'Baikai.Model.headers', -- then this field; later values replace earlier ones by -- case-insensitive header name, including auth headers for callers--- intentionally fronting a gateway.+-- intentionally fronting a gateway. Because that is an invitation to+-- put a credential here, the 'Show' and 'ToJSON' instances below print+-- 'Baikai.Auth.redactedMarker' in place of the value of any header+-- whose name looks credential-carrying. The field itself is untouched+-- and the header is still sent exactly as written. ----- EP-4 added @toolChoice@. EP-5 adds @cacheRetention@ and @thinking@--- (provider-agnostic preferences that each provider maps to its own--- primitive — see 'Baikai.CacheRetention' and 'Baikai.ThinkingLevel'--- for the mappings). EP-2 (shikumi) adds @responseFormat@, the--- provider-agnostic structured-output preference — see--- 'Baikai.ResponseFormat'.+-- @cacheRetention@, @thinking@ and @responseFormat@ are+-- provider-agnostic preferences that each provider maps onto its own+-- primitive — see 'Baikai.CacheRetention', 'Baikai.ThinkingLevel' and+-- 'Baikai.ResponseFormat' for the mappings.+--+-- '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,@@ -43,27 +56,37 @@     toolChoice,     cacheRetention,     thinking,+    speed,     responseFormat,+    evidence,     topP,     stopSequences,     seed,     frequencyPenalty,     presencePenalty,     emptyOptions,-    _Options,   ) where  import Baikai.Auth (ApiKeySource)+import Baikai.Auth qualified as Auth import Baikai.CacheRetention (CacheRetention)+import Baikai.Evidence (EvidenceRequest)+import Baikai.Header (HeaderName) import Baikai.ResponseFormat (ResponseFormat)+import Baikai.Speed (Speed) import Baikai.ThinkingLevel (ThinkingLevel) import Baikai.Tool (ToolChoice)-import Data.Aeson (ToJSON, Value)+import Data.Aeson+  ( ToJSON (toEncoding, toJSON),+    Value,+    defaultOptions,+    genericToEncoding,+    genericToJSON,+  ) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text)-import Data.Vector (Vector) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -72,21 +95,86 @@     temperature :: !(Maybe Double),     apiKey :: !(Maybe ApiKeySource),     timeoutMs :: !(Maybe Int),-    headers :: !(Map Text Text),+    headers :: !(Map HeaderName Text),     metadata :: !(Map Text Value),+    -- | 'Nothing' and @Just 'ToolChoiceAuto'@ are the same request: both+    -- send no @tool_choice@ and let the provider apply its own default,+    -- which is @auto@ at Anthropic and OpenAI. The constructor is kept+    -- for a caller who wants to say "auto" explicitly.     toolChoice :: !(Maybe ToolChoice),+    -- | 'Nothing' and @Just 'CacheRetentionNone'@ are the same request:+    -- both send no cache-control marker. The constructor is kept for a+    -- caller who wants to say "no caching" explicitly.     cacheRetention :: !(Maybe CacheRetention),+    -- | Nothing omits the speed field; standard explicitly requests standard+    -- speed. Fast is catalog-gated by Anthropic and dropped with evidence on+    -- unsupported models. See "Baikai.Speed" for availability and pricing.+    speed :: !(Maybe Speed),     thinking :: !(Maybe ThinkingLevel),     responseFormat :: !(Maybe ResponseFormat),+    evidence :: !(Maybe EvidenceRequest),     topP :: !(Maybe Double),-    stopSequences :: !(Maybe (Vector Text)),-    seed :: !(Maybe Integer),+    -- | Sequences that stop generation. Empty means "send nothing" —+    -- one representation, where @Nothing@ and @Just []@ used to be two+    -- indistinguishable ones.+    stopSequences :: ![Text],+    -- | A machine integer, like 'timeoutMs': every provider that accepts+    -- a seed accepts one.+    seed :: !(Maybe Int),     frequencyPenalty :: !(Maybe Double),     presencePenalty :: !(Maybe Double)   }-  deriving stock (Eq, Show, Generic)-  deriving anyclass (ToJSON)+  deriving stock (Eq, Generic) +-- | Rendered field by field rather than derived, so that the value of a+-- credential-carrying header prints as 'Auth.redactedMarker'.+--+-- The format is exactly what @deriving stock Show@ produces — the same+-- record syntax, the same field order, the same @showsPrec@ precedence+-- — because the point is to redact one value, not to invent a new+-- rendering. A test in @baikai\/test\/Main.hs@ walks the 'Generic'+-- representation and asserts that every field name appears here, so a+-- field added later cannot silently vanish from 'show'.+--+-- 'Eq' is untouched: two 'Options' whose credential headers differ are+-- still unequal.+instance Show Options where+  showsPrec d o =+    showParen (d >= 11) $+      showString "Options {"+        . field "maxTokens" (maxTokens o)+        . next "temperature" (temperature o)+        . next "apiKey" (apiKey o)+        . next "timeoutMs" (timeoutMs o)+        . next "headers" (Auth.redactHeaderValues (headers o))+        . next "metadata" (metadata o)+        . next "toolChoice" (toolChoice o)+        . next "cacheRetention" (cacheRetention o)+        . next "speed" (speed o)+        . next "thinking" (thinking o)+        . next "responseFormat" (responseFormat o)+        . next "evidence" (evidence o)+        . next "topP" (topP o)+        . next "stopSequences" (stopSequences o)+        . next "seed" (seed o)+        . next "frequencyPenalty" (frequencyPenalty o)+        . next "presencePenalty" (presencePenalty o)+        . showChar '}'+    where+      field name v = showString name . showString " = " . showsPrec 0 v+      next name v = showString ", " . field name v++-- | Encoded through the 'Generic' representation of a copy whose+-- credential headers have been replaced, so the output is byte-identical+-- to the derived instance's for every record that carries none, and+-- there is no recursion back into this instance.+instance ToJSON Options where+  toJSON = genericToJSON defaultOptions . redactOptions+  toEncoding = genericToEncoding defaultOptions . redactOptions++redactOptions :: Options -> Options+redactOptions o = o {headers = Auth.redactHeaderValues (headers o)}+ emptyOptions :: Options emptyOptions =   Options@@ -98,15 +186,13 @@       metadata = Map.empty,       toolChoice = Nothing,       cacheRetention = Nothing,+      speed = Nothing,       thinking = Nothing,       responseFormat = Nothing,+      evidence = Nothing,       topP = Nothing,-      stopSequences = Nothing,+      stopSequences = [],       seed = Nothing,       frequencyPenalty = Nothing,       presencePenalty = Nothing     }--{-# DEPRECATED _Options "Use emptyOptions instead." #-}-_Options :: Options-_Options = emptyOptions
src/Baikai/Provider.hs view
@@ -10,7 +10,9 @@ -- @import Baikai.Provider@ habit still resolves the symbols a -- caller cares about. module Baikai.Provider-  ( ApiProvider (..),+  ( ApiProvider (apiTag, stream, complete, describeThinking, strengthCeiling),+    apiProvider,+    apiProviderWith,     ProviderRegistry,     newProviderRegistry,     newProviderRegistryFrom,@@ -28,9 +30,14 @@   ) where +import Baikai.Api (Api)+import Baikai.Context (Context)+import Baikai.Model (Model)+import Baikai.Options (Options) import Baikai.Provider.Registry   ( ApiProvider (..),     ProviderRegistry,+    apiProviderWith,     assertRegistered,     completeRequest,     completeRequestWith,@@ -45,3 +52,23 @@     runToolLoop,     runToolLoopWith,   )+import Baikai.Stream (streamingComplete)+import Baikai.Stream.Event (AssistantMessageEvent)+import Streamly.Data.Stream (Stream)++-- | Build an 'ApiProvider' from an 'Baikai.Api.Api' tag and a streaming+-- producer, deriving the synchronous @complete@ by draining that stream+-- with 'Baikai.Stream.streamingComplete'.+--+-- This is the documented construction path. The 'ApiProvider'+-- constructor is not exported, so a field added in a later release+-- cannot break a registration site: start here and override what you+-- need by record update.+--+-- > apiProvider (Custom "my-api") myStream+-- >   & #describeThinking .~ myDescribeThinking+apiProvider ::+  Api ->+  (Model -> Context -> Options -> Stream IO AssistantMessageEvent) ->+  ApiProvider+apiProvider tag producer = apiProviderWith tag producer (streamingComplete producer)
src/Baikai/Provider/Cli/Internal.hs view
@@ -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 (..), providerReportedBasis, zeroCost, zeroCostBreakdown)+import Baikai.Error (BaikaiError, decodeError)+import Baikai.Evidence (EvidenceStrength (..), Observed (..), deriveStrength, usageEnvelope) 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,17 @@ 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 +169,138 @@ 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. A last line with no trailing newline is still parsed.+--+-- Lines are cut out of each chunk with 'BS.elemIndex' and 'BS.splitAt',+-- which are a scan and a constant-time slice, and the pieces of a line+-- that spans a chunk boundary are carried as a reversed list and joined+-- once, when its newline arrives. Every byte is therefore copied a+-- bounded number of times however long the line is. The obvious+-- alternative — unpacking each chunk into a stream of bytes and+-- appending them one at a time with 'BS.snoc' — copies the whole+-- accumulator per byte, which is quadratic in line length: a codex event+-- carrying a two-million-character message cost on the order of a+-- trillion byte moves and in practice never finished.+parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport+parseCodexJsonlStream chunks = do+  (folded, pending) <-+    Stream.fold (Fold.foldl' absorbChunk (emptyCodexAccumulator, [])) chunks+  -- Whatever follows the last newline. An empty remainder — the ordinary+  -- case, because codex terminates every line — decodes to Nothing and+  -- is skipped, exactly as a non-JSON line is.+  let acc = absorbLine folded (joinPieces pending)+  pure+    CodexRunReport+      { message = Text.concat (reverse (acc ^. #messages)),+        threadId = acc ^. #threadId,+        reportedModel = acc ^. #reportedModel,+        usage = acc ^. #usage+      }+  where+    absorbChunk (acc, pending) chunk = case BS.elemIndex newlineByte chunk of+      Nothing -> (acc, chunk : pending)+      Just at ->+        let (piece, rest) = BS.splitAt at chunk+            acc' = absorbLine acc (joinPieces (piece : pending))+         in absorbChunk (acc', []) (BS.drop 1 rest)+    absorbLine acc line = maybe acc (absorbCodexEvent acc) (Aeson.decodeStrict line)+    joinPieces = BS.concat . reverse++-- | 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 +339,421 @@         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,+          availability = Nothing,+          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,+                  availability = Nothing,+                  cost = reportedCost+                }+  _ -> Nothing+  where+    reportedCost = case KeyMap.lookup "total_cost_usd" o of+      Just (Number n) | n >= 0 -> Cost {usd = toRational n, breakdown = zeroCostBreakdown, basis = providerReportedBasis}+      _ -> 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,+      -- Token counts only; see 'Evidence.usageEnvelope'.+      "usage" .= usageEnvelope 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.+--+-- The rule itself is 'Evidence.deriveStrength', shared with the HTTP+-- transports. A subprocess has no response header to capture, so the+-- tool's session or thread identifier is the correlation identifier it+-- passes; this keeps its argument order for the three call sites that+-- already have one.+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 =+  deriveStrength reported Unobserved sessionIdentifier
+ src/Baikai/Provider/Internal/StreamWorker.hs view
@@ -0,0 +1,136 @@+-- | The hand-off between a provider's SSE worker thread and the+-- consumer draining its 'Stream'.+--+-- __This module is internal.__ Like "Baikai.Provider.Cli.Internal" it is+-- exposed so the provider packages can share one implementation, and it+-- is outside baikai's PVP promise: its contents may change in a minor+-- release.+--+-- A provider forks one worker per call to read frames off the socket and+-- push them here; the consumer pulls them out on the other side. Three+-- things about that hand-off are deliberate, and a reader of either+-- provider's @Api.hs@ will find the reasoning only here.+--+-- __The queue is bounded.__ 'frameQueueCapacity' slots, and 'pushFrame'+-- blocks when they are full. A consumer that simply stops pulling — it+-- took the first three events and moved on — therefore stops the socket+-- read after at most 'frameQueueCapacity' further frames, with the+-- worker parked in an interruptible STM wait. No garbage collection and+-- no timer is involved: the bound alone stops the read, and the provider+-- stops being billed for a generation nobody is reading. An unbounded+-- channel gives the opposite behaviour, draining the whole response into+-- memory for a consumer that will never look at it.+--+-- __Cleanup has three strengths, and they are not the same.__+--+-- * /Immediate/ when the consumer stops by exception. 'withFrameWorker'+--   wraps the consumer in 'Stream.bracketIO', so an exception thrown+--   into the draining thread — @Ctrl-C@, 'System.Timeout.timeout',+--   @cancel@ — lands while that thread sits inside the stream's own+--   step, inside the bracket. streamly runs the release synchronously:+--   the worker is killed, the transport's own @bracket@ around the HTTP+--   response runs, and the connection is back in the pool before the+--   exception reaches the caller.+--+-- * /Immediate/ when the stream ends normally, for the same reason.+--+-- * /Eventual/ when the consumer abandons the stream without an+--   exception (@Stream.take 3@ and carry on). Nothing runs at that+--   moment, because nothing knows it happened; the bound above has+--   already stopped the read, and streamly's GC finaliser runs the same+--   'killThread' at the next major collection, which is when the+--   connection is released. Callers who need the connection back at a+--   known moment cancel the draining thread or wrap the drain in+--   'System.Timeout.timeout'.+--+-- A "consumer still alive" flag was considered and rejected: nothing+-- sets it to false on abandonment, so only the collector can answer+-- "will anyone pull again". So was a stall deadline on a full queue —+-- a slow but live consumer, a callback that takes minutes per event,+-- would be cut off, and correctness must not depend on consumer speed.+--+-- __The worker never writes a sentinel.__ End-of-frames is a 'TVar'+-- flag set by 'forkFrameWorker''s 'finally', not a @Nothing@ pushed onto+-- the queue. A sentinel write can block on a full queue and so defeat+-- the very cleanup it is part of; a 'TVar' write never blocks. This is+-- also why an asynchronous exception delivered to the worker can no+-- longer strand the consumer: the flag is set however the body ends.+module Baikai.Provider.Internal.StreamWorker+  ( FrameQueue,+    frameQueueCapacity,+    newFrameQueue,+    pushFrame,+    closeFrames,+    pullFrame,+    forkFrameWorker,+    withFrameWorker,+  )+where++import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread)+import Control.Concurrent.STM+  ( TVar,+    atomically,+    check,+    newTVarIO,+    orElse,+    readTVar,+    writeTVar,+  )+import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue, writeTBQueue)+import Control.Exception (finally, mask_)+import GHC.Generics (Generic)+import Numeric.Natural (Natural)+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++-- | The bounded hand-off between one worker and one consumer.+data FrameQueue a = FrameQueue+  { frames :: !(TBQueue a),+    closed :: !(TVar Bool)+  }+  deriving stock (Generic)++-- | How many frames a worker may run ahead of its consumer.+--+-- Large enough that a consumer doing ordinary per-event work is never+-- the bottleneck, small enough that an abandoned stream stops reading+-- the socket almost at once.+frameQueueCapacity :: Natural+frameQueueCapacity = 64++newFrameQueue :: IO (FrameQueue a)+newFrameQueue = FrameQueue <$> newTBQueueIO frameQueueCapacity <*> newTVarIO False++-- | Push one frame. Blocks while the queue is full, interruptibly, so a+-- worker parked here dies as soon as it is killed.+pushFrame :: FrameQueue a -> a -> IO ()+pushFrame q a = atomically (writeTBQueue (frames q) a)++-- | Mark the queue closed. Never blocks, so it is safe inside a+-- 'finally' on a full queue.+closeFrames :: FrameQueue a -> IO ()+closeFrames q = atomically (writeTVar (closed q) True)++-- | The next frame, or 'Nothing' once the queue is empty /and/ closed.+-- Frames pushed before the close are always delivered first.+pullFrame :: FrameQueue a -> IO (Maybe a)+pullFrame q =+  atomically $+    (Just <$> readTBQueue (frames q))+      `orElse` (readTVar (closed q) >>= check >> pure Nothing)++-- | Fork a worker body so that its 'ThreadId' cannot be lost to an+-- asynchronous exception arriving between the fork and the caller+-- recording it, and so that the queue is closed however the body ends —+-- normal return, synchronous exception, or 'killThread'.+forkFrameWorker :: FrameQueue a -> IO () -> IO ThreadId+forkFrameWorker q body =+  mask_ (forkIOWithUnmask (\unmask -> unmask body `finally` closeFrames q))++-- | Run a consumer stream with the worker alive, killing the worker when+-- the stream stops, throws, or is collected. See the module+-- documentation for which of those is immediate and which is eventual.+withFrameWorker :: FrameQueue a -> IO () -> Stream IO b -> Stream IO b+withFrameWorker q body consumer =+  Stream.bracketIO (forkFrameWorker q body) killThread (const consumer)
src/Baikai/Provider/Registry.hs view
@@ -1,10 +1,12 @@+{-# LANGUAGE LambdaCase #-}+ -- | The provider registry — the dispatch surface that replaces the -- prior 'Baikai.Provider' typeclass and 'SomeProvider' existential. ----- An 'ApiProvider' is the per-API handler. EP-3 promotes 'stream' to--- the primary method: every handler exposes a streaming producer--- that emits 'AssistantMessageEvent' values, and 'complete' is the--- synchronous draining wrapper (typically @streamingComplete . stream@).+-- An 'ApiProvider' is the per-API handler, and 'stream' is its primary+-- method: every handler exposes a streaming producer that emits+-- 'AssistantMessageEvent' values, and 'complete' is the synchronous+-- draining wrapper (typically @streamingComplete . stream@). -- Callers can use an explicit 'ProviderRegistry' handle to isolate handler -- sets, or use the global convenience registry for simple scripts. --@@ -13,7 +15,9 @@ -- error-shaped 'Response' in the 'Baikai.Error.ProviderUnavailable' -- category. module Baikai.Provider.Registry-  ( ApiProvider (..),+  ( ApiProvider (apiTag, stream, complete, describeThinking, strengthCeiling),+    apiProviderWith,+    describeApi,     ProviderRegistry,     newProviderRegistry,     newProviderRegistryFrom,@@ -22,23 +26,30 @@     registerApiProvider,     assertRegistered,     lookupApiProviderWith,+    evidenceRefusals,     lookupApiProvider,     completeRequestWith,     completeRequest,+    requireEvidenceOnResponse,     runToolLoopWith,     runToolLoop,     completeText,   ) where -import Baikai.Api (Api, renderApi)-import Baikai.Content (AssistantContent (..), ToolCall)+import Baikai.Api (Api (..), normaliseApi, renderApi)+import Baikai.Content (AssistantContent (..), ToolCall, isCutOffToolCall) import Baikai.Context (Context, appendToolResult, contextOf) import Baikai.Error (providerUnavailable)+import Baikai.Error qualified as Error+import Baikai.Evidence (ThinkingTranslation)+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)@@ -52,18 +63,97 @@ import Data.Text qualified as Text import Data.Time (getCurrentTime) import Data.Vector qualified as Vector+import GHC.Generics (Generic) import Streamly.Data.Stream (Stream) import System.IO.Unsafe (unsafePerformIO)  -- | A per-API handler. 'stream' is the primary streaming -- entry point; 'complete' is the synchronous draining wrapper, -- typically @streamingComplete . stream@ from "Baikai.Stream".+--+-- Construction: the constructor is deliberately not exported. Start+-- from 'Baikai.Provider.apiProvider' and override fields by record+-- update, so that a field added in a later release cannot break a+-- registration site — as adding 'describeThinking' in 0.5.0.0 did. 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),+    -- | The highest strength this provider's evidence can reach when+    -- everything goes well: a static declaration the pre-dispatch gate+    -- compares against a strict caller's requirement.+    --+    -- Only the provider knows this, which is why it is declared here+    -- rather than looked up by tag. 'Evidence.declaredStrength' is where+    -- the built-in providers get their value; a caller-supplied+    -- transport that observes a model was previously capped at+    -- 'Evidence.EvidenceRequestedOnly' by that table and so could never+    -- satisfy a strict 'Evidence.EvidenceCorrelated' caller.+    --+    -- Declaring more than the provider delivers is the one remaining way+    -- to make strict mode lie, so a declaration above+    -- 'Evidence.EvidenceRequestedOnly' needs a test that drives the+    -- provider to it. A provider that attaches no record at all must+    -- declare 'Evidence.EvidenceRequestedOnly', and will still fail a+    -- strict caller at the terminal — see+    -- @docs\/adr\/0014-strict-evidence-means-a-record-exists.md@.+    strengthCeiling :: !Evidence.EvidenceStrength   }+  deriving stock (Generic) +-- | Build an 'ApiProvider' from its three functions, leaving every+-- later-added field at a safe default.+--+-- This is the explicit builder: it takes the streaming producer /and/+-- the synchronous completer, because "Baikai.Provider.Registry" cannot+-- import 'Baikai.Stream.streamingComplete' without a module cycle.+-- Most callers want 'Baikai.Provider.apiProvider', which supplies the+-- completer by draining the stream.+--+-- 'describeThinking' defaults to reporting that nothing was requested+-- and nothing translated, which is honest for a transport with no+-- reasoning controls; 'strengthCeiling' defaults to+-- 'Evidence.EvidenceRequestedOnly', matching @declaredStrength (Custom _)@.+-- Override either by record update.+apiProviderWith ::+  Api ->+  (Model -> Context -> Options -> Stream IO AssistantMessageEvent) ->+  (Model -> Context -> Options -> IO Response) ->+  ApiProvider+apiProviderWith tag producer completer =+  ApiProvider+    { apiTag = tag,+      stream = producer,+      complete = completer,+      describeThinking = \_ _ -> Evidence.noThinkingRequested,+      strengthCeiling = Evidence.EvidenceRequestedOnly+    }++-- | How an 'Api' tag reads in a dispatch failure.+--+-- 'renderApi' everywhere except @Custom ""@, which renders as the empty+-- string and made "No provider registered for API: " the whole message.+-- A blank tag has one cause — 'Baikai.Model.emptyModel' whose @api@ was+-- never set — so the message says that instead of nothing.+describeApi :: Api -> Text+describeApi = \case+  Custom "" -> "<blank Custom tag — emptyModel.api was never set>"+  other -> renderApi other+ -- | A mutable provider registry handle. Each handle owns its own handler map, -- so tests and applications can maintain isolated provider sets in one process. newtype ProviderRegistry = ProviderRegistry@@ -93,9 +183,16 @@ -- | Install (or replace) a handler. Idempotent for the same 'Api' -- tag — calling 'registerApiProviderWith' twice for the same tag keeps only -- the second handler.+--+-- The key is 'normaliseApi' of the provider's own tag, so registering+-- under @Custom \"anthropic-messages\"@ and under+-- 'Baikai.Api.AnthropicMessages' collide as one entry rather than+-- sitting side by side and dispatching by which spelling the model+-- happened to use. registerApiProviderWith :: ProviderRegistry -> ApiProvider -> IO () registerApiProviderWith reg p =-  atomicModifyIORef' (registryRef reg) $ \m -> (Map.insert (apiTag p) p m, ())+  atomicModifyIORef' (registryRef reg) $ \m ->+    (Map.insert (normaliseApi (apiTag p)) p m, ())  -- | Install (or replace) a handler in the process-global registry. registerApiProvider :: ApiProvider -> IO ()@@ -121,8 +218,13 @@       )  -- | Look up the handler registered for an 'Api' tag.+--+-- Both the stored key and the query go through 'normaliseApi', so a+-- handler registered under @Custom \"anthropic-messages\"@ answers a+-- model tagged 'Baikai.Api.AnthropicMessages', and the reverse. lookupApiProviderWith :: ProviderRegistry -> Api -> IO (Maybe ApiProvider)-lookupApiProviderWith reg tag = Map.lookup tag <$> readIORef (registryRef reg)+lookupApiProviderWith reg tag =+  Map.lookup (normaliseApi tag) <$> readIORef (registryRef reg)  -- | Look up the handler registered for an 'Api' tag in the process-global -- registry.@@ -136,16 +238,107 @@ 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+      [] -> requireEvidenceOnResponse opts <$> 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: " <> describeApi (Model.api m)+          err = providerUnavailable detail+      ev <-+        Build.minimalEvidence           m+          opts+          (Build.transportForModel m)+          (Build.requestedTranslation opts)+          (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} +-- | The 'Response' twin of 'Baikai.Stream.requireEvidenceOnTerminal':+-- fail a strict call whose successful response carries no evidence+-- record.+--+-- Both dispatch points need the rule because the built-in providers'+-- @complete@ is @streamingComplete . stream@, which reassembles the+-- provider's own stream and never passes through+-- 'Baikai.Stream.streamRequestWith'. A caller using 'completeRequest'+-- with no sink at all therefore gets the same guarantee as a streaming+-- one: under 'Evidence.EvidenceRequired', a record exists or the call+-- failed.+--+-- A response that already failed keeps its own error, which is more+-- useful than this one and already satisfies the contract.+requireEvidenceOnResponse :: Options -> Response -> Response+requireEvidenceOnResponse opts resp = case Build.strictnessOf opts of+  Evidence.EvidenceRequired _ | recordMissing -> failResponse resp+  _ -> resp+  where+    recordMissing = case (responseError resp, resp) of+      (Nothing, Response {evidence = Nothing}) -> True+      _ -> False++    failResponse r@Response {message = msg} =+      r+        { errorInfo = Just Build.missingEvidenceError,+          message =+            msg+              { stopReason = ErrorReason,+                errorMessage = Just (Error.message Build.missingEvidenceError)+              }+        }++-- | 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)+      (strengthCeiling p)+      (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 completeRequest = completeRequestWith globalProviderRegistry@@ -173,6 +366,12 @@ -- exceptions become error tool results so the model can recover; asynchronous -- exceptions are rethrown. Dispatchers should return 'toolResultErrorText' for -- unknown tool names rather than throwing.+--+-- The loop also stops, with the response and its tool calls intact, when+-- any tool call was cut off by the output cap+-- ('Baikai.Content.isCutOffToolCall'). The model asked for something it+-- could not finish, and the only useful next step -- raise @maxTokens@+-- and retry -- is the caller's to take. runToolLoopWith ::   ProviderRegistry ->   Int ->@@ -192,10 +391,17 @@           ctx' <- appendToolResult ctx resp (safeDispatcher dispatcher)           go (remaining - 1) ctx' +    -- A cut-off call is normally a 'Length' stop, which the second+    -- clause already catches, but a compatible host that reports+    -- @finish_reason: tool_calls@ for truncated arguments would slip+    -- through it. Dispatching a call the model never finished asking+    -- for is the one outcome this loop must not have, so the check is+    -- on the calls themselves.     shouldStop remaining resp =       responseError resp /= Nothing         || responseStopReason resp /= ToolUse         || Vector.null (responseToolCalls resp)+        || Vector.any isCutOffToolCall (responseToolCalls resp)         || remaining <= 1  -- | One-shot text completion through the global registry. Throws the
+ src/Baikai/Provider/Transport/Classify.hs view
@@ -0,0 +1,202 @@+-- | Transport-failure classification, shared by every HTTP provider.+--+-- The rule is /where/ the failure happened, not what type it is. A+-- failure after the request went out that breaks or ends the connection+-- is 'TransientError': the same call may well succeed on the next+-- attempt. A failure that says the caller's request or the process's+-- configuration is wrong — a bad URL, an unsendable header, a proxy or+-- TLS setup that cannot work, a server that does not speak HTTP — is+-- not retryable. A programming error is neither, and stays+-- 'OtherError' so it is not silently retried forever.+--+-- Three exception types reach a provider's worker, because+-- @http-client@ delivers the same underlying failure differently+-- depending on the phase it happened in. At connect time the manager's+-- exception wrapper turns a socket or TLS failure into+-- @HttpExceptionRequest _ (InternalException _)@ or+-- @ConnectionFailure@. While the response body is streaming, only+-- @http-client@'s own thin wrapper is in play, so an 'IOException' from+-- the socket or a 'TLS.TLSException' from the session reaches the+-- caller /raw/ — which is why a classifier that understood+-- 'HTTP.HttpException' alone called a mid-stream reset 'OtherError'+-- while calling the identical reset at connect time transient.+--+-- Providers call 'classifyTransportException' and keep their own+-- fallback for a 'Nothing'; see+-- @Baikai.Provider.Claude.Internal.ErrorClass.classifyException@.+module Baikai.Provider.Transport.Classify+  ( classifyTransportException,+    classifyHttpException,+    classifyHttpExceptionContent,+    classifyIOException,+    classifyTlsException,+  )+where++import Baikai.Error+  ( BaikaiError (..),+    ErrorCategory (..),+    httpError,+    invalidRequest,+    parseHttpDate,+    parseRetryAfterSeconds,+    providerError,+    retryAfterSecondsAt,+  )+import Control.Exception (SomeException, displayException, fromException)+import Data.ByteString (ByteString)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Text.Encoding.Error qualified as Text+import Foreign.C.Error+  ( Errno (..),+    eCONNABORTED,+    eCONNRESET,+    eHOSTDOWN,+    eHOSTUNREACH,+    eNETDOWN,+    eNETRESET,+    eNETUNREACH,+    ePIPE,+    eTIMEDOUT,+  )+-- Qualified: its 'IOErrorType' has a constructor named @OtherError@,+-- which collides with the 'ErrorCategory' constructor of that name.+import GHC.IO.Exception qualified as IOE+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Types.Header (hDate, hRetryAfter)+import Network.HTTP.Types.Status (statusCode)+import Network.TLS qualified as TLS++-- | Classify any exception a transport can raise. 'Nothing' means "not+-- a transport failure at all" — the caller keeps its own fallback,+-- which is what makes a @userError@ from a buggy callback stay+-- 'OtherError' instead of being reported as a network blip.+classifyTransportException :: SomeException -> Maybe BaikaiError+classifyTransportException ex+  | Just httpEx <- fromException ex = Just (classifyHttpException httpEx)+  | Just tlsEx <- fromException ex = Just (classifyTlsException tlsEx)+  | Just ioEx <- fromException ex = classifyIOException ioEx+  | otherwise = Nothing++-- | Classify an @http-client@ 'HTTP.HttpException'.+classifyHttpException :: HTTP.HttpException -> BaikaiError+classifyHttpException = \case+  HTTP.InvalidUrlException url reason ->+    invalidRequest (Text.pack (url <> ": " <> reason))+  HTTP.HttpExceptionRequest _ content -> classifyHttpExceptionContent content++-- | Classify the payload of an 'HTTP.HttpExceptionRequest'.+classifyHttpExceptionContent :: HTTP.HttpExceptionContent -> BaikaiError+classifyHttpExceptionContent = \case+  -- A response arrived and carried a failing status. Unreachable from+  -- baikai's own transports, which never install+  -- 'throwErrorStatusCodes'; mapped for third-party providers built on+  -- http-client.+  HTTP.StatusCodeException resp body ->+    let hdrs = HTTP.responseHeaders resp+        headerText name = decodeLenient <$> lookup name hdrs+        -- The server's own Date is the reference instant, so an+        -- HTTP-date Retry-After does not inherit this machine's clock+        -- skew. Falling back to epoch would be worse than falling back+        -- to the integer form alone, so a missing Date leaves the date+        -- form unconverted here; the transports, which are in IO, use+        -- the local clock instead.+        retryAfter = case parseHttpDate =<< headerText hDate of+          Just reference -> retryAfterSecondsAt reference =<< headerText hRetryAfter+          Nothing -> parseRetryAfterSeconds =<< headerText hRetryAfter+     in httpError (statusCode (HTTP.responseStatus resp)) retryAfter (decodeLenient body)+  -- The connection could not be made, or went quiet, or went away.+  HTTP.ConnectionFailure e -> transient ("connection failure: " <> Text.pack (displayException e))+  HTTP.ConnectionTimeout -> transient "connection timeout"+  HTTP.ResponseTimeout -> transient "response timeout"+  HTTP.ConnectionClosed -> transient "connection closed"+  HTTP.NoResponseDataReceived -> transient "no response data received"+  HTTP.IncompleteHeaders -> transient "incomplete response headers"+  -- The body broke after the status line: framing, declared length, or+  -- inflation. A server that closes the socket mid-chunk surfaces here.+  HTTP.InvalidChunkHeaders -> transient "chunked response body ended or broke mid-chunk"+  HTTP.ResponseBodyTooShort expected actual ->+    transient+      ( "response body too short: expected "+          <> tshow expected+          <> " bytes, got "+          <> tshow actual+      )+  HTTP.HttpZlibException e ->+    transient ("compressed response body could not be inflated: " <> tshow e)+  -- http-client-tls's wrapper for a socket or TLS failure at connect+  -- time. The constructor is documented as carrying exactly those, so+  -- an unrecognised inner exception is still a connection failure.+  HTTP.InternalException inner+    | Just tlsEx <- fromException inner -> classifyTlsException tlsEx+    | Just ioEx <- fromException inner ->+        transient (Text.pack (displayException (ioEx :: IOE.IOException)))+    | otherwise -> transient (Text.pack (displayException inner))+  -- The caller's request cannot be sent as written.+  HTTP.InvalidRequestHeader h -> invalidRequest ("invalid request header: " <> decodeLenient h)+  HTTP.InvalidDestinationHost h -> invalidRequest ("invalid destination host: " <> decodeLenient h)+  HTTP.WrongRequestBodyStreamSize expected actual ->+    invalidRequest+      ( "request body size mismatch: declared "+          <> tshow expected+          <> ", sent "+          <> tshow actual+      )+  -- Everything else is a server that does not speak HTTP, or a proxy or+  -- redirect configuration that cannot work. Retrying changes nothing.+  other -> providerError (Text.take 300 (tshow other))+  where+    tshow :: (Show a) => a -> Text+    tshow = Text.pack . show++-- | Classify a raw 'IOE.IOException', which is what a socket failure+-- during the body read looks like.+--+-- Both the error /type/ and the errno are consulted, because @base@+-- maps @ECONNABORTED@ to the 'IOE.OtherError' error type: a type-only+-- rule would call an aborted connection a programming error.+classifyIOException :: IOE.IOException -> Maybe BaikaiError+classifyIOException ioe+  | IOE.ioe_type ioe `elem` [IOE.ResourceVanished, IOE.EOF, IOE.TimeExpired] =+      Just (transient detail)+  | Just n <- IOE.ioe_errno ioe, Errno n `elem` socketErrnos = Just (transient detail)+  | otherwise = Nothing+  where+    detail = Text.pack (displayException ioe)+    socketErrnos =+      [ eCONNABORTED,+        eCONNRESET,+        eNETRESET,+        eNETDOWN,+        eNETUNREACH,+        eHOSTDOWN,+        eHOSTUNREACH,+        eTIMEDOUT,+        ePIPE+      ]++-- | Classify a 'TLS.TLSException'. The constructor names encode /when/+-- the failure happened, which is exactly the fact the rule needs: a+-- session that existed and broke is transient, a session that never+-- existed is a trust-store, protocol or library-misuse problem that a+-- retry will reproduce.+classifyTlsException :: TLS.TLSException -> BaikaiError+classifyTlsException = \case+  TLS.Terminated _ why err ->+    transient ("TLS session terminated: " <> Text.pack why <> " (" <> tshow err <> ")")+  TLS.PostHandshake err -> transient ("TLS failure after handshake: " <> tshow err)+  TLS.Uncontextualized err -> transient ("TLS failure: " <> tshow err)+  TLS.HandshakeFailed err -> providerError ("TLS handshake failed: " <> tshow err)+  TLS.ConnectionNotEstablished -> providerError "TLS connection not established"+  TLS.MissingHandshake -> providerError "TLS handshake missing"+  where+    tshow :: (Show a) => a -> Text+    tshow = Text.pack . show++transient :: Text -> BaikaiError+transient t = (providerError ("connection error: " <> t)) {category = TransientError}++decodeLenient :: ByteString -> Text+decodeLenient = Text.decodeUtf8With Text.lenientDecode
src/Baikai/Response.hs view
@@ -13,7 +13,6 @@ module Baikai.Response   ( Response (..),     emptyResponse,-    _Response,     responseMessage,     flattenAssistantBlocks,     flattenAssistantText,@@ -26,6 +25,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,11 +52,22 @@     -- 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) --- | A blank assistant turn at epoch start. Useful as a fixture base+-- | A blank assistant turn with no timestamp. Useful as a fixture base -- for tests and as the default in error paths where no message was -- received. emptyResponse :: Response@@ -75,7 +86,8 @@       provider = "",       responseId = Nothing,       latencyMs = 0,-      errorInfo = Nothing+      errorInfo = Nothing,+      evidence = Nothing     }  -- | Wrap the response payload as a conversation 'AssistantMessage'.@@ -124,9 +136,6 @@       provider = Model.provider m,       responseId = Nothing,       latencyMs = latency,-      errorInfo = Just err+      errorInfo = Just err,+      evidence = Nothing     }--{-# DEPRECATED _Response "Use emptyResponse instead." #-}-_Response :: Response-_Response = emptyResponse
src/Baikai/ResponseFormat.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -Wno-partial-fields #-}+{-# LANGUAGE OverloadedRecordDot #-}  -- | Provider-agnostic structured-output preference. --@@ -8,26 +8,57 @@ -- structured-output constraint (today's behaviour). module Baikai.ResponseFormat   ( ResponseFormat (..),+    JsonSchemaFormat (name, schema, strict),+    jsonSchemaFormat,   ) where -import Data.Aeson (FromJSON, ToJSON, Value)+import Data.Aeson+  ( FromJSON (parseJSON),+    ToJSON (toJSON),+    Value,+    object,+    withObject,+    (.:),+    (.:?),+    (.=),+  )+import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics (Generic) +-- | A named JSON Schema to enforce.+--+-- The 'schema' is a raw JSON Schema document (an aeson 'Value'), passed+-- through verbatim; baikai never inspects or validates it. 'strict'+-- requests the provider's strict schema-enforcement mode where available+-- (OpenAI honours it; Anthropic structured outputs are always+-- schema-enforcing and ignore it).+--+-- Construction: the constructor is deliberately not exported. Start from+-- 'jsonSchemaFormat' and override 'strict' by record update.+data JsonSchemaFormat = JsonSchemaFormat+  { name :: !Text,+    schema :: !Value,+    strict :: !Bool+  }+  deriving stock (Eq, Show, Generic)++-- | A schema request from its name and its schema document, with+-- @strict = False@.+jsonSchemaFormat :: Text -> Value -> JsonSchemaFormat+jsonSchemaFormat schemaName schemaDoc =+  JsonSchemaFormat {name = schemaName, schema = schemaDoc, strict = False}+ -- | How to constrain the model's output.+--+-- The schema fields live on 'JsonSchemaFormat' rather than directly on+-- the 'JsonSchema' constructor: as fields of a sum they were partial+-- selectors, and @name f@ on a 'JsonObject' was a crash rather than a+-- type error. data ResponseFormat-  = -- | Enforce a named JSON Schema. The 'schema' is a raw JSON-    --   Schema document (an aeson 'Value'), passed through verbatim;-    --   baikai never inspects or validates it. 'strict' requests the-    --   provider's strict schema-enforcement mode where available-    --   (OpenAI honours it; Anthropic structured outputs are always-    --   schema-enforcing and ignore it).-    JsonSchema-      { name :: !Text,-        schema :: !Value,-        strict :: !Bool-      }+  = -- | Enforce a named JSON Schema.+    JsonSchema !JsonSchemaFormat   | -- | Plain-JSON mode: the model must emit syntactically valid JSON     --   but is not constrained to a specific shape. Maps to OpenAI's     --   @{"type":"json_object"}@; on Anthropic (whose structured@@ -35,4 +66,33 @@     --   @{"type":"object"}@ schema.     JsonObject   deriving stock (Eq, Show, Generic)-  deriving anyclass (FromJSON, ToJSON)++-- | Hand-written to keep the flat encoding the derived instances+-- produced before 'JsonSchemaFormat' existed:+-- @{"tag":"JsonSchema","name":…,"schema":…,"strict":…}@ and+-- @{"tag":"JsonObject"}@. 'Baikai.Options.Options' derives 'ToJSON'+-- through this, and at least one consumer keys a cache on the result.+instance ToJSON ResponseFormat where+  toJSON (JsonSchema f) =+    object+      [ "tag" .= ("JsonSchema" :: Text),+        "name" .= f.name,+        "schema" .= f.schema,+        "strict" .= f.strict+      ]+  toJSON JsonObject = object ["tag" .= ("JsonObject" :: Text)]++instance FromJSON ResponseFormat where+  parseJSON = withObject "ResponseFormat" $ \o -> do+    tag <- o .: "tag"+    case tag :: Text of+      "JsonObject" -> pure JsonObject+      "JsonSchema" -> do+        schemaName <- o .: "name"+        schemaDoc <- o .: "schema"+        isStrict <- o .:? "strict"+        pure+          ( JsonSchema+              (jsonSchemaFormat schemaName schemaDoc) {strict = fromMaybe False isStrict}+          )+      other -> fail ("unknown ResponseFormat tag: " <> show other)
+ src/Baikai/Speed.hs view
@@ -0,0 +1,13 @@+-- | Provider-independent inference speed preference. Anthropic sends fast mode+-- only for catalog entries advertising it (currently Opus 5 and Opus 4.8).+-- Their published fast rates are twice standard rates. Unsupported fast+-- requests are dropped with an evidence adjustment. Other providers omit it.+-- A request is a preference; only provider usage reports which speed ran.+module Baikai.Speed (Speed (..)) where++import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generic)++data Speed = SpeedStandard | SpeedFast+  deriving stock (Eq, Show, Generic)+  deriving anyclass (FromJSON, ToJSON)
src/Baikai/StopReason.hs view
@@ -8,7 +8,7 @@ -- subprocess reports an error. -- -- Constructor encoding on the wire is snake-case: @"stop"@, @"length"@,--- @"tool_use"@, @"error"@, @"aborted"@. @ErrorReason@ is renamed to+-- @"tool_use"@, @"error"@. @ErrorReason@ is renamed to -- @"error"@ so the Haskell name does not clash with @Prelude.Either.Left@ -- callers and the wire shape stays terse. module Baikai.StopReason (StopReason (..)) where@@ -29,7 +29,6 @@   | Length   | ToolUse   | ErrorReason-  | Aborted   deriving stock (Eq, Show, Generic)  stopReasonOptions :: Options
src/Baikai/Stream.hs view
@@ -24,10 +24,10 @@     streamingComplete,     reassembleResponse,     liftCompleteToStream,+    requireEvidenceOnTerminal,   ) where -import Baikai.Api (renderApi) import Baikai.Content   ( AssistantContent (..),     TextContent (..),@@ -36,6 +36,9 @@ import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Error (BaikaiError, providerError, providerUnavailable)+import Baikai.Evidence (ModelCallEvidence)+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,8 @@ import Baikai.Provider.Registry   ( ApiProvider (..),     ProviderRegistry,+    describeApi,+    evidenceRefusals,     globalProviderRegistry,     lookupApiProviderWith,   )@@ -90,7 +95,8 @@ streamRequest = streamRequestWith globalProviderRegistry  -- | Dispatch a streaming call through the selected provider registry.--- Returns a one-event error stream when no handler is registered for that tag.+-- Returns an 'EventStart' then 'EventError' stream when no handler is+-- registered for that tag. streamRequestWith ::   ProviderRegistry ->   Model ->@@ -101,8 +107,17 @@   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 (applyStrict (stream p m ctx opts))+        refusals ->+          Stream.fromList <$> refusedEvents m opts (describeThinking p m opts) refusals+  where+    -- A best-effort or opted-out call pays one 'Maybe' test here and no+    -- per-event map; only a strict call is rewritten event by event.+    applyStrict = case Build.strictnessOf opts of+      Evidence.EvidenceRequired _ -> fmap (requireEvidenceOnTerminal opts)+      Evidence.EvidenceBestEffort -> id  -- | Stream a request through the process-global registry, invoking the -- callback once per event, then return the same reassembled 'Response'@@ -175,7 +190,11 @@   { model :: !Model,     -- | 'Just' once 'EventStart' has been observed.     skeleton :: !(Maybe Message),-    -- | Captured by the reassembler when the fold starts driving the stream.+    -- | Captured by the reassembler when the fold starts driving the+    -- stream, and used to measure 'latencyMs' when the provider stamped+    -- no timestamps on its skeleton or its terminal. Provider+    -- timestamps stay primary: a lifted or replaying provider stamps+    -- the true provider window, which this clock cannot see.     wallStart :: !UTCTime,     -- | Provider message id, preferring the terminal payload over the start payload.     responseId :: !(Maybe Text),@@ -195,6 +214,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)@@ -213,47 +235,76 @@       terminal = Nothing     } +-- | Fold one event into the assembly.+--+-- Two totality rules hold over the whole fold and are stated here+-- because they are invisible at the individual branches. __The first+-- terminal wins__: once 'terminal' is 'Just', every further event is+-- ignored, so a producer that keeps talking after its terminal cannot+-- rewrite the answer. __The first start wins__: a duplicated+-- 'EventStart' keeps the first skeleton, and @responseId@ merges with+-- '<|>' on every event that carries one, so a later 'Nothing' never+-- erases an id an earlier event supplied. Both match the OpenAI+-- assembler's @firstObserved@ discipline. step :: ReassemblyState -> AssistantMessageEvent -> ReassemblyState-step s = \case-  EventStart StartPayload {partial = sk, responseId = rid} ->-    s & #skeleton .~ Just sk & #responseId .~ rid-  TextStart IndexPayload {contentIndex = i} ->-    s & #textBuf %~ IntMap.insert i Text.empty-  TextDelta DeltaPayload {contentIndex = i, delta = d} ->-    s & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i d-  TextEnd BlockEndPayload {contentIndex = i, content = body} ->-    s-      & #blocks %~ IntMap.insert i (AssistantText (TextContent body))-      & #textBuf %~ IntMap.delete i-  ThinkingStart IndexPayload {contentIndex = i} ->-    s & #thinkBuf %~ IntMap.insert i Text.empty-  ThinkingDelta DeltaPayload {contentIndex = i, delta = d} ->-    s & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i d-  ThinkingEnd ThinkingEndPayload {contentIndex = i, content = tc} ->-    s-      & #blocks-        %~ IntMap.insert-          i-          (AssistantThinking tc)-      & #thinkBuf %~ IntMap.delete i-  ToolCallStart IndexPayload {contentIndex = i} ->-    s & #toolArgsBuf %~ IntMap.insert i Text.empty-  ToolCallDelta DeltaPayload {contentIndex = i, delta = d} ->-    s & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i d-  ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} ->-    s-      & #blocks %~ IntMap.insert i (AssistantToolCall tc)-      & #toolArgsBuf %~ IntMap.delete i-  EventDone TerminalPayload {reason = r, message = msg, responseId = rid} ->-    s-      & #terminal-        .~ Just TerminalSeen {reason = r, message = msg, errorInfo = Nothing, failed = False}-      & #responseId %~ (\old -> rid <|> old)-  EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei} ->-    s-      & #terminal-        .~ Just TerminalSeen {reason = r, message = msg, errorInfo = ei, failed = True}-      & #responseId %~ (\old -> rid <|> old)+step s event+  | Just _ <- s ^. #terminal = s+  | otherwise = case event of+      EventStart StartPayload {partial = sk, responseId = rid} ->+        s+          & #skeleton %~ (\old -> old <|> Just sk)+          & #responseId %~ (\old -> rid <|> old)+      TextStart IndexPayload {contentIndex = i} ->+        s & #textBuf %~ IntMap.insert i Text.empty+      TextDelta DeltaPayload {contentIndex = i, delta = d} ->+        s & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i d+      TextEnd BlockEndPayload {contentIndex = i, content = body} ->+        s+          & #blocks %~ IntMap.insert i (AssistantText (TextContent body))+          & #textBuf %~ IntMap.delete i+      ThinkingStart IndexPayload {contentIndex = i} ->+        s & #thinkBuf %~ IntMap.insert i Text.empty+      ThinkingDelta DeltaPayload {contentIndex = i, delta = d} ->+        s & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i d+      ThinkingEnd ThinkingEndPayload {contentIndex = i, content = tc} ->+        s+          & #blocks+            %~ IntMap.insert+              i+              (AssistantThinking tc)+          & #thinkBuf %~ IntMap.delete i+      ToolCallStart IndexPayload {contentIndex = i} ->+        s & #toolArgsBuf %~ IntMap.insert i Text.empty+      ToolCallDelta DeltaPayload {contentIndex = i, delta = d} ->+        s & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i d+      ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} ->+        s+          & #blocks %~ IntMap.insert i (AssistantToolCall tc)+          & #toolArgsBuf %~ IntMap.delete i+      EventDone TerminalPayload {reason = r, message = msg, responseId = rid, evidence = ev} ->+        s+          & #terminal+            .~ 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, evidence = ev} ->+        s+          & #terminal+            .~ Just+              TerminalSeen+                { reason = r,+                  message = msg,+                  errorInfo = ei,+                  evidence = ev,+                  failed = True+                }+          & #responseId %~ (\old -> rid <|> old)  finalizeState :: ReassemblyState -> IO Response finalizeState s = do@@ -266,6 +317,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))@@ -278,7 +330,9 @@       message' = overrideBlocksAndReason terminalReason terminalMsg finalContent now       latency = case (s ^. #skeleton >>= messageTimestamp, assistantPayloadTimestamp message') of         (Just startTs, Just endTs) -> millisBetween startTs endTs-        _ -> 0+        -- No provider timestamps: measure the window this fold actually+        -- saw rather than reporting zero, which reads as "instant".+        _ -> millisBetween (s ^. #wallStart) now   pure     Response       { message = message',@@ -287,7 +341,8 @@         provider = m ^. #provider,         responseId = s ^. #responseId,         latencyMs = latency,-        errorInfo = normalizedError+        errorInfo = normalizedError,+        evidence = terminalEvidence       }  -- | Project the event-assembled content in 'contentIndex' order,@@ -315,14 +370,12 @@     thinkingBlock t       | Text.null t = Nothing       | otherwise =-          Just (AssistantThinking ThinkingContent {thinking = t, signature = Nothing, redacted = False})+          Just (AssistantThinking ThinkingContent {thinking = t, signature = Nothing, redacted = False, replayState = Nothing})      toolBlock raw       | Text.null raw = Nothing       | otherwise =-          let decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 raw) of-                Right v -> v-                Left _ -> Aeson.String raw+          let decoded = Content.toolArgumentsFromText raw            in Just                 ( AssistantToolCall                     Content.ToolCall@@ -422,7 +475,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@@ -441,9 +494,12 @@     Right a -> pure (Right a)  -- | Build the synthetic event list for a fully resolved 'Response'.--- The 'EventStart' carries the supplied @startTs@ on its message--- skeleton so 'reassembleResponse' can recover 'latencyMs' from the--- start/end timestamps.+--+-- The 'EventStart' carries the response's message skeleton — empty+-- content, but the final usage, stop reason and error text already+-- filled in, because the lifted response is complete before the stream+-- begins — and the supplied @startTs@, so 'reassembleResponse' can+-- recover 'latencyMs' from the start/end timestamps. eventsFor :: UTCTime -> Response -> [AssistantMessageEvent] eventsFor startTs resp =   let payload = resp ^. #message@@ -465,9 +521,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 +553,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,17 +581,120 @@               Msg.timestamp = Just now             }       err = maybe (providerError errText) id mErr+  ev <-+    Build.minimalEvidence+      m+      opts+      (Build.transportForModel m)+      (Build.requestedTranslation opts)+      (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)     ] +-- | Fail a strict call whose successful terminal carries no evidence+-- record.+--+-- Strict mode already guaranteed that a record which was built and then+-- lost fails the call; it did not guarantee that one was built. A+-- provider that attaches nothing returned a successful response and+-- wrote no @call_evidence@ line, with no error anywhere — evidence that+-- can vanish without the caller noticing is not evidence. Under+-- 'Evidence.EvidenceRequired' such a terminal becomes an 'EventError'+-- carrying 'Build.missingEvidenceError'.+--+-- Everything else is returned unchanged: an error terminal (whose own+-- error is more useful than this one and which already satisfies the+-- contract — the call failed), any terminal carrying a record, every+-- non-terminal event, and every best-effort or opted-out call.+requireEvidenceOnTerminal :: Options -> AssistantMessageEvent -> AssistantMessageEvent+requireEvidenceOnTerminal opts ev = case (Build.strictnessOf opts, ev) of+  (Evidence.EvidenceRequired _, EventDone p)+    | Nothing <- p ^. #evidence ->+        EventError+          ( p+              & #reason+                .~ ErrorReason+              & #errorInfo+                .~ Just Build.missingEvidenceError+              & #message+                %~ markFailed+          )+  _ -> ev+  where+    markFailed = \case+      AssistantMessage p ->+        AssistantMessage+          ( p+              & #stopReason+                .~ ErrorReason+              & #errorMessage+                .~ Just (Build.missingEvidenceError ^. #message)+          )+      other -> other+ -- | 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 'EventStart' then 'EventError' 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 detail = "No provider registered for API: " <> renderApi (m ^. #api)+  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: " <> describeApi (m ^. #api)       be = providerUnavailable detail       msg =         AssistantMessage@@ -534,7 +705,18 @@               Msg.errorMessage = Just detail,               Msg.timestamp = Just now             }+  ev <-+    Build.minimalEvidence+      m+      opts+      (Build.transportForModel m)+      (Build.requestedTranslation opts)+      (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)     ]
src/Baikai/Stream/Event.hs view
@@ -4,17 +4,19 @@ -- -- A provider call exposes its progress as a 'Streamly.Data.Stream.Stream -- IO AssistantMessageEvent'. The stream begins with a single--- 'EventStart' carrying an empty 'AssistantMessage' skeleton (api,--- provider, model id), interleaves per-content-block lifecycle events+-- 'EventStart' carrying an 'AssistantMessage' skeleton — empty content,+-- zero usage, no stop reason yet — interleaves per-content-block+-- lifecycle events -- (@_Start@ / @_Delta@ / @_End@) keyed by 'contentIndex', and -- terminates with exactly one 'EventDone' (success) or 'EventError' -- (any failure that bubbled out of the producer). This EventStart-first -- invariant includes error-only streams produced by core dispatch and -- request-preparation failures; they emit a synthetic skeleton before--- the terminal error. One temporary provider-side gap remains: a Claude--- mid-call failure before @message_start@ can still terminate without a--- start event until the EP-7 Claude streaming rewrite pre-seeds its--- skeleton. The terminal event carries the fully assembled+-- the terminal error. It holds without exception: both HTTP providers+-- pre-seed their skeleton before the first wire read, so a failure that+-- arrives before the provider has said anything about the response+-- still begins its stream with 'EventStart'.+-- The terminal event carries the fully assembled -- 'AssistantMessage' so a consumer that only pattern-matches on the -- terminal event still gets a correct response without folding deltas. --@@ -44,6 +46,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)@@ -69,9 +72,9 @@ -- constructors. data AssistantMessageEvent   = -- | The first event in every stream. The payload's 'partial' is an-    -- 'AssistantMessage' with empty content; downstream consumers that-    -- care only about the message skeleton (api, provider, model id)-    -- can read it here.+    -- 'AssistantMessage' skeleton: empty content, zero usage, and no+    -- stop reason yet. The api, provider and model id live on the+    -- 'Baikai.Response.Response', not on the message.     EventStart StartPayload   | -- | A text content block is about to receive deltas.     TextStart IndexPayload@@ -109,15 +112,23 @@   | -- | The stream's terminal failure event. The payload's 'message'     -- is an 'AssistantMessage' carrying whatever content blocks were     -- already closed before the failure, plus a populated-    -- 'errorMessage' and @stopReason = ErrorReason@ or-    -- @stopReason = Aborted@.+    -- 'errorMessage' and @stopReason = ErrorReason@.     EventError TerminalPayload   deriving stock (Eq, Show, Generic)   deriving anyclass (ToJSON)  -- | Payload of 'EventStart': the message skeleton observed up front,--- plus the provider's message id when the provider learns it this--- early (Anthropic's @message_start.id@). 'Nothing' otherwise.+-- plus the provider's message id when the provider knows it before its+-- first event.+--+-- Neither HTTP provider does: both pre-seed this event before the first+-- wire read, so that a failure arriving before the provider has said+-- anything still begins the stream the way the protocol says every+-- stream begins. The id, when it arrives, rides+-- 'TerminalPayload.responseId', which+-- 'Baikai.Stream.reassembleResponse' prefers over this one anyway. A+-- lifted or replaying provider that knows the id up front may still set+-- it here. data StartPayload = StartPayload   { partial :: !Message,     responseId :: !(Maybe Text)@@ -180,7 +191,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 +212,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.
src/Baikai/ThinkingLevel.hs view
@@ -10,6 +10,7 @@ module Baikai.ThinkingLevel   ( ThinkingLevel (..),     renderThinkingLevel,+    parseThinkingLevel,     thinkingTokenBudget,   ) where@@ -42,6 +43,21 @@   ThinkingHigh -> "high"   ThinkingXHigh -> "xhigh"   ThinkingMax -> "max"++-- | The inverse of 'renderThinkingLevel': parse a canonical level name.+--+-- Beside its renderer so the two cannot drift, which three hand-copied+-- tables — in 'Baikai.Evidence', @Baikai.Agent.Config@ and+-- @Baikai.Agent.Cli@ — did the first time a level was added.+parseThinkingLevel :: Text -> Maybe ThinkingLevel+parseThinkingLevel = \case+  "minimal" -> Just ThinkingMinimal+  "low" -> Just ThinkingLow+  "medium" -> Just ThinkingMedium+  "high" -> Just ThinkingHigh+  "xhigh" -> Just ThinkingXHigh+  "max" -> Just ThinkingMax+  _ -> Nothing  -- | Recommended token budget for providers that take an explicit -- count (Anthropic's @thinking.budget_tokens@).
src/Baikai/Tool.hs view
@@ -18,10 +18,10 @@ -- between this module (which 'Baikai.Context' imports for the @tools@ -- field type) and 'Baikai.Context' itself. module Baikai.Tool-  ( Tool (..),+  ( Tool (name, description, parameters),+    mkTool,     ToolChoice (..),     emptyTool,-    _Tool,   ) where @@ -42,6 +42,12 @@  -- | A caller-declared tool. @parameters@ holds a JSON Schema; the -- provider-side encoders pass it through unchanged.+--+-- Construction: the constructor is deliberately not exported. Use+-- 'mkTool', which takes the three fields every provider needs, and+-- override anything else by record update. 'emptyTool' remains for+-- fixtures, but a tool declared from it and sent unchanged reaches the+-- wire with @input_schema: null@. data Tool = Tool   { name :: !Text,     description :: !Text,@@ -50,6 +56,18 @@   deriving stock (Eq, Show, Generic)   deriving anyclass (FromJSON, ToJSON) +-- | A tool from its name, its description and its JSON Schema — the+-- three things every provider requires.+--+-- > mkTool "get_weather" "Look up the weather" schema+mkTool :: Text -> Text -> Value -> Tool+mkTool toolName toolDescription toolParameters =+  Tool+    { name = toolName,+      description = toolDescription,+      parameters = toolParameters+    }+ -- | How the model should pick between the registered tools. -- -- * 'ToolChoiceAuto' — model decides (the default at most providers).@@ -84,7 +102,3 @@       description = Text.empty,       parameters = Null     }--{-# DEPRECATED _Tool "Use emptyTool instead." #-}-_Tool :: Tool-_Tool = emptyTool
src/Baikai/Trace.hs view
@@ -2,7 +2,7 @@  -- | The 'withTrace' wrapper and supporting helpers. ----- After EP-3, the trace bridge is stream-shaped at the core:+-- The trace bridge is stream-shaped at the core: -- 'withTraceStream' returns a 'Stream IO AssistantMessageEvent' -- that side-effects 'CallStarted' / 'CallFinished' / 'CallFailed' -- events to a user-supplied 'TraceSink' as the stream's lifecycle@@ -16,12 +16,27 @@ -- 'AssistantMessageEvent' is emitted), then watch for the stream's -- terminal event ('EventDone' or 'EventError') and push the -- matching 'CallFinished' / 'CallFailed' before yielding the--- terminal event to the consumer. Cleanup ('Nothing' sentinel on--- the channel + 'takeMVar' on the worker) is idempotent and runs--- through 'Stream.finallyIO' so an early-aborting consumer eventually--- records a synthetic 'CallFailed' and never leaks the worker. Sink--- exceptions are captured by the worker and reported once on stderr--- during cleanup; they do not propagate into the provider call.+-- terminal event to the consumer.+--+-- Cleanup — the 'Nothing' sentinel on the channel, then a wait for+-- the worker — runs exactly once per call. On a normal terminal it+-- runs on the calling thread, so when 'withTrace' returns the sink+-- has processed this call's events. When the consumer abandons the+-- stream instead, it runs from streamly's garbage-collection hook:+-- the synthetic 'CallFailed' and its @aborted@ evidence record are+-- delivered at the next major collection after the stream becomes+-- unreachable, and are __not guaranteed before process exit__. A+-- caller who needs the record before exiting drains the stream to+-- its terminal ('withTrace', or a fold that keeps consuming) rather+-- than stopping early.+--+-- The wait for the worker is bounded by 'sinkDrainBoundMicros'. A+-- sink that blocks forever costs the call one second, after which+-- the worker is abandoned and the stall is reported. Sink+-- exceptions — and stalls — are recorded by the worker and reported+-- once on stderr during cleanup; they fail the call only under+-- 'Baikai.Evidence.EvidenceRequired', where a record whose delivery+-- was never confirmed is not one the caller can account for. module Baikai.Trace   ( -- * Re-exports     TraceEvent (..),@@ -36,7 +51,6 @@     runRequestWithRegistry,      -- * Helpers-    newEventId,     summarizeContext,   ) where@@ -50,12 +64,25 @@     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+  ( ModelCallEvidence,+    newCallId,+  )+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.Provider.Registry qualified as Registry 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 (..))@@ -64,23 +91,18 @@ import Baikai.Usage qualified as Usage 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.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception (Exception (..), SomeException, mask, onException, try, uninterruptibleMask_)+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.Maybe (fromMaybe, isJust) 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)+import System.Timeout (timeout)  -- ============================================================ -- Stream-shaped trace bridge@@ -133,7 +155,7 @@           Left e -> writeIORef (state ^. #sinkError) (Just e)           Right () -> pure ()         putMVar d ()-    eid <- newEventId+    eid <- newCallId     start <- getCurrentTime     writeChan c $       Just@@ -147,20 +169,21 @@           }     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 reg state eid start m opts))+        (Stream.mapM (traceEvent reg state eid start m opts) (streamRequestWith reg m ctx opts))  -- | Synchronous trace wrapper. Drains 'withTraceStream' into a -- 'Response' through 'reassembleResponse'. ----- Unlike the EP-2 'withTrace' (which re-threw the producer's--- exception), this implementation never throws for producer-side--- failures: errors flow through the stream as a terminal--- 'EventError' and the drained 'Response' carries--- @stopReason = ErrorReason@ plus 'errorMessage'. The masterplan's--- Vision & Scope section commits to "partial output is always--- recoverable" and the plan's Decision Log records that producer--- failures must surface as response data, not exceptions.+-- This never throws for producer-side failures: errors flow through+-- the stream as a terminal 'EventError' and the drained 'Response'+-- carries @stopReason = ErrorReason@ plus 'errorMessage'. Partial+-- output must always be recoverable, so a producer failure surfaces as+-- response data rather than as an exception. -- Downstream-of-the-fold exceptions (e.g. an 'appendEntry' that -- fails) still propagate unchanged. withTrace ::@@ -211,56 +234,258 @@   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 ::+  ProviderRegistry -> TraceState -> Text -> UTCTime -> Model -> Options -> IO (Maybe BaikaiError)+finalizeTrace reg s eid start m opts = mask $ \restore -> 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,+                  inputTokens = Nothing,+                  outputTokens = Nothing,+                  cachedInputTokens = Nothing,+                  cacheWriteTokens = Nothing,+                  reasoningTokens = Nothing,+                  totalTokens = Nothing,+                  costBasis = Nothing,+                  usageAvailability = Nothing,+                  usd = Nothing,+                  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.+        --+        -- The translation comes from the registered adapter's own+        -- 'Registry.describeThinking': the adapter /did/ run on this+        -- path, so its description is the truthful one and the only one+        -- @docs\/adr\/0003-the-adapter-owns-the-translation-description.md@+        -- permits. Where no provider is registered there is nothing to+        -- ask, and 'Build.requestedTranslation' says the caller\'s level+        -- was never translated. Either way the caller\'s own level is+        -- recorded, which passing 'Evidence.noThinkingRequested' here+        -- silently denied.+        mProvider <- Registry.lookupApiProviderWith reg (m ^. #api)+        let translation = case mProvider of+              Just p -> Registry.describeThinking p m opts+              Nothing -> Build.requestedTranslation opts+        mev <-+          Build.minimalEvidence+            m+            opts+            (Build.transportForModel m)+            translation+            (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))+        commitTerminal s eid now m mev aborted+      writeChan (s ^. #chan) Nothing+      -- The claim-through-sentinel region above cannot be interrupted;+      -- the wait below can, which is the whole point of the 'mask' /+      -- 'restore' pair. The GC-hook path enters here already under+      -- 'Control.Exception.mask_', and 'restore' puts back /that/ state,+      -- in which a blocking 'readMVar' is still interruptible — so+      -- 'timeout' can deliver its exception on either path. The+      -- 'onException' releases the root if the wait is interrupted: the+      -- sentinel is already queued, so the worker cannot block on the+      -- channel again and no longer needs rooting.+      drained <- restore (awaitWorker s) `onException` releaseStableRoot s+      unless drained $+        atomicModifyIORef' (s ^. #sinkError) $ \old ->+          (Just (fromMaybe (toException (TraceSinkStalled sinkDrainBoundMicros)) old), ())+      fatal <- reportSinkError s opts+      releaseStableRoot s+      pure fatal +-- | How long 'finalizeTrace' waits for the trace worker after writing+-- the shutdown sentinel.+--+-- On expiry the worker is abandoned, not killed, and the call proceeds.+-- One second is chosen because a call produces at most four events, the+-- wait covers only their delivery and the sink's end-of-stream action,+-- and a sink whose per-call latency approaches a second is+-- mis-configured for per-call tracing — an OpenTelemetry exporter+-- belongs behind the non-blocking batch processor. Not a public option:+-- if the bound ever proves tight the answer is an 'Options' field.+sinkDrainBoundMicros :: Int+sinkDrainBoundMicros = 1_000_000++-- | The trace sink did not confirm delivery within+-- 'sinkDrainBoundMicros', carried here as the microsecond bound.+--+-- Stored in the trace state's @sinkError@ as a plain exception, so the+-- strict-mode decision in "Baikai.Evidence.Build" applies to it exactly+-- as it does to a sink that threw: best-effort callers get the stderr+-- line and their answer, a caller who required evidence gets a failed+-- call. Not exported — it renders as text through both paths, and an+-- exported type is a name the surface freeze would have to keep.+newtype TraceSinkStalled = TraceSinkStalled Int+  deriving stock (Show)++instance Exception TraceSinkStalled where+  displayException (TraceSinkStalled us) =+    "the trace sink did not confirm delivery within "+      <> show (us `div` 1000)+      <> " ms; its worker was abandoned, and events already queued may still be \+         \delivered later"++-- | Wait for the worker to signal completion, for at most+-- 'sinkDrainBoundMicros'. 'True' when it did.+--+-- On 'False' the worker is left running: killing it would abort the+-- sink's fold mid-step and lose its end-of-stream action. An abandoned+-- worker finishes when the sink unblocks, or is reaped with+-- 'Control.Exception.BlockedIndefinitelyOnMVar' — which its 'try'+-- catches — when whatever it blocks on becomes unreachable.+--+-- 'readMVar', not 'takeMVar', so the worker's eventual 'putMVar' can+-- never block on a slot this thread emptied.+awaitWorker :: TraceState -> IO Bool+awaitWorker s = isJust <$> timeout sinkDrainBoundMicros (readMVar (s ^. #done))++-- | 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+          }++-- | Commit a call's terminal to the sink: mark the terminal as sent,+-- push the evidence record (when there is one), then push the terminal+-- event.+--+-- One unit with respect to asynchronous exceptions. An exception+-- delivered between the terminal push and the flag write made+-- 'finalizeTrace' read the flag as unset and push a second evidence+-- record and an @aborted@ 'CallFailed' after the real terminal, so a+-- sink saw two records and two contradictory terminals for one call.+-- Plain 'Control.Exception.mask_' closes the window everywhere except+-- inside 'writeChan', whose internal 'takeMVar' on the channel's write+-- lock is interruptible; it never blocks in practice, because the+-- worker only reads, but "never in practice" is what this exists to+-- remove. Every write here is a non-blocking push to an unbounded+-- 'Chan' or one 'IORef' write, so the uninterruptible block holds for+-- microseconds and cannot become an un-cancellable hang.+--+-- The flag goes /first/ so a synchronous failure inside the block+-- yields a missing terminal — which the abort machinery tolerates —+-- rather than a duplicated one. The wait for the worker is outside the+-- block, in 'finalizeTrace'.+commitTerminal ::+  TraceState -> Text -> UTCTime -> Model -> Maybe ModelCallEvidence -> TraceEvent -> IO ()+commitTerminal s eid now m mev terminal =+  uninterruptibleMask_ $ do+    writeIORef (s ^. #terminalSent) True+    pushEvidence s eid now m mev+    writeChan (s ^. #chan) (Just terminal)+ 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+      -- A stall is not a throw, and 'Build.onSinkFailure's line says+      -- the events "were dropped", which is the one thing an abandoned+      -- worker's events were not: they are still queued and may yet be+      -- delivered. The fatality decision below is identical for both.+      case fromException e of+        Just stalled@TraceSinkStalled {} ->+          hPutStrLn stderr ("baikai: " <> displayException stalled)+        Nothing -> Build.onSinkFailure strictness e+      pure+        ( if Build.sinkFailureIsFatal strictness+            then Just (Build.sinkFailureError e)+            else Nothing+        )+  where+    strictness = Build.strictnessOf opts  traceEvent ::+  ProviderRegistry ->   TraceState ->   Text ->   UTCTime ->   Model ->+  Options ->   AssistantMessageEvent ->   IO AssistantMessageEvent-traceEvent state eid start m ev = do+traceEvent reg 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,17 +495,41 @@                 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.+                costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost,+                usageAvailability = mu >>= Usage.availability,+                usd = fmap (usdAsScientific . Usage.cost) mu               }-      writeChan (state ^. #chan) (Just finished)-      writeIORef (state ^. #terminalSent) True-      finalizeTrace state eid start m-    EventError TerminalPayload {message = msg} -> do+      -- 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.+      commitTerminal state eid now m mev finished+      fatal <- finalizeTrace reg 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+          mu = assistantUsageFromMsg msg           errMsg = case msg of             AssistantMessage AssistantPayload {errorMessage = Just t} -> t             _ -> "stream terminated with EventError"@@ -291,14 +540,49 @@                 provider = m ^. #provider,                 model = m ^. #modelId,                 latencyMs = latency,+                inputTokens = fmap Usage.inputTokens mu,+                outputTokens = fmap Usage.outputTokens mu,+                cachedInputTokens = fmap Usage.cacheReadTokens mu,+                cacheWriteTokens = fmap Usage.cacheWriteTokens mu,+                reasoningTokens = mu >>= Usage.reasoningTokens,+                totalTokens = fmap Usage.totalTokens mu,+                costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost,+                usageAvailability = mu >>= Usage.availability,+                usd = fmap (usdAsScientific . Usage.cost) mu,                 errorMessage = errMsg               }-      writeChan (state ^. #chan) (Just failed)-      writeIORef (state ^. #terminalSent) True-      finalizeTrace state eid start m-    _ -> pure ()-  pure ev+      commitTerminal state eid now m mev failed+      -- 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 reg 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 +615,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,@@ -340,11 +623,15 @@             inputTokens = mu >>= positiveNat . Usage.inputTokens,             outputTokens = mu >>= positiveNat . Usage.outputTokens,             cachedInputTokens = mu >>= positiveNat . Usage.cacheReadTokens,+            cacheWriteTokens = fmap Usage.cacheWriteTokens mu,+            costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost,+            usageAvailability = mu >>= Usage.availability,             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 +651,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@@ -376,32 +660,3 @@  millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double))---- ============================================================--- 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.-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 #-}
src/Baikai/Trace/Event.hs view
@@ -1,27 +1,34 @@+{-# 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.Cost (CostBasis)+import Baikai.Evidence (ModelCallEvidence)+import Baikai.Usage (UsageAvailability) import Data.Aeson   ( FromJSON (parseJSON),     Options (..),     SumEncoding (..),     ToJSON (..),     defaultOptions,-    genericParseJSON,     genericToEncoding,     genericToJSON,+    withObject,+    (.:),+    (.:?),   ) import Data.Char (toLower) import Data.Scientific (Scientific)@@ -33,10 +40,26 @@ -- | 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--- providers (the CLIs) do not report them; 'omitNothingFields' keeps the--- absent fields out of the rendered JSON.+-- with its matching @finished@, @failed@, or @evidence@ event within a+-- single process run. Token counts are 'Maybe' because a non-assistant+-- terminal has no usage and a subprocess tool may report nothing; since+-- 0.5.0.0 both CLI providers carry the counts the tool reported.+-- '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@.+--+-- The @model@ field carries the __requested__ 'Baikai.Model.modelId' on+-- every constructor, including 'CallEvidence'. The model the provider+-- actually served — which can differ, and which is an observation+-- rather than a request — is available only inside 'CallEvidence'\'s+-- record, as+-- 'Baikai.Evidence.ModelCallEvidence'\'s @observedModel@. A sink must+-- not present @model@ under a response-model key. data TraceEvent   = CallStarted       { eventId :: !Text,@@ -54,6 +77,16 @@         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),+        costBasis :: !(Maybe CostBasis),+        usageAvailability :: !(Maybe UsageAvailability),         usd :: !(Maybe Scientific)       }   | CallFailed@@ -62,15 +95,50 @@         provider :: !Text,         model :: !Text,         latencyMs :: !Int,+        inputTokens :: !(Maybe Natural),+        outputTokens :: !(Maybe Natural),+        cachedInputTokens :: !(Maybe Natural),+        cacheWriteTokens :: !(Maybe Natural),+        reasoningTokens :: !(Maybe Natural),+        totalTokens :: !(Maybe Natural),+        costBasis :: !(Maybe CostBasis),+        usageAvailability :: !(Maybe UsageAvailability),+        usd :: !(Maybe Scientific),         errorMessage :: !Text       }+  | -- | The complete evidence record for one terminal provider call.+    --+    -- Emitted exactly once per call, immediately __before__ the+    -- matching 'CallFinished' or 'CallFailed', so a sink that keys+    -- per-call state off the started/terminal pair still has the call+    -- open when the record arrives. 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":"<tag>","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 +159,64 @@   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 .:? "costBasis"+          <*> d .:? "usageAvailability"+          <*> d .:? "usd"+      "call_failed" ->+        CallFailed+          <$> d .: "eventId"+          <*> d .: "timestamp"+          <*> d .: "provider"+          <*> d .: "model"+          <*> d .: "latencyMs"+          <*> d .:? "inputTokens"+          <*> d .:? "outputTokens"+          <*> d .:? "cachedInputTokens"+          <*> d .:? "cacheWriteTokens"+          <*> d .:? "reasoningTokens"+          <*> d .:? "totalTokens"+          <*> d .:? "costBasis"+          <*> d .:? "usageAvailability"+          <*> d .:? "usd"+          <*> 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)
src/Baikai/Trace/Sink.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}  -- | The 'TraceSink' newtype and four built-in sinks. --@@ -7,6 +8,12 @@ -- combinators like 'Fold.tee' (fan to two folds), 'Fold.filter' (drop inputs -- failing a predicate), and 'Fold.lmap' (project each input), so future -- sinks (OpenTelemetry, redaction, projection) plug in without an adapter.+--+-- 'multiSink' is the one place that does /not/ compose with 'Fold.tee':+-- 'Fold.tee' runs one member then the other and lets either's exception+-- escape, so a single throwing member stopped delivery to its siblings+-- and skipped their end-of-stream actions. Each member now runs on its+-- own drain thread; see 'multiSink'. module Baikai.Trace.Sink   ( TraceSink (..),     silent,@@ -17,15 +24,23 @@   ) where +import Baikai.Evidence qualified as Evidence import Baikai.Trace.Event (TraceEvent (..))+import Control.Concurrent (forkIO)+import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar)+import Control.Exception (Exception (..), SomeException, throwIO, try)+import Control.Monad (forM_, unless) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BSL+import Data.List (intercalate) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Data.Time (defaultTimeLocale, formatTime) import Streamly.Data.Fold (Fold) import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream import System.IO (IOMode (AppendMode), withFile)  -- | A trace sink is a streamly fold over 'TraceEvent' values. Folds@@ -53,15 +68,82 @@     withFile path AppendMode $ \h ->       BSL.hPut h (Aeson.encode e <> "\n") --- | Fan every event out to every sink in the list. Implemented by folding--- 'Fold.tee' across the input list; 'Fold.tee' runs both folds on each--- input and returns the pair of their accumulators, which we discard.+-- | Fan every event out to every sink in the list.+--+-- Each member runs on its own drain thread behind its own unbounded+-- channel, so a member that throws or blocks cannot stop delivery to+-- the others or skip their end-of-stream action. This fold's step never+-- blocks. Its final action sends every member the sentinel, waits for+-- every member, and throws one 'TraceSinkFailure' naming each failed+-- member by zero-based index when any failed — which the trace worker+-- records like any other sink failure.+--+-- The wait for a member is unbounded here; "Baikai.Trace" bounds the+-- whole drain, so a member that blocks forever costs the call the drain+-- bound and no more. One consequence is accepted: while such a member+-- is blocked the aggregate is never thrown, so a /throwing/ sibling's+-- message does not reach stderr in that combination. The stall line+-- names the actionable fact, and the sibling's events were delivered+-- regardless. multiSink :: [TraceSink] -> TraceSink multiSink sinks =-  TraceSink (foldr step Fold.drain sinks)+  TraceSink (Fold.rmapM finish (Fold.foldlM' deliver start))   where-    step (TraceSink f) acc = fmap (const ()) (Fold.tee f acc)+    start :: IO [Member]+    start = mapM startMember sinks +    deliver :: [Member] -> TraceEvent -> IO [Member]+    deliver members e = do+      forM_ members $ \member -> writeChan (chan member) (Just e)+      pure members++    finish :: [Member] -> IO ()+    finish members = do+      forM_ members $ \member -> writeChan (chan member) Nothing+      outcomes <- mapM (readMVar . outcome) members+      let failures = [(i, e) | (i, Just e) <- zip [0 :: Int ..] outcomes]+      unless (null failures) $+        throwIO (TraceSinkFailure (length members) failures)++-- | One member of a 'multiSink': the channel it is fed through and the+-- slot its drain thread fills with the outcome of its fold.+data Member = Member+  { chan :: !(Chan (Maybe TraceEvent)),+    outcome :: !(MVar (Maybe SomeException))+  }++-- | Fork one member's drain thread. The 'try' is @SomeException@ for+-- the same reason the trace worker's is: nothing throws /to/ this+-- thread, so the catch cannot swallow a cancellation aimed at anyone,+-- and a member abandoned by a stalled drain is reaped with+-- 'Control.Exception.BlockedIndefinitelyOnMVar', which is worth+-- recording rather than printing through the runtime.+startMember :: TraceSink -> IO Member+startMember (TraceSink f) = do+  c <- newChan+  o <- newEmptyMVar+  _ <- forkIO $ do+    let step () = fmap (fmap (\e -> (e, ()))) (readChan c)+    r <- try (Stream.fold f (Stream.unfoldrM step ())) :: IO (Either SomeException ())+    putMVar o (either Just (const Nothing) r)+  pure Member {chan = c, outcome = o}++-- | One or more members of a 'multiSink' failed. Not exported: the+-- strict-mode error and the stderr line both render its text, and an+-- exported type is a name the surface freeze would have to keep.+data TraceSinkFailure = TraceSinkFailure Int [(Int, SomeException)]+  deriving stock (Show)++instance Exception TraceSinkFailure where+  displayException (TraceSinkFailure total failures) =+    show (length failures)+      <> " of "+      <> show total+      <> " member sinks failed: "+      <> intercalate+        "; "+        ["member " <> show i <> ": " <> displayException e | (i, e) <- failures]+ -- | Format an event as a single human-readable line. renderHuman :: TraceEvent -> Text renderHuman = \case@@ -94,7 +176,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 'OverloadedRecordDot' rather than bare selectors:+-- 'Evidence.ModelCallEvidence' and 'Evidence.EvidenceRequest' both+-- carry @runId@, so under @DuplicateRecordFields@ a bare+-- @Evidence.runId ev@ is an ambiguous occurrence. A record pattern+-- would also work, but the constructor is no longer exported.+evidenceSummary :: Evidence.ModelCallEvidence -> Text+evidenceSummary ev =+  Text.unwords+    [ "run=" <> ev.runId,+      "call=" <> ev.callId,+      "strength=" <> Text.pack (show ev.strength)+    ]
+ src/Baikai/Url.hs view
@@ -0,0 +1,254 @@+-- | The one place baikai reads a host out of a URL.+--+-- baikai decides which API key to send and which per-host compatibility+-- record to apply by looking at the host name inside a model's+-- @baseUrl@. That decision routes a credential, so it has to be made the+-- same way everywhere: two parsers that disagree about what host a URL+-- names are two different answers to "where does this key go".+--+-- This module is deliberately __not__ a validating URI parser. It knows+-- just enough to name a host, key a cache, render an endpoint for an+-- evidence record, and say why a base URL is unusable. It has no+-- dependencies beyond @text@ and @base@, and every function is total.+--+-- The rule, in full:+--+-- * Leading and trailing whitespace is stripped.+--+-- * If the text before the first @\"://\"@ is a syntactically valid+--   scheme — a letter followed by letters, digits, @+@, @-@ or @.@ —+--   that is the scheme, lower-cased, and it is removed. Otherwise there+--   is no scheme and nothing is removed.+--+-- * The __authority__ is everything up to the first @\/@, @?@ or @#@.+--   This is what RFC 3986 means by the term, and bounding it at all+--   three characters is the point of this module: a URL such as+--   @https:\/\/proxy.example.com\/v1?u=\@api.openai.com@ names the host+--   @proxy.example.com@, and anything that reads the text after the last+--   @\@@ anywhere in the URL will send that proxy another host's key.+--+-- * Userinfo is everything up to the last @\@@ __inside the authority__,+--   and is dropped. Its presence is recorded; its text never is.+--+-- * What remains is the host and an optional port. A bracketed IPv6+--   literal keeps its brackets and its port follows the closing+--   bracket; otherwise the host is the text before the first @:@. A+--   non-numeric port is ignored and the host is still the text before+--   the colon. The host is lower-cased, because DNS names are+--   case-insensitive.+--+-- * The path is everything from the first @\/@ up to the first @?@ or+--   @#@, kept verbatim — case and trailing slash included.+--+-- * An empty host means there is no result at all.+module Baikai.Url+  ( -- * Parsing+    UrlParts (scheme, host, port, path, hasUserInfo, hasQuery, hasFragment),+    parseUrl,+    urlHost,+    hostMatchesSuffix,++    -- * Rendering+    renderEndpoint,+    stripApiVersion,++    -- * Fitness as a base URL+    baseUrlProblem,+  )+where++import Data.Char (isAlpha, isAlphaNum, isDigit)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)++-- | The pieces of a URL that baikai needs.+--+-- Credential-free by construction: userinfo, the query string and the+-- fragment are recorded as /present or absent/ and never as text, so a+-- value of this type cannot carry a secret into a log line. That is why+-- the constructor is not exported — 'parseUrl' is the only producer.+data UrlParts = UrlParts+  { -- | Lower-cased scheme without the @\"://\"@, when one was present.+    scheme :: !(Maybe Text),+    -- | Lower-cased host. An IPv6 literal keeps its brackets: @\"[::1]\"@.+    host :: !Text,+    -- | The port, when one was given as digits.+    port :: !(Maybe Int),+    -- | From the first @\/@ up to (not including) @?@ or @#@; @\"\"@ when+    -- there was no path. Kept verbatim.+    path :: !Text,+    -- | Whether a @user:password\@@ prefix was present and dropped.+    hasUserInfo :: !Bool,+    -- | Whether a @?query@ was present and dropped.+    hasQuery :: !Bool,+    -- | Whether a @#fragment@ was present and dropped.+    hasFragment :: !Bool+  }+  deriving stock (Eq, Show, Generic)++-- | Parse a URL far enough to name its host. 'Nothing' when no host can+-- be found, which includes the empty string and a bare scheme.+parseUrl :: Text -> Maybe UrlParts+parseUrl raw+  | Text.null hostText = Nothing+  | otherwise =+      Just+        UrlParts+          { scheme = parsedScheme,+            host = hostText,+            port = parsedPort,+            path = pathText,+            hasUserInfo = userInfoPresent,+            hasQuery = queryPresent,+            hasFragment = fragmentPresent+          }+  where+    trimmed = Text.strip raw++    -- The scheme is only a scheme when it looks like one. "note://x" has+    -- one; ":://x" does not, and neither does a bare "api.openai.com".+    (parsedScheme, afterScheme) = case Text.breakOn "://" trimmed of+      (candidate, rest)+        | not (Text.null rest),+          validScheme candidate ->+            (Just (Text.toLower candidate), Text.drop 3 rest)+      _ -> (Nothing, trimmed)+    validScheme s = case Text.uncons s of+      Just (c, cs) -> isAlpha c && Text.all schemeChar cs+      Nothing -> False+    schemeChar c = isAlphaNum c || c == '+' || c == '-' || c == '.'++    -- The authority ends at the first '/', '?' or '#'. Everything this+    -- module exists for depends on that boundary.+    (authority, afterAuthority) =+      Text.break (\c -> c == '/' || c == '?' || c == '#') afterScheme++    -- Userinfo is the last '@' inside the authority, never one later in+    -- the path or query.+    (userInfoPresent, hostAndPort) = case Text.breakOnEnd "@" authority of+      (before, after) | not (Text.null before) -> (True, after)+      _ -> (False, authority)++    (hostText, parsedPort) = splitHostPort hostAndPort++    (pathText, afterPath) =+      Text.break (\c -> c == '?' || c == '#') afterAuthority+    queryPresent = "?" `Text.isPrefixOf` afterPath+    fragmentPresent = "#" `Text.isInfixOf` afterPath++-- | Split @host:port@, keeping an IPv6 literal's brackets together.+splitHostPort :: Text -> (Text, Maybe Int)+splitHostPort raw+  | "[" `Text.isPrefixOf` raw =+      case Text.breakOn "]" raw of+        (literal, rest)+          | not (Text.null rest) ->+              (Text.toLower (literal <> "]"), portOf (Text.drop 1 rest))+        _ -> (Text.toLower raw, Nothing)+  | otherwise =+      let (h, rest) = Text.breakOn ":" raw+       in (Text.toLower h, portOf rest)+  where+    -- ":8080" is a port; ":" alone, ":abc" and "" are not, and in every+    -- one of those cases the host is still what came before the colon.+    portOf rest = case Text.stripPrefix ":" rest of+      Just digits+        | not (Text.null digits),+          Text.all isDigit digits ->+            Just (read (Text.unpack digits))+      _ -> Nothing++-- | The host a URL names, or 'Nothing' when it names none.+urlHost :: Text -> Maybe Text+urlHost = fmap host . parseUrl++-- | Match a hostname against a suffix at a label boundary, so that+-- @evil-api.openai.com.attacker.test@ does not match @api.openai.com@.+hostMatchesSuffix :: Text -> Text -> Bool+hostMatchesSuffix h suffix =+  let lowerHost = Text.toLower (Text.strip h)+      lowerSuffix = Text.toLower (Text.strip suffix)+   in not (Text.null lowerHost)+        && not (Text.null lowerSuffix)+        && (lowerHost == lowerSuffix || ("." <> lowerSuffix) `Text.isSuffixOf` lowerHost)++-- | Render the parts back as an endpoint: scheme, host, port and path,+-- and nothing else. Userinfo, the query and the fragment are gone+-- because 'UrlParts' never held them.+renderEndpoint :: UrlParts -> Text+renderEndpoint parts =+  maybe "" (<> "://") (scheme parts)+    <> host parts+    <> maybe "" (\p -> ":" <> Text.pack (show p)) (port parts)+    <> path parts++-- | Remove one trailing @\/v1@ segment from a path, along with any+-- trailing slashes.+--+-- Segment-wise, so @\/v10@ and @\/v1beta@ are left alone. The result is+-- either @\"\"@ or a path beginning with @\/@. This is what makes+-- @https:\/\/api.deepseek.com\/v1@ — the base URL every OpenAI SDK+-- teaches — compose to one @\/v1\/chat\/completions@ rather than two.+stripApiVersion :: Text -> Text+stripApiVersion raw+  | Text.null trimmed = ""+  | otherwise = case Text.stripSuffix "/v1" withLeadingSlash of+      Just kept -> kept+      Nothing -> withLeadingSlash+  where+    trimmed = Text.dropWhileEnd (== '/') raw+    withLeadingSlash+      | "/" `Text.isPrefixOf` trimmed = trimmed+      | otherwise = "/" <> trimmed++-- | Why this text cannot be used as a model's @baseUrl@, or 'Nothing'+-- when it can.+--+-- Every message names the offending URL with its userinfo and query+-- removed — rendered through 'renderEndpoint', never echoed raw — so an+-- error that reaches a log cannot carry a key someone put in a query+-- parameter.+baseUrlProblem :: Text -> Maybe Text+baseUrlProblem raw = case parseUrl raw of+  Nothing -> Just "no host could be found in it"+  Just parts+    | Nothing <- scheme parts ->+        Just (safe parts <> " has no scheme; start it with https:// or http://")+    | Just s <- scheme parts,+      s /= "http",+      s /= "https" ->+        Just (safe parts <> " uses the scheme " <> s <> "; only http and https are sent")+    | hasUserInfo parts ->+        Just+          ( safe parts+              <> " carries credentials before the host, which are never sent; \+                 \use Options.apiKey for the API key or Options.headers for a \+                 \gateway header"+          )+    | hasQuery parts ->+        Just+          ( safe parts+              <> " has a query string; baikai composes the request path itself \+                 \and does not support per-host query parameters such as \+                 \?api-version=. Remove it, or front the host with a gateway \+                 \that adds it"+          )+    | hasFragment parts ->+        Just (safe parts <> " has a fragment, which is not part of a request")+    | Just ending <- endpointSuffix (path parts) ->+        Just+          ( safe parts+              <> " already ends in the endpoint path "+              <> ending+              <> "; Model.baseUrl is the API root, and baikai appends the \+                 \endpoint path itself"+          )+    | otherwise -> Nothing+  where+    safe = renderEndpoint+    endpointSuffix p =+      case filter (`Text.isSuffixOf` Text.dropWhileEnd (== '/') p) endpointPaths of+        (found : _) -> Just found+        [] -> Nothing+    endpointPaths = ["/chat/completions", "/messages", "/embeddings"]
src/Baikai/Usage.hs view
@@ -22,20 +22,55 @@ -- every cost-reading caller would have to handle. 'Baikai.Cost.Pricing.computeCost' -- depends on the token classes being disjoint so each class is billed -- exactly once.-module Baikai.Usage (Usage (..), zeroUsage, _Usage, sumUsage) where+module Baikai.Usage (Usage (..), UsageAvailability (..), UsageCategory (..), BillingFact (..), observeBilling, zeroUsage, sumUsage) where  import Baikai.Cost (Cost, zeroCost)-import Data.Aeson-  ( Options (fieldLabelModifier),-    ToJSON (toJSON),-    camelTo2,-    defaultOptions,-    genericToJSON,-  )+import Data.Aeson (FromJSON (parseJSON), Options (constructorTagModifier, fieldLabelModifier), ToJSON (toJSON), camelTo2, defaultOptions, genericToJSON, (.!=), (.:), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KeyMap import Data.Maybe (fromMaybe)+import Data.Set (Set)+import Data.Set qualified as Set+import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) +-- | Billed categories whose omission affects the local calculation.+data UsageCategory = InputUsage | OutputUsage | CacheReadUsage | CacheWriteUsage+  deriving stock (Eq, Ord, Show, Generic)++-- | Provider observations, independent of the requested tier and local rates.+data BillingFact = BillingServiceTier Text | BillingSpeed Text | BillingServerToolUse+  deriving stock (Eq, Ord, Show, Generic)++instance FromJSON BillingFact where parseJSON = Aeson.genericParseJSON usageOptions++instance ToJSON BillingFact where toJSON = genericToJSON usageOptions++-- | Provider facts, independent of local prices. Missing categories are not+-- observed zeroes; inconsistent counters cannot support an exact calculation.+data UsageAvailability = UsageAvailability+  { missingCategories :: !(Set UsageCategory),+    inconsistent :: !Bool,+    billingFacts :: !(Set BillingFact)+  }+  deriving stock (Eq, Show, Generic)++instance FromJSON UsageCategory where parseJSON = Aeson.genericParseJSON usageOptions++instance ToJSON UsageCategory where toJSON = genericToJSON usageOptions++instance FromJSON UsageAvailability where+  parseJSON = Aeson.withObject "UsageAvailability" $ \o -> UsageAvailability <$> o .: "missing_categories" <*> o .: "inconsistent" <*> o .:? "billing_facts" .!= Set.empty++instance ToJSON UsageAvailability where+  toJSON facts = case genericToJSON usageOptions facts of+    Aeson.Object o | Set.null (billingFacts facts) -> Aeson.Object (KeyMap.delete "billing_facts" o)+    value -> value++instance Semigroup UsageAvailability where+  a <> b = UsageAvailability (missingCategories a <> missingCategories b) (inconsistent a || inconsistent b) (billingFacts a <> billingFacts b)+ -- | Provider-normalized token usage for one model call. -- -- The prompt-side classes are disjoint: 'inputTokens' excludes@@ -62,16 +97,21 @@     -- 'inputTokens' + 'outputTokens' + 'cacheReadTokens' +     -- 'cacheWriteTokens'.     totalTokens :: !Natural,-    -- | Computed cost for this usage. Providers without pricing data-    -- use 'zeroCost'.+    -- | Availability of provider billing facts. Nothing is the legacy/manual+    -- representation; normalized API responses always carry an annotation.+    availability :: !(Maybe UsageAvailability),+    -- | Computed cost. Incomplete usage or prices carry estimation reasons.     cost :: !Cost   }   deriving stock (Eq, Show, Generic)  usageOptions :: Options-usageOptions = defaultOptions {fieldLabelModifier = camelTo2 '_'}+usageOptions = defaultOptions {fieldLabelModifier = camelTo2 '_', constructorTagModifier = camelTo2 '_'} -instance ToJSON Usage where toJSON = genericToJSON usageOptions+instance ToJSON Usage where+  toJSON u = case genericToJSON usageOptions u of+    Aeson.Object o | Nothing <- availability u -> Aeson.Object (KeyMap.delete "availability" o)+    value -> value  -- | Empty usage with every count and cost set to zero. zeroUsage :: Usage@@ -83,6 +123,7 @@       cacheWriteTokens = 0,       reasoningTokens = Nothing,       totalTokens = 0,+      availability = Nothing,       cost = zeroCost     } @@ -103,6 +144,7 @@         cacheWriteTokens = cacheWriteTokens a + cacheWriteTokens b,         reasoningTokens = combineReasoning (reasoningTokens a) (reasoningTokens b),         totalTokens = totalTokens a + totalTokens b,+        availability = availability a <> availability b,         cost = cost a <> cost b       } @@ -113,6 +155,9 @@ sumUsage :: (Foldable f) => f Usage -> Usage sumUsage = foldl' (<>) mempty -{-# DEPRECATED _Usage "Use zeroUsage instead." #-}-_Usage :: Usage-_Usage = zeroUsage+-- | Add actual response observations without overwriting missing-count facts.+observeBilling :: [BillingFact] -> Usage -> Usage+observeBilling [] u = u+observeBilling facts u =+  let previous = fromMaybe (UsageAvailability Set.empty False Set.empty) (availability u)+   in u {availability = Just previous {billingFacts = billingFacts previous <> Set.fromList facts}}
+ src/Baikai/Usage/Normalize.hs view
@@ -0,0 +1,44 @@+-- | Shared billing-category normalization. Adapters extract optional wire+-- counts; this module preserves their availability without inferring writes.+module Baikai.Usage.Normalize (InputAccounting (..), ReportedUsage (..), normalizeUsage) where++import Baikai.Usage qualified as U+import Data.Maybe (fromMaybe, isNothing)+import Data.Set qualified as Set+import Numeric.Natural (Natural)++data InputAccounting = InclusiveInput | ExclusiveInput+  deriving stock (Eq, Show)++data ReportedUsage = ReportedUsage+  { inputTokens :: !(Maybe Natural),+    outputTokens :: !(Maybe Natural),+    cacheReadTokens :: !(Maybe Natural),+    cacheWriteTokens :: !(Maybe Natural),+    reasoningTokens :: !(Maybe Natural)+  }+  deriving stock (Eq, Show)++normalizeUsage :: InputAccounting -> ReportedUsage -> U.Usage+normalizeUsage accounting r =+  let input = fromMaybe 0 (inputTokens r)+      output = fromMaybe 0 (outputTokens r)+      cached = fromMaybe 0 (cacheReadTokens r)+      writes = fromMaybe 0 (cacheWriteTokens r)+      fresh = case accounting of+        ExclusiveInput -> input+        InclusiveInput -> if cached + writes > input then 0 else input - cached - writes+      invalidInput = accounting == InclusiveInput && maybe False (cached + writes >) (inputTokens r)+      invalidReasoning = case (reasoningTokens r, outputTokens r) of+        (Just reasoning, Just out) -> reasoning > out+        _ -> False+      missing = Set.fromList [category | (category, count) <- [(U.InputUsage, inputTokens r), (U.OutputUsage, outputTokens r), (U.CacheReadUsage, cacheReadTokens r), (U.CacheWriteUsage, cacheWriteTokens r)], isNothing count]+   in U.zeroUsage+        { U.inputTokens = fresh,+          U.outputTokens = output,+          U.cacheReadTokens = cached,+          U.cacheWriteTokens = writes,+          U.reasoningTokens = reasoningTokens r,+          U.totalTokens = fresh + output + cached + writes,+          U.availability = Just (U.UsageAvailability missing (invalidInput || invalidReasoning) Set.empty)+        }
test/AgentAssetsSpec.hs view
@@ -12,7 +12,8 @@     "Baikai.AgentAssets"     [ pathTests,       layoutTests,-      codexTomlTest+      codexTomlTest,+      codexTomlLiteralBodyTests     ]  pathTests :: TestTree@@ -64,7 +65,7 @@  codexTomlTest :: TestTree codexTomlTest =-  testCase "Codex custom-agent TOML escapes strings and preserves instructions" $ do+  testCase "Codex custom-agent TOML uses a literal body and escapes basic strings" $ do     codexCustomAgentToml       CodexCustomAgent         { name = "repo\"reviewer",@@ -74,5 +75,75 @@       @?= Text.unlines         [ "name = \"repo\\\"reviewer\"",           "description = \"Reviews\\tchanges\"",-          "developer_instructions = \"\"\"\nRead first.\nAvoid triple quotes: \\\"\\\"\\\"\n\"\"\""+          -- A literal string interprets nothing, so the three quotation+          -- marks in the body need no escape at all; only three+          -- apostrophes would, and there are none.+          "developer_instructions = \'\'\'\nRead first.\nAvoid triple quotes: \"\"\"\n\'\'\'"         ]++-- | The body of a Codex custom agent is Markdown a human reads in+-- @.codex\/agents\/*.toml@, so it is rendered as a TOML /literal/+-- multi-line string — delimited by three apostrophes, interpreting+-- nothing — and comes back byte for byte.+--+-- This is the defect these cases exist for: rendered as a /basic/+-- string, every backslash in the body is the start of an escape+-- sequence, so a body containing @\\d+@ made Codex refuse to load the+-- file with an unknown-escape error.+--+-- A literal string cannot contain three apostrophes, a bare carriage+-- return, or any control character other than tab and newline, so such a+-- body falls back to a fully escaped basic string rather than being+-- refused.+codexTomlLiteralBodyTests :: TestTree+codexTomlLiteralBodyTests =+  testGroup+    "Codex custom-agent bodies"+    [ testCase "backslashes render verbatim in a literal string" $+        bodyBlock "Match \\d+ then \\ and stop."+          @?= "developer_instructions = \'\'\'\nMatch \\d+ then \\ and stop.\n\'\'\'",+      testCase "a body containing three apostrophes falls back to a basic string" $+        bodyBlock "say \'\'\'hi\'\'\'"+          @?= "developer_instructions = \"\"\"\nsay \'\'\'hi\'\'\'\n\"\"\"",+      testCase "the fallback escapes backslashes and quotation marks" $+        bodyBlock "a\\b \"c\" \'\'\'"+          @?= "developer_instructions = \"\"\"\na\\\\b \\\"c\\\" \'\'\'\n\"\"\"",+      testCase "a control character in the body forces the fallback and is escaped" $+        bodyBlock "before\SOHafter"+          @?= "developer_instructions = \"\"\"\nbefore\\u0001after\n\"\"\"",+      testCase "newlines survive the fallback as newlines" $+        bodyBlock "first\nsecond\SOH"+          @?= "developer_instructions = \"\"\"\nfirst\nsecond\\u0001\n\"\"\"",+      testCase "control characters in name and description are escaped" $ do+        let rendered =+              Text.lines+                ( codexCustomAgentToml+                    CodexCustomAgent+                      { name = "x\SOHy",+                        description = "\DEL",+                        developerInstructions = "body"+                      }+                )+        take 2 rendered+          @?= [ "name = \"x\\u0001y\"",+                "description = \"\\u007F\""+              ]+    ]+  where+    -- Everything from the third line on: the body's own delimiters and+    -- the lines between them.+    bodyBlock body =+      Text.intercalate+        "\n"+        ( drop+            2+            ( Text.lines+                ( codexCustomAgentToml+                    CodexCustomAgent+                      { name = "n",+                        description = "d",+                        developerInstructions = body+                      }+                )+            )+        )
+ test/AgentSpec.hs view
@@ -0,0 +1,416 @@+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,+      toolGrantCeilingTest,+      impliedGrantsTest,+      timeoutCeilingTest,+      outputLimitCeilingTest,+      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 ^. #outputFormat @?= TextFormat+    req ^. #outputLimit @?= Nothing+    req ^. #envRequires @?= []++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++    renderAgentOutputFormat TextFormat @?= "text"+    renderAgentOutputFormat JsonFormat @?= "json"+    parseAgentOutputFormat "text" @?= Just TextFormat+    parseAgentOutputFormat "json" @?= Just JsonFormat+    parseAgentOutputFormat "JSON" @?= Nothing+    parseAgentOutputFormat "stream-json" @?= Nothing++-- | A request carrying a per-stream output limit.+--+-- 'agentRunRequest' defaults 'outputLimit' to 'Nothing', which means+-- \"capture without bound\", and the default ceiling's+-- 'defaultMaxOutputLimit' refuses exactly that. Every case below that is+-- not itself about the output limit starts from this helper, so the+-- violation it asserts is the only one in the list. Jobs resolved+-- through @baikai-agent@ never hit this, because that layer's own+-- default supplies a finite limit.+bounded :: AgentRunRequest -> AgentRunRequest+bounded request = request & #outputLimit .~ Just 4096++-- | 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 = bounded (agentRunRequest AgentClaude "/tmp/work" "look around")+        editing =+          readOnly+            & #safety+            .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read", "Edit"])+            & #timeout+            .~ Just 600+            & #outputLimit+            .~ Just 1024+    applyAgentCeiling defaultAgentCeiling readOnly @?= Right readOnly+    -- Grants the capability already implies, a timeout under an+    -- unlimited maximum, and a limit under the default maximum all pass+    -- through untouched.+    applyAgentCeiling defaultAgentCeiling editing @?= Right editing++ceilingRefusalTest :: TestTree+ceilingRefusalTest =+  testCase "the ceiling refuses with the exact violation for each closed channel" $ do+    let base = bounded (agentRunRequest AgentClaude "/tmp/work" "rewrite everything")+        greedy = base & #safety .~ agentSafety AgentFullAccess+        rawArgs =+          base+            & #safety+            . #providerArgs+            .~ ["--dangerously-skip-permissions", "--verbose"]+        claudeOnly = defaultAgentCeiling & #allowedProviders .~ [AgentClaude]+        codexRequest = bounded (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 =+          bounded (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 = bounded (agentRunRequest AgentClaude "/tmp/work" "hello")+        codexRequest = bounded (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 =+          bounded (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++-- | A tool grant is authority, so the capability decides which grants+-- need no operator involvement and the operator's allow-list supplies+-- the rest. @Bash@ is in neither implied set, which is the whole point+-- of the finding this pins: a repository file granting itself shell+-- access under @edit-workspace@ must be refused.+toolGrantCeilingTest :: TestTree+toolGrantCeilingTest =+  testCase "a tool grant needs the capability to imply it or the operator to grant it" $ do+    let granting names =+          bounded (agentRunRequest AgentClaude "/tmp/work" "look around")+            & #safety+            .~ (agentSafety AgentEditWorkspace & #allowedTools .~ names)+        bash = granting ["Bash"]+    applyAgentCeiling defaultAgentCeiling bash+      @?= Left [ToolGrantForbidden ["Bash"] AgentEditWorkspace]+    applyAgentCeiling (defaultAgentCeiling & #allowedTools .~ ["Bash"]) bash @?= Right bash+    applyAgentCeiling (defaultAgentCeiling & #maxCapability .~ AgentFullAccess) bash+      @?= Right bash+    -- Matching is exact on the whole string. A pattern-scoped grant is a+    -- different grant, so granting the bare name does not permit it and+    -- an operator who wants it writes it out.+    let scoped = granting ["Bash(git *)"]+    applyAgentCeiling (defaultAgentCeiling & #allowedTools .~ ["Bash"]) scoped+      @?= Left [ToolGrantForbidden ["Bash(git *)"] AgentEditWorkspace]+    -- Grants the capability already implies need no operator at all,+    -- and only the forbidden ones are named in the refusal.+    applyAgentCeiling defaultAgentCeiling (granting ["Read", "Write", "Bash", "WebFetch"])+      @?= Left [ToolGrantForbidden ["Bash", "WebFetch"] AgentEditWorkspace]++-- | The implied grant lists are a security boundary, so they are pinned+-- name by name rather than by a property. A name added here widens every+-- ceiling in existence, which should require editing this test.+impliedGrantsTest :: TestTree+impliedGrantsTest =+  testCase "each capability implies exactly the documented grants" $ do+    toolGrantsImpliedBy AgentReadOnly+      @?= Just ["Read", "Glob", "Grep", "NotebookRead", "TodoWrite"]+    toolGrantsImpliedBy AgentEditWorkspace+      @?= Just+        [ "Read",+          "Glob",+          "Grep",+          "NotebookRead",+          "TodoWrite",+          "Edit",+          "MultiEdit",+          "Write",+          "NotebookEdit"+        ]+    toolGrantsImpliedBy AgentFullAccess @?= Nothing++-- | A finite maximum bounds a requested timeout and also refuses a job+-- that requests none, because a maximum an operator can defeat by+-- omitting the setting is not a maximum.+timeoutCeilingTest :: TestTree+timeoutCeilingTest =+  testCase "a finite max-timeout refuses a longer run and an untimed one" $ do+    let twoHours = defaultAgentCeiling & #maxTimeout .~ Just 7200+        asking limit = bounded (agentRunRequest AgentClaude "/tmp/work" "work") & #timeout .~ limit+    applyAgentCeiling twoHours (asking (Just 3600)) @?= Right (asking (Just 3600))+    applyAgentCeiling twoHours (asking (Just 7200)) @?= Right (asking (Just 7200))+    applyAgentCeiling twoHours (asking (Just 10800))+      @?= Left [TimeoutExceeded (Just 10800) 7200]+    applyAgentCeiling twoHours (asking Nothing) @?= Left [TimeoutExceeded Nothing 7200]+    -- The default maximum is unlimited, so an untimed run passes.+    applyAgentCeiling defaultAgentCeiling (asking Nothing) @?= Right (asking Nothing)++-- | The default maximum is finite, so @unlimited@ is refused until the+-- operator opens it. The memory belongs to the operator's host.+outputLimitCeilingTest :: TestTree+outputLimitCeilingTest =+  testCase "a finite max-output-limit refuses a larger capture and an unlimited one" $ do+    let asking limit =+          bounded (agentRunRequest AgentClaude "/tmp/work" "work") & #outputLimit .~ limit+        unbounded = defaultAgentCeiling & #maxOutputLimit .~ Nothing+    defaultMaxOutputLimit @?= 67108864+    applyAgentCeiling defaultAgentCeiling (asking (Just 1024))+      @?= Right (asking (Just 1024))+    applyAgentCeiling defaultAgentCeiling (asking (Just defaultMaxOutputLimit))+      @?= Right (asking (Just defaultMaxOutputLimit))+    applyAgentCeiling defaultAgentCeiling (asking (Just (defaultMaxOutputLimit + 1)))+      @?= Left [OutputLimitExceeded (Just (defaultMaxOutputLimit + 1)) defaultMaxOutputLimit]+    applyAgentCeiling defaultAgentCeiling (asking Nothing)+      @?= Left [OutputLimitExceeded Nothing defaultMaxOutputLimit]+    applyAgentCeiling unbounded (asking Nothing) @?= Right (asking Nothing)++-- | 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)++    -- A grant refusal must name what to do about it, because the fix is+    -- in a file the person reading the message may not know exists.+    let grantMessage =+          renderCeilingViolation (ToolGrantForbidden ["Bash", "Skill"] AgentEditWorkspace)+    mapM_+      ( \fragment ->+          assertBool+            ("expected " <> Text.unpack fragment <> " in: " <> Text.unpack grantMessage)+            (fragment `Text.isInfixOf` grantMessage)+      )+      ["Bash", "Skill", "edit-workspace", "policy.allowed-tools"]++    -- Durations are rendered in the spellings the configuration parser+    -- accepts, so an operator can paste the maximum back into their file.+    let overTime = renderCeilingViolation (TimeoutExceeded (Just 10800) 7200)+        untimed = renderCeilingViolation (TimeoutExceeded Nothing 7200)+    assertBool+      ("expected both durations in: " <> Text.unpack overTime)+      ("3h" `Text.isInfixOf` overTime && "2h" `Text.isInfixOf` overTime)+    assertBool+      ("expected the permitted maximum in: " <> Text.unpack untimed)+      ("2h" `Text.isInfixOf` untimed && "no timeout" `Text.isInfixOf` untimed)++    let overBytes = renderCeilingViolation (OutputLimitExceeded (Just 99999999) 67108864)+        unlimitedBytes = renderCeilingViolation (OutputLimitExceeded Nothing 67108864)+    assertBool+      ("expected both byte counts in: " <> Text.unpack overBytes)+      ("99999999" `Text.isInfixOf` overBytes && "67108864" `Text.isInfixOf` overBytes)+    assertBool+      ("expected the word unlimited in: " <> Text.unpack unlimitedBytes)+      ("unlimited" `Text.isInfixOf` unlimitedBytes && "67108864" `Text.isInfixOf` unlimitedBytes)++    let scopeMessage = renderCeilingViolation (RepositoryScopeForbidden "executable")+    assertBool+      ("expected the setting name in: " <> Text.unpack scopeMessage)+      ("executable" `Text.isInfixOf` scopeMessage)+    let outsideMessage =+          renderCeilingViolation (WorkingDirOutsideRepository "/etc" "/tmp/checkout")+    assertBool+      ("expected both paths in: " <> Text.unpack outsideMessage)+      ("/etc" `Text.isInfixOf` outsideMessage && "/tmp/checkout" `Text.isInfixOf` outsideMessage)++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 (AgentTimedOut 90 OutputNotCaptured OutputNotCaptured),+            MissingEnvironment ["KEIRO_PATH", "ANTHROPIC_API_KEY"],+            WorkingDirMissing "/tmp/gone"+          ]+    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
test/CatalogSpec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedRecordDot #-}+ -- | Regression test that locks down the contract between the JSON -- catalog files under @baikai\/data\/models\/@ and the auto-generated -- @baikai\/src\/Baikai\/Models\/Generated.hs@ module.@@ -18,17 +20,47 @@ -- JSON file changed without a paired regeneration. module CatalogSpec (tests) where +import Baikai.Api (Api (AnthropicMessages, OpenAIResponses))+import Baikai.Compat+  ( AnthropicMessagesCompat,+    AnthropicThinkingStyle (..),+    OpenAIResponsesCompat (supportedReasoningEfforts, supportsLongCacheRetention, supportsPromptCacheOptions, supportsSamplingParameters),+    supportsFastMode,+    supportsForcedToolChoice,+    supportsSamplingParameters,+    thinkingStyle,+  )+import Baikai.Model+  ( Compat (CompatAnthropicMessages, CompatOpenAIResponses),+    Model,+    api,+    compat,+    modelId,+  )+import Baikai.Models.Generated (allModels)+import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.ByteString qualified as BS+import Data.List (sort)+import Data.Text (Text) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertEqual, testCase)+import Test.Tasty.HUnit (assertEqual, assertFailure, testCase, (@?=))  tests :: TestTree tests =   testGroup     "Baikai.Models.Generated"-    [ testCase "regenerating from data/models produces no diff" $+    [ testCase "Astra selects Responses with explicit endpoint facts" $ do+        [api m | m <- allModels, modelId m == "gpt-6-astra"] @?= [OpenAIResponses]+        case [compat m | m <- allModels, modelId m == "gpt-6-astra"] of+          [CompatOpenAIResponses c] -> do+            c.supportsPromptCacheOptions @?= True+            c.supportsLongCacheRetention @?= False+            c.supportsSamplingParameters @?= False+            c.supportedReasoningEfforts @?= Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax]+          _ -> assertFailure "Astra needs explicit OpenAI endpoint facts",+      testCase "regenerating from data/models produces no diff" $         withSystemTempDirectory "baikai-catalog-spec" $ \tmpDir -> do           let regenPath = tmpDir <> "/Generated.hs"               committedPath = "src/Baikai/Models/Generated.hs"@@ -39,5 +71,57 @@             "Generated.hs is out of sync with data/models/*.json.\n\             \Run `cabal run baikai-gen-models` and commit the result."             committed-            regenerated+            regenerated,+      -- Which extended-thinking wire shape a generation accepts, and+      -- whether it accepts sampling parameters, cannot be recovered+      -- from the model id or the base URL. Every Anthropic catalog+      -- entry must therefore carry an explicit compat record stating+      -- both, and this table is where the shipped values are pinned:+      -- a catalog refresh that changes one has to change this row too.+      testCase "every Anthropic catalog entry carries an explicit thinking style and sampling flag" $ do+        assertEqual+          "the pinned table must cover exactly the catalog's Anthropic ids"+          (sort (map fst expectedAnthropicFacts))+          (sort (map modelId anthropicCatalogModels))+        mapM_ assertFacts anthropicCatalogModels     ]++-- | Every Anthropic model in the generated catalog.+anthropicCatalogModels :: [Model]+anthropicCatalogModels = [m | m <- allModels, api m == AnthropicMessages]++-- | The shipped thinking style and sampling support of each Anthropic+-- catalog id, written out by hand from+-- @baikai\/data\/models\/anthropic.json@.+expectedAnthropicFacts :: [(Text, (AnthropicThinkingStyle, Bool, Bool, Bool))]+expectedAnthropicFacts =+  [ ("claude-fable-5", (AnthropicThinkingAdaptive, False, True, False)),+    ("claude-fable-5-1", (AnthropicThinkingAdaptive, False, False, False)),+    ("claude-haiku-4-5", (AnthropicThinkingBudget, True, True, False)),+    ("claude-opus-4-5", (AnthropicThinkingBudget, True, True, False)),+    ("claude-opus-4-6", (AnthropicThinkingAdaptive, True, True, False)),+    ("claude-opus-4-7", (AnthropicThinkingAdaptive, False, True, False)),+    ("claude-opus-4-8", (AnthropicThinkingAdaptive, False, True, True)),+    ("claude-opus-5", (AnthropicThinkingAdaptive, False, True, True)),+    ("claude-sonnet-4-5", (AnthropicThinkingBudget, True, True, False)),+    ("claude-sonnet-4-6", (AnthropicThinkingAdaptive, True, True, False)),+    ("claude-sonnet-5", (AnthropicThinkingAdaptive, False, True, False))+  ]++assertFacts :: Model -> IO ()+assertFacts m = case compat m of+  CompatAnthropicMessages c -> case lookup (modelId m) expectedAnthropicFacts of+    Just expected -> facts c @?= expected+    Nothing ->+      assertFailure+        ("no pinned facts for Anthropic catalog model " <> show (modelId m))+  other ->+    assertFailure+      ( "Anthropic catalog model "+          <> show (modelId m)+          <> " must carry an explicit CompatAnthropicMessages record, not "+          <> show other+      )+  where+    facts :: AnthropicMessagesCompat -> (AnthropicThinkingStyle, Bool, Bool, Bool)+    facts c = (thinkingStyle c, c.supportsSamplingParameters, c.supportsForcedToolChoice, c.supportsFastMode)
test/CliInternalSpec.hs view
@@ -1,16 +1,52 @@+-- | 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.Text.Encoding 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 System.Timeout qualified as Timeout 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 +65,312 @@       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,+      -- Chunk boundaries are the operating system's business, not the+      -- codex event schema's: a pipe read returns whatever bytes had+      -- arrived, which for a long event is the middle of a line.+      testCase "a line spanning several chunks is one event" $ do+        report <-+          parseCodex+            [ "{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_mess",+              "age\",\"text\":\"split\"}}\n"+            ]+        report ^. #message @?= "split",+      testCase "a final line without a newline is still parsed" $ do+        report <-+          parseCodex+            ["{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"last\"}}"]+        report ^. #message @?= "last",+      -- The previous implementation appended one byte at a time with+      -- BS.snoc, copying the whole accumulator per byte: quadratic in+      -- line length, so a two-million-character message cost on the+      -- order of a trillion byte moves and never finished. The bound is+      -- what makes this a test rather than a benchmark.+      testCase "a multi-megabyte event is assembled in linear time" $ do+        let body = Text.replicate 2000000 "a"+            event =+              Text.encodeUtf8+                ( "{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\""+                    <> body+                    <> "\"}}\n"+                )+        finished <- Timeout.timeout 10000000 (parseCodex [event])+        case finished of+          Nothing ->+            assertFailure+              "assembling one two-megabyte event did not finish within ten seconds"+          Just report -> Text.length (report ^. #message) @?= 2000000+    ]++-- ============================================================+-- The claude result document+-- ============================================================++claudeParserTests :: TestTree+claudeParserTests =+  testGroup+    "claude -p --output-format json result"+    [ testCase "a reported zero total retains its source instead of becoming missing cost" $ do+        case decodeClaudeCliResult "{\"result\":\"ok\",\"is_error\":false,\"usage\":{\"input_tokens\":0},\"total_cost_usd\":0}" of+          Left err -> assertFailure (show err)+          Right report -> case report ^. #usage of+            Just u -> do+              u ^. #cost . #usd @?= 0+              u ^. #cost . #basis @?= providerReportedBasis+            Nothing -> assertFailure "usage disappeared",+      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"     ]
test/ContextSpec.hs view
@@ -3,21 +3,45 @@ import Baikai import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson+import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as V import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.HUnit (assertBool, testCase, (@?=))  tests :: TestTree tests =   testGroup     "Context helpers"-    [ monoidTests,+    [ replayStateTests,+      monoidTests,       constructorTests,       timestampTests,-      flattenTextTests+      flattenTextTests,+      toolResultTests     ] +-- | A failed call has no assistant turn worth replaying and no tool+-- calls to answer, so 'appendToolResult' appends nothing and runs+-- nothing. 'runToolLoop' has always stopped on such a response; the+-- documented direct round trip reaches here instead.+toolResultTests :: TestTree+toolResultTests =+  testGroup+    "appendToolResult"+    [ testCase "an error-shaped response leaves the context unchanged and never dispatches" $ do+        let ctx = contextOf [user "go"]+            failed =+              errorResponse+                emptyModel+                (read "2026-06-05 01:02:03 UTC" :: UTCTime)+                12+                (providerError "upstream died")+            explode _ = error "the dispatcher must not run for an error-shaped response"+        after <- appendToolResult ctx failed explode+        after @?= ctx+    ]+ monoidTests :: TestTree monoidTests =   testGroup@@ -107,7 +131,8 @@                   ThinkingContent                     { thinking = "hidden",                       signature = Nothing,-                      redacted = False+                      redacted = False,+                      replayState = Nothing                     },                 AssistantToolCall emptyToolCall {name = "lookup", arguments = Aeson.object []},                 AssistantText (TextContent " world")@@ -131,3 +156,35 @@  (|>) :: a -> (a -> b) -> b (|>) x f = f x++replayStateTests :: TestTree+replayStateTests =+  testGroup+    "provider-scoped reasoning replay"+    [ testCase "legacy JSON remains valid and byte-compatible" $ do+        let old = Aeson.object ["thinking" Aeson..= ("" :: Text.Text), "signature" Aeson..= Aeson.Null, "redacted" Aeson..= False]+        Aeson.fromJSON old @?= Aeson.Success emptyThinkingContent+        Aeson.toJSON emptyThinkingContent @?= old,+      testCase "empty summary and ordered encrypted items survive content persistence and context appending" $ do+        let saved = Aeson.eitherDecode (Aeson.encode thought)+        saved @?= Right thought+        let resp = emptyResponse & #message . #content .~ V.singleton (AssistantThinking thought)+            context = addResponse resp (contextOf [user "go"])+        context ^. #messages @?= V.fromList [user "go", responseMessage resp]+        flattenAssistantText (resp ^. #message . #content) @?= ""+        assertBool "Show omits encrypted content" (not ("encrypted-secret" `Text.isInfixOf` Text.pack (show resp))),+      testCase "response content commitment binds replay scope, identity, payload and order" $ do+        let digest t = commitmentDigest (Aeson.object ["content" Aeson..= V.singleton (AssistantThinking t)])+            changed r = thought & #replayState .~ Just r+        mapM_+          (\r -> assertBool "replay mutation must change commitment" (digest thought /= digest (changed r)))+          [ state & #replayApi .~ AnthropicMessages,+            state & #replayModel .~ "other-model",+            state & #replayItems .~ V.reverse items,+            state & #replayItems .~ V.singleton (Aeson.object ["id" Aeson..= ("different" :: Text.Text)])+          ]+    ]+  where+    items = V.fromList [Aeson.object ["type" Aeson..= ("reasoning" :: Text.Text), "id" Aeson..= ("rs_1" :: Text.Text), "summary" Aeson..= ([] :: [Aeson.Value]), "encrypted_content" Aeson..= ("encrypted-secret" :: Text.Text)], Aeson.object ["id" Aeson..= ("rs_2" :: Text.Text)]]+    state = ThinkingReplay OpenAIResponses "gpt-6-astra" items+    thought = emptyThinkingContent & #replayState .~ Just state
test/CostSpec.hs view
@@ -1,34 +1,41 @@ module CostSpec (tests) where  import Baikai.Api (Api (..))+import Baikai.CacheRetention (CacheRetention (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext) import Baikai.Cost qualified as Cost import Baikai.Cost.Log-  ( CallLogConfig (..),-    CallLogEntry (..),+  ( CallLogEntry (..),     appendEntry,+    callLogConfig,+    closeCallLog,+    openCallLog,     runRequestWithLog,     withCallLog,   )-import Baikai.Cost.Pricing (attachCost, computeCost)+import Baikai.Cost.Pricing (attachCost, computeCost, computeCostAtSpeed, computeCostForService) import Baikai.Message (AssistantPayload (..), user)-import Baikai.Model (Model (..), ModelCost (..), emptyModel)+import Baikai.Model (InputPriceTier (..), Model (..), ModelCost (..), PricingPolicy (..), emptyModel)+import Baikai.Models.Generated qualified as Models import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider-  ( ApiProvider (..),+  ( apiProviderWith,     registerApiProvider,   ) import Baikai.Response (Response (..), flattenAssistantBlocks)+import Baikai.Speed (Speed (..)) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) import Baikai.Usage (Usage, zeroUsage)+import Baikai.Usage qualified as Usage import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BSL import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Maybe (fromJust, isJust)-import Data.Time (getCurrentTime)+import Data.Set qualified as Set+import Data.Time (UTCTime, getCurrentTime) import Data.Vector qualified as V import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath ((</>))@@ -40,7 +47,8 @@ tests =   testGroup     "Baikai.Cost"-    [ computeTests,+    [ fastCostTests,+      computeTests,       attachCostTests,       callLogTests     ]@@ -142,7 +150,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,18 +176,19 @@           provider = "canned",           responseId = Nothing,           latencyMs = 7,-          errorInfo = Nothing+          errorInfo = Nothing,+          evidence = Nothing         }  registerCanned :: Response -> IO () registerCanned resp =   let handler _m _ctx _opts = pure resp    in registerApiProvider-        ApiProvider-          { apiTag = cannedApi,-            stream = liftCompleteToStream handler,-            complete = handler-          }+        ( apiProviderWith+            cannedApi+            (liftCompleteToStream handler)+            (handler)+        )  cannedModel :: Model cannedModel = knownModel & #api .~ cannedApi@@ -195,7 +205,7 @@     "CallLog"     [ testCase "disabled handle skips disk I/O" $ do         registerCanned cannedHaiku-        let cfg = CallLogConfig {path = "/dev/null", enabled = False}+        let cfg = callLogConfig "/dev/null" & #enabled .~ False         withCallLog cfg $ \h -> do           resp <- runRequestWithLog h cannedModel ctxHello optsZero           flattenAssistantBlocks resp@@ -205,7 +215,7 @@         tmp <- getTemporaryDirectory         let path' = tmp </> "baikai-cost-test.jsonl"         writeFile path' ""-        let cfg = CallLogConfig {path = path', enabled = True}+        let cfg = callLogConfig path'         withCallLog cfg $ \h -> do           _ <- runRequestWithLog h cannedModel ctxHello optsZero           pure ()@@ -226,25 +236,95 @@         entry ^. #latencyMs @?= 7         entry ^. #promptSummary @?= "Hello world"         isJust (entry ^. #usd) @?= True+        entry ^. #costBasis @?= Just (cannedHaiku ^. #message . #usage . #cost . #basis)+        entry ^. #cacheWriteTokens @?= Just (cannedHaiku ^. #message . #usage . #cacheWriteTokens)         removeFile path',       testCase "closeCallLog returns even when the log path is unwritable" $ do         tmp <- getTemporaryDirectory         let missing = tmp </> "baikai-costspec-no-such-dir" </> "entries.jsonl"-            cfg = CallLogConfig {path = missing, enabled = True}+            cfg = callLogConfig missing         now <- getCurrentTime-        let entry =-              CallLogEntry-                { timestamp = now,-                  provider = "test",-                  model = "m",-                  inputTokens = Nothing,-                  outputTokens = Nothing,-                  cachedInputTokens = Nothing,-                  reasoningTokens = Nothing,-                  usd = Nothing,-                  latencyMs = 0,-                  promptSummary = ""-                }-        result <- timeout 5000000 (withCallLog cfg (\h -> appendEntry h entry))+        result <- timeout 5000000 (withCallLog cfg (\h -> appendEntry h (sampleEntry now)))+        result @?= Just (),+      -- 'withCallLog' brackets a close around a body that may also close+      -- the handle, so the second close is a shape a caller reaches by+      -- accident. Before the claim it blocked forever on an 'MVar' the+      -- worker had already emptied.+      testCase "closeCallLog twice returns and appendEntry after close is a no-op" $ do+        tmp <- getTemporaryDirectory+        let path' = tmp </> "baikai-costspec-double-close.jsonl"+        writeFile path' ""+        let cfg = callLogConfig path'+        h <- openCallLog cfg+        result <- timeout 5000000 (closeCallLog h >> closeCallLog h)         result @?= Just ()+        now <- getCurrentTime+        appendEntry h (sampleEntry now)+        raw <- BSL.readFile path'+        BSL.length raw @?= 0+        removeFile path'     ]++-- | A minimal entry, shared by the call-log cases that need one to+-- enqueue rather than one to inspect.+sampleEntry :: UTCTime -> CallLogEntry+sampleEntry now =+  CallLogEntry+    { timestamp = now,+      provider = "test",+      model = "m",+      inputTokens = Nothing,+      outputTokens = Nothing,+      cachedInputTokens = Nothing,+      reasoningTokens = Nothing,+      cacheWriteTokens = Nothing,+      costBasis = Nothing,+      usageAvailability = Nothing,+      usd = Nothing,+      latencyMs = 0,+      promptSummary = ""+    }++fastCostTests :: TestTree+fastCostTests =+  testGroup+    "fast pricing"+    [ testCase "fast premiums compose with context tiers before pricing" $ do+        let m = Models.anthropic_claude_opus_5 & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 1000 (ModelCost 10 50 1 12.5)] Nothing)+        Cost.usd (computeCostAtSpeed m SpeedFast u) @?= 2 * Cost.usd (computeCost m u),+      testCase "invalid premium rates and undefined policy ratios are explicit" $ do+        let negative = knownModel & #fastModeCost .~ Just (ModelCost (-1) 10 0.2 2.5)+            undefinedRatio = knownModel & #cost .~ ModelCost 0 5 0.1 1.25 & #fastModeCost .~ Just (ModelCost 10 10 0.2 2.5) & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 1 (ModelCost 5 5 0.1 1.25)] Nothing)+        mapM_ (\m -> Set.member Cost.InvalidPricingPolicy (Cost.estimateReasons (Cost.basis (computeCostAtSpeed m SpeedFast u))) @?= True) [negative, undefinedRatio],+      testCase "contradictory speed observations remain an explicit standard estimate" $ do+        let usage = Usage.observeBilling [Usage.BillingSpeed "fast", Usage.BillingSpeed "standard"] u+            result = computeCostForService Nothing Nothing Models.anthropic_claude_opus_5 usage+        Cost.usd result @?= Cost.usd (computeCost Models.anthropic_claude_opus_5 u)+        Set.member Cost.InconsistentUsage (Cost.estimateReasons (Cost.basis result)) @?= True,+      testCase "fast Opus costs exactly twice standard across all four token categories" $ do+        mapM_+          ( \m -> do+              let standard = computeCost m u+                  fast = computeCostAtSpeed m SpeedFast u+              Cost.usd fast @?= 2 * Cost.usd standard+              Cost.breakdown fast @?= Cost.breakdown (standard <> standard)+              computeCostAtSpeed m SpeedStandard u @?= standard+              Cost.sources (Cost.basis fast) @?= Set.singleton Cost.ResolvedTokenRates+          )+          [Models.anthropic_claude_opus_5, Models.anthropic_claude_opus_4_8],+      testCase "uncurated fast pricing retains the standard amount and marks the estimate" $ do+        let m = Models.anthropic_claude_sonnet_5+            fast = computeCostAtSpeed m SpeedFast u+        Cost.usd fast @?= Cost.usd (computeCost m u)+        Set.member (Cost.UnsupportedSpeed "fast") (Cost.estimateReasons (Cost.basis fast)) @?= True,+      testCase "observed fast speed selects premium long-cache rates once" $ do+        let usage = Usage.observeBilling [Usage.BillingSpeed "fast", Usage.BillingServiceTier "standard"] (zeroUsage & #cacheWriteTokens .~ 1000000)+            price = computeCostForService (Just CacheRetentionLong) Nothing Models.anthropic_claude_opus_5 usage+        Cost.usd price @?= 20+        Set.member (Cost.UnsupportedSpeed "fast") (Cost.estimateReasons (Cost.basis price)) @?= False,+      testCase "observed standard speed retains standard long-cache rates" $ do+        let usage = Usage.observeBilling [Usage.BillingSpeed "standard", Usage.BillingServiceTier "standard"] (zeroUsage & #cacheWriteTokens .~ 1000000)+        Cost.usd (computeCostForService (Just CacheRetentionLong) Nothing Models.anthropic_claude_opus_5 usage) @?= 10+    ]+  where+    u = sampleUsage & #cacheReadTokens .~ 200 & #cacheWriteTokens .~ 300
test/EmbeddingSpec.hs view
@@ -1,4 +1,4 @@--- | Tests for the embeddings client (EP-15, M1).+-- | Tests for the embeddings client. -- -- The request-mapping test is hermetic: it asserts on the pure -- 'mkEmbeddingRequest' (no network), proving the input text, model id, and@@ -7,14 +7,32 @@ -- default run stays offline. module EmbeddingSpec (tests) where -import Baikai.Embedding (embedOne, firstEmbedding, mkEmbeddingRequest, openAIEmbeddingModel)-import Baikai.Error (decodeError)+import Baikai.Auth (ApiKeySource (..))+import Baikai.Embedding+  ( EmbeddingModel (..),+    embedOne,+    embeddingClientEnv,+    emptyEmbeddingModel,+    firstEmbedding,+    mkEmbeddingRequest,+    openAIEmbeddingModel,+    resolveEmbeddingKey,+  )+import Baikai.Error (BaikaiError, ErrorCategory (..), decodeError)+import Baikai.Http qualified as Http+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 V import OpenAI.V1.Embeddings qualified as Emb import OpenAI.V1.Models qualified as OpenAIModels+import Servant.Client qualified as Client import System.Environment (lookupEnv)+import System.Environment qualified as Environment import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  tests :: TestTree tests =@@ -36,6 +54,54 @@                   Emb.object = "embedding"                 }         firstEmbedding (V.singleton obj) @?= Right vec,+      testCase "an embedding host resolves its own key, not OpenAI's" $ do+        -- The defect: whatever the base URL said, the default key was+        -- OPENAI_API_KEY. Pointing an EmbeddingModel at DeepSeek sent an+        -- OpenAI key to DeepSeek.+        withEnv "OPENAI_API_KEY" (Just "openai-secret") $+          withEnv "DEEPSEEK_API_KEY" Nothing $ do+            err <-+              expectAuthError+                (emptyEmbeddingModel & #baseUrl .~ "https://api.deepseek.com")+            assertBool+              ("names the host's own variable: " <> Text.unpack (err ^. #message))+              ("DEEPSEEK_API_KEY" `Text.isInfixOf` (err ^. #message)),+      testCase "an unknown embedding host refuses rather than sending OpenAI's key" $+        withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do+          err <-+            expectAuthError+              (emptyEmbeddingModel & #baseUrl .~ "https://vectors.example")+          assertBool+            ("says what to set: " <> Text.unpack (err ^. #message))+            ("EmbeddingModel.apiKey" `Text.isInfixOf` (err ^. #message)),+      testCase "the OpenAI default still resolves OPENAI_API_KEY" $+        withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do+          resolved <- resolveEmbeddingKey (openAIEmbeddingModel "text-embedding-3-small")+          resolved @?= "openai-secret",+      testCase "an explicit key source wins over the per-host table" $+        withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do+          resolved <-+            resolveEmbeddingKey+              ( openAIEmbeddingModel "m"+                  & #apiKey+                    .~ Just (ApiKeyLiteral "explicit-key")+              )+          resolved @?= "explicit-key",+      testCase "embeddings share the connection cache with the chat providers" $ do+        -- One TLS manager per host, not one per call: the SDK's own+        -- getClientEnv allocated a fresh manager every time embed ran.+        before <- Http.cachedClientEnvCount+        _ <- embeddingClientEnv (emptyEmbeddingModel & #baseUrl .~ "https://embed-cache.test")+        env <- embeddingClientEnv (emptyEmbeddingModel & #baseUrl .~ "https://Embed-Cache.test/")+        afterBoth <- Http.cachedClientEnvCount+        afterBoth @?= before + 1+        Client.baseUrlHost (Client.baseUrl env) @?= "embed-cache.test"+        Client.baseUrlPath (Client.baseUrl env) @?= "",+      testCase "the #field idiom compiles on EmbeddingModel" $ do+        -- It could not before: the record derived neither Generic nor Eq.+        let m = openAIEmbeddingModel "m" & #dimensions .~ Just 256+        m ^. #dimensions @?= Just 256+        m @?= (openAIEmbeddingModel "m" & #dimensions .~ Just 256),       testCase "live embedding returns a 1536-length vector" $ do         live <- lookupEnv "BAIKAI_EMBEDDING_LIVE"         case live of@@ -44,3 +110,29 @@             V.length v @?= 1536           _ -> putStrLn "BAIKAI_EMBEDDING_LIVE not set; skipping live test"     ]++-- | Resolve a model's key, expecting it to refuse.+expectAuthError :: EmbeddingModel -> IO BaikaiError+expectAuthError m = do+  thrown <- Exception.try (resolveEmbeddingKey m) :: IO (Either BaikaiError Text)+  case thrown of+    Right key -> assertFailure ("expected an AuthError, got a key: " <> Text.unpack key)+    Left err -> do+      err ^. #category @?= AuthError+      pure err++-- | Run an action with one environment variable set to a value, or+-- removed, restoring whatever was there before.+withEnv :: String -> Maybe String -> IO a -> IO a+withEnv name value action =+  Exception.bracket+    ( do+        old <- Environment.lookupEnv name+        apply value+        pure old+    )+    apply+    (const action)+  where+    apply Nothing = Environment.unsetEnv name+    apply (Just v) = Environment.setEnv name v
test/ErrorInfoSpec.hs view
@@ -37,6 +37,7 @@       term =         errorTerminal           Nothing+          Nothing           ErrorReason           (AssistantMessage payload)           (rateLimited (Just 5) "rate limited, slow down")@@ -50,11 +51,11 @@ registerErr :: IO () registerErr =   registerApiProvider-    ApiProvider-      { apiTag = errApi,-        stream = errStream,-        complete = streamingComplete errStream-      }+    ( apiProviderWith+        errApi+        (errStream)+        (streamingComplete errStream)+    )  tests :: TestTree tests =@@ -92,6 +93,7 @@                 .~ Just "legacy unclassified failure"             terminal =               doneTerminal+                Nothing                 Nothing                 ErrorReason                 (AssistantMessage payload)
test/ErrorSpec.hs view
@@ -5,14 +5,19 @@     ErrorCategory (..),     classifyHttpStatus,     classifyHttpStatusWithBody,+    contentFiltered,     decodeError,     httpError,     invalidRequest,     isRetryable,+    parseHttpDate,     parseRetryAfterSeconds,     processError,     rateLimited,+    retryAfterSecondsAt,   )+import Data.Aeson qualified as Aeson+import Data.Time (UTCTime) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -24,6 +29,7 @@       bodyClassifyTests,       httpHelperTests,       retryTests,+      refusalJsonTests,       constructorTests     ] @@ -36,15 +42,45 @@         category e @?= RateLimited         httpStatus e @?= Just 429         retryAfterSeconds e @?= Just 12,+      -- Re-homed from the provider suites' servant fixtures: the+      -- assertion is about 'httpError', which is where it belongs.+      testCase "429 without Retry-After -> RateLimited, no hint" $ do+        let e = httpError 429 Nothing "slow down"+        category e @?= RateLimited+        retryAfterSeconds e @?= Nothing,       testCase "400 + overflow body -> ContextOverflow" $         category (httpError 400 Nothing "maximum context length exceeded")           @?= ContextOverflow,       testCase "integer Retry-After parses as seconds" $         parseRetryAfterSeconds "12" @?= Just 12,-      testCase "HTTP-date Retry-After is ignored" $-        parseRetryAfterSeconds "Wed, 21 Oct 2026 07:28:00 GMT" @?= Nothing+      -- The integer-only contract is now deliberate rather than a+      -- limitation: converting a date needs a reference instant, which+      -- 'retryAfterSecondsAt' takes and this function cannot.+      testCase "parseRetryAfterSeconds is integer-only" $+        parseRetryAfterSeconds "Wed, 21 Oct 2026 07:28:00 GMT" @?= Nothing,+      testCase "HTTP-date Retry-After yields seconds from the reference instant" $+        retryAfterSecondsAt referenceInstant "Wed, 21 Oct 2026 07:28:00 GMT" @?= Just 30,+      -- The server is saying "now", not "some time last week".+      testCase "HTTP-date Retry-After in the past yields zero" $+        retryAfterSecondsAt referenceInstant "Wed, 21 Oct 2026 07:00:00 GMT" @?= Just 0,+      testCase "integer Retry-After ignores the reference instant" $+        retryAfterSecondsAt referenceInstant "12" @?= Just 12,+      testCase "malformed Retry-After yields Nothing" $+        retryAfterSecondsAt referenceInstant "soonish" @?= Nothing,+      testCase "parseHttpDate accepts IMF-fixdate, RFC 850 and asctime" $ do+        let expected = Just (read "1994-11-06 08:49:37 UTC" :: UTCTime)+        parseHttpDate "Sun, 06 Nov 1994 08:49:37 GMT" @?= expected+        parseHttpDate "Sunday, 06-Nov-94 08:49:37 GMT" @?= expected+        parseHttpDate "Sun Nov  6 08:49:37 1994" @?= expected,+      testCase "parseHttpDate rejects text that is not a date" $+        parseHttpDate "tomorrow" @?= Nothing     ] +-- | Thirty seconds before the @Retry-After@ date the cases above use, so+-- the expected answer is a number a reader can check by eye.+referenceInstant :: UTCTime+referenceInstant = read "2026-10-21 07:27:30 UTC"+ bodyClassifyTests :: TestTree bodyClassifyTests =   testGroup@@ -62,7 +98,13 @@         classifyHttpStatusWithBody 429 Nothing "context length whatever"           @?= RateLimited,       testCase "500 defers to status -> TransientError" $-        classifyHttpStatusWithBody 500 Nothing "context length" @?= TransientError+        classifyHttpStatusWithBody 500 Nothing "context length" @?= TransientError,+      -- 413 is the size-limit status, so the body's wording changes+      -- nothing: the caller's remedy is to shrink the input either way.+      testCase "413 + ordinary body -> ContextOverflow" $+        classifyHttpStatusWithBody 413 Nothing "payload too large" @?= ContextOverflow,+      testCase "413 + request_too_large body -> ContextOverflow" $+        classifyHttpStatusWithBody 413 Nothing "request_too_large" @?= ContextOverflow     ]  classifyTests :: TestTree@@ -79,6 +121,7 @@       testCase "500 -> TransientError" $ classifyHttpStatus 500 Nothing @?= TransientError,       testCase "502 -> TransientError" $ classifyHttpStatus 502 Nothing @?= TransientError,       testCase "503 -> TransientError" $ classifyHttpStatus 503 Nothing @?= TransientError,+      testCase "413 -> ContextOverflow" $ classifyHttpStatus 413 Nothing @?= ContextOverflow,       testCase "418 -> OtherError" $ classifyHttpStatus 418 Nothing @?= OtherError     ] @@ -110,4 +153,27 @@         category (invalidRequest "x") @?= InvalidRequest,       testCase "decodeError category" $         category (decodeError "x") @?= DecodeFailure+    ]++refusalJsonTests :: TestTree+refusalJsonTests =+  testGroup+    "refusal error JSON"+    [ testCase "provider category round-trips under its snake-case key" $ do+        let e = (contentFiltered "declined") {refusalCategory = Just "future_category"}+        Aeson.eitherDecode (Aeson.encode e) @?= Right e+        Aeson.toJSON e+          @?= Aeson.object+            [ "category" Aeson..= ("content_filtered" :: String),+              "message" Aeson..= ("declined" :: String),+              "http_status" Aeson..= Aeson.Null,+              "retry_after_seconds" Aeson..= Aeson.Null,+              "exit_code" Aeson..= Aeson.Null,+              "refusal_category" Aeson..= ("future_category" :: String)+            ],+      testCase "legacy errors without refusal_category still decode" $+        Aeson.eitherDecode "{\"category\":\"content_filtered\",\"message\":\"declined\",\"http_status\":null,\"retry_after_seconds\":null,\"exit_code\":null}"+          @?= Right (contentFiltered "declined"),+      testCase "ordinary failures have no refusal category" $+        refusalCategory (httpError 429 Nothing "slow down") @?= Nothing     ]
+ test/EvidenceSpec.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | 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.Cost (Cost (..), CostEstimateReason (CacheWriteUsageNotReported), estimateCost, zeroCost)+import Baikai.Evidence+import Baikai.Provider.Cli.Internal qualified as Internal+import Baikai.ThinkingLevel (ThinkingLevel (..))+import Baikai.Usage (Usage (..), zeroUsage)+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"+    [ translationDisplayTests,+      canonicalTests,+      digestTests,+      usageEnvelopeTests,+      deriveStrengthTests,+      redactionTests,+      observedTests,+      adjustmentJsonTests,+      callIdTests+    ]++-- ============================================================+-- Adjustment JSON+-- ============================================================++-- | Every adjustment kind, through JSON and back.+--+-- The two sampling kinds carry a @fields@ array and no @requested@+-- level, so a decoder that reads @requested@ before it reads @kind@+-- fails on them. Round-tripping every constructor is what keeps that+-- ordering honest as constructors are added.+adjustmentJsonTests :: TestTree+adjustmentJsonTests =+  testGroup+    "ThinkingAdjustment JSON"+    ( [ testCase (show adjustment) (roundTripAdjustment adjustment)+      | adjustment <-+          [ EffortClamped ThinkingMax "high",+            EffortCollapsedToToggle ThinkingHigh,+            EffortOmitted ThinkingHigh,+            ThinkingDroppedUnsupportedModel ThinkingLow,+            ThinkingDroppedUnsupportedHost ThinkingMinimal,+            ThinkingDroppedBudgetExceeded ThinkingMax 32000 8192,+            SamplingDroppedUnsupportedModel ["temperature", "top_p"],+            SamplingDroppedUnsupportedApi ["seed", "frequency_penalty", "presence_penalty"],+            ThinkingSummaryUnavailable+          ]+      ]+        <> [ testCase "a sampling drop encodes its kind and fields and no requested level" $+               Aeson.toJSON (SamplingDroppedUnsupportedModel ["temperature", "top_p"])+                 @?= Aeson.object+                   [ "kind" Aeson..= ("sampling_dropped_unsupported_model" :: Text.Text),+                     "fields" Aeson..= (["temperature", "top_p"] :: [Text.Text])+                   ],+             testCase "an API-level sampling drop names its own kind" $+               Aeson.toJSON (SamplingDroppedUnsupportedApi ["seed"])+                 @?= Aeson.object+                   [ "kind" Aeson..= ("sampling_dropped_unsupported_api" :: Text.Text),+                     "fields" Aeson..= (["seed"] :: [Text.Text])+                   ]+           ]+    )+  where+    roundTripAdjustment :: ThinkingAdjustment -> IO ()+    roundTripAdjustment v = case Aeson.fromJSON (Aeson.toJSON v) of+      Aeson.Success v' -> v' @?= v+      Aeson.Error e -> assertFailure ("round trip failed: " <> e)++-- ============================================================+-- 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 -> "<unparsed: " <> 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 "speed participates in the configuration fingerprint" $ do+        let absent = object ["model" .= ("claude-opus-5" :: Text.Text)]+            standard = object ["model" .= ("claude-opus-5" :: Text.Text), "speed" .= ("standard" :: Text.Text)]+            fast = object ["model" .= ("claude-opus-5" :: Text.Text), "speed" .= ("fast" :: Text.Text)]+        assertBool "fast differs from standard" (configurationDigest fast /= configurationDigest standard)+        assertBool "explicit standard differs from absent" (configurationDigest standard /= configurationDigest absent),+      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.+      --+      -- Both values changed at schema version 2.0, because the fixture+      -- gained an `output_config` and a `response_format` and the+      -- projection now summarises both. They were recomputed only after+      -- the redaction group above was green: a golden value pasted while+      -- a marker still leaked would pin the leak.+      testCase "the request commitment matches the golden value" $ do+        env <- loadFixture+        commitmentDigest env+          @?= "sha256:7328ef9e177fbf71793c2167c25749b98845ecc5ea1cf9cd5a38ef3aa52d3b0b",+      testCase "the configuration digest matches the golden value" $ do+        env <- loadFixture+        configurationDigest env+          @?= "sha256:5ed62ecd1a00798c06de88363e9f6a591610449f1e06fa8bd8260ee7934ea366",+      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+    ]++-- ============================================================+-- The one strength rule+-- ============================================================++-- | All eight combinations, one named case per row.+--+-- Three copies of this rule had drifted: the subprocess one counted a+-- session or thread id as correlation while the two API ones looked only+-- at a captured header, so a host reporting @model@ and @id@ on every+-- chunk but no header landed below a host that sent only a header.+deriveStrengthTests :: TestTree+deriveStrengthTests =+  testGroup+    "deriveStrength"+    [ row "nothing observed" Unobserved Unobserved Unobserved EvidenceRequestedOnly,+      row "a model alone does not climb the scale" (Observed "m") Unobserved Unobserved EvidenceRequestedOnly,+      row "a request id alone is correlation" Unobserved (Observed "req") Unobserved EvidenceCorrelated,+      row "A RESPONSE ID ALONE IS ALSO CORRELATION" Unobserved Unobserved (Observed "resp") EvidenceCorrelated,+      row "both identifiers are still correlation" Unobserved (Observed "req") (Observed "resp") EvidenceCorrelated,+      row "a model with a request id is model_observed" (Observed "m") (Observed "req") Unobserved EvidenceModelObserved,+      row "A MODEL WITH A RESPONSE ID IS ALSO model_observed" (Observed "m") Unobserved (Observed "resp") EvidenceModelObserved,+      row "a model with both identifiers is model_observed" (Observed "m") (Observed "req") (Observed "resp") EvidenceModelObserved,+      testCase "nothing reaches fully_observed" $+        assertBool+          "no combination of these three observations may reach the top of the scale"+          ( all+              (< EvidenceFullyObserved)+              [ deriveStrength o r i+              | o <- both,+                r <- both,+                i <- both+              ]+          )+    ]+  where+    row name observedModel requestId responseId expected =+      testCase name (deriveStrength observedModel requestId responseId @?= expected)+    both = [Unobserved, Observed "x"]++-- ============================================================+-- The usage a response digest commits to+-- ============================================================++usageEnvelopeTests :: TestTree+usageEnvelopeTests =+  testGroup+    "usage envelope"+    [ testCase "cost basis is serialized additively without changing provider commitments" $ do+        evidenceSchemaVersion @?= "baikai.model-call-evidence/2.5"+        let estimated = zeroUsage {cost = estimateCost [CacheWriteUsageNotReported] zeroCost}+        usageEnvelope estimated @?= usageEnvelope zeroUsage+        assertBool "usage JSON retains the local calculation basis" (Aeson.toJSON estimated /= Aeson.toJSON zeroUsage),+      testCase "two usages differing only in cost produce the same envelope" $ do+        -- The cost is computed here from the caller's catalog rates, not+        -- read off the response, so a verifier holding only the response+        -- could not recompute a digest that covered it — and the digest+        -- changed whenever a price was edited.+        let cheap = zeroUsage {inputTokens = 10, outputTokens = 20}+            dear = cheap {cost = zeroCost {usd = 1234}}+        usageEnvelope cheap @?= usageEnvelope dear,+      testCase "legacy usage envelope has exactly the original six keys" $+        case usageEnvelope zeroUsage of+          Object fields -> KeyMap.size fields @?= 6+          _ -> assertFailure "usage envelope is not an object",+      testCase "the encoded envelope carries no cost key" $ do+        let encoded = BS8.unpack (canonicalEncode (usageEnvelope zeroUsage))+        assertBool+          ("cost survived into the usage envelope: " <> encoded)+          (not ("cost" `isInfix` encoded))+        mapM_+          ( \k ->+              assertBool+                (k <> " missing from the usage envelope: " <> encoded)+                (k `isInfix` encoded)+          )+          [ "input_tokens",+            "output_tokens",+            "cache_read_tokens",+            "cache_write_tokens",+            "reasoning_tokens",+            "total_tokens"+          ]+    ]+  where+    isInfix needle haystack =+      Text.isInfixOf (Text.pack needle) (Text.pack haystack)++-- ============================================================+-- 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.",+            -- A JSON schema is content wherever it appears. These two+            -- markers sit in the `description` of a structured-output+            -- schema reached two different ways: Anthropic's+            -- `output_config.format.schema` and the OpenAI-compatible+            -- `response_format.json_schema.schema`. The fixture is one+            -- recorded envelope serving both the digest and the+            -- redaction tests, and it already carries a non-wire+            -- `extra_headers` key, so mixing an OpenAI-shaped key into+            -- an Anthropic-shaped body is in keeping.+            "OUTPUT-SCHEMA-MARKER",+            "RESPONSE-SCHEMA-MARKER"+          ],+      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",+            -- The same rule around a structured-output schema: the+            -- effort, the schema's name and its strictness are how the+            -- call is configured.+            "effort",+            "quarterly_report",+            "strict"+          ],+      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 'OverloadedRecordDot' or the+      -- generic-lens labels (@r ^. #runId@) the rest of this codebase+      -- uses; the constructor is no longer exported.+      testCase "evidenceRequest defaults to best effort, attempt one" $ do+        let req = evidenceRequest "run-42"+        req.runId @?= "run-42"+        req.strictness @?= EvidenceBestEffort+        req.attempt @?= 1+        req.supersedes @?= 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++translationDisplayTests :: TestTree+translationDisplayTests = testCase "display translation is optional in legacy JSON and round-trips when present" $ do+  let legacy = Aeson.toJSON noThinkingRequested+      summary = noThinkingRequested {displayText = Just "summarized"}+  case legacy of+    Object o -> KeyMap.lookup "display_text" o @?= Nothing+    _ -> assertFailure "translation must be an object"+  Aeson.fromJSON legacy @?= Aeson.Success noThinkingRequested+  Aeson.fromJSON (Aeson.toJSON summary) @?= Aeson.Success summary
test/FetchModelsSpec.hs view
@@ -4,8 +4,11 @@ -- models.dev-shaped fixture. No network is involved. module FetchModelsSpec (tests) where +import Baikai.Compat (AnthropicThinkingStyle (..), defaultOpenAIResponsesCompat) import Baikai.Model (InputModality (..))+import Baikai.Model qualified as Model import Baikai.Prelude+import Control.Monad (forM_) import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as BSL@@ -18,6 +21,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Vector qualified as V import FetchModelsCore+import GenModelsCore qualified as Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -56,8 +60,12 @@               reasoning = True,               input = [InputText, InputImage],               cost = CatalogCost 0.05 0.4 0 0,+              fastModeCost = Nothing,+              pricingPolicy = Nothing,               contextWindow = 400000,-              maxOutputTokens = 128000+              maxOutputTokens = 128000,+              apiOverride = Nothing,+              compat = Nothing             },           CatalogModel             { modelId = "gpt-5.4",@@ -65,18 +73,116 @@               reasoning = True,               input = [InputText, InputImage],               cost = CatalogCost 2.5 15 0.25 0,+              fastModeCost = Nothing,+              pricingPolicy = Nothing,               contextWindow = 1050000,-              maxOutputTokens = 128000+              maxOutputTokens = 128000,+              apiOverride = Nothing,+              compat = Nothing             }         ]     } +-- | Expected Anthropic catalog after normalization. The one fixture+-- model carries the generation facts curated in 'anthropicInclude':+-- the budget thinking shape, sampling parameters accepted.+expectedAnthropic :: Catalog+expectedAnthropic =+  Catalog+    { provider = "anthropic",+      baseUrl = "https://api.anthropic.com",+      api = "anthropic-messages",+      models =+        [ CatalogModel+            { modelId = "claude-opus-4-5",+              name = "Claude Opus 4.5",+              reasoning = True,+              input = [InputText, InputImage],+              cost = CatalogCost 5 25 1.5 6.25,+              fastModeCost = Nothing,+              pricingPolicy = Nothing,+              contextWindow = 200000,+              maxOutputTokens = 64000,+              apiOverride = Nothing,+              compat =+                Just+                  ( CatalogAnthropicCompat+                      ( AnthropicGenerationFacts+                          { thinkingStyle = AnthropicThinkingBudget,+                            supportsSamplingParameters = True,+                            supportsForcedToolChoice = True,+                            fastModeCost = Nothing+                          }+                      )+                  )+            }+        ]+    }+ tests :: TestTree tests =   testGroup     "Baikai.FetchModels"-    [ testCase "OpenAI normalization filters, curates, and maps fields" $ do+    [ testCase "per-model API and Responses compat survive normalization and rendering" $ do         upstream <- loadUpstream+        let spec =+              openaiSpec+                & #apiFor+                .~ (\mid -> if mid == "gpt-5.4" then Just "openai-responses" else Nothing)+                & #compatFor+                .~ (\mid -> if mid == "gpt-5.4" then Just (CatalogResponsesCompat defaultOpenAIResponsesCompat) else Nothing)+            refreshed = catalogFor upstream spec+            raw = renderCatalog refreshed+        map (^. #apiOverride) (refreshed ^. #models) @?= [Nothing, Just "openai-responses"]+        case Aeson.eitherDecode (BSL.fromStrict raw) of+          Left err -> assertFailure err+          Right catalog -> do+            let generated = Gen.renderModule (Gen.flattenEntries catalog)+            assertBool "generator reads the rendered override" ("api = OpenAIResponses" `Text.isInfixOf` generated)+            assertBool "generator keeps the inherited default" ("api = OpenAIChatCompletions" `Text.isInfixOf` generated)++        case Aeson.eitherDecode (BSL.fromStrict raw) of+          Right (Aeson.Object root) -> case KeyMap.lookup "models" root of+            Just (Aeson.Array entries) -> case V.toList entries of+              [Aeson.Object legacy, Aeson.Object native] -> do+                KeyMap.lookup "api" legacy @?= Nothing+                KeyMap.lookup "api" native @?= Just (Aeson.String "openai-responses")+                case KeyMap.lookup "compat" native of+                  Just (Aeson.Object facts) -> KeyMap.lookup "kind" facts @?= Just (Aeson.String "openai-responses")+                  _ -> assertFailure "missing Responses compat"+              _ -> assertFailure "wrong entries"+            _ -> assertFailure "missing models"+          _ -> assertFailure "invalid rendered catalog",+      testCase "refresh preserves Astra endpoint restrictions despite upstream tool support" $ do+        upstream <- loadUpstream+        let sample = (upstream Map.! "openai") Map.! "gpt-5.4"+            astra = sample & #modelId .~ "gpt-6-astra"+            refreshed = normalizeProvider openaiSpec (Map.singleton "gpt-6-astra" astra)+            expected = Map.lookup "gpt-6-astra" openaiInclude >>= id+        map (^. #apiOverride) (refreshed ^. #models) @?= [Just "openai-responses"]+        map (^. #compat) (refreshed ^. #models) @?= [expected]+        assertBool "explicit compat survives rendering" ("openai-responses" `Text.isInfixOf` decodeUtf8 (renderCatalog refreshed)),+      testCase "fast rates and capability survive fetch and generator on exactly two curated models" $ do+        upstream <- loadUpstream+        let sample = (upstream Map.! "openai") Map.! "gpt-5.4"+        forM_ (Map.keys anthropicInclude) $ \mid -> do+          let refreshed = normalizeProvider anthropicSpec (Map.singleton mid (sample & #modelId .~ mid))+              expected = if mid `elem` ["claude-opus-5", "claude-opus-4-8"] then Just (CatalogCost 10 50 1 12.5) else Nothing+          map (^. #fastModeCost) (refreshed ^. #models) @?= [expected]+          case Aeson.eitherDecode (BSL.fromStrict (renderCatalog refreshed)) of+            Left err -> assertFailure err+            Right catalog -> Gen.checkAnthropicCompat (Gen.flattenEntries catalog) @?= Right (),+      testCase "curated pricing survives fetch rendering and generator parsing" $ do+        upstream <- loadUpstream+        let sample = (upstream Map.! "openai") Map.! "gpt-5.4"+        forM_ [(openaiSpec, "gpt-6-astra", Model.PricingPolicy [Model.InputPriceTier 272000 (Model.ModelCost 20 75 2 25)] Nothing), (anthropicSpec, "claude-fable-5-1", Model.PricingPolicy [] (Just 20))] $ \(spec, mid, policy) -> do+          let refreshed = normalizeProvider spec (Map.singleton mid (sample & #modelId .~ mid))+          map (^. #pricingPolicy) (refreshed ^. #models) @?= [Just policy]+          case Aeson.eitherDecode (BSL.fromStrict (renderCatalog refreshed)) of+            Left err -> assertFailure err+            Right catalog -> map (Gen.pricingPolicy . snd) (Gen.flattenEntries catalog) @?= [Just policy],+      testCase "OpenAI normalization filters, curates, and maps fields" $ do+        upstream <- loadUpstream         catalogFor upstream openaiSpec @?= expectedOpenAI,       testCase "tool_call: false model is excluded" $ do         upstream <- loadUpstream@@ -123,8 +229,12 @@                           reasoning = False,                           input = [InputText],                           cost = CatalogCost 0 0 0 0,+                          fastModeCost = Nothing,+                          pricingPolicy = Nothing,                           contextWindow = 1,-                          maxOutputTokens = 1+                          maxOutputTokens = 1,+                          apiOverride = Nothing,+                          compat = Nothing                         }                     ]                 }@@ -147,6 +257,31 @@         upstream <- loadUpstream         let ids = map (^. #modelId) (catalogFor upstream anthropicSpec ^. #models)         ids @?= ["claude-opus-4-5"],+      testCase "Anthropic normalization carries the curated generation facts" $ do+        upstream <- loadUpstream+        catalogFor upstream anthropicSpec @?= expectedAnthropic,+      testCase "the generation facts render as a per-model compat block" $ do+        upstream <- loadUpstream+        let rendered = renderText (catalogFor upstream anthropicSpec)+        assertBool+          "compat block rendered"+          ( Text.unlines+              [ "      \"compat\": {",+                "        \"kind\": \"anthropic-messages\",",+                "        \"thinkingStyle\": \"budget\",",+                "        \"supportsSamplingParameters\": true,",+                "        \"supportsFastMode\": false,",+                "        \"supportsForcedToolChoice\": true",+                "      },"+              ]+              `Text.isInfixOf` rendered+          ),+      testCase "an OpenAI model renders no compat block" $ do+        upstream <- loadUpstream+        let rendered = renderText (catalogFor upstream openaiSpec)+        assertBool+          "no per-model compat block (the file-level \"compat\": \"auto\" stays)"+          (not ("\"compat\": {" `Text.isInfixOf` rendered)),       testCase "\" (latest)\" suffix is stripped from display names" $ do         upstream <- loadUpstream         let cat = catalogFor upstream anthropicSpec
test/GenModelsSpec.hs view
@@ -1,7 +1,16 @@ module GenModelsSpec (tests) where -import Baikai.Api (Api (OpenAIChatCompletions))+import Baikai.Api (Api (AnthropicMessages, OpenAIChatCompletions, OpenAIResponses))+import Baikai.Compat+  ( AnthropicThinkingStyle (AnthropicThinkingAdaptive),+    defaultAnthropicMessagesCompat,+    supportsFastMode,+    supportsSamplingParameters,+    thinkingStyle,+  ) import Baikai.Model (InputModality (InputText))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Text qualified as Text import GenModelsCore@@ -12,16 +21,92 @@ tests =   testGroup     "Baikai.GenModels"-    [ testCase "checkIdentifierCollisions rejects sanitized binding duplicates" $ do+    [ testCase "fast capability and rates must agree in both directions" $ do+        forM_ [(True, Nothing), (False, Just (CostEntry 10 50 1 12.5))] $ \(supported, rates) -> do+          let block = CatalogCompatAnthropic (defaultAnthropicMessagesCompat {supportsFastMode = supported})+              catalog = (anthropicCatalog CatalogCompatAuto (Just block)) {models = [(model "claude-x") {entryCompatOverride = Just block, entryFastModeCost = rates}]}+          case checkAnthropicCompat (flattenEntries catalog) of+            Left err -> assertBool "names model" ("claude-x" `Text.isInfixOf` err)+            Right () -> assertFailure "contradictory fast-mode catalog accepted",+      testCase "catalog rejects invalid policy thresholds and negative rates" $ do+        let cost n = Aeson.object ["input" Aeson..= (n :: Int), "output" Aeson..= (1 :: Int), "cacheRead" Aeson..= (0 :: Int), "cacheWrite" Aeson..= (0 :: Int)]+            tier n rate = Aeson.object ["inputAbove" Aeson..= (n :: Int), "rates" Aeson..= cost rate]+            policy tiers = Aeson.object ["inputTiers" Aeson..= tiers]+            entry p = Aeson.object ["id" Aeson..= ("test" :: Text), "name" Aeson..= ("Test" :: Text), "input" Aeson..= (["text"] :: [Text]), "cost" Aeson..= cost 1, "contextWindow" Aeson..= (1 :: Int), "maxOutputTokens" Aeson..= (1 :: Int), "pricingPolicy" Aeson..= p]+        forM_ [policy [Aeson.object ["inputAbove" Aeson..= (1 :: Int), "rates" Aeson..= Aeson.object ["input" Aeson..= (1 :: Int), "output" Aeson..= (1 :: Int)]]], policy [tier (-1) 1], policy [tier 1 1, tier 1 1], policy [tier 2 1, tier 1 1], policy [tier 1 (-1)], Aeson.object ["longCacheWriteCost" Aeson..= (-1 :: Int)]] $ \p ->+          case Aeson.fromJSON (entry p) :: Aeson.Result ModelEntry of+            Aeson.Error _ -> pure ()+            Aeson.Success _ -> assertFailure "invalid policy accepted",+      testCase "per-model API override changes only the selected binding" $ do+        let catalog = collisionCatalog {models = [model "legacy", (model "native") {entryApiOverride = Just OpenAIResponses}]}+            rendered = renderModule (flattenEntries catalog)+        assertBool "legacy inherits file API" ("api = OpenAIChatCompletions" `Text.isInfixOf` rendered)+        assertBool "native overrides API" ("api = OpenAIResponses" `Text.isInfixOf` rendered),+      testCase "Responses catalog compat parses and renders all endpoint facts" $ do+        let raw = Aeson.object ["kind" Aeson..= ("openai-responses" :: Text), "supportsSamplingParameters" Aeson..= False, "supportsLongCacheRetention" Aeson..= False, "supportsPromptCacheOptions" Aeson..= True, "supportedReasoningEfforts" Aeson..= (["low", "max"] :: [Text])]+        case Aeson.fromJSON raw of+          Aeson.Error err -> assertFailure err+          Aeson.Success block -> do+            let rendered = renderModule (flattenEntries collisionCatalog {models = [(model "native") {entryApiOverride = Just OpenAIResponses, entryCompatOverride = Just block}]})+            mapM_ (\expected -> assertBool (Text.unpack expected) (expected `Text.isInfixOf` rendered)) ["CompatOpenAIResponses", "supportsPromptCacheOptions = True", "supportsLongCacheRetention = False", "supportsSamplingParameters = False", "Just [ThinkingLow, ThinkingMax]"],+      testCase "OpenAI effort policy rejects empty, duplicate, unordered and unknown levels" $+        mapM_+          ( \levels ->+              case Aeson.fromJSON (Aeson.object ["kind" Aeson..= ("openai-completions" :: Text), "supportedReasoningEfforts" Aeson..= levels]) :: Aeson.Result CatalogCompat of+                Aeson.Error _ -> pure ()+                Aeson.Success _ -> assertFailure "invalid effort policy accepted"+          )+          ([[], ["low", "low"], ["high", "low"], ["unknown"]] :: [[Text]]),+      testCase "checkIdentifierCollisions rejects sanitized binding duplicates" $ do         let entries = flattenEntries collisionCatalog         case checkIdentifierCollisions entries of           Right () -> assertFailure "expected duplicate generated identifier to be rejected"           Left err -> do             assertBool "mentions duplicate identifier" ("openai_a_b" `Text.isInfixOf` err)             assertBool "mentions first origin" ("openai/a-b" `Text.isInfixOf` err)-            assertBool "mentions second origin" ("openai/a_b" `Text.isInfixOf` err)+            assertBool "mentions second origin" ("openai/a_b" `Text.isInfixOf` err),+      testCase "checkAnthropicCompat rejects an entry left at compat auto" $ do+        let entries = flattenEntries (anthropicCatalog CatalogCompatAuto Nothing)+        case checkAnthropicCompat entries of+          Right () ->+            assertFailure+              "expected an anthropic-messages entry with no compat block to be rejected"+          Left err -> do+            assertBool "names the entry" ("anthropic/claude-x" `Text.isInfixOf` err)+            assertBool "names the fix" ("thinkingStyle" `Text.isInfixOf` err)+            assertBool+              "names the sampling field"+              ("supportsSamplingParameters" `Text.isInfixOf` err),+      testCase "checkAnthropicCompat accepts an entry that states its facts" $ do+        let block =+              CatalogCompatAnthropic+                defaultAnthropicMessagesCompat+                  { thinkingStyle = AnthropicThinkingAdaptive,+                    supportsSamplingParameters = False+                  }+            entries = flattenEntries (anthropicCatalog CatalogCompatAuto (Just block))+        case checkAnthropicCompat entries of+          Right () -> pure ()+          Left err -> assertFailure ("unexpected rejection: " <> Text.unpack err),+      testCase "checkAnthropicCompat ignores an OpenAI catalog" $ do+        case checkAnthropicCompat (flattenEntries collisionCatalog) of+          Right () -> pure ()+          Left err -> assertFailure ("unexpected rejection: " <> Text.unpack err)     ] +-- | A one-model @anthropic-messages@ catalog, with the file-level+-- compat directive and the per-model override both under the caller's+-- control.+anthropicCatalog :: CatalogCompat -> Maybe CatalogCompat -> CatalogFile+anthropicCatalog fileCompat override =+  CatalogFile+    { provider = "anthropic",+      baseUrl = "https://api.anthropic.com",+      api = AnthropicMessages,+      compat = fileCompat,+      models = [(model "claude-x") {entryCompatOverride = override}]+    }+ collisionCatalog :: CatalogFile collisionCatalog =   CatalogFile@@ -49,8 +134,11 @@             costCacheRead = 0,             costCacheWrite = 0           },+      entryFastModeCost = Nothing,+      entryPricingPolicy = Nothing,       entryContextWindow = 1,       entryMaxOutputTokens = 1,       entryEnabled = True,+      entryApiOverride = Nothing,       entryCompatOverride = Nothing     }
test/HelpersSpec.hs view
@@ -5,6 +5,8 @@ import Control.Exception qualified as Exception import Data.Aeson qualified as Aeson import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Map.Strict qualified as Map+import Data.Maybe (isJust) import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as Vector@@ -33,7 +35,36 @@ tests =   testGroup     "Baikai helpers"-    [ testCase "runToolLoop resolves repeated tool turns and leaves final response separate" $ do+    [ -- The registry keys on 'normaliseApi' of the tag, at registration+      -- and at lookup, so the two spellings of a built-in API are one+      -- entry rather than two that dispatch by whichever the model used.+      testCase "a handler registered under a Custom spelling answers the built-in tag" $ do+        reg <- newProviderRegistryFrom [oneShotProvider (Custom "anthropic-messages") "spelled custom"]+        found <- lookupApiProviderWith reg AnthropicMessages+        assertBool "AnthropicMessages finds the Custom-spelled handler" (isJust found),+      testCase "a handler registered under the built-in tag answers a Custom spelling" $ do+        reg <- newProviderRegistryFrom [oneShotProvider AnthropicMessages "spelled built-in"]+        found <- lookupApiProviderWith reg (Custom "anthropic-messages")+        assertBool "Custom \"anthropic-messages\" finds the built-in handler" (isJust found),+      -- A header name is case-insensitive on the wire, so a map keyed+      -- on 'HeaderName' must hold one entry for two spellings rather+      -- than two entries whose winner depends on Map order.+      testCase "two spellings of one header name are one map entry" $ do+        let hs = Map.fromList [("Authorization", "a"), ("authorization", "b")] :: Map.Map HeaderName Text+        Map.size hs @?= 1+        Map.lookup "AUTHORIZATION" hs @?= Just "b",+      -- 'emptyModel' carries @Custom ""@, which used to render as nothing+      -- at all: "No provider registered for API: " with an empty tail.+      testCase "dispatching emptyModel names emptyModel rather than nothing" $ do+        reg <- newProviderRegistry+        resp <- completeRequestWith reg emptyModel emptyContext emptyOptions+        case responseError resp of+          Nothing -> assertFailure "expected a ProviderUnavailable response"+          Just err ->+            assertBool+              ("expected the blank-tag hint, got: " <> Text.unpack (err ^. #message))+              ("blank Custom tag" `Text.isInfixOf` (err ^. #message)),+      testCase "runToolLoop resolves repeated tool turns and leaves final response separate" $ do         scripted <- newScripted [toolUseResponse "call_1" "get_time", toolUseResponse "call_2" "get_time", textResponse "done"] []         let ctx0 = addUser "start" emptyContext             dispatcher _ = pure (toolResultText "2026-06-05T00:00:00Z")@@ -139,6 +170,71 @@                 assertBool "message should include first name" (Text.pack first `Text.isInfixOf` (err ^. #message))                 assertBool "message should include second name" (Text.pack second `Text.isInfixOf` (err ^. #message))               Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key),+      testCase "ApiKeyEnv rejects a variable set to the empty string" $ do+        -- An empty key can never authenticate. Reporting it here, by+        -- name, beats sending "Authorization: Bearer " and reading a+        -- provider's 401 back.+        let name = "BAIKAI_HELPERS_EMPTY_KEY"+        withUnsetEnv name $ do+          Environment.setEnv name ""+          thrown <- Exception.try (resolveApiKey (ApiKeyEnv name)) :: IO (Either BaikaiError Text)+          case thrown of+            Left err -> do+              err ^. #category @?= AuthError+              assertBool+                ("message should name the variable: " <> Text.unpack (err ^. #message))+                (Text.pack name `Text.isInfixOf` (err ^. #message))+              assertBool+                ("message should say it is empty: " <> Text.unpack (err ^. #message))+                ("empty" `Text.isInfixOf` (err ^. #message))+            Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key),+      testCase "ApiKeyEnv rejects a whitespace-only variable" $ do+        let name = "BAIKAI_HELPERS_BLANK_KEY"+        withUnsetEnv name $ do+          Environment.setEnv name "   "+          thrown <- Exception.try (resolveApiKey (ApiKeyEnv name)) :: IO (Either BaikaiError Text)+          case thrown of+            Left err -> err ^. #category @?= AuthError+            Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key),+      testCase "ApiKeyEnv passes a real value through untrimmed" $ do+        -- Only a blank value counts as unset. Trimming a real key would+        -- be a second, unrelated behaviour change, and one that could+        -- break a key whose edge character matters.+        let name = "BAIKAI_HELPERS_PADDED_KEY"+        withUnsetEnv name $ do+          Environment.setEnv name " sk-padded "+          resolved <- resolveApiKey (ApiKeyEnv name)+          resolved @?= " sk-padded ",+      testCase "ApiKeyEnvChain skips a variable set to the empty string" $ do+        let first = "BAIKAI_HELPERS_CHAIN_EMPTY_A"+            second = "BAIKAI_HELPERS_CHAIN_EMPTY_B"+        withUnsetEnv first $+          withUnsetEnv second $ do+            Environment.setEnv first ""+            Environment.setEnv second "second-key"+            resolved <- resolveApiKey (ApiKeyEnvChain [first, second])+            resolved @?= "second-key",+      testCase "ApiKeyEnvChain reports every name when all are empty" $ do+        let first = "BAIKAI_HELPERS_CHAIN_ALL_EMPTY_A"+            second = "BAIKAI_HELPERS_CHAIN_ALL_EMPTY_B"+        withUnsetEnv first $+          withUnsetEnv second $ do+            Environment.setEnv first ""+            Environment.setEnv second ""+            thrown <- Exception.try (resolveApiKey (ApiKeyEnvChain [first, second])) :: IO (Either BaikaiError Text)+            case thrown of+              Left err -> do+                err ^. #category @?= AuthError+                assertBool+                  "message should include first name"+                  (Text.pack first `Text.isInfixOf` (err ^. #message))+                assertBool+                  "message should include second name"+                  (Text.pack second `Text.isInfixOf` (err ^. #message))+                assertBool+                  ("message should explain that empty counts as unset: " <> Text.unpack (err ^. #message))+                  ("empty" `Text.isInfixOf` (err ^. #message))+              Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key),       testCase "mkModel fills dispatch discriminators and defaults" $ do         let model = mkModel OpenAIChatCompletions "gpt-test" "https://example.test"         model ^. #api @?= OpenAIChatCompletions@@ -177,11 +273,10 @@   responsesRef <- newIORef responses   callsRef <- newIORef 0   registerApiProviderWith reg $-    ApiProvider-      { apiTag = helpersApi,-        complete = scriptedComplete responsesRef callsRef,-        stream = \_ _ _ -> Stream.fromList events-      }+    apiProviderWith+      helpersApi+      (\_ _ _ -> Stream.fromList events)+      (scriptedComplete responsesRef callsRef)   pure Scripted {scriptRegistry = reg, scriptCallRef = callsRef}  scriptedComplete :: IORef [Response] -> IORef Int -> Model -> Context -> Options -> IO Response@@ -203,27 +298,25 @@ registerOneShot :: Api -> Response -> IO () registerOneShot apiTag resp =   registerApiProvider-    ApiProvider-      { apiTag,-        complete = \model _ctx _opts -> pure (stampModel model resp),-        stream = \_ _ _ -> Stream.fromList []-      }+    ( apiProviderWith+        apiTag+        (\_ _ _ -> Stream.fromList [])+        (\model _ctx _opts -> pure (stampModel model resp))+    )  oneShotProvider :: Api -> Text -> ApiProvider oneShotProvider apiTag body =-  ApiProvider-    { apiTag,-      complete = \model _ctx _opts -> pure (stampModel model (textResponse body)),-      stream = \_ _ _ -> Stream.fromList []-    }+  apiProviderWith+    apiTag+    (\_ _ _ -> Stream.fromList [])+    (\model _ctx _opts -> pure (stampModel model (textResponse body)))  errorProvider :: Api -> BaikaiError -> ApiProvider errorProvider apiTag err =-  ApiProvider-    { apiTag,-      complete = \model _ctx _opts -> pure (errorResponse model epoch 0 err),-      stream = \_ _ _ -> Stream.fromList []-    }+  apiProviderWith+    apiTag+    (\_ _ _ -> Stream.fromList [])+    (\model _ctx _opts -> pure (errorResponse model epoch 0 err))  stampModel :: Model -> Response -> Response stampModel model resp =@@ -321,7 +414,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
test/Main.hs view
@@ -1,34 +1,51 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+ module Main (main) where  import AgentAssetsSpec qualified+import AgentSpec qualified import Baikai import Baikai.Models.Generated import Baikai.Prelude import CatalogSpec qualified import CliInternalSpec qualified import ContextSpec qualified+import Control.Monad (forM_) import CostSpec qualified import Data.Aeson qualified as Aeson import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as LBS8+import Data.Kind (Type)+import Data.List (isInfixOf)+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..)) import Data.Text qualified as Text import Data.Vector qualified as V import EmbeddingSpec qualified import ErrorInfoSpec qualified import ErrorSpec qualified+import EvidenceSpec qualified import FetchModelsSpec qualified+import GHC.Generics (C1, D1, Rep, S1, Selector (selName), (:*:)) import GenModelsSpec qualified import HelpersSpec qualified import InteractiveSpec qualified+import PricingPolicySpec qualified+import PublicSurfaceSpec qualified import StreamSpec qualified+import StreamWorkerSpec 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, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import Test.Tasty.QuickCheck (Gen) import Test.Tasty.QuickCheck qualified as QC import ThinkingLevelSpec qualified import TraceSpec qualified+import TransportClassifySpec qualified+import UrlSpec qualified import UsageSpec qualified  -- | Ground the test provider on a 'Custom' API tag so it does not@@ -75,11 +92,11 @@             .~ testApi             & #provider             .~ providerName-   in ApiProvider-        { apiTag = testApi,-          stream = liftCompleteToStream handler,-          complete = handler-        }+   in ( apiProviderWith+          testApi+          (liftCompleteToStream handler)+          (handler)+      )  main :: IO () main = do@@ -89,6 +106,7 @@       "baikai"       [ tests,         AgentAssetsSpec.tests,+        AgentSpec.tests,         CatalogSpec.tests,         CliInternalSpec.tests,         ContextSpec.tests,@@ -96,21 +114,28 @@         EmbeddingSpec.tests,         ErrorInfoSpec.tests,         ErrorSpec.tests,+        EvidenceSpec.tests,         FetchModelsSpec.tests,         GenModelsSpec.tests,         HelpersSpec.tests,         InteractiveSpec.tests,+        PricingPolicySpec.tests,+        PublicSurfaceSpec.tests,         StreamSpec.tests,+        StreamWorkerSpec.tests,+        StrictEvidenceSpec.tests,         SurfaceSpec.tests,         ThinkingLevelSpec.tests,         TraceSpec.tests,+        TransportClassifySpec.tests,+        UrlSpec.urlTests,         UsageSpec.tests       ]  tests :: TestTree tests =   testGroup-    "baikai EP-2"+    "baikai core"     [ testCase "emptyContext defaults are zero-y" $ do         emptyContext ^. #systemPrompt @?= Nothing         V.length (emptyContext ^. #messages) @?= 0,@@ -126,9 +151,25 @@               Aeson.object                 [ "type" Aeson..= ("object" :: Text)                 ]-            schemaFmt = JsonSchema {name = "person", schema = person, strict = True}+            schemaFmt = JsonSchema (jsonSchemaFormat "person" person) {strict = True}         responseFormat (emptyOptions & #responseFormat .~ Just schemaFmt)           @?= Just schemaFmt,+      -- The wire shape is pinned, not merely round-tripped: 'Options'+      -- derives 'ToJSON' through it and at least one consumer keys a+      -- cache on the result, so moving the three fields onto+      -- 'JsonSchemaFormat' must not move them in JSON.+      testCase "ResponseFormat keeps its flat JSON encoding" $ do+        Aeson.toJSON (JsonSchema (jsonSchemaFormat "o" Aeson.Null))+          @?= Aeson.object+            [ "tag" Aeson..= ("JsonSchema" :: Text),+              "name" Aeson..= ("o" :: Text),+              "schema" Aeson..= Aeson.Null,+              "strict" Aeson..= False+            ]+        Aeson.toJSON JsonObject @?= Aeson.object ["tag" Aeson..= ("JsonObject" :: Text)]+        let strictFmt = JsonSchema (jsonSchemaFormat "o" Aeson.Null) {strict = True}+        Aeson.decode (Aeson.encode strictFmt) @?= Just strictFmt+        Aeson.decode (Aeson.encode JsonObject) @?= Just JsonObject,       testCase "Options Show redacts literal API keys" $ do         let secret = "sk-baikai-secret-never-print"             opts = emptyOptions & #apiKey .~ Just (ApiKeyLiteral secret)@@ -141,6 +182,63 @@         assertBool           "Aeson.encode opts must not contain the raw API key"           (not (secret `Text.isInfixOf` Text.pack (LBS8.unpack (Aeson.encode opts)))),+      testCase "Options Show and JSON redact credential headers" $ do+        -- Options.headers is documented as the place to put a gateway's+        -- own Authorization header, and the guides tell people to print+        -- a response. Both of those are fine; printing the credential+        -- is not.+        let opts = emptyOptions & #headers .~ credentialHeaders+            shown = Text.pack (show opts)+            encoded = Text.pack (LBS8.unpack (Aeson.encode opts))+        forM_ [shown, encoded] $ \rendered -> do+          assertBool+            ("the bearer token must not appear: " <> Text.unpack rendered)+            (not ("sk-live-secret" `Text.isInfixOf` rendered))+          assertBool+            ("the subscription key must not appear: " <> Text.unpack rendered)+            (not ("azure-secret" `Text.isInfixOf` rendered))+          assertBool+            ("an ordinary header still appears: " <> Text.unpack rendered)+            ("my app" `Text.isInfixOf` rendered)+          Text.count redactedMarker rendered @?= 2+        -- Redaction is about rendering, never about the value.+        Map.lookup "Authorization" (opts ^. #headers)+          @?= Just "Bearer sk-live-secret",+      testCase "Model and Response Show redact credential headers" $ do+        -- A Model is embedded in every Response, so `print resp` is the+        -- likeliest way a credential reaches a log.+        let m = emptyModel & #headers .~ credentialHeaders+            resp = emptyResponse & #model .~ m+        forM_ [Text.pack (show m), Text.pack (show resp)] $ \rendered -> do+          assertBool+            ("the bearer token must not appear: " <> Text.unpack rendered)+            (not ("sk-live-secret" `Text.isInfixOf` rendered))+          assertBool+            ("the redaction marker appears: " <> Text.unpack rendered)+            (redactedMarker `Text.isInfixOf` rendered),+      testCase "a Model round-tripped through JSON carries the marker, not the key" $ do+        -- Deliberately lossy: a serialised Model is exactly the thing+        -- that should not carry a key.+        let m = emptyModel & #headers .~ credentialHeaders+        case Aeson.decode (Aeson.encode m) :: Maybe Model of+          Nothing -> assertFailure "a redacted Model must still parse"+          Just decoded -> do+            Map.lookup "Authorization" (decoded ^. #headers) @?= Just redactedMarker+            Map.lookup "X-Title" (decoded ^. #headers) @?= Just "my app",+      testCase "Options and Model Show list every field" $ do+        -- The drift guard for the two hand-written Show instances: a+        -- field added later must fail here rather than quietly vanish+        -- from `show`.+        let shownOptions = show emptyOptions+            shownModel = show emptyModel+        forM_ (fieldNames @Options) $ \name ->+          assertBool+            ("Options Show omits the field " <> name)+            ((name <> " = ") `isInfixOf` shownOptions)+        forM_ (fieldNames @Model) $ \name ->+          assertBool+            ("Model Show omits the field " <> name)+            ((name <> " = ") `isInfixOf` shownModel),       testCase "completeRequest dispatches through the registered handler" $ do         let ctx = emptyContext & #messages .~ V.fromList [user "ping"]         resp <- completeRequest testModel ctx emptyOptions@@ -197,12 +295,24 @@           ^. #thinkingFormat           @?= ThinkingFormatOpenRouter         autoDetectOpenAICompletions ""-          @?= defaultOpenAICompletionsCompat,+          @?= defaultOpenAICompletionsCompat+        -- An "@" after the authority names nothing. A parser that took+        -- the text after the last "@" anywhere would hand a proxy the+        -- vendor's own compatibility record, and then its key.+        autoDetectOpenAICompletions "https://proxy.example.com/v1?u=@api.deepseek.com"+          @?= defaultOpenAICompletionsCompat+        urlHost "https://proxy.example.com/v1?u=@api.deepseek.com"+          @?= Just "proxy.example.com",       QC.testProperty "unknown OpenAI host suffixes use defaults" $         QC.forAll unknownHostGen $ \host ->           QC.property $             autoDetectOpenAICompletions ("https://" <> Text.pack host)               == defaultOpenAICompletionsCompat,+      QC.testProperty "no trailing @-suffix can rename a host" $+        QC.forAll ((,) <$> unknownHostGen <*> QC.elements atSuffixes) $ \(host, suffix) ->+          QC.property $+            urlHost ("https://" <> Text.pack host <> suffix)+              == Just (Text.pack host),       testCase "default API-key env table matches known hosts" $ do         defaultApiKeyEnvForBaseUrl "https://api.deepseek.com/v1"           @?= Just "DEEPSEEK_API_KEY"@@ -213,7 +323,20 @@         defaultApiKeyEnvForBaseUrl "https://api.xyz.ai"           @?= Nothing         defaultApiKeyEnvForBaseUrl ""-          @?= Nothing,+          @?= Nothing+        -- The credential-misdirection case. Every one of these named a+        -- known vendor host before the authority was bounded properly,+        -- so each resolved that vendor's key and sent it to the proxy.+        defaultApiKeyEnvForBaseUrl "https://proxy.example.com/v1?u=@api.openai.com"+          @?= Nothing+        defaultApiKeyEnvForBaseUrl "https://proxy.example.com?u=@api.anthropic.com"+          @?= Nothing+        defaultApiKeyEnvForBaseUrl "https://proxy.example.com#@api.deepseek.com"+          @?= Nothing+        -- And the benign case the same defect broke in the other+        -- direction: an "@" in the path is part of the path.+        defaultApiKeyEnvForBaseUrl "https://api.openai.com/v1/@x"+          @?= Just "OPENAI_API_KEY",       testCase "explicit OpenAI compat overrides baseUrl auto-detection" $ do         let explicit =               defaultOpenAICompletionsCompat@@ -242,32 +365,29 @@         compat ^. #supportsCacheControlOnTools @?= False         compat ^. #sendSessionAffinityHeaders @?= True         compat ^. #supportsLongCacheRetention @?= False-        compat ^. #thinkingStyle @?= AnthropicThinkingBudget,-      testCase "Anthropic compat defaults thinking style by model generation" $ do-        anthropicMessagesCompatFor anthropic_claude_opus_4_6-          ^. #thinkingStyle-          @?= AnthropicThinkingAdaptive-        anthropicMessagesCompatFor anthropic_claude_opus_4_7-          ^. #thinkingStyle-          @?= AnthropicThinkingAdaptive-        anthropicMessagesCompatFor anthropic_claude_opus_4_8-          ^. #thinkingStyle-          @?= AnthropicThinkingAdaptive-        anthropicMessagesCompatFor anthropic_claude_fable_5-          ^. #thinkingStyle-          @?= AnthropicThinkingAdaptive-        anthropicMessagesCompatFor anthropic_claude_haiku_4_5-          ^. #thinkingStyle-          @?= AnthropicThinkingBudget-        anthropicMessagesCompatFor anthropic_claude_opus_4_5-          ^. #thinkingStyle-          @?= AnthropicThinkingBudget-        anthropicMessagesCompatFor anthropic_claude_sonnet_4_5-          ^. #thinkingStyle-          @?= AnthropicThinkingBudget-        anthropicMessagesCompatFor anthropic_claude_sonnet_4_6-          ^. #thinkingStyle-          @?= AnthropicThinkingBudget,+        compat ^. #thinkingStyle @?= AnthropicThinkingBudget+        compat ^. #supportsSamplingParameters @?= True,+      testCase "Anthropic catalog compat records carry thinking style and sampling support" $ do+        let facts m =+              let c = anthropicMessagesCompatFor m+               in (c ^. #thinkingStyle, c ^. #supportsSamplingParameters)+        facts anthropic_claude_fable_5 @?= (AnthropicThinkingAdaptive, False)+        facts anthropic_claude_haiku_4_5 @?= (AnthropicThinkingBudget, True)+        facts anthropic_claude_opus_4_5 @?= (AnthropicThinkingBudget, True)+        facts anthropic_claude_opus_4_6 @?= (AnthropicThinkingAdaptive, True)+        facts anthropic_claude_opus_4_7 @?= (AnthropicThinkingAdaptive, False)+        facts anthropic_claude_opus_4_8 @?= (AnthropicThinkingAdaptive, False)+        facts anthropic_claude_sonnet_4_5 @?= (AnthropicThinkingBudget, True)+        facts anthropic_claude_sonnet_4_6 @?= (AnthropicThinkingAdaptive, True)+        facts anthropic_claude_sonnet_5 @?= (AnthropicThinkingAdaptive, False),+      testCase "a hand-rolled Anthropic model with CompatNone gets budget style and sampling supported" $ do+        -- The model id names an adaptive-era generation, but nothing+        -- reads it: a generation's wire facts are a field of the+        -- catalog record, and a hand-rolled model carries none.+        let handRolled = mkModel AnthropicMessages "claude-sonnet-5" ""+            compat = anthropicMessagesCompatFor handRolled+        compat ^. #thinkingStyle @?= AnthropicThinkingBudget+        compat ^. #supportsSamplingParameters @?= True,       testCase "user smart constructor produces a UserMessage" $ do         let ts = read "2026-06-05 01:02:03 UTC"         case userAt ts "hello" of@@ -359,3 +479,50 @@ unknownHostGen = do   label <- QC.listOf1 (QC.elements (['a' .. 'z'] <> ['0' .. '9']))   pure (label <> ".example.invalid")++-- | A header map with two credential-carrying names, spelled the way a+-- gateway would, and one ordinary header that must survive redaction.+credentialHeaders :: Map.Map HeaderName Text+credentialHeaders =+  Map.fromList+    [ ("Authorization", "Bearer sk-live-secret"),+      ("X-Title", "my app"),+      ("Ocp-Apim-Subscription-Key", "azure-secret")+    ]++-- | The record field names of a type, read off its 'Generic'+-- representation.+--+-- This exists to guard the two hand-written 'Show' instances on+-- 'Options' and 'Model': they list their fields by hand, so a field+-- added later would silently stop being printed. Asking the compiler+-- what the fields actually are turns that into a test failure that names+-- the missing one.+class GFieldNames (f :: Type -> Type) where+  gFieldNames :: Proxy f -> [String]++instance (GFieldNames f) => GFieldNames (D1 m f) where+  gFieldNames _ = gFieldNames (Proxy @f)++instance (GFieldNames f) => GFieldNames (C1 m f) where+  gFieldNames _ = gFieldNames (Proxy @f)++instance (GFieldNames f, GFieldNames g) => GFieldNames (f :*: g) where+  gFieldNames _ = gFieldNames (Proxy @f) <> gFieldNames (Proxy @g)++instance (Selector m) => GFieldNames (S1 m f) where+  gFieldNames _ = [selName (undefined :: S1 m f ())]++fieldNames :: forall a. (GFieldNames (Rep a)) => [String]+fieldNames = gFieldNames (Proxy @(Rep a))++-- | Ways of writing another provider's host after the authority ends.+-- None of them may change which host a URL names, because which host a+-- URL names is which key baikai sends.+atSuffixes :: [Text]+atSuffixes =+  [ "/v1?u=@api.openai.com",+    "/@api.anthropic.com",+    "?x=@api.deepseek.com",+    "#@openrouter.ai"+  ]
+ test/PricingPolicySpec.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE OverloadedRecordDot #-}++module PricingPolicySpec (tests) where++import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Cost qualified as C+import Baikai.Cost.Pricing (computeCost, computeCostAtRates, computeCostForService, computeCostWith, resolveRates)+import Baikai.Evidence qualified as Ev+import Baikai.Model qualified as M+import Baikai.Models.Generated qualified as Models+import Baikai.Usage qualified as U+import Baikai.Usage.Normalize qualified as N+import Control.Lens ((&), (.~))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Set qualified as Set+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Pricing policy"+    [ testCase "requested tiers never substitute for observed service" $ do+        let unknown = N.normalizeUsage N.InclusiveInput (N.ReportedUsage (Just 1000) (Just 0) (Just 0) (Just 0) Nothing)+            standard = U.observeBilling [U.BillingServiceTier "default"] unknown+            priority = U.observeBilling [U.BillingServiceTier "priority"] unknown+        (computeCostForService Nothing (Just "default") astra unknown).basis.estimateReasons @?= Set.singleton C.ServiceTierNotReported+        (computeCostForService Nothing (Just "default") astra standard).basis.estimateReasons @?= Set.empty+        (computeCostForService Nothing (Just "default") astra priority).basis.estimateReasons @?= Set.fromList [C.UnsupportedServiceTier "priority", C.ServiceTierMismatch "default" "priority"]+        assertBool "observed tier joins commitment" (Ev.usageEnvelope standard /= Ev.usageEnvelope priority),+      testCase "standard-only matches observed standard and fast remains an explicit estimate" $ do+        let u = N.normalizeUsage N.ExclusiveInput (N.ReportedUsage (Just 1000) (Just 0) (Just 0) (Just 0) Nothing)+            standard = U.observeBilling [U.BillingServiceTier "standard", U.BillingSpeed "standard"] u+            fast = U.observeBilling [U.BillingServiceTier "standard", U.BillingSpeed "fast"] u+        (computeCostForService Nothing (Just "standard_only") fable standard).basis.estimateReasons @?= Set.empty+        (computeCostForService Nothing Nothing fable fast).basis.estimateReasons @?= Set.singleton (C.UnsupportedSpeed "fast")+        (computeCostForService Nothing Nothing fable fast).usd @?= (computeCost fable u).usd,+      testCase "server-side tool products are explicitly outside token charges" $ do+        let u = U.observeBilling [U.BillingServiceTier "standard", U.BillingServerToolUse] (U.zeroUsage & #inputTokens .~ 1000)+        (computeCostForService Nothing Nothing fable u).basis.estimateReasons @?= Set.singleton C.AdditionalChargesExcluded,+      testCase "resolved rate seam prices a speed policy exactly once" $ do+        let u = U.zeroUsage & #inputTokens .~ 1000 & #outputTokens .~ 100+            doubled = M.ModelCost 20 100 2 25+            selected = computeCostAtRates doubled u+        selected.usd @?= 2 * (computeCost astra u).usd+        selected.basis.sources @?= Set.singleton C.ResolvedTokenRates,+      testCase "legacy availability JSON preserves its encoding without billing facts" $ do+        let old = Aeson.object ["missing_categories" Aeson..= ([] :: [U.UsageCategory]), "inconsistent" Aeson..= False]+        case Aeson.fromJSON old of+          Aeson.Success facts -> Aeson.toJSON (facts :: U.UsageAvailability) @?= old+          Aeson.Error err -> assertFailure err,+      testCase "context thresholds are exclusive and price the whole request" $+        forM_ [(271999, base), (272000, base), (272001, high)] $ \(n, expectedRates) -> do+          let u = U.zeroUsage & #inputTokens .~ n & #outputTokens .~ 100+          resolveRates Nothing astra u @?= Right expectedRates+          (computeCost astra u).usd @?= (fromIntegral n * expectedRates.inputCost + 100 * expectedRates.outputCost) / 1000000,+      testCase "272001 input plus 100 output costs exactly 5.44752" $+        (computeCost astra (U.zeroUsage & #inputTokens .~ 272001 & #outputTokens .~ 100)).usd @?= 544752 / 100000,+      testCase "cache reads and writes both contribute to context threshold" $ do+        forM_ [U.zeroUsage & #inputTokens .~ 272000 & #cacheReadTokens .~ 1, U.zeroUsage & #inputTokens .~ 272000 & #cacheWriteTokens .~ 1] $ \u -> resolveRates Nothing astra u @?= Right high+        resolveRates Nothing astra (U.zeroUsage & #cacheReadTokens .~ 136000 & #cacheWriteTokens .~ 136000) @?= Right base,+      testCase "Fable cache reads and shaped write duration use exact rates" $ do+        (computeCost fable (U.zeroUsage & #cacheReadTokens .~ 1000)).usd @?= 1 / 4000+        (computeCostWith (Just CacheRetentionShort) fable (U.zeroUsage & #cacheWriteTokens .~ 1000)).usd @?= 1 / 80+        (computeCostWith (Just CacheRetentionLong) fable (U.zeroUsage & #cacheWriteTokens .~ 1000)).usd @?= 1 / 50,+      testCase "reasoning is a subset of output, not an extra charge" $ do+        let u = U.zeroUsage & #outputTokens .~ 100+        computeCost astra (u & #reasoningTokens .~ Just 75) @?= computeCost astra u,+      testCase "flat policies retain base calculations" $ do+        let flat = astra & #pricingPolicy .~ Nothing+        resolveRates (Just CacheRetentionLong) flat (U.zeroUsage & #inputTokens .~ 900000) @?= Right base,+      testCase "duplicate, unordered and negative policy data are rejected" $ do+        forM_ [M.PricingPolicy [M.InputPriceTier 2 high, M.InputPriceTier 2 base] Nothing, M.PricingPolicy [M.InputPriceTier 2 high, M.InputPriceTier 1 base] Nothing, M.PricingPolicy [] (Just (-1)), M.PricingPolicy [M.InputPriceTier 1 (base & #inputCost .~ (-1))] Nothing] $ \p -> do+          assertBool "pure validation rejects" (case M.validatePricingPolicy p of Left _ -> True; _ -> False)+          case Aeson.fromJSON (Aeson.toJSON p) :: Aeson.Result M.PricingPolicy of Aeson.Error _ -> pure (); _ -> assertFailure "invalid policy decoded"+        let negative = Aeson.object ["inputTiers" Aeson..= [Aeson.object ["inputAbove" Aeson..= (-1 :: Int), "rates" Aeson..= base]]]+        case Aeson.fromJSON negative :: Aeson.Result M.PricingPolicy of Aeson.Error _ -> pure (); _ -> assertFailure "negative threshold decoded",+      testCase "old model JSON without a policy decodes and new policy round trips" $ do+        let old = case Aeson.toJSON M.emptyModel of Aeson.Object o -> Aeson.Object (KM.delete "pricingPolicy" o); v -> v+        case Aeson.fromJSON old of Aeson.Success m -> (m :: M.Model).pricingPolicy @?= Nothing; Aeson.Error err -> assertFailure err+        case Aeson.fromJSON (Aeson.toJSON astra) of Aeson.Success m -> (m :: M.Model) @?= astra; Aeson.Error err -> assertFailure err,+      testCase "estimated components retain reasons and provenance when summed" $ do+        let known = computeCost fable (U.zeroUsage & #cacheReadTokens .~ 1000)+            missing = C.estimateCost [C.CacheWriteUsageNotReported] known+            unknown = C.estimateCost [C.ServiceTierNotReported, C.CacheWriteUsageNotReported] known+            total = known <> missing <> unknown+        total.usd @?= 3 * known.usd+        total.basis.estimateReasons @?= Set.fromList [C.CacheWriteUsageNotReported, C.ServiceTierNotReported]+        total.basis.sources @?= Set.singleton C.StandardTokenRates+        mempty <> total @?= total+        total <> mempty @?= total+        (known <> missing) <> unknown @?= known <> (missing <> unknown)+        case Aeson.fromJSON (Aeson.toJSON total.basis) of Aeson.Success decoded -> decoded @?= total.basis; Aeson.Error err -> assertFailure err,+      testCase "unavailable prices carry an explicit estimate reason" $+        (computeCost M.emptyModel (U.zeroUsage & #inputTokens .~ 50)).basis.estimateReasons @?= Set.singleton C.PricingUnavailable+    ]++base :: M.ModelCost+base = M.ModelCost 10 50 1 (25 / 2)++high :: M.ModelCost+high = M.ModelCost 20 75 2 25++astra :: M.Model+astra = Models.openai_gpt_6_astra++fable :: M.Model+fable = Models.anthropic_claude_fable_5_1
+ test/PublicSurfaceSpec.hs view
@@ -0,0 +1,99 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | A downstream consumer's view of baikai, compiled.+--+-- This module imports __only__ modules a published consumer can import:+-- no @Baikai.Prelude@, no @Control.Lens@, no generic-lens, no+-- @.Internal@ module. Everything it does, it does with record update,+-- plain selectors and the exported base values.+--+-- Its value is that it compiles. Plan 43 chose compile-time probes over+-- a golden @:browse@ dump, because a dump goes stale silently while a+-- module that sees what a downstream sees fails the build the moment a+-- name a consumer needs stops being exported — or the moment a record+-- can no longer be built without the constructor this release hid.+--+-- It exports one 'TestTree' so the suite runs the few facts that are+-- cheap to assert here; the compilation is the real test.+module PublicSurfaceSpec (tests) where++import Baikai+import Baikai.Cost.Log (CallLogConfig (enabled, path), callLogConfig)+import Baikai.Embedding qualified as Embedding+import Data.Aeson (Value (Null))+import Data.Aeson qualified as Aeson+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Vector qualified as V+import Streamly.Data.Stream qualified as Stream+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "public surface"+    [ testCase "Responses API and compatibility are public and serializable" $ do+        parseApi "openai-responses" @?= OpenAIResponses+        renderApi OpenAIResponses @?= "openai-responses"+        normaliseApi (Custom "openai-responses") @?= OpenAIResponses+        let model =+              (mkModel OpenAIResponses "probe" "https://api.openai.com")+                { compat = CompatOpenAIResponses defaultOpenAIResponsesCompat {supportsPromptCacheOptions = True}+                }+        (openaiResponsesCompatFor model).supportsPromptCacheOptions @?= True+        Aeson.fromJSON (Aeson.toJSON model) @?= Aeson.Success model,+      testCase "every hidden record is buildable with record update alone" $ do+        probeTool.name @?= "probe"+        probeLog.path @?= "/dev/null"+        probeLog.enabled @?= True+        Embedding.modelId probeEmbedding @?= "text-embedding-probe"+        headerCount @?= 1,+      testCase "a provider registered from apiProvider dispatches" $ do+        reg <- newProviderRegistryFrom [probeProvider]+        resp <- completeRequestWith reg probeModel probeContext probeOptions+        -- The stream is empty, so reassembly produces a response with no+        -- content and no error. What matters is that dispatch found the+        -- handler and that a consumer could build it.+        assertBool "the call produced no error" (responseError resp == Nothing)+    ]++-- | Built from 'apiProvider' — re-exported by the umbrella — not from a+-- constructor.+probeProvider :: ApiProvider+probeProvider = apiProvider (Custom "public-surface-probe") (\_ _ _ -> Stream.fromList [])++probeModel :: Model+probeModel =+  emptyModel+    { modelId = "probe-model",+      api = Custom "public-surface-probe",+      provider = "probe"+    }++probeContext :: Context+probeContext = emptyContext {messages = V.singleton (user "hello")}++probeOptions :: Options+probeOptions = emptyOptions {maxTokens = Just 16}++probeTool :: Tool+probeTool = mkTool "probe" "a probe" Null++probeLog :: CallLogConfig+probeLog = callLogConfig "/dev/null"++-- Qualified because @modelId@ alone does not name a type: 'Model',+-- 'EmbeddingModel' and 'InteractiveLaunchRequest' all have it, and under+-- @DuplicateRecordFields@ a record update whose fields do not determine+-- the datatype is ambiguous. Hiding constructors did not cause that and+-- does not change it; a consumer either qualifies, as here, or reaches+-- for generic-lens.+probeEmbedding :: Embedding.EmbeddingModel+probeEmbedding =+  Embedding.emptyEmbeddingModel {Embedding.modelId = "text-embedding-probe"}++-- | Two spellings of one header name, through the public 'HeaderName'.+headerCount :: Int+headerCount =+  Map.size (Map.fromList [("X-Probe", "a"), ("x-probe", "b")] :: Map.Map HeaderName Text)
test/StreamSpec.hs view
@@ -5,6 +5,7 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay, throwTo) import Control.Exception qualified as Exception import Data.Aeson qualified as Aeson+import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Time (UTCTime) import Data.Vector qualified as Vector import Streamly.Data.Stream qualified as Stream@@ -71,11 +72,11 @@  doneEvent :: Maybe Text -> [AssistantContent] -> AssistantMessageEvent doneEvent rid blocks =-  EventDone (doneTerminal rid Stop (assistantMessage blocks))+  EventDone (doneTerminal Nothing rid Stop (assistantMessage blocks))  signedThinking :: ThinkingContent signedThinking =-  ThinkingContent {thinking = "t", signature = Just "sig-abc", redacted = True}+  ThinkingContent {thinking = "t", signature = Just "sig-abc", redacted = True, replayState = Nothing}  tests :: TestTree tests =@@ -132,13 +133,21 @@         let expected =               Vector.fromList                 [ AssistantText (TextContent "first"),-                  AssistantThinking ThinkingContent {thinking = "partial-think", signature = Nothing, redacted = False},+                  AssistantThinking ThinkingContent {thinking = "partial-think", signature = Nothing, redacted = False, replayState = Nothing},                   AssistantText (TextContent "last"),                   AssistantToolCall ToolCall {id_ = "", name = "", arguments = Aeson.String "{\"a\":1"}                 ]         resp ^. #message ^. #content @?= expected         resp ^. #message ^. #stopReason @?= Stop-        resp ^. #message ^. #errorMessage @?= Just "stream ended without terminal event",+        resp ^. #message ^. #errorMessage @?= Just "stream ended without terminal event"+        -- The recovered call is the same shape the two provider+        -- assemblers now produce for a cut-off call, and it says so.+        [tc | AssistantToolCall tc <- Vector.toList (resp ^. #message ^. #content)]+          @?= [ToolCall {id_ = "", name = "", arguments = Aeson.String "{\"a\":1"}]+        assertBool+          "a flushed dangling tool call is marked cut off"+          (all isCutOffToolCall [tc | AssistantToolCall tc <- Vector.toList (resp ^. #message ^. #content)]),+      cutOffToolCallIsNeverDispatchedTest,       testCase "latencyMs is clamped at zero" $ do         let oldResponse =               responseWith Nothing [AssistantText (TextContent "old")]@@ -147,6 +156,11 @@             handler _ _ _ = pure oldResponse         resp <- streamingComplete (liftCompleteToStream handler) streamModel streamContext streamOptions         assertBool "latencyMs should be non-negative" (resp ^. #latencyMs >= 0),+      duplicateStartTest,+      eventsAfterTerminalTest,+      failedTerminalAppendsDanglingTest,+      emptySuccessfulTerminalFallsBackTest,+      wallClockLatencyTest,       testCase "async exceptions pass through liftCompleteToStream" $ do         done <- newEmptyMVar         let blocked _ _ _ = threadDelay (10 * 1000 * 1000) *> pure (responseWith Nothing [])@@ -184,3 +198,193 @@             be ^. #retryAfterSeconds @?= Just 5           Nothing -> assertFailure "expected lifted BaikaiError to survive reassembly"     ]++-- | A tool call the model never finished asking for is not executed.+--+-- Both halves: 'runToolLoopWith' stops with the response intact rather+-- than dispatching, and 'appendToolResult' -- the documented direct+-- round-trip, which a caller drives by hand -- appends an error result+-- without calling the dispatcher either.+cutOffToolCallIsNeverDispatchedTest :: TestTree+cutOffToolCallIsNeverDispatchedTest =+  testCase "a cut-off tool call is never dispatched" $ do+    let cutOffCall = ToolCall {id_ = "call_1", name = "search", arguments = Aeson.String "{\"a\":1"}+        -- 'Length' is what a real cut-off carries; the guard does not+        -- rely on it, because a compatible host can report+        -- @finish_reason: tool_calls@ for truncated arguments.+        cutOffResponse =+          emptyResponse+            & #message+            .~ assistantPayload (Vector.singleton (AssistantToolCall cutOffCall)) Length Nothing epoch+            & #model+            .~ cutOffModel+            & #api+            .~ cutOffApi+            & #provider+            .~ "stream-spec"+    reg <- newProviderRegistry+    registerApiProviderWith+      reg+      ( apiProviderWith+          cutOffApi+          (liftCompleteToStream (\_ _ _ -> pure cutOffResponse))+          (\_ _ _ -> pure cutOffResponse)+      )+    dispatched <- newIORef ([] :: [ToolCall])+    let dispatcher tc = modifyIORef' dispatched (<> [tc]) >> pure (toolResultText "never")++    (_, looped) <- runToolLoopWith reg 4 dispatcher cutOffModel streamContext streamOptions+    looped ^. #message ^. #content @?= Vector.singleton (AssistantToolCall cutOffCall)+    looped ^. #message ^. #stopReason @?= Length+    readIORef dispatched >>= \calls -> calls @?= []++    ctx' <- appendToolResult streamContext cutOffResponse dispatcher+    readIORef dispatched >>= \calls -> calls @?= []+    case Vector.toList (ctx' ^. #messages) of+      [_assistant, ToolResultMessage p] -> do+        p ^. #isError @?= True+        p ^. #toolCallId @?= "call_1"+      other -> assertFailure ("expected the assistant message then one tool result, got: " <> show (length other))++-- | Its own tag, so this case cannot collide with the module's other+-- registrations when the suite runs in one process.+cutOffApi :: Api+cutOffApi = Custom "baikai-stream-spec-cutoff"++cutOffModel :: Model+cutOffModel =+  emptyModel+    & #modelId+    .~ "stream-spec-cutoff-model"+    & #api+    .~ cutOffApi+    & #provider+    .~ "stream-spec"++-- | A duplicated start does not rewrite the assembly.+--+-- First skeleton wins, so the latency window is measured from the first+-- event the provider actually sent; @responseId@ merges, so a later+-- 'Nothing' cannot erase an id an earlier event supplied.+duplicateStartTest :: TestTree+duplicateStartTest =+  testCase "a duplicate EventStart keeps the first skeleton and merges responseId" $ do+    let firstSkeleton = AssistantMessage (assistantPayload Vector.empty Stop Nothing later)+        staleSkeleton = AssistantMessage (assistantPayload Vector.empty Stop Nothing epoch)+    resp <-+      runEvents+        [ EventStart StartPayload {partial = firstSkeleton, responseId = Just "msg_1"},+          EventStart StartPayload {partial = staleSkeleton, responseId = Nothing},+          EventDone+            ( doneTerminal+                Nothing+                Nothing+                Stop+                (AssistantMessage (assistantPayload (Vector.singleton (AssistantText (TextContent "hi"))) Stop Nothing muchLater))+            )+        ]+    resp ^. #responseId @?= Just "msg_1"+    -- Measured from the first skeleton's timestamp, not the stale one:+    -- the stale skeleton is at the epoch, which would give a latency of+    -- decades.+    resp ^. #latencyMs @?= 2000++-- | The first terminal wins. A producer that keeps talking afterwards+-- cannot rewrite the answer a consumer has already been handed.+eventsAfterTerminalTest :: TestTree+eventsAfterTerminalTest =+  testCase "events after the terminal are ignored" $ do+    resp <-+      runEvents+        [ startEvent Nothing,+          doneEvent Nothing [AssistantText (TextContent "final")],+          TextStart IndexPayload {contentIndex = 5},+          TextDelta DeltaPayload {contentIndex = 5, delta = "late"},+          EventError+            ( errorTerminal+                Nothing+                Nothing+                ErrorReason+                (AssistantMessage (assistantPayload Vector.empty ErrorReason (Just "too late") epoch))+                (providerError "too late")+            )+        ]+    resp ^. #message ^. #content @?= Vector.singleton (AssistantText (TextContent "final"))+    resp ^. #message ^. #stopReason @?= Stop+    resp ^. #errorInfo @?= Nothing++-- | A failed terminal's own content comes first and the blocks that were+-- still open are appended after it. Safe because an open index is always+-- greater than every closed one.+failedTerminalAppendsDanglingTest :: TestTree+failedTerminalAppendsDanglingTest =+  testCase "a failed terminal appends dangling blocks after its content" $ do+    resp <-+      runEvents+        [ startEvent Nothing,+          TextStart IndexPayload {contentIndex = 0},+          TextDelta DeltaPayload {contentIndex = 0, delta = "closed"},+          TextEnd BlockEndPayload {contentIndex = 0, content = "closed"},+          ThinkingStart IndexPayload {contentIndex = 1},+          ThinkingDelta DeltaPayload {contentIndex = 1, delta = "half a thought"},+          EventError+            ( errorTerminal+                Nothing+                Nothing+                ErrorReason+                (AssistantMessage (assistantPayload (Vector.singleton (AssistantText (TextContent "closed"))) ErrorReason (Just "boom") epoch))+                (providerError "boom")+            )+        ]+    resp ^. #message ^. #content+      @?= Vector.fromList+        [ AssistantText (TextContent "closed"),+          AssistantThinking ThinkingContent {thinking = "half a thought", signature = Nothing, redacted = False, replayState = Nothing}+        ]++-- | A terminal that carries no content is not authoritative about+-- content: the blocks the stream assembled are.+emptySuccessfulTerminalFallsBackTest :: TestTree+emptySuccessfulTerminalFallsBackTest =+  testCase "a successful terminal with empty content falls back to the assembled blocks" $ do+    resp <-+      runEvents+        [ startEvent Nothing,+          TextStart IndexPayload {contentIndex = 0},+          TextDelta DeltaPayload {contentIndex = 0, delta = "assembled"},+          TextEnd BlockEndPayload {contentIndex = 0, content = "assembled"},+          doneEvent Nothing []+        ]+    resp ^. #message ^. #content @?= Vector.singleton (AssistantText (TextContent "assembled"))++-- | With no provider timestamps, latency is the window this fold saw+-- rather than a zero that reads as "instant".+wallClockLatencyTest :: TestTree+wallClockLatencyTest =+  testCase "latencyMs falls back to the wall clock when timestamps are absent" $ do+    let untimed sr err blocks =+          AssistantMessage+            AssistantPayload+              { content = Vector.fromList blocks,+                usage = zeroUsage,+                stopReason = sr,+                errorMessage = err,+                timestamp = Nothing+              }+        events =+          [ EventStart StartPayload {partial = untimed Stop Nothing [], responseId = Nothing},+            EventDone (doneTerminal Nothing Nothing Stop (untimed Stop Nothing [AssistantText (TextContent "slow")]))+          ]+    resp <-+      Stream.fold+        (reassembleResponse streamModel)+        (Stream.mapM (\e -> threadDelay 20000 >> pure e) (Stream.fromList events))+    assertBool+      ("expected a wall-clock latency of at least 20ms, got: " <> show (resp ^. #latencyMs))+      (resp ^. #latencyMs >= 20)++later :: UTCTime+later = read "2000-01-01 00:00:01 UTC"++muchLater :: UTCTime+muchLater = read "2000-01-01 00:00:03 UTC"
+ test/StreamWorkerSpec.hs view
@@ -0,0 +1,86 @@+-- | The bounded worker/consumer hand-off in+-- "Baikai.Provider.Internal.StreamWorker".+--+-- Both HTTP providers depend on the three properties pinned here: every+-- frame pushed before the close is delivered, a worker blocked on a full+-- queue is interruptible, and the queue closes however the body ends.+module StreamWorkerSpec (tests) where++import Baikai.Provider.Internal.StreamWorker+  ( FrameQueue,+    closeFrames,+    forkFrameWorker,+    frameQueueCapacity,+    newFrameQueue,+    pullFrame,+    pushFrame,+  )+import Control.Concurrent (forkIO, killThread, threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryTakeMVar)+import Control.Exception (finally)+import Control.Monad (forM_)+import Data.IORef (newIORef, readIORef, writeIORef)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Baikai.Provider.Internal.StreamWorker"+    [ deliversEveryFrameTest,+      blockedPushIsInterruptibleTest,+      killedBodyClosesQueueTest+    ]++-- | Ordering and completeness: the close flag never overtakes frames+-- already in the queue.+deliversEveryFrameTest :: TestTree+deliversEveryFrameTest =+  testCase "pullFrame delivers every frame pushed before close" $ do+    q <- newFrameQueue+    forM_ [1 :: Int .. 10] (pushFrame q)+    closeFrames q+    let drain acc =+          pullFrame q >>= \case+            Nothing -> pure (reverse acc)+            Just a -> drain (a : acc)+    got <- drain []+    got @?= [1 .. 10]++-- | A worker whose consumer has stopped parks on a full queue rather+-- than reading on, and the park is an interruptible STM wait, so+-- 'killThread' reaches it.+blockedPushIsInterruptibleTest :: TestTree+blockedPushIsInterruptibleTest =+  testCase "pushFrame blocks when the queue is full and is interruptible" $ do+    q <- newFrameQueue+    pushed <- newEmptyMVar+    diedRef <- newIORef False+    tid <- forkIO $ do+      ( do+          forM_ [1 .. fromIntegral frameQueueCapacity] (pushFrame q :: Int -> IO ())+          pushFrame q 0+          putMVar pushed ()+        )+        `finally` writeIORef diedRef True+    threadDelay 100000+    stillBlocked <- tryTakeMVar pushed+    stillBlocked @?= Nothing+    killThread tid+    threadDelay 50000+    died <- readIORef diedRef+    assertBool "the blocked pusher was interrupted" died++-- | The close flag is set by the fork's own @finally@, so a worker that+-- dies by asynchronous exception cannot leave the consumer waiting.+killedBodyClosesQueueTest :: TestTree+killedBodyClosesQueueTest =+  testCase "forkFrameWorker closes the queue when the body is killed" $ do+    q <- newFrameQueue :: IO (FrameQueue Int)+    blocked <- newEmptyMVar+    tid <- forkFrameWorker q (takeMVar blocked)+    threadDelay 20000+    killThread tid+    got <- timeout 1000000 (pullFrame q)+    got @?= Just Nothing
+ test/StrictEvidenceSpec.hs view
@@ -0,0 +1,558 @@+-- | 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.Aeson qualified as Aeson+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time (getCurrentTime)+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)+          (declaredStrength (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)+          (declaredStrength 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)+          (declaredStrength 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)+          (declaredStrength 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)+              (declaredStrength (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)+      (declaredStrength 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)+          (declaredStrength 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)+          (declaredStrength AnthropicMessages)+          noThinkingRequested+          @?= [],+      testCase "A DROPPED SAMPLING PARAMETER IS NOT A THINKING DOWNGRADE" $+        -- The documented contract is refusing a call that would weaken+        -- the requested thinking level. A sampling parameter the model+        -- generation or the API has nowhere to put is recorded in the+        -- evidence — that is what the adjustment is for — but it is not+        -- a thinking downgrade, and a caller who set `temperature` on a+        -- Claude model must not have every strict call refused over it.+        checkEvidenceRequirements+          (EvidenceRequired EvidenceRequestedOnly)+          (declaredStrength AnthropicMessages)+          ( noThinkingRequested+              & #adjustments .~ [SamplingDroppedUnsupportedModel ["temperature"]]+          )+          @?= [],+      testCase "a sampling drop alongside a real downgrade reports only the downgrade" $+        case checkEvidenceRequirements+          (EvidenceRequired EvidenceRequestedOnly)+          (declaredStrength AnthropicMessages)+          ( noThinkingRequested+              & #requested .~ Just ThinkingMax+              & #adjustments+                .~ [ EffortOmitted ThinkingMax,+                     SamplingDroppedUnsupportedModel ["temperature", "top_p"]+                   ]+          ) of+          [ThinkingWouldDowngrade reported] ->+            reported @?= [EffortOmitted ThinkingMax]+          other -> assertFailure ("expected one ThinkingWouldDowngrade, got: " <> show other),+      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)+          (declaredStrength 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 (declaredStrength 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,+                  SamplingDroppedUnsupportedModel ["temperature"],+                  SamplingDroppedUnsupportedApi ["seed"],+                  FastModeDroppedUnsupportedModel,+                  ThinkingSummaryUnavailable+                ]+            ]+    ]++-- | 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+  ThinkingSummaryUnavailable -> "summary unavailable"+  FastModeDroppedUnsupportedModel -> "fast mode dropped"+  EffortClamped {} -> "clamped"+  EffortCollapsedToToggle {} -> "collapsed"+  EffortOmitted {} -> "omitted"+  ThinkingDroppedUnsupportedModel {} -> "dropped-model"+  ThinkingDroppedUnsupportedHost {} -> "dropped-host"+  ThinkingDroppedBudgetExceeded {} -> "dropped-budget"+  SamplingDroppedUnsupportedModel {} -> "sampling-dropped-model"+  SamplingDroppedUnsupportedApi {} -> "sampling-dropped-api"++-- ============================================================+-- 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+                        (declaredStrength 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)+                        (declaredStrength 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",+      testCase "a strict completeRequest with a record-less provider fails after the call" $ do+        -- The gate lets this through: a custom provider declaring+        -- requested_only can satisfy a requested_only requirement, and+        -- one that builds a minimal record does. This one does not, and+        -- the failure is caught at the terminal instead — with no sink+        -- anywhere, which is the point of enforcing at dispatch.+        reg <- newProviderRegistry+        registerApiProviderWith reg countingProvider+        resp <- completeRequestWith reg customModel testContext (strictly EvidenceRequestedOnly)+        case responseError resp of+          Nothing -> assertFailure "expected the missing record to fail the call"+          Just err ->+            assertBool+              ("the message names the missing record: " <> Text.unpack (err ^. #message))+              ("attached no evidence record" `Text.isInfixOf` (err ^. #message))+        -- The provider was reached and its content is kept, so a caller+        -- reading the failure can still see what came back.+        flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran",+      testCase "A CUSTOM PROVIDER DECLARING correlated SATISFIES A STRICT correlated CALL" $ do+        -- Under the tag-keyed table this was impossible: every Custom+        -- transport was capped at requested_only whatever its evidence+        -- actually reached, so a gateway that observes a response id+        -- could never serve a strict correlated caller.+        reg <- newProviderRegistry+        registerApiProviderWith reg correlatingProvider+        resp <- completeRequestWith reg customModel testContext (strictly EvidenceCorrelated)+        responseError resp @?= Nothing+        case resp ^. #evidence of+          Nothing -> assertFailure "a strict caller opted into evidence and must get a record"+          Just ev -> ev ^. #strength @?= EvidenceCorrelated,+      testCase "a declaration is still a ceiling, not a blank cheque" $ do+        reg <- newProviderRegistry+        registerApiProviderWith reg correlatingProvider+        resp <- completeRequestWith reg customModel testContext (strictly EvidenceModelObserved)+        case responseError resp of+          Nothing -> assertFailure "expected a refusal"+          Just err ->+            assertBool+              ("the message names both strengths: " <> Text.unpack (err ^. #message))+              ( "model_observed" `Text.isInfixOf` (err ^. #message)+                  && "correlated" `Text.isInfixOf` (err ^. #message)+              )+    ]++-- ============================================================+-- 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 custom transport that declares, and delivers, 'EvidenceCorrelated'+-- — a response id it observed. Its ceiling is its own declaration, which+-- the tag-keyed table could never express.+correlatingProvider :: ApiProvider+correlatingProvider =+  apiProviderWith+    customApi+    (liftCompleteToStream handler)+    (handler)+    & #strengthCeiling .~ (EvidenceCorrelated)+  where+    handler m _ opts = do+      now <- getCurrentTime+      ev <-+        minimalEvidence+          m+          opts+          TransportHttpApi+          noThinkingRequested+          (Aeson.object ["model" Aeson..= (m ^. #modelId :: Text)])+          now+          now+          CallSucceeded+          Nothing+      let seen = Observed "gateway-response-1" :: Observed Text+          observed e =+            e+              & #responseId .~ seen+              & #strength .~ deriveStrength Unobserved Unobserved seen+      pure+        ( emptyResponse+            & #model .~ m+            & #evidence .~ fmap observed ev+            & #message . #content+              .~ Vector.singleton (AssistantText (TextContent "the provider ran"))+        )++-- | A provider that fails loudly if it is reached. Used to prove the+-- gate refuses /before/ dispatch rather than annotating afterwards.+explodingProvider :: ApiProvider+explodingProvider =+  apiProviderWith+    customApi+    (\_ _ _ -> error "the provider was dispatched despite a strict refusal")+    (\_ _ _ -> error "the provider was dispatched despite a strict refusal")++-- | The same shape, but it answers.+countingProvider :: ApiProvider+countingProvider =+  apiProviderWith+    customApi+    (liftCompleteToStream handler)+    (handler)+  where+    handler m _ _ =+      pure+        ( emptyResponse+            & #model .~ m+            & #message . #content+              .~ Vector.singleton (AssistantText (TextContent "the provider ran"))+        )
test/SurfaceSpec.hs view
@@ -1,11 +1,13 @@ module SurfaceSpec (tests) where  import Baikai+import Baikai.Cost.Log (callLogConfig) import Baikai.Embedding qualified as Embedding import Baikai.Prelude import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map import Data.Vector qualified as V+import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -49,5 +51,24 @@         zeroModelCost ^. #inputCost @?= 0         emptyTool ^. #parameters @?= Aeson.Null         emptyToolCall ^. #arguments @?= Aeson.Null-        Embedding.modelId Embedding.emptyEmbeddingModel @?= ""+        Embedding.modelId Embedding.emptyEmbeddingModel @?= "",+      -- Every record whose constructor this release hid must still be+      -- reachable: build each from its exported base and read one field+      -- back. A base value that disappears, or a field that stops being+      -- exported, fails to compile here rather than at a consumer.+      testCase "hidden records build from their bases" $ do+        let provider = apiProvider (Custom "probe") (\_ _ _ -> Stream.nil)+            req = evidenceRequest "r" & #attempt .~ 2+            tool = mkTool "t" "d" Aeson.Null+            embedding = Embedding.emptyEmbeddingModel & #modelId .~ "e"+            logCfg = callLogConfig "/dev/null"+        provider ^. #apiTag @?= Custom "probe"+        provider ^. #strengthCeiling @?= EvidenceRequestedOnly+        req ^. #attempt @?= 2+        req ^. #runId @?= "r"+        tool ^. #name @?= "t"+        tool ^. #parameters @?= Aeson.Null+        embedding ^. #modelId @?= "e"+        logCfg ^. #path @?= "/dev/null"+        logCfg ^. #enabled @?= True     ]
test/ThinkingLevelSpec.hs view
@@ -10,6 +10,7 @@   testGroup     "ThinkingLevel"     [ testGroup "canonical rendering" renderTests,+      testGroup "canonical parsing" parseTests,       testGroup "token budgets" budgetTests     ] @@ -28,6 +29,18 @@   [ testCase name $ renderThinkingLevel level @?= expected   | (name, level, expected, _) <- levels   ]++-- | 'parseThinkingLevel' is the inverse of 'renderThinkingLevel' on+-- every level, which is what lets @baikai-agent@'s KDL decoder and the+-- evidence schema read the table instead of copying it.+parseTests :: [TestTree]+parseTests =+  [ testCase name $ do+      parseThinkingLevel expected @?= Just level+      parseThinkingLevel (renderThinkingLevel level) @?= Just level+  | (name, level, expected, _) <- levels+  ]+    <> [testCase "an unknown name is Nothing" $ parseThinkingLevel "enormous" @?= Nothing]  budgetTests :: [TestTree] budgetTests =
test/TraceSpec.hs view
@@ -3,225 +3,1262 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext)-import Baikai.Error (BaikaiError, providerError)-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.StopReason (StopReason (..))-import Baikai.Stream (liftCompleteToStream)-import Baikai.Trace (newEventId, withTrace, withTraceStream)-import Baikai.Trace.Event (TraceEvent (..))-import Baikai.Trace.Sink (TraceSink (..), silent)-import Baikai.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.Set qualified as Set-import Data.Text qualified as Text-import Data.Vector qualified as V-import Streamly.Data.Fold qualified as Fold-import Streamly.Data.Stream qualified as Stream-import System.Mem (performMajorGC)-import System.Timeout (timeout)-import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))--tests :: TestTree-tests =-  testGroup-    "Baikai.Trace"-    [ silentTest,-      memoryFinishTest,-      memoryFailTest,-      throwingSinkTest,-      eventIdUniquenessTest,-      earlyAbortTest-    ]---- | Each test uses its own private 'Api' tag so tasty's parallel--- test scheduler cannot race the (process-global) registry between--- tests.-stubModel :: Api -> Model-stubModel a =-  emptyModel-    & #modelId-    .~ "stub-1"-    & #api-    .~ a-    & #provider-    .~ "stub.trace"-    & #maxOutputTokens-    .~ 16--stubContext :: Context-stubContext = emptyContext & #messages .~ V.fromList [user "hello"]--stubOptions :: Options-stubOptions = emptyOptions & #maxTokens .~ Just 16--stubResponse :: Api -> Response-stubResponse a =-  Response-    { message =-        AssistantPayload-          { content = V.singleton (AssistantText (TextContent "hi")),-            usage = zeroUsage,-            stopReason = Stop,-            errorMessage = Nothing,-            timestamp = Just (read "2026-05-14 00:00:00 UTC")-          },-      model = stubModel a,-      api = a,-      provider = "stub.trace",-      responseId = Nothing,-      latencyMs = 0,-      errorInfo = Nothing-    }--registerOk :: Api -> IO ()-registerOk a =-  let handler _m _ctx _opts = pure (stubResponse a)-   in registerApiProvider-        ApiProvider-          { apiTag = a,-            stream = liftCompleteToStream handler,-            complete = handler-          }--registerFail :: Api -> BaikaiError -> IO ()-registerFail a e =-  let handler _m _ctx _opts = throwIO e-   in registerApiProvider-        ApiProvider-          { apiTag = a,-            stream = liftCompleteToStream handler,-            complete = handler-          }--memorySink :: IO (TVar [TraceEvent], TraceSink)-memorySink = do-  ref <- newTVarIO []-  let step () e = atomically (modifyTVar' ref (e :))-      sink = TraceSink (Fold.foldlM' step (pure ()))-  pure (ref, sink)--silentTest :: TestTree-silentTest =-  testGroup-    "silent sink"-    [ testCase "returns the response on success" $ do-        let a = Custom "baikai-trace-silent-ok"-        registerOk a-        _ <- withTrace silent (stubModel a) stubContext stubOptions-        pure (),-      testCase "encodes failure as ErrorReason in the response" $ do-        let a = Custom "baikai-trace-silent-fail"-        registerFail a (providerError "boom")-        resp <- withTrace silent (stubModel a) stubContext stubOptions-        let AssistantPayload {stopReason = sr, errorMessage = em} = resp ^. #message-        sr @?= ErrorReason-        assertBool-          ("expected errorMessage to mention boom, got: " <> show em)-          (maybe False ("boom" `Text.isInfixOf`) em)-    ]--memoryFinishTest :: TestTree-memoryFinishTest =-  testCase "memory sink records CallStarted then CallFinished" $ do-    let a = Custom "baikai-trace-memory-ok"-    registerOk a-    (ref, sink) <- memorySink-    _ <- withTrace sink (stubModel a) stubContext stubOptions-    rev <- readTVarIO ref-    let events = reverse rev-    length events @?= 2-    case events of-      [s@CallStarted {}, f@CallFinished {}] -> do-        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)-        (s ^. #provider :: Text) @?= "stub.trace"-        (f ^. #provider :: Text) @?= "stub.trace"-        (s ^. #model :: Text) @?= "stub-1"-        (f ^. #model :: Text) @?= "stub-1"-      _ -> assertFailure ("unexpected event sequence: " <> show events)--memoryFailTest :: TestTree-memoryFailTest =-  testCase "memory sink records CallStarted then CallFailed on stream error" $ do-    let a = Custom "baikai-trace-memory-fail"-    registerFail a (providerError "stub-failure")-    (ref, sink) <- memorySink-    resp <- withTrace sink (stubModel a) stubContext stubOptions-    -- The producer-side failure surfaces as an ErrorReason on the-    -- response (no throw) and as CallFailed on the trace sink.-    let AssistantPayload {stopReason = sr} = resp ^. #message-    sr @?= ErrorReason-    rev <- readTVarIO ref-    let events = reverse rev-    length events @?= 2-    case events of-      [s@CallStarted {}, f@CallFailed {errorMessage = msg}] -> do-        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)-        assertBool-          ("expected error to mention stub-failure, got: " <> show msg)-          ("stub-failure" `Text.isInfixOf` msg)-      _ -> assertFailure ("unexpected event sequence: " <> show events)--throwingSink :: TraceSink-throwingSink =-  TraceSink (Fold.drainMapM (\_ -> throwIO (providerError "sink exploded")))--throwingSinkTest :: TestTree-throwingSinkTest =-  testCase "a throwing sink cannot hang withTrace" $ do-    let a = Custom "baikai-trace-throwing-sink"-    registerOk a-    result <- timeout 5000000 (withTrace throwingSink (stubModel a) stubContext stubOptions)-    case result of-      Nothing -> assertFailure "withTrace hung on a throwing sink"-      Just resp -> do-        let AssistantPayload {stopReason = sr} = resp ^. #message-        sr @?= Stop--eventIdUniquenessTest :: TestTree-eventIdUniquenessTest =-  testCase "newEventId yields 70000 distinct 16-char ids" $ do-    ids <- replicateM 70000 newEventId-    Set.size (Set.fromList ids) @?= 70000-    assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids)--earlyAbortTest :: TestTree-earlyAbortTest =-  testCase "early abort pushes a synthetic CallFailed" $ do-    let a = Custom "baikai-trace-abort"-    registerOk a-    (ref, sink) <- memorySink-    emitted <--      Stream.toList-        (Stream.take 1 (withTraceStream sink (stubModel a) stubContext stubOptions))-    length emitted @?= 1-    events <- awaitEvents ref 2-    case events of-      [s@CallStarted {}, f@CallFailed {errorMessage = msg}] -> do-        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)-        assertBool-          ("expected abort message, got: " <> show msg)-          ("aborted" `Text.isInfixOf` msg)-      _ -> assertFailure ("unexpected event sequence: " <> show events)---- The trace finalizer on an abandoned stream runs from streamly's GC hook.-awaitEvents :: TVar [TraceEvent] -> Int -> IO [TraceEvent]-awaitEvents ref n = go (100 :: Int)-  where-    go 0 = do-      evs <- readTVarIO ref-      assertFailure ("timed out waiting for trace events; got: " <> show (reverse evs))-    go k = do-      performMajorGC-      evs <- readTVarIO ref-      if length evs >= n-        then pure (reverse evs)-        else threadDelay 50000 >> go (k - 1)+import Baikai.Cost qualified as Cost+import Baikai.Error (BaikaiError, ErrorCategory (..), 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 (apiProviderWith, registerApiProvider)+import Baikai.Response (Response (..), responseError)+import Baikai.StopReason (StopReason (..))+import Baikai.Stream (liftCompleteToStream)+import Baikai.Stream.Event (AssistantMessageEvent (..))+import Baikai.ThinkingLevel (ThinkingLevel (..))+import Baikai.Trace (withTrace, withTraceStream)+import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..), multiSink, silent)+import Baikai.Usage (Usage, zeroUsage)+import Control.Concurrent (forkIO, threadDelay, throwTo)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar, takeMVar)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Exception (AsyncException (ThreadKilled), SomeException, throwIO, try)+import Control.Monad (forM_, 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.Either (isLeft)+import Data.List (findIndex)+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+import System.Mem (performMajorGC)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Baikai.Trace"+    [ silentTest,+      memoryFinishTest,+      memoryFailTest,+      throwingSinkTest,+      blockingSinkTest,+      blockingSinkStrictTest,+      multiSinkThrowingMemberTest,+      multiSinkBlockingMemberTest,+      multiSinkStrictNamesMemberTest,+      terminalPathAtomicityTest,+      throwToAroundTerminalTest,+      eventIdUniquenessTest,+      earlyAbortTest,+      fidelityTest,+      evidenceTests,+      requestedLevelTests,+      encodingTests+    ]++-- | Each test uses its own private 'Api' tag so tasty's parallel+-- test scheduler cannot race the (process-global) registry between+-- tests.+stubModel :: Api -> Model+stubModel a =+  emptyModel+    & #modelId+    .~ "stub-1"+    & #api+    .~ a+    & #provider+    .~ "stub.trace"+    & #maxOutputTokens+    .~ 16++stubContext :: Context+stubContext = emptyContext & #messages .~ V.fromList [user "hello"]++stubOptions :: Options+stubOptions = emptyOptions & #maxTokens .~ Just 16++stubResponse :: Api -> Response+stubResponse a =+  Response+    { message =+        AssistantPayload+          { content = V.singleton (AssistantText (TextContent "hi")),+            usage = zeroUsage,+            stopReason = Stop,+            errorMessage = Nothing,+            timestamp = Just (read "2026-05-14 00:00:00 UTC")+          },+      model = stubModel a,+      api = a,+      provider = "stub.trace",+      responseId = Nothing,+      latencyMs = 0,+      errorInfo = Nothing,+      evidence = Nothing+    }++registerOk :: Api -> IO ()+registerOk a =+  let handler _m _ctx _opts = pure (stubResponse a)+   in registerApiProvider+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )++registerFail :: Api -> BaikaiError -> IO ()+registerFail a e =+  let handler _m _ctx _opts = throwIO e+   in registerApiProvider+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )++memorySink :: IO (TVar [TraceEvent], TraceSink)+memorySink = do+  ref <- newTVarIO []+  let step () e = atomically (modifyTVar' ref (e :))+      sink = TraceSink (Fold.foldlM' step (pure ()))+  pure (ref, sink)++silentTest :: TestTree+silentTest =+  testGroup+    "silent sink"+    [ testCase "returns the response on success" $ do+        let a = Custom "baikai-trace-silent-ok"+        registerOk a+        _ <- withTrace silent (stubModel a) stubContext stubOptions+        pure (),+      testCase "encodes failure as ErrorReason in the response" $ do+        let a = Custom "baikai-trace-silent-fail"+        registerFail a (providerError "boom")+        resp <- withTrace silent (stubModel a) stubContext stubOptions+        let AssistantPayload {stopReason = sr, errorMessage = em} = resp ^. #message+        sr @?= ErrorReason+        assertBool+          ("expected errorMessage to mention boom, got: " <> show em)+          (maybe False ("boom" `Text.isInfixOf`) em)+    ]++memoryFinishTest :: TestTree+memoryFinishTest =+  testCase "memory sink records CallStarted then CallFinished" $ do+    let a = Custom "baikai-trace-memory-ok"+    registerOk a+    (ref, sink) <- memorySink+    _ <- withTrace sink (stubModel a) stubContext stubOptions+    rev <- readTVarIO ref+    let events = reverse rev+    length events @?= 2+    case events of+      [s@CallStarted {}, f@CallFinished {}] -> do+        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)+        (s ^. #provider :: Text) @?= "stub.trace"+        (f ^. #provider :: Text) @?= "stub.trace"+        (s ^. #model :: Text) @?= "stub-1"+        (f ^. #model :: Text) @?= "stub-1"+      _ -> assertFailure ("unexpected event sequence: " <> show events)++memoryFailTest :: TestTree+memoryFailTest =+  testCase "memory sink records CallStarted then CallFailed on stream error" $ do+    let a = Custom "baikai-trace-memory-fail"+    registerFail a (providerError "stub-failure")+    (ref, sink) <- memorySink+    resp <- withTrace sink (stubModel a) stubContext stubOptions+    -- The producer-side failure surfaces as an ErrorReason on the+    -- response (no throw) and as CallFailed on the trace sink.+    let AssistantPayload {stopReason = sr} = resp ^. #message+    sr @?= ErrorReason+    rev <- readTVarIO ref+    let events = reverse rev+    length events @?= 2+    case events of+      [s@CallStarted {}, f@CallFailed {errorMessage = msg}] -> do+        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)+        assertBool+          ("expected error to mention stub-failure, got: " <> show msg)+          ("stub-failure" `Text.isInfixOf` msg)+      _ -> assertFailure ("unexpected event sequence: " <> show events)++throwingSink :: TraceSink+throwingSink =+  TraceSink (Fold.drainMapM (\_ -> throwIO (providerError "sink exploded")))++throwingSinkTest :: TestTree+throwingSinkTest =+  testCase "a throwing sink cannot hang withTrace" $ do+    let a = Custom "baikai-trace-throwing-sink"+    registerOk a+    result <- timeout 5000000 (withTrace throwingSink (stubModel a) stubContext stubOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a throwing sink"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= Stop++-- | A sink that never returns from its first step until released.+blockingSink :: IO (MVar (), TraceSink)+blockingSink = do+  release <- newEmptyMVar+  pure (release, TraceSink (Fold.drainMapM (\_ -> readMVar release)))++-- | Unfixed, 'finalizeTrace' blocked on the worker forever and the+-- guard below reported the hang. The bound turns a pathological sink+-- into about one second and a stderr line.+blockingSinkTest :: TestTree+blockingSinkTest =+  testCase "a sink that blocks forever cannot hold withTrace past the drain bound" $ do+    let a = Custom "baikai-trace-blocking-sink"+    registerOk a+    (release, sink) <- blockingSink+    result <- timeout 2000000 (withTrace sink (stubModel a) stubContext stubOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a blocking sink"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= Stop+    putMVar release ()++-- | A record whose delivery was never confirmed is not one a strict+-- caller can account for, so the stall fails the call through the same+-- path a throwing sink does.+blockingSinkStrictTest :: TestTree+blockingSinkStrictTest =+  testCase "a strict call whose sink never confirms delivery fails" $ do+    let a = Custom "baikai-trace-blocking-sink-strict"+    -- The evidence-building fixture, so the sink is the only reason+    -- this call can fail.+    registerOkWithEvidence a+    (release, sink) <- blockingSink+    result <- timeout 2000000 (withTrace sink (stubModel a) stubContext strictOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a blocking sink"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= ErrorReason+        case responseError resp of+          Nothing -> assertFailure "expected the stall to reach the response"+          Just be ->+            assertBool+              ("the error names the stall: " <> Text.unpack (be ^. #message))+              ("did not confirm delivery" `Text.isInfixOf` (be ^. #message))+    putMVar release ()++-- | Under 'Fold.tee' the throwing member's exception stopped delivery+-- to the sibling for the rest of the call and skipped its end-of-stream+-- action, so this sibling was empty.+multiSinkThrowingMemberTest :: TestTree+multiSinkThrowingMemberTest =+  testCase "a throwing multiSink member does not starve its sibling" $ do+    let a = Custom "baikai-trace-multisink-throwing"+    registerOk a+    (ref, memory) <- memorySink+    result <-+      timeout+        5000000+        (withTrace (multiSink [throwingSink, memory]) (stubModel a) stubContext stubOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a throwing multiSink member"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= Stop+    events <- reverse <$> readTVarIO ref+    case events of+      [CallStarted {}, CallFinished {}] -> pure ()+      other -> assertFailure ("the sibling missed events: " <> show other)++multiSinkBlockingMemberTest :: TestTree+multiSinkBlockingMemberTest =+  testCase "a blocking multiSink member does not starve its sibling" $ do+    let a = Custom "baikai-trace-multisink-blocking"+    registerOk a+    (release, blocking) <- blockingSink+    (ref, memory) <- memorySink+    result <-+      timeout+        2000000+        (withTrace (multiSink [blocking, memory]) (stubModel a) stubContext stubOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a blocking multiSink member"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= Stop+    events <- reverse <$> readTVarIO ref+    case events of+      [CallStarted {}, CallFinished {}] -> pure ()+      other -> assertFailure ("the sibling missed events: " <> show other)+    putMVar release ()++-- | The aggregate failure has to say /which/ member failed, or an+-- operator with three sinks learns only that tracing broke.+multiSinkStrictNamesMemberTest :: TestTree+multiSinkStrictNamesMemberTest =+  testCase "a strict call names the multiSink member that failed" $ do+    let a = Custom "baikai-trace-multisink-strict"+    registerOkWithEvidence a+    (_ref, memory) <- memorySink+    result <-+      timeout+        5000000+        (withTrace (multiSink [throwingSink, memory]) (stubModel a) stubContext strictOptions)+    case result of+      Nothing -> assertFailure "withTrace hung on a throwing multiSink member"+      Just resp -> do+        let AssistantPayload {stopReason = sr} = resp ^. #message+        sr @?= ErrorReason+        case responseError resp of+          Nothing -> assertFailure "expected the member failure to reach the response"+          Just be -> do+            let msg = be ^. #message+            assertBool+              ("the error names the member index: " <> Text.unpack msg)+              ("member 0" `Text.isInfixOf` msg)+            assertBool+              ("the error carries the member's own message: " <> Text.unpack msg)+              ("sink exploded" `Text.isInfixOf` msg)++-- | A memory sink that parks on the terminal event until released.+--+-- The park is what makes the atomicity test deterministic: when+-- @parked@ is filled the consumer has already run 'commitTerminal' to+-- completion and is waiting for the worker, which is exactly the moment+-- an asynchronous exception used to leave a half-committed terminal+-- behind.+gatedSink :: IO (TVar [TraceEvent], MVar (), MVar (), TraceSink)+gatedSink = do+  ref <- newTVarIO []+  parked <- newEmptyMVar+  release <- newEmptyMVar+  let step () e = do+        atomically (modifyTVar' ref (e :))+        case e of+          CallFinished {} -> putMVar parked () >> readMVar release+          _ -> pure ()+      sink = TraceSink (Fold.foldlM' step (pure ()))+  pure (ref, parked, release, sink)++-- | Kill the consumer while it waits for a sink that has already taken+-- the terminal. The stream's exception path runs the trace finaliser a+-- second time, and it must find nothing left to do: one evidence+-- record, one terminal, and no synthetic @aborted@ 'CallFailed' on top+-- of the real 'CallFinished'.+terminalPathAtomicityTest :: TestTree+terminalPathAtomicityTest =+  testCase "an async exception on the terminal path leaves one terminal and one evidence" $ do+    let a = Custom "baikai-trace-terminal-atomicity"+    registerOkWithEvidence a+    (ref, parked, release, sink) <- gatedSink+    outcome <- newEmptyMVar+    consumer <- forkIO $ do+      r <- try (withTrace sink (stubModel a) stubContext evidenceOptions)+      putMVar outcome (r :: Either SomeException Response)+    takeMVar parked+    throwTo consumer ThreadKilled+    r <- takeMVar outcome+    assertBool "the consumer was killed" (isLeft r)+    putMVar release ()+    events <- awaitEvents ref 3+    length [e | e@CallEvidence {} <- events] @?= 1+    length [e | e@CallFinished {} <- events] @?= 1+    length [e | e@CallFailed {} <- events] @?= 0++-- | Aim an asynchronous exception at the consumer the instant the+-- evidence event reaches the sink — while the consumer is pushing the+-- terminal and setting the flag. Fifty times, because the window is a+-- few instructions wide and no scheduling hook can hit it+-- deterministically; the plan's widened-window demonstration shows the+-- test detects the defect.+throwToAroundTerminalTest :: TestTree+throwToAroundTerminalTest =+  testCase "fifty exceptions aimed at the terminal push never duplicate terminal or evidence" $+    forM_ [1 .. 50 :: Int] $ \i -> do+      let a = Custom ("baikai-trace-throwto-" <> Text.pack (show i))+      registerOkWithEvidence a+      ref <- newTVarIO []+      consumerVar <- newEmptyMVar+      let step () e = do+            atomically (modifyTVar' ref (e :))+            case e of+              CallEvidence {} -> readMVar consumerVar >>= \tid -> throwTo tid ThreadKilled+              _ -> pure ()+          sink = TraceSink (Fold.foldlM' step (pure ()))+      outcome <- newEmptyMVar+      tid <- forkIO $ do+        r <- try (withTrace sink (stubModel a) stubContext evidenceOptions)+        putMVar outcome (r :: Either SomeException Response)+      putMVar consumerVar tid+      _ <- takeMVar outcome+      _ <- awaitEvents ref 3+      -- Let anything the finaliser might still push arrive before counting.+      threadDelay 200000+      performMajorGC+      settled <- reverse <$> readTVarIO ref+      length [e | e@CallEvidence {} <- settled] @?= 1+      length [e | e@CallFinished {} <- settled] + length [e | e@CallFailed {} <- settled] @?= 1++-- | The length assertion here used to read+-- @assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids)@.+-- It reads 32 because 'Baikai.Evidence.newCallId', which replaced the+-- removed @newEventId@, 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 "newCallId yields 70000 distinct 32-char ids" $ do+    ids <- replicateM 70000 Ev.newCallId+    Set.size (Set.fromList ids) @?= 70000+    assertBool "every id is 32 chars" (all ((== 32) . Text.length) ids)++earlyAbortTest :: TestTree+earlyAbortTest =+  testCase "early abort pushes a synthetic CallFailed" $ do+    let a = Custom "baikai-trace-abort"+    registerOk a+    (ref, sink) <- memorySink+    emitted <-+      Stream.toList+        (Stream.take 1 (withTraceStream sink (stubModel a) stubContext stubOptions))+    length emitted @?= 1+    events <- awaitEvents ref 2+    case events of+      [s@CallStarted {}, f@CallFailed {errorMessage = msg}] -> do+        (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text)+        assertBool+          ("expected abort message, got: " <> show msg)+          ("aborted" `Text.isInfixOf` msg)+      _ -> assertFailure ("unexpected event sequence: " <> show events)++-- The trace finalizer on an abandoned stream runs from streamly's GC hook.+awaitEvents :: TVar [TraceEvent] -> Int -> IO [TraceEvent]+awaitEvents ref n = go (100 :: Int)+  where+    go 0 = do+      evs <- readTVarIO ref+      assertFailure ("timed out waiting for trace events; got: " <> show (reverse evs))+    go k = do+      performMajorGC+      evs <- readTVarIO ref+      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+    & #cost+    .~ Cost.estimateCost [Cost.ServiceTierNotReported] Cost.zeroCost++registerWithUsage :: Api -> Usage -> IO ()+registerWithUsage a u =+  let resp = stubResponse a & #message . #usage .~ u+      handler _m _ctx _opts = pure resp+   in registerApiProvider+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )++fidelityTest :: TestTree+fidelityTest =+  testGroup+    "CallFinished fidelity"+    [ testCase "failed terminal retains the partial response billing" $ do+        let a = Custom "baikai-partial-billing"+            partial = stubResponse a & #message . #usage .~ richUsage & #message . #stopReason .~ ErrorReason & #message . #errorMessage .~ Just "reset"+            handler _ _ _ = pure partial+        registerApiProvider (apiProviderWith a (liftCompleteToStream handler) handler)+        (ref, sink) <- memorySink+        response <- withTrace sink (stubModel a) stubContext stubOptions+        events <- reverse <$> readTVarIO ref+        case [f | f@CallFailed {} <- events] of+          [CallFailed {inputTokens, outputTokens, cachedInputTokens, cacheWriteTokens, totalTokens, usd, costBasis}] -> do+            inputTokens @?= Just 11+            outputTokens @?= Just 7+            cachedInputTokens @?= Just 5+            cacheWriteTokens @?= Just 3+            totalTokens @?= Just 26+            usd @?= Just (Cost.usdAsScientific (response ^. #message . #usage . #cost))+            costBasis @?= Cost.nonEmptyBasis (response ^. #message . #usage . #cost)+          other -> assertFailure (show other),+      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,+                costBasis+              }+            ] -> do+              inputTokens @?= Just 11+              outputTokens @?= Just 7+              cachedInputTokens @?= Just 5+              cacheWriteTokens @?= Just 3+              reasoningTokens @?= Just 4+              totalTokens @?= Just 26+              costBasis @?= Just (Cost.basis (richUsage ^. #cost))+          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+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )++-- | 'registerOk' with an honest describer.+--+-- The other fixtures answer 'noThinkingRequested' whatever the caller+-- set, which is exactly what hid the defect these tests pin: a stub+-- that always says "nothing was asked" cannot tell a path that lost the+-- caller's level from one that kept it.+registerOkHonest :: Api -> IO ()+registerOkHonest a =+  let handler _m _ctx _opts = pure (stubResponse a)+   in registerApiProvider+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+            & #describeThinking+            .~ (\_ o -> Build.requestedTranslation o)+        )++-- | A describer that answers with a wire shape of its own, so a test+-- can tell "the core asked the adapter" from "the core spelled+-- not_translated itself".+registerOkBudgetDescriber :: Api -> IO ()+registerOkBudgetDescriber a =+  let handler _m _ctx _opts = pure (stubResponse a)+      budgetTranslation o =+        Ev.ThinkingTranslation+          { Ev.requested = o ^. #thinking,+            Ev.mode = Ev.ThinkingModeBudget,+            Ev.effortText = Nothing,+            Ev.budgetTokens = Just 1024,+            Ev.wireField = Just "thinking",+            Ev.displayText = Nothing,+            Ev.adjustments = []+          }+   in registerApiProvider+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+            & #describeThinking+            .~ (\_ o -> budgetTranslation o)+        )++thinkingOptions :: Options+thinkingOptions = evidenceOptions & #thinking .~ Just ThinkingMax++-- | Read one key out of the encoded @thinking@ object.+thinkingField :: Text -> ModelCallEvidence -> Maybe Value+thinkingField k ev =+  KeyMap.lookup (Key.fromText k) (asObject (maybe Null id (evidenceField "thinking" ev)))++requestedLevelTests :: TestTree+requestedLevelTests =+  testGroup+    "the caller's thinking level on every evidence path"+    [ abortRecordsRequestedLevelTest,+      abortUsesTheAdapterDescriberTest,+      noProviderRecordsRequestedLevelTest,+      throwingHandlerRecordsRequestedLevelTest+    ]++abortRecordsRequestedLevelTest :: TestTree+abortRecordsRequestedLevelTest =+  testCase "an abandoned stream records the level the caller asked for" $ do+    let a = Custom "baikai-trace-abort-thinking"+    registerOkHonest a+    (ref, sink) <- memorySink+    emitted <-+      Stream.toList+        (Stream.take 1 (withTraceStream sink (stubModel a) stubContext thinkingOptions))+    length emitted @?= 1+    events <- awaitEvents ref 3+    ev <- exactlyOneEvidence events+    thinkingField "requested" ev @?= Just (String "max")+    thinkingField "mode" ev @?= Just (String "not_translated")++abortUsesTheAdapterDescriberTest :: TestTree+abortUsesTheAdapterDescriberTest =+  testCase "an abandoned stream asks the registered adapter to describe the translation" $ do+    let a = Custom "baikai-trace-abort-describer"+    registerOkBudgetDescriber a+    (ref, sink) <- memorySink+    emitted <-+      Stream.toList+        (Stream.take 1 (withTraceStream sink (stubModel a) stubContext thinkingOptions))+    length emitted @?= 1+    events <- awaitEvents ref 3+    ev <- exactlyOneEvidence events+    thinkingField "requested" ev @?= Just (String "max")+    -- The proof that the core consulted the adapter rather than+    -- spelling not_translated unconditionally.+    thinkingField "mode" ev @?= Just (String "budget")+    thinkingField "budget_tokens" ev @?= Just (Number 1024)++noProviderRecordsRequestedLevelTest :: TestTree+noProviderRecordsRequestedLevelTest =+  testCase "an unregistered provider records the level the caller asked for" $ do+    let a = Custom "baikai-trace-unregistered-thinking"+    (ref, sink) <- memorySink+    _ <- withTrace sink (stubModel a) stubContext thinkingOptions+    events <- awaitEvents ref 3+    ev <- exactlyOneEvidence events+    thinkingField "requested" ev @?= Just (String "max")+    thinkingField "mode" ev @?= Just (String "not_translated")++throwingHandlerRecordsRequestedLevelTest :: TestTree+throwingHandlerRecordsRequestedLevelTest =+  testCase "a handler that threw records the level the caller asked for" $ do+    let a = Custom "baikai-trace-throwing-thinking"+    registerFail a (providerError "stub-failure")+    (ref, sink) <- memorySink+    _ <- withTrace sink (stubModel a) stubContext thinkingOptions+    events <- awaitEvents ref 3+    ev <- exactlyOneEvidence events+    thinkingField "requested" ev @?= Just (String "max")+    thinkingField "mode" ev @?= Just (String "not_translated")+    evidenceField "status" ev @?= Just (String "failed")++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,+      strictNoRecordFailsTest,+      strictNoRecordIsOneTerminalTest,+      strictWithRecordSucceedsTest,+      strictNoRecordErrorPathKeepsProviderErrorTest,+      bestEffortNoRecordStillSucceedsTest+    ]++-- | 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@.+-- | The record must reach the sink while the call is still open there.+--+-- "Baikai.Trace" pushes 'CallEvidence' before the terminal since commit+-- @1717694@, because the OpenTelemetry sink ends and removes its span on+-- the terminal and so could never attach evidence that arrived after it.+-- 'docs\/capabilities\/model-call-evidence.md' claimed an ordering+-- assertion existed; this is it, and every evidence case runs it on its+-- own path — success, failure, abort, unregistered provider.+assertEvidencePrecedesTerminal :: [TraceEvent] -> IO ()+assertEvidencePrecedesTerminal events =+  case (findIndex isEvidence events, findIndex isTerminal events) of+    (Just i, Just j) ->+      assertBool+        ("CallEvidence at " <> show i <> " must precede the terminal at " <> show j)+        (i < j)+    (Just _, Nothing) -> assertFailure "an evidence event without a terminal"+    _ -> assertFailure "no evidence event to order"+  where+    isEvidence = \case CallEvidence {} -> True; _ -> False+    isTerminal = \case+      CallFinished {} -> True+      CallFailed {} -> True+      _ -> False++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+    assertEvidencePrecedesTerminal events+    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"+    -- The evidence-building fixture, so the sink is the only reason this+    -- call can fail. With a provider that attaches no record, a strict+    -- call now fails on that account before the sink is ever reached,+    -- and this case would assert the sink rule against the record rule.+    registerOkWithEvidence 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))++-- | Strict mode guaranteed that a record which was built and then lost+-- fails the call. It did not guarantee that one was built: a provider+-- that attached nothing returned a successful response and wrote no+-- @call_evidence@ line, with no error anywhere.+strictNoRecordFailsTest :: TestTree+strictNoRecordFailsTest =+  testCase "A STRICT CALL WHOSE PROVIDER ATTACHED NO RECORD FAILS, AND EMITS NO RECORD" $ do+    let a = Custom "baikai-evidence-strict-no-record"+    registerOk a+    (ref, sink) <- memorySink+    resp <- withTrace sink (stubModel a) stubContext strictOptions+    let AssistantPayload {stopReason = sr} = resp ^. #message+    sr @?= ErrorReason+    case responseError resp of+      Nothing -> assertFailure "expected the missing record to fail the call"+      Just be -> do+        be ^. #category @?= OtherError+        assertBool+          ("the error names the missing record: " <> Text.unpack (be ^. #message))+          ("attached no evidence record" `Text.isInfixOf` (be ^. #message))+    events <- awaitEvents ref 2+    length [e | e@CallStarted {} <- events] @?= 1+    length [e | e@CallFailed {} <- events] @?= 1+    length (evidencesIn events) @?= 0++-- | The rewrite produces one terminal, not two.+strictNoRecordIsOneTerminalTest :: TestTree+strictNoRecordIsOneTerminalTest =+  testCase "a record-less strict stream yields one EventError and no EventDone" $ do+    let a = Custom "baikai-evidence-strict-no-record-stream"+    registerOk a+    events <-+      Stream.toList (withTraceStream silent (stubModel a) stubContext strictOptions)+    length [e | e@(EventDone _) <- events] @?= 0+    length [e | e@(EventError _) <- events] @?= 1++-- | The rewrite fires on the absence of a record, not on strictness+-- alone.+strictWithRecordSucceedsTest :: TestTree+strictWithRecordSucceedsTest =+  testCase "a strict call whose provider attached a record still succeeds" $ do+    let a = Custom "baikai-evidence-strict-with-record"+    registerOkWithEvidence a+    (ref, sink) <- memorySink+    resp <- withTrace sink (stubModel a) stubContext strictOptions+    let AssistantPayload {stopReason = sr} = resp ^. #message+    sr @?= Stop+    responseError resp @?= Nothing+    events <- awaitEvents ref 3+    length (evidencesIn events) @?= 1++-- | On the error path the provider's own error is the more useful of+-- the two, and the strict contract already holds: the call failed.+strictNoRecordErrorPathKeepsProviderErrorTest :: TestTree+strictNoRecordErrorPathKeepsProviderErrorTest =+  testCase "a failed strict call keeps the provider's own error" $ do+    let a = Custom "baikai-evidence-strict-provider-error"+    registerFail a (providerError "stub-failure")+    resp <- withTrace silent (stubModel a) stubContext strictOptions+    case responseError resp of+      Nothing -> assertFailure "expected the provider's failure to reach the response"+      Just be -> do+        assertBool+          ("the provider's error survives: " <> Text.unpack (be ^. #message))+          ("stub-failure" `Text.isInfixOf` (be ^. #message))+        assertBool+          "the missing-record error must not overwrite it"+          (not ("attached no evidence record" `Text.isInfixOf` (be ^. #message)))++-- | Best effort never refuses, here as everywhere.+bestEffortNoRecordStillSucceedsTest :: TestTree+bestEffortNoRecordStillSucceedsTest =+  testCase "a best-effort call whose provider attached no record still succeeds" $ do+    let a = Custom "baikai-evidence-best-effort-no-record"+    registerOk a+    resp <- withTrace silent (stubModel a) stubContext evidenceOptions+    let AssistantPayload {stopReason = sr} = resp ^. #message+    sr @?= Stop+    responseError resp @?= Nothing++-- | 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" "\"<ts>\""+    . redactField "eventId" "\"<id>\""+    . 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+      ( apiProviderWith+          a+          (liftCompleteToStream handler)+          (handler)+      )+    (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,+      costBasis = Nothing,+      usageAvailability = Nothing,+      usd = Just 0+    }++sampleFailed :: TraceEvent+sampleFailed =+  CallFailed+    { eventId = "abc",+      timestamp = fixedTime,+      provider = "stub.trace",+      model = "stub-1",+      latencyMs = 12,+      inputTokens = Nothing,+      outputTokens = Nothing,+      cachedInputTokens = Nothing,+      cacheWriteTokens = Nothing,+      reasoningTokens = Nothing,+      totalTokens = Nothing,+      costBasis = Nothing,+      usageAvailability = Nothing,+      usd = Nothing,+      errorMessage = "boom"+    }
+ test/TransportClassifySpec.hs view
@@ -0,0 +1,265 @@+-- | The one transport classifier, pinned against the exception shapes+-- @http-client@, @tls@ and the socket layer actually raise.+--+-- The rule under test is /where/ the failure happened, not what type it+-- is: a connection that existed and broke is retryable, a connection+-- that could never work is not, and a programming error is neither. The+-- cases below therefore pair each constructor with the phase it belongs+-- to, and the negative cases matter as much as the positive ones — a+-- classifier that calls a @userError@ a network blip feeds a retry loop+-- a bug it can never retry away.+module TransportClassifySpec (tests) where++import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable)+import Baikai.Provider.Transport.Classify+  ( classifyHttpException,+    classifyHttpExceptionContent,+    classifyIOException,+    classifyTlsException,+    classifyTransportException,+  )+import Control.Exception (toException)+import Data.ByteString (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Text qualified as Text+import Foreign.C.Error (Errno (..), eCONNABORTED, eCONNRESET)+import GHC.IO.Exception qualified as IOE+import Network.HTTP.Client qualified as HTTP+import Network.HTTP.Client.Internal qualified as HTTPI+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11)+import Network.TLS qualified as TLS+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Baikai.Provider.Transport.Classify"+    [ testGroup "socket failures during the body read" ioTests,+      testGroup "http-client exception content" httpContentTests,+      testGroup "TLS failures" tlsTests,+      testGroup "the top-level dispatcher" dispatchTests+    ]++-- ============================================================+-- Fixtures+-- ============================================================++-- | An 'IOError' shaped the way the socket layer raises one during a+-- body read: a location naming the recv call, a description from the+-- kernel, an error type and an errno.+socketError :: IOE.IOErrorType -> Errno -> String -> IOE.IOException+socketError ty (Errno n) description =+  IOE.IOError+    { IOE.ioe_handle = Nothing,+      IOE.ioe_type = ty,+      IOE.ioe_location = "Network.Socket.recvBuf",+      IOE.ioe_description = description,+      IOE.ioe_errno = Just n,+      IOE.ioe_filename = Nothing+    }++-- | The canonical mid-stream reset: the peer sent RST while the+-- response body was still arriving.+connectionReset :: IOE.IOException+connectionReset = socketError IOE.ResourceVanished eCONNRESET "Connection reset by peer"++assertTransient :: BaikaiError -> Assertion+assertTransient be = do+  category be @?= TransientError+  isRetryable be @?= True++assertNotRetryable :: ErrorCategory -> BaikaiError -> Assertion+assertNotRetryable expected be = do+  category be @?= expected+  isRetryable be @?= False++assertJustTransient :: Maybe BaikaiError -> Assertion+assertJustTransient = \case+  Just be -> assertTransient be+  Nothing -> assertFailure "expected a classified transport failure, got Nothing"++-- ============================================================+-- Raw IOExceptions+-- ============================================================++ioTests :: [TestTree]+ioTests =+  [ testCase "a connection reset during the body read is transient" $+      assertJustTransient (classifyIOException connectionReset),+    -- base maps ECONNABORTED to the IOErrorType constructor named+    -- OtherError, so a rule that looked only at the type would call an+    -- aborted connection a programming error.+    testCase "ECONNABORTED is recognised by errno when the error type is OtherError" $+      assertJustTransient+        ( classifyIOException+            (socketError IOE.OtherError eCONNABORTED "Software caused connection abort")+        ),+    testCase "an end-of-file on the socket is transient" $+      assertJustTransient+        ( classifyIOException+            (IOE.IOError Nothing IOE.EOF "brRead" "end of input" Nothing Nothing)+        ),+    testCase "a timed-out read is transient" $+      assertJustTransient+        ( classifyIOException+            (IOE.IOError Nothing IOE.TimeExpired "recv" "operation timed out" Nothing Nothing)+        ),+    testCase "a userError is not a transport failure" $ do+      classifyIOException (userError "bug") @?= Nothing+      classifyTransportException (toException (userError "bug")) @?= Nothing,+    testCase "a missing file is not a transport failure" $+      classifyIOException+        (IOE.IOError Nothing IOE.NoSuchThing "openFile" "does not exist" Nothing (Just "/nope"))+        @?= Nothing,+    testCase "the classified message keeps the socket detail" $+      case classifyIOException connectionReset of+        Just be -> assertBool "message names the reset" ("reset by peer" `Text.isInfixOf` message be)+        Nothing -> assertFailure "expected a classified transport failure"+  ]++-- ============================================================+-- HttpExceptionContent+-- ============================================================++httpContentTests :: [TestTree]+httpContentTests =+  [ testCase "InvalidChunkHeaders is transient" $+      assertTransient (classifyHttpExceptionContent HTTP.InvalidChunkHeaders),+    testCase "ResponseBodyTooShort is transient" $+      assertTransient (classifyHttpExceptionContent (HTTP.ResponseBodyTooShort 100 40)),+    testCase "ConnectionClosed is transient" $+      assertTransient (classifyHttpExceptionContent HTTP.ConnectionClosed),+    testCase "IncompleteHeaders is transient" $+      assertTransient (classifyHttpExceptionContent HTTP.IncompleteHeaders),+    testCase "NoResponseDataReceived is transient" $+      assertTransient (classifyHttpExceptionContent HTTP.NoResponseDataReceived),+    testCase "ConnectionTimeout and ResponseTimeout are transient" $ do+      assertTransient (classifyHttpExceptionContent HTTP.ConnectionTimeout)+      assertTransient (classifyHttpExceptionContent HTTP.ResponseTimeout),+    testCase "ConnectionFailure is transient" $+      assertTransient+        (classifyHttpExceptionContent (HTTP.ConnectionFailure (toException connectionReset))),+    testCase "InternalException unwraps to the inner socket rule" $+      assertTransient+        (classifyHttpExceptionContent (HTTP.InternalException (toException connectionReset))),+    testCase "InternalException unwraps to the inner TLS rule" $+      assertNotRetryable+        OtherError+        ( classifyHttpExceptionContent+            ( HTTP.InternalException+                (toException (TLS.HandshakeFailed (TLS.Error_Misc "certificate rejected")))+            )+        ),+    testCase "InvalidUrlException is InvalidRequest" $+      assertNotRetryable+        InvalidRequest+        (classifyHttpException (HTTP.InvalidUrlException "http://%%%" "invalid escape")),+    testCase "InvalidRequestHeader is InvalidRequest" $+      assertNotRetryable+        InvalidRequest+        (classifyHttpExceptionContent (HTTP.InvalidRequestHeader "X-Bad: \n")),+    testCase "InvalidDestinationHost is InvalidRequest" $+      assertNotRetryable+        InvalidRequest+        (classifyHttpExceptionContent (HTTP.InvalidDestinationHost "bad host")),+    testCase "WrongRequestBodyStreamSize is InvalidRequest" $+      assertNotRetryable+        InvalidRequest+        (classifyHttpExceptionContent (HTTP.WrongRequestBodyStreamSize 10 4)),+    -- Unreachable from baikai's own transports, which never install+    -- throwErrorStatusCodes; pinned for third-party providers built on+    -- http-client, and because it is the one arm that reads headers.+    testCase "StatusCodeException classifies by status and converts an HTTP-date Retry-After" $ do+      let be =+            classifyHttpExceptionContent+              ( HTTP.StatusCodeException+                  ( statusResponse+                      429+                      [ ("Retry-After", "Wed, 21 Oct 2026 07:28:00 GMT"),+                        ("Date", "Wed, 21 Oct 2026 07:27:15 GMT")+                      ]+                  )+                  "slow down"+              )+      category be @?= RateLimited+      httpStatus be @?= Just 429+      retryAfterSeconds be @?= Just 45,+    testCase "StatusCodeException falls back to the integer form when there is no Date" $ do+      let be =+            classifyHttpExceptionContent+              (HTTP.StatusCodeException (statusResponse 429 [("Retry-After", "9")]) "")+      retryAfterSeconds be @?= Just 9,+    -- A server that does not speak HTTP, or a proxy or TLS setup that+    -- cannot work, will answer the retry exactly the same way.+    testCase "InvalidStatusLine, TooManyHeaderFields and TlsNotSupported are not retryable" $ do+      assertNotRetryable OtherError (classifyHttpExceptionContent (HTTP.InvalidStatusLine "gibberish"))+      assertNotRetryable OtherError (classifyHttpExceptionContent HTTP.TooManyHeaderFields)+      assertNotRetryable OtherError (classifyHttpExceptionContent HTTP.TlsNotSupported)+      assertNotRetryable OtherError (classifyHttpExceptionContent (HTTP.TooManyRedirects []))+  ]++-- | The header-carrying half of a 'HTTP.StatusCodeException': the body+-- travels separately, so the response's own body is @()@.+statusResponse :: Int -> [(ByteString, ByteString)] -> HTTP.Response ()+statusResponse status hdrs =+  HTTPI.Response+    { HTTPI.responseStatus = mkStatus status "",+      HTTPI.responseVersion = http11,+      HTTPI.responseHeaders = [(CI.mk n, v) | (n, v) <- hdrs],+      HTTPI.responseBody = (),+      HTTPI.responseCookieJar = HTTP.createCookieJar [],+      HTTPI.responseClose' = HTTPI.ResponseClose (pure ()),+      HTTPI.responseOriginalRequest = HTTP.defaultRequest,+      HTTPI.responseEarlyHints = []+    }++-- ============================================================+-- TLS+-- ============================================================++tlsTests :: [TestTree]+tlsTests =+  [ -- Upstream's own manager agrees: http-client-tls treats a+    -- post-handshake EOF as retryable.+    testCase "a TLS end-of-file after the handshake is transient" $+      assertTransient (classifyTlsException (TLS.PostHandshake TLS.Error_EOF)),+    testCase "a terminated TLS session is transient" $+      assertTransient (classifyTlsException (TLS.Terminated True "peer closed" TLS.Error_EOF)),+    testCase "an uncontextualized TLS failure is transient" $+      assertTransient (classifyTlsException (TLS.Uncontextualized TLS.Error_EOF)),+    -- Against a well-known API host a handshake failure is a trust-store+    -- or protocol mismatch, which the retry reproduces. A socket reset+    -- during connect arrives as ConnectionFailure instead, and is+    -- transient.+    testCase "a failed TLS handshake is not retryable" $+      assertNotRetryable+        OtherError+        (classifyTlsException (TLS.HandshakeFailed (TLS.Error_Misc "certificate rejected"))),+    testCase "a session that never existed is not retryable" $ do+      assertNotRetryable OtherError (classifyTlsException TLS.ConnectionNotEstablished)+      assertNotRetryable OtherError (classifyTlsException TLS.MissingHandshake)+  ]++-- ============================================================+-- Dispatch+-- ============================================================++dispatchTests :: [TestTree]+dispatchTests =+  [ testCase "a raw IOException reaches the socket rule" $+      assertJustTransient (classifyTransportException (toException connectionReset)),+    -- This is the shape that reaches a worker raw: http-client wraps the+    -- body reader with nothing that would convert it.+    testCase "a raw TLSException reaches the TLS rule" $+      assertJustTransient+        (classifyTransportException (toException (TLS.PostHandshake TLS.Error_EOF))),+    testCase "an HttpException reaches the http-client rule" $+      assertJustTransient+        ( classifyTransportException+            (toException (HTTP.HttpExceptionRequest HTTP.defaultRequest HTTP.InvalidChunkHeaders))+        ),+    testCase "anything else is not a transport failure" $+      classifyTransportException (toException (userError "callback bug")) @?= Nothing+  ]
+ test/UrlSpec.hs view
@@ -0,0 +1,275 @@+-- | The one URL parser, and the three decisions that hang off it: which+-- API key a base URL resolves, which compatibility record it selects,+-- and what an evidence record calls the endpoint.+--+-- The cases that matter most are the negative ones. baikai routes a+-- credential by host name, so a parser that can be talked into naming+-- the wrong host is a parser that can be talked into sending one+-- provider's key to another.+module UrlSpec (urlTests) where++import Baikai+  ( autoDetectAnthropicMessages,+    autoDetectOpenAICompletions,+    defaultAnthropicMessagesCompat,+    defaultApiKeyEnvForBaseUrl,+    defaultOpenAICompletionsCompat,+  )+import Baikai.Evidence.Build (sanitizeEndpoint)+import Baikai.Http qualified as Http+import Baikai.Url+  ( UrlParts (..),+    baseUrlProblem,+    parseUrl,+    renderEndpoint,+    stripApiVersion,+    urlHost,+  )+import Control.Monad (forM_)+import Data.Text (Text)+import Data.Text qualified as Text+import Servant.Client qualified as Client+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++urlTests :: TestTree+urlTests =+  testGroup+    "Baikai.Url"+    [ authorityBoundaryTests,+      hostAndPortTests,+      renderingTests,+      stripApiVersionTests,+      baseUrlProblemTests,+      canonicalBaseUrlTests+    ]++-- --------------------------------------------------------------------+-- Where the authority ends+-- --------------------------------------------------------------------++-- | The defect this module exists for. Reading the text after the last+-- @\@@ anywhere in a URL lets anyone who can set @baseUrl@ choose which+-- provider's key baikai sends — and send it to their own host.+authorityBoundaryTests :: TestTree+authorityBoundaryTests =+  testGroup+    "the authority ends at the first /, ? or #"+    [ testCase "an @ in the query does not rename the host" $ do+        let url = "https://proxy.example.com/v1?u=@api.openai.com"+        urlHost url @?= Just "proxy.example.com"+        -- The consequences, asserted rather than assumed: no key is+        -- resolved for an unknown host, and no vendor compat record is+        -- selected for it either.+        defaultApiKeyEnvForBaseUrl url @?= Nothing+        assertBool+          "no OpenAI compat record for a proxy host"+          (autoDetectOpenAICompletions url == defaultOpenAICompletionsCompat)+        assertBool+          "no vendor Anthropic compat record for a proxy host"+          (autoDetectAnthropicMessages url == defaultAnthropicMessagesCompat),+      testCase "an @ in a query with no path does not rename the host" $+        -- The case the evidence module's own parser got wrong: it+        -- bounded the authority at the first "/" only.+        urlHost "https://proxy.example.com?u=@api.openai.com"+          @?= Just "proxy.example.com",+      testCase "an @ in a fragment does not rename the host" $+        urlHost "https://proxy.example.com#@api.openai.com"+          @?= Just "proxy.example.com",+      testCase "an @ in the path does not rename the host" $ do+        urlHost "https://api.openai.com/v1/@x" @?= Just "api.openai.com"+        defaultApiKeyEnvForBaseUrl "https://api.openai.com/v1/@x"+          @?= Just "OPENAI_API_KEY",+      testCase "real userinfo is still dropped" $ do+        let url = "https://user:pw@api.openai.com/"+        urlHost url @?= Just "api.openai.com"+        fmap hasUserInfo (parseUrl url) @?= Just True+        defaultApiKeyEnvForBaseUrl url @?= Just "OPENAI_API_KEY"+    ]++-- --------------------------------------------------------------------+-- Hosts, ports and paths+-- --------------------------------------------------------------------++hostAndPortTests :: TestTree+hostAndPortTests =+  testGroup+    "hosts, ports and paths"+    [ testCase "an IPv6 literal keeps its brackets and its port" $ do+        parts <- expectParse "http://[::1]:8080/v1"+        host parts @?= "[::1]"+        port parts @?= Just 8080+        path parts @?= "/v1",+      testCase "an IPv6 literal with no port has no port" $ do+        parts <- expectParse "https://[::1]"+        host parts @?= "[::1]"+        port parts @?= Nothing,+      testCase "the host is lower-cased and the path is not" $ do+        parts <- expectParse "https://Api.OpenAI.com:443/V1/"+        host parts @?= "api.openai.com"+        port parts @?= Just 443+        path parts @?= "/V1/",+      testCase "a non-numeric port is ignored and the host survives" $ do+        parts <- expectParse "https://api.openai.com:notaport/v1"+        host parts @?= "api.openai.com"+        port parts @?= Nothing,+      testCase "a scheme-less URL parses with no scheme" $ do+        parts <- expectParse "api.openai.com"+        scheme parts @?= Nothing+        host parts @?= "api.openai.com",+      testCase "a scheme is recognised only when it looks like one" $ do+        parts <- expectParse "HTTPS://Api.OpenAI.com"+        scheme parts @?= Just "https",+      testCase "no host means no result" $ do+        parseUrl "" @?= Nothing+        parseUrl "https://" @?= Nothing+        parseUrl "   " @?= Nothing+    ]++-- --------------------------------------------------------------------+-- Rendering an endpoint+-- --------------------------------------------------------------------++renderingTests :: TestTree+renderingTests =+  testGroup+    "rendering an endpoint"+    [ testCase "userinfo, query and fragment are gone; scheme and host are lower-cased" $ do+        let url = "https://user:pw@Host.example:8443/a/b?k=v#f"+        parts <- expectParse url+        renderEndpoint parts @?= "https://host.example:8443/a/b"+        -- The evidence record's endpoint is the same function, so the+        -- two cannot drift.+        sanitizeEndpoint url @?= Just "https://host.example:8443/a/b",+      testCase "an empty endpoint is absent rather than empty" $+        sanitizeEndpoint "" @?= Nothing+    ]++-- --------------------------------------------------------------------+-- Stripping a version segment+-- --------------------------------------------------------------------++stripApiVersionTests :: TestTree+stripApiVersionTests =+  testGroup+    "stripApiVersion removes one trailing /v1 segment"+    [ testCase "a bare version path becomes empty" $ do+        stripApiVersion "/v1" @?= ""+        stripApiVersion "/v1/" @?= ""+        stripApiVersion "/" @?= ""+        stripApiVersion "" @?= ""+        stripApiVersion "v1" @?= "",+      testCase "a mounted API keeps its prefix" $ do+        stripApiVersion "/api/v1" @?= "/api"+        stripApiVersion "/compatible-mode/v1/" @?= "/compatible-mode"+        stripApiVersion "api" @?= "/api",+      testCase "a segment that merely starts with v1 is untouched" $ do+        stripApiVersion "/v10" @?= "/v10"+        stripApiVersion "/v1beta" @?= "/v1beta"+    ]++-- --------------------------------------------------------------------+-- Fitness as a base URL+-- --------------------------------------------------------------------++baseUrlProblemTests :: TestTree+baseUrlProblemTests =+  testGroup+    "baseUrlProblem"+    [ testCase "the shapes baikai supports are accepted" $ do+        baseUrlProblem "https://api.openai.com" @?= Nothing+        baseUrlProblem "https://api.deepseek.com/v1" @?= Nothing+        baseUrlProblem "https://openrouter.ai/api" @?= Nothing+        baseUrlProblem "http://localhost:11434" @?= Nothing,+      testCase "a query string is refused without echoing it" $ do+        problem <- expectProblem "https://h.example/v1?api-version=1"+        assertBool+          ("names the problem: " <> Text.unpack problem)+          ("query string" `Text.isInfixOf` problem)+        assertBool+          ("does not echo the query: " <> Text.unpack problem)+          (not ("api-version=1" `Text.isInfixOf` problem)),+      testCase "userinfo is refused without echoing the password" $ do+        problem <- expectProblem "https://u:secret@h.example"+        assertBool+          ("names the problem: " <> Text.unpack problem)+          ("credentials" `Text.isInfixOf` problem)+        assertBool+          ("does not echo the password: " <> Text.unpack problem)+          (not ("secret" `Text.isInfixOf` problem)),+      testCase "a missing scheme is refused, saying which to use" $ do+        problem <- expectProblem "h.example"+        assertBool+          ("names the fix: " <> Text.unpack problem)+          ("https://" `Text.isInfixOf` problem),+      testCase "a scheme baikai does not send is refused" $ do+        problem <- expectProblem "ftp://h.example"+        assertBool+          ("names the scheme: " <> Text.unpack problem)+          ("ftp" `Text.isInfixOf` problem),+      testCase "a fragment is refused" $ do+        problem <- expectProblem "https://h.example/v1#frag"+        assertBool+          ("names the problem: " <> Text.unpack problem)+          ("fragment" `Text.isInfixOf` problem),+      testCase "a full endpoint URL is refused as a base URL" $ do+        forM_ ["https://h.example/v1/chat/completions", "https://h.example/v1/messages", "https://h.example/v1/embeddings"] $ \url -> do+          problem <- expectProblem url+          assertBool+            ("names the problem for " <> Text.unpack url <> ": " <> Text.unpack problem)+            ("endpoint path" `Text.isInfixOf` problem),+      testCase "text that names no host is refused" $ do+        problem <- expectProblem ""+        assertBool+          ("names the problem: " <> Text.unpack problem)+          ("no host" `Text.isInfixOf` problem)+    ]++-- --------------------------------------------------------------------+-- Helpers+-- --------------------------------------------------------------------++expectParse :: Text -> IO UrlParts+expectParse url = case parseUrl url of+  Nothing -> assertFailure ("expected " <> Text.unpack url <> " to parse")+  Just parts -> pure parts++expectProblem :: Text -> IO Text+expectProblem url = case baseUrlProblem url of+  Nothing -> assertFailure ("expected " <> Text.unpack url <> " to be refused")+  Just problem -> pure problem++-- --------------------------------------------------------------------+-- What the transports actually connect to+-- --------------------------------------------------------------------++-- | The normalisation the connection cache keys on, and the composition+-- rule the transports rely on.+canonicalBaseUrlTests :: TestTree+canonicalBaseUrlTests =+  testGroup+    "canonicalBaseUrl"+    [ testCase "a trailing /v1 and its absence are the same target" $ do+        withVersion <- expectCanonical "https://api.deepseek.com/v1"+        without <- expectCanonical "https://api.deepseek.com"+        Client.showBaseUrl withVersion @?= Client.showBaseUrl without,+      testCase "the host is lower-cased and a default port is implied" $ do+        base <- expectCanonical "https://Api.OpenAI.com:443/"+        Client.showBaseUrl base @?= "https://api.openai.com",+      testCase "a mounted API keeps its prefix without its version" $ do+        base <- expectCanonical "https://openrouter.ai/api/v1/"+        Client.baseUrlPath base @?= "/api",+      testCase "an unusable base URL is a reason, not an exception" $+        case Http.canonicalBaseUrl "h.test" of+          Right base ->+            assertFailure ("expected a refusal, got " <> Client.showBaseUrl base)+          Left problem ->+            assertBool+              ("names the fix: " <> Text.unpack problem)+              ("https://" `Text.isInfixOf` problem)+    ]++expectCanonical :: Text -> IO Client.BaseUrl+expectCanonical url = case Http.canonicalBaseUrl url of+  Left problem -> assertFailure (Text.unpack (url <> " was refused: " <> problem))+  Right base -> pure base
test/UsageSpec.hs view
@@ -1,6 +1,6 @@ module UsageSpec (tests) where -import Baikai.Cost (Cost (..), CostBreakdown (..), zeroCost, zeroCostBreakdown)+import Baikai.Cost (Cost (..), CostBreakdown (..), standardCostBasis, zeroCost, zeroCostBreakdown) import Baikai.Usage (Usage (..), sumUsage, zeroUsage) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=))@@ -35,7 +35,8 @@ costOf :: Rational -> Rational -> Rational -> Rational -> Cost costOf i o ci cw =   Cost-    { usd = (i + o + ci + cw) / 100,+    { basis = standardCostBasis,+      usd = (i + o + ci + cw) / 100,       breakdown =         CostBreakdown           { inputUsd = i / 100,