packages feed

baikai 0.5.0.0 → 0.7.0.0

raw patch · 72 files changed

Files

CHANGELOG.md view
@@ -7,125 +7,1552 @@  ## [Unreleased] -## [baikai 0.5.0.0] - 2026-08-05--### Added--- `baikai`: new exposed module `Baikai.Agent`, the provider-neutral vocabulary-  for an **unattended coding-agent run** — a run with no terminal and no human,-  which owns its own tool loop, may change files inside directories the caller-  authorized, and returns a process result rather than a `Response`. It defines-  `AgentRunRequest` (with a required `workingDir`), `AgentRunResult`, the-  `AgentCapability` profile (`read-only`, `edit-workspace`, `full-access`),-  `AgentSafety`, the `AgentOutputMode` and `AgentCapturedOutput` output-  discipline, the `AgentCommand` renderer/runner boundary with an explicit-  prompt transport, and the `AgentRenderError` / `AgentRunFailure` taxonomies.--- `baikai`: the operator policy ceiling — `AgentCeiling`,-  `defaultAgentCeiling`, `CeilingViolation`, and the pure `applyAgentCeiling`.-  It returns a request unchanged when it is within the ceiling and reports-  every violation when it is not; it never clamps an over-broad request to the-  permitted value. The default ceiling permits read-only and edit-workspace-  authority and refuses full access and raw provider arguments.--  `Baikai.Agent` itself is vocabulary and pure policy algebra only: it spawns no-  process and renders no command-line flags. Those live in the vendor packages-  and in `baikai-agent`, below. The module is deliberately not re-exported from-  the umbrella `Baikai` module, because its field accessors share names with-  `Baikai.Interactive`, so `import Baikai` continues to compile unchanged.--- `baikai`: new exposed module `Baikai.Evidence`, the vocabulary for-  **verifiable model-call evidence** — a record of what actually crossed the-  boundary to a provider, as opposed to what the process was configured to ask-  for. It defines `ModelCallEvidence` and the `evidenceSchemaVersion` string-  consumers pin against, `Observed` (a deliberate non-`Maybe` for a value the-  provider either did or did not report, with no function that supplies a-  default), `ThinkingTranslation` with its `ThinkingMode` and-  `ThinkingAdjustment` enumerations describing what a requested-  reasoning-effort level actually became on the wire and every clamp, collapse,-  or drop applied on the way, `EndpointIdentity` and `TransportKind`,-  `CallStatus`, and the ascending `EvidenceStrength` scale.--  It also provides the canonical hashing core: `canonicalEncode` gives a JSON-  value exactly one byte representation (object keys sorted, no insignificant-  whitespace, numbers normalised so `1`, `1.0`, `1.00`, and `1e0` all encode as-  `1`, and a hand-written string escaper so an aeson upgrade cannot silently-  invalidate a recorded digest); `commitmentDigest` hashes a full request-  envelope, and `configurationDigest` hashes an allow-list projection-  (`configurationProjection`) that keeps configuration and replaces content with-  structural summaries, so two calls that ask the same model the same way about-  different subjects agree. The two digests are separate on purpose: the first-  binds a record to a particular request, the second is safe to compare across-  runs that legitimately differ in content.--  Nothing constructs a `ModelCallEvidence` from a real call yet, and no existing-  behaviour changed. New dependencies: `cryptohash-sha256` and-  `base16-bytestring`, both single-purpose packages chosen over a full-  cryptographic framework.--- `baikai`: `Options` gains an `evidence` field carrying an optional-  `EvidenceRequest` — the caller's run identifier, retry provenance, and how-  strictly they need evidence. A call whose `evidence` is `Nothing`, which is-  every call that does not opt in, behaves exactly as it did before: no digest-  is computed and no evidence is emitted.--- `baikai`: model-call evidence is now **produced and emitted**. A caller who-  sets `Options.evidence` gets exactly one `call_evidence` line per call from-  their trace sink, under every way a call can end: success, provider failure, a-  consumer that abandons the stream (status `aborted`, not `failed` — an abort-  is the consumer's doing and reporting it as a provider failure would-  misattribute it), and dispatch that found no registered handler.--  New exposed module `Baikai.Evidence.Build` bridges the vocabulary to the-  `Model` and `Options` records: `minimalEvidence` and `prepareEvidence` build a-  record, `dispatchEnvelope` supplies the request envelope for the paths where-  no adapter ran, `sanitizeEndpoint` reduces a base URL to scheme/host/port/path-  with the query string and any userinfo dropped wholesale, and `onSinkFailure`-  is the hook a future release replaces to make a strict caller's call fail when-  the trace sink does.--  Every record this release produces has `strength` `requested_only` and every-  provider-observed field set to `"unobserved"`. That is not a placeholder: it-  is a truthful record for a transport that has not yet been taught to observe-  anything. Later releases teach each transport to observe more.--  **A caller who does not opt in pays nothing.** With `Options.evidence` absent-  no digest is computed, no call identifier is generated, no evidence event is-  emitted, and the request envelope is never even forced — the gate lives inside-  the shared builder rather than at each adapter's call site, and the envelope-  parameter is deliberately lazy. Both facts are guarded by tests.--- `baikai`: `TraceEvent` gains a `CallEvidence` constructor, encoded as-  `{"kind":"call_evidence", …}`. A consumer whose pattern match over `TraceEvent`-  is exhaustive must add a branch; one with a wildcard is unaffected. Filter for-  it with `jq 'select(.kind == "call_evidence") | .evidence'`. Note that a trace-  line carries its fields alongside the `kind` discriminator rather than nested-  under a `data` key, and that the evidence record inside spells its own fields-  in snake_case — the two encodings differ deliberately, because an evidence-  record must render an absent field as explicit `null` while a trace line drops-  it to stay small.--- `baikai`: `Baikai.Provider.Cli.Internal` — the module the two subprocess-  providers share — gains the vocabulary for reading what a coding-agent CLI-  reported about its own run. `CodexRunReport` and the new-  `parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport` fold the-  `codex exec --json` event stream into its assistant text, its thread-  identifier, and its token counts, instead of concatenating agent-message text-  and discarding everything else. `ClaudeCliReport` and-  `decodeClaudeCliResult` do the same for `claude -p --output-format json`.-  Every field but the message text is optional, because both tools' event-  schemas have changed across versions and an absent field is a genuine absence-  rather than a parse failure. **Breaking** for anyone calling-  `parseCodexJsonlStream` directly: its result type is no longer `Text`. This is-  an internal module and is documented as outside the PVP guarantee.--- `baikai`: `Baikai.Provider.Cli.Internal` also gains `ExecutableIdentity` and-  `executableIdentity`, which resolve a configured executable name to an-  absolute path and read the tool's own `--version` line. The probe is cached-  per resolved name for the lifetime of the process, because spawning it per-  model call would roughly double the process cost of the cheapest possible-  call, and it is bounded by a two-second timeout so a tool that hangs on-  `--version` cannot wedge a model call. A probe that fails records the version+## [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
baikai.cabal view
@@ -1,6 +1,6 @@ cabal-version:   3.4 name:            baikai-version:         0.5.0.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@@ -67,6 +68,8 @@     Baikai.Error     Baikai.Evidence     Baikai.Evidence.Build+    Baikai.Header+    Baikai.Http     Baikai.Interactive     Baikai.Message     Baikai.Model@@ -75,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@@ -86,7 +92,9 @@     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,@@ -100,19 +108,26 @@     , 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 @@ -152,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@@ -180,11 +195,16 @@     GenModelsSpec     HelpersSpec     InteractiveSpec+    PricingPolicySpec+    PublicSurfaceSpec     StreamSpec+    StreamWorkerSpec     StrictEvidenceSpec     SurfaceSpec     ThinkingLevelSpec     TraceSpec+    TransportClassifySpec+    UrlSpec     UsageSpec    build-tool-depends: baikai:baikai-gen-models@@ -193,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@@ -209,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,@@ -36,6 +37,7 @@      -- * Per-API compat shims and call-time options     module Baikai.Compat,+    module Baikai.Speed,     module Baikai.CacheRetention,     module Baikai.ResponseFormat,     module Baikai.ThinkingLevel,@@ -60,6 +62,7 @@ import Baikai.Error import Baikai.Evidence import Baikai.Evidence.Build+import Baikai.Header import Baikai.Interactive import Baikai.Message import Baikai.Model@@ -67,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
@@ -36,6 +36,9 @@     AgentOutputMode (..),     renderAgentOutputMode,     parseAgentOutputMode,+    AgentOutputFormat (..),+    renderAgentOutputFormat,+    parseAgentOutputFormat,     AgentCapturedOutput (..),     capturedBytes, @@ -50,24 +53,35 @@         safety,         timeout,         output,+        outputFormat,         outputLimit,-        envPassthrough+        envRequires       ),     agentRunRequest,      -- * The operator policy ceiling-    AgentCeiling (maxCapability, allowProviderArgs, allowedProviders),+    AgentCeiling+      ( maxCapability,+        allowProviderArgs,+        allowedProviders,+        allowedTools,+        maxTimeout,+        maxOutputLimit+      ),     defaultAgentCeiling,+    defaultMaxOutputLimit,+    toolGrantsImpliedBy,     CeilingViolation (..),     renderCeilingViolation,     applyAgentCeiling,+    ceilingViolations,      -- * The rendered command     AgentPromptTransport (..),     AgentCommand (..),      -- * The run result-    AgentRunResult,+    AgentRunResult (provider, exitCode, stdout, stderr, duration),     agentRunResult,     AgentRunOutcome (..),     agentRunOutcome,@@ -76,6 +90,7 @@     AgentRenderError (..),     renderAgentRenderError,     AgentRunFailure (..),+    AgentTimedOut (..),     renderAgentRunFailure,   ) where@@ -142,10 +157,21 @@ data AgentSafety = AgentSafety   { -- | How much filesystem authority the run requests.     capability :: !AgentCapability,-    -- | Optional narrowing of the provider's tool set. An empty list-    -- means \"do not restrict tools beyond what the capability-    -- implies\"; a non-empty list is rendered where the provider-    -- supports a tool allow-list.+    -- | 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@@ -158,8 +184,8 @@   }   deriving stock (Eq, Show, Generic) --- | A safety request for the given capability, with no tool narrowing--- and no raw provider arguments.+-- | 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@@ -194,6 +220,38 @@ 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@@ -245,6 +303,8 @@     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),@@ -258,7 +318,7 @@     -- fails before spawning when a declared variable is unset or     -- empty, so a misconfigured job produces one clear error instead     -- of a coding agent that starts and then flails.-    envPassthrough :: ![Text]+    envRequires :: ![Text]   }   deriving stock (Eq, Show, Generic) @@ -266,8 +326,8 @@ -- working directory, with the given prompt. Everything else defaults -- to the least-authority, least-surprising value: no model or effort -- override, no extra directories, read-only capability, no timeout,--- inherited output, no output limit, and no declared environment--- variables.+-- 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@@ -284,8 +344,9 @@       safety = agentSafety AgentReadOnly,       timeout = Nothing,       output = InheritOutput,+      outputFormat = TextFormat,       outputLimit = Nothing,-      envPassthrough = []+      envRequires = []     }  -- | The limit an operator places on what any job may request.@@ -304,7 +365,21 @@     allowProviderArgs :: !Bool,     -- | The providers jobs may select. An empty list permits __no__     -- provider; it does not mean \"all providers\".-    allowedProviders :: ![AgentProvider]+    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) @@ -323,9 +398,53 @@   AgentCeiling     { maxCapability = AgentEditWorkspace,       allowProviderArgs = False,-      allowedProviders = [AgentClaude, AgentCodex]+      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@@ -346,6 +465,31 @@     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@@ -368,7 +512,56 @@   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.@@ -384,28 +577,68 @@ -- 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-    violations =-      concat-        [ [ ProviderForbidden requestedProvider permittedProviders-          | requestedProvider `notElem` permittedProviders-          ],-          [ CapabilityExceeded requestedCapability permittedCapability-          | requestedCapability > permittedCapability-          ],-          [ ProviderArgsForbidden requestedArgs-          | not (null requestedArgs),-            not (limit ^. #allowProviderArgs)-          ]+    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.@@ -458,6 +691,8 @@ -- 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,@@ -563,6 +798,28 @@   "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. --@@ -575,16 +832,16 @@     -- not installed\" from \"the tool is installed but the working     -- directory does not exist\".     SpawnFailed !FilePath !Text-  | -- | The run exceeded this limit and was terminated.-    RunTimedOut !NominalDiffTime-  | -- | Every variable named in the request's 'envPassthrough' that is+  | -- | 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 run produced output the caller could not interpret.-    OutputMalformed !Text   | -- | The caller required evidence this configuration cannot produce,     -- so nothing was started. Carries one rendered explanation per     -- reason, from@@ -601,16 +858,14 @@ renderAgentRunFailure :: AgentRunFailure -> Text renderAgentRunFailure (SpawnFailed path message) =   "could not start " <> Text.pack path <> ": " <> message-renderAgentRunFailure (RunTimedOut limit) =-  "the run exceeded its timeout of " <> Text.pack (show limit)+renderAgentRunFailure (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 (OutputMalformed why) =-  "the run produced malformed output: " <> why renderAgentRunFailure (EvidenceRefused reasons) =   "refused before starting, because this run cannot produce the evidence it \   \required: "
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@@ -79,12 +92,16 @@   = -- | OpenAI-native: top-level @reasoning_effort: "minimal" | "low"     --   | "medium" | "high" | "xhigh" | "max"@.     ---    --   This shape sends the canonical baikai level verbatim. The other-    --   six route through @Baikai.Provider.OpenAI.Shape.compatibleEffort@,-    --   which clamps @minimal@ to @low@ and both @xhigh@ and @max@ to-    --   @high@ — a lowest-common-denominator vocabulary for hosts that-    --   do not accept the full one. The exclusion is deliberate and-    --   guarded by @nativeHigherEffortTests@ in+    --   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@@ -138,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,@@ -147,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.@@ -167,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@@ -186,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.@@ -209,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@@ -223,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@@ -298,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.@@ -181,6 +219,9 @@             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,             -- A zero cost is reported as zero. The other entry-building             -- site ('Baikai.Trace.runRequestWithRegistry') used to
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
@@ -29,7 +29,31 @@     evidenceSchemaVersion,      -- * The evidence record-    ModelCallEvidence (..),+    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@@ -40,7 +64,9 @@     ThinkingTranslation (..),     ThinkingMode (..),     ThinkingAdjustment (..),+    weakensThinking,     noThinkingRequested,+    untranslatedThinking,      -- * Endpoint and transport     EndpointIdentity (..),@@ -50,14 +76,17 @@     CallStatus (..),     EvidenceStrength (..),     renderEvidenceStrength,+    parseEvidenceStrength,     declaredStrength,+    deriveStrength,      -- * The caller's request-    EvidenceRequest (..),+    EvidenceRequest (runId, strictness, attempt, supersedes),     EvidenceStrictness (..),     evidenceRequest,      -- * Canonical encoding and digests+    usageEnvelope,     canonicalEncode,     commitmentDigest,     configurationDigest,@@ -70,8 +99,9 @@  import Baikai.Api (Api (..)) import Baikai.Error (BaikaiError)-import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel)+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@@ -91,7 +121,7 @@   ) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap-import Data.Aeson.Types (typeMismatch)+import Data.Aeson.Types (Parser, typeMismatch) import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString@@ -172,7 +202,7 @@ -- | Which shape a provider's thinking configuration took on the wire. -- -- Encodes as a lowercase string: @budget@, @adaptive@, @flag@,--- @toggle@, @unsupported@, @absent@.+-- @toggle@, @unsupported@, @not_translated@, @absent@. data ThinkingMode   = -- | The provider took an explicit token budget.     ThinkingModeBudget@@ -185,6 +215,13 @@   | -- | 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)@@ -196,6 +233,7 @@   ThinkingModeFlag -> "flag"   ThinkingModeToggle -> "toggle"   ThinkingModeUnsupported -> "unsupported"+  ThinkingModeNotTranslated -> "not_translated"   ThinkingModeAbsent -> "absent"  parseThinkingMode :: Text -> Maybe ThinkingMode@@ -205,6 +243,7 @@   "flag" -> Just ThinkingModeFlag   "toggle" -> Just ThinkingModeToggle   "unsupported" -> Just ThinkingModeUnsupported+  "not_translated" -> Just ThinkingModeNotTranslated   "absent" -> Just ThinkingModeAbsent   _ -> Nothing @@ -220,13 +259,20 @@ -- between the canonical 'ThinkingLevel' and the wire. -- -- This is the type that makes an otherwise silent downgrade visible.--- Every constructor corresponds to a real site in this repository--- where a request is weakened, dropped, or made indistinguishable from--- the provider's own default.+-- 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.@@ -248,8 +294,45 @@     -- 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.@@ -270,28 +353,49 @@         "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"-      lvl <- o .: "requested" >>= parseThinkingLevelText+      let withLevel :: (ThinkingLevel -> Parser ThinkingAdjustment) -> Parser ThinkingAdjustment+          withLevel k = o .: "requested" >>= parseThinkingLevelText >>= k       case kind :: Text of-        "effort_clamped" -> EffortClamped lvl <$> o .: "wire"-        "effort_collapsed_to_toggle" -> pure (EffortCollapsedToToggle lvl)-        "effort_omitted" -> pure (EffortOmitted lvl)+        "effort_clamped" -> withLevel $ \lvl -> EffortClamped lvl <$> o .: "wire"+        "effort_collapsed_to_toggle" -> withLevel (pure . EffortCollapsedToToggle)+        "effort_omitted" -> withLevel (pure . EffortOmitted)         "thinking_dropped_unsupported_model" ->-          pure (ThinkingDroppedUnsupportedModel lvl)+          withLevel (pure . ThinkingDroppedUnsupportedModel)         "thinking_dropped_unsupported_host" ->-          pure (ThinkingDroppedUnsupportedHost lvl)+          withLevel (pure . ThinkingDroppedUnsupportedHost)         "thinking_dropped_budget_exceeded" ->-          ThinkingDroppedBudgetExceeded lvl <$> o .: "budget_tokens" <*> o .: "max_tokens"+          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 @@ -301,15 +405,13 @@ -- 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 = \case-  "minimal" -> pure ThinkingMinimal-  "low" -> pure ThinkingLow-  "medium" -> pure ThinkingMedium-  "high" -> pure ThinkingHigh-  "xhigh" -> pure ThinkingXHigh-  "max" -> pure ThinkingMax-  other -> fail ("unknown thinking level: " <> show other)+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.@@ -333,9 +435,20 @@     -- 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. Empty means the-    -- request was expressed exactly.+    -- 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)@@ -343,13 +456,15 @@ 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-      ]+      ( [ "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@@ -361,6 +476,7 @@         <*> o .:? "effort_text"         <*> o .:? "budget_tokens"         <*> o .:? "wire_field"+        <*> o .:? "display_text"         <*> o .: "adjustments"     v -> typeMismatch "ThinkingTranslation" v @@ -368,6 +484,12 @@ -- 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@@ -376,9 +498,53 @@       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 -- ============================================================@@ -522,16 +688,23 @@   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" $ \case-    "requested_only" -> pure EvidenceRequestedOnly-    "correlated" -> pure EvidenceCorrelated-    "model_observed" -> pure EvidenceModelObserved-    "fully_observed" -> pure EvidenceFullyObserved-    other -> fail ("unknown evidence strength: " <> show other)+  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.@@ -569,10 +742,50 @@ -- -- * '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@@ -619,6 +832,9 @@ -- 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.@@ -662,14 +878,55 @@ -- 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-evidenceSchemaVersion = "baikai.model-call-evidence/1.0"+-- 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 ------------------------------------------------------- @@ -981,13 +1238,25 @@ -- the digest until someone adds it here, which loses fidelity rather -- than leaking. ----- Keys outside the list are dropped entirely. Three keys are kept but+-- 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, so descriptions and JSON schemas do not survive.+-- 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.@@ -1000,6 +1269,8 @@       "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 -> []@@ -1016,12 +1287,11 @@       "max_completion_tokens",       "max_tokens",       "model",-      "output_config",       "presence_penalty",       "reasoning",       "reasoning_effort",-      "response_format",       "seed",+      "speed",       "stop_sequences",       "stream",       "temperature",@@ -1074,6 +1344,56 @@ -- 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)
src/Baikai/Evidence/Build.hs view
@@ -16,10 +16,14 @@ -- cannot forget it. module Baikai.Evidence.Build   ( minimalEvidence,+    minimalEvidenceAt,     prepareEvidence,+    prepareEvidenceAt,     endpointIdentity,+    endpointIdentityAt,     sanitizeEndpoint,     dispatchEnvelope,+    requestedTranslation,     transportForModel,     baikaiPackageVersion, @@ -28,6 +32,10 @@     sinkFailureIsFatal,     sinkFailureError, +    -- * Strict mode+    strictnessOf,+    missingEvidenceError,+     -- * The pre-dispatch strictness gate     EvidenceRefusal (..),     renderEvidenceRefusal,@@ -50,14 +58,16 @@     baseEvidence,     commitmentDigest,     configurationDigest,-    declaredStrength,     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)@@ -125,8 +135,36 @@   -- documentation rather than enforced by the type.   Maybe BaikaiError ->   IO (Maybe ModelCallEvidence)-minimalEvidence m opts transport translation envelope started ended st err = do-  mk <- prepareEvidence m opts transport translation envelope started+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@@ -154,12 +192,30 @@   -- | Started at.   UTCTime ->   IO (Maybe (UTCTime -> CallStatus -> Maybe BaikaiError -> ModelCallEvidence))-prepareEvidence m opts transport translation envelope started =+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 = endpointIdentity m transport+      let ep = endpointIdentityAt baseUrl m transport           commitment = commitmentDigest envelope           configuration = configurationDigest envelope       pure $@@ -179,6 +235,40 @@             { 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@@ -186,53 +276,43 @@ -- executable, but neither fact is available to the core, and inventing -- one would be worse than admitting the gap. endpointIdentity :: Model -> TransportKind -> EndpointIdentity-endpointIdentity m transport =+endpointIdentity 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 (m ^. #baseUrl),+      endpoint = sanitizeEndpoint baseUrl,       baikaiVersion = baikaiPackageVersion,       implementationVersion = Nothing     }  -- | Reduce a base URL to scheme, host, port, and path. ----- The query string is dropped __wholesale__ rather than filtered field--- by field, because some gateways carry an API key in a query--- parameter and an allow-list of safe parameter names would be wrong--- the first time a host invented one. Any @userinfo@ component--- (@https:\/\/user:secret\@host\/@) is dropped for the same reason. A--- fragment cannot carry a credential to a server but is dropped too,--- since it is never part of what was requested.+-- 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 raw-  | Text.null trimmed = Nothing-  | Text.null cleaned = Nothing-  | otherwise = Just cleaned-  where-    trimmed = Text.strip raw-    withoutFragment = Text.takeWhile (/= '#') trimmed-    withoutQuery = Text.takeWhile (/= '?') withoutFragment-    cleaned = dropUserInfo withoutQuery---- | Drop a @user:password\@@ prefix from the authority component,--- keeping the scheme. Splits on the last @\@@ before the first @\/@ of--- the path so that an @\@@ later in the path is not mistaken for--- userinfo.-dropUserInfo :: Text -> Text-dropUserInfo url =-  let (scheme, rest) = case Text.breakOn "://" url of-        (s, r) | not (Text.null r) -> (s <> "://", Text.drop 3 r)-        _ -> ("", url)-      (authority, path) = Text.break (== '/') rest-   in case Text.breakOnEnd "@" authority of-        (before, after) | not (Text.null before) -> scheme <> after <> path-        _ -> scheme <> authority <> path+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@@ -305,10 +385,13 @@     "the reasoning-effort request would not reach the provider as asked: "       <> Text.intercalate "; " (map describeAdjustment adjustments) --- | One downgrade, in words. These are the six places baikai weakens a+-- | 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.+-- 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 ->@@ -332,6 +415,14 @@       <> 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.@@ -355,22 +446,37 @@ -- The downgrade rule needs one judgement stated, because it is not -- obvious. A caller who requested no level at all is never downgraded — -- there is nothing to weaken, and 'Baikai.Evidence.noThinkingRequested'--- carries no adjustments, so this falls out. But /every/ non-empty--- adjustment list refuses, including+-- 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 -> Api -> ThinkingTranslation -> [EvidenceRefusal]+  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) api translation =+checkEvidenceRequirements (EvidenceRequired needed) declared translation =   [StrengthUnreachable needed declared | declared < needed]     <> [ThinkingWouldDowngrade downgrades | not (null downgrades)]   where-    declared = declaredStrength api-    downgrades = adjustments translation+    downgrades = filter weakensThinking (adjustments translation)  -- | Turn a non-empty refusal list into the error the call fails with. --@@ -425,10 +531,18 @@ -- 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 written: "+      \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,24 @@ -- 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@@ -51,6 +56,7 @@     toolChoice,     cacheRetention,     thinking,+    speed,     responseFormat,     evidence,     topP,@@ -59,21 +65,28 @@     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) @@ -82,22 +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@@ -109,16 +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
@@ -40,9 +40,9 @@     UserContent (..),   ) import Baikai.Context (Context)-import Baikai.Cost (Cost (..), zeroCost, zeroCostBreakdown)+import Baikai.Cost (Cost (..), providerReportedBasis, zeroCost, zeroCostBreakdown) import Baikai.Error (BaikaiError, decodeError)-import Baikai.Evidence (EvidenceStrength (..), Observed (..))+import Baikai.Evidence (EvidenceStrength (..), Observed (..), deriveStrength, usageEnvelope) import Baikai.Message   ( AssistantPayload (..),     Message (..),@@ -87,7 +87,6 @@ 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)@@ -242,16 +241,26 @@ -- 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.+-- 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-  let bytes :: Stream IO Word8-      bytes = Stream.unfoldEach Unfold.fromList (fmap BS.unpack chunks)-      lineFold = Fold.takeEndBy_ (== newlineByte) (Fold.foldl' BS.snoc BS.empty)-  acc <--    Stream.foldMany lineFold bytes-      & Stream.mapMaybe Aeson.decodeStrict-      & Stream.fold (Fold.foldl' absorbCodexEvent emptyCodexAccumulator)+  (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)),@@ -259,6 +268,15 @@         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. --@@ -400,6 +418,7 @@           cacheWriteTokens = written,           reasoningTokens = natFieldMaybe u "reasoning_output_tokens",           totalTokens = nonCached + out + cached + written,+          availability = Nothing,           cost = zeroCost         } @@ -520,12 +539,13 @@                   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}+      Just (Number n) | n >= 0 -> Cost {usd = toRational n, breakdown = zeroCostBreakdown, basis = providerReportedBasis}       _ -> zeroCost  claudeUsageKeys :: [Key]@@ -711,7 +731,8 @@   Aeson.object     [ "content" .= Vector.singleton (AssistantText (TextContent body)),       "stop_reason" .= Stop,-      "usage" .= used+      -- Token counts only; see 'Evidence.usageEnvelope'.+      "usage" .= usageEnvelope used     ]  -- | How much a subprocess call's evidence proves.@@ -722,6 +743,12 @@ -- 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 ->@@ -729,7 +756,4 @@   Observed Text ->   EvidenceStrength subprocessStrength sessionIdentifier reported =-  case (reported, sessionIdentifier) of-    (Observed _, Observed _) -> EvidenceModelObserved-    (_, Observed _) -> EvidenceCorrelated-    _ -> EvidenceRequestedOnly+  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,@@ -26,17 +30,19 @@     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.Evidence (ThinkingTranslation, noThinkingRequested)+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)@@ -57,12 +63,18 @@ 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),@@ -80,9 +92,68 @@     --     -- 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)+    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@@ -112,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 ()@@ -140,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.@@ -156,21 +239,21 @@   mProvider <- lookupApiProviderWith reg (Model.api m)   case mProvider of     Just p -> case evidenceRefusals p m opts of-      [] -> complete p m ctx opts+      [] -> requireEvidenceOnResponse opts <$> complete p m ctx opts       refusals -> refusedResponse m opts (describeThinking p m opts) refusals     Nothing -> do       now <- getCurrentTime       -- "No provider was registered" is a fact about the call, so a       -- caller who asked for evidence gets a record of it. Nothing was       -- sent, so the digests are over 'Build.dispatchEnvelope'.-      let detail = "No provider registered for API: " <> renderApi (Model.api m)+      let detail = "No provider registered for API: " <> describeApi (Model.api m)           err = providerUnavailable detail       ev <-         Build.minimalEvidence           m           opts           (Build.transportForModel m)-          noThinkingRequested+          (Build.requestedTranslation opts)           (Build.dispatchEnvelope m opts)           now           now@@ -179,6 +262,39 @@       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. --@@ -194,7 +310,7 @@   Just req ->     Build.checkEvidenceRequirements       (Evidence.strictness req)-      (Model.api m)+      (strengthCeiling p)       (describeThinking p m opts)  -- | The error-shaped response a refused call returns.@@ -250,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 ->@@ -269,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,@@ -68,7 +67,7 @@   }   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@@ -140,7 +139,3 @@       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,7 +36,7 @@ import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Error (BaikaiError, providerError, providerUnavailable)-import Baikai.Evidence (ModelCallEvidence, noThinkingRequested)+import Baikai.Evidence (ModelCallEvidence) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), Message (AssistantMessage))@@ -46,6 +46,7 @@ import Baikai.Provider.Registry   ( ApiProvider (..),     ProviderRegistry,+    describeApi,     evidenceRefusals,     globalProviderRegistry,     lookupApiProviderWith,@@ -94,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 ->@@ -107,9 +109,15 @@     case mProvider of       Nothing -> Stream.fromList <$> noProviderEvents m opts       Just p -> case evidenceRefusals p m opts of-        [] -> pure (stream p m ctx opts)+        [] -> 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'@@ -182,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),@@ -223,61 +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, 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)+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@@ -303,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',@@ -341,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@@ -467,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@@ -556,7 +586,7 @@       m       opts       (Build.transportForModel m)-      noThinkingRequested+      (Build.requestedTranslation opts)       (Build.dispatchEnvelope m opts)       startTs       now@@ -567,6 +597,47 @@       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. --@@ -575,8 +646,8 @@ -- omits it is worse than one that records the failure. There is no wire -- request body to digest here because nothing was ever sent, so the -- digests are over 'Build.dispatchEnvelope'.--- | The one-event error stream a strict call refused before dispatch--- returns.+-- | 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@@ -623,7 +694,7 @@ noProviderEvents :: Model -> Options -> IO [AssistantMessageEvent] noProviderEvents m opts = do   now <- getCurrentTime-  let detail = "No provider registered for API: " <> renderApi (m ^. #api)+  let detail = "No provider registered for API: " <> describeApi (m ^. #api)       be = providerUnavailable detail       msg =         AssistantMessage@@ -639,7 +710,7 @@       m       opts       (Build.transportForModel m)-      noThinkingRequested+      (Build.requestedTranslation opts)       (Build.dispatchEnvelope m opts)       now       now
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. --@@ -70,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@@ -110,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)
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,13 +51,13 @@     runRequestWithRegistry,      -- * Helpers-    newEventId,     summarizeContext,   ) where  import Baikai.Context (Context) import Baikai.Cost (usdAsScientific)+import Baikai.Cost qualified as Cost import Baikai.Cost.Log   ( CallLogEntry (..),     CallLogHandle,@@ -55,10 +70,8 @@ -- both belong in this module, so the status constructors stay behind -- the @Evidence.@ qualifier. import Baikai.Evidence-  ( EvidenceStrictness (..),-    ModelCallEvidence,+  ( ModelCallEvidence,     newCallId,-    noThinkingRequested,   ) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build@@ -67,6 +80,7 @@ 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)@@ -77,16 +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, try)+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.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)-import Data.Maybe (fromMaybe)+import Data.Maybe (fromMaybe, isJust) import Data.Time (UTCTime, diffUTCTime, getCurrentTime) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream+import System.IO (hPutStrLn, stderr)+import System.Timeout (timeout)  -- ============================================================ -- Stream-shaped trace bridge@@ -157,20 +173,17 @@         -- is already over — so a fatal sink failure discovered here has         -- nowhere to go but the stderr line 'reportSinkError' already         -- wrote. The terminal event below is where it can still matter.-        (void (finalizeTrace state eid start m opts))-        (Stream.mapM (traceEvent state eid start m opts) (streamRequestWith reg m ctx opts))+        (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 ::@@ -235,8 +248,8 @@ -- answer can still change the call's outcome; by cleanup time the -- stream is over. finalizeTrace ::-  TraceState -> Text -> UTCTime -> Model -> Options -> IO (Maybe BaikaiError)-finalizeTrace s eid start m opts = do+  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))   if alreadyClosed@@ -253,6 +266,15 @@                   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@@ -262,12 +284,26 @@         -- 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)-            noThinkingRequested+            translation             (Build.dispatchEnvelope m opts)             start             now@@ -278,14 +314,71 @@             -- because nothing about the provider went wrong: the consumer             -- stopped reading. The message says exactly that.             (Just (providerError abortText))-        pushEvidence s eid now m mev-        writeChan (s ^. #chan) (Just aborted)+        commitTerminal s eid now m mev aborted       writeChan (s ^. #chan) Nothing-      takeMVar (s ^. #done)+      -- 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@@ -315,6 +408,35 @@             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))@@ -333,22 +455,24 @@   case merr of     Nothing -> pure Nothing     Just e -> do-      Build.onSinkFailure strictness e+      -- 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 = strictnessOf opts---- | The strictness a call was dispatched under. A call with no evidence--- request is best-effort.-strictnessOf :: Options -> EvidenceStrictness-strictnessOf opts =-  maybe EvidenceBestEffort (^. #strictness) (opts ^. #evidence)+    strictness = Build.strictnessOf opts  traceEvent ::+  ProviderRegistry ->   TraceState ->   Text ->   UTCTime ->@@ -356,7 +480,7 @@   Options ->   AssistantMessageEvent ->   IO AssistantMessageEvent-traceEvent state eid start m opts ev = do+traceEvent reg state eid start m opts ev = do   case ev of     EventDone TerminalPayload {message = msg, evidence = mev} -> do       now <- getCurrentTime@@ -386,6 +510,8 @@                 -- 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               }       -- Evidence goes out *before* the terminal, so a sink that keys@@ -393,10 +519,8 @@       -- call's state open when it arrives. The OpenTelemetry sink ends       -- and removes its span on the terminal, so the other order left       -- its evidence branch unreachable from a live stream.-      pushEvidence state eid now m mev-      writeChan (state ^. #chan) (Just finished)-      writeIORef (state ^. #terminalSent) True-      fatal <- finalizeTrace state eid start m opts+      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@@ -405,6 +529,7 @@     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"@@ -415,15 +540,22 @@                 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               }-      pushEvidence state eid now m mev-      writeChan (state ^. #chan) (Just failed)-      writeIORef (state ^. #terminalSent) True+      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 state eid start m opts+      _ <- finalizeTrace reg state eid start m opts       pure ev     _ -> pure ev @@ -491,6 +623,9 @@             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,             -- Report a zero cost as zero. Suppressing it made "this             -- call was free" indistinguishable from "baikai could not@@ -525,19 +660,3 @@  millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double))---- ============================================================--- Event id--- ============================================================---- | Generate an identifier for one traced call.------ Delegates to 'newCallId'. The previous implementation combined the--- process-start POSIX /second/ with a process-local counter and--- produced 16 hexadecimal characters, which meant two processes--- started within the same second emitted identical identifier--- sequences. 'newCallId' produces 32 characters and is unique across--- processes.-newEventId :: IO Text-newEventId = newCallId-{-# DEPRECATED newEventId "Use Baikai.Evidence.newCallId; newEventId's ids were only unique within one process." #-}
src/Baikai/Trace/Event.hs view
@@ -15,7 +15,9 @@   ) where +import Baikai.Cost (CostBasis) import Baikai.Evidence (ModelCallEvidence)+import Baikai.Usage (UsageAvailability) import Data.Aeson   ( FromJSON (parseJSON),     Options (..),@@ -39,9 +41,10 @@ -- -- Every event carries an 'eventId' that correlates the @started@ event -- with its matching @finished@, @failed@, or @evidence@ event within a--- single process run. Token counts are 'Maybe' because subscription-based--- providers (the CLIs) do not report them; 'omitNothingFields' keeps the--- absent fields out of the rendered JSON.+-- 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@@ -49,6 +52,14 @@ -- 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,@@ -74,6 +85,8 @@         cacheWriteTokens :: !(Maybe Natural),         reasoningTokens :: !(Maybe Natural),         totalTokens :: !(Maybe Natural),+        costBasis :: !(Maybe CostBasis),+        usageAvailability :: !(Maybe UsageAvailability),         usd :: !(Maybe Scientific)       }   | CallFailed@@ -82,12 +95,23 @@         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 after the matching-    -- 'CallFinished' or 'CallFailed', and only when the caller set+    -- 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@@ -171,6 +195,8 @@           <*> d .:? "cacheWriteTokens"           <*> d .:? "reasoningTokens"           <*> d .:? "totalTokens"+          <*> d .:? "costBasis"+          <*> d .:? "usageAvailability"           <*> d .:? "usd"       "call_failed" ->         CallFailed@@ -179,6 +205,15 @@           <*> 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
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,@@ -19,14 +26,21 @@  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@@ -54,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@@ -114,15 +195,15 @@     tshow x = Text.pack (show x)     fmtTime t = Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" t) --- | Read through a record pattern rather than bare selectors:+-- | 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.+-- @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-  Evidence.ModelCallEvidence {Evidence.runId, Evidence.callId, Evidence.strength} =-    Text.unwords-      [ "run=" <> runId,-        "call=" <> callId,-        "strength=" <> Text.pack (show strength)-      ]+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
@@ -18,6 +18,10 @@       multipleViolationTest,       emptyAllowedProvidersTest,       providerArgsCeilingTest,+      toolGrantCeilingTest,+      impliedGrantsTest,+      timeoutCeilingTest,+      outputLimitCeilingTest,       violationRenderingTest,       capturedOutputTest,       failureRenderingTest,@@ -43,8 +47,9 @@     req ^. #safety . #providerArgs @?= []     req ^. #timeout @?= Nothing     req ^. #output @?= InheritOutput+    req ^. #outputFormat @?= TextFormat     req ^. #outputLimit @?= Nothing-    req ^. #envPassthrough @?= []+    req ^. #envRequires @?= []  canonicalRenderingTest :: TestTree canonicalRenderingTest =@@ -73,21 +78,50 @@     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 = agentRunRequest AgentClaude "/tmp/work" "look around"-        editing = readOnly & #safety .~ agentSafety AgentEditWorkspace+    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 = agentRunRequest AgentClaude "/tmp/work" "rewrite everything"+    let base = bounded (agentRunRequest AgentClaude "/tmp/work" "rewrite everything")         greedy = base & #safety .~ agentSafety AgentFullAccess         rawArgs =           base@@ -95,7 +129,7 @@             . #providerArgs             .~ ["--dangerously-skip-permissions", "--verbose"]         claudeOnly = defaultAgentCeiling & #allowedProviders .~ [AgentClaude]-        codexRequest = agentRunRequest AgentCodex "/tmp/work" "rewrite everything"+        codexRequest = bounded (agentRunRequest AgentCodex "/tmp/work" "rewrite everything")     applyAgentCeiling defaultAgentCeiling greedy       @?= Left [CapabilityExceeded AgentFullAccess AgentEditWorkspace]     applyAgentCeiling defaultAgentCeiling rawArgs@@ -118,7 +152,7 @@             & #allowedProviders             .~ [AgentClaude]         req =-          agentRunRequest AgentCodex "/tmp/work" "rewrite everything"+          bounded (agentRunRequest AgentCodex "/tmp/work" "rewrite everything")             & #safety             .~ ( agentSafety AgentFullAccess                    & #providerArgs@@ -137,8 +171,8 @@ emptyAllowedProvidersTest =   testCase "an empty allowedProviders list permits no provider" $ do     let closed = defaultAgentCeiling & #allowedProviders .~ []-        claudeRequest = agentRunRequest AgentClaude "/tmp/work" "hello"-        codexRequest = agentRunRequest AgentCodex "/tmp/work" "hello"+        claudeRequest = bounded (agentRunRequest AgentClaude "/tmp/work" "hello")+        codexRequest = bounded (agentRunRequest AgentCodex "/tmp/work" "hello")     applyAgentCeiling closed claudeRequest       @?= Left [ProviderForbidden AgentClaude []]     applyAgentCeiling closed codexRequest@@ -148,7 +182,7 @@ providerArgsCeilingTest =   testCase "raw provider arguments pass only when the operator opens the channel" $ do     let req =-          agentRunRequest AgentClaude "/tmp/work" "hello"+          bounded (agentRunRequest AgentClaude "/tmp/work" "hello")             & #safety             . #providerArgs             .~ ["--some-vendor-flag"]@@ -157,6 +191,92 @@       @?= 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@@ -187,6 +307,48 @@       ("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@@ -207,10 +369,9 @@           ]         runFailures =           [ SpawnFailed "/usr/local/bin/claude" "no such file or directory",-            RunTimedOut 90,+            RunTimedOut (AgentTimedOut 90 OutputNotCaptured OutputNotCaptured),             MissingEnvironment ["KEIRO_PATH", "ANTHROPIC_API_KEY"],-            WorkingDirMissing "/tmp/gone",-            OutputMalformed "expected JSON, got a banner"+            WorkingDirMissing "/tmp/gone"           ]     mapM_       ( \e ->
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
@@ -18,11 +18,13 @@ 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 (assertBool, assertFailure, testCase, (@?=)) @@ -149,7 +151,41 @@             [ "{\"type\":\"turn.completed\",\               \\"usage\":{\"input_tokens\":5,\"cached_input_tokens\":9,\"output_tokens\":1}}\n"             ]-        fmap (^. #inputTokens) (report ^. #usage) @?= Just 0+        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     ]  -- ============================================================@@ -160,7 +196,15 @@ claudeParserTests =   testGroup     "claude -p --output-format json result"-    [ testCase "a recorded run yields its text, session id, model, usage, and cost" $ do+    [ 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)
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,35 +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.Evidence (noThinkingRequested)+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 ((</>))@@ -41,7 +47,8 @@ tests =   testGroup     "Baikai.Cost"-    [ computeTests,+    [ fastCostTests,+      computeTests,       attachCostTests,       callLogTests     ]@@ -177,12 +184,11 @@ registerCanned resp =   let handler _m _ctx _opts = pure resp    in registerApiProvider-        ApiProvider-          { apiTag = cannedApi,-            stream = liftCompleteToStream handler,-            complete = handler,-            describeThinking = \_ _ -> noThinkingRequested-          }+        ( apiProviderWith+            cannedApi+            (liftCompleteToStream handler)+            (handler)+        )  cannedModel :: Model cannedModel = knownModel & #api .~ cannedApi@@ -199,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@@ -209,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 ()@@ -230,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
@@ -51,12 +51,11 @@ registerErr :: IO () registerErr =   registerApiProvider-    ApiProvider-      { apiTag = errApi,-        stream = errStream,-        complete = streamingComplete errStream,-        describeThinking = \_ _ -> noThinkingRequested-      }+    ( apiProviderWith+        errApi+        (errStream)+        (streamingComplete errStream)+    )  tests :: TestTree tests =
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
@@ -1,11 +1,16 @@+{-# 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, (.=))@@ -22,14 +27,65 @@ tests =   testGroup     "Evidence"-    [ canonicalTests,+    [ 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 -- ============================================================ @@ -104,7 +160,13 @@ digestTests =   testGroup     "digests"-    [ testCase "a digest is sha256: plus 64 lowercase hex characters" $ do+    [ 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) $@@ -118,14 +180,20 @@       -- 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:ee1baf81dad750bb61bbcd6a737b8266c206a4288403510be5e10cace20b5798",+          @?= "sha256:7328ef9e177fbf71793c2167c25749b98845ecc5ea1cf9cd5a38ef3aa52d3b0b",       testCase "the configuration digest matches the golden value" $ do         env <- loadFixture         configurationDigest env-          @?= "sha256:858f0d5ec35ba6f8bac39140c6523785abcbf4e8007c770c1ba2e13f0e72d6b5",+          @?= "sha256:5ed62ecd1a00798c06de88363e9f6a591610449f1e06fa8bd8260ee7934ea366",       testCase "the configuration digest ignores content, the commitment does not" $ do         let ask subject =               object@@ -156,6 +224,93 @@     ]  -- ============================================================+-- 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 -- ============================================================ @@ -182,7 +337,18 @@             "SYSTEM-PROMPT-BODY-MARKER",             "REASONING-TEXT-MARKER",             "TOOL-PAYLOAD-MARKER",-            "Fetch a quarterly report by identifier."+            "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@@ -198,7 +364,13 @@             "max_tokens",             "temperature",             -- A tool's name is configuration; its description is not.-            "fetch_report"+            "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@@ -271,20 +443,15 @@       -- 'attempt', and 'supersedes' name a field on both       -- 'EvidenceRequest' and 'ModelCallEvidence', and under       -- DuplicateRecordFields a bare selector is ambiguous. Library-      -- code reaches these through the generic-lens labels-      -- (@r ^. #runId@) that the rest of this codebase uses.-      testCase "evidenceRequest defaults to best effort, attempt one" $-        case evidenceRequest "run-42" of-          EvidenceRequest-            { runId = rid,-              strictness = strict,-              attempt = att,-              supersedes = prev-            } -> do-              rid @?= "run-42"-              strict @?= EvidenceBestEffort-              att @?= 1-              prev @?= Nothing+      -- 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 ()@@ -342,3 +509,13 @@   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,12 +273,10 @@   responsesRef <- newIORef responses   callsRef <- newIORef 0   registerApiProviderWith reg $-    ApiProvider-      { apiTag = helpersApi,-        complete = scriptedComplete responsesRef callsRef,-        stream = \_ _ _ -> Stream.fromList events,-        describeThinking = \_ _ -> noThinkingRequested-      }+    apiProviderWith+      helpersApi+      (\_ _ _ -> Stream.fromList events)+      (scriptedComplete responsesRef callsRef)   pure Scripted {scriptRegistry = reg, scriptCallRef = callsRef}  scriptedComplete :: IORef [Response] -> IORef Int -> Model -> Context -> Options -> IO Response@@ -204,30 +298,25 @@ registerOneShot :: Api -> Response -> IO () registerOneShot apiTag resp =   registerApiProvider-    ApiProvider-      { apiTag,-        complete = \model _ctx _opts -> pure (stampModel model resp),-        stream = \_ _ _ -> Stream.fromList [],-        describeThinking = \_ _ -> noThinkingRequested-      }+    ( 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 [],-      describeThinking = \_ _ -> noThinkingRequested-    }+  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 [],-      describeThinking = \_ _ -> noThinkingRequested-    }+  apiProviderWith+    apiTag+    (\_ _ _ -> Stream.fromList [])+    (\model _ctx _opts -> pure (errorResponse model epoch 0 err))  stampModel :: Model -> Response -> Response stampModel model resp =
test/Main.hs view
@@ -1,3 +1,6 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE UndecidableInstances #-}+ module Main (main) where  import AgentAssetsSpec qualified@@ -8,10 +11,15 @@ 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@@ -19,19 +27,25 @@ 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@@ -78,12 +92,11 @@             .~ testApi             & #provider             .~ providerName-   in ApiProvider-        { apiTag = testApi,-          stream = liftCompleteToStream handler,-          complete = handler,-          describeThinking = \_ _ -> noThinkingRequested-        }+   in ( apiProviderWith+          testApi+          (liftCompleteToStream handler)+          (handler)+      )  main :: IO () main = do@@ -106,18 +119,23 @@         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,@@ -133,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)@@ -148,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@@ -204,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"@@ -220,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@@ -249,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@@ -366,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@@ -75,7 +76,7 @@  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
@@ -13,9 +13,11 @@ 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)@@ -88,7 +90,7 @@     [ testCase "a custom transport cannot supply model_observed" $         case checkEvidenceRequirements           (EvidenceRequired EvidenceModelObserved)-          (Custom "someone-elses-gateway")+          (declaredStrength (Custom "someone-elses-gateway"))           noThinkingRequested of           [StrengthUnreachable needed declared] -> do             needed @?= EvidenceModelObserved@@ -97,14 +99,14 @@       testCase "the codex CLI cannot supply model_observed, because it names no model" $         case checkEvidenceRequirements           (EvidenceRequired EvidenceModelObserved)-          OpenAICompletionsCli+          (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)-          OpenAICompletionsCli+          (declaredStrength OpenAICompletionsCli)           noThinkingRequested           @?= [],       testCase "an exactly-met requirement is not a refusal" $@@ -112,7 +114,7 @@         -- what was asked for satisfies it.         checkEvidenceRequirements           (EvidenceRequired EvidenceModelObserved)-          AnthropicMessages+          (declaredStrength AnthropicMessages)           noThinkingRequested           @?= [],       testCase "both halves of the gate report together, not one per attempt" $@@ -122,7 +124,7 @@         length           ( checkEvidenceRequirements               (EvidenceRequired EvidenceModelObserved)-              (Custom "gateway")+              (declaredStrength (Custom "gateway"))               (downgradedBy (EffortClamped ThinkingMax "high"))           )           @?= 2@@ -149,7 +151,7 @@   testCase name $     case checkEvidenceRequirements       (EvidenceRequired EvidenceRequestedOnly)-      AnthropicMessages+      (declaredStrength AnthropicMessages)       (downgradedBy adjustment) of       [ThinkingWouldDowngrade [reported]] -> do         reported @?= adjustment@@ -196,7 +198,7 @@       testCase "several downgrades on one call are reported together" $         case checkEvidenceRequirements           (EvidenceRequired EvidenceRequestedOnly)-          AnthropicMessages+          (declaredStrength AnthropicMessages)           ( noThinkingRequested               & #requested .~ Just ThinkingMax               & #adjustments@@ -210,16 +212,44 @@         -- no thinking level must still run.         checkEvidenceRequirements           (EvidenceRequired EvidenceModelObserved)-          AnthropicMessages+          (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)-          OpenAIChatCompletions+          (declaredStrength OpenAIChatCompletions)           ( noThinkingRequested               & #requested .~ Just ThinkingXHigh               & #mode .~ ThinkingModeAdaptive@@ -240,7 +270,7 @@     -- a sample is a promise about the sample.     "a best-effort caller is never refused, on any transport at any level"     [ testCase (Text.unpack (renderApi api) <> " / " <> label) $-        checkEvidenceRequirements EvidenceBestEffort api translation @?= []+        checkEvidenceRequirements EvidenceBestEffort (declaredStrength api) translation @?= []     | api <-         [ AnthropicMessages,           OpenAIChatCompletions,@@ -267,7 +297,11 @@                   EffortOmitted lvl,                   ThinkingDroppedUnsupportedModel lvl,                   ThinkingDroppedUnsupportedHost lvl,-                  ThinkingDroppedBudgetExceeded lvl 32000 8192+                  ThinkingDroppedBudgetExceeded lvl 32000 8192,+                  SamplingDroppedUnsupportedModel ["temperature"],+                  SamplingDroppedUnsupportedApi ["seed"],+                  FastModeDroppedUnsupportedModel,+                  ThinkingSummaryUnavailable                 ]             ]     ]@@ -276,12 +310,16 @@ -- 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@@ -297,7 +335,16 @@     "the gate never computes a translation it does not need"     [ testCase "A BEST-EFFORT CALL NEVER FORCES THE TRANSLATION" $ do         outcome <--          try (evaluate (length (checkEvidenceRequirements EvidenceBestEffort AnthropicMessages explodes)))+          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),@@ -308,7 +355,7 @@                 ( length                     ( checkEvidenceRequirements                         (EvidenceRequired EvidenceRequestedOnly)-                        AnthropicMessages+                        (declaredStrength AnthropicMessages)                         explodes                     )                 )@@ -378,7 +425,49 @@         registerApiProviderWith reg countingProvider         resp <- completeRequestWith reg customModel testContext emptyOptions         responseError resp @?= Nothing-        flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran"+        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)+              )     ]  -- ============================================================@@ -406,26 +495,59 @@ 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 =-  ApiProvider-    { apiTag = customApi,-      stream = \_ _ _ -> error "the provider was dispatched despite a strict refusal",-      complete = \_ _ _ -> error "the provider was dispatched despite a strict refusal",-      describeThinking = \_ _ -> noThinkingRequested-    }+  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 =-  ApiProvider-    { apiTag = customApi,-      stream = liftCompleteToStream handler,-      complete = handler,-      describeThinking = \_ _ -> noThinkingRequested-    }+  apiProviderWith+    customApi+    (liftCompleteToStream handler)+    (handler)   where     handler m _ _ =       pure
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
@@ -1,15 +1,10 @@--- This module deliberately exercises 'newEventId', which is deprecated--- in favour of 'Baikai.Evidence.newCallId'. The alias is still part of--- the public surface, so it keeps a test; suppressing the warning here--- is narrower than dropping the coverage.-{-# OPTIONS_GHC -Wno-deprecations #-}- module TraceSpec (tests) where  import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext)-import Baikai.Error (BaikaiError, providerError)+import Baikai.Cost qualified as Cost+import Baikai.Error (BaikaiError, ErrorCategory (..), providerError) import Baikai.Evidence   ( ModelCallEvidence,     TransportKind (..),@@ -22,24 +17,28 @@ import Baikai.Model (Model (..), emptyModel) import Baikai.Options (Options, emptyOptions) import Baikai.Prelude-import Baikai.Provider (ApiProvider (..), registerApiProvider)+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.Trace (newEventId, withTrace, withTraceStream)+import Baikai.ThinkingLevel (ThinkingLevel (..))+import Baikai.Trace (withTrace, withTraceStream) import Baikai.Trace.Event (TraceEvent (..))-import Baikai.Trace.Sink (TraceSink (..), silent)+import Baikai.Trace.Sink (TraceSink (..), multiSink, silent) import Baikai.Usage (Usage, zeroUsage)-import Control.Concurrent (threadDelay)+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 (throwIO)-import Control.Monad (replicateM)+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@@ -61,10 +60,18 @@       memoryFinishTest,       memoryFailTest,       throwingSinkTest,+      blockingSinkTest,+      blockingSinkStrictTest,+      multiSinkThrowingMemberTest,+      multiSinkBlockingMemberTest,+      multiSinkStrictNamesMemberTest,+      terminalPathAtomicityTest,+      throwToAroundTerminalTest,       eventIdUniquenessTest,       earlyAbortTest,       fidelityTest,       evidenceTests,+      requestedLevelTests,       encodingTests     ] @@ -113,23 +120,21 @@ registerOk a =   let handler _m _ctx _opts = pure (stubResponse a)    in registerApiProvider-        ApiProvider-          { apiTag = a,-            stream = liftCompleteToStream handler,-            complete = handler,-            describeThinking = \_ _ -> noThinkingRequested-          }+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (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,-            describeThinking = \_ _ -> noThinkingRequested-          }+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )  memorySink :: IO (TVar [TraceEvent], TraceSink) memorySink = do@@ -215,17 +220,217 @@         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 now reads 32, because 'newEventId' delegates to--- 'Baikai.Evidence.newCallId', which carries 128 bits rather than 64.--- The widening is the point of the replacement: the old generator--- packed a process-start /second/ into its high half and so repeated--- itself across processes started in the same second.+-- 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 "newEventId yields 70000 distinct 32-char ids" $ do-    ids <- replicateM 70000 newEventId+  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) @@ -283,24 +488,43 @@     .~ 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-        ApiProvider-          { apiTag = a,-            stream = liftCompleteToStream handler,-            complete = handler,-            describeThinking = \_ _ -> noThinkingRequested-          }+        ( apiProviderWith+            a+            (liftCompleteToStream handler)+            (handler)+        )  fidelityTest :: TestTree fidelityTest =   testGroup     "CallFinished fidelity"-    [ testCase "carries the full disjoint token breakdown" $ do+    [ 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@@ -317,7 +541,8 @@                 cachedInputTokens,                 cacheWriteTokens,                 reasoningTokens,-                totalTokens+                totalTokens,+                costBasis               }             ] -> do               inputTokens @?= Just 11@@ -326,6 +551,7 @@               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@@ -383,13 +609,130 @@             Nothing         pure (stubResponse a & #evidence .~ ev)    in registerApiProvider-        ApiProvider-          { apiTag = a,-            stream = liftCompleteToStream handler,-            complete = handler,-            describeThinking = \_ _ -> noThinkingRequested+        ( 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] @@ -420,7 +763,12 @@       strictSinkFailureIsStillOneTerminalTest,       optOutSilentTest,       optOutGoldenTest,-      envelopeNotForcedTest+      envelopeNotForcedTest,+      strictNoRecordFailsTest,+      strictNoRecordIsOneTerminalTest,+      strictWithRecordSucceedsTest,+      strictNoRecordErrorPathKeepsProviderErrorTest,+      bestEffortNoRecordStillSucceedsTest     ]  -- | Assert the shape every record this plan produces must have: the@@ -446,12 +794,37 @@  -- | 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@@ -549,7 +922,11 @@     -- something they cannot account for, with no way to notice: evidence     -- that can vanish without the caller noticing is not evidence.     let a = Custom "baikai-evidence-strict-throwing-sink"-    registerOk a+    -- 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@@ -564,6 +941,86 @@               ("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@@ -696,12 +1153,11 @@               Nothing           pure (stubResponse a & #evidence .~ ev)     registerApiProvider-      ApiProvider-        { apiTag = a,-          stream = liftCompleteToStream handler,-          complete = handler,-          describeThinking = \_ _ -> noThinkingRequested-        }+      ( apiProviderWith+          a+          (liftCompleteToStream handler)+          (handler)+      )     (ref, sink) <- memorySink     _ <- withTrace sink (stubModel a) stubContext stubOptions     events <- reverse <$> readTVarIO ref@@ -782,6 +1238,8 @@       cacheWriteTokens = Just 3,       reasoningTokens = Just 4,       totalTokens = Just 26,+      costBasis = Nothing,+      usageAvailability = Nothing,       usd = Just 0     } @@ -793,5 +1251,14 @@       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,