packages feed

baikai-openai 0.4.0.0 → 0.7.0.0

raw patch · 36 files changed

Files

+ CHANGELOG.md view
@@ -0,0 +1,2487 @@+# Changelog++All notable changes to baikai are recorded here.++The format follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and+this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html).++## [Unreleased]++## [baikai 0.7.0.0] - 2026-09-08++### Added++- `BaikaiError.refusalCategory` preserves an Anthropic refusal's+  provider category. JSON adds `refusal_category`; older errors still decode.+  Evidence schema 2.5 records the addition without changing digest inputs.+  __Breaking__ to construct a `BaikaiError` from its full field list.++- `Speed`, `Options.speed`, catalog-owned fast rates and+  `computeCostAtSpeed`. Anthropic gates fast mode by model capability, adds the+  beta header and records unsupported drops. Terminal pricing uses observed+  speed, including cache duration; unreported speed is an explicit estimate.+  Older `Model` JSON defaults the new fields safely. __Breaking__: public+  records and sum types gain fields and constructors.++- API usage now records observed service tiers, inference speed and server-tool+  use in optional billing facts covered by evidence schema 2.2. Missing service+  information and uncurated products produce explicit standard-rate estimates.+  `computeCostForService` separates requested and observed service, while+  `computeCostAtRates` prices a resolved rate set once for future speed policies.+  Empty billing facts preserve legacy availability JSON; a CLI-reported zero+  cost retains its reported-total source. __Breaking__: the public vocabulary+  and records gain members.++- Failed trace terminals now retain partial response token counts, cost basis,+  usage availability and USD totals. Synthetic aborts leave unreported billing+  absent; legacy failed trace JSON still decodes. __Breaking__: `TraceEvent`'s+  `CallFailed` gains fields. See `baikai-trace-otel 0.4.0.1` for the export.++- Successful trace terminals and call-log records carry optional cost basis and+  usage availability; call logs also carry cache-write counts. Old JSON decodes+  with absent metadata and empty additive-zero bases stay omitted from traces.+  __Breaking__: `CallFinished` and the call-log record gain fields.++- Optional `Usage.availability` and shared inclusive/exclusive billing+  normalization, in the new `Baikai.Usage.Normalize`. OpenAI Chat/Responses and+  Claude preserve missing cache counters as explicit estimation reasons,+  distinguish reported zeroes, and merge cumulative usage without+  double-counting. Schema 2.2 commits provider availability while preserving+  legacy usage digests. __Breaking__: `Usage` gains a field.++- Optional `Model.pricingPolicy`, exact whole-request context tiers,+  and an explicit cache-duration rate resolver. Generated Astra pricing changes+  above 272000 input tokens; Fable exposes its one-hour write price. `Cost.basis`+  preserves calculation sources and estimation reasons when summed. Evidence+  schema 2.2 serializes the local basis without including local pricing metadata+  in provider commitments. __Breaking__: `Model` and `Cost` gain fields.++- Separate `OpenAIResponses` dispatch and compatibility types, and+  optional provider/model-scoped `ThinkingContent.replayState` with opaque+  diagnostic output and backward-compatible JSON decoding. Evidence schema 2.2+  includes replay state and optional billing facts in commitments while preserving+  legacy encodings when those fields are absent. __Breaking__ for a `case` over+  `Api` that is exhaustive without a wildcard.++- `Baikai.Evidence.ThinkingTranslation` gains `displayText` and+  `ThinkingAdjustment` gains `ThinkingSummaryUnavailable`, so a transport can+  record the thinking display setting it asked for and diagnose a successful+  response whose thinking blocks carry no readable summary. `Baikai.Compat`+  gains `supportsForcedToolChoice`; legacy JSON defaults it to True.+  __Breaking__ for an exhaustive `case` over `ThinkingAdjustment`.++- GPT-6 Astra and Claude Fable 5.1 catalog bindings, with verified+  pricing, token limits, and Anthropic thinking/sampling compatibility.++- Repository `update-models` skill for verifying provider releases and refreshing+  the curated JSON and generated Haskell catalog.++### Fixed++- Preserve OpenAI endpoint capability facts through catalog refreshes.++- Chat and Claude reject provider-scoped reasoning replay they cannot encode.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++## [baikai-claude 0.7.0.0] - 2026-09-08++### Changed++- Refusal messages include the reported category and explanation,+  retaining the original message when neither exists. Classification remains+  non-retryable `ContentFiltered`. Server-side fallbacks remain deliberately+  unsupported, as recorded in ADR 0005.++- Adaptive reasoning requests explicitly ask for summarized+  thinking. Evidence schema 2.4 records the display setting and diagnoses+  successful responses whose thinking blocks contain no readable summary.+  Budget and absent-thinking request shapes, signed empty blocks, redacted+  content and multi-turn replay are preserved.++- Fast mode is gated by the generated model capability: it adds the Anthropic+  beta header for a model that advertises it and records an evidence adjustment+  for one that does not.++### Fixed++- Price Fable cache writes using the TTL in the shaped request,+  including compatibility downgrades. Missing write-duration context is explicit+  in the cost basis.++- Reject forced tool choices locally on Fable 5.1, using the+  generated `supportsForcedToolChoice` capability. Automatic tool rounds retain+  signed empty/visible thinking, redacted blocks and prior-message order.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`.++## [baikai-openai 0.7.0.0] - 2026-09-08++### Added++- Explicit `Baikai.Provider.OpenAI.Responses` registration and+  stream/complete provider with stateless reasoning replay, function tool turns,+  structured output and bounded worker cleanup, across the new+  `Baikai.Provider.OpenAI.Responses.{Request,Stream,Assembler}` modules. Astra+  now selects this provider through a per-model catalog override; callers must+  register it explicitly. Cache writes, billing availability and context pricing+  are integrated.++- `Baikai.Provider.OpenAI.Internal.Usage`, the shared usage mapping both the+  Chat Completions and Responses transports read.++### Fixed++- Reject tools locally for models whose Chat Completions endpoint+  disallows them, including GPT-6 Astra. Respect generated effort policies and+  sampling restrictions, with matching translation evidence and strict refusal.++- Validate Responses terminals and enforce the stream contracts.++- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the+  tagged but never-published 0.6.0.1).++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`.++## [baikai-trace-otel 0.4.0.1] - 2026-09-08++### Added++- Successful and failed spans export `baikai.cost.basis` and+  `baikai.usage.availability` as canonically encoded JSON. A failed span now+  also carries the input/output token counts and USD total that+  `baikai 0.7.0.0` retains on `CallFailed`, alongside its error status.++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`, and now depends on `aeson ^>=2.2` to encode the+  two new attributes.++## [baikai-effectful 0.4.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`. No API change.++## [baikai-kit 0.2.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`. No API change.++## [baikai-agent 0.2.0.1] - 2026-09-08++### Changed (dependencies)++- Requires `baikai ^>=0.7.0`, `baikai-claude ^>=0.7` and+  `baikai-openai ^>=0.7`. No API change.++## [baikai 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4. The 0.4 API retains the+  manager functions this package uses and belongs to the same TLS 2.x / Crypton+  1.1 dependency cohort as baikai 0.6; the old `^>=0.3` cap made baikai 0.6+  impossible to solve in applications that require Crypton 1.1.++## [baikai-claude 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4, allowing applications that+  require Crypton 1.1 to solve the dependency set.++## [baikai-openai 0.6.0.1] - 2026-08-30++### Fixed++- widened the `http-client-tls` bound to admit 0.4, allowing applications that+  require Crypton 1.1 to solve the dependency set.++## [baikai 0.6.0.0] - 2026-08-28++### Added++- `baikai`: `Baikai.ThinkingLevel.parseThinkingLevel :: Text -> Maybe+  ThinkingLevel` and `Baikai.Evidence.parseEvidenceStrength :: Text -> Maybe+  EvidenceStrength`, each beside its renderer. Three hand-copied tables — the+  evidence schema's level parser, `baikai-agent`'s KDL `effort` decoder, and its+  `--require-evidence` parser — now read them instead, so a level or strength+  added later cannot be added in one place and missed in three. (REV-2 G.6.)++- `baikai`: `Baikai.Agent.AgentRunResult` exports its selectors (`provider`,+  `exitCode`, `stdout`, `stderr`, `duration`). It exported neither them nor its+  constructor, so a consumer without generic-lens could not read a run's exit+  code at all. (REV-2 G.6.)++- `baikai`: `Baikai.Api.normaliseApi :: Api -> Api`, which collapses a `Custom`+  tag that spells a built-in API onto that constructor. The registry applies it+  to the key it stores and to the tag it is asked for, so a handler registered+  under `Custom "anthropic-messages"` answers a model tagged `AnthropicMessages`+  and the reverse; the two used to be separate entries and dispatch depended on+  which spelling the model happened to carry. Derived `Eq`/`Ord` on `Api` are+  deliberately unchanged: altering them would silently rearrange every+  `Map Api` a consumer holds. (REV-2 G.4.)++- `baikai`: `Baikai.Header`, a new module exporting `HeaderName` with+  `headerName` and `renderHeaderName`. See the `headers` retype under Changed.++- `baikai`: `Baikai.Error.ErrorCategory` gains `ContentFiltered` (wire tag+  `content_filtered`, never retryable) with the smart constructor+  `contentFiltered`. OpenAI's `finish_reason: "content_filter"` and Anthropic's+  `refusal` stop now carry it. Both used to be `OtherError`, so the only way to+  tell a filtered response from any other non-retryable failure was to match on+  the message text. __Breaking__ for a consumer whose `case` over+  `ErrorCategory` is exhaustive without a wildcard. (REV-1 1.7 residual.)++- `baikai` (breaking to construct, not to read): every record that can still+  grow a field is now built from an exported base value and refined by record+  update, and its constructor is no longer exported —+  `Baikai.Provider.Registry.ApiProvider` (`apiProvider` /`apiProviderWith`),+  `Baikai.Evidence.ModelCallEvidence` (`baseEvidence`),+  `Baikai.Evidence.EvidenceRequest` (`evidenceRequest`), `Baikai.Tool.Tool`+  (`mkTool`, with `emptyTool` kept for fixtures),+  `Baikai.Embedding.EmbeddingModel` (`emptyEmbeddingModel`),+  `Baikai.Cost.Log.CallLogConfig` (`callLogConfig`),+  `baikai-trace-otel`'s `OtelSinkOptions` (`defaultOtelSinkOptions`), and+  `baikai-agent`'s `AgentCliOptions` (`agentCliOptions`), `AgentCliRun`+  (`agentCliRun`), `AgentJob` (`agentJob`) and `AgentConfigPaths`+  (`emptyAgentConfigPaths`). Selectors, record update, `OverloadedRecordDot`+  reads and generic-lens labels all keep working; only construction from the+  constructor stops. Adding `describeThinking` to `ApiProvider` in 0.5.0.0 broke+  every third-party registration site, and `strengthCeiling` would have broken+  them again; from this release such an addition is a minor bump. (REV-2 G.1.)++- `baikai`: `Baikai.Provider.apiProvider`, which builds an `ApiProvider` from an+  `Api` tag and a streaming producer, deriving `complete` with+  `streamingComplete`; and `Baikai.Provider.Registry.apiProviderWith`, which+  takes the completer explicitly. Both default `describeThinking` to+  "nothing requested, nothing translated" and `strengthCeiling` to+  `EvidenceRequestedOnly`, matching `declaredStrength (Custom _)`.++- `baikai`: `Baikai.Tool.mkTool` — a tool from its name, description and JSON+  Schema. A tool built from `emptyTool` and sent unchanged reaches the wire with+  `input_schema: null`; `mkTool` has no such shape.++- `baikai`: `Baikai.Agent.AgentOutputFormat` (`TextFormat`, `JsonFormat`) with+  `renderAgentOutputFormat` and `parseAgentOutputFormat`, and+  `AgentRunRequest.outputFormat`, defaulting to `TextFormat`. `baikai-claude`+  renders `--output-format json` and `baikai-openai` renders `--json`, both+  right after the effort flags; `baikai-agent` reads it from+  `jobs.<name>.output-format`. This is the one setting an evidence record needs+  in order to observe a run's session, model and usage, and asking for it used+  to require the `provider-args` channel that an operator ceiling closes by+  default — an operator should not have to open a privileged channel to get a+  record. (REV-2 F.14.)++- `baikai`: `Baikai.Agent.AgentCeiling` gains three fields and the module gains+  the vocabulary they need. `allowedTools :: [Text]` names tool grants the+  operator permits beyond the ones `toolGrantsImpliedBy` (also new) says a+  capability implies on its own; `maxTimeout :: Maybe NominalDiffTime` and+  `maxOutputLimit :: Maybe Int` bound what any job may request, the second+  defaulting to the new `defaultMaxOutputLimit` (67108864, sixty-four+  mebibytes). `Baikai.Agent.ceilingViolations` is `applyAgentCeiling`'s violation+  list on its own, so a caller can concatenate it with violations of its own.+  (REV-2 F.3.)++- `baikai`: `Baikai.Content.toolArgumentsFromText` and+  `Baikai.Content.isCutOffToolCall`. The first is the single rule that turns a+  tool call's accumulated argument text into its `arguments` value — empty text+  is an empty object, non-empty text that does not decode is kept verbatim as a+  `String` — and both provider assemblers and core's stream-recovery path now+  use it, so the second means the same thing at every layer.++- `baikai`: new exposed module `Baikai.Provider.Internal.StreamWorker` — the+  bounded hand-off both HTTP providers now use between their SSE worker thread+  and the consumer draining the stream. `FrameQueue` is a 64-slot `TBQueue` plus+  a closed flag; `forkFrameWorker` closes the queue however the body ends, and+  `withFrameWorker` runs the consumer under `Stream.bracketIO` so the worker is+  killed when the stream stops. The module is exposed like+  `Baikai.Provider.Cli.Internal`, outside the PVP promise. See+  [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md).++- `baikai`: every Anthropic model in the generated catalog now carries an+  explicit `CompatAnthropicMessages` record stating the two request-shaping+  facts of its generation: `AnthropicMessagesCompat.thinkingStyle` (which+  extended-thinking wire shape it accepts) and the new+  `AnthropicMessagesCompat.supportsSamplingParameters` (whether it accepts+  `temperature`, `top_p` and `top_k`). Both are sourced from+  `baikai/data/models/anthropic.json`, which the fetcher writes from its+  curated `anthropicInclude` table, and `baikai-gen-models` now refuses an+  `anthropic-messages` entry that reaches it without a `compat` block rather+  than falling back to host auto-detection, which cannot know a generation.+  This is what fixes `claude-sonnet-5`, whose thinking requests were shaped by+  a prefix table that did not know the id. See+  [docs/adr/0009](docs/adr/0009-provider-capability-facts-live-in-the-generated-catalog-record.md).++- `baikai`: two new `Baikai.Evidence.ThinkingAdjustment` constructors,+  `SamplingDroppedUnsupportedModel` and `SamplingDroppedUnsupportedApi`, encoding as+  `{"kind":"sampling_dropped_unsupported_model","fields":["temperature","top_p"]}` and+  `{"kind":"sampling_dropped_unsupported_api","fields":["seed"]}`. They record sampling+  parameters removed because the model generation rejects them, or because the API has no+  such field on any generation. Both carry a `fields` array and no `requested` level, so+  they can appear on a call whose thinking mode is `absent`.++- `baikai`: `Baikai.Evidence.weakensThinking`, which says whether an adjustment weakens the+  thinking the caller asked for. Strict evidence mode filters through it, so a dropped+  sampling parameter is recorded without refusing the call — the documented contract is+  refusing a call that would weaken the requested *thinking level*.++- `baikai`: new exposed module `Baikai.Url` — the one place baikai turns a URL+  into a host name. `parseUrl` yields a `UrlParts` record with the scheme, host,+  port and path, plus flags saying whether userinfo, a query string or a+  fragment were present; it never holds their text, so the value cannot carry a+  secret into a log line. Alongside it: `urlHost`, `hostMatchesSuffix` (moved+  from `Baikai.Compat`, which now re-exports both), `renderEndpoint`,+  `stripApiVersion`, and `baseUrlProblem`, which says why a URL is unusable as a+  `Model.baseUrl` and what to do instead. See+  [docs/adr/0008](docs/adr/0008-one-url-host-parser-and-every-consumer-uses-it.md).++- `baikai`: new exposed module `Baikai.Provider.Transport.Classify` — the one+  rule every HTTP provider uses to classify a transport failure, exporting+  `classifyTransportException` plus the per-type functions it composes. The rule+  is *where* the failure happened, not what type it is: anything that breaks or+  ends the connection after the request went out is `TransientError`, anything+  that says the request or the configuration is wrong is not retryable, and a+  programming error stays `OtherError`. It understands all three shapes+  `http-client` can deliver — an `HttpException` of any constructor, a raw socket+  `IOException`, and a raw or wrapped `TLSException` — because the manager wraps+  the connect phase but not the body reader. Core gains direct `build-depends` on+  `http-types` and `tls`, both already in its install plan. Written for+  third-party `Custom` providers built on `http-client` as much as for baikai's+  own two. See+  [docs/adr/0011](docs/adr/0011-core-owns-transport-failure-classification.md).++- `baikai`: `Baikai.Error.parseHttpDate` and `Baikai.Error.retryAfterSecondsAt`.+  The first parses an HTTP-date in the IMF-fixdate form servers must send plus+  the two obsolete forms a recipient must accept; the second converts a+  `Retry-After` header in either of its forms to seconds against a reference+  instant, clamping a date already in the past to `0`.+  `parseRetryAfterSeconds` keeps its integer-only contract, now a deliberate+  division of labour rather than a limitation.++- `baikai`: new exposed module `Baikai.Http` — `canonicalBaseUrl`,+  `getClientEnvCached` and `cachedClientEnvCount`, the process-global+  `ClientEnv` cache that both HTTP provider packages now share instead of each+  keeping its own. Core gains direct `build-depends` on `servant-client`,+  `http-client` and `http-client-tls`, which were already in its install plan+  through the `openai` SDK.++- `baikai`: `Baikai.Evidence.ThinkingModeNotTranslated`, encoded as+  `"not_translated"`, and `Baikai.Evidence.untranslatedThinking`; and+  `Baikai.Evidence.Build.requestedTranslation`. A path where no adapter ran to+  translate the caller's level now records the level and says the translation is+  unknown, instead of saying nothing was asked. (REV-2 D.2.)++- `baikai`: `Baikai.Evidence.Build.missingEvidenceError`,+  `Baikai.Evidence.Build.strictnessOf` (moved here from `Baikai.Trace`, where it+  was private), `Baikai.Stream.requireEvidenceOnTerminal` and+  `Baikai.Provider.Registry.requireEvidenceOnResponse`. (REV-2 D.3.)++- `baikai`: `Baikai.Evidence.usageEnvelope`, and+  `Baikai.Evidence.Build.endpointIdentityAt`, `prepareEvidenceAt` and+  `minimalEvidenceAt`, which take the base URL the adapter actually resolved.+  The three unsuffixed functions remain and pass the model's own field.+  (REV-2 D.8, D.11.)++- `baikai`: `Baikai.Evidence.deriveStrength`, the single rule that turns an+  observed model, a provider request id and a response id into an+  `EvidenceStrength`. (REV-2 D.10.)++### Changed++- `baikai`: catalog refresh. `claude-opus-5` joins the curated Anthropic include+  set (adaptive thinking, sampling parameters rejected — the facts+  `docs/plans/60-make-anthropic-thinking-style-and-sampling-support-catalog-driven.md`+  said whoever curated it in would have to state), and the `gpt-5.6` family+  picks up its price cut: `gpt-5.6` and `gpt-5.6-sol` to $4.00/$20.00,+  `gpt-5.6-terra` to $2.00/$12.00, `gpt-5.6-luna` to $0.20/$1.20 per Mtok, cache+  rates in step. `Baikai.Models.Generated` gains `anthropic_claude_opus_5` and+  now carries 36 enabled models. No OpenAI id was added: the `gpt-5.6` family is+  still the newest one models.dev reports that speaks+  `openai-chat-completions`.++- `baikai` (breaking): `ResponseFormat`'s `JsonSchema` carries a+  `JsonSchemaFormat` record — `name`, `schema`, `strict`, exported+  selector-only with the base `jsonSchemaFormat name schema` — instead of+  holding the three fields directly. As fields of a sum they were partial+  selectors: `name f` on a `JsonObject` crashed at runtime rather than failing to+  typecheck, which contradicted the module's own documentation.+  `-Wno-partial-fields` is dropped from the module. The JSON encoding is+  deliberately unchanged (`{"tag":"JsonSchema","name":…,"schema":…,"strict":…}`)+  and is now pinned by a test, because `Options` derives `ToJSON` through it and+  at least one consumer keys a cache on the result. (REV-2 G.2.)++- `baikai`: `Baikai.Context.appendToolResult` returns its input context+  unchanged, and runs no dispatcher, when the response is error-shaped. A failed+  call has no assistant turn worth replaying and no tool calls to answer;+  appending its empty message put a turn into the transcript the model never+  took. `runToolLoop` has always stopped on such a response — the documented+  direct round trip in `docs/user/tools.md` reaches `appendToolResult` instead,+  and now behaves the same way. Its Haddock also stops claiming multi-call+  concurrency lives in the dispatcher: the calls are traversed in order.+  (REV-2 G.7.)++- Release metadata (REV-2 G.8): every publishable package now declares+  `tested-with: GHC ==9.12.4` and ships its `CHANGELOG.md` (a symlink to the+  root one, as `baikai` already did) via `extra-doc-files`, so Hackage shows a+  changelog and a tested compiler for all seven. `baikai-claude` and+  `baikai-openai` describe what they actually contain — four surfaces each, not+  "wraps package X" — and `baikai-trace-otel`'s `streamly-core` bound is+  `>=0.3 && <0.5`, matching every other package in the workspace rather than+  excluding the 0.4 series the others accept.++- `baikai` (breaking): `Options.headers` and `Model.headers` are keyed on+  `Baikai.Header.HeaderName` — a newtype over a case-insensitive `CI Text` that+  keeps the original spelling — instead of `Text`. A header name is+  case-insensitive on the wire, so a `Map Text Text` holding both+  `Authorization` and `authorization` sent whichever the assembling fold reached+  last; the map now holds one entry per header and the last write wins, as a+  caller writing two spellings would expect. `HeaderName` has an `IsString`+  instance, so `Map.singleton "x-test" "1"` and `#headers` updates keep+  compiling; the spelling given is what goes out on the wire and into JSON.+  (REV-2 G.5.)++- `baikai` (breaking): `Options.stopSequences` is `[Text]`, where empty means+  "send nothing", instead of `Maybe (Vector Text)` — `Nothing` and `Just []`+  were indistinguishable on the wire and only one of them could be right. Plan+  43's rule is lists for caller-side configuration and `Vector` for+  provider-bound sequences; this was the one field breaking it. `Options.seed`+  is `Maybe Int` rather than `Maybe Integer`: a seed is a machine integer at+  every provider that accepts one, and it now sits beside+  `timeoutMs :: Maybe Int`. (REV-2 G.5, R14.)++- `baikai` (breaking): `StopReason.Aborted` is removed. Nothing produced it —+  timeouts are `ErrorReason`/`TransientError`, and a consumer abort is recorded+  as evidence `CallAborted` — while `responseError`, `eventsFor` and+  `runToolLoop` all treated it as a *success*, so a value that reached any of+  them would have been silently mishandled. Since 0.6.0.0 a stream consumer that+  stops cancels the producer, so no consumer is left to receive such a terminal+  either. (REV-2 B.6.)++- `baikai`: dispatching a model whose `api` is still `emptyModel`'s+  `Custom ""` says so — `No provider registered for API: <blank Custom tag —+  emptyModel.api was never set>` — where the message used to end after the+  colon. `emptyModel`'s Haddock says the same thing. (REV-2 G.4.)++- `baikai`: `withTrace` and `withTraceStream` wait at most one second for the+  trace sink after writing the shutdown sentinel. On expiry the worker is+  abandoned — not killed, which would abort the sink's fold mid-step and lose+  its end-of-stream action — the call proceeds, and one stderr line reports+  `the trace sink did not confirm delivery within 1000 ms; its worker was+  abandoned, and events already queued may still be delivered later`. A sink+  that blocked forever used to hold the call forever and swallow the first+  attempt to cancel it. A caller under `EvidenceRequired` whose sink did not+  confirm delivery gets a failed call, through the same path a throwing sink+  takes; `Baikai.Evidence.Build.sinkFailureError` now says "its record was not+  confirmed written" rather than "not written", which is the honest claim for+  an abandoned worker whose events are still queued. The synthetic terminal a+  consumer's abort produces is delivered from a garbage-collection hook and is+  not guaranteed before process exit; that was always true and is now stated in+  `docs/user/model-call-evidence.md`, `docs/capabilities/call-tracing.md` and+  the `Baikai.Trace` module documentation, with the pattern for callers who need+  the record. See+  [docs/adr/0015](docs/adr/0015-trace-cleanup-is-bounded-and-abort-cleanup-is-gc-eventual.md).+  (REV-2 D.5, Theme 7.3.)++- `baikai`: `Baikai.Trace.Sink.multiSink` runs each member on its own drain+  thread behind its own unbounded channel, instead of folding `Fold.tee` across+  the list. `Fold.tee` runs one member then the other and lets either's+  exception escape, so a single throwing member stopped delivery to every+  sibling for the rest of the call and skipped their end-of-stream actions — an+  OpenTelemetry span paired with an unwritable file sink was opened and never+  ended, and nothing was exported. The step never blocks; the final action sends+  every member the sentinel, waits for every member, and reports one aggregate+  failure naming each failed member by zero-based index+  (`1 of 2 member sinks failed: member 0: …`). (REV-2 D.6.)++- `baikai`: `AgentSafety.allowedTools` is documented as the __grant__ it is.+  On Claude Code it renders `--allowedTools`, whose help reads "list of tool+  names to allow": it pre-approves tools the permission mode would otherwise+  raise a request for, and in an unattended run a request nobody answers is+  denied. The old Haddock called it "optional narrowing of the provider's tool+  set", which was the opposite, and `applyAgentCeiling` never looked at it. It+  is now bounded: a grant passes when the maximum capability implies it+  (`read-only` implies `Read`, `Glob`, `Grep`, `NotebookRead`, `TodoWrite`;+  `edit-workspace` adds `Edit`, `MultiEdit`, `Write`, `NotebookEdit`;+  `full-access` implies every grant) or when the operator named it in+  `policy.allowed-tools`. Matching is exact, so `Bash(git *)` is not `Bash`.+  A repository job that grants itself `Bash` under `edit-workspace` — which+  passed unexamined before — is now refused with exit 77 before any process is+  created. (REV-2 F.3.)++- `baikai` (breaking): `Baikai.Agent.CeilingViolation` gains five constructors:+  `ToolGrantForbidden`, `TimeoutExceeded`, `OutputLimitExceeded`,+  `RepositoryScopeForbidden` and `WorkingDirOutsideRepository`. A `case` over+  the type that was exhaustive is no longer.++- `baikai` (behaviour): the default ceiling has a finite `maxOutputLimit`, so+  `applyAgentCeiling defaultAgentCeiling` now refuses a request whose+  `outputLimit` is `Nothing` — capture without bound is exactly what the+  maximum exists to refuse. Jobs resolved through `baikai-agent` are unaffected:+  that layer's own default supplies a finite limit, and only an explicit+  `output-limit "unlimited"` reaches the ceiling as `Nothing`.++- `baikai`: a tool call cut off by the output cap is no longer executed.+  `runToolLoop` stops with the response and its tool calls intact when any call+  is cut off, and `appendToolResult` appends a `ToolResultMessage` with+  `isError = True` explaining why instead of calling the dispatcher. Previously+  both assemblers replaced truncated arguments with `{}` and a tool loop+  happily ran the call with no arguments at all. (REV-2 B.2.)++- `baikai`: `Baikai.Model.anthropicMessagesCompatFor` no longer overlays a+  thinking style guessed from the model id onto a model whose `compat` is+  `CompatNone`. `CompatNone` now means host auto-detection alone — the budget+  thinking shape, sampling parameters supported. Every catalog model carries an+  explicit record, so this changes nothing for them; a **hand-rolled** model+  naming an adaptive-era id (`claude-sonnet-5`, `claude-opus-4-7`,+  `claude-opus-4-8`, `claude-fable-5`) must now carry+  `CompatAnthropicMessages (defaultAnthropicMessagesCompat {thinkingStyle = AnthropicThinkingAdaptive, supportsSamplingParameters = False})`+  or start from the catalog value.++- `baikai`: `Baikai.Evidence.evidenceSchemaVersion` is now+  `baikai.model-call-evidence/1.1`. A minor bump: the two sampling adjustment kinds are a+  compatible addition, and no previously recorded digest changes.++- `baikai`: HTTP 413 classifies as `ContextOverflow` rather than `OtherError`,+  from the status alone and whatever the body says. 413 *is* the size-limit+  status and the caller's remedy — shrink the input — is the same either way;+  making the category depend on body wording would recreate for 413 the+  inconsistency this release fixes for connection resets. (REV-2 A.7.)++- `baikai`, `baikai-claude`, `baikai-openai`: an HTTP-date `Retry-After` is+  converted to seconds instead of ignored. Both transports use the response's own+  `Date` header as the reference instant, falling back to the local clock, so a+  CDN-fronted `429` — the common case for a date-valued `Retry-After` — now+  carries a hint rather than leaving the caller to guess. (REV-2 A.9.)++- `baikai`: **breaking.** `Baikai.Embedding.EmbeddingModel.apiKey` is now+  `Maybe ApiKeySource` rather than `ApiKeySource`. `Nothing` means the+  conventional environment variable for the model's host, from+  `defaultApiKeyEnvForBaseUrl` — the same table the chat providers use — and a+  host that table does not know refuses with an `AuthError` naming+  `EmbeddingModel.apiKey`. Migration: `apiKey = source` becomes+  `apiKey = Just source`. `EmbeddingModel` also derives `Eq` and `Generic`, so+  the `#field .~ value` idiom works on it as it does on every other record.+  (REV-2 E.3.)++- `baikai`: **breaking.** `AgentRunFailure`'s `RunTimedOut` constructor now+  carries a new record `AgentTimedOut` — the configured `limit` plus the+  `stdout` and `stderr` a timed-out run drained before its process group was+  killed — instead of a bare `NominalDiffTime`. A caller matching+  `RunTimedOut limit` becomes `RunTimedOut timedOut` and reads `timedOut ^.+  #limit`; `renderAgentRunFailure` is unchanged in what it says. The bytes were+  always there, drained from the moment the child was spawned, and were simply+  dropped on the timeout path — which is the run an operator most wants an+  account of, because the tool started, may have consumed tokens, and may+  already have changed the working tree.++- `baikai`: under `EvidenceRequired`, a successful terminal that carries no+  evidence record fails the call with `missingEvidenceError` rather than+  returning a silent success with zero `call_evidence` lines. Strict mode+  guaranteed that a record which was built and then lost fails the call; it did+  not guarantee that one was built. The rule is applied at both dispatch points,+  so `completeRequest` with no sink gets the same guarantee as a streaming call;+  a failed call keeps the provider's own error, and best effort is unchanged.+  See `docs/adr/0014-strict-evidence-means-a-record-exists.md`. (REV-2 D.3.)++- `baikai`: a caller's thinking level is recorded on every evidence path — the+  consumer abort, an unregistered provider, a `complete` handler that threw, and+  each provider's `immediateError`. The abort path asks the registered adapter's+  own `describeThinking`; the others record `not_translated`. All four used to+  record the caller's request as `absent`, which+  `docs/adr/0002-requested-translated-observed-are-never-collapsed.md` forbids.+  (REV-2 D.2.)++- **`baikai.model-call-evidence/2.0`.** Two digests cover different bytes, so a+  verifier must now select its rules by `schema_version`. `response_commitment`+  covers the provider-reported token counts and never baikai's computed cost:+  the cost comes from the caller's catalog rates rather than from the response,+  so the digest used to change whenever a price was edited and a verifier+  holding only the response could not recompute it. `request_configuration`+  summarises `output_config` and `response_format` as it already summarised+  `tools`, because a structured-output JSON schema carries author-written+  `description` strings and is content wherever it appears — the same schema was+  stripped from `tools[].input_schema` and survived verbatim through the other+  two keys. `thinking.mode` may also now be `"not_translated"`, which is a+  compatible addition. (REV-2 D.7, D.11.)++- **Breaking.** `baikai`: `Baikai.Provider.Registry.ApiProvider` gains a fifth+  field, `strengthCeiling :: EvidenceStrength`, and+  `Baikai.Evidence.Build.checkEvidenceRequirements` takes that ceiling where it+  took an `Api`. The gate compared against `declaredStrength`, a table keyed by+  the API tag, which necessarily answered `EvidenceRequestedOnly` for every+  `Custom` transport — so a gateway that genuinely observes a model could never+  satisfy a strict caller who required that it did. Only a provider knows what+  its evidence reaches. `EvidenceRequestedOnly` reproduces the old behaviour for+  any custom provider; the four built-in providers fill the field from+  `declaredStrength`, which is unchanged in value and still used by the+  unattended-agent surface. (REV-2 D.10, G.1.)++- `baikai`, `baikai-claude`, `baikai-openai`: one strength derivation replaces+  three. An observed **response id** now counts as correlation alongside a+  captured request-id header, so a host that names its model and its response id+  on every chunk but sends no header reaches `model_observed` instead of+  `requested_only` — which had put it *below* a host that sent only a header and+  named nothing. `anthropicStrength` and `openaiStrength` are removed;+  `Baikai.Provider.Cli.Internal.subprocessStrength` keeps its signature and+  delegates. (REV-2 D.10.)++### Removed++- `baikai` **0.6.0.0** (breaking): the sixteen `_Type` base-value aliases deprecated in+  0.3.0.0 — `_Options`, `_Context`, `_Model`, `_ModelCost`, `_Response`,+  `_Usage`, `_Cost`, `_CostBreakdown`, `_Tool`, `_TextContent`,+  `_ThinkingContent`, `_ToolCall`, `_ImageContent`, `_EmbeddingModel`,+  `_InteractiveLaunchRequest` and `_InteractiveLaunchResult`. Each has an+  `empty…` or `zero…` replacement of the same value, named in the pragma that+  has been on it since 0.3.0.0. The 0.3.0.0 entry said they remained "for this+  release"; 0.4.0.0 and 0.5.0.0 shipped without removing them because no entry+  named a version.+  `docs/adr/0016-deprecated-names-are-removed-at-the-next-major.md` now fixes+  the rule: a name deprecated in `A.B.0.0` is removed in `A.(B+1).0.0`, and+  every pragma says so. (REV-2 G.3.)++- `baikai` **0.6.0.0** (breaking): `Baikai.Trace.newEventId`. It has delegated to+  `Baikai.Evidence.newCallId` since 0.5.0.0; call that. (REV-2 G.3.)++- `baikai` **0.6.0.0** (breaking): `Baikai.Compat.defaultAnthropicThinkingStyle`, deprecated+  earlier in this cycle. Nothing in baikai consults it — the thinking style of a+  first-party Anthropic model is a field of its generated catalog record+  (`Baikai.Models.Generated`); start from that value, or set+  `CompatAnthropicMessages` explicitly.++- `baikai` (breaking): `AgentRunRequest.envPassthrough` is renamed `envRequires`.+  The field is a list of variables the job declares it requires, checked as a+  precondition; it has never passed anything through, and the KDL key has said+  `env-requires` since the setting existed.++- `baikai` (breaking): `AgentRunFailure.OutputMalformed`, and with it+  `baikai-agent`'s exit code 70 and its `internalExitCode` export. Nothing ever+  constructed the constructor, and giving it a producer would have been wrong:+  the runner treats the tool's output as best-effort observation and its+  deliverable is the changed working tree, so a run that edited files correctly+  and then printed an unparseable final line would have been reported as a+  failure with its exit code and output discarded. A record's `strength` and+  `unobserved` fields already say when output could not be read. (REV-2 F.13.)++### Fixed++- `baikai`: the terminal event and its evidence record are pushed to the trace+  sink exactly once under asynchronous exceptions. The terminal path pushed the+  evidence record, pushed the terminal event and only then set the+  already-sent flag; an exception delivered between the last two made the+  stream finaliser read the flag as unset and push a second `CallEvidence` and+  an `aborted` `CallFailed` after the real `CallFinished`, so a sink saw two+  records and two contradictory terminals for one call. All three writes now+  run inside one `uninterruptibleMask_` with the flag first. (REV-2 D.4.)++- `baikai`: `Baikai.Cost.Log.closeCallLog` is idempotent. The first caller+  claims the handle and waits for the worker; a second returns at once instead+  of blocking forever on an `MVar` the worker had already emptied — a shape+  `withCallLog` makes easy to reach, since its bracket closes a handle the body+  may also have closed. An `appendEntry` after the close enqueues nothing.++- `baikai`: `reassembleResponse` is total under duplicated, late and+  timestamp-less input. The first `EventStart` wins the skeleton and+  `responseId` merges with `<|>`, so a later `Nothing` cannot erase an id an+  earlier event supplied; events after the first terminal are ignored, so a+  producer that keeps talking cannot rewrite the answer; and `latencyMs` falls+  back to the reassembler's own wall clock when neither the skeleton nor the+  terminal carries a provider timestamp, instead of reporting a zero that reads+  as "instant". (REV-2 B.7.)++- `baikai`: an `EmbeddingModel` pointed at a non-OpenAI host no longer sends+  `OPENAI_API_KEY` to it. The default key source was that variable whatever the+  base URL said, so pointing the client at DeepSeek handed DeepSeek an OpenAI+  credential. It now resolves per host, and refuses an unknown one. New+  `resolveEmbeddingKey` and `embeddingClientEnv` expose both decisions without+  making a request. (REV-2 E.3.)++- `baikai`: `Baikai.Embedding.embed` no longer allocates a TLS manager per call.+  It used the `openai` SDK's own `getClientEnv`, which builds a fresh manager+  every time; it now takes one from `Baikai.Http`'s process-global cache, the+  same one the chat providers use, so an embedding call and a chat call to one+  host share a connection pool.++- `baikai`: **a credential in a header is no longer printed.** `Options.headers`+  and `Model.headers` went through derived `Show` and `ToJSON` instances that+  rendered every value verbatim — while `Baikai.Options`' own documentation+  invites callers to put a gateway's `Authorization` header there and the+  getting-started guide tells them to `print resp`, which renders the embedded+  `Model`. Both types now have hand-written instances that render exactly what+  the derived ones did, except that the value of a header whose name looks+  credential-carrying (`authorization`, `api-key`, `apikey`, `token`, `secret`,+  `cookie`, `password`, or any name ending in `-key`, case-insensitively) prints+  as `<redacted>`. `Baikai.Auth` exports the three pieces — `redactedMarker`,+  `isCredentialHeader`, `redactHeaderValues` — so a caller can apply the same+  rule to its own logging. Only the rendering changes: the field is untouched,+  `Eq` is untouched, and the header is still sent as written. A JSON round trip+  of a `Model` is deliberately lossy, since a serialised `Model` is exactly the+  thing that should not carry a key. (REV-2 E.2.)++- `baikai`: an API-key environment variable set to the empty string, or to+  nothing but whitespace, now counts as **unset**. `ApiKeyEnv` fails with an+  `AuthError` naming the variable and saying it is not set or is empty;+  `ApiKeyEnvChain` skips it and continues, and reports every name when none+  yields a key. Previously an empty variable resolved to an empty key, which+  short-circuited a chain and produced `Authorization: Bearer ` and a provider+  401 that said nothing about the cause. A key with real content is still passed+  through untrimmed. (REV-2 E.6.)++- `baikai`: **the host parse no longer lets a base URL choose which key baikai+  sends.** `urlHost` took the text after the *last* `@` anywhere in a URL, so+  `https://proxy.example.com/v1?u=@api.openai.com` named the host+  `api.openai.com`: `defaultApiKeyEnvForBaseUrl` resolved `OPENAI_API_KEY`,+  `autoDetectOpenAICompletions` returned OpenAI's own compatibility record, and+  the bearer token went to `proxy.example.com`. Anyone who could set `baseUrl` —+  a `Model` decoded from JSON, a proxy override — could pick which provider's+  credential to be handed. The same defect broke the benign direction:+  `https://api.openai.com/v1/@x` named the host `x` and resolved no key at all.+  The authority now ends at the first `/`, `?` or `#`, and userinfo is only ever+  the last `@` inside it. (REV-2 A.1 / E.1.)++- `baikai`: `Baikai.Evidence.Build.sanitizeEndpoint` was a second, separately+  written parser that bounded the authority at the first `/` only, so a URL with+  a query and no path recorded the wrong host. It is now `renderEndpoint <$>+  parseUrl`, which also means a recorded endpoint has a lower-cased scheme and+  host; the path keeps its case and trailing slash.++- `baikai`: `parseCodexJsonlStream` assembles lines in **linear time**. It+  previously unpacked every chunk into a stream of bytes and appended them one+  at a time with `BS.snoc`, copying the whole accumulator per byte — quadratic+  in line length, so one codex event carrying a two-million-character message+  cost on the order of a trillion byte moves and in practice never finished.+  Lines are now cut out of each chunk with `BS.elemIndex` and `BS.splitAt`, and+  the pieces of a line that spans a chunk boundary are joined once. Behaviour is+  unchanged: a non-JSON line is still skipped, and a last line without a+  trailing newline is still parsed.++- `baikai`: a Codex custom agent's instructions body renders as a TOML+  **literal** multi-line string (`'''`), which interprets nothing, instead of a+  basic one (`"""`), which interprets backslash escapes. As a basic string an+  instruction as ordinary as "match `\d+`" made Codex refuse to load the file;+  `tomllib` rejects the old output with `Unescaped '\' in a string`. A body a+  literal string cannot hold — one containing three apostrophes, a bare carriage+  return, or a control character other than tab and newline — falls back to a+  fully escaped basic string. `tomlString`, which renders `name` and+  `description`, now escapes every control character as TOML 1.0 requires+  instead of only the five it happened to name.++- Documentation: `baikai`'s Haddock no longer describes behaviour the code left+  behind. The trace event's token counts are `Maybe` because a non-assistant+  terminal has no usage, not because the CLI providers report nothing — since+  0.5.0.0 both carry what the tool reported. `EventStart`'s `partial` is a+  message skeleton with empty content, zero usage and no stop reason; the api,+  provider and model id live on the `Response`. A lifted stream's `EventStart`+  carries the final usage and stop reason already filled in, because the+  response is complete before the stream begins. `Baikai.CacheRetention` no+  longer mentions an OpenAI Responses 24-hour bucket no code emits. System+  prompts are documented as living on `Context.systemPrompt` rather than on a+  `Baikai.Request` module that no longer exists, `emptyModel`'s `compat` is+  described as auto-detection rather than a placeholder, tool dispatch says+  calls run one at a time in order, and every reference to a plan number is+  gone. (REV-2 H.4.)++## [baikai-claude 0.6.0.0] - 2026-08-28++### Added++- `baikai-claude`: `Baikai.Provider.Claude.Internal.Request` exports `planRequest`,+  `SamplingPlan`, `uncappedMaxTokensFloor` and `normalizeToolCallId` as test seams.+  `planThinking` and `describeThinkingFor` are now projections of `planRequest`, so the+  strict gate, the request builder and the evidence record read one answer.++### Changed++- `baikai-claude`, `baikai-openai` (breaking): each provider's streaming+  machinery moved from `Baikai.Provider.<P>.Api` to+  `Baikai.Provider.<P>.Internal.Stream` — the `SseDriver` seam, `liveSseDriver`,+  `<p>StreamWith`, `Assembler`, `emptyAssembler`, `translate`, and on the OpenAI+  side `RawChunk`, `RawToolDelta`, `parseChunk`, `parseFrame`, `TagScanState`,+  `scanThinkTags`, `closeOpenStream`, `RawUsage`, `parseUsage` and+  `rawUsageToUsage`. `Api` now exports exactly `register`, the provider value+  and the live stream function. The `.Internal` module is exposed for the test+  suites and sibling packages and, like every `.Internal` module, may change in+  any release without a major bump — so changing the assembler stops being a+  documented break. `Shape`, `Sse` and `Transport` keep their names and gain the+  same no-guarantees header. `_TagScanState` is renamed `emptyTagScanState`.+  (REV-2 G.1.)++- `baikai-claude`, `baikai-openai`: a consumer that stops reading now stops the+  provider. Both packages fork their SSE worker under `Stream.bracketIO` and+  hand frames through the bounded `FrameQueue` above instead of an unbounded+  `Chan`. A consumer that cancels — `Ctrl-C`, `System.Timeout.timeout`,+  `cancel` — releases the HTTP connection immediately; a consumer that abandons+  the stream (`Stream.take 3`) stops the socket read within 64 further frames+  and releases the connection at the next major garbage collection. Previously+  the worker read the entire generation into memory for a consumer that would+  never look at it, and the provider billed all of it. The three cleanup+  strengths are stated in+  [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md)+  and in caller terms in `docs/user/streaming.md`.++- `baikai-claude`: `anthropic_claude_sonnet_4_6` now sends the adaptive+  thinking shape rather than `budget_tokens`. The budget shape is deprecated+  for that generation; baikai sends the shape Anthropic documents as current.++- `baikai-claude`, `baikai-openai`: **behaviour change.** `Options.timeoutMs` of+  `Just n` with `n <= 0` is refused as `InvalidRequest` before the action runs, so+  no connection is opened. `System.Timeout.timeout` returns immediately at zero+  and runs unbounded below it, and the previous `max 0` clamp made both spellings+  fail instantly as a *retryable* `TransientError` — a classification a caller's+  retry loop re-issues forever for what is a configuration mistake. `Nothing`+  remains the only spelling of "no bound". (REV-2 A.10.)++- `baikai-claude`, `baikai-openai`: an evidence record's `endpoint` names the+  host the call actually went to. Both adapters substitute a vendor default for+  an empty `Model.baseUrl` inside `prepareCall`, so a call with a perfectly+  definite destination recorded `endpoint: null`. Where no adapter ran, `null`+  remains the truthful answer. (REV-2 D.8.)++- `baikai-claude`: the `claude` dependency moves from `^>=1.4` to `^>=1.5`.+  1.5.0 adds a `Pause_Turn` constructor to `Claude.V1.Messages.StopReason`, and+  `mapStopReason` matches that type with no wildcard under+  `-Werror=incomplete-patterns`, so the bump forced a decision. A paused turn+  maps to `Stop`: Anthropic suspends the turn mid-flight for a long-running+  server-side tool and expects the caller to send the message back to continue+  it, so nothing failed, and `Baikai.StopReason` has no constructor that says+  "resume me". Widening that public sum is a breaking change for every consumer+  who matches on it exhaustively, and it is not this bump's to make. The general+  rule is+  [ADR 0018](docs/adr/0018-a-provider-stop-reason-with-no-baikai-equivalent-maps-to-the-nearest-truthful-one.md):+  a provider stop reason with no baikai equivalent maps to the constructor that+  is truthful about whether the call failed, and the sum widens only when baikai+  would behave differently for it.++- `baikai-claude`: `Messages.StreamUsage` lost its `Generic` instance in `claude`+  1.5.0, so the `message_delta` usage is read through `OverloadedRecordDot`+  rather than a generic-lens label. `Messages.max_tokens` and+  `Messages.output_config` became ambiguous selectors — `Messages.Fallback`+  carries both names — so the provider's tests read them through `^. #max_tokens`+  and `^. #output_config` instead.++### Removed++- `baikai-claude`, `baikai-openai` **0.6.0.0** (breaking): the eight registration shims —+  `registerWith`, `registerWithRegistry` and `registerWithRegistryAndConfig` in+  both `Cli` modules, and `registerWithRegistry` in both `Api` modules. Register+  the exported provider value instead:+  `registerApiProvider (claudeCliProvider cfg)`,+  `registerApiProviderWith reg (codexCliProvider cfg)`,+  `registerApiProviderWith reg claudeMessagesProvider`. The batch-mode note that+  had accumulated on `registerWith` — why `complete` stays on the direct path+  rather than going through `streamingComplete` — moves to the provider value it+  describes. (REV-2 G.3.)++- `baikai-claude`, `baikai-openai`: `responseToError` and `classifyErrorText`+  (and its private `classifySdkHttpText` half) from both+  `.Internal.ErrorClass` modules. Neither package runs a `servant-client` client+  on the chat path any more, so the `ClientError` branch was unreachable, and the+  text classifiers parsed a string shape the local SSE transports stopped+  producing in July. The phrase table `classifyErrorText` held survives as the+  message fallback inside `classifyErrorFrame`, pinned through the entry point the+  runtime actually uses. Both modules are documented as outside the PVP-stable+  surface, so this is not a major bump; version bumps are recorded once, later.++- **Breaking.** `baikai-claude`: `Baikai.Provider.Claude.Api.anthropicStrength`+  and `baikai-openai`: `Baikai.Provider.OpenAI.Api.openaiStrength`, both replaced+  by `Baikai.Evidence.deriveStrength`.++### Fixed++- `baikai-claude`, `baikai-openai`: a failure that lands while the response body+  is streaming is classified as the transient failure it is. A connection reset,+  a server closing the socket mid-chunk, a body shorter than its declared length+  and a TLS session torn down after the handshake all now terminate the stream+  with `TransientError` and `isRetryable = True`, carrying whatever text had+  already been drained. Every one of them used to be `OtherError` with+  `isRetryable = False`, while the identical failure at connect time was+  transient — because `http-client` wraps the connect phase with the manager's+  exception wrapper and the body reader with nothing that converts a socket+  `IOException` or a `TLSException`, so those reached the worker raw and missed+  the `HttpException` branch entirely. (REV-2 A.2.)++- `baikai-claude`, `baikai-openai`: a transport failure mid-stream now closes+  the blocks that were open when it arrived, on both providers, so a consumer+  reading raw events and a consumer reassembling them see the same partial+  output. Both providers built their terminal from the closed blocks alone and+  silently dropped open text, thinking and tool arguments. On the Claude side+  this covers `translate (Left …)`, the in-band `error` frame, and the+  unexpected end of stream. (REV-2 B.3.)++- `baikai-claude`: an SSE frame whose event `type` — or whose+  `content_block_delta` `delta.type` — the SDK has no constructor for is now+  skipped instead of ending the stream with a decode error. The SDK decodes both+  with no unknown-tag fallback, so a new frame type from Anthropic used to be a+  terminal fault. A frame of a *known* type that still fails to decode remains+  one. `Baikai.Provider.Claude.Sse` exports the new `decodeFrame`. (REV-2 B.5.)++- `baikai-claude`, `baikai-openai`: an empty `data:` heartbeat is ignored, and+  on the OpenAI side `[DONE]` is compared after trailing whitespace is trimmed,+  so `data: [DONE] ` and `data: [DONE]\r` end the stream rather than failing to+  decode. (REV-2 A.8.)++- `baikai-claude`: every failing stream now begins with `EventStart`. The+  producer pre-seeds the start event before the first wire read, exactly as the+  OpenAI producer already did, and `message_start` updates the assembler without+  emitting a second one. Previously a 401, a rate limit, an in-band `error`+  frame or an EOF arriving before `message_start` produced a lone `EventError`,+  breaking the protocol `Baikai.Stream.Event` documents. `StartPayload.responseId`+  is consequently `Nothing` on both HTTP providers; the provider's message id+  rides `TerminalPayload.responseId`, which `reassembleResponse` already prefers.+  (REV-2 A.4, REV-1 Theme 1.1.)++- `baikai-claude`, `baikai-openai`: an asynchronous exception delivered to the+  stream worker can no longer strand its consumer. End-of-frames is a flag set+  by the worker fork's own `finally` rather than a sentinel value pushed onto+  the channel, so a worker that dies without running its normal exit path still+  ends the stream in an `EventError`. Previously the consumer blocked until the+  runtime's deadlock detector noticed.++- `baikai-smoke`: two keyed cases against `claude-sonnet-5` — one asking for+  thinking (which is a 400 before this release) and one setting `temperature` — plus+  `deepseek-chat` and `openrouter/openai/gpt-4o-mini` in `apiCases`, so the tool and+  structured-output smokes run against a compatible host that is not OpenAI.+  `CompatSmoke` now asserts DeepSeek honoured the output cap rather than only that it+  answered, and `CacheSmoke` asserts the cached token classes cost something.++- `baikai-claude`: a thinking request on `claude-sonnet-5` no longer 400s. It sends+  `"thinking":{"type":"adaptive"}` and no `budget_tokens`, because the shape is read off+  the model's catalog record rather than guessed from its id. (REV-2 C.1.)++- `baikai-claude`: `temperature` and `top_p` are no longer sent to a model generation that+  rejects them with a 400. They are omitted and the omission is recorded as+  `sampling_dropped_unsupported_model` in the call's evidence. `seed`, `frequencyPenalty`+  and `presencePenalty`, which the Anthropic Messages API has no field for on any+  generation, are recorded as `sampling_dropped_unsupported_api`. (REV-2 C.1, C.5.)++- `baikai-claude`: a model whose `maxOutputTokens` is `0` no longer sends+  `"max_tokens":0`, which Anthropic rejects — and, with thinking set, no longer had its+  whole thinking plan discarded for not fitting inside a ceiling of zero. It sends+  `uncappedMaxTokensFloor` (1024, the SDK's own default) instead. An explicit+  `maxTokens = Just 0` is still forwarded as written. (REV-2 C.2.)++- `baikai-claude`: replay no longer sends an empty text block or an empty `content` array,+  both of which Anthropic rejects. An empty text block is dropped; an assistant turn left+  with nothing is dropped whole (it is baikai's own artifact — a block that closed with no+  deltas, or only unsigned thinking, which replay already omits); a user turn left with+  nothing is refused locally with a message naming the turn. (REV-2 C.3.)++- `baikai-claude`: tool-call ids that differ only in characters the alphabet forbids, or+  only past character 64, no longer normalise onto the same id and misroute a tool result.+  A conforming id passes through unchanged — every id Anthropic and OpenAI actually mint+  does — and any other is truncated to 51 characters and suffixed with twelve hex+  characters of its SHA-256. Two `tool_use` blocks in one turn that still collide are+  refused rather than sent. (REV-2 C.7.)++- Documentation: `baikai-claude`'s and `baikai-openai`'s Haddock point at the+  functions that exist. `Baikai.Compat` named+  `Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat`,+  `…Api.applyThinkingFormat` and `…Api.translateTextLikeDelta`; the first two+  moved to `…Internal.Request` and the third is+  `…Internal.Stream.scanThinkTags`. `ThinkingFormat`'s note said the six+  non-native shapes all clamp through `compatibleEffort`; three do, Z.ai and+  Qwen send a bare toggle, and `ThinkingFormatNone` drops the control.+  `immediateError` carried two `-- |` headers where one was intended.+  (REV-2 H.4.)++- `baikai-claude`: an Anthropic call reports its thinking tokens. `Usage.reasoningTokens`+  was hard-coded to `Nothing` on this provider because `claude` 1.4.0's+  `Messages.Usage` had no breakdown to read; 1.5.0 adds+  `output_tokens_details.thinking_tokens`, and both `message_start` and+  `message_delta` now fill the field from it. `reasoningTokens` is an+  informational subset of `outputTokens`, so no total and no cost moves.++- `baikai-claude`: the prompt-side token counts survive a server-side tool run.+  The final `message_delta` used to contribute only `output_tokens`, and+  `inputTokens`, `cacheReadTokens` and `cacheWriteTokens` kept whatever+  `message_start` had reported — which is wrong for a call whose prompt grew+  mid-stream. `claude` 1.5.0 exposes those three on `Messages.StreamUsage`, and+  each is now taken when present. An absent field still keeps the+  `message_start` figure rather than zeroing it, so a model that sends only+  `output_tokens` is accounted for exactly as before.++## [baikai-openai 0.6.0.0] - 2026-08-28++### Added++- `baikai-openai`: `Baikai.Provider.OpenAI.Internal.ErrorClass.classifyErrorFrame`+  and `Baikai.Provider.OpenAI.Api.parseFrame`, which sort a decoded SSE payload+  into a classified in-band error or a completion chunk.++### Changed++- `baikai-openai`: **breaking.** `Baikai.Provider.OpenAI.Shape`'s+  `injectThinkingShape`, `describeThinkingShape`, `shapeRequestBody` and+  `streamRequestBody` take a `Bool` after the compat record — whether the model+  advertises reasoning support (`Model.reasoning`). A level on a `reasoning = False`+  model now sends no `reasoning_effort`, `reasoning`, `thinking` or `enable_thinking`+  key on any host, and records `thinking_dropped_unsupported_model` instead. The model+  check runs before the host-format check. This is what stops `gpt-4o-mini` plus a+  level from 400ing. (REV-2 C.4.)++### Fixed++- `baikai-openai`: an in-band `{"error": …}` frame on a `2xx` stream terminates+  the call with the frame's own classification, status and message. Compatible+  hosts (OpenRouter, DeepSeek, Together) report an upstream failure they only+  learned about after committing to a `200` this way, and `parseChunk` never+  looked at `error`. The pre-fix behaviour was worse than a bad category:+  OpenRouter's frame carries `choices[0].finish_reason = "error"`, which mapped+  to `Stop`, so the call ended as `EventDone` with `errorInfo = Nothing` — a+  consumer switching on the terminal saw a *completed* call. A frame with no+  `choices` beside the error ended as+  `OtherError "openai stream ended without finish_reason"`. (REV-2 A.3.)++- `baikai-openai`: reasoning that arrives after visible text closes the open+  text block before opening the thinking block, so at most one of the two is+  open at a time, every `_End` precedes the next `_Start`, and no `contentIndex`+  is revisited after a later one. (REV-2 B.4.)++- `baikai-openai`, `baikai-claude`: **a provider POST no longer follows+  redirects.** `http-client`'s default is to follow up to ten with every header+  intact, so a 3xx would have re-sent the bearer token (or `x-api-key`) to+  whatever host the `Location` header named. `redirectCount` is now zero and the+  3xx is delivered as the one in-band terminal error carrying its status. Each+  transport's request builder is exported as `buildRequest`, so the method, the+  composed path and the redirect policy are assertable without a connection.+  (REV-2 A.5 / E.4.)++- `baikai-openai`, `baikai-claude`, `baikai`: **the base-URL convention is+  stated and enforced.** `Model.baseUrl` and `EmbeddingModel.baseUrl` are the+  API *root* — the host, or the prefix a host mounts the API under — because+  baikai appends `/v1/chat/completions`, `/v1/messages` or `/v1/embeddings`+  itself. A trailing `/v1` is accepted and removed rather than doubled, so+  `https://api.deepseek.com/v1` now requests `/v1/chat/completions` instead of+  `/v1/v1/chat/completions`. A base URL with no scheme, a scheme other than+  `http`/`https`, credentials, a query string, a fragment, or a path that is+  already an endpoint is refused as an `InvalidRequest` naming the problem —+  and refused *before* a key is read, so an unusable base URL never causes a+  credential to be looked up. The message renders the URL without its userinfo+  or query, so it is safe to log. `docs/user/models-and-providers.md` gains a+  **Base URLs** section stating all of it. (REV-2 A.6.)++- `baikai-openai`, `baikai-claude`: the `ClientEnv` cache was duplicated in each+  package and keyed on the raw base-URL text, so `https://h` and `https://h/`+  were two TLS managers and two connection pools to one host. There is now one+  cache, in `Baikai.Http`, keyed on the canonical rendering of the parsed base+  URL. `Transport.getClientEnvCached` and `Transport.cachedClientEnvCount` are+  re-exports of the core functions and keep their signatures.++- `baikai-openai`: the Codex interactive launcher now **refuses the two approval+  policies the installed CLI rejects**. `codex --help` at `codex-cli 0.149.1`+  lists exactly `on-request` and `never` for `--ask-for-approval`;+  `CodexApprovalUntrusted` and `CodexApprovalOnFailure` are older spellings the+  CLI answers with `error: invalid value 'untrusted' for+  '--ask-for-approval'`. Rendering them made a launch return `Right` carrying a+  non-zero exit code — a session that ran and failed — instead of the `Left+  SafetyNotExpressible` this module promises for a policy that cannot be+  honoured. They are refused before any process is created, and refused rather+  than quietly mapped onto `on-request`, because substituting a different+  approval policy would change what the caller asked for. The constructors and+  their spellings are unchanged, so code that matches on `CodexApprovalPolicy`+  keeps compiling.++## [baikai-trace-otel 0.4.0.0] - 2026-08-28++### Added++- `baikai-trace-otel`: `OtelSinkOptions` derives `Generic`, so `#spanName`+  resolves on it. No `Eq` or `Show`: `OpenTelemetry.Context.Context` has neither,+  and an instance that ignored `parentContext` would be a lie. (REV-2 G.6.)++- `baikai-trace-otel`: `OtelSinkOptions.parentContext :: Maybe Context`, default+  `Nothing`. When set, every span the sink opens becomes a child of the span in+  that context instead of a root, so a call can be nested under the caller's own+  request span. It is a value fixed when the sink is built rather than an action+  run per call, because the fold runs on baikai's trace worker thread where the+  caller's thread-local context is invisible: capture the context on your own+  thread (`ctx <- getContext`, or `Context.insertSpan mySpan Context.empty`) and+  build the sink for that request. __Breaking for positional construction__ of+  `OtelSinkOptions`; the documented path is a record update on+  `defaultOtelSinkOptions`. (REV-2 D.9.)++### Changed++- `baikai-trace-otel`: the `baikai.evidence.strength` span attribute is rendered+  by `Baikai.Evidence.renderEvidenceStrength`, the function the JSON encoding+  uses, instead of a second spelling local to the sink that could drift from it.++- `baikai-trace-otel`: `gen_ai.response.model` is set only by the evidence+  branch, from the model the provider reported. The terminal branch set it from+  the *requested* id, and since evidence is pushed before the terminal and+  `addAttributes` replaces a key, that both labelled a request as an observation+  on every call without evidence and overwrote the genuinely observed value on+  every call with one. (REV-2 D.1.)++## [baikai-effectful 0.4.0.0] - 2026-08-28++### Changed++- `baikai-effectful` (breaking): the version is a **major** bump although this+  package's own exports are unchanged. Its `baikai` bound moves to `^>=0.6.0`,+  and the `Baikai` effect's three operations are typed in `Model`, `Context`,+  `Options` and `Response` — every one of which baikai 0.6.0.0 changes+  breakingly. A consumer therefore meets a break through this package even+  though nothing in it was renamed, so the number says so rather than making+  `0.3.0.4` look like a safe upgrade.++- `baikai-effectful`: no longer depends on `streamly`. Both stanzas listed it+  while every module imports only `Streamly.Data.Fold` and+  `Streamly.Data.Stream`, which are `streamly-core`. (REV-2 minor.)++## [baikai-kit 0.2.0.0] - 2026-08-28++### Added++- `baikai-kit`: `Baikai.Kit.Error` with the closed `KitError` sum, its+  `Exception` instance and `renderKitError`; `Baikai.Kit.Path.safeSourcePath`,+  which resolves an untrusted relative source below the kit checkout and refuses+  a symbolic link in any component or a canonical path outside the checkout;+  `Baikai.Kit.Manifest.itemSources`/`ItemSources`, the one pure derivation of an+  item's source list, and `supportedManifestVersions`;+  `Baikai.Kit.Sidecar.hashEntries`; `Baikai.Kit.Repo.KitRepo`/`RepoRefresh`;+  `Baikai.Kit.Install.installFrom`, `renderAvailable` and `UpdateReport`;+  `Baikai.Kit.Status.StatusReport`, `UpstreamAvailability` and the now-pure+  `renderStatusTable`; `Baikai.Kit.Command.runKitCommand`. `KitState` gains+  `KitUpstreamRefused`, rendered `refused`. (REV-2 E.5, F.10, F.11.)++- `baikai-kit`: `Baikai.Kit.Install.OverwritePolicy` (`KeepLocalEdits`,+  `OverwriteLocalEdits`), `reinstallPresent` (the network-free half of+  `updateKit`), and `PlannedWrite`/`WriteContent`/`executePlan`/`executePlanWith`+  as a test seam. `SidecarMeta` gains `installedFiles` and `installedHash`,+  which record what this tool wrote for one provider and the hash of exactly+  those bytes; `newSidecarMeta` takes both. `kit update` gains `--force`.+  (REV-2 F.12, Theme 8.2.)++### Changed++- **Breaking.** `baikai-kit`: every library function returns+  `Either KitError a` and prints nothing; only+  `Baikai.Kit.Command.runKit` prints `Error: …` and exits 1. `loadManifest`,+  `loadManifestMaybe`, `installItem`, `listAvailable`, `uninstallItem`,+  `updateKit` and `ensureKitRepo` change shape accordingly, `computeKitHash`+  takes the kit root, a base and relative file names, `kitStatus` returns a+  `StatusReport` instead of printing, and `KitUpdate`'s report is rendered by+  the caller. See `docs/adr/0013-library-code-never-calls-exitfailure.md`. A+  consumer that only calls `runKit` and `kitCommandParser` needs no change; one+  that calls the library directly binds `Right`. (REV-2 F.11.)++- `baikai-kit`: a kit is plain files. Install, the content hash and `kit status`+  resolve every listed source through `safeSourcePath`, so a kit repository that+  commits a symbolic link can no longer have a file read through it and copied+  into a provider directory. `kit status` shows such an item as `refused`.+  (REV-2 E.5 = F.10.)++- `baikai-kit`: a manifest whose `version` is not 1 or 2 is refused with+  `KitManifestVersionUnsupported` instead of being decoded and installed.+  (REV-2 F.12.)++- `baikai-kit`: an agent that lists several `files` installs all of them. The+  first becomes the provider's agent file as before, and each remaining file+  goes into a resource directory named after the agent beside it+  (`<agents dir>/<name>/<file>`), which uninstall removes with the agent. Only+  the first file used to be installed. (REV-2 F.12.)++- `baikai-kit`: `kit update` skips an item whose installed files no longer hash+  to what its sidecar recorded, printing the `--force` invocation that would+  overwrite them; `kit update --force` reinstalls anyway. Sidecars written+  before this release carry no such hash and are updated without the check.+  (REV-2 Theme 8.2.)++### Removed++- **Breaking.** `baikai-kit`: `Baikai.Kit.Path.safeUnder` (exported and unused),+  `Baikai.Kit.Manifest.agentSources` (replaced by `itemSources`) and+  `Baikai.Kit.Install.uninstallOutcomes` (absorbed by `uninstallItem`, which now+  returns the outcomes for the caller to render). The internal `requireSafe` and+  `Baikai.Kit.Status.resolveCacheOrEmpty` are gone with the exits they wrapped.++### Fixed++- `baikai-kit`: `kit status` with no cache and no network prints+  `No kit items installed.` and exits 0. It used to exit 1: the guard around+  `ensureKitRepo` caught `IOException`, which is not what `exitFailure` throws.+  (REV-2 F.11.)++- `baikai-kit`: `Baikai.Kit.Status.upstreamHash` joined the manifest `path`+  without validating it, a second unsanitised join that grew after the July+  hardening pass validated the first. Both now go through `itemSources` and+  `safeSourcePath`. (REV-2 Theme 8.1.)++- `baikai-kit`: an install that fails while renaming files into place now+  restores what was there before, or names the paths it could not restore.+  Phase two was a bare loop of renames, so a failure part-way left earlier+  renames in place while the message said "no changes were made". Temporary+  files are also created with `openTempFile`, so two concurrent installs of one+  item no longer clobber each other's staging file, and a destination that is a+  directory is refused before anything is written. (REV-2 F.12.)++- `baikai-kit`: `Baikai.Kit.Install.stripYamlFrontmatter` normalises line+  endings to LF on every branch. Input without frontmatter, and input whose+  frontmatter is never closed, used to keep their `\r` characters and leak them+  into the Codex agent TOML. (REV-2 Theme 8.7.)++- `baikai-kit`: an `IOException` raised while reinstalling during `kit update`+  is returned as `KitWriteFailed` instead of escaping as an uncaught exception.+  (REV-2 Theme 8.4.)++## [baikai-agent 0.2.0.0] - 2026-08-28++### Added++- `baikai-agent`: three operator-only `policy` keys — `policy.allowed-tools`,+  `policy.max-timeout` (a duration or `"unlimited"`) and+  `policy.max-output-limit` (a byte count or `"unlimited"`) — each defaulting+  from `defaultAgentCeiling`, and all six ceiling fields now printed by+  `agent show` and carried in its `--json` object.++- `baikai-agent`: `Baikai.Agent.Config.repositoryScopeViolations`, which reads+  the resolution report to say which values the untrusted repository file was+  not allowed to supply at all. `Baikai.Agent.Cli` concatenates its answer with+  the pure ceiling's, so an operator sees one refusal naming every problem.++### Changed++- `baikai-agent` (breaking): `AgentConfigScope`'s constructors are+  `AgentUserScope` and `AgentRepositoryScope`. `UserScope` collided with+  `baikai-kit`'s `KitScope` constructor of the same name, the one clash between+  two baikai-family packages. (REV-2 G.5.)++- `baikai-agent` (breaking): a relative `working-dir` resolves against the+  repository root rather than the process's own directory, so `working-dir "."`+  means the checkout whichever file declared it. Resolving against the process+  directory made `"."` mean two places when two documents defined one job, since+  which one it was depended on which layer won. An absolute path is unchanged.+  (REV-2 F.14.)++- `baikai-agent` (breaking): every `--json` output is now built with `aeson`+  rather than a hand-rolled writer, and `agent show --json` always emits one+  object with the same seven keys — `job`, `outcome` (`shown`, `refused` or+  `failed`), `exitCode`, `message`, `configuration`, `ceiling`, `command` —+  with `null` for the parts that do not apply. Previously a refusal emitted a+  different shape from a success and a document that would not parse emitted a+  bare resolution report or nothing at all, so a reader had to know which+  failure mode it was looking at before it could find the exit code. `run --json`+  keeps its `outcome` values and `list --json` is unchanged. (REV-2 F.14.)++- `baikai-agent` (breaking): `--run-id` or `--require-evidence` without either+  `--evidence-file` or `--json` is now a usage error (64) naming both fixes.+  Before, the record was built — a `--version` probe of the tool and two digests+  — and then dropped. Under `--json` the record now travels in the envelope as+  `evidence`, encoded by the same `ToJSON` `--evidence-file` writes.++- `baikai-agent`: `agent show` and `agent run` no longer print another job's+  unknown-key warnings, or the operator file's `policy` keys. The declaration+  describes one job and the ceiling is a separate declaration, so `settei` warns+  about both; neither is a mistake and a document with four jobs printed three+  jobs' worth of noise on every run. A misspelled key inside the selected job+  still warns, and a `policy` node in the *repository* document earns exactly one+  notice saying it has no effect. `Baikai.Agent.Config` exports the two filters,+  `relevantWarnings` and `repositoryPolicyNotice`. (REV-2 F.13.)++- `baikai-agent`: an evidence record's `endpoint` resolves a relative executable+  against the job's working directory before probing it, because that is what+  the child execs. A job whose `executable` is `./bin/agent` previously reported+  a path resolved against the parent's own directory, which does not exist.+  `Baikai.Agent.Run` exports `executableForEvidence`. (REV-2 F.13.)++- `baikai-agent`: a failed run's `error_info.message` keeps the last+  `errorInfoStderrTailBytes` (4096) bytes of standard error, prefixed with how+  many earlier bytes were dropped, instead of the whole captured stream — which+  the output limit allows to reach four mebibytes by default. `Baikai.Agent.Run`+  exports the constant. (REV-2 F.13.)++- `baikai-agent`: `--evidence-file` stages through a uniquely named temporary+  file created with `O_EXCL` beside the destination, instead of the destination+  plus `.partial`. A symbolic link planted at the old, guessable name was+  followed, which let an unattended run overwrite a file of the planter's+  choosing. (REV-2 F.13.)++- `baikai-agent` (breaking): an operator configuration file that lies inside the+  repository root is refused with exit 78, naming the file and the root, and no+  ceiling is established. The source list already refused the repository+  *document*; this closes the shape where the repository supplies the *operator*+  document, which both `--user-config .baikai/policy.kdl` and+  `XDG_CONFIG_HOME=$PWD/.baikai` produce. `--user-config`, `XDG_CONFIG_HOME` and+  `HOME` remain the operator's own inputs: the ceiling is exactly as trustworthy+  as the process environment that selects it, and the guide now says so.+  (REV-2 F.4.)++- `baikai-agent` (breaking): an unrecognised key under the operator file's+  `policy` node is an error rather than a warning, naming the file and every+  such key. Everywhere else a forward-compatible file should not stop an older+  binary; under `policy` a misspelling would silently leave the default ceiling+  in force, which for the one node whose purpose is limiting authority is+  indefensible. Two `AgentConfigError` constructors are added,+  `CeilingFileInsideRepository` and `UnknownPolicySetting`.++- `baikai-agent` (breaking): `AgentConfigPaths` gains `repositoryRoot`, the+  directory the process runs in. `--config PATH` chooses which file supplies+  repository-scope settings and does not move the root, because the root is what+  confines a repository-supplied `working-dir`.++- `baikai-agent` (breaking): a repository configuration file may no longer set+  `executable` or a non-empty `extra-dirs`, and its `working-dir` must resolve —+  after following symbolic links — inside the repository root. Each is refused+  with exit 77 naming the setting, or naming both directories. The operator's+  own file and `--set` may still set all three. `executable` turns configuration+  into code execution with the operator's environment and the prompt on standard+  input; `extra-dirs` inside the root adds nothing the working directory does not+  already give, so the only ones a checkout would ask for are outside it.+  (REV-2 F.3.)++### Removed++- `baikai-agent` (breaking): the `BAIKAI_AGENT_EXECUTABLE` environment binding.+  An environment variable is inherited by every child process and is easy to set+  by accident, and naming the program to run is the widest widening there is.+  An operator whose installation is not on `PATH` writes `executable` in their+  own configuration file or passes `--set`.++### Fixed++- `baikai-agent`: a timed-out run now **escalates to `SIGKILL`**. The runner+  interrupts the child's whole process group, then terminates it, then kills it,+  each of the first two stages bounded by the grace period and ended early once+  the leader has been reaped and no member of the group is left. Previously the+  last resort was `terminateProcess` followed by an *unbounded* wait, so a+  coding agent that ignored `SIGTERM` — or a grandchild holding the output pipe+  — hung the run for as long as it chose to live, with the deadline already+  past. Polling the group rather than waiting on the leader alone is also what+  gives a grandchild the same grace the agent gets.++- `baikai-agent`: a timed-out run **reports the output it drained**. `baikai+  agent run` prints it under the same stream discipline a finished run gets, so+  `response=$(baikai agent run job)` under `capture` receives the partial answer+  with `$?` set to 75, and `--json`'s failure envelope carries the same+  `stdout`, `stdoutTruncated`, `stderr` and `stderrTruncated` fields. A drain+  interrupted because something outside the process group still held the pipe+  open keeps its bytes too, reported as truncated.++- `baikai-agent`: the `baikai` command writes its output as **UTF-8 bytes**+  rather than through the locale encoding. Where an unattended run actually+  happens — cron, a systemd unit, a container — the environment says `LANG=C`,+  and on a platform whose locale encoding follows it a single accented character+  in the agent's answer made the write throw after the run had already finished:+  exit 1, answer lost. This mirrors what the prompt read and the prompt write+  have always done.++- `baikai-agent`: the `baikai` executable now links the **threaded runtime**+  (`ghc-options: -threaded` on the `executable baikai` stanza). Without it a+  blocking operating-system call — the `waitpid` inside+  `System.Process.waitForProcess` — stopped every Haskell thread in the+  installed binary, so a job's configured `timeout` could never fire and a+  coding agent that wrote more than one pipe buffer deadlocked against the+  runner's drain threads. Both defects existed only in the shipped executable:+  the test suite was already compiled `-threaded`, so every runner test passed+  under a runtime the binary did not have.++  The suite now proves the runtime the binary ships with rather than its own.+  `baikai-agent/test/BinaryTests.hs` spawns the built executable — cabal builds+  it first and puts it on the suite's `PATH` through+  `build-tool-depends: baikai-agent:baikai` — asserts that `baikai +RTS --info`+  reports `rts_thr`, and runs `baikai agent run` against a stub agent that+  outlives its deadline, requiring exit 75 within seconds and the whole process+  group gone. See+  [docs/adr/0006](docs/adr/0006-a-process-spawning-executable-ships-on-the-threaded-runtime.md).++## [baikai 0.5.0.0] - 2026-08-05++### Added++- `baikai`: new exposed module `Baikai.Agent`, the provider-neutral vocabulary+  for an **unattended coding-agent run** — a run with no terminal and no human,+  which owns its own tool loop, may change files inside directories the caller+  authorized, and returns a process result rather than a `Response`. It defines+  `AgentRunRequest` (with a required `workingDir`), `AgentRunResult`, the+  `AgentCapability` profile (`read-only`, `edit-workspace`, `full-access`),+  `AgentSafety`, the `AgentOutputMode` and `AgentCapturedOutput` output+  discipline, the `AgentCommand` renderer/runner boundary with an explicit+  prompt transport, and the `AgentRenderError` / `AgentRunFailure` taxonomies.++- `baikai`: the operator policy ceiling — `AgentCeiling`,+  `defaultAgentCeiling`, `CeilingViolation`, and the pure `applyAgentCeiling`.+  It returns a request unchanged when it is within the ceiling and reports+  every violation when it is not; it never clamps an over-broad request to the+  permitted value. The default ceiling permits read-only and edit-workspace+  authority and refuses full access and raw provider arguments.++  `Baikai.Agent` itself is vocabulary and pure policy algebra only: it spawns no+  process and renders no command-line flags. Those live in the vendor packages+  and in `baikai-agent`, below. The module is deliberately not re-exported from+  the umbrella `Baikai` module, because its field accessors share names with+  `Baikai.Interactive`, so `import Baikai` continues to compile unchanged.++- `baikai`: new exposed module `Baikai.Evidence`, the vocabulary for+  **verifiable model-call evidence** — a record of what actually crossed the+  boundary to a provider, as opposed to what the process was configured to ask+  for. It defines `ModelCallEvidence` and the `evidenceSchemaVersion` string+  consumers pin against, `Observed` (a deliberate non-`Maybe` for a value the+  provider either did or did not report, with no function that supplies a+  default), `ThinkingTranslation` with its `ThinkingMode` and+  `ThinkingAdjustment` enumerations describing what a requested+  reasoning-effort level actually became on the wire and every clamp, collapse,+  or drop applied on the way, `EndpointIdentity` and `TransportKind`,+  `CallStatus`, and the ascending `EvidenceStrength` scale.++  It also provides the canonical hashing core: `canonicalEncode` gives a JSON+  value exactly one byte representation (object keys sorted, no insignificant+  whitespace, numbers normalised so `1`, `1.0`, `1.00`, and `1e0` all encode as+  `1`, and a hand-written string escaper so an aeson upgrade cannot silently+  invalidate a recorded digest); `commitmentDigest` hashes a full request+  envelope, and `configurationDigest` hashes an allow-list projection+  (`configurationProjection`) that keeps configuration and replaces content with+  structural summaries, so two calls that ask the same model the same way about+  different subjects agree. The two digests are separate on purpose: the first+  binds a record to a particular request, the second is safe to compare across+  runs that legitimately differ in content.++  Nothing constructs a `ModelCallEvidence` from a real call yet, and no existing+  behaviour changed. New dependencies: `cryptohash-sha256` and+  `base16-bytestring`, both single-purpose packages chosen over a full+  cryptographic framework.++- `baikai`: `Options` gains an `evidence` field carrying an optional+  `EvidenceRequest` — the caller's run identifier, retry provenance, and how+  strictly they need evidence. A call whose `evidence` is `Nothing`, which is+  every call that does not opt in, behaves exactly as it did before: no digest+  is computed and no evidence is emitted.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`: **strict+  evidence mode**. `EvidenceStrictness` is `EvidenceBestEffort` or+  `EvidenceRequired !EvidenceStrength`, and a caller who asks for the second+  gets a call that **refuses to start** — before any request is built or any+  connection opened — when the configuration cannot reach the strength asked+  for: `Baikai.Evidence.Build.checkEvidenceRequirements` compares the+  requirement against what the provider can deliver and against the thinking+  translation, and `completeRequest` / `streamRequest` return an error-shaped+  response or a terminal `EventError` instead of dispatching. The gate is+  pre-dispatch by design; that is the only point at which refusing is still+  free.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`:+  **sink-failure semantics under strict mode**. `Baikai.Evidence.Build`+  exports `onSinkFailure`, `sinkFailureIsFatal` and `sinkFailureError`: a trace+  sink that throws fails an `EvidenceRequired` caller's call, because a record+  the sink did not confirm written is not a record, while a best-effort caller's+  call succeeds with the failure reported on stderr.++- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) **Breaking.**+  `baikai`: `Baikai.Provider.Registry.ApiProvider` gained a fourth field,+  `describeThinking :: Model -> Options -> ThinkingTranslation`, which the+  pre-dispatch strictness gate calls to learn what a provider would do with the+  caller's reasoning-effort request without sending anything. Every third-party+  provider constructed with the `ApiProvider` constructor stopped compiling.+  This was not recorded at the time; it is the defect that made 0.6.0.0 hide the+  constructor behind `apiProvider` so that the next field addition is a minor+  release.++- `baikai`: model-call evidence is now **produced and emitted**. A caller who+  sets `Options.evidence` gets exactly one `call_evidence` line per call from+  their trace sink, under every way a call can end: success, provider failure, a+  consumer that abandons the stream (status `aborted`, not `failed` — an abort+  is the consumer's doing and reporting it as a provider failure would+  misattribute it), and dispatch that found no registered handler.++  New exposed module `Baikai.Evidence.Build` bridges the vocabulary to the+  `Model` and `Options` records: `minimalEvidence` and `prepareEvidence` build a+  record, `dispatchEnvelope` supplies the request envelope for the paths where+  no adapter ran, `sanitizeEndpoint` reduces a base URL to scheme/host/port/path+  with the query string and any userinfo dropped wholesale, and `onSinkFailure`+  is the hook a future release replaces to make a strict caller's call fail when+  the trace sink does.++  Every record this release produces has `strength` `requested_only` and every+  provider-observed field set to `"unobserved"`. That is not a placeholder: it+  is a truthful record for a transport that has not yet been taught to observe+  anything. Later releases teach each transport to observe more.++  (Correction added 2026-08-27: the two paragraphs above describe the release+  inaccurately and are kept as shipped rather than rewritten. `onSinkFailure`+  did not await a future release — it shipped in 0.5.0.0 together with+  `sinkFailureIsFatal` and `sinkFailureError`, which already fail a strict+  caller's call when the sink throws. And not every 0.5.0.0 record has `strength`+  `requested_only`: the provider entries below describe what each transport+  reports, and the HTTP adapters reach `correlated` and `model_observed`.)++  **A caller who does not opt in pays nothing.** With `Options.evidence` absent+  no digest is computed, no call identifier is generated, no evidence event is+  emitted, and the request envelope is never even forced — the gate lives inside+  the shared builder rather than at each adapter's call site, and the envelope+  parameter is deliberately lazy. Both facts are guarded by tests.++- `baikai`: `TraceEvent` gains a `CallEvidence` constructor, encoded as+  `{"kind":"call_evidence", …}`. A consumer whose pattern match over `TraceEvent`+  is exhaustive must add a branch; one with a wildcard is unaffected. Filter for+  it with `jq 'select(.kind == "call_evidence") | .evidence'`. Note that a trace+  line carries its fields alongside the `kind` discriminator rather than nested+  under a `data` key, and that the evidence record inside spells its own fields+  in snake_case — the two encodings differ deliberately, because an evidence+  record must render an absent field as explicit `null` while a trace line drops+  it to stay small.++- `baikai`: `Baikai.Provider.Cli.Internal` — the module the two subprocess+  providers share — gains the vocabulary for reading what a coding-agent CLI+  reported about its own run. `CodexRunReport` and the new+  `parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport` fold the+  `codex exec --json` event stream into its assistant text, its thread+  identifier, and its token counts, instead of concatenating agent-message text+  and discarding everything else. `ClaudeCliReport` and+  `decodeClaudeCliResult` do the same for `claude -p --output-format json`.+  Every field but the message text is optional, because both tools' event+  schemas have changed across versions and an absent field is a genuine absence+  rather than a parse failure. **Breaking** for anyone calling+  `parseCodexJsonlStream` directly: its result type is no longer `Text`. This is+  an internal module and is documented as outside the PVP guarantee.++- `baikai`: `Baikai.Provider.Cli.Internal` also gains `ExecutableIdentity` and+  `executableIdentity`, which resolve a configured executable name to an+  absolute path and read the tool's own `--version` line. The probe is cached+  per resolved name for the lifetime of the process, because spawning it per+  model call would roughly double the process cost of the cheapest possible+  call, and it is bounded by a five-second timeout so a tool that hangs on+  `--version` cannot wedge a model call. (Corrected 2026-08-27: the entry said+  two seconds; `versionProbeMicros` has always been five.) A probe that fails records the version+  as absent rather than failing the call. It is only ever called from inside+  the evidence branch: a caller who asked for no evidence must not pay for a+  process whose only purpose is to describe a tool they were about to run+  anyway.++- `baikai`: `subprocessStrength` and `cliResponseEnvelope`, also in+  `Baikai.Provider.Cli.Internal`. The former derives a subprocess call's+  evidence strength from what the tool reported and **nothing else** — the exit+  status is deliberately not one of its arguments. The latter spells the+  response-commitment envelope with the same three keys, in the same shapes, as+  the two API transports build by hand, so a verifier holding a response can+  recompute the digest without first knowing which transport served it.++- `baikai`: `Baikai.Agent` gains `AgentRunOutcome` and `agentRunOutcome`. It+  pairs what an unattended run did — the existing+  `Either AgentRunFailure AgentRunResult` — with the evidence the runner built+  for it. The evidence is a sibling of the outcome rather than a field on+  `AgentRunResult` because the run that most needs a record is one that did not+  produce a result: a run killed by its own timeout reports+  `Left (RunTimedOut …)`, so a record hanging off the `Right` would be+  unreachable exactly there.++### Fixed++- `baikai`: a `call_evidence` event is now emitted **before** its call's+  terminal `call_finished` or `call_failed`, rather than after. The+  OpenTelemetry sink ends and removes a call's span on the terminal, so under+  the old order its evidence-attribute branch was unreachable from any real+  call and every backend saw a span with no evidence on it — nothing failed,+  the attributes were simply never there. No consumer can have depended on the+  old order, because no consumer has ever seen a `call_evidence` line.++- `baikai`: the `ThinkingFormatOpenAI` Haddock in `Baikai.Compat` listed the+  native `reasoning_effort` vocabulary as `minimal | low | medium | high`, which+  predates `xhigh` and `max`. It now lists all six and states that this shape+  alone sends the canonical baikai level verbatim while the other six clamp+  through `compatibleEffort`. No behaviour changed: the native path's exclusion+  from that clamp is deliberate and is guarded by two named tests in+  `baikai-openai/test/ShapeSpec.hs`. A reader who consulted the comment to+  decide whether `xhigh` was safe to use against OpenAI has until now been told+  something untrue.++### Changed++- **Breaking:** `baikai`: `TerminalPayload` gains an `evidence` field and the two+  terminal smart constructors take it as their new first argument:+  `doneTerminal :: Maybe ModelCallEvidence -> Maybe Text -> StopReason -> Message -> TerminalPayload`+  and `errorTerminal` likewise. `Response` gains the same field. A custom+  provider implementation must pass `Nothing` (or a record it builds through+  `Baikai.Evidence.Build`); a custom `Response` built with the record+  constructor must add `evidence = Nothing`. Code that only pattern-matches on+  these types is unaffected.++- **Breaking:** `baikai`: `CallFinished` gains `cachedInputTokens`,+  `cacheWriteTokens`, `reasoningTokens`, and `totalTokens`. The trace path used+  to drop counts that `Baikai.Cost.Log.CallLogEntry` kept from the same `Usage`+  value, which made the cost log strictly more faithful than the trace.++- **Breaking:** `baikai`: a computed cost of **zero is now reported as zero**+  rather than suppressed, in `CallFinished` and at all three `CallLogEntry`+  construction sites. Previously `usd` was omitted whenever the cost came out at+  zero, so "this call was free" and "baikai could not price this call" were+  indistinguishable — and the subscription-based CLI providers always price at+  zero, so that was the common case rather than a corner. **A cost dashboard+  that treated an absent `usd` as "unpriced" will now count those calls as+  costing zero.** That is the correct reading, but it changes what such a+  dashboard shows.++- **Breaking:** `baikai`: `FromJSON TraceEvent` is written out by hand instead of+  derived. The three pre-existing kinds decode exactly as before; a+  `call_evidence` line fails to parse with a message saying to read it as a+  plain `Data.Aeson.Value`. `ModelCallEvidence` has no `FromJSON` on purpose —+  it embeds a `Cost` whose exact `Rational` amounts encode through an+  approximating `Scientific`, so a decoder would return a different value than+  was encoded — and manufacturing that fidelity would be the precise failure+  this vocabulary exists to eliminate.++- `baikai`: `Baikai.Trace.Sink.renderHuman` renders a `CallEvidence` event as a+  single `EVIDENCE run=… call=… strength=…` line rather than the whole record. A+  human-readable sink is for watching calls go by; the full record is meant to+  be read out of `fileSink` output by a machine.++- `baikai`: call identifiers on the trace path are now globally unique.+  `Baikai.Evidence.newCallId` produces 32 lowercase hexadecimal characters+  carrying 128 bits — 48 bits of Unix time in milliseconds, 48 bits of a+  per-process random seed drawn once from `/dev/urandom`, and a 32-bit counter.+  The previous generator combined the process-start *second* with a+  process-local counter into 16 characters, so two processes started within the+  same second emitted identical identifier sequences; its own documentation+  claimed only per-process uniqueness. Identifiers still sort chronologically+  and are still not secrets.++  `Baikai.Trace.newEventId` keeps its name and signature, delegates to+  `newCallId`, and is now deprecated. Anything that pinned the 16-character+  width — a log parser, a fixture, a column type — must widen to 32.++- `baikai`: `renderCeilingViolation` no longer prints the raw provider arguments+  a `ProviderArgsForbidden` violation carries. It reports how many were+  requested and states that their values are not shown. Raw provider arguments+  are the one part of a job description that can hold a credential — the+  configuration layer classifies the setting secret for that reason — and a+  refusal message that quoted them defeated the classification. The constructor+  keeps its `[Text]` payload so a programmatic caller can still inspect it.++## [baikai-claude 0.5.0.0] - 2026-08-05++### Added++- `baikai-claude`: new exposed module `Baikai.Provider.Claude.Agent` with+  `ClaudeAgentConfig`, `defaultClaudeAgentConfig`, and `claudeAgentCommand`, a+  pure renderer from an unattended `AgentRunRequest` to the `claude` argument+  vector. It maps the capability profile onto `--permission-mode`+  (`plan` / `acceptEdits` / `bypassPermissions`), joins a tool allow-list into+  one `--allowedTools` argument, repeats `--add-dir` per extra directory, always+  emits `-p`, and emits `--no-session-persistence` unless `persistSession` is+  set. The prompt travels on standard input and appears nowhere in the argument+  vector. A request naming a different provider is refused with+  `ProviderMismatch`. Nothing is spawned.++- `baikai-claude`: the Anthropic Messages provider now fills in the evidence+  record it previously left blank. It records the model **Anthropic reported+  running** (read from the `message_start` event, which the adapter already+  decoded for the response id and then discarded), Anthropic's `request-id`+  correlation header, the response id, the token counts Anthropic actually+  reported, and a commitment digest over the assembled response. A field the+  provider did not report stays `"unobserved"` and is never backfilled from the+  request — in particular, a stream that fails before `message_start` reports no+  observed model at all. `strength` is `model_observed` when both the model and a+  correlation identifier arrived, `correlated` when only the identifier did, and+  `requested_only` otherwise; a 2xx status never raises it, because a 200 means+  the request was accepted, not that any particular model ran.+  `fully_observed` is unreachable on this transport, since Anthropic does not+  echo the thinking configuration it applied.++- `baikai-claude`: an evidence record's `thinking` field now describes what the+  caller's reasoning-effort preference actually became on the wire, including+  three downgrades that were previously invisible everywhere in baikai's output:+  asking for thinking on a model that does not advertise `reasoning`+  (`thinking_dropped_unsupported_model`); asking for a level whose token budget+  does not fit under the resolved output-token ceiling+  (`thinking_dropped_budget_exceeded`, carrying both colliding numbers), which is+  reachable by lowering `maxTokens` alone; and asking for `high` on an+  adaptive-thinking model, which sends no effort field and so is+  wire-indistinguishable from taking Anthropic's default depth+  (`effort_omitted`). `minimal` on an adaptive model reports `effort_clamped`,+  because Anthropic's adaptive vocabulary has no `minimal`.++- `baikai-claude`: new exports from `Baikai.Provider.Claude.Sse` —+  `ResponseMetadata` and `capturedHeaderNames` — and from+  `Baikai.Provider.Claude.Api` — `claudeMessagesStreamWith`, `SseDriver`, and+  `anthropicStrength`. Response-header capture is an **allow-list**+  (`request-id`, `x-request-id`, `cf-ray`, in that preference order), not a+  denylist, so a header a future gateway adds is not recorded by default.++- `baikai-claude` and `baikai-openai`: both subprocess providers now fill in the+  evidence record they previously left blank, and both export the translation+  function that describes it — `claudeCliThinking` and `codexCliThinking`. They+  record the session or thread identifier the tool reported, the token counts it+  reported, the model it named when it names one, the resolved executable path+  in place of an endpoint URL, the tool's own `--version` string as the+  implementation version (for this transport the tool *is* the implementation),+  a request commitment over the rendered argument vector, and a response+  commitment over the assembled answer.++  **A zero exit status never raises the strength.** A coding-agent CLI that+  exits zero has demonstrated that it ran and did not crash; it has not stated+  which model served the request. Subprocess calls almost always exit zero, so+  encoding that as corroboration would make the weakest evidence in the system+  look like the strongest. `strength` is `model_observed` only when the tool+  named both an identifier and a model, `correlated` when it named only an+  identifier, and `requested_only` otherwise.++  The two transports differ in how far they can get. `claude` names the model+  that consumed tokens in its result event's `modelUsage` map, complete with a+  context-window variant marker such as `[1m]`, so a Claude CLI run can reach+  `model_observed`. `codex-cli 0.146.0` names no model anywhere in its event+  stream, so **no** Codex CLI run can exceed `correlated` — backfilling the+  `--model` flag baikai passed would report the request as an observation.++- `baikai-claude`: an evidence record's `thinking` field now describes what a+  reasoning-effort request became on the `claude` command line: mode `flag`,+  wire field `--effort`, and an `effort_clamped` adjustment recording the+  `minimal` → `low` collapse, because the tool's `--effort` flag has no+  `minimal`. A caller asking for `minimal` and a caller asking for `low` produce+  byte-identical argument vectors — and therefore identical request commitment+  digests — so the translation is the only place that difference survives.++- **Breaking:** `baikai-claude` and `baikai-openai`: `claudeAgentCommand` and+  `codexAgentCommand` return `(AgentCommand, ThinkingTranslation)` rather than+  `AgentCommand`. The runner deliberately imports no vendor renderer, so it+  cannot derive the translation and has to be handed it. A caller that only+  wants the command writes `fmap fst`. Both modules also export the translation+  function alone — `claudeAgentThinking` and `codexAgentThinking` — for asking+  what a level would become without rendering anything.++### Fixed++- **Loud:** `baikai-claude` and `baikai-openai`: both subprocess providers+  hardcoded `usage = zeroUsage` on every call, so a cost dashboard saw every+  `claude -p` and `codex exec` call as consuming no tokens and costing nothing.+  Both tools report their own token counts and baikai now carries them through,+  normalized into the disjoint `Usage` convention: `claude`'s counts are+  Anthropic-shaped and already disjoint, while `codex` reports OpenAI-style+  inclusive prompt counts, so its cached tokens are subtracted out of+  `inputTokens`. `claude` additionally reports a `total_cost_usd`, which now+  populates `Usage.cost` exactly rather than being reported as zero.++  **A dashboard that read these calls as free will now see real tokens and, for+  `claude`, a real cost.** That is the correction, not a regression — but it+  changes what existing reports show, and totals over historical data will not+  match totals over new data.++- `baikai-claude`: `Response.responseId` was always `Nothing` on the `claude -p`+  transport even though `ClaudeCliResult` decoded the tool's `session_id` one+  screen earlier and then dropped it. It now carries that identifier, on both+  the successful and the failed terminal. `baikai-openai`: the same for+  `codex exec`, whose thread identifier was filtered out of the event stream+  along with everything that was not an `agent_message`. These are the handles+  each vendor's support tooling looks a run up by.++### Changed++- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Sse`'s four streaming+  entry points — `claudeSseStream`, `claudeSseStreamValue`,+  `claudeSseStreamValueWithHeaders`, and `sseFromResponse` — take a new+  `ResponseMetadata -> IO ()` callback immediately before the existing per-event+  callback. It fires exactly once, before the first event, on both the success+  and the non-2xx path. Pass `(\_ -> pure ())` to keep the previous behaviour.+  The callback is separate rather than a widening of the per-event one because+  the per-event callback runs once per SSE frame and response-level data does not+  belong on that path.++- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Internal.Request`'s+  `mapRequest` now returns+  `Either Text (Messages.CreateMessage, ThinkingTranslation)` and+  `computeThinking` returns `(ThinkingPlan, ThinkingTranslation)`. Take `fst` to+  keep the previous value. This module is exposed for provider tests and+  debugging and its header states it is not covered by PVP compatibility+  guarantees, but the change is recorded here because that is not a licence to+  break a consumer silently.++- **Breaking:** `baikai-claude`: `claudeInteractiveCommand` now returns+  `Either AgentRenderError (FilePath, [String])` and `launchClaudeInteractive`+  returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request+  whose `safety` is a `CodexSandbox` policy — which Claude Code cannot express+  — is refused with `SafetyNotExpressible AgentClaude`, naming the rejected+  sandbox mode and approval policy and suggesting `ClaudeAllowedTools` or+  `DefaultSafety`. Previously the policy was silently discarded and an+  **unrestricted** Claude session was started and reported as a success. A+  `Left` means no process was started; a `Right` with a non-zero exit code+  means the session ran and exited non-zero. `DefaultSafety` and an empty+  `ClaudeAllowedTools` list still render no safety flag and are never refused,+  and no previously rendered argument vector changed. Callers must handle the+  refusal branch.++## [baikai-openai 0.5.0.0] - 2026-08-05++### Added++- `baikai-openai`: new exposed module `Baikai.Provider.OpenAI.Agent` with+  `CodexAgentConfig`, `defaultCodexAgentConfig`, and `codexAgentCommand`, the+  same renderer for `codex exec`. It maps the capability profile onto+  `--sandbox` (`read-only` / `workspace-write` / `danger-full-access`), emits+  `--cd` for the working root, and defaults `--skip-git-repo-check` and+  `--ephemeral` on. A request carrying a tool allow-list is **refused** with+  `UnsupportedToolRestriction`, because `codex exec` has no such flag and running+  it with unrestricted tools would grant more authority than the caller asked+  for. Nothing is spawned.++- `baikai-openai`: an evidence record's `thinking` field now describes what the+  caller's reasoning-effort preference became on the wire for the specific host+  the call went to, across **all seven** OpenAI-compatible wire shapes. The+  OpenAI-native shape sends the canonical level verbatim and records no+  adjustment, because it expresses every level exactly. The four shapes that+  carry an effort word for a non-native host record `effort_clamped` whenever+  the word differs from the canonical name — `minimal` becomes `low`, and both+  `xhigh` and `max` become `high`. Z.ai and Qwen accept a bare+  `enable_thinking: true` with no depth, so **every** level records+  `effort_collapsed_to_toggle`: a caller asking for `max` and a caller asking+  for `low` produce byte-identical requests there, and only the evidence record+  can tell them apart. A host with no reasoning controls records+  `thinking_dropped_unsupported_host` where the option previously vanished with+  no trace. A forty-two-row table test pins the translation and the shaped+  request body for every shape at every level.++- `baikai-openai`: the Chat Completions provider now fills in the evidence record+  it previously left blank. It records the model **the host reported running**+  (read from the first streamed chunk carrying a top-level `model` field and+  never overwritten by a later one), the host's `x-request-id` correlation+  header, the response id, the token counts the host actually reported, and a+  commitment digest over the assembled response. A field the host did not report+  stays `"unobserved"` and is never backfilled from the request — in particular,+  a call that fails before any chunk arrives reports no observed model at all.+  `strength` is `model_observed` when both the model and a correlation+  identifier arrived, `correlated` when only the identifier did, and+  `requested_only` otherwise; a 2xx status never raises it, because a 200 means+  the request was accepted, not that any particular model ran.+  `fully_observed` is unreachable on this transport, since no host in this+  ecosystem echoes the reasoning configuration it applied.++- `baikai-openai`: new exports from `Baikai.Provider.OpenAI.Sse` —+  `ResponseMetadata` and `capturedHeaderNames` — and from+  `Baikai.Provider.OpenAI.Api` — `openaiChatStreamWith` and `SseDriver`.+  Response-header capture is an **allow-list** (`x-request-id`, `request-id`,+  `x-amzn-requestid`, `x-ms-request-id`, `cf-ray`, in that preference order),+  not a denylist, so a header a future gateway adds is not recorded by default.+  The list is longer than the Anthropic one because this transport speaks to an+  open-ended set of hosts and the gateways commonly in front of them.++- `baikai-openai`: the same field for `codex exec`: mode `flag`, wire field+  `model_reasoning_effort`, and **no** adjustments at any level. Codex is the+  only transport in baikai that expresses all six canonical levels exactly, and+  a test asserts each one reaches the command line verbatim.++### Fixed++- `baikai-openai`: `Response.responseId` was always `Nothing` on the Chat+  Completions transport, although every compatible host sends a top-level `id`+  on every streamed chunk. It now carries the identifier the host reported, on+  both the successful and the failed terminal.++### Changed++- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Sse`'s four streaming+  entry points — `openaiSseStream`, `openaiSseStreamValue`,+  `openaiSseStreamValueWithHeaders`, and `sseFromResponse` — take a new+  `ResponseMetadata -> IO ()` callback immediately before the existing per-chunk+  callback. It fires exactly once, before the first chunk, on both the success+  and the non-2xx path — a failed call's correlation identifier is if anything+  more valuable than a successful one's. Pass `(\_ -> pure ())` to keep the+  previous behaviour. The callback is separate rather than a widening of the+  per-chunk one because that one runs once per SSE frame and response-level data+  does not belong on that path.++- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Api`'s `RawChunk` gains+  `model` and `responseId` fields, both `Maybe Text`. Code that pattern-matches+  on `RawChunk` is unaffected; code that constructs one with record syntax must+  add them.++- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Shape`'s+  `shapeRequestBody`, `streamRequestBody`, and `injectThinkingShape` now return+  `(Aeson.Value, ThinkingTranslation)` instead of a bare body. Take `fst` to+  keep the previous value. The description has to travel out of the shaping step+  because nothing downstream can recompute it: it depends on the host's+  `ThinkingFormat`, which only the compat lookup knows. **No request body+  changed** — every one of the seven shapes puts exactly the same bytes on the+  wire as before.++- **Breaking:** `baikai-openai`: `codexInteractiveCommand` now returns+  `Either AgentRenderError (FilePath, [String])` and `launchCodexInteractive`+  returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request+  whose `safety` is a non-empty `ClaudeAllowedTools` list — which `codex` has+  no flag for — is refused with `SafetyNotExpressible AgentCodex`, quoting the+  rejected tools and suggesting `CodexSandbox` or `DefaultSafety`. Previously+  the allow-list was silently discarded and Codex was started with its default+  sandbox. The same `Left`/`Right` reading applies, `DefaultSafety` and an+  empty allow-list are never refused, and no previously rendered argument+  vector changed. Callers must handle the refusal branch.++  Both changes make the interactive surface honor the same contract as the new+  unattended surface: a safety policy the chosen provider cannot express fails+  visibly instead of silently becoming a weaker policy. Downstream consumers+  must adapt before upgrading; the known one is `shinzui/seihou`, whose+  `Seihou.CLI.AgentLaunchExec` module builds interactive launch requests.++## [baikai-trace-otel 0.3.0.3] - 2026-08-05++### Added++- `baikai-trace-otel`: the sink attaches an evidence record's salient fields to+  the open span as flat attributes (`baikai.evidence.run_id`,+  `baikai.evidence.call_id`, `baikai.evidence.strength`, the two digests, and+  `gen_ai.response.model` only when the provider actually reported one) rather+  than serialising the record into one blob. A `CallEvidence` event neither+  opens nor closes a span.++### Changed++- `baikai-trace-otel`: widened its `baikai` bound to admit `0.5`. No API change.++## [baikai-effectful 0.3.0.3] - 2026-08-05++### Changed++- Widened its `baikai` bound to admit `0.5`. No API change; the package's+  own surface is untouched.++## [baikai-kit 0.1.0.4] - 2026-08-05++### Changed++- Widened its `baikai` bound to admit `0.5`. No API change; the package's+  own surface is untouched.++## [baikai-agent 0.1.0.0] - 2026-08-05++### Added++- `baikai-agent`: **new package** (`0.1.0.0`) holding the unattended+  coding-agent runner. `Baikai.Agent.Run.runAgentCommand` takes an+  `AgentRunRequest` and an already-rendered `AgentCommand` and spawns the tool+  with no terminal and no human present. It delivers the prompt on standard+  input and closes the handle, drains standard output and standard error+  concurrently so a chatty agent cannot deadlock on a full pipe, retains at most+  `outputLimit` bytes per stream while reading and discarding the excess, and+  honors the three output disciplines. Preconditions run before any spawn: a+  missing working directory is `WorkingDirMissing` and unset or empty declared+  variables are `MissingEnvironment`, listing all of them at once. On timeout+  the child's whole process group is interrupted, given a grace period, and then+  terminated, so the agent's own child processes go with it; the failure reports+  the configured limit. A non-zero exit code is a successful run carrying that+  code, not a failure. The runner consumes an already-rendered `AgentCommand`+  and never imports a vendor renderer, so it is exercised entirely with+  hand-written argument vectors. Its POSIX-signal escalation is conditional on a+  non-Windows build.++- `baikai-agent`: new exposed module `Baikai.Agent.Config`, the layered+  configuration layer. `resolveAgentJob` resolves one named job across five+  layers — built-in defaults, the operator file, the repository file, the+  environment, then command-line overrides, later layers winning — and returns+  the resolved `AgentJob` together with a report attributing every value to the+  file, line, and column it came from. `agentJobRequest` converts a job into an+  `AgentRunRequest`, taking the prompt at call time. `listAgentJobs` enumerates+  configured job names, sorted, each attributed to the highest-precedence scope+  defining it. `defaultAgentConfigPaths` locates+  `$XDG_CONFIG_HOME/baikai/agents.kdl` (or `$HOME/.config/baikai/agents.kdl`)+  and `./.baikai/agents.kdl`, with no upward search through parent directories.++  The **policy ceiling** is loaded by a separate function, `loadAgentCeiling`,+  against a separate source list containing the operator file and nothing else:+  no repository file, environment variable, or command-line override can raise+  it. `applyCeilingToJob` refuses an over-broad request with `CeilingRejected`+  rather than clamping it. With no operator file the ceiling is+  `defaultAgentCeiling`. `safety.provider-args` is classified secret and renders+  as `<redacted>` in any report or structured error.++  New dependencies: `settei`, `settei-env`, `settei-kdl`, and+  `settei-optparse-applicative` (all `^>=0.2`, published on Hackage at+  `0.2.0.0`), plus `containers` and `filepath`. `settei-formats` is deliberately+  excluded, because it bundles Dhall loading and repository configuration is+  untrusted input here.++- `baikai-agent`: the **`baikai` executable**, with the `agent run`,+  `agent show`, and `agent list` commands, and the `Baikai.Agent.Cli` module+  that implements them. A shell script now invokes one stable command, supplies+  a prompt on standard input, and selects Claude Code or Codex entirely through+  configuration.++  `agent run` resolves the named job, caps it against the operator ceiling,+  renders it through the vendor renderer for its provider, and spawns it. The+  agent's own exit code passes through unchanged; Baikai's own failures use 64+  and above following the `sysexits` convention — 64 for a usage error or an+  empty prompt, 69 when the executable could not be started, 70 for malformed+  output, 75 for a timeout, 77 for a policy refusal, and 78 for a configuration+  problem. The prompt comes from `--prompt-stdin`, `--prompt-file`, or+  `--prompt`, which are mutually exclusive, and is decoded as UTF-8 explicitly+  rather than through the handle's locale encoding.++  `agent show` performs the whole pipeline except spawning and prints each+  resolved value with the file, line, and column it came from, the policy+  ceiling in force and where it was read, and the exact argument vector that+  would be spawned — with `<redacted>` in place of any raw provider argument. A+  job whose policy is refused prints its configuration first and then the+  refusal. `agent list` enumerates configured jobs and the scope each came from.++  Every Baikai diagnostic goes to standard error. The agent's own output follows+  the job's output mode, so `response=$(baikai agent run job)` yields the+  agent's answer alone for a capturing job. `--set KEY=VALUE` overrides one+  setting of the selected job through `settei`'s own command-line source, so an+  override is attributed with the same fidelity as a file. `--json` emits+  exactly one JSON object per command.++  New dependencies for `baikai-agent`: `baikai-claude`, `baikai-openai`, and+  `optparse-applicative`. The provider packages are needed only so that+  `renderJobCommand`, the single provider dispatch point in the codebase, can+  reach both renderers. This is the first dependency in the workspace from+  `baikai-agent` onto the provider packages, so `baikai-agent` now publishes+  after all three of `baikai`, `baikai-claude`, and `baikai-openai`.++  The user guide `docs/user/unattended-agent-runs.md` documents the whole+  surface: the three commands with their flags, exit codes, and stream+  discipline; the KDL job format and layer precedence; the operator ceiling and+  redaction; the capability mapping tables for both tools; and a before-and-after+  migration of a script that embeds provider flags today.+  `docs/user/cli-providers.md` and `docs/user/interactive-launches.md` link to+  it, and the capability mapping tables moved there from the latter.++- `baikai-agent`: **an unattended coding-agent run now produces model-call+  evidence.** This surface previously had no observability of any kind: no trace+  sink, no `Response`, no usage, no identifiers. An operator could show that a+  process started, exited, and took some time; they could not show which model+  ran, which reasoning effort was applied, or which agent session the run+  corresponds to in the vendor's records.++  A record carries the run and call identifiers, the resolved executable and its+  own reported version, digests over the request, the requested model and what+  the reasoning-effort request became on the command line, whatever the tool+  reported about itself, the outcome, and an honest strength.++  **A zero exit status never raises the strength.** On this surface that rule+  matters more than anywhere else, because almost every unattended run exits+  zero. A coding agent that exits zero has demonstrated that it ran, not which+  model served it.++  Two things gate what a record can prove, and neither is the default. The job+  must **capture** output — under `inherit` the agent's bytes went to the+  operator's terminal and baikai never held them — and the tool must be+  configured to print a structured format, which means `--output-format json`+  for `claude` or `--json` for `codex exec` through the job's `provider-args`.+  Without both, the tool's session identifier, model, and token counts are+  genuinely unavailable and the record says `"unobserved"` rather than inferring+  anything. A timed-out run records `aborted`; a run that never started records+  nothing at all.++- **Breaking:** `baikai-agent`: `Baikai.Agent.Run.runAgentCommand` takes two new+  leading arguments and returns the new outcome type:+  `Maybe EvidenceRequest -> ThinkingTranslation -> AgentRunRequest -> AgentCommand -> IO AgentRunOutcome`.+  A caller who wants the previous behaviour passes `Nothing` and+  `Baikai.Evidence.noThinkingRequested` and reads the `outcome` field; that path+  is byte-for-byte what it was, and costs what it cost — no digest is computed,+  no call identifier is generated, and the tool is not invoked a second time to+  read its version.++- `baikai-agent`: `baikai agent run` gains `--evidence-file PATH` and+  `--run-id TEXT`. Supplying neither leaves the run on the pre-existing path at+  the pre-existing cost; supplying either turns recording on, with the job's own+  name standing in as the run identifier when only a destination is given. The+  file is written atomically — a staging file beside the destination, then a+  rename — so a reader polling the path never sees a half-written object, and it+  is never appended to. A failed write is reported on standard error and never+  changes the exit code, because the agent's own status is what a calling script+  branches on. `docs/user/unattended-agent-runs.md` documents both options and,+  more importantly, what the record does and does not prove.++- `baikai-agent`: `baikai agent run` gains `--require-evidence STRENGTH`, taking+  `requested_only`, `correlated`, `model_observed`, or `fully_observed` — the+  same words a record's `strength` field spells, so what one record showed can+  be passed back as the next run's requirement. A job whose configuration cannot+  produce evidence of at least that strength is refused before anything is+  spawned, exiting 77 — the code a ceiling violation and an inexpressible safety+  policy already use, so a script branching on 77 needs no new case.++## [baikai-claude 0.4.0.1] - 2026-07-30++### Fixed++- Widened the `crypton` bound from `^>=1.0` to `>=1.0 && <1.2` so consumers can+  build `baikai-claude` alongside packages that require `crypton` 1.1.x (for+  example `pg-migrate-1.1.0.0`), which previously had no solvable build plan.+  The only `crypton` use is `Crypto.Hash` (`Digest`, `SHA256`) in+  `Baikai.Provider.Claude.Transport`, whose API is identical across the 1.0/1.1+  boundary. No API change.++## [baikai 0.4.1.0] - 2026-07-20++### Changed++- Version bump only; no library API or code changes. Released so the umbrella+  release tag `baikai-0.4.1.0` names a fresh core version alongside the breaking+  `baikai-claude` / `baikai-openai` 0.4.0.0 releases, matching the tag+  convention downstream consumers pin against.++## [baikai-claude 0.4.0.0] - 2026-07-20++### Changed++- **Breaking:** `claudeCliCommand` now takes the `Options` record and forwards+  `Options.thinking` to batch `claude -p` as `--effort <level>` (`minimal`+  collapses to `low`, matching the interactive launcher and the claude CLI's+  lack of a `minimal` value). `thinking = Nothing` emits no effort flag, keeping+  existing argv byte-for-byte. The added parameter is a PVP-major signature+  change.++## [baikai-openai 0.4.0.0] - 2026-07-20++### Changed++- **Breaking:** `codexCliCommand` now takes the `Options` record and forwards+  `Options.thinking` to `codex exec` as `-c model_reasoning_effort=<level>` for+  all six effort levels. `thinking = Nothing` emits no override, keeping+  existing argv byte-for-byte. The added parameter is a PVP-major signature+  change.++## [baikai 0.4.0.0] - 2026-07-20++### Added++- Added `ThinkingXHigh` and `ThinkingMax` to the exported `ThinkingLevel`+  vocabulary and added a defaulted `InteractiveLaunchRequest.effort` field.+  Extending the closed sum type is a PVP-major API change for downstream+  exhaustive matches.++## [baikai-claude 0.3.0.2] - 2026-07-20++### Added++- Added `--effort` rendering to interactive Claude Code launches and preserved+  `xhigh` / `max` on native adaptive Anthropic API requests, with larger fixed+  budgets for manual-thinking models.++### Changed++- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the+  baikai 0.4.0.0 release.++## [baikai-openai 0.3.0.2] - 2026-07-20++### Added++- Added `model_reasoning_effort` overrides to interactive Codex launches and+  preserved `xhigh` / `max` in native OpenAI request JSON; non-native+  OpenAI-compatible request shapes continue to clamp them to `high`.++### Changed++- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the+  baikai 0.4.0.0 release.++## [baikai-trace-otel 0.3.0.2] - 2026-07-20++### Changed++- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the+  baikai 0.4.0.0 release. No API changes.++## [baikai-effectful 0.3.0.2] - 2026-07-20++### Changed++- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the+  baikai 0.4.0.0 release. No API changes.++## [baikai-kit 0.1.0.3] - 2026-07-20++### Changed++- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the+  baikai 0.4.0.0 release. No API changes.++## [baikai 0.3.1.0] - 2026-07-15++### Added++- Added `claude-sonnet-5` to the Anthropic model catalog (1M context window,+  128k max output, `tool_call` + reasoning).+- Added the `gpt-5.6` family — `gpt-5.6`, `gpt-5.6-luna`, `gpt-5.6-sol`, and+  `gpt-5.6-terra` — to the OpenAI model catalog (chat-completions with+  `tool_call` support).++### Changed++- Corrected `claude-sonnet-4-5` context window to 1M tokens and+  `claude-sonnet-4-6` max output to 128k tokens in the catalog.+- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai-claude 0.3.0.1] - 2026-07-15++### Changed++- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai-openai 0.3.0.1] - 2026-07-15++### Changed++- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai-trace-otel 0.3.0.1] - 2026-07-15++### Changed++- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai-effectful 0.3.0.1] - 2026-07-15++### Changed++- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai-kit 0.1.0.2] - 2026-07-15++### Changed++- Added PVP-compliant upper bounds to all previously-unbounded library and+  executable dependencies.++## [baikai 0.3.0.0] - 2026-07-03++### Added++- Added the documented record-update bases `emptyOptions`, `emptyContext`,+  `emptyModel`, `emptyResponse`, `emptyTool`, `emptyTextContent`,+  `emptyThinkingContent`, `emptyToolCall`, `emptyImageContent`,+  `emptyEmbeddingModel`, plus zero-valued bases `zeroUsage`, `zeroCost`,+  `zeroCostBreakdown`, and `zeroModelCost`.+- Added `firstEmbedding`, a total accessor for OpenAI-compatible embedding+  responses.+- Added `responseError`, `errorResponse`, `httpError`, and+  `parseRetryAfterSeconds` for the in-band error contract.++### Changed++- **Breaking:** Constructors for evolvable records are no longer exported:+  `Options`, `Context`, `Model`, `OpenAICompletionsCompat`,+  `AnthropicMessagesCompat`, and `InteractiveLaunchRequest` are built from+  exported base values plus record updates.+- **Breaking:** The `_X` base values are deprecated in favor of the new+  `empty*` and `zero*` names; the aliases remain for this release.+- **Breaking:** Removed `unModel`; use `mkModel` or `emptyModel` record+  updates.+- **Breaking:** Renamed `InteractiveLaunchRequest.model` to `modelId`.+- **Breaking:** `Response.latencyMs` and trace event `latencyMs` fields are+  now `Int`.+- **Breaking:** `completeRequest` / `completeRequestWith` no longer throw+  `BaikaiError` for unregistered API tags; they return an error-shaped+  `Response`.+- **Breaking:** CLI providers now report subprocess/decode/provider failures+  in-band as error-shaped `Response`s.+- **Breaking:** `errorTerminal` now requires a `BaikaiError`, enforcing+  structured error details for `EventError` construction sites.+- Documented that `Baikai.Prelude` is a convenience module outside the PVP+  stability contract and that `.Internal` modules have no compatibility+  guarantees.++### Fixed++- Empty embedding `data` arrays now produce a typed `decodeError` instead of+  crashing on an empty vector.+- The model-fetch JSON renderer now delegates string escaping to aeson.+- The model generator now fails on sanitized Haskell identifier collisions+  instead of rendering duplicate bindings.+- Live HTTP status, `Retry-After`, and network-failure classification now+  works on both API providers.+- `content_filter` / Anthropic refusals terminate as classified `EventError`+  terminals, and `liftCompleteToStream` preserves error-shaped responses.++## [baikai-claude 0.3.0.0] - 2026-07-03++### Changed++- **Breaking:** `Baikai.Provider.Claude.ErrorClass` moved to+  `Baikai.Provider.Claude.Internal.ErrorClass`.+- **Breaking:** `mapRequest` and pure request-shaping helpers moved from+  `Baikai.Provider.Claude.Api` to+  `Baikai.Provider.Claude.Internal.Request`.+- **Breaking:** `ClaudeCliConfig` and `ClaudeInteractiveConfig` constructors+  are no longer exported; start from their default config values and update+  fields.+- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`.++## [baikai-openai 0.3.0.0] - 2026-07-03++### Changed++- **Breaking:** `Baikai.Provider.OpenAI.ErrorClass` moved to+  `Baikai.Provider.OpenAI.Internal.ErrorClass`.+- **Breaking:** `mapRequest` and pure request-shaping helpers moved from+  `Baikai.Provider.OpenAI.Api` to+  `Baikai.Provider.OpenAI.Internal.Request`.+- **Breaking:** `CodexCliConfig` and `CodexInteractiveConfig` constructors are+  no longer exported; start from their default config values and update fields.+- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`.++## [baikai-trace-otel 0.3.0.0] - 2026-07-03++### Changed++- Updated the `baikai` dependency bound to `^>=0.3.0`.+- Adjusted to the core trace event `latencyMs :: Int` type.++## [baikai-effectful 0.3.0.0] - 2026-07-03++### Changed++- Updated the `baikai` dependency bound to `^>=0.3.0`.++## [baikai-kit 0.1.0.1] - 2026-07-03++### Changed++- Updated the `baikai` dependency bound to `^>=0.3.0`.++## [baikai 0.2.0.0] - 2026-06-21++### Added++- `Usage`, `Cost`, and `CostBreakdown` now have `Semigroup`/`Monoid`+  instances that add field-by-field, plus `sumUsage :: Foldable f => f+  Usage -> Usage`, so callers can total per-call usage and cost.+  `reasoningTokens` combines as presence-wins (`Nothing` only when both+  operands are `Nothing`).+- A categorised error model: `BaikaiError` is now a record carrying an+  `ErrorCategory` (`AuthError`, `RateLimited`, `ContextOverflow`,+  `InvalidRequest`, `TransientError`, `DecodeFailure`, `ProcessFailure`,+  `ProviderUnavailable`, `OtherError`), an optional HTTP `httpStatus`, a+  `retryAfterSeconds` hint, and a subprocess `exitCode`. New smart+  constructors (`providerError`, `invalidRequest`, `decodeError`,+  `processError`, `rateLimited`, `authError`, `providerUnavailable`),+  the `isRetryable` predicate, and the pure `classifyHttpStatus` /+  `classifyHttpStatusWithBody` helpers let callers implement retry+  policy without parsing error text. `ErrorCategory` and `BaikaiError`+  serialize to JSON.+- `Response` and the streaming `EventError`'s `TerminalPayload` now+  carry `errorInfo :: Maybe BaikaiError`, so a failed `completeRequest`+  (or a drained stream) exposes the structured category/retry hint+  in-band. `Baikai.Stream.Event` gains `doneTerminal` / `errorTerminal`+  constructors.++### Changed++- **Breaking:** `BaikaiError`'s four flat constructors+  (`ProviderError`, `RequestInvalid`, `DecodeError`, `ProcessError`)+  were replaced by the record above. Migrate by lowercasing to the+  smart constructors — `ProviderError "x"` becomes `providerError "x"`,+  `ProcessError n "x"` becomes `processError n "x"`, etc.+- **Breaking:** `Baikai.Stream.Event.TerminalPayload` and+  `Baikai.Response.Response` gained an `errorInfo` field; build+  `TerminalPayload` via `doneTerminal` / `errorTerminal`.++### Fixed++- Restored JSON decoding for `BaikaiError` values with omitted optional+  metadata fields.++## [baikai-claude 0.2.0.0] - 2026-06-21++### Added++- The Anthropic API and `claude -p` CLI providers now classify failures+  into the typed `BaikaiError` categories: HTTP errors (via the caught+  `servant-client` `ClientError`) map status/`Retry-After`/body onto+  `AuthError` / `RateLimited` / `ContextOverflow` / `InvalidRequest` /+  `TransientError`, and mid-stream Anthropic `error` events are+  classified by their error type. The result is surfaced on+  `Response.errorInfo`.++## [baikai-openai 0.2.0.0] - 2026-06-21++### Added++- The OpenAI/OpenAI-compatible API and `codex exec` CLI providers now+  classify failures into the typed `BaikaiError` categories the same way+  as `baikai-claude` (HTTP `ClientError` for status-based errors,+  streamed error text for mid-stream errors), surfaced on+  `Response.errorInfo`.++## [baikai-trace-otel 0.2.0.0] - 2026-06-21++### Changed++- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with+  the `baikai 0.2.0.0` breaking API release.++## [baikai-effectful 0.2.0.0] - 2026-06-21++### Changed++- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with+  the `baikai 0.2.0.0` breaking API release.++## [baikai 0.1.1.0] - 2026-06-12++### Added++- Added provider-agnostic `ResponseFormat` support on `Options`, including+  plain JSON-object mode and named JSON-schema mode.+- Added `Baikai.Embedding`, an OpenAI `/v1/embeddings` client for text+  embeddings.++## [baikai-claude 0.1.1.0] - 2026-06-12++### Added++- Mapped baikai `ResponseFormat` options onto Anthropic `output_config` for+  Claude API requests.+- Exported `mapRequest` for request-mapping tests and downstream inspection.++## [baikai-openai 0.1.1.0] - 2026-06-12++### Added++- Mapped baikai `ResponseFormat` options onto OpenAI Chat Completions+  `response_format`.+- Exported `mapRequest` for request-mapping tests and downstream inspection.++## [baikai-effectful 0.1.0.0] - 2026-06-12++### Added++- Initial release: effectful binding for baikai with the `Baikai` dynamic+  effect, `complete`, `streamCollect`, `streamEach`, and registry-backed+  interpreters.++## [baikai 0.1.0.0] - 2026-06-04++### Added++- Initial release: unified Haskell interface for working with multiple AI+  providers. Core modules including `Baikai`, `Baikai.Prelude`, `Baikai.Api`,+  `Baikai.Provider`, `Baikai.Provider.Registry`, `Baikai.Response`,+  `Baikai.Stream`, `Baikai.Tool`, `Baikai.Trace`, and the cost/usage modules.+- Depends on released `streamly` (`>=0.11 && <0.13`) and `streamly-core`+  (`>=0.3 && <0.5`) from Hackage, so all dependencies resolve from Hackage.++## [baikai-claude 0.1.0.0] - 2026-06-04++### Added++- Initial release: Anthropic Claude providers for the baikai abstraction,+  wrapping the `claude` package for both the Anthropic API and the `claude -p`+  CLI (`Baikai.Provider.Claude.Api`, `.Cli`, `.Interactive`).++## [baikai-openai 0.1.0.0] - 2026-06-04++### Added++- Initial release: OpenAI providers for the baikai abstraction, wrapping the+  `openai` package for OpenAI's Chat Completions API+  (`Baikai.Provider.OpenAI.Api`, `.Cli`, `.Interactive`).++## [baikai-trace-otel 0.1.0.0] - 2026-06-04++### Added++- Initial release: OpenTelemetry `TraceSink` adapter for baikai+  (`Baikai.Trace.Sink.OpenTelemetry`), emitting one OTel span per provider call+  with GenAI semantic-convention attributes plus baikai cost and latency.
baikai-openai.cabal view
@@ -1,17 +1,21 @@-cabal-version: 3.4-name:          baikai-openai-version:       0.4.0.0-synopsis:      OpenAI providers for the baikai abstraction+cabal-version:   3.4+name:            baikai-openai+version:         0.7.0.0+synopsis:        OpenAI providers for the baikai abstraction description:-  Wraps the openai Haskell package as a Baikai Provider for OpenAI's Chat Completions API.+  OpenAI-compatible backends for baikai: Chat Completions over SSE against OpenAI and+  any host that emulates it, the codex exec batch provider, a launcher for interactive+  Codex sessions, and the renderer for unattended codex runs driven by baikai-agent. -category:      AI-license:       BSD-3-Clause-license-file:  LICENSE-author:        Nadeem Bitar-maintainer:    nadeem@gmail.com-copyright:     (c) 2026 Nadeem Bitar-build-type:    Simple+category:        AI+license:         BSD-3-Clause+license-file:    LICENSE+author:          Nadeem Bitar+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   ghc-options:@@ -20,6 +24,21 @@     -fhide-source-paths -Wmissing-export-lists -Wpartial-fields     -Wmissing-deriving-strategies +  -- Exhaustiveness is an error, not a warning. A non-exhaustive match+  -- is a crash the compiler already found: it fails at runtime, on+  -- whichever input reaches the missing branch, usually in front of a+  -- user. This is not hypothetical here — adding a constructor to+  -- AgentRunFailure left `failureExitCode` non-exhaustive and shipped a+  -- pattern-match failure on `baikai agent run --require-evidence`,+  -- because the warning scrolled past in a build log.+  --+  -- Promoted individually rather than through -Werror, which would also+  -- fail the build on warnings that are stylistic or that a future GHC+  -- invents, and would push people toward blanket suppression.+  ghc-options:+    -Werror=incomplete-patterns -Werror=incomplete-uni-patterns+    -Werror=incomplete-record-updates+   default-language:   GHC2024   default-extensions:     DeriveAnyClass@@ -31,18 +50,27 @@   import:          common-options   hs-source-dirs:  src   exposed-modules:+    Baikai.Provider.OpenAI.Agent     Baikai.Provider.OpenAI.Api     Baikai.Provider.OpenAI.Cli     Baikai.Provider.OpenAI.Interactive     Baikai.Provider.OpenAI.Internal.ErrorClass     Baikai.Provider.OpenAI.Internal.Request+    Baikai.Provider.OpenAI.Internal.Stream+    Baikai.Provider.OpenAI.Internal.Usage+    Baikai.Provider.OpenAI.Responses+    Baikai.Provider.OpenAI.Responses.Assembler+    Baikai.Provider.OpenAI.Responses.Request+    Baikai.Provider.OpenAI.Responses.Stream     Baikai.Provider.OpenAI.Shape     Baikai.Provider.OpenAI.Sse     Baikai.Provider.OpenAI.Transport +  other-modules:   Paths_baikai_openai+  autogen-modules: Paths_baikai_openai   build-depends:     , aeson              ^>=2.2-    , baikai             ^>=0.4.0+    , baikai             ^>=0.7.0     , base               >=4.20   && <5     , base64-bytestring  ^>=1.2     , bytestring         ^>=0.12@@ -50,11 +78,12 @@     , containers         ^>=0.7     , generic-lens       ^>=2.3     , http-client        ^>=0.7-    , http-client-tls    ^>=0.3+    , 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     , streamly           >=0.11   && <0.13     , streamly-core      >=0.3    && <0.5@@ -68,15 +97,28 @@   hs-source-dirs: test   main-is:        Main.hs   other-modules:+    BillingSpec+    CliEvidenceSpec+    Contract+    EndpointModels     ErrorClassSpec+    EvidenceSpec+    LifecycleSpec+    MidStreamSpec+    PublicSurfaceSpec     ReasoningSpec+    ResponsesAssemblerSpec+    ResponsesEvidenceSpec+    ResponsesSpec+    ResponsesStreamSpec+    ResponsesTransportSpec     ShapeSpec     SseSpec     TransportSpec    build-depends:     , aeson-    , baikai            ^>=0.4.0+    , baikai            ^>=0.7.0     , baikai-openai     , base              >=4.20   && <5     , bytestring@@ -88,11 +130,15 @@     , http-client     , http-types     , lens              ^>=5.3+    , network     , openai     , servant-client+    , stm     , streamly-core     >=0.3    && <0.5     , tasty     , tasty-hunit+    , temporary     , text              ^>=2.1     , time+    , tls     , vector
+ src/Baikai/Provider/OpenAI/Agent.hs view
@@ -0,0 +1,219 @@+-- | Render the argument vector for an __unattended__ Codex run from+-- Baikai's provider-neutral unattended request type.+--+-- This module is intentionally separate from the other two Codex+-- surfaces. "Baikai.Provider.OpenAI.Cli" drives @codex exec --json@ as+-- a batch completion provider and returns a parsed response.+-- "Baikai.Provider.OpenAI.Interactive" starts the interactive terminal+-- UI and returns when the human quits. This module describes a run with+-- no terminal and no human, whose deliverable is the changed working+-- tree.+--+-- Every function here is pure: nothing is spawned, and the prompt is+-- carried as data rather than as an argument. A policy @codex exec@+-- cannot express is refused with an 'AgentRenderError' before a process+-- would ever be created — notably a tool allow-list, for which Codex+-- has no flag at all.+module Baikai.Provider.OpenAI.Agent+  ( CodexAgentConfig (executable, extraArgs, skipGitRepoCheck, ephemeral),+    defaultCodexAgentConfig,+    codexAgentCommand,+    codexAgentThinking,+  )+where++import Baikai.Agent+  ( AgentCapability (..),+    AgentCommand (..),+    AgentOutputFormat (..),+    AgentPromptTransport (..),+    AgentProvider (..),+    AgentRenderError (..),+    AgentRunRequest,+  )+import Baikai.Evidence+  ( ThinkingAdjustment (..),+    ThinkingMode (..),+    ThinkingTranslation (..),+    noThinkingRequested,+  )+import Baikai.Prelude+import Baikai.ThinkingLevel (ThinkingLevel, renderThinkingLevel)+import Data.Generics.Labels ()+import Data.Text qualified as Text++-- | Configuration for the unattended @codex@ process.+data CodexAgentConfig = CodexAgentConfig+  { -- | The program to run, either a bare name resolved on @PATH@ or+    -- an explicit path.+    executable :: !FilePath,+    -- | Raw provider defaults an application always wants. Rendered+    -- after every structured flag and before the request's own raw+    -- arguments.+    extraArgs :: ![Text],+    -- | Whether to emit @--skip-git-repo-check@. Defaults to 'True' so+    -- an unattended run works outside a Git repository.+    skipGitRepoCheck :: !Bool,+    -- | Whether to emit @--ephemeral@. Defaults to 'True' so the run+    -- leaves no session files behind.+    ephemeral :: !Bool+  }+  deriving stock (Eq, Show, Generic)++defaultCodexAgentConfig :: CodexAgentConfig+defaultCodexAgentConfig =+  CodexAgentConfig+    { executable = "codex",+      extraArgs = mempty,+      skipGitRepoCheck = True,+      ephemeral = True+    }++-- | Render the executable, argument vector, and prompt transport for an+-- unattended Codex run, or refuse the request.+--+-- The prompt appears nowhere in the argument vector: the transport is+-- 'PromptOnStdin'. That is not merely convenient here — @codex exec@+-- documents that if standard input is piped /and/ a positional prompt+-- is supplied, standard input is appended as a @\<stdin\>@ block, so+-- emitting both would silently corrupt the instruction.+--+-- Long flag spellings are used throughout, @--sandbox@ and @--cd@+-- rather than @-s@ and @-C@, because the rendered vector is printed to+-- operators and a long flag is self-describing.+-- The second half of the pair describes what the request's reasoning+-- effort became on that command line. The runner cannot derive it — it+-- never imports a vendor renderer — so it travels alongside the command.+codexAgentCommand ::+  CodexAgentConfig ->+  AgentRunRequest ->+  Either AgentRenderError (AgentCommand, ThinkingTranslation)+codexAgentCommand cfg req+  | req ^. #provider /= AgentCodex =+      Left (ProviderMismatch AgentCodex (req ^. #provider))+  | otherwise = do+      toolRestrictionGuard req+      sandbox <- sandboxArgs (req ^. #safety . #capability)+      pure+        ( AgentCommand+            { executable = cfg ^. #executable,+              arguments =+                ["exec"]+                  <> modelArgs req+                  <> effortArgs req+                  <> outputFormatArgs req+                  <> sandbox+                  <> ["--cd", req ^. #workingDir]+                  <> extraDirArgs req+                  <> ["--skip-git-repo-check" | cfg ^. #skipGitRepoCheck]+                  <> ["--ephemeral" | cfg ^. #ephemeral]+                  <> fmap Text.unpack (cfg ^. #extraArgs)+                  <> fmap Text.unpack (req ^. #safety . #providerArgs),+              promptTransport = PromptOnStdin,+              promptText = req ^. #prompt+            },+          codexAgentThinking req+        )++-- | What the request's reasoning effort became on the @codex exec@+-- command line.+--+-- The adjustment list is derived by comparing what 'effortArgs' actually+-- sends — through the same 'codexEffortValue' — with the canonical level+-- name, rather than being hardcoded empty. It is empty at every level,+-- because codex is the one tool baikai drives that accepts all six+-- verbatim; writing @[]@ by hand would keep claiming that after someone+-- changed the mapping.+--+-- A request with no effort at all yields 'noThinkingRequested', which is+-- a different fact from a request whose level the tool weakened.+codexAgentThinking :: AgentRunRequest -> ThinkingTranslation+codexAgentThinking req = case req ^. #effort of+  Nothing -> noThinkingRequested+  Just lvl ->+    let wire = codexEffortValue lvl+     in ThinkingTranslation+          { requested = Just lvl,+            mode = ThinkingModeFlag,+            effortText = Just wire,+            budgetTokens = Nothing,+            wireField = Just "model_reasoning_effort",+            displayText = Nothing,+            adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl]+          }++-- | Map a capability profile onto @codex exec@'s @--sandbox@. Kept an+-- 'Either' for the same reason as the Claude renderer's permission-mode+-- mapping: an unmappable capability must be refused, never+-- approximated.+sandboxArgs :: AgentCapability -> Either AgentRenderError [String]+sandboxArgs = \case+  AgentReadOnly -> Right ["--sandbox", "read-only"]+  AgentEditWorkspace -> Right ["--sandbox", "workspace-write"]+  AgentFullAccess -> Right ["--sandbox", "danger-full-access"]++-- | @codex exec@ has no tool allow-list flag, so a request that names+-- tool grants is refused rather than run without them. A caller who+-- granted a tool set and gets a run that ignores the list has been given+-- something other than what they asked for, which is the silent+-- substitution this surface exists to prevent. The message names the+-- alternative so the error is actionable.+--+-- The operator's ceiling runs first, so a job that both grants a tool+-- the operator forbids /and/ selects Codex hears about the policy+-- problem — the one the operator can fix — rather than this one.+toolRestrictionGuard :: AgentRunRequest -> Either AgentRenderError ()+toolRestrictionGuard req = case req ^. #safety . #allowedTools of+  [] -> Right ()+  _ ->+    Left+      ( UnsupportedToolRestriction+          AgentCodex+          "codex exec has no tool allow-list flag; restrict Codex with a narrower \+          \sandbox mode, or pass an explicit provider argument if your operator \+          \policy permits raw arguments"+      )++-- | Ask @codex exec@ for machine-readable output.+--+-- @codex exec --json@ prints its events to standard output as JSONL,+-- which is the shape+-- 'Baikai.Provider.Cli.Internal.parseCodexJsonlStream' already parses;+-- without it the tool prints a transcript meant for a person and an+-- evidence record can observe nothing. There is no @text@ flag to+-- render, because that is the default.+outputFormatArgs :: AgentRunRequest -> [String]+outputFormatArgs req = case req ^. #outputFormat of+  TextFormat -> []+  JsonFormat -> ["--json"]++-- | A blank model value must not produce @--model ""@.+modelArgs :: AgentRunRequest -> [String]+modelArgs req = case Text.strip <$> req ^. #modelId of+  Nothing -> []+  Just "" -> []+  Just mid -> ["--model", Text.unpack mid]++-- | Codex receives reasoning effort through a config override and+-- accepts all six canonical Baikai levels, so there is no clamp here —+-- unlike Claude, whose @--effort@ has no @minimal@ value. The+-- provider-only @none@ and @ultra@ values remain available through raw+-- provider arguments.+effortArgs :: AgentRunRequest -> [String]+effortArgs req = case req ^. #effort of+  Nothing -> []+  Just lvl ->+    ["-c", "model_reasoning_effort=" <> Text.unpack (codexEffortValue lvl)]++-- | The word codex's @model_reasoning_effort@ override receives. Codex+-- accepts all six baikai levels verbatim, which makes this the identity.+codexEffortValue :: ThinkingLevel -> Text+codexEffortValue = renderThinkingLevel++-- | On @codex exec@ @--add-dir@ grants /write/ access alongside the+-- primary workspace. The identically named Claude Code flag grants tool+-- /access/, so the shared @extraDirs@ field means "directories this run+-- may reach" and the precise authority is provider-dependent.+extraDirArgs :: AgentRunRequest -> [String]+extraDirArgs req =+  concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs)
src/Baikai/Provider/OpenAI/Api.hs view
@@ -1,993 +1,89 @@-{-# LANGUAGE LambdaCase #-}---- | Provider wrapping the @openai@ package's Chat Completions API.------ Call 'register' once (typically from @main@) to install the--- 'Baikai.Api.OpenAIChatCompletions' handler into the baikai--- provider registry. After registration, any 'Baikai.Model.Model'--- whose 'Baikai.Api.api' tag is 'OpenAIChatCompletions' dispatches--- through this handler.------ The handler resolves 'Baikai.Options.apiKey' when present, falling--- back to the host-specific env var from--- 'Baikai.Auth.defaultApiKeyEnvForBaseUrl'. Unknown hosts require an--- explicit key source.------ EP-3 promotes streaming to the primary entry point. The handler--- exposes a 'streamly' 'Stream' of 'AssistantMessageEvent' values--- bridged from a local SSE transport. Requests start as the SDK's--- typed 'OpenAI.V1.Chat.Completions.CreateChatCompletion' value, then--- 'Baikai.Provider.OpenAI.Shape.streamRequestBody' rewrites the raw--- JSON body for OpenAI-compatible host quirks before--- 'Baikai.Provider.OpenAI.Sse.openaiSseStreamValueWithHeaders' sends--- it with cached transport settings and caller headers. Streaming--- responses are parsed from raw 'Aeson.Value' chunks so partial--- tool-call deltas may omit fields such as @id@ and @function.name@.------ The synchronous 'complete' field is derived via--- 'streamingComplete', so callers that drain the stream get the--- same fully-assembled 'Response' they had before.-module Baikai.Provider.OpenAI.Api-  ( register,-    registerWithRegistry,-    openaiChatProvider,-    openaiChatStream,-    RawChunk (..),-    RawToolDelta (..),-    parseChunk,-    TagScanState (..),-    _TagScanState,-    scanThinkTags,-    Assembler (..),-    emptyAssembler,-    translate,-    closeOpenStream,--    -- * Usage mapping--    -- Exposed for tests; may move behind an .Internal namespace in a later plan.-    RawUsage (..),-    parseUsage,-    rawUsageToUsage,-  )-where--import Baikai.Api (Api (..))-import Baikai.Compat (OpenAICompletionsCompat (requiresThinkingAsText))-import Baikai.Content qualified as Content-import Baikai.Context (Context (..))-import Baikai.Cost (zeroCost)-import Baikai.Cost.Pricing qualified as Pricing-import Baikai.Error (BaikaiError, invalidRequest, providerError)-import Baikai.Message qualified as Msg-import Baikai.Model (Model, openaiCompletionsCompatFor)-import Baikai.Options (Options (..))-import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyException)-import Baikai.Provider.OpenAI.Internal.Request (mapRequest)-import Baikai.Provider.OpenAI.Shape (streamRequestBody)-import Baikai.Provider.OpenAI.Sse (openaiSseStreamValueWithHeaders)-import Baikai.Provider.OpenAI.Transport qualified as Transport-import Baikai.Provider.Registry-  ( ApiProvider (..),-    ProviderRegistry,-    registerApiProvider,-    registerApiProviderWith,-  )-import Baikai.StopReason qualified as Stop-import Baikai.Stream (streamingComplete)-import Baikai.Stream.Event-  ( AssistantMessageEvent (..),-    BlockEndPayload (..),-    DeltaPayload (..),-    IndexPayload (..),-    StartPayload (..),-    ThinkingEndPayload (..),-    ToolCallEndPayload (..),-    doneTerminal,-    errorTerminal,-  )-import Baikai.Usage qualified as Usage-import Control.Applicative ((<|>))-import Control.Concurrent (forkIO)-import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan)-import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try)-import Control.Lens ((%~), (&), (.~), (^.))-import Data.Aeson (Value (..), (.:?))-import Data.Aeson qualified as Aeson-import Data.Aeson.Key qualified as AesonKey-import Data.Aeson.KeyMap qualified as KeyMap-import Data.Aeson.Types qualified as Aeson-import Data.Generics.Labels ()-import Data.IORef (IORef, newIORef, readIORef, writeIORef)-import Data.IntMap.Strict (IntMap)-import Data.IntMap.Strict qualified as IntMap-import Data.Map.Strict (Map)-import Data.Map.Strict qualified as Map-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import Data.Text qualified as Text-import Data.Text.Encoding qualified as Text-import Data.Time.Clock (UTCTime, getCurrentTime)-import Data.Vector (Vector)-import Data.Vector qualified as Vector-import GHC.Generics (Generic)-import Network.HTTP.Types.Header (RequestHeaders)-import Numeric.Natural (Natural)-import Servant.Client qualified as Client-import Streamly.Data.Stream (Stream)-import Streamly.Data.Stream qualified as Stream---- | Install the OpenAI Chat Completions handler into the registry.-register :: IO ()-register = registerApiProvider openaiChatProvider---- | First-class OpenAI Chat Completions provider value. Use with--- 'registerApiProviderWith' or 'newProviderRegistryFrom' for explicit--- registries.-openaiChatProvider :: ApiProvider-openaiChatProvider =-  ApiProvider-    { apiTag = OpenAIChatCompletions,-      stream = openaiChatStream,-      complete = streamingComplete openaiChatStream-    }---- | Install the OpenAI Chat Completions handler into an explicit registry.-registerWithRegistry :: ProviderRegistry -> IO ()-registerWithRegistry reg =-  registerApiProviderWith-    reg-    openaiChatProvider-{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg openaiChatProvider" #-}---- | Streaming producer for the OpenAI Chat Completions API.------ Forks one worker thread per call that drives--- 'OpenAI.createChatCompletionStream' (the raw 'Aeson.Value'--- variant, not the typed one — see module docs for why). The--- worker pushes raw chunk values onto a 'Chan' terminated by--- 'Nothing'; the consumer translates each chunk into zero or more--- baikai 'AssistantMessageEvent' values and terminates with exactly--- one 'EventDone' or 'EventError'.-openaiChatStream ::-  Model -> Context -> Options -> Stream IO AssistantMessageEvent-openaiChatStream m ctx opts =-  Stream.concatEffect $ do-    setupResult <- trySync (prepareCall m ctx opts)-    let setup = either (Left . exceptionToError) id setupResult-    case setup of-      Left err -> Stream.fromList <$> immediateError err-      Right call -> do-        ch <- newChan :: IO (Chan (Maybe (Either BaikaiError RawChunk)))-        tref <- newIORef False-        _ <- forkIO (worker call ch)-        startTime <- getCurrentTime-        let initialState =-              ProducerState-                { chan = ch,-                  pending = [EventStart StartPayload {partial = skeletonStart m startTime, responseId = Nothing}],-                  assembler = emptyAssembler m startTime,-                  finished = False,-                  terminalRef = tref-                }-        pure (Stream.unfoldrM step initialState)--skeletonStart :: Model -> UTCTime -> Msg.Message-skeletonStart _m start =-  Msg.AssistantMessage-    Msg.AssistantPayload-      { Msg.content = Vector.empty,-        Msg.usage = Usage.zeroUsage,-        Msg.stopReason = Stop.Stop,-        Msg.errorMessage = Nothing,-        Msg.timestamp = Just start-      }---- | Per-call prepared values.-data OpenAICall = OpenAICall-  { clientEnv :: !Client.ClientEnv,-    requestHeaders :: !RequestHeaders,-    timeoutMs :: !(Maybe Int),-    requestBody :: !Aeson.Value-  }-  deriving stock (Generic)--prepareCall :: Model -> Context -> Options -> IO (Either BaikaiError OpenAICall)-prepareCall m ctx opts = case mapRequest m ctx opts of-  Left e -> pure (Left (invalidRequest e))-  Right req -> do-    let url = case m ^. #baseUrl of-          "" -> "https://api.openai.com"-          u -> u-    key <- Transport.resolveKey url opts-    env <- Transport.getClientEnvCached url-    let compat = openaiCompletionsCompatFor m-        body = streamRequestBody compat opts req-        headers = Transport.requestHeaders key m opts-    pure-      ( Right-          OpenAICall-            { clientEnv = env,-              requestHeaders = headers,-              timeoutMs = opts ^. #timeoutMs,-              requestBody = body-            }-      )---- | A loose summary of one streamed chunk. The raw 'Aeson.Value' is--- pre-parsed into the fields we care about; unknown fields are--- ignored. Missing fields are 'Nothing' (we tolerate partial--- tool-call deltas).-data RawChunk = RawChunk-  { contentDelta :: !(Maybe Text),-    reasoningDelta :: !(Maybe Text),-    finishReason :: !(Maybe Text),-    toolDeltas :: ![RawToolDelta],-    usage :: !(Maybe RawUsage)-  }-  deriving stock (Show, Generic)--data RawToolDelta = RawToolDelta-  { index :: !(Maybe Int),-    id_ :: !(Maybe Text),-    name :: !(Maybe Text),-    args :: !(Maybe Text)-  }-  deriving stock (Show, Generic)--data RawUsage = RawUsage-  { inputTokens :: !Natural,-    outputTokens :: !Natural,-    cacheReadTokens :: !Natural,-    reasoningTokens :: !(Maybe Natural)-  }-  deriving stock (Show, Generic)--worker ::-  OpenAICall -> Chan (Maybe (Either BaikaiError RawChunk)) -> IO ()-worker call ch = do-  r <--    trySync $-      Transport.runWithTimeout (call ^. #timeoutMs) $-        openaiSseStreamValueWithHeaders (call ^. #clientEnv) (call ^. #requestHeaders) (call ^. #requestBody) $ \case-          Left be -> writeChan ch (Just (Left be))-          Right val -> case parseChunk val of-            Left err -> writeChan ch (Just (Left (providerError (Text.pack err))))-            Right chunk -> writeChan ch (Just (Right chunk))-  case r of-    Right Nothing -> pure ()-    Right (Just be) -> writeChan ch (Just (Left be))-    Left e -> writeChan ch (Just (Left (exceptionToError e)))-  writeChan ch Nothing---- | Aeson parser tolerant of partial tool-call fields.-parseChunk :: Value -> Either String RawChunk-parseChunk = Aeson.parseEither $ Aeson.withObject "ChatCompletionChunk" $ \o -> do-  choices <- o .:? "choices"-  let firstChoice :: Maybe Aeson.Object-      firstChoice = case choices of-        Just (Aeson.Array a)-          | Vector.length a > 0 ->-              case Vector.head a of-                Aeson.Object obj -> Just obj-                _ -> Nothing-        _ -> Nothing-  (contentDelta, reasoningDelta, finishR, toolDeltas) <- case firstChoice of-    Nothing -> pure (Nothing, Nothing, Nothing, [])-    Just ch -> do-      finish <- ch .:? "finish_reason"-      delta <- ch .:? "delta"-      case delta of-        Nothing -> parseMessageObject ch finish-        Just (Aeson.Object dObj) -> do-          cd <- dObj .:? "content"-          let rd = reasoningText dObj-          tc <- dObj .:? "tool_calls"-          let tds = parseToolCallDeltas tc-          pure (cd, rd, finish, tds)-        _ -> parseMessageObject ch finish-  usageM <- o .:? "usage"-  let ru = case usageM of-        Just (Aeson.Object uObj) -> parseUsage uObj-        _ -> Nothing-  pure-    RawChunk-      { contentDelta = contentDelta,-        reasoningDelta = reasoningDelta,-        finishReason = finishR,-        toolDeltas = toolDeltas,-        usage = ru-      }--parseMessageObject ::-  Aeson.Object ->-  Maybe Text ->-  Aeson.Parser (Maybe Text, Maybe Text, Maybe Text, [RawToolDelta])-parseMessageObject ch finish = do-  msg <- ch .:? "message"-  case msg of-    Just (Aeson.Object mObj) -> do-      cd <- mObj .:? "content"-      pure (cd, reasoningText mObj, finish, [])-    _ -> pure (Nothing, Nothing, finish, [])--reasoningText :: Aeson.Object -> Maybe Text-reasoningText obj =-  lookupText "reasoning_content" obj <|> lookupText "reasoning" obj--parseToolCallDeltas :: Maybe Value -> [RawToolDelta]-parseToolCallDeltas = \case-  Just (Aeson.Array v) -> Vector.toList (Vector.mapMaybe oneDelta v)-  _ -> []-  where-    oneDelta :: Value -> Maybe RawToolDelta-    oneDelta = \case-      Aeson.Object o ->-        let funcObj :: Maybe Aeson.Object-            funcObj = case lookupField "function" o of-              Just (Aeson.Object f) -> Just f-              _ -> Nothing-            getName = funcObj >>= lookupText "name"-            getArgs = funcObj >>= lookupText "arguments"-         in Just-              RawToolDelta-                { index = fromInt <$> lookupField "index" o,-                  id_ = lookupText "id" o,-                  name = getName,-                  args = getArgs-                }-      _ -> Nothing--parseUsage :: Aeson.Object -> Maybe RawUsage-parseUsage o =-  case Aeson.parseEither pUsage o of-    Right u -> Just u-    Left _ -> Nothing-  where-    pUsage obj = do-      i <- obj .:? "prompt_tokens"-      out <- obj .:? "completion_tokens"-      ptd <- obj .:? "prompt_tokens_details"-      ctd <- obj .:? "completion_tokens_details"-      let cached = case ptd of-            Just (Aeson.Object p) -> case lookupField "cached_tokens" p of-              Just (Aeson.Number n) -> truncate n-              _ -> 0 :: Natural-            _ -> 0-          reasoning = case ctd of-            Just (Aeson.Object c) -> case lookupField "reasoning_tokens" c of-              Just (Aeson.Number n) -> Just (truncate n)-              _ -> Nothing-            _ -> Nothing-      pure-        RawUsage-          { inputTokens = fromMaybe 0 i,-            outputTokens = fromMaybe 0 out,-            cacheReadTokens = cached,-            reasoningTokens = reasoning-          }--lookupField :: Text -> Aeson.Object -> Maybe Value-lookupField k = KeyMap.lookup (AesonKey.fromText k)---- Pull a Text-valued field out of an Aeson object; tolerates--- absent or non-Text values by returning 'Nothing'.-lookupText :: Text -> Aeson.Object -> Maybe Text-lookupText k o = case lookupField k o of-  Just (Aeson.String t) -> Just t-  _ -> Nothing--fromInt :: Value -> Int-fromInt = \case-  Aeson.Number n -> truncate n-  _ -> 0---- ============================================================--- Streamly state machine--- ============================================================--data ProducerState = ProducerState-  { chan :: !(Chan (Maybe (Either BaikaiError RawChunk))),-    pending :: ![AssistantMessageEvent],-    assembler :: !Assembler,-    finished :: !Bool,-    terminalRef :: !(IORef Bool)-  }-  deriving stock (Generic)--step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState))-step s-  | (e : rest) <- s ^. #pending = do-      writeTerminal s e-      pure-        ( Just-            ( e,-              s-                & #pending .~ rest-                & #finished .~ (s ^. #finished || terminal e)-            )-        )-  | s ^. #finished = pure Nothing-  | otherwise = do-      mRaw <- readChan (s ^. #chan)-      case mRaw of-        Nothing -> do-          alreadyTerminal <- readIORef (s ^. #terminalRef)-          if alreadyTerminal-            then pure Nothing-            else do-              now <- getCurrentTime-              let (events, ass') = closeOpenStream now Nothing (s ^. #assembler)-              case events of-                [] -> pure Nothing-                (e : rest) -> do-                  writeTerminal s e-                  pure-                    ( Just-                        ( e,-                          s-                            & #pending .~ rest-                            & #assembler .~ ass'-                            & #finished .~ True-                        )-                    )-        Just raw -> do-          now <- getCurrentTime-          let (events, ass') = translate raw (s ^. #assembler) now-          case events of-            [] -> step (s & #assembler .~ ass')-            (e : rest) -> do-              writeTerminal s e-              pure-                ( Just-                    ( e,-                      s-                        & #pending .~ rest-                        & #assembler .~ ass'-                        & #finished .~ (s ^. #finished || terminal e)-                    )-                )--writeTerminal :: ProducerState -> AssistantMessageEvent -> IO ()-writeTerminal s ev-  | terminal ev = writeIORef (s ^. #terminalRef) True-  | otherwise = pure ()--terminal :: AssistantMessageEvent -> Bool-terminal = \case-  EventDone {} -> True-  EventError {} -> True-  _ -> False---- ============================================================--- Translation--- ============================================================--data TagMode-  = TagVisible-  | TagReasoning-  deriving stock (Eq, Show, Generic)---- | Incremental scanner state for hosts that stream reasoning in--- assistant text using @<think>@ or @<thinking>@ tags.-data TagScanState = TagScanState-  { tagMode :: !TagMode,-    tagPending :: !Text-  }-  deriving stock (Eq, Show, Generic)--_TagScanState :: TagScanState-_TagScanState =-  TagScanState-    { tagMode = TagVisible,-      tagPending = Text.empty-    }---- | Split one text delta into reasoning fragments ('Left') and--- visible text fragments ('Right'), preserving partial tag prefixes--- across chunk boundaries.-scanThinkTags :: TagScanState -> Text -> (TagScanState, [Either Text Text])-scanThinkTags st input =-  let (mode', pending', parts) = go (tagMode st) (tagPending st <> input) []-   in (TagScanState {tagMode = mode', tagPending = pending'}, parts)-  where-    go mode txt acc =-      case findTag mode txt of-        Just (before, after, nextMode) ->-          go nextMode after (appendPart mode before acc)-        Nothing ->-          let (emitNow, pending) = splitPending mode txt-           in (mode, pending, appendPart mode emitNow acc)--    appendPart _ "" acc = acc-    appendPart TagVisible t acc = acc <> [Right t]-    appendPart TagReasoning t acc = acc <> [Left t]--findTag :: TagMode -> Text -> Maybe (Text, Text, TagMode)-findTag mode txt =-  case earliest markers of-    Nothing -> Nothing-    Just (idx, marker) ->-      Just-        ( Text.take idx txt,-          Text.drop (idx + Text.length marker) txt,-          nextMode-        )-  where-    (markers, nextMode) = case mode of-      TagVisible -> (openingTags, TagReasoning)-      TagReasoning -> (closingTags, TagVisible)-    earliest =-      foldr-        ( \marker best ->-            case Text.breakOn marker txt of-              (_, "") -> best-              (before, _) ->-                let candidate = (Text.length before, marker)-                 in case best of-                      Nothing -> Just candidate-                      Just (oldIdx, _) | Text.length before < oldIdx -> Just candidate-                      _ -> best-        )-        Nothing--splitPending :: TagMode -> Text -> (Text, Text)-splitPending mode txt =-  let suffix = longestTagPrefix (case mode of TagVisible -> openingTags; TagReasoning -> closingTags) txt-   in (Text.dropEnd (Text.length suffix) txt, suffix)--longestTagPrefix :: [Text] -> Text -> Text-longestTagPrefix markers txt =-  foldr longer Text.empty candidates-  where-    candidates =-      [ suffix-      | n <- [1 .. Text.length txt],-        let suffix = Text.takeEnd n txt,-        any (suffix `Text.isPrefixOf`) markers-      ]-    longer a b-      | Text.length a > Text.length b = a-      | otherwise = b--openingTags :: [Text]-openingTags = ["<think>", "<thinking>"]--closingTags :: [Text]-closingTags = ["</think>", "</thinking>"]---- | Translation state across one streaming call.-data Assembler = Assembler-  { model :: !Model,-    start :: !UTCTime,-    -- | 'Just i' when a text block at baikai contentIndex @i@ is-    -- currently open; 'Nothing' when no text block is open.-    textOpen :: !(Maybe Int),-    textAccum :: !Text,-    textEverOpened :: !Bool,-    reasoningOpen :: !(Maybe Int),-    reasoningAccum :: !Text,-    tagScanState :: !TagScanState,-    -- | Maps OpenAI's per-call tool-call index to baikai's-    -- 'contentIndex'.-    toolIndexMap :: !(IntMap Int),-    toolIdMap :: !(Map Text Int),-    lastToolIdx :: !(Maybe Int),-    -- | baikai contentIndex → (id, name).-    toolMeta :: !(IntMap (Text, Text)),-    -- | baikai contentIndex → accumulated arguments JSON.-    toolArgs :: !(IntMap Text),-    closed :: !(IntMap Content.AssistantContent),-    nextContentIndex :: !Int,-    usage :: !Usage.Usage,-    stopReason :: !Stop.StopReason,-    -- | 'True' once a chunk carrying @finish_reason@ has been-    -- observed. The terminal 'EventDone' fires on channel close so-    -- the post-@finish_reason@ usage chunk (when @include_usage@ is-    -- enabled) has a chance to land.-    finishSeen :: !Bool,-    pendingError :: !(Maybe BaikaiError),-    finishNote :: !(Maybe Text)-  }-  deriving stock (Generic)--emptyAssembler :: Model -> UTCTime -> Assembler-emptyAssembler m s =-  Assembler-    { model = m,-      start = s,-      textOpen = Nothing,-      textAccum = Text.empty,-      textEverOpened = False,-      reasoningOpen = Nothing,-      reasoningAccum = Text.empty,-      tagScanState = _TagScanState,-      toolIndexMap = IntMap.empty,-      toolIdMap = Map.empty,-      lastToolIdx = Nothing,-      toolMeta = IntMap.empty,-      toolArgs = IntMap.empty,-      closed = IntMap.empty,-      nextContentIndex = 0,-      usage = Usage.zeroUsage,-      stopReason = Stop.Stop,-      finishSeen = False,-      pendingError = Nothing,-      finishNote = Nothing-    }--translate ::-  Either BaikaiError RawChunk ->-  Assembler ->-  UTCTime ->-  ([AssistantMessageEvent], Assembler)-translate chunk ass now-  | Left be <- chunk =-      let msg = finalMessage ass now (Just (be ^. #message)) Stop.ErrorReason-       in ([EventError (errorTerminal Nothing Stop.ErrorReason msg be)], ass)-  | Right raw <- chunk =-      let -- 1. Apply field-based reasoning delta.-          (reasoningEvents, ass1) = applyReasoningDelta (raw ^. #reasoningDelta) ass-          -- 2. Apply content delta (open text block if needed).-          (textEvents, ass2) = applyContentDelta (raw ^. #contentDelta) ass1-          -- 3. Apply tool-call deltas.-          (toolEvents, ass3) = applyToolDeltas (raw ^. #toolDeltas) ass2-          -- 4. Apply usage chunk if present.-          ass4 = applyUsage (raw ^. #usage) ass3-          -- 5. If finish_reason is set, close any open text/tool-          --    blocks and stash the reason. EventDone is deferred-          --    to channel close so the post-finish_reason usage-          --    chunk has a chance to land.-          (closeEvents, ass5) = case raw ^. #finishReason of-            Just fr -> closeOnFinish fr ass4-            Nothing -> ([], ass4)-       in (reasoningEvents <> textEvents <> toolEvents <> closeEvents, ass5)--applyReasoningDelta ::-  Maybe Text -> Assembler -> ([AssistantMessageEvent], Assembler)-applyReasoningDelta Nothing ass = ([], ass)-applyReasoningDelta (Just "") ass = ([], ass)-applyReasoningDelta (Just d) ass =-  case ass ^. #reasoningOpen of-    Just i ->-      ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = d}],-        ass & #reasoningAccum %~ (<> d)-      )-    Nothing ->-      let i = ass ^. #nextContentIndex-       in ( [ThinkingStart IndexPayload {contentIndex = i}, ThinkingDelta DeltaPayload {contentIndex = i, delta = d}],-            ass-              & #reasoningOpen .~ Just i-              & #reasoningAccum .~ d-              & #nextContentIndex .~ (i + 1)-          )--applyContentDelta ::-  Maybe Text -> Assembler -> ([AssistantMessageEvent], Assembler)-applyContentDelta Nothing ass = ([], ass)-applyContentDelta (Just "") ass = ([], ass)-applyContentDelta (Just d) ass =-  if requiresThinkingAsText (openaiCompletionsCompatFor (ass ^. #model))-    then-      let (tagState', parts) = scanThinkTags (ass ^. #tagScanState) d-          (events, ass') = foldl' applyTaggedPart ([], ass & #tagScanState .~ tagState') parts-       in (events, ass')-    else applyVisibleTextDelta d ass--applyTaggedPart ::-  ([AssistantMessageEvent], Assembler) ->-  Either Text Text ->-  ([AssistantMessageEvent], Assembler)-applyTaggedPart (acc, ass) = \case-  Left reasoning ->-    let (events, ass') = applyReasoningDelta (Just reasoning) ass-     in (acc <> events, ass')-  Right visible ->-    let (events, ass') = applyVisibleTextDelta visible ass-     in (acc <> events, ass')--applyVisibleTextDelta ::-  Text -> Assembler -> ([AssistantMessageEvent], Assembler)-applyVisibleTextDelta "" ass = ([], ass)-applyVisibleTextDelta d ass =-  case ass ^. #textOpen of-    Just i ->-      let (reasoningEvents, ass1) = closeOpenReasoning ass-       in ( reasoningEvents <> [TextDelta DeltaPayload {contentIndex = i, delta = d}],-            ass1 & #textAccum %~ (<> d)-          )-    Nothing ->-      let (reasoningEvents, ass1) = closeOpenReasoning ass-          i = ass1 ^. #nextContentIndex-       in ( reasoningEvents <> [TextStart IndexPayload {contentIndex = i}, TextDelta DeltaPayload {contentIndex = i, delta = d}],-            ass1-              & #textOpen .~ Just i-              & #textAccum .~ d-              & #textEverOpened .~ True-              & #nextContentIndex .~ (i + 1)-          )--applyToolDeltas ::-  [RawToolDelta] -> Assembler -> ([AssistantMessageEvent], Assembler)-applyToolDeltas [] ass = ([], ass)-applyToolDeltas deltas ass =-  let (reasoningEvents, ass0) = closeOpenReasoning ass-      (toolEvents, ass') = foldl' apply ([], ass0) deltas-   in (reasoningEvents <> toolEvents, ass')-  where-    apply (acc, a) d =-      let (events, a') = applyOneToolDelta d a-       in (acc <> events, a')--applyOneToolDelta ::-  RawToolDelta -> Assembler -> ([AssistantMessageEvent], Assembler)-applyOneToolDelta d ass =-  let mOpenaiIdx = d ^. #index-      mToolId = d ^. #id_-      byIndex = mOpenaiIdx >>= \idx -> IntMap.lookup idx (ass ^. #toolIndexMap)-      byId = mToolId >>= \tid -> Map.lookup tid (ass ^. #toolIdMap)-      byLast =-        case (mOpenaiIdx, mToolId) of-          (Nothing, Nothing) -> ass ^. #lastToolIdx-          _ -> Nothing-      (baikaiIdx, ass1, opened) = case byIndex <|> byId <|> byLast of-        Just i ->-          ( i,-            ass-              & #toolIdMap %~ maybe id (`Map.insert` i) mToolId-              & #lastToolIdx .~ Just i,-            False-          )-        Nothing ->-          let i = ass ^. #nextContentIndex-              ass' =-                ass-                  & #toolIndexMap %~ maybe id (`IntMap.insert` i) mOpenaiIdx-                  & #toolIdMap %~ maybe id (`Map.insert` i) mToolId-                  & #lastToolIdx .~ Just i-                  & #toolMeta %~ IntMap.insert i ("", "")-                  & #toolArgs %~ IntMap.insert i Text.empty-                  & #nextContentIndex .~ (i + 1)-           in (i, ass', True)-      -- Update metadata (id/name first delta only).-      ass2 =-        ass1-          & #toolMeta-            %~ IntMap.adjust-              ( \(existingId, existingName) ->-                  ( maybe existingId (\x -> if Text.null existingId then x else existingId) (d ^. #id_),-                    maybe existingName (\x -> if Text.null existingName then x else existingName) (d ^. #name)-                  )-              )-              baikaiIdx-      -- Append args if present.-      argsDelta = fromMaybe "" (d ^. #args)-      ass3 = ass2 & #toolArgs %~ IntMap.adjust (<> argsDelta) baikaiIdx-      events0 = if opened then [ToolCallStart IndexPayload {contentIndex = baikaiIdx}] else []-      events1 =-        if Text.null argsDelta-          then events0-          else events0 <> [ToolCallDelta DeltaPayload {contentIndex = baikaiIdx, delta = argsDelta}]-   in (events1, ass3)---- | Normalize OpenAI's inclusive usage counters into baikai's--- disjoint 'Usage.Usage' convention. OpenAI's @prompt_tokens@--- includes @prompt_tokens_details.cached_tokens@, so the cached count--- is subtracted out of 'Usage.inputTokens'. The subtraction is clamped--- at zero because 'Natural' subtraction throws on underflow and because--- OpenAI-compatible hosts can report inconsistent counters.--- 'Usage.totalTokens' is recomputed from the normalized parts;--- 'Usage.reasoningTokens' is a subset of 'Usage.outputTokens' and is--- not added to the total. OpenAI does not bill cache writes, so--- 'Usage.cacheWriteTokens' is always zero.-rawUsageToUsage :: RawUsage -> Usage.Usage-rawUsageToUsage u =-  let prompt = u ^. #inputTokens-      cached = u ^. #cacheReadTokens-      out = u ^. #outputTokens-      nonCached = if cached >= prompt then 0 else prompt - cached-   in Usage.Usage-        { Usage.inputTokens = nonCached,-          Usage.outputTokens = out,-          Usage.cacheReadTokens = cached,-          Usage.cacheWriteTokens = 0,-          Usage.reasoningTokens = u ^. #reasoningTokens,-          Usage.totalTokens = nonCached + out + cached,-          Usage.cost = zeroCost-        }--applyUsage :: Maybe RawUsage -> Assembler -> Assembler-applyUsage Nothing ass = ass-applyUsage (Just u) ass = ass & #usage .~ rawUsageToUsage u---- | Close all open content blocks and stash the resolved stop--- reason; defer 'EventDone' to channel close.-closeOnFinish ::-  Text -> Assembler -> ([AssistantMessageEvent], Assembler)-closeOnFinish finishReason ass =-  let (tagEvents, ass0) = flushTagScanPending ass-      (closeReasoning, ass1) = closeOpenReasoning ass0-      (closeText, ass2) = closeOpenText ass1-      (closeTools, ass3) = closeOpenTools ass2-      (reason, note) = mapFinishReason finishReason-      pending =-        if reason == Stop.ErrorReason-          then Just (providerError ("provider stopped the response: finish_reason=" <> finishReason))-          else Nothing-      ass4 =-        ass3-          & #stopReason .~ reason-          & #finishSeen .~ True-          & #pendingError .~ pending-          & #finishNote .~ note-   in (tagEvents <> closeReasoning <> closeText <> closeTools, ass4)--flushTagScanPending :: Assembler -> ([AssistantMessageEvent], Assembler)-flushTagScanPending ass =-  let st = ass ^. #tagScanState-      pending = tagPending st-      ass0 = ass & #tagScanState .~ st {tagPending = Text.empty}-   in case (tagMode st, pending) of-        (_, "") -> ([], ass0)-        (TagVisible, t) -> applyVisibleTextDelta t ass0-        (TagReasoning, t) -> applyReasoningDelta (Just t) ass0--closeOpenReasoning :: Assembler -> ([AssistantMessageEvent], Assembler)-closeOpenReasoning ass = case ass ^. #reasoningOpen of-  Nothing -> ([], ass)-  Just i ->-    let body = ass ^. #reasoningAccum-        thinkingContent =-          Content.ThinkingContent-            { Content.thinking = body,-              Content.signature = Nothing,-              Content.redacted = False-            }-        block = Content.AssistantThinking thinkingContent-     in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}],-          ass-            & #reasoningOpen .~ Nothing-            & #reasoningAccum .~ Text.empty-            & #closed %~ IntMap.insert i block-        )---- | Close the open text block, if any, by emitting a 'TextEnd' and--- storing the assembled content in 'closed'.-closeOpenText :: Assembler -> ([AssistantMessageEvent], Assembler)-closeOpenText ass = case ass ^. #textOpen of-  Nothing -> ([], ass)-  Just i ->-    let body = ass ^. #textAccum-        block = Content.AssistantText (Content.TextContent body)-     in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}],-          ass-            & #textOpen .~ Nothing-            & #textAccum .~ Text.empty-            & #closed %~ IntMap.insert i block-        )---- | Close every open tool call by emitting 'ToolCallEnd' (with the--- fully parsed 'ToolCall') in index order.-closeOpenTools :: Assembler -> ([AssistantMessageEvent], Assembler)-closeOpenTools ass =-  let openTools = IntMap.toAscList (ass ^. #toolArgs)-      (events, ass') = foldl' closeOne ([], ass) openTools-   in (events, ass')-  where-    closeOne (acc, a) (i, argsText) =-      let (tid, tn) = fromMaybe ("", "") (IntMap.lookup i (a ^. #toolMeta))-          decoded :: Value-          decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 argsText) of-            Right v -> v-            Left _ -> Aeson.Object mempty-          tc =-            Content.ToolCall-              { Content.id_ = tid,-                Content.name = tn,-                Content.arguments = decoded-              }-          block = Content.AssistantToolCall tc-       in ( acc <> [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}],-            a-              & #closed %~ IntMap.insert i block-              & #toolArgs %~ IntMap.delete i-              & #toolMeta %~ IntMap.delete i-              & #toolIdMap %~ (if Text.null tid then id else Map.delete tid)-              & #lastToolIdx .~ Nothing-          )--closeOpenStream ::-  UTCTime -> Maybe BaikaiError -> Assembler -> ([AssistantMessageEvent], Assembler)-closeOpenStream now mErr ass-  | ass ^. #finishSeen =-      -- Channel closed cleanly after finish_reason.-      let reason = ass ^. #stopReason-          terminalErr =-            (ass ^. #pendingError)-              <|> if reason == Stop.ErrorReason-                then Just (providerError "provider stopped the response with an error finish_reason")-                else Nothing-          msg = finalMessage ass now (fmap (^. #message) terminalErr) reason-          terminalEvent = case terminalErr of-            Just be -> EventError (errorTerminal Nothing reason msg be)-            Nothing -> EventDone (doneTerminal Nothing reason msg)-       in ([terminalEvent], ass)-  | otherwise =-      -- Channel closed without a finish_reason. Force-close any-      -- still-open blocks and emit EventError. When the worker stored a-      -- classified HTTP error ('Just be'), surface it structurally;-      -- otherwise report the unexpected end of stream.-      let (tagEvents, ass0) = flushTagScanPending ass-          (closeReasoning, ass1) = closeOpenReasoning ass0-          (closeText, ass2) = closeOpenText ass1-          (closeTools, ass3) = closeOpenTools ass2-          reason = Stop.ErrorReason-          errText = case mErr of-            Just be -> be ^. #message-            Nothing -> "openai stream ended without finish_reason"-          msg = finalMessage ass3 now (Just errText) reason-          errInfo = fromMaybe (providerError errText) mErr-          errEv = EventError (errorTerminal Nothing reason msg errInfo)-       in (tagEvents <> closeReasoning <> closeText <> closeTools <> [errEv], ass3)--finalMessage ::-  Assembler -> UTCTime -> Maybe Text -> Stop.StopReason -> Msg.Message-finalMessage ass now errMsg sr =-  let blocks = blocksInOrder ass-      m = ass ^. #model-      usageBare = ass ^. #usage-      computed = Pricing.computeCost m usageBare-      usage' = usageBare & #cost .~ computed-   in Msg.AssistantMessage-        Msg.AssistantPayload-          { Msg.content = blocks,-            Msg.usage = usage',-            Msg.stopReason = sr,-            Msg.errorMessage = errMsg <|> (ass ^. #finishNote),-            Msg.timestamp = Just now-          }--blocksInOrder :: Assembler -> Vector Content.AssistantContent-blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed))---- | Immediate error stream emitted when the request itself could not--- be built (e.g. message mapping failed).-immediateError :: BaikaiError -> IO [AssistantMessageEvent]-immediateError err = do-  now <- getCurrentTime-  let errText = err ^. #message-  let msg =-        Msg.AssistantMessage-          Msg.AssistantPayload-            { Msg.content = Vector.empty,-              Msg.usage = Usage.zeroUsage,-              Msg.stopReason = Stop.ErrorReason,-              Msg.errorMessage = Just errText,-              Msg.timestamp = Just now-            }-  pure-    [ EventStart StartPayload {partial = msg, responseId = Nothing},-      EventError (errorTerminal Nothing Stop.ErrorReason msg err)-    ]--mapFinishReason :: Text -> (Stop.StopReason, Maybe Text)-mapFinishReason r = case r of-  "stop" -> (Stop.Stop, Nothing)-  "length" -> (Stop.Length, Nothing)-  "tool_calls" -> (Stop.ToolUse, Nothing)-  "function_call" -> (Stop.ToolUse, Nothing)-  "content_filter" -> (Stop.ErrorReason, Nothing)-  _ -> (Stop.Stop, Just ("unrecognized finish_reason: " <> r))--trySync :: IO a -> IO (Either SomeException a)-trySync action = do-  r <- try action-  case r of-    Left e-      | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) ->-          throwIO e-      | otherwise -> pure (Left e)-    Right a -> pure (Right a)--exceptionToError :: SomeException -> BaikaiError-exceptionToError e = fromMaybe (classifyException e) (fromException e)+-- | Provider wrapping the @openai@ package's Chat Completions API.+--+-- Call 'register' once (typically from @main@) to install the+-- 'Baikai.Api.OpenAIChatCompletions' handler into the baikai+-- provider registry. After registration, any 'Baikai.Model.Model'+-- whose 'Baikai.Api.api' tag is 'OpenAIChatCompletions' dispatches+-- through this handler.+--+-- The handler resolves 'Baikai.Options.apiKey' when present, falling+-- back to the host-specific env var from+-- 'Baikai.Auth.defaultApiKeyEnvForBaseUrl'. Unknown hosts require an+-- explicit key source.+--+-- Streaming is the primary entry point. The handler exposes a+-- 'streamly' 'Stream' of 'AssistantMessageEvent' values bridged from a+-- local SSE transport. The synchronous @complete@ field is derived via+-- 'Baikai.Stream.streamingComplete', so callers that drain the stream+-- get the same fully-assembled 'Baikai.Response.Response'.+--+-- The machinery behind these three names — the transport driver seam,+-- the chunk decoders, the reasoning-tag scanner, the assembler and the+-- usage mapping — lives in "Baikai.Provider.OpenAI.Internal.Stream",+-- which carries no stability guarantees.+module Baikai.Provider.OpenAI.Api+  ( register,+    openaiChatProvider,+    openaiChatStream,+  )+where++import Baikai.Api (Api (..))+import Baikai.Context (Context)+import Baikai.Evidence qualified as Ev+import Baikai.Model (Model, openaiCompletionsCompatFor)+import Baikai.Options (Options)+import Baikai.Provider (ApiProvider, apiProvider)+import Baikai.Provider.OpenAI.Internal.Stream (liveSseDriver, openaiChatStreamWith)+import Baikai.Provider.OpenAI.Shape (describeThinkingShape)+import Baikai.Provider.Registry (registerApiProvider)+import Baikai.Stream.Event (AssistantMessageEvent)+import Control.Lens ((&), (.~), (^.))+import Data.Generics.Labels ()+import Streamly.Data.Stream (Stream)++-- | Install the OpenAI Chat Completions handler into the registry.+register :: IO ()+register = registerApiProvider openaiChatProvider++-- | First-class OpenAI Chat Completions provider value. Use with+-- 'Baikai.Provider.registerApiProviderWith' or+-- 'Baikai.Provider.newProviderRegistryFrom' for explicit registries.+openaiChatProvider :: ApiProvider+openaiChatProvider =+  apiProvider OpenAIChatCompletions openaiChatStream+    -- Runs the real shaping function and keeps only its description, so+    -- the gate's answer and the wire's behaviour cannot disagree.+    & #describeThinking+      .~ ( \m opts ->+             describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning) opts+         )+    & #strengthCeiling .~ Ev.declaredStrength OpenAIChatCompletions++-- | Streaming producer for the OpenAI Chat Completions API.+--+-- Forks one worker thread per call that drives the local+-- OpenAI-compatible SSE transport, pushing classified errors and decoded+-- chunk values onto a bounded+-- 'Baikai.Provider.Internal.StreamWorker.FrameQueue'. The consumer+-- translates each chunk into zero or more baikai+-- 'AssistantMessageEvent' values, beginning with exactly one+-- 'Baikai.Stream.Event.EventStart' and terminating with exactly one+-- 'Baikai.Stream.Event.EventDone' or 'Baikai.Stream.Event.EventError'.+--+-- The queue is bounded at+-- 'Baikai.Provider.Internal.StreamWorker.frameQueueCapacity' frames, so+-- a consumer that stops pulling stops the socket read after at most that+-- many further frames rather than letting the worker drain a whole+-- generation nobody will read.+--+-- The worker runs under a bracket, so the connection comes back+-- immediately when the stream ends normally or when an exception reaches+-- the draining thread (@Ctrl-C@, 'System.Timeout.timeout', @cancel@),+-- and at the next major garbage collection when a consumer simply+-- abandons the stream. "Baikai.Provider.Internal.StreamWorker" documents+-- why those three strengths differ and how a caller stops+-- deterministically.+openaiChatStream ::+  Model -> Context -> Options -> Stream IO AssistantMessageEvent+openaiChatStream = openaiChatStreamWith liveSseDriver
src/Baikai/Provider/OpenAI/Cli.hs view
@@ -3,7 +3,21 @@ -- -- Call 'register' once (typically from @main@) to install the -- 'Baikai.Api.OpenAICompletionsCli' handler with default config.--- 'registerWith' accepts a caller-supplied 'CodexCliConfig'.+-- Register @codexCliProvider cfg@ to supply a caller-supplied+-- 'CodexCliConfig'.+--+-- The 'Response' this provider returns carries whatever the tool+-- reported about its own run: the token counts from the event stream's+-- turn-completion event, and the thread identifier from its+-- thread-start event as the response identifier. A tool that reports+-- neither yields zeroes and 'Nothing', which is an accurate record of+-- its silence rather than a claim that the call consumed nothing.+--+-- Evidence from this transport is deliberately weaker than from the+-- Chat Completions API. A tool that exits zero has demonstrated that+-- it ran, not which model served the request, so a successful exit+-- never raises the recorded 'Baikai.Evidence.EvidenceStrength' — see+-- 'Baikai.Provider.Cli.Internal.subprocessStrength'. module Baikai.Provider.OpenAI.Cli   ( CodexCliConfig,     executable,@@ -13,12 +27,10 @@     ephemeral,     codexCliCommand,     codexCliPrompt,+    codexCliThinking,     defaultCodexCliConfig,     codexCliProvider,     register,-    registerWith,-    registerWithRegistry,-    registerWithRegistryAndConfig,   ) where @@ -26,25 +38,26 @@ import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context) import Baikai.Error (BaikaiError, processError, providerError)+import Baikai.Evidence qualified as Ev+import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..)) import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Provider.Cli.Internal qualified as Internal import Baikai.Provider.Registry   ( ApiProvider (..),-    ProviderRegistry,+    apiProviderWith,     registerApiProvider,-    registerApiProviderWith,   ) import Baikai.Response qualified as Resp import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream)-import Baikai.ThinkingLevel (renderThinkingLevel)-import Baikai.Usage (zeroUsage)+import Baikai.ThinkingLevel (ThinkingLevel, renderThinkingLevel)+import Baikai.Usage (Usage, zeroUsage) import Control.Concurrent (forkIO) import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)-import Control.Exception (SomeAsyncException (..), SomeException, displayException, fromException, throwIO, try)-import Control.Lens ((^.))+import Control.Exception (SomeException, displayException, fromException, try)+import Control.Lens ((&), (.~), (^.)) import Data.ByteString qualified as BS import Data.Generics.Labels () import Data.Maybe (fromMaybe)@@ -84,42 +97,23 @@ register = registerApiProvider (codexCliProvider defaultCodexCliConfig)  -- | First-class Codex CLI provider value for a caller-supplied config.-codexCliProvider :: CodexCliConfig -> ApiProvider-codexCliProvider cfg =-  ApiProvider-    { apiTag = OpenAICompletionsCli,-      stream = liftCompleteToStream (runCodexCli cfg),-      complete = runCodexCli cfg-    }---- | Install the Codex CLI handler with a caller-supplied config. ----- The Codex binary runs in batch mode. 'stream' wraps the batch+-- The Codex binary runs in batch mode. @stream@ wraps the batch -- output in a synthetic one-shot event stream -- (@EventStart, TextStart 0, TextDelta 0 body, TextEnd 0, EventDone@)--- emitted after the subprocess exits. 'complete' stays on the--- direct batch path so it preserves 'Response.latencyMs' rather than--- recomputing it from synthetic event timestamps. EP-3's Decision--- Log records the deviation from "complete = streamingComplete .--- stream".-registerWith :: CodexCliConfig -> IO ()-registerWith cfg = registerApiProvider (codexCliProvider cfg)-{-# DEPRECATED registerWith "use registerApiProvider (codexCliProvider cfg)" #-}---- | Install the Codex CLI handler with 'defaultCodexCliConfig' into an explicit--- registry.-registerWithRegistry :: ProviderRegistry -> IO ()-registerWithRegistry reg = registerWithRegistryAndConfig reg defaultCodexCliConfig-{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg (codexCliProvider defaultCodexCliConfig)" #-}---- | Install the Codex CLI handler with a caller-supplied config into an--- explicit registry.-registerWithRegistryAndConfig :: ProviderRegistry -> CodexCliConfig -> IO ()-registerWithRegistryAndConfig reg cfg =-  registerApiProviderWith-    reg-    (codexCliProvider cfg)-{-# DEPRECATED registerWithRegistryAndConfig "use registerApiProviderWith reg (codexCliProvider cfg)" #-}+-- emitted after the subprocess exits. @complete@ stays on the+-- direct batch path so it preserves 'Baikai.Response.latencyMs' rather+-- than recomputing it from synthetic event timestamps.+codexCliProvider :: CodexCliConfig -> ApiProvider+codexCliProvider cfg =+  apiProviderWith+    OpenAICompletionsCli+    (liftCompleteToStream (runCodexCli cfg))+    (runCodexCli cfg)+    -- The model plays no part: this transport's only reasoning+    -- control is a command-line flag derived from Options alone.+    & #describeThinking .~ (\_ opts -> codexCliThinking opts)+    & #strengthCeiling .~ Ev.declaredStrength OpenAICompletionsCli  modelArgs :: Model -> [String] modelArgs m = case Text.strip (m ^. #modelId) of@@ -165,8 +159,39 @@ effortArgs :: Options -> [String] effortArgs opts = case opts ^. #thinking of   Nothing -> []-  Just lvl -> ["-c", "model_reasoning_effort=" <> Text.unpack (renderThinkingLevel lvl)]+  Just lvl -> ["-c", "model_reasoning_effort=" <> Text.unpack (codexEffortValue lvl)] +-- | The word codex's @model_reasoning_effort@ override receives. Codex+-- accepts all six baikai levels verbatim, which makes this the identity+-- — and makes it the one transport in baikai that expresses every level+-- exactly.+codexEffortValue :: ThinkingLevel -> Text+codexEffortValue = renderThinkingLevel++-- | What the caller's reasoning-effort preference became on this+-- transport's command line.+--+-- The adjustment list is derived by comparing what 'effortArgs'+-- actually sends — through the same 'codexEffortValue' — with the+-- canonical level name, rather than being hardcoded empty. It is empty+-- today, but writing @[]@ by hand would keep claiming that after+-- someone changed the mapping, which is the class of silent divergence+-- this record exists to prevent.+codexCliThinking :: Options -> Ev.ThinkingTranslation+codexCliThinking opts = case opts ^. #thinking of+  Nothing -> Ev.noThinkingRequested+  Just lvl ->+    let wire = codexEffortValue lvl+     in Ev.ThinkingTranslation+          { requested = Just lvl,+            mode = Ev.ThinkingModeFlag,+            effortText = Just wire,+            budgetTokens = Nothing,+            wireField = Just "model_reasoning_effort",+            displayText = Nothing,+            adjustments = [Ev.EffortClamped lvl wire | wire /= renderThinkingLevel lvl]+          }+ runCodexCli :: CodexCliConfig -> Model -> Context -> Options -> IO Resp.Response runCodexCli cfg m ctx opts = do   let (exe, args) = codexCliCommand cfg m ctx opts@@ -178,22 +203,48 @@             P.cwd = cfg ^. #workingDir           }   start <- getCurrentTime-  result <- trySync (P.withCreateProcess procSpec (consume start m))+  -- The argument vector is the envelope: for a subprocess it is what+  -- crossed the boundary, and there is nothing else to describe the+  -- launch with. Built lazily and dropped unforced when the caller+  -- asked for no evidence.+  let mkEv mReport end st mErr = do+        prepared <-+          Build.minimalEvidence+            m+            opts+            Ev.TransportSubprocess+            (codexCliThinking opts)+            (Internal.argvEnvelope exe args)+            start+            end+            st+            mErr+        traverse (observeCodexCli exe mReport st) prepared+  result <- Internal.trySync (P.withCreateProcess procSpec (consume start mkEv m))   case result of     Right resp -> pure resp     Left ex -> do       end <- getCurrentTime-      pure (Resp.errorResponse m end (millisBetween start end) (exceptionToError ex))+      let err = exceptionToError ex+      ev <- mkEv Nothing end Ev.CallFailed (Just err)+      let resp = Resp.errorResponse m end (millisBetween start end) err+      pure resp {Resp.evidence = ev}  consume ::   UTCTime ->+  ( Maybe Internal.CodexRunReport ->+    UTCTime ->+    Ev.CallStatus ->+    Maybe BaikaiError ->+    IO (Maybe Ev.ModelCallEvidence)+  ) ->   Model ->   Maybe Handle ->   Maybe Handle ->   Maybe Handle ->   P.ProcessHandle ->   IO Resp.Response-consume start m _ mOut mErr ph = do+consume start mkEv m _ mOut mErr ph = do   case (mOut, mErr) of     (Nothing, _) -> errorNow (providerError "codex: stdout handle missing")     (_, Nothing) -> errorNow (providerError "codex: stderr handle missing")@@ -203,20 +254,31 @@         forkIO $ do           result <- try (BS.hGetContents hErr) :: IO (Either SomeException BS.ByteString)           putMVar errVar (either (const BS.empty) id result)-      body <- Internal.parseCodexJsonlStream (handleStream hOut)+      report <- Internal.parseCodexJsonlStream (handleStream hOut)       errBytes <- takeMVar errVar       exitCode <- P.waitForProcess ph       end <- getCurrentTime       case exitCode of-        ExitFailure n -> pure (Resp.errorResponse m end (millisBetween start end) (processError n (Internal.decodeUtf8Lenient errBytes)))-        ExitSuccess ->+        ExitFailure n -> do+          let err = processError n (Internal.decodeUtf8Lenient errBytes)+          -- The event stream was drained before the exit status was+          -- known, so a failed run may still have named its thread and+          -- its token counts. Those are genuine observations and are+          -- kept; only the response commitment is withheld, because no+          -- complete response exists to commit to.+          ev <- mkEv (Just report) end Ev.CallFailed (Just err)+          let resp = Resp.errorResponse m end (millisBetween start end) err+          pure resp {Resp.evidence = ev, Resp.responseId = report ^. #threadId}+        ExitSuccess -> do+          ev <- mkEv (Just report) end Ev.CallSucceeded Nothing           pure             Resp.Response               { Resp.message =                   AssistantPayload                     { content =-                        Vector.singleton (AssistantText (TextContent (Text.strip body))),-                      usage = zeroUsage,+                        Vector.singleton+                          (AssistantText (TextContent (Text.strip (report ^. #message)))),+                      usage = reportedUsage report,                       stopReason = Stop,                       errorMessage = Nothing,                       timestamp = Just end@@ -224,27 +286,82 @@                 Resp.model = m,                 Resp.api = OpenAICompletionsCli,                 Resp.provider = m ^. #provider,-                Resp.responseId = Nothing,+                Resp.responseId = report ^. #threadId,                 Resp.latencyMs = millisBetween start end,-                Resp.errorInfo = Nothing+                Resp.errorInfo = Nothing,+                Resp.evidence = ev               }   where     errorNow err = do       end <- getCurrentTime-      pure (Resp.errorResponse m end (millisBetween start end) err)+      ev <- mkEv Nothing end Ev.CallFailed (Just err)+      let resp = Resp.errorResponse m end (millisBetween start end) err+      pure resp {Resp.evidence = ev} +-- | Fill in what the tool reported and what baikai knows about the+-- process it launched.+--+-- Only ever reached on a call whose caller asked for evidence, which is+-- what makes the version probe affordable here: it spawns a whole extra+-- subprocess, and charging that to a caller who only wanted an answer+-- from a tool they were about to run anyway would be a visible cost on+-- the cheapest possible call. The event-stream parsing it reads is the+-- opposite case and happens unconditionally, because the provider had+-- already decoded every event to find the assistant text.+--+-- Nothing here consults the request. A field the tool did not report+-- stays 'Ev.Unobserved' — which at @codex-cli 0.146.0@ includes the+-- model, because no event in its stream names one.+observeCodexCli ::+  FilePath ->+  Maybe Internal.CodexRunReport ->+  Ev.CallStatus ->+  Ev.ModelCallEvidence ->+  IO Ev.ModelCallEvidence+observeCodexCli exe mReport st ev = do+  identity <- Internal.executableIdentity exe+  let thread = observedOf (mReport >>= (^. #threadId))+      reported = observedOf (mReport >>= (^. #reportedModel))+      used = mReport >>= (^. #usage)+  pure $+    ev+      -- A subprocess has no endpoint URL. Recording the model's base+      -- URL here would suggest an HTTP request that was never made, so+      -- the resolved executable path takes its place.+      & #endpoint . #endpoint .~ Just (fromMaybe (Text.pack exe) (identity ^. #resolvedPath))+      -- For this transport the tool is the implementation, so its own+      -- version is what determines behaviour — not this package's.+      & #endpoint . #implementationVersion .~ (identity ^. #version)+      & #responseId .~ thread+      & #observedModel .~ reported+      & #usage .~ observedOf used+      & #responseCommitment .~ commitment used+      & #strength .~ Internal.subprocessStrength thread reported+  where+    commitment used = case (st, mReport) of+      (Ev.CallSucceeded, Just r) ->+        Ev.Observed+          ( Ev.commitmentDigest+              ( Internal.cliResponseEnvelope+                  (Text.strip (r ^. #message))+                  (fromMaybe zeroUsage used)+              )+          )+      _ -> Ev.Unobserved++observedOf :: Maybe a -> Ev.Observed a+observedOf = maybe Ev.Unobserved Ev.Observed++-- | The tool's own token counts, or zeroes when it reported none.+--+-- 'Resp.Response' has nowhere to say "the tool stayed silent", so a+-- silent tool still yields 'zeroUsage' here. The evidence record does+-- have somewhere to say it, and says it: see 'observeCodexCli'.+reportedUsage :: Internal.CodexRunReport -> Usage+reportedUsage r = fromMaybe zeroUsage (r ^. #usage)+ millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double))--trySync :: IO a -> IO (Either SomeException a)-trySync action = do-  r <- try action-  case r of-    Left e-      | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) ->-          throwIO e-      | otherwise -> pure (Left e)-    Right a -> pure (Right a)  exceptionToError :: SomeException -> BaikaiError exceptionToError e = fromMaybe (providerError (Text.pack (displayException e))) (fromException e)
src/Baikai/Provider/OpenAI/Interactive.hs view
@@ -5,6 +5,15 @@ -- "Baikai.Provider.OpenAI.Cli": that module drives @codex exec@ as a -- batch completion provider, while this module starts the interactive -- terminal UI and returns only after the CLI exits.+--+-- A safety policy Codex cannot express is refused before launch rather+-- than dropped: both the pure command builder and the launcher return+-- 'Either' 'AgentRenderError', and a 'Left' means no process was+-- started. Two things are refused: a tool allow-list, which Codex has no+-- flag for at all, and an approval policy the installed @codex@+-- generation does not accept — 'CodexApprovalUntrusted' and+-- 'CodexApprovalOnFailure', which are older spellings current releases+-- reject. module Baikai.Provider.OpenAI.Interactive   ( CodexInteractiveConfig,     executable,@@ -16,8 +25,9 @@   ) where +import Baikai.Agent (AgentProvider (..), AgentRenderError (..)) import Baikai.Interactive-  ( CodexApprovalPolicy,+  ( CodexApprovalPolicy (..),     CodexSandboxMode,     InteractiveLaunchRequest,     InteractiveLaunchResult,@@ -50,19 +60,27 @@  -- | Render the executable and arguments for an interactive Codex -- launch. The final positional argument is the initial prompt.+--+-- Returns 'Left' when the request's safety policy is one Codex cannot+-- express, so a caller who asked to be constrained never receives a+-- command that is not. codexInteractiveCommand ::-  CodexInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String])-codexInteractiveCommand cfg req =-  ( cfg ^. #executable,-    modelArgs req-      <> effortArgs req-      <> workingDirArgs req-      <> extraDirArgs req-      <> safetyArgs req-      <> fmap Text.unpack (cfg ^. #extraArgs)-      <> fmap Text.unpack (req ^. #extraArgs)-      <> ["--", Text.unpack (codexInteractivePrompt req)]-  )+  CodexInteractiveConfig ->+  InteractiveLaunchRequest ->+  Either AgentRenderError (FilePath, [String])+codexInteractiveCommand cfg req = do+  safety <- safetyArgs req+  pure+    ( cfg ^. #executable,+      modelArgs req+        <> effortArgs req+        <> workingDirArgs req+        <> extraDirArgs req+        <> safety+        <> fmap Text.unpack (cfg ^. #extraArgs)+        <> fmap Text.unpack (req ^. #extraArgs)+        <> ["--", Text.unpack (codexInteractivePrompt req)]+    )  -- | Codex does not currently expose a top-level interactive -- system-prompt flag. Preserve Baikai's request shape by placing the@@ -73,19 +91,26 @@  -- | Launch Codex with inherited stdin, stdout, and stderr so the -- local CLI owns the interactive terminal experience.+--+-- A 'Left' result means no process was started: the requested safety+-- policy was refused before launch. A 'Right' carrying a non-zero+-- 'System.Exit.ExitCode' means the session ran and exited non-zero. launchCodexInteractive ::-  CodexInteractiveConfig -> InteractiveLaunchRequest -> IO InteractiveLaunchResult-launchCodexInteractive cfg req = do-  let (exe, args) = codexInteractiveCommand cfg req-      spec =-        (P.proc exe args)-          { P.std_in = P.Inherit,-            P.std_out = P.Inherit,-            P.std_err = P.Inherit,-            P.cwd = req ^. #workingDir-          }-  code <- P.withCreateProcess spec (\_ _ _ ph -> P.waitForProcess ph)-  pure (interactiveLaunchResult InteractiveCodex code)+  CodexInteractiveConfig ->+  InteractiveLaunchRequest ->+  IO (Either AgentRenderError InteractiveLaunchResult)+launchCodexInteractive cfg req = case codexInteractiveCommand cfg req of+  Left err -> pure (Left err)+  Right (exe, args) -> do+    let spec =+          (P.proc exe args)+            { P.std_in = P.Inherit,+              P.std_out = P.Inherit,+              P.std_err = P.Inherit,+              P.cwd = req ^. #workingDir+            }+    code <- P.withCreateProcess spec (\_ _ _ ph -> P.waitForProcess ph)+    pure (Right (interactiveLaunchResult InteractiveCodex code))  modelArgs :: InteractiveLaunchRequest -> [String] modelArgs req = case Text.strip <$> req ^. #modelId of@@ -111,11 +136,61 @@ extraDirArgs req =   concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs) -safetyArgs :: InteractiveLaunchRequest -> [String]+-- | 'DefaultSafety' means the caller declined to specify a policy, so+-- rendering nothing honors it rather than downgrading it.+safetyArgs :: InteractiveLaunchRequest -> Either AgentRenderError [String] safetyArgs req = case req ^. #safety of-  CodexSandbox sandbox approval -> codexSafetyArgs sandbox approval-  DefaultSafety -> []-  ClaudeAllowedTools _ -> []+  DefaultSafety -> Right []+  CodexSandbox sandbox approval+    | approvalAccepted approval -> Right (codexSafetyArgs sandbox approval)+    | otherwise ->+        Left+          ( SafetyNotExpressible+              AgentCodex+              ( "the installed codex CLI accepts only on-request and never for \+                \--ask-for-approval (codex 0.149.1); it rejects "+                  <> renderCodexApprovalPolicy approval+                  <> ", so the session was not started; use CodexApprovalOnRequest or \+                     \CodexApprovalNever"+              )+          )+  -- An empty allow-list restricts nothing, so there is nothing Codex+  -- fails to honor. Only a non-empty list is a restriction Codex+  -- cannot express. The asymmetry with the next case is deliberate.+  ClaudeAllowedTools [] -> Right []+  ClaudeAllowedTools tools ->+    Left+      ( SafetyNotExpressible+          AgentCodex+          ( "Codex has no tool allow-list flag, so it cannot honor the requested tools ("+              <> Text.intercalate ", " tools+              <> "); use CodexSandbox to restrict Codex, or DefaultSafety to accept its own \+                 \default"+          )+      )++-- | Whether the installed @codex@ generation accepts this approval+-- policy.+--+-- @codex --help@ at @codex-cli 0.149.1@ (verified 2026-08-27) lists+-- exactly two possible values for @--ask-for-approval@, @on-request@ and+-- @never@. @untrusted@ and @on-failure@ are older spellings the CLI+-- rejects with a usage error, which would surface as a @Right@ carrying+-- a non-zero exit code — a session that ran and failed — rather than as+-- the refusal this module promises.+--+-- Refused rather than quietly mapped onto @on-request@: silently+-- substituting a different approval policy would change the very thing+-- the caller asked for, which is the failure this module exists to+-- prevent. Which values the installed tool accepts is the vendor+-- adapter's knowledge, which is why the check lives here and not in the+-- core vocabulary.+approvalAccepted :: CodexApprovalPolicy -> Bool+approvalAccepted = \case+  CodexApprovalOnRequest -> True+  CodexApprovalNever -> True+  CodexApprovalUntrusted -> False+  CodexApprovalOnFailure -> False  codexSafetyArgs :: CodexSandboxMode -> CodexApprovalPolicy -> [String] codexSafetyArgs sandbox approval =
src/Baikai/Provider/OpenAI/Internal/ErrorClass.hs view
@@ -4,14 +4,18 @@ -- not part of baikai's PVP-stable application surface. Names, types, -- and semantics here may change in minor releases. ----- 'classifyException' handles an exception thrown by the--- @servant-client@ HTTP layer; 'classifyErrorText' handles an error--- that arrives mid-stream as a plain text message.+-- Two entry points cover the two ways a failure reaches the provider.+-- 'classifyException' handles any exception the worker catches from the+-- transport — @http-client@, TLS and socket failures, all delegated to+-- "Baikai.Provider.Transport.Classify" so both providers classify them+-- identically. 'classifyErrorFrame' handles an in-band error frame: a+-- decoded SSE payload on a @2xx@ stream that reports a failure instead+-- of a completion chunk, which is how OpenRouter, DeepSeek and Together+-- report an upstream failure they only learned about after committing+-- to a @200@. module Baikai.Provider.OpenAI.Internal.ErrorClass   ( classifyException,-    classifyErrorText,-    -- | Exposed for testing the HTTP-status mapping without a live call.-    responseToError,+    classifyErrorFrame,   ) where @@ -19,122 +23,137 @@   ( BaikaiError (..),     ErrorCategory (..),     bodyIndicatesOverflow,-    decodeError,-    httpError,-    invalidRequest,-    parseRetryAfterSeconds,+    classifyHttpStatusWithBody,     providerError,   )-import Control.Exception (SomeException, displayException, fromException)-import Data.ByteString (ByteString)-import Data.ByteString.Lazy qualified as LBS-import Data.CaseInsensitive qualified as CI-import Data.Foldable (toList)-import Data.Sequence (Seq)+import Baikai.Provider.Transport.Classify (classifyTransportException)+import Control.Applicative ((<|>))+import Control.Exception (SomeException, displayException)+import Data.Aeson (Value (..))+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap (KeyMap)+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Maybe (fromMaybe)+import Data.Scientific (Scientific, toBoundedInteger) 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 Network.HTTP.Client qualified as HTTP-import Network.HTTP.Types.Status (statusCode)-import Servant.Client (ClientError, ResponseF (..))-import Servant.Client qualified as Servant-import Text.Read (readMaybe) --- | Convert any exception caught from the OpenAI SDK into a categorised--- 'BaikaiError'. Recognises @servant-client@ 'ClientError' and raw--- @http-client@ 'HttpException'; anything else degrades to a generic--- provider error carrying the displayed exception text.+-- | Convert any exception caught while driving the OpenAI-compatible+-- transport into a categorised 'BaikaiError'.+--+-- Recognised transport failures — every @http-client@ 'HttpException'+-- constructor, a raw socket 'IOException' from the body read, and a raw+-- or wrapped TLS exception — are classified by the shared core rule.+-- Anything else is not a transport failure at all (a programming error+-- in a callback, say) and degrades to a generic provider error carrying+-- the displayed exception text, so it is never reported as retryable. classifyException :: SomeException -> BaikaiError-classifyException ex-  | Just clientErr <- fromException ex = fromClientError clientErr-  | Just httpEx <- fromException ex = fromHttpException httpEx-  | otherwise = providerError (Text.pack (displayException ex))+classifyException ex =+  fromMaybe+    (providerError (Text.pack (displayException ex)))+    (classifyTransportException ex) -fromClientError :: ClientError -> BaikaiError-fromClientError clientErr = case clientErr of-  Servant.FailureResponse _req resp -> responseToError resp-  Servant.DecodeFailure detail _ -> decodeError detail-  Servant.UnsupportedContentType _ _ -> decodeError "unsupported content type in OpenAI response"-  Servant.InvalidContentTypeHeader _ -> decodeError "invalid content-type header in OpenAI response"-  Servant.ConnectionError exc ->-    (providerError ("connection error: " <> Text.pack (displayException exc)))-      { category = TransientError-      }+-- | Classify an in-band error frame: a decoded SSE payload on a @2xx@+-- stream whose JSON reports a failure instead of a completion chunk.+--+-- Returns 'Nothing' for anything without an @error@ key, so an ordinary+-- chunk passes through untouched. Detection keys on @error@ alone and+-- not on the absence of @choices@, because OpenRouter sends both: its+-- mid-stream failure frame carries the error object /and/ a @choices@+-- array whose element has @finish_reason: "error"@.+--+-- Precedence inside the frame, most specific first: a numeric @code@ or+-- @status@ of 400 or more is the upstream HTTP status and is classified+-- as one (and recorded in 'httpStatus'); else a string @code@, then a+-- string @type@, is looked up in the vocabulary the compatible hosts+-- share; else the message text is phrase-sniffed; else 'OtherError'. The+-- message always becomes the error's 'message'.+classifyErrorFrame :: Value -> Maybe BaikaiError+classifyErrorFrame (Object o) = do+  errVal <- KeyMap.lookup "error" o+  inner <- case errVal of+    Object e -> Just e+    -- Some hosts send a bare string where the object is documented.+    String s -> Just (KeyMap.singleton "message" (String s))+    _ -> Nothing+  let msg =+        fromMaybe+          "provider sent an error frame without a message"+          (nonEmpty =<< stringField "message" inner)+      status = numberField "code" inner <|> numberField "status" inner+      byName =+        (stringField "code" inner >>= codeToCategory msg)+          <|> (stringField "type" inner >>= codeToCategory msg)+      cat = case status of+        Just n | n >= 400 -> classifyHttpStatusWithBody n Nothing msg+        _ -> fromMaybe (categoryFromMessage msg) byName+  Just (providerError msg) {category = cat, httpStatus = status}+classifyErrorFrame _ = Nothing -responseToError :: ResponseF LBS.ByteString -> BaikaiError-responseToError resp = httpError status retryAfter body-  where-    status = statusCode (responseStatusCode resp)-    body = decodeLenient (LBS.toStrict (responseBody resp))-    retryAfter = parseRetryAfter (responseHeaders resp)+nonEmpty :: Text -> Maybe Text+nonEmpty t = if Text.null (Text.strip t) then Nothing else Just t -parseRetryAfter :: Seq (CI.CI ByteString, ByteString) -> Maybe Int-parseRetryAfter headers = do-  raw <- lookup (CI.mk "Retry-After") (toList headers)-  parseRetryAfterSeconds (decodeLenient raw)+stringField :: Text -> KeyMap Value -> Maybe Text+stringField k o = case KeyMap.lookup (Key.fromText k) o of+  Just (String t) -> Just t+  _ -> Nothing -fromHttpException :: HTTP.HttpException -> BaikaiError-fromHttpException = \case-  HTTP.InvalidUrlException url reason ->-    invalidRequest (Text.pack (url <> ": " <> reason))-  HTTP.HttpExceptionRequest _ content -> fromHttpExceptionContent content+-- | An integral JSON number only: a @code@ of @"429"@ as a string is a+-- code name, not a status, and is handled by 'codeToCategory'.+numberField :: Text -> KeyMap Value -> Maybe Int+numberField k o = case KeyMap.lookup (Key.fromText k) o of+  Just (Number n) -> toBoundedInteger (n :: Scientific)+  _ -> Nothing -fromHttpExceptionContent :: HTTP.HttpExceptionContent -> BaikaiError-fromHttpExceptionContent = \case-  HTTP.StatusCodeException resp body ->-    httpError-      (statusCode (HTTP.responseStatus resp))-      (parseRetryAfterHttp (HTTP.responseHeaders resp))-      (decodeLenient body)-  HTTP.ConnectionFailure e -> transient (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"-  other -> providerError (Text.pack (show other))+-- | The @code@ and @type@ vocabulary the OpenAI-compatible hosts share.+-- The message is threaded through only for the overflow special case,+-- where the category depends on what the request actually hit.+codeToCategory :: Text -> Text -> Maybe ErrorCategory+codeToCategory msg raw = case Text.toLower (Text.strip raw) of+  "rate_limit_error" -> Just RateLimited+  "rate_limit_exceeded" -> Just RateLimited+  "tokens" -> Just RateLimited+  "requests" -> Just RateLimited+  "too_many_requests" -> Just RateLimited+  "authentication_error" -> Just AuthError+  "permission_error" -> Just AuthError+  "invalid_api_key" -> Just AuthError+  "insufficient_quota" -> Just AuthError+  "billing_not_active" -> Just AuthError+  "account_deactivated" -> Just AuthError+  "context_length_exceeded" -> Just ContextOverflow+  "request_too_large" -> Just ContextOverflow+  "server_error" -> Just TransientError+  "overloaded_error" -> Just TransientError+  "engine_overloaded" -> Just TransientError+  "service_unavailable" -> Just TransientError+  "timeout" -> Just TransientError+  "upstream_error" -> Just TransientError+  "provider_error" -> Just TransientError+  "invalid_request_error" -> Just (overflowOr InvalidRequest)+  "model_not_found" -> Just (overflowOr InvalidRequest)+  "invalid_value" -> Just (overflowOr InvalidRequest)+  "unsupported_value" -> Just (overflowOr InvalidRequest)+  "missing_required_parameter" -> Just (overflowOr InvalidRequest)+  _ -> Nothing   where-    transient t = (providerError ("connection error: " <> t)) {category = TransientError}--parseRetryAfterHttp :: [(CI.CI ByteString, ByteString)] -> Maybe Int-parseRetryAfterHttp headers = do-  raw <- lookup (CI.mk "Retry-After") headers-  parseRetryAfterSeconds (decodeLenient raw)--decodeLenient :: ByteString -> Text-decodeLenient = Text.decodeUtf8With Text.lenientDecode+    overflowOr fallback+      | bodyIndicatesOverflow msg = ContextOverflow+      | otherwise = fallback --- | Best-effort classification of an OpenAI streamed error message,--- which arrives as plain text without an HTTP status. Returns 'Nothing'--- for empty text (the caller keeps the raw message and 'errorInfo'--- stays absent).-classifyErrorText :: Text -> Maybe BaikaiError-classifyErrorText t-  | Just e <- classifySdkHttpText t = Just e-  | Text.null (Text.strip t) = Nothing-  | otherwise = Just (providerError t) {category = cat}+-- | The last resort: what the message text says, when the frame named no+-- code or type this classifier knows.+categoryFromMessage :: Text -> ErrorCategory+categoryFromMessage t+  | bodyIndicatesOverflow t = ContextOverflow+  | has "rate limit" || has "rate_limit" = RateLimited+  | has "overloaded" || has "server_error" || has "service unavailable" = TransientError+  | has "insufficient_quota"+      || has "invalid api key"+      || has "incorrect api key"+      || has "invalid_api_key" =+      AuthError+  | otherwise = OtherError   where     lower = Text.toLower t     has needle = needle `Text.isInfixOf` lower-    cat-      | bodyIndicatesOverflow t = ContextOverflow-      | has "rate limit" || has "rate_limit" = RateLimited-      | has "overloaded" || has "server_error" || has "service unavailable" = TransientError-      | has "insufficient_quota"-          || has "invalid api key"-          || has "incorrect api key"-          || has "invalid_api_key" =-          AuthError-      | otherwise = OtherError--classifySdkHttpText :: Text -> Maybe BaikaiError-classifySdkHttpText raw = do-  rest <- Text.stripPrefix "HTTP error " raw-  let (codeText, afterCode) = Text.breakOn " " rest-  code <- readMaybe (Text.unpack codeText)-  let body = case Text.breakOn ": " afterCode of-        (_, sepBody)-          | not (Text.null sepBody) -> Text.drop 2 sepBody-        _ -> ""-  pure (httpError code Nothing body)
src/Baikai/Provider/OpenAI/Internal/Request.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}  -- | Internal request mapping for the OpenAI Chat Completions provider. --@@ -18,14 +19,17 @@ import Baikai.Message qualified as Msg import Baikai.Model (Model, openaiCompletionsCompatFor) import Baikai.Options (Options (..))-import Baikai.ResponseFormat (ResponseFormat (..))+import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort)+import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) import Baikai.ThinkingLevel (ThinkingLevel (..)) import Baikai.Tool qualified as Tool import Control.Lens ((^.))+import Control.Monad (unless) import Data.Aeson qualified as Aeson import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Lazy qualified as BSL import Data.Generics.Labels ()+import Data.List (nub, sort) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as Text@@ -39,12 +43,38 @@ import OpenAI.V1.ToolCall qualified as ToolCall  -- ============================================================--- Request mapping (preserved from EP-2 with minor refactoring)+-- Request mapping: Context and Options onto the SDK's request record. -- ============================================================  mapRequest ::   Model -> Context -> Options -> Either Text Chat.CreateChatCompletion mapRequest m ctx opts = do+  let capability = openaiCompletionsCompatFor m+      forced = case opts ^. #toolChoice of+        Just Tool.ToolChoiceRequired -> True+        Just (Tool.ToolChoiceSpecific _) -> True+        _ -> False+  unless (capability.supportsToolCalls || (Vector.null (ctx ^. #tools) && not forced)) $+    Left "This model does not support tools on OpenAI Chat Completions; use OpenAI Responses for tool calling"+  case capability.supportedReasoningEfforts of+    Just levels+      | null levels || levels /= sort (nub levels) ->+          Left "supportedReasoningEfforts must be nonempty, unique and ordered"+    _ -> pure ()+  mapM_+    ( \msg -> case msg of+        Msg.AssistantMessage payload ->+          mapM_+            ( \block -> case block of+                Content.AssistantThinking th+                  | Just _ <- Content.replayState th ->+                      Left "This endpoint cannot replay provider-scoped reasoning state; use its originating API and model"+                _ -> pure ()+            )+            (payload ^. #content)+        _ -> pure ()+    )+    (ctx ^. #messages)   body <- traverse mapMessage (Vector.toList (ctx ^. #messages))   let compat = openaiCompletionsCompatFor m       prefix = case ctx ^. #systemPrompt of@@ -63,8 +93,14 @@           then Nothing           else Just (Vector.map (mkOpenAITool compat) (ctx ^. #tools))       toolChoiceField = fmap mkOpenAIToolChoice (opts ^. #toolChoice)+      -- The model's capability is consulted before the host's wire+      -- shape, and for the same reason Shape.injectThinkingShape does+      -- it in that order: a host may speak a good reasoning dialect+      -- while the model selected on it cannot reason at all.       reasoningEffortField =-        applyThinkingFormat compat (opts ^. #thinking)+        if m ^. #reasoning+          then applyThinkingFormat compat (opts ^. #thinking)+          else Nothing       responseFormatField =         fmap (mkOpenAIResponseFormat compat) (opts ^. #responseFormat)   pure@@ -72,10 +108,10 @@       { Chat.messages = Vector.fromList (prefix <> body),         Chat.model = OpenAIModels.Model (m ^. #modelId),         Chat.max_completion_tokens = maxTokensField,-        Chat.temperature = opts ^. #temperature,-        Chat.top_p = opts ^. #topP,-        Chat.stop = opts ^. #stopSequences,-        Chat.seed = opts ^. #seed,+        Chat.temperature = if compat.supportsSamplingParameters then opts ^. #temperature else Nothing,+        Chat.top_p = if compat.supportsSamplingParameters then opts ^. #topP else Nothing,+        Chat.stop = nonEmptyStops (opts ^. #stopSequences),+        Chat.seed = fmap fromIntegral (opts ^. #seed),         Chat.frequency_penalty = opts ^. #frequencyPenalty,         Chat.presence_penalty = opts ^. #presencePenalty,         Chat.tools = toolsField,@@ -84,20 +120,27 @@         Chat.response_format = responseFormatField       } +-- | The wire wants an absent field for "no stop sequences", and+-- 'Baikai.Options.stopSequences' says that with an empty list — the one+-- representation, where @Nothing@ and @Just []@ used to be two.+nonEmptyStops :: [Text] -> Maybe (Vector.Vector Text)+nonEmptyStops [] = Nothing+nonEmptyStops xs = Just (Vector.fromList xs)+ -- | Map a baikai 'ResponseFormat' onto the upstream OpenAI -- 'RF.ResponseFormat'. 'JsonObject' becomes plain-JSON mode; -- 'JsonSchema' becomes a named, optionally-strict schema. The -- schema 'Value' is forwarded verbatim. mkOpenAIResponseFormat :: OpenAICompletionsCompat -> ResponseFormat -> RF.ResponseFormat mkOpenAIResponseFormat _ JsonObject = RF.JSON_Object-mkOpenAIResponseFormat compat JsonSchema {name = n, schema = s, strict = st} =+mkOpenAIResponseFormat compat (JsonSchema f) =   RF.JSON_Schema     { RF.json_schema =         RF.JSONSchema           { RF.description = Nothing,-            RF.name = n,-            RF.schema = Just s,-            RF.strict = if supportsStrictMode compat then Just st else Nothing+            RF.name = f.name,+            RF.schema = Just f.schema,+            RF.strict = if supportsStrictMode compat then Just f.strict else Nothing           }     } @@ -108,17 +151,24 @@ -- the SDK does not support natively. -- -- The non-OpenAI thinking formats (DeepSeek, OpenRouter, Together,--- Z.ai, Qwen) require additional top-level JSON keys the upstream--- @openai@ Haskell SDK does not expose. They are silently dropped on--- this revision; see the EP-5 Decision Log for the rationale and--- pointers to the workaround when one is needed.+-- Z.ai, Qwen) need top-level JSON keys the upstream @openai@ Haskell+-- SDK does not expose, so this function returns 'Nothing' for them.+-- They are __not__ dropped: 'Baikai.Provider.OpenAI.Shape.injectThinkingShape'+-- injects each host's own keys into the serialized body afterwards,+-- and it is the function that records what the level became. Nothing+-- here needs to, which is why this one returns a bare 'Maybe'.+--+-- The caller gates this on 'Baikai.Model.reasoning': a level on a model+-- that does not advertise reasoning support is dropped and recorded by+-- 'Baikai.Provider.OpenAI.Shape.injectThinkingShape', which sees the+-- same flag. applyThinkingFormat ::   OpenAICompletionsCompat ->   Maybe ThinkingLevel ->   Maybe Chat.ReasoningEffort applyThinkingFormat _ Nothing = Nothing applyThinkingFormat compat (Just lvl) = case thinkingFormat compat of-  ThinkingFormatOpenAI -> Just (toReasoningEffort lvl)+  ThinkingFormatOpenAI -> Just (toReasoningEffort (resolveSupportedEffort compat.supportedReasoningEfforts lvl))   _ -> Nothing  toReasoningEffort :: ThinkingLevel -> Chat.ReasoningEffort@@ -140,9 +190,8 @@ -- The default ('defaultOpenAICompletionsCompat') leaves strict -- unset, which OpenAI treats as the default-permissive behaviour; -- callers that want @strict: true@ on every tool can flip the field--- on their compat record (a future enhancement; currently we pass--- 'Nothing' even when 'supportsStrictMode' is 'True', matching the--- pre-EP-5 behaviour).+-- on their compat record (a future enhancement; this function passes+-- 'Nothing' even when 'supportsStrictMode' is 'True'). mkOpenAITool :: OpenAICompletionsCompat -> Tool.Tool -> OpenAITool.Tool mkOpenAITool _compat t =   OpenAITool.Tool_Function
+ src/Baikai/Provider/OpenAI/Internal/Stream.hs view
@@ -0,0 +1,1306 @@+{-# LANGUAGE LambdaCase #-}++-- | __Internal module — no stability guarantees.__ This module is+-- exposed so baikai's own test suites and sibling packages can reach+-- it, but it is not part of the public API: its contents may change+-- in /any/ release without a PVP major bump. Do not import it from+-- application code.+--+-- The OpenAI Chat Completions streaming machinery: the SSE driver seam,+-- the raw chunk decoders, the reasoning-tag scanner, the event assembler+-- and the usage mapping. The public entry points built on it live in+-- "Baikai.Provider.OpenAI.Api".+--+-- Requests start as the SDK's typed+-- 'OpenAI.V1.Chat.Completions.CreateChatCompletion' value, then+-- 'Baikai.Provider.OpenAI.Shape.streamRequestBody' rewrites the raw JSON+-- body for OpenAI-compatible host quirks before+-- 'Baikai.Provider.OpenAI.Sse.openaiSseStreamValueWithHeaders' sends it+-- with cached transport settings and caller headers. Streaming responses+-- are parsed from raw 'Aeson.Value' chunks so partial tool-call deltas+-- may omit fields such as @id@ and @function.name@.+module Baikai.Provider.OpenAI.Internal.Stream+  ( openaiChatStreamWith,+    SseDriver,+    liveSseDriver,+    RawChunk (..),+    RawToolDelta (..),+    parseChunk,+    parseFrame,+    TagScanState (..),+    emptyTagScanState,+    scanThinkTags,+    Assembler (..),+    emptyAssembler,+    translate,+    closeOpenStream,++    -- * Usage mapping+    RawUsage (..),+    parseUsage,+    rawUsageToUsage,+  )+where++import Baikai.Compat (OpenAICompletionsCompat (requiresThinkingAsText))+import Baikai.Content qualified as Content+import Baikai.Context (Context (..))+import Baikai.Cost.Pricing qualified as Pricing+import Baikai.Error (BaikaiError, contentFiltered, invalidRequest, providerError)+import Baikai.Evidence qualified as Ev+import Baikai.Evidence.Build qualified as Build+import Baikai.Message qualified as Msg+import Baikai.Model (Model, openaiCompletionsCompatFor)+import Baikai.Options (Options (..))+import Baikai.Provider.Internal.StreamWorker+  ( FrameQueue,+    newFrameQueue,+    pullFrame,+    pushFrame,+    withFrameWorker,+  )+import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyErrorFrame, classifyException)+import Baikai.Provider.OpenAI.Internal.Request (mapRequest)+import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing+import Baikai.Provider.OpenAI.Shape (describeThinkingShape, streamRequestBody)+import Baikai.Provider.OpenAI.Sse (ResponseMetadata, capturedHeaderNames, openaiSseStreamValueWithHeaders)+import Baikai.Provider.OpenAI.Transport qualified as Transport+import Baikai.StopReason qualified as Stop+import Baikai.Stream.Event+  ( AssistantMessageEvent (..),+    BlockEndPayload (..),+    DeltaPayload (..),+    IndexPayload (..),+    StartPayload (..),+    ThinkingEndPayload (..),+    ToolCallEndPayload (..),+    doneTerminal,+    errorTerminal,+  )+import Baikai.Url qualified as Url+import Baikai.Usage qualified as Usage+import Control.Applicative ((<|>))+import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try)+import Control.Lens ((%~), (&), (.~), (^.))+import Data.Aeson (Value (..), (.:?))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as AesonKey+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types qualified as Aeson+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.IntMap.Strict (IntMap)+import Data.IntMap.Strict qualified as IntMap+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import Data.Version (showVersion)+import GHC.Generics (Generic)+import Network.HTTP.Types.Header (RequestHeaders)+import Paths_baikai_openai qualified as Paths+import Servant.Client qualified as Client+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++-- | How a call physically reaches the host.+--+-- The arguments are exactly those of+-- 'Baikai.Provider.OpenAI.Sse.openaiSseStreamValueWithHeaders', which is+-- what 'liveSseDriver' is. A test passes a driver that replays a+-- recorded response through the same+-- 'Baikai.Provider.OpenAI.Sse.sseFromResponse' the live one uses, so the+-- request shaping, header allow-list, status classification, and chunk+-- decoding under test are all the real implementations and only the+-- socket is missing.+--+-- The request body arrives as an argument rather than inside a per-call+-- record, so a test driver can capture exactly what went out without+-- this module exporting the record that also holds the resolved API key.+type SseDriver =+  Client.ClientEnv ->+  RequestHeaders ->+  Aeson.Value ->+  (ResponseMetadata -> IO ()) ->+  (Either BaikaiError Aeson.Value -> IO ()) ->+  IO ()++-- | The production driver: a real HTTPS request through the cached+-- transport settings.+liveSseDriver :: SseDriver+liveSseDriver = openaiSseStreamValueWithHeaders++-- | 'Baikai.Provider.OpenAI.Api.openaiChatStream' over an explicit+-- transport driver.+openaiChatStreamWith ::+  SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent+openaiChatStreamWith driver m ctx opts =+  Stream.concatEffect $ do+    setupResult <- trySync (prepareCall m ctx opts)+    let setup = either (Left . exceptionToError) id setupResult+    case setup of+      Left err -> Stream.fromList <$> immediateError m opts err+      Right call -> do+        q <- newFrameQueue :: IO (FrameQueue (Either BaikaiError RawChunk))+        tref <- newIORef False+        mref <- newIORef Nothing+        startTime <- getCurrentTime+        -- The request body is the envelope the two digests commit to:+        -- it is exactly the JSON this call is about to put on the wire.+        -- Credentials are not in it -- they travel in the headers built+        -- separately by 'Transport.requestHeaders'.+        mkEvidence <-+          Build.prepareEvidenceAt+            (call ^. #baseUrl)+            m+            opts+            Ev.TransportHttpApi+            (call ^. #thinking)+            (call ^. #requestBody)+            startTime+        let initialState =+              ProducerState+                { chan = q,+                  pending = [EventStart StartPayload {partial = skeletonStart m startTime, responseId = Nothing}],+                  assembler = emptyAssembler m startTime,+                  finished = False,+                  terminalRef = tref,+                  metadataRef = mref,+                  evidence = mkEvidence+                }+        pure (withFrameWorker q (worker driver call mref q) (Stream.unfoldrM step initialState))++skeletonStart :: Model -> UTCTime -> Msg.Message+skeletonStart _m start =+  Msg.AssistantMessage+    Msg.AssistantPayload+      { Msg.content = Vector.empty,+        Msg.usage = Usage.zeroUsage,+        Msg.stopReason = Stop.Stop,+        Msg.errorMessage = Nothing,+        Msg.timestamp = Just start+      }++-- | Per-call prepared values.+data OpenAICall = OpenAICall+  { clientEnv :: !Client.ClientEnv,+    requestHeaders :: !RequestHeaders,+    timeoutMs :: !(Maybe Int),+    requestBody :: !Aeson.Value,+    -- | The base URL this call actually resolved to, which is the+    -- vendor default when the model carries none. Carried so the+    -- evidence endpoint names the host the call went to; the model's+    -- own field can be @""@ for a call with a perfectly definite+    -- destination.+    baseUrl :: !Text,+    -- | What the caller's reasoning-effort preference became on this+    -- request, as 'streamRequestBody' described it. Carried from here+    -- rather than recomputed at the terminal: only the shaping step+    -- knows which of the seven host wire shapes was used.+    thinking :: !Ev.ThinkingTranslation+  }+  deriving stock (Generic)++-- | The host this call goes to: the model's base URL, or OpenAI's when+-- it carries none.+resolvedBaseUrl :: Model -> Text+resolvedBaseUrl m = case m ^. #baseUrl of+  "" -> "https://api.openai.com"+  u -> u++prepareCall :: Model -> Context -> Options -> IO (Either BaikaiError OpenAICall)+prepareCall m ctx opts = case mapRequest m ctx opts of+  Left e -> pure (Left (invalidRequest e))+  Right req -> do+    let url = resolvedBaseUrl 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 message names the problem and what to write+    -- instead; it renders the URL without its userinfo or query, so an+    -- error reaching a log cannot carry a key someone put in either.+    case Url.baseUrlProblem url of+      Just problem ->+        pure (Left (invalidRequest ("Model.baseUrl is not usable: " <> problem)))+      Nothing -> do+        key <- Transport.resolveKey url opts+        env <- Transport.getClientEnvCached url+        let compat = openaiCompletionsCompatFor m+            (body, translation) = streamRequestBody compat (m ^. #reasoning) opts req+            headers = Transport.requestHeaders key m opts+        pure+          ( Right+              OpenAICall+                { clientEnv = env,+                  requestHeaders = headers,+                  timeoutMs = opts ^. #timeoutMs,+                  requestBody = body,+                  baseUrl = url,+                  thinking = translation+                }+          )++-- | A loose summary of one streamed chunk. The raw 'Aeson.Value' is+-- pre-parsed into the fields we care about; unknown fields are+-- ignored. Missing fields are 'Nothing' (we tolerate partial+-- tool-call deltas).+data RawChunk = RawChunk+  { contentDelta :: !(Maybe Text),+    reasoningDelta :: !(Maybe Text),+    finishReason :: !(Maybe Text),+    toolDeltas :: ![RawToolDelta],+    usage :: !(Maybe RawUsage),+    -- | The model the host says produced this chunk, from the chunk's+    -- top-level @model@ field. 'Nothing' means the host did not report+    -- one — never that it reported the configured model.+    model :: !(Maybe Text),+    -- | The host's identifier for this response, from the chunk's+    -- top-level @id@ field.+    serviceTier :: !(Maybe Text),+    responseId :: !(Maybe Text)+  }+  deriving stock (Show, Generic)++data RawToolDelta = RawToolDelta+  { index :: !(Maybe Int),+    id_ :: !(Maybe Text),+    name :: !(Maybe Text),+    args :: !(Maybe Text)+  }+  deriving stock (Show, Generic)++newtype RawUsage = RawUsage Aeson.Object+  deriving stock (Show, Generic)++-- | Worker body: drive the transport, forwarding decoded chunks onto the+-- frame queue. Any synchronous exception is converted into a classified+-- error frame so the consumer side can translate it through the normal+-- path.+--+-- Nothing here signals end-of-frames: that is the queue's closed flag,+-- set by 'Baikai.Provider.Internal.StreamWorker.forkFrameWorker''s+-- @finally@ however this body ends. A sentinel push would block on a+-- full queue, which is exactly the state a stopped consumer leaves+-- behind.+worker ::+  SseDriver ->+  OpenAICall ->+  IORef (Maybe ResponseMetadata) ->+  FrameQueue (Either BaikaiError RawChunk) ->+  IO ()+worker driver call metaRef q = do+  r <-+    trySync+      $ Transport.runWithTimeout (call ^. #timeoutMs)+      $ driver+        (call ^. #clientEnv)+        (call ^. #requestHeaders)+        (call ^. #requestBody)+        (writeIORef metaRef . Just)+      $ \case+        Left be -> pushFrame q (Left be)+        Right val -> case parseFrame val of+          Left err -> pushFrame q (Left (providerError (Text.pack err)))+          Right frame -> pushFrame q frame+  case r of+    Right Nothing -> pure ()+    Right (Just be) -> pushFrame q (Left be)+    Left e -> pushFrame q (Left (exceptionToError e))++-- | Sort one decoded SSE frame into what it is: a classified in-band+-- error, or a completion chunk.+--+-- Compatible hosts report an upstream failure on a @2xx@ stream as a+-- frame carrying an @error@ object, with or without a @choices@ array+-- beside it. Such a frame ends the call with the failure's own+-- classification and message instead of being parsed as an empty chunk,+-- dropped, and reported at stream end as+-- @openai stream ended without finish_reason@.+--+-- The classified error travels back through the same+-- @Either BaikaiError RawChunk@ channel element a non-2xx uses, so the+-- assembler's 'Left' path — including its block closing — applies+-- unchanged.+parseFrame :: Value -> Either String (Either BaikaiError RawChunk)+parseFrame v = case classifyErrorFrame v of+  Just be -> Right (Left be)+  Nothing -> Right <$> parseChunk v++-- | Aeson parser tolerant of partial tool-call fields.+parseChunk :: Value -> Either String RawChunk+parseChunk = Aeson.parseEither $ Aeson.withObject "ChatCompletionChunk" $ \o -> do+  choices <- o .:? "choices"+  let firstChoice :: Maybe Aeson.Object+      firstChoice = case choices of+        Just (Aeson.Array a)+          | Vector.length a > 0 ->+              case Vector.head a of+                Aeson.Object obj -> Just obj+                _ -> Nothing+        _ -> Nothing+  (contentDelta, reasoningDelta, finishR, toolDeltas) <- case firstChoice of+    Nothing -> pure (Nothing, Nothing, Nothing, [])+    Just ch -> do+      finish <- ch .:? "finish_reason"+      delta <- ch .:? "delta"+      case delta of+        Nothing -> parseMessageObject ch finish+        Just (Aeson.Object dObj) -> do+          cd <- dObj .:? "content"+          let rd = reasoningText dObj+          tc <- dObj .:? "tool_calls"+          let tds = parseToolCallDeltas tc+          pure (cd, rd, finish, tds)+        _ -> parseMessageObject ch finish+  usageM <- o .:? "usage"+  let ru = case usageM of+        Just (Aeson.Object uObj) -> parseUsage uObj+        _ -> Nothing+  pure+    RawChunk+      { contentDelta = contentDelta,+        reasoningDelta = reasoningDelta,+        finishReason = finishR,+        toolDeltas = toolDeltas,+        usage = ru,+        -- Read as a lookup yielding 'Maybe' rather than a required+        -- field: chunks are decoded as raw JSON precisely because+        -- compatible hosts vary, and a host that omits either of these+        -- has reported nothing, which is not a decode failure.+        model = lookupText "model" o,+        serviceTier = lookupText "service_tier" o,+        responseId = lookupText "id" o+      }++parseMessageObject ::+  Aeson.Object ->+  Maybe Text ->+  Aeson.Parser (Maybe Text, Maybe Text, Maybe Text, [RawToolDelta])+parseMessageObject ch finish = do+  msg <- ch .:? "message"+  case msg of+    Just (Aeson.Object mObj) -> do+      cd <- mObj .:? "content"+      pure (cd, reasoningText mObj, finish, [])+    _ -> pure (Nothing, Nothing, finish, [])++reasoningText :: Aeson.Object -> Maybe Text+reasoningText obj =+  lookupText "reasoning_content" obj <|> lookupText "reasoning" obj++parseToolCallDeltas :: Maybe Value -> [RawToolDelta]+parseToolCallDeltas = \case+  Just (Aeson.Array v) -> Vector.toList (Vector.mapMaybe oneDelta v)+  _ -> []+  where+    oneDelta :: Value -> Maybe RawToolDelta+    oneDelta = \case+      Aeson.Object o ->+        let funcObj :: Maybe Aeson.Object+            funcObj = case lookupField "function" o of+              Just (Aeson.Object f) -> Just f+              _ -> Nothing+            getName = funcObj >>= lookupText "name"+            getArgs = funcObj >>= lookupText "arguments"+         in Just+              RawToolDelta+                { index = fromInt <$> lookupField "index" o,+                  id_ = lookupText "id" o,+                  name = getName,+                  args = getArgs+                }+      _ -> Nothing++parseUsage :: Aeson.Object -> Maybe RawUsage+parseUsage o = RawUsage o <$ Billing.readUsage Billing.ChatUsage (Aeson.Object o)++lookupField :: Text -> Aeson.Object -> Maybe Value+lookupField k = KeyMap.lookup (AesonKey.fromText k)++-- Pull a Text-valued field out of an Aeson object; tolerates+-- absent or non-Text values by returning 'Nothing'.+lookupText :: Text -> Aeson.Object -> Maybe Text+lookupText k o = case lookupField k o of+  Just (Aeson.String t) -> Just t+  _ -> Nothing++fromInt :: Value -> Int+fromInt = \case+  Aeson.Number n -> truncate n+  _ -> 0++-- ============================================================+-- Streamly state machine+-- ============================================================++data ProducerState = ProducerState+  { chan :: !(FrameQueue (Either BaikaiError RawChunk)),+    pending :: ![AssistantMessageEvent],+    assembler :: !Assembler,+    finished :: !Bool,+    terminalRef :: !(IORef Bool),+    -- | Where the worker leaves the response-level metadata it captured+    -- before the first chunk. Read on this side rather than pushed+    -- through 'chan' so the channel keeps carrying exactly one kind of+    -- thing; 'absorbMetadata' folds it into the assembler.+    metadataRef :: !(IORef (Maybe ResponseMetadata)),+    -- | Everything about this call's evidence that was knowable before+    -- the first byte came back, waiting on the terminal timestamp and+    -- outcome. 'Nothing' when the caller did not ask for evidence.+    -- 'sealTerminal' applies it.+    evidence ::+      !(Maybe (UTCTime -> Ev.CallStatus -> Maybe BaikaiError -> Ev.ModelCallEvidence))+  }+  deriving stock (Generic)++step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState))+step s+  | (e : rest) <- s ^. #pending = do+      sealed <- sealTerminal s e+      pure+        ( Just+            ( sealed,+              s+                & #pending .~ rest+                & #finished .~ (s ^. #finished || terminal sealed)+            )+        )+  | s ^. #finished = pure Nothing+  | otherwise = do+      mRaw <- pullFrame (s ^. #chan)+      -- After the read, because the worker writes the metadata before it+      -- writes anything onto the channel: taking it here means every+      -- path out of this branch — including the one where the channel+      -- closed without ever producing a chunk — sees it.+      ass0 <- absorbMetadata (s ^. #metadataRef) (s ^. #assembler)+      let s' = s & #assembler .~ ass0+      case mRaw of+        Nothing -> do+          alreadyTerminal <- readIORef (s' ^. #terminalRef)+          if alreadyTerminal+            then pure Nothing+            else do+              now <- getCurrentTime+              let (events, ass') = closeOpenStream now Nothing ass0+              case events of+                [] -> pure Nothing+                (e : rest) -> do+                  sealed <- sealTerminal (s' & #assembler .~ ass') e+                  pure+                    ( Just+                        ( sealed,+                          s'+                            & #pending .~ rest+                            & #assembler .~ ass'+                            & #finished .~ True+                        )+                    )+        Just raw -> do+          now <- getCurrentTime+          let (events, ass') = translate raw ass0 now+          case events of+            [] -> step (s' & #assembler .~ ass')+            (e : rest) -> do+              sealed <- sealTerminal (s' & #assembler .~ ass') e+              pure+                ( Just+                    ( sealed,+                      s'+                        & #pending .~ rest+                        & #assembler .~ ass'+                        & #finished .~ (s' ^. #finished || terminal sealed)+                    )+                )++-- | Fold whatever response-level metadata the worker has captured into+-- the assembler.+--+-- Idempotent: applying it again overwrites the same fields with the same+-- values, which is what lets 'step' call it on every pass rather than+-- tracking whether it has run.+absorbMetadata :: IORef (Maybe ResponseMetadata) -> Assembler -> IO Assembler+absorbMetadata ref ass = do+  meta <- readIORef ref+  pure $ case meta of+    Nothing -> ass+    Just md ->+      ass+        & #httpStatus .~ Just (md ^. #httpStatus)+        & #providerRequestId .~ correlationId md++-- | The host's correlation identifier for this response, or a gateway's+-- if the host's own is absent.+--+-- The preference order is+-- 'Baikai.Provider.OpenAI.Sse.capturedHeaderNames' itself, so the+-- allow-list and the preference cannot disagree. Nothing is invented: a+-- response carrying none of those headers leaves this 'Ev.Unobserved'.+correlationId :: ResponseMetadata -> Ev.Observed Text+correlationId md =+  case [v | n <- capturedHeaderNames, Just v <- [lookup (headerName n) (md ^. #headers)]] of+    (v : _) -> Ev.Observed v+    [] -> Ev.Unobserved+  where+    headerName = Text.decodeUtf8 . CI.foldedCase++-- | Mark the stream terminated and attach the call's evidence to the+-- terminal event.+--+-- Every event this producer yields goes through here, so the three+-- sites that can produce a terminal -- a translated upstream chunk, a+-- queued event drained from 'pending', and the channel-close path --+-- all seal identically. Doing it here rather than inside 'translate'+-- keeps that function pure; evidence construction needs 'IO' for the+-- call identifier.+--+-- A non-terminal event passes through unchanged, and so does a terminal+-- on a call whose caller asked for no evidence.+sealTerminal :: ProducerState -> AssistantMessageEvent -> IO AssistantMessageEvent+sealTerminal s ev+  | not (terminal ev) = pure ev+  | otherwise = do+      writeIORef (s ^. #terminalRef) True+      case s ^. #evidence of+        Nothing -> pure ev+        Just finish -> do+          now <- getCurrentTime+          let st = statusOf ev+              record = observeOpenAI st (s ^. #assembler) (finish now st (errorOf ev))+          pure (withEvidence record ev)+  where+    statusOf = \case+      EventDone {} -> Ev.CallSucceeded+      _ -> Ev.CallFailed+    -- The terminal payload already carries the normalized error, and+    -- 'errorTerminal' guarantees it is 'Just' on every 'EventError'.+    errorOf = \case+      EventError p -> p ^. #errorInfo+      _ -> Nothing+    -- Set through the generic-lens label rather than a record update:+    -- 'Baikai.Options.Options' also has an @evidence@ field, so under+    -- @DuplicateRecordFields@ a bare @p {evidence = ...}@ has no unique+    -- constructor to resolve to.+    withEvidence record = \case+      EventDone p -> EventDone (p & #evidence .~ Just record)+      EventError p -> EventError (p & #evidence .~ Just record)+      other -> other++-- | Replace the observed fields of a prepared evidence record with what+-- this call actually saw, and derive the strength from that.+--+-- Only ever reached on a call whose caller asked for evidence, which is+-- what makes it safe to compute the response commitment here: that+-- digest hashes the model's entire output and is the most expensive+-- thing this provider adds. The observations it reads were gathered+-- unconditionally, because each costs a lookup and each improves the+-- 'Baikai.Response.Response' for every caller.+--+-- Nothing here consults the request. An observation the host did not+-- make stays 'Ev.Unobserved'.+observeOpenAI ::+  Ev.CallStatus -> Assembler -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence+observeOpenAI st ass ev =+  ev+    & #endpoint . #implementationVersion .~ Just openaiPackageVersion+    & #observedModel .~ (ass ^. #observedModel)+    & #providerRequestId .~ (ass ^. #providerRequestId)+    & #responseId .~ maybe Ev.Unobserved Ev.Observed (ass ^. #responseId)+    & #usage .~ observedUsage ass+    & #responseCommitment .~ responseCommitment st ass+    & #strength+      .~ Ev.deriveStrength+        (ass ^. #observedModel)+        (ass ^. #providerRequestId)+        (maybe Ev.Unobserved Ev.Observed (ass ^. #responseId))++-- | The token accounting, but only if the host actually reported it.+--+-- The assembler initialises 'usage' to zeroes, so reporting it+-- unconditionally would tell a reader the host said this call consumed+-- nothing — which for a call that failed before any usage arrived is a+-- fabrication, and exactly what 'Ev.Observed' exists to stop.+observedUsage :: Assembler -> Ev.Observed Usage.Usage+observedUsage ass+  | ass ^. #usageReported = Ev.Observed (finalUsage ass)+  | otherwise = Ev.Unobserved++-- | A commitment to what came back, on a call that produced a response.+--+-- Left 'Ev.Unobserved' otherwise: a digest of an empty envelope is a+-- real-looking value standing for a response that never arrived.+responseCommitment :: Ev.CallStatus -> Assembler -> Ev.Observed Text+responseCommitment Ev.CallSucceeded ass =+  Ev.Observed (Ev.commitmentDigest (responseEnvelope ass))+responseCommitment _ _ = Ev.Unobserved++-- | What that digest commits to: the assembled content blocks in order,+-- the stop reason, and the reported usage.+--+-- Deliberately the assembled response rather than the raw SSE bytes. Two+-- identical responses split into different chunks must produce the same+-- digest, and the chunk boundaries are a transport detail no verifier+-- holding the response could reproduce. The key names match the+-- Anthropic adapter's envelope so a consumer reading both does not have+-- to learn two spellings.+responseEnvelope :: Assembler -> Value+responseEnvelope ass =+  Aeson.object+    [ "content" Aeson..= blocksInOrder ass,+      "stop_reason" Aeson..= (ass ^. #stopReason),+      -- Token counts only: 'Ev.usageEnvelope' omits the cost, which+      -- baikai computes from the caller's catalog rather than reads off+      -- the response, and which a verifier therefore cannot reproduce.+      "usage" Aeson..= Ev.usageEnvelope (finalUsage ass)+    ]++-- | The version of this package, for the evidence record's endpoint+-- identity. Read from the cabal-generated module rather than written as+-- a literal, which becomes a lie the first time a release misses it.+openaiPackageVersion :: Text+openaiPackageVersion = Text.pack (showVersion Paths.version)++terminal :: AssistantMessageEvent -> Bool+terminal = \case+  EventDone {} -> True+  EventError {} -> True+  _ -> False++-- ============================================================+-- Translation+-- ============================================================++data TagMode+  = TagVisible+  | TagReasoning+  deriving stock (Eq, Show, Generic)++-- | Incremental scanner state for hosts that stream reasoning in+-- assistant text using @<think>@ or @<thinking>@ tags.+data TagScanState = TagScanState+  { tagMode :: !TagMode,+    tagPending :: !Text+  }+  deriving stock (Eq, Show, Generic)++-- | The scanner's starting state: nothing buffered, nothing hidden.+emptyTagScanState :: TagScanState+emptyTagScanState =+  TagScanState+    { tagMode = TagVisible,+      tagPending = Text.empty+    }++-- | Split one text delta into reasoning fragments ('Left') and+-- visible text fragments ('Right'), preserving partial tag prefixes+-- across chunk boundaries.+scanThinkTags :: TagScanState -> Text -> (TagScanState, [Either Text Text])+scanThinkTags st input =+  let (mode', pending', parts) = go (tagMode st) (tagPending st <> input) []+   in (TagScanState {tagMode = mode', tagPending = pending'}, parts)+  where+    go mode txt acc =+      case findTag mode txt of+        Just (before, after, nextMode) ->+          go nextMode after (appendPart mode before acc)+        Nothing ->+          let (emitNow, pending) = splitPending mode txt+           in (mode, pending, appendPart mode emitNow acc)++    appendPart _ "" acc = acc+    appendPart TagVisible t acc = acc <> [Right t]+    appendPart TagReasoning t acc = acc <> [Left t]++findTag :: TagMode -> Text -> Maybe (Text, Text, TagMode)+findTag mode txt =+  case earliest markers of+    Nothing -> Nothing+    Just (idx, marker) ->+      Just+        ( Text.take idx txt,+          Text.drop (idx + Text.length marker) txt,+          nextMode+        )+  where+    (markers, nextMode) = case mode of+      TagVisible -> (openingTags, TagReasoning)+      TagReasoning -> (closingTags, TagVisible)+    earliest =+      foldr+        ( \marker best ->+            case Text.breakOn marker txt of+              (_, "") -> best+              (before, _) ->+                let candidate = (Text.length before, marker)+                 in case best of+                      Nothing -> Just candidate+                      Just (oldIdx, _) | Text.length before < oldIdx -> Just candidate+                      _ -> best+        )+        Nothing++splitPending :: TagMode -> Text -> (Text, Text)+splitPending mode txt =+  let suffix = longestTagPrefix (case mode of TagVisible -> openingTags; TagReasoning -> closingTags) txt+   in (Text.dropEnd (Text.length suffix) txt, suffix)++longestTagPrefix :: [Text] -> Text -> Text+longestTagPrefix markers txt =+  foldr longer Text.empty candidates+  where+    candidates =+      [ suffix+      | n <- [1 .. Text.length txt],+        let suffix = Text.takeEnd n txt,+        any (suffix `Text.isPrefixOf`) markers+      ]+    longer a b+      | Text.length a > Text.length b = a+      | otherwise = b++openingTags :: [Text]+openingTags = ["<think>", "<thinking>"]++closingTags :: [Text]+closingTags = ["</think>", "</thinking>"]++-- | Translation state across one streaming call.+data Assembler = Assembler+  { model :: !Model,+    start :: !UTCTime,+    -- | 'Just i' when a text block at baikai contentIndex @i@ is+    -- currently open; 'Nothing' when no text block is open.+    textOpen :: !(Maybe Int),+    textAccum :: !Text,+    textEverOpened :: !Bool,+    reasoningOpen :: !(Maybe Int),+    reasoningAccum :: !Text,+    tagScanState :: !TagScanState,+    -- | Maps OpenAI's per-call tool-call index to baikai's+    -- 'contentIndex'.+    toolIndexMap :: !(IntMap Int),+    toolIdMap :: !(Map Text Int),+    lastToolIdx :: !(Maybe Int),+    -- | baikai contentIndex → (id, name).+    toolMeta :: !(IntMap (Text, Text)),+    -- | baikai contentIndex → accumulated arguments JSON.+    toolArgs :: !(IntMap Text),+    closed :: !(IntMap Content.AssistantContent),+    -- | The next @contentIndex@ to hand out. Every block open takes it+    -- and bumps it, and no index is ever reused: text and thinking+    -- close each other before opening, so a stream that alternates+    -- between them produces 0, 1, 2, … in the order the host sent them,+    -- which is the order reassembly rebuilds the message in.+    nextContentIndex :: !Int,+    usage :: !Usage.Usage,+    stopReason :: !Stop.StopReason,+    -- | 'True' once a chunk carrying @finish_reason@ has been+    -- observed. The terminal 'EventDone' fires on channel close so+    -- the post-@finish_reason@ usage chunk (when @include_usage@ is+    -- enabled) has a chance to land.+    finishSeen :: !Bool,+    pendingError :: !(Maybe BaikaiError),+    finishNote :: !(Maybe Text),+    -- The five fields below are what this call /observed/, as distinct+    -- from what it requested. They live here because this record is the+    -- only state that survives from the first chunk to the last, and+    -- because an observation that never arrived must stay+    -- 'Ev.Unobserved' rather than falling back to the caller's+    -- configuration.++    -- | The host's own correlation identifier for this call, from the+    -- response headers.+    providerRequestId :: !(Ev.Observed Text),+    -- | The model identifier the host reported running, from the first+    -- chunk that carried one. Never the configured model.+    observedModel :: !(Ev.Observed Text),+    -- | The host's identifier for this response, from the first chunk+    -- that carried one.+    responseId :: !(Maybe Text),+    -- | The response's HTTP status. Recorded because the transport has+    -- it; 'Baikai.Evidence.ModelCallEvidence' has no field for it, and+    -- inventing one belongs to the vocabulary's plan, not to this+    -- module.+    httpStatus :: !(Maybe Int),+    -- | Whether the host actually reported token counts, as opposed to+    -- 'usage' still holding the zeroes it was initialised with. Without+    -- this a failed call would claim the host reported consuming+    -- nothing.+    serviceTiers :: !(Set.Set Text),+    usageSnapshot :: !(Maybe Value),+    usageReported :: !Bool+  }+  deriving stock (Generic)++emptyAssembler :: Model -> UTCTime -> Assembler+emptyAssembler m s =+  Assembler+    { model = m,+      start = s,+      textOpen = Nothing,+      textAccum = Text.empty,+      textEverOpened = False,+      reasoningOpen = Nothing,+      reasoningAccum = Text.empty,+      tagScanState = emptyTagScanState,+      toolIndexMap = IntMap.empty,+      toolIdMap = Map.empty,+      lastToolIdx = Nothing,+      toolMeta = IntMap.empty,+      toolArgs = IntMap.empty,+      closed = IntMap.empty,+      nextContentIndex = 0,+      usage = Usage.zeroUsage,+      stopReason = Stop.Stop,+      finishSeen = False,+      pendingError = Nothing,+      finishNote = Nothing,+      providerRequestId = Ev.Unobserved,+      observedModel = Ev.Unobserved,+      responseId = Nothing,+      httpStatus = Nothing,+      serviceTiers = Set.empty,+      usageSnapshot = Nothing,+      usageReported = False+    }++translate ::+  Either BaikaiError RawChunk ->+  Assembler ->+  UTCTime ->+  ([AssistantMessageEvent], Assembler)+translate chunk ass now+  -- A transport failure mid-stream goes through the same closer as a+  -- clean channel close, so text, reasoning and tool arguments that were+  -- open when it arrived are closed before the terminal. Building the+  -- terminal from 'blocksInOrder' alone -- which is what this branch used+  -- to do -- silently dropped them from both the events and the message.+  | Left be <- chunk = closeOpenStream now (Just be) ass+  | Right raw <- chunk =+      let -- 0. Record what the host said about itself.+          ass0 = observeChunk raw ass+          -- 1. Apply field-based reasoning delta.+          (reasoningEvents, ass1) = applyReasoningDelta (raw ^. #reasoningDelta) ass0+          -- 2. Apply content delta (open text block if needed).+          (textEvents, ass2) = applyContentDelta (raw ^. #contentDelta) ass1+          -- 3. Apply tool-call deltas.+          (toolEvents, ass3) = applyToolDeltas (raw ^. #toolDeltas) ass2+          -- 4. Apply usage chunk if present.+          ass4 = applyUsage (raw ^. #usage) ass3+          -- 5. If finish_reason is set, close any open text/tool+          --    blocks and stash the reason. EventDone is deferred+          --    to channel close so the post-finish_reason usage+          --    chunk has a chance to land.+          (closeEvents, ass5) = case raw ^. #finishReason of+            Just fr -> closeOnFinish fr ass4+            Nothing -> ([], ass4)+       in (reasoningEvents <> textEvents <> toolEvents <> closeEvents, ass5)++-- | Record what the host reported about itself on this chunk.+--+-- Both values come from the /first/ chunk that carries them and are+-- never overwritten. Compatible hosts repeat both fields on every chunk+-- and they are expected to agree; a host where they disagree is a+-- genuine discovery worth recording rather than something to resolve+-- silently by last-write-wins.+--+-- A missing field means the host reported nothing, so the observation+-- stays 'Ev.Unobserved'. The configured model is never substituted —+-- that is the specific mistake 'Ev.Observed' exists to prevent.+observeChunk :: RawChunk -> Assembler -> Assembler+observeChunk raw ass =+  ass+    & #serviceTiers %~ maybe id Set.insert (raw ^. #serviceTier)+    & #observedModel .~ firstObserved (ass ^. #observedModel) (raw ^. #model)+    & #responseId .~ ((ass ^. #responseId) <|> (raw ^. #responseId))++firstObserved :: Ev.Observed a -> Maybe a -> Ev.Observed a+firstObserved (Ev.Observed a) _ = Ev.Observed a+firstObserved Ev.Unobserved m = maybe Ev.Unobserved Ev.Observed m++applyReasoningDelta ::+  Maybe Text -> Assembler -> ([AssistantMessageEvent], Assembler)+applyReasoningDelta Nothing ass = ([], ass)+applyReasoningDelta (Just "") ass = ([], ass)+applyReasoningDelta (Just d) ass =+  case ass ^. #reasoningOpen of+    Just i ->+      ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = d}],+        ass & #reasoningAccum %~ (<> d)+      )+    -- Opening a thinking block closes an open text block first, so at+    -- most one of the two is open at a time and every _End precedes the+    -- next _Start. 'applyVisibleTextDelta' already closes reasoning+    -- symmetrically. Tool-call blocks are deliberately not closed here:+    -- hosts emit @content@ and @tool_calls@ in one chunk, and closing a+    -- tool call early would split a block the host meant as one.+    Nothing ->+      let (textEvents, ass0) = closeOpenText ass+          i = ass0 ^. #nextContentIndex+       in ( textEvents+              <> [ ThinkingStart IndexPayload {contentIndex = i},+                   ThinkingDelta DeltaPayload {contentIndex = i, delta = d}+                 ],+            ass0+              & #reasoningOpen .~ Just i+              & #reasoningAccum .~ d+              & #nextContentIndex .~ (i + 1)+          )++applyContentDelta ::+  Maybe Text -> Assembler -> ([AssistantMessageEvent], Assembler)+applyContentDelta Nothing ass = ([], ass)+applyContentDelta (Just "") ass = ([], ass)+applyContentDelta (Just d) ass =+  if requiresThinkingAsText (openaiCompletionsCompatFor (ass ^. #model))+    then+      let (tagState', parts) = scanThinkTags (ass ^. #tagScanState) d+          (events, ass') = foldl' applyTaggedPart ([], ass & #tagScanState .~ tagState') parts+       in (events, ass')+    else applyVisibleTextDelta d ass++applyTaggedPart ::+  ([AssistantMessageEvent], Assembler) ->+  Either Text Text ->+  ([AssistantMessageEvent], Assembler)+applyTaggedPart (acc, ass) = \case+  Left reasoning ->+    let (events, ass') = applyReasoningDelta (Just reasoning) ass+     in (acc <> events, ass')+  Right visible ->+    let (events, ass') = applyVisibleTextDelta visible ass+     in (acc <> events, ass')++applyVisibleTextDelta ::+  Text -> Assembler -> ([AssistantMessageEvent], Assembler)+applyVisibleTextDelta "" ass = ([], ass)+applyVisibleTextDelta d ass =+  case ass ^. #textOpen of+    Just i ->+      let (reasoningEvents, ass1) = closeOpenReasoning ass+       in ( reasoningEvents <> [TextDelta DeltaPayload {contentIndex = i, delta = d}],+            ass1 & #textAccum %~ (<> d)+          )+    Nothing ->+      let (reasoningEvents, ass1) = closeOpenReasoning ass+          i = ass1 ^. #nextContentIndex+       in ( reasoningEvents <> [TextStart IndexPayload {contentIndex = i}, TextDelta DeltaPayload {contentIndex = i, delta = d}],+            ass1+              & #textOpen .~ Just i+              & #textAccum .~ d+              & #textEverOpened .~ True+              & #nextContentIndex .~ (i + 1)+          )++applyToolDeltas ::+  [RawToolDelta] -> Assembler -> ([AssistantMessageEvent], Assembler)+applyToolDeltas [] ass = ([], ass)+applyToolDeltas deltas ass =+  let (reasoningEvents, ass0) = closeOpenReasoning ass+      (toolEvents, ass') = foldl' apply ([], ass0) deltas+   in (reasoningEvents <> toolEvents, ass')+  where+    apply (acc, a) d =+      let (events, a') = applyOneToolDelta d a+       in (acc <> events, a')++applyOneToolDelta ::+  RawToolDelta -> Assembler -> ([AssistantMessageEvent], Assembler)+applyOneToolDelta d ass =+  let mOpenaiIdx = d ^. #index+      mToolId = d ^. #id_+      byIndex = mOpenaiIdx >>= \idx -> IntMap.lookup idx (ass ^. #toolIndexMap)+      byId = mToolId >>= \tid -> Map.lookup tid (ass ^. #toolIdMap)+      byLast =+        case (mOpenaiIdx, mToolId) of+          (Nothing, Nothing) -> ass ^. #lastToolIdx+          _ -> Nothing+      (baikaiIdx, ass1, opened) = case byIndex <|> byId <|> byLast of+        Just i ->+          ( i,+            ass+              & #toolIdMap %~ maybe id (`Map.insert` i) mToolId+              & #lastToolIdx .~ Just i,+            False+          )+        Nothing ->+          let i = ass ^. #nextContentIndex+              ass' =+                ass+                  & #toolIndexMap %~ maybe id (`IntMap.insert` i) mOpenaiIdx+                  & #toolIdMap %~ maybe id (`Map.insert` i) mToolId+                  & #lastToolIdx .~ Just i+                  & #toolMeta %~ IntMap.insert i ("", "")+                  & #toolArgs %~ IntMap.insert i Text.empty+                  & #nextContentIndex .~ (i + 1)+           in (i, ass', True)+      -- Update metadata (id/name first delta only).+      ass2 =+        ass1+          & #toolMeta+            %~ IntMap.adjust+              ( \(existingId, existingName) ->+                  ( maybe existingId (\x -> if Text.null existingId then x else existingId) (d ^. #id_),+                    maybe existingName (\x -> if Text.null existingName then x else existingName) (d ^. #name)+                  )+              )+              baikaiIdx+      -- Append args if present.+      argsDelta = fromMaybe "" (d ^. #args)+      ass3 = ass2 & #toolArgs %~ IntMap.adjust (<> argsDelta) baikaiIdx+      events0 = if opened then [ToolCallStart IndexPayload {contentIndex = baikaiIdx}] else []+      events1 =+        if Text.null argsDelta+          then events0+          else events0 <> [ToolCallDelta DeltaPayload {contentIndex = baikaiIdx, delta = argsDelta}]+   in (events1, ass3)++-- | Shared Chat/Responses normalization preserves reported writes and marks+-- missing or inconsistent billing categories explicitly.+rawUsageToUsage :: RawUsage -> Usage.Usage+rawUsageToUsage (RawUsage o) = fromMaybe Billing.unreportedUsage (Billing.readUsage Billing.ChatUsage (Aeson.Object o))++applyUsage :: Maybe RawUsage -> Assembler -> Assembler+applyUsage Nothing ass = ass+applyUsage (Just (RawUsage raw)) ass =+  let snapshot = Billing.mergeUsage (ass ^. #usageSnapshot) (Just (Aeson.Object raw))+      normalized = fromMaybe Billing.unreportedUsage (snapshot >>= Billing.readUsage Billing.ChatUsage)+   in ass+        & #usage .~ normalized+        & #usageSnapshot .~ snapshot+        & #usageReported .~ True++-- | Close all open content blocks and stash the resolved stop+-- reason; defer 'EventDone' to channel close.+closeOnFinish ::+  Text -> Assembler -> ([AssistantMessageEvent], Assembler)+closeOnFinish finishReason ass =+  let (tagEvents, ass0) = flushTagScanPending ass+      (closeReasoning, ass1) = closeOpenReasoning ass0+      (closeText, ass2) = closeOpenText ass1+      (closeTools, ass3) = closeOpenTools ass2+      (reason, note) = mapFinishReason finishReason+      pending =+        if reason == Stop.ErrorReason+          then+            Just+              ( -- A filter is its own category: the content is the+                -- problem, so a caller can branch on it without matching+                -- on the message text.+                (if finishReason == "content_filter" then contentFiltered else providerError)+                  ("provider stopped the response: finish_reason=" <> finishReason)+              )+          else Nothing+      ass4 =+        ass3+          & #stopReason .~ reason+          & #finishSeen .~ True+          & #pendingError .~ pending+          & #finishNote .~ note+   in (tagEvents <> closeReasoning <> closeText <> closeTools, ass4)++flushTagScanPending :: Assembler -> ([AssistantMessageEvent], Assembler)+flushTagScanPending ass =+  let st = ass ^. #tagScanState+      pending = tagPending st+      ass0 = ass & #tagScanState .~ st {tagPending = Text.empty}+   in case (tagMode st, pending) of+        (_, "") -> ([], ass0)+        (TagVisible, t) -> applyVisibleTextDelta t ass0+        (TagReasoning, t) -> applyReasoningDelta (Just t) ass0++closeOpenReasoning :: Assembler -> ([AssistantMessageEvent], Assembler)+closeOpenReasoning ass = case ass ^. #reasoningOpen of+  Nothing -> ([], ass)+  Just i ->+    let body = ass ^. #reasoningAccum+        thinkingContent =+          Content.ThinkingContent+            { Content.thinking = body,+              Content.signature = Nothing,+              Content.redacted = False,+              Content.replayState = Nothing+            }+        block = Content.AssistantThinking thinkingContent+     in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}],+          ass+            & #reasoningOpen .~ Nothing+            & #reasoningAccum .~ Text.empty+            & #closed %~ IntMap.insert i block+        )++-- | Close the open text block, if any, by emitting a 'TextEnd' and+-- storing the assembled content in 'closed'.+closeOpenText :: Assembler -> ([AssistantMessageEvent], Assembler)+closeOpenText ass = case ass ^. #textOpen of+  Nothing -> ([], ass)+  Just i ->+    let body = ass ^. #textAccum+        block = Content.AssistantText (Content.TextContent body)+     in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}],+          ass+            & #textOpen .~ Nothing+            & #textAccum .~ Text.empty+            & #closed %~ IntMap.insert i block+        )++-- | Close every open tool call by emitting 'ToolCallEnd' (with the+-- fully parsed 'ToolCall') in index order.+closeOpenTools :: Assembler -> ([AssistantMessageEvent], Assembler)+closeOpenTools ass =+  let openTools = IntMap.toAscList (ass ^. #toolArgs)+      (events, ass') = foldl' closeOne ([], ass) openTools+   in (events, ass')+  where+    closeOne (acc, a) (i, argsText) =+      let (tid, tn) = fromMaybe ("", "") (IntMap.lookup i (a ^. #toolMeta))+          -- One rule, shared with the Claude assembler and with core's+          -- stream recovery: text that does not decode is kept verbatim+          -- as a String, marking the call cut off, rather than replaced+          -- by an empty object a tool loop would execute.+          decoded :: Value+          decoded = Content.toolArgumentsFromText argsText+          tc =+            Content.ToolCall+              { Content.id_ = tid,+                Content.name = tn,+                Content.arguments = decoded+              }+          block = Content.AssistantToolCall tc+       in ( acc <> [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}],+            a+              & #closed %~ IntMap.insert i block+              & #toolArgs %~ IntMap.delete i+              & #toolMeta %~ IntMap.delete i+              & #toolIdMap %~ (if Text.null tid then id else Map.delete tid)+              & #lastToolIdx .~ Nothing+          )++closeOpenStream ::+  UTCTime -> Maybe BaikaiError -> Assembler -> ([AssistantMessageEvent], Assembler)+closeOpenStream now mErr ass+  | ass ^. #finishSeen =+      -- The frames ended after finish_reason: either cleanly (the+      -- channel-close call site, which passes 'Nothing') or with a+      -- classified transport failure that arrived afterwards. The+      -- caller's error wins, because a stream that failed after+      -- finish_reason still failed.+      let reason = ass ^. #stopReason+          terminalErr =+            mErr+              <|> (ass ^. #pendingError)+              <|> if reason == Stop.ErrorReason+                then Just (providerError "provider stopped the response with an error finish_reason")+                else Nothing+          msg = finalMessage ass now (fmap (^. #message) terminalErr) reason+          terminalEvent = case terminalErr of+            Just be -> EventError (errorTerminal Nothing (ass ^. #responseId) reason msg be)+            Nothing -> EventDone (doneTerminal Nothing (ass ^. #responseId) reason msg)+       in ([terminalEvent], ass)+  | otherwise =+      -- Channel closed without a finish_reason. Force-close any+      -- still-open blocks and emit EventError. When the worker stored a+      -- classified HTTP error ('Just be'), surface it structurally;+      -- otherwise report the unexpected end of stream.+      let (tagEvents, ass0) = flushTagScanPending ass+          (closeReasoning, ass1) = closeOpenReasoning ass0+          (closeText, ass2) = closeOpenText ass1+          (closeTools, ass3) = closeOpenTools ass2+          reason = Stop.ErrorReason+          errText = case mErr of+            Just be -> be ^. #message+            Nothing -> "openai stream ended without finish_reason"+          msg = finalMessage ass3 now (Just errText) reason+          errInfo = fromMaybe (providerError errText) mErr+          errEv = EventError (errorTerminal Nothing (ass3 ^. #responseId) reason msg errInfo)+       in (tagEvents <> closeReasoning <> closeText <> closeTools <> [errEv], ass3)++-- | The accumulated token counts with this model's price applied.+--+-- Shared by the assistant message and the evidence record so the two+-- cannot report different numbers for the same call.+finalUsage :: Assembler -> Usage.Usage+finalUsage ass =+  let usageBare = Usage.observeBilling (map Usage.BillingServiceTier (Set.toList (ass ^. #serviceTiers))) (if ass ^. #usageReported then ass ^. #usage else Billing.unreportedUsage)+   in usageBare & #cost .~ Pricing.computeCostForService Nothing Nothing (ass ^. #model) usageBare++finalMessage ::+  Assembler -> UTCTime -> Maybe Text -> Stop.StopReason -> Msg.Message+finalMessage ass now errMsg sr =+  let blocks = blocksInOrder ass+   in Msg.AssistantMessage+        Msg.AssistantPayload+          { Msg.content = blocks,+            Msg.usage = finalUsage ass,+            Msg.stopReason = sr,+            Msg.errorMessage = errMsg <|> (ass ^. #finishNote),+            Msg.timestamp = Just now+          }++blocksInOrder :: Assembler -> Vector Content.AssistantContent+blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed))++-- | Immediate error stream emitted when the request itself could not+-- be built (e.g. message mapping failed).+-- Nothing was sent, so there is no wire body to digest and the evidence+-- commits to 'Build.dispatchEnvelope' instead -- see its documentation.+immediateError :: Model -> Options -> BaikaiError -> IO [AssistantMessageEvent]+immediateError m opts err = do+  now <- getCurrentTime+  let errText = err ^. #message+  let msg =+        Msg.AssistantMessage+          Msg.AssistantPayload+            { Msg.content = Vector.empty,+              Msg.usage = Usage.zeroUsage,+              Msg.stopReason = Stop.ErrorReason,+              Msg.errorMessage = Just errText,+              Msg.timestamp = Just now+            }+  ev <-+    Build.minimalEvidenceAt+      (resolvedBaseUrl m)+      m+      opts+      Ev.TransportHttpApi+      -- The adapter's own describer, not 'Ev.noThinkingRequested': the+      -- caller's level is a fact about the call even when the request+      -- was never built, and this is the expression the provider's own+      -- 'describeThinking' field uses.+      (describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning) opts)+      (Build.dispatchEnvelope m opts)+      now+      now+      Ev.CallFailed+      (Just err)+  pure+    [ EventStart StartPayload {partial = msg, responseId = Nothing},+      EventError (errorTerminal ev Nothing Stop.ErrorReason msg err)+    ]++mapFinishReason :: Text -> (Stop.StopReason, Maybe Text)+mapFinishReason r = case r of+  "stop" -> (Stop.Stop, Nothing)+  "length" -> (Stop.Length, Nothing)+  "tool_calls" -> (Stop.ToolUse, Nothing)+  "function_call" -> (Stop.ToolUse, Nothing)+  "content_filter" -> (Stop.ErrorReason, Nothing)+  _ -> (Stop.Stop, Just ("unrecognized finish_reason: " <> r))++trySync :: IO a -> IO (Either SomeException a)+trySync action = do+  r <- try action+  case r of+    Left e+      | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) ->+          throwIO e+      | otherwise -> pure (Left e)+    Right a -> pure (Right a)++exceptionToError :: SomeException -> BaikaiError+exceptionToError e = fromMaybe (classifyException e) (fromException e)
+ src/Baikai/Provider/OpenAI/Internal/Usage.hs view
@@ -0,0 +1,55 @@+-- | Shared Chat/Responses usage extraction. Input totals are inclusive of+-- cache reads and writes; missing categories stay explicit after normalization.+-- Wire semantics: https://developers.openai.com/api/docs/guides/prompt-caching+-- Chat's prompt_tokens_details.cache_write_tokens is documented at+-- https://developers.openai.com/api/reference/resources/chat/subresources/completions/methods/create+-- (verified 2026-09-07).+module Baikai.Provider.OpenAI.Internal.Usage (UsageEndpoint (..), readUsage, unreportedUsage, mergeUsage) where++import Baikai.Usage qualified as U+import Baikai.Usage.Normalize qualified as N+import Data.Aeson (Value (..))+import Data.Aeson.Key (Key)+import Data.Aeson.KeyMap qualified as KM+import Data.Maybe (isJust, isNothing)+import Numeric.Natural (Natural)++data UsageEndpoint = ChatUsage | ResponsesUsage++unreportedUsage :: U.Usage+unreportedUsage = N.normalizeUsage N.InclusiveInput (N.ReportedUsage Nothing Nothing Nothing Nothing Nothing)++readUsage :: UsageEndpoint -> Value -> Maybe U.Usage+readUsage endpoint value =+  let (inputKey, outputKey, inputDetails, outputDetails) = case endpoint of+        ChatUsage -> ("prompt_tokens", "completion_tokens", "prompt_tokens_details", "completion_tokens_details")+        ResponsesUsage -> ("input_tokens", "output_tokens", "input_tokens_details", "output_tokens_details")+      input = field inputKey value+      output = field outputKey value+      cached = field inputDetails value >>= field "cached_tokens"+      writes = field inputDetails value >>= field "cache_write_tokens"+      reasoning = field outputDetails value >>= field "reasoning_tokens"+      raw = [input, output, cached, writes, reasoning]+      count v = v >>= natural+      normalized = N.normalizeUsage N.InclusiveInput (N.ReportedUsage (count input) (count output) (count cached) (count writes) (count reasoning))+      malformed = any (\v -> isJust v && isNothing (count v)) raw+      mark facts = facts {U.inconsistent = U.inconsistent facts || malformed}+   in if any isJust raw then Just normalized {U.availability = mark <$> U.availability normalized} else Nothing+  where+    field :: Key -> Value -> Maybe Value+    field key (Object o) = case KM.lookup key o of Just Null -> Nothing; found -> found+    field _ _ = Nothing+    natural :: Value -> Maybe Natural+    natural (Number n) | n >= 0, fromInteger (floor n) == n = Just (fromInteger (floor n))+    natural _ = Nothing++-- | Usage events are cumulative snapshots, never increments. Omitted fields+-- preserve earlier observations; explicit zero replaces the previous value.+mergeUsage :: Maybe Value -> Maybe Value -> Maybe Value+mergeUsage old Nothing = old+mergeUsage Nothing new = new+mergeUsage (Just old) (Just new) = Just (merge new old)+  where+    merge Null previous = previous+    merge (Object newer) (Object previous) = Object (KM.unionWith merge newer previous)+    merge newer _ = newer
+ src/Baikai/Provider/OpenAI/Responses.hs view
@@ -0,0 +1,35 @@+-- | Native OpenAI Responses provider. Register explicitly alongside the+-- Chat Completions provider for a registry supporting both protocols.+module Baikai.Provider.OpenAI.Responses+  ( register,+    openaiResponsesProvider,+    openaiResponsesStream,+  )+where++import Baikai.Api (Api (OpenAIResponses))+import Baikai.Context (Context)+import Baikai.Evidence qualified as Ev+import Baikai.Model (Model)+import Baikai.Options (Options)+import Baikai.Provider (ApiProvider, apiProvider)+import Baikai.Provider.OpenAI.Responses.Request (describeThinking)+import Baikai.Provider.OpenAI.Responses.Stream (liveResponsesDriver, openaiResponsesStreamWith)+import Baikai.Provider.Registry (registerApiProvider)+import Baikai.Stream.Event (AssistantMessageEvent)+import Control.Lens ((&), (.~))+import Data.Generics.Labels ()+import Streamly.Data.Stream (Stream)++register :: IO ()+register = registerApiProvider openaiResponsesProvider++-- | Completion folds the same event stream, as for other API providers.+openaiResponsesProvider :: ApiProvider+openaiResponsesProvider =+  apiProvider OpenAIResponses openaiResponsesStream+    & #describeThinking .~ describeThinking+    & #strengthCeiling .~ Ev.declaredStrength OpenAIResponses++openaiResponsesStream :: Model -> Context -> Options -> Stream IO AssistantMessageEvent+openaiResponsesStream = openaiResponsesStreamWith liveResponsesDriver
+ src/Baikai/Provider/OpenAI/Responses/Assembler.hs view
@@ -0,0 +1,314 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | Internal Responses item assembly; no stability guarantee. The wire+-- schema is wider than the released SDK's streaming sum (see+-- mori://MercuryTechnologies/openai/packages/openai), so inspect JSON at+-- this boundary and preserve reasoning snapshots without re-encoding.+module Baikai.Provider.OpenAI.Responses.Assembler+  ( Assembler,+    emptyAssembler,+    advance,+    closePartial,+    assembledContent,+    observedResponse,+    terminalReason,+  )+where++import Baikai.Api (Api (OpenAIResponses))+import Baikai.Content qualified as C+import Baikai.Provider.OpenAI.Responses.Request (validateReplayItems)+import Baikai.StopReason (StopReason (..))+import Baikai.Stream.Event qualified as E+import Control.Monad (foldM, unless)+import Data.Aeson (Value (..))+import Data.Aeson.Key (Key)+import Data.Aeson.KeyMap qualified as KM+import Data.IntMap.Strict qualified as IM+import Data.IntSet qualified as IS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V++-- No Show: items can contain opaque encrypted continuation.+data Item = Item+  { kind :: !Text,+    identity :: !Text,+    callId :: !Text,+    functionName :: !Text,+    parts :: !(IM.IntMap Text),+    endedParts :: !IS.IntSet,+    complete :: !Bool,+    snapshot :: !(Maybe Value)+  }++data Assembler = Assembler+  { scopeModel :: !Text,+    items :: !(IM.IntMap Item),+    cursor :: !Int,+    opened :: !Bool,+    emitted :: !Text,+    assembledContent :: !(V.Vector C.AssistantContent),+    -- | Actual provider response object, including raw usage availability.+    observedResponse :: !(Maybe Value),+    terminalReason :: !(Maybe StopReason)+  }++emptyAssembler :: Text -> Assembler+emptyAssembler m = Assembler m IM.empty 0 False "" V.empty Nothing Nothing++-- | Consume one JSON event. Errors contain only schema diagnostics, never+-- raw response bodies. The caller closes partial blocks and emits the+-- terminal error on Left. Lifecycle terminal events are emitted by the+-- owning stream after attaching usage and evidence.+advance :: Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+advance frame a+  | Just _ <- a.terminalReason = Right (a, [])+  | otherwise = do+      typ <- str "type" frame+      case typ of+        "response.created" -> observe frame a+        "response.in_progress" -> observe frame a+        "response.queued" -> observe frame a+        "response.output_item.added" -> do+          n <- index "output_index" frame+          raw <- field "item" frame+          item <- fromSnapshot False raw+          unless (IM.notMember n a.items && n >= a.cursor) (Left "Responses repeated output item")+          unless (freshIdentity item (IM.elems a.items)) (Left "Responses duplicate item or function call ID")+          pump a {items = IM.insert n item a.items}+        "response.output_item.done" -> do+          n <- index "output_index" frame+          raw <- field "item" frame+          updated <- mergeSnapshot n True raw a+          pump updated+        "response.output_text.delta" -> delta "message" "content_index" frame a+        "response.refusal.delta" -> delta "message" "content_index" frame a+        "response.reasoning_summary_text.delta" -> delta "reasoning" "summary_index" frame a+        "response.function_call_arguments.delta" -> delta "function_call" "" frame a+        "response.output_text.done" -> donePart "message" "content_index" "text" frame a+        "response.refusal.done" -> donePart "message" "content_index" "refusal" frame a+        "response.reasoning_summary_text.done" -> donePart "reasoning" "summary_index" "text" frame a+        "response.function_call_arguments.done" -> donePart "function_call" "" "arguments" frame a+        "response.content_part.added" -> partEvent False "message" "content_index" frame a+        "response.content_part.done" -> partEvent True "message" "content_index" frame a+        "response.reasoning_summary_part.added" -> partEvent False "reasoning" "summary_index" frame a+        "response.reasoning_summary_part.done" -> partEvent True "reasoning" "summary_index" frame a+        "response.completed" -> terminal Stop frame a+        "response.incomplete" -> do+          response <- field "response" frame+          details <- field "incomplete_details" response+          reason <- str "reason" details+          unless (reason == "max_output_tokens") (Left "Responses terminated incomplete for a reason other than max_output_tokens")+          terminal Length frame a+        "response.failed" -> Left "Responses response.failed"+        "error" -> Left "Responses error event"+        -- Annotations and reasoning details do not change the public text+        -- or continuation. New output kinds are rejected at item creation.+        _ -> Right (a, [])++observe :: Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+observe f a = do+  r <- field "response" f+  pure (a {observedResponse = Just r}, [])++terminal :: StopReason -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+terminal reason f a = do+  r <- field "response" f+  output <- array "output" r+  mapM_+    ( \raw -> case raw of+        Object o | reason == Stop && KM.lookup "type" o == Just (String "reasoning") -> validateReplayItems (V.singleton raw)+        _ -> pure ()+    )+    output+  updated <- foldM (\s (n, raw) -> mergeSnapshot n True raw s) a (zip [0 ..] (V.toList output))+  unless (IM.size updated.items == V.length output) (Left "Responses terminal output omitted an existing item")+  (drained, events) <- pump updated {observedResponse = Just r}+  unless (drained.cursor == IM.size drained.items) (Left "Responses terminal output has a gap")+  let hasTool = any (\case C.AssistantToolCall _ -> True; _ -> False) drained.assembledContent+      stop = if reason == Stop && hasTool then ToolUse else reason+  pure (drained {terminalReason = Just stop}, events)++fromSnapshot :: Bool -> Value -> Either Text Item+fromSnapshot final raw = do+  k <- str "type" raw+  ident <- nonempty "id" raw+  (call, name, ps) <- case k of+    "message" -> do+      cs <- array "content" raw+      texts <- traverse partText (V.toList cs)+      pure ("", "", IM.fromList (zip [0 ..] texts))+    "reasoning" -> do+      cs <- array "summary" raw+      texts <- traverse partText (V.toList cs)+      pure ("", "", IM.fromList (zip [0 ..] texts))+    "function_call" -> do+      call <- nonempty "call_id" raw+      name <- nonempty "name" raw+      args <- str "arguments" raw+      pure (call, name, IM.singleton 0 args)+    _ -> Left "Responses unsupported output item type"+  pure (Item k ident call name ps (if final then IS.fromList (IM.keys ps) else IS.empty) final (if final then Just raw else Nothing))++freshIdentity :: Item -> [Item] -> Bool+freshIdentity new = all (\old -> old.identity /= new.identity && (new.kind /= "function_call" || old.kind /= "function_call" || old.callId /= new.callId))++mergeSnapshot :: Int -> Bool -> Value -> Assembler -> Either Text Assembler+mergeSnapshot n final raw a = do+  new <- fromSnapshot final raw+  case IM.lookup n a.items of+    Nothing -> do+      unless (n >= a.cursor && freshIdentity new (IM.elems a.items)) (Left "Responses duplicate item or function call ID")+      pure a {items = IM.insert n new a.items}+    Just old -> do+      unless (old.kind == new.kind && old.identity == new.identity && old.callId == new.callId && old.functionName == new.functionName) (Left "Responses item identity changed")+      unless (not old.complete || old.snapshot == Just raw) (Left "Responses completed item changed")+      mapM_ (\(p, t) -> unless (maybe False (T.isPrefixOf t) (IM.lookup p new.parts)) (Left "Responses final snapshot contradicts streamed content")) (IM.toList old.parts)+      pure a {items = IM.insert n new a.items}++partText :: Value -> Either Text Text+partText p = do+  k <- str "type" p+  case k of+    "output_text" -> str "text" p+    "summary_text" -> str "text" p+    "refusal" -> str "refusal" p+    _ -> Left "Responses unsupported output content part"++itemAt :: Text -> Value -> Assembler -> Either Text (Int, Item)+itemAt expected f a = do+  n <- index "output_index" f+  ident <- str "item_id" f+  item <- maybe (Left "Responses delta before output item") Right (IM.lookup n a.items)+  unless (item.kind == expected && item.identity == ident) (Left "Responses delta item identity mismatch")+  pure (n, item)++partIndex :: Key -> Value -> Either Text Int+partIndex "" _ = Right 0+partIndex key f = index key f++delta :: Text -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+delta k key f a = do+  (n, item) <- itemAt k f a+  p <- partIndex key f+  txt <- str "delta" f+  unless (not item.complete && not (IS.member p item.endedParts)) (Left "Responses delta after content done")+  let ps = IM.insert p (IM.findWithDefault "" p item.parts <> txt) item.parts+  pump a {items = IM.insert n item {parts = ps} a.items}++donePart :: Text -> Key -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+donePart k key txtKey f a = do+  txt <- str txtKey f+  setPart True k key txt f a++partEvent :: Bool -> Text -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+partEvent final k key f a = do+  p <- field "part" f+  txt <- partText p+  setPart final k key txt f a++setPart :: Bool -> Text -> Key -> Text -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+setPart final k key txt f a = do+  (n, item) <- itemAt k f a+  p <- partIndex key f+  let old = IM.findWithDefault "" p item.parts+  unless (old `T.isPrefixOf` txt && (not (item.complete || IS.member p item.endedParts) || old == txt)) (Left "Responses part snapshot contradicts streamed content")+  let updated = item {parts = IM.insert p txt item.parts, endedParts = if final then IS.insert p item.endedParts else item.endedParts}+  pump a {items = IM.insert n updated a.items}++-- Only the contiguous prefix is visible: a later parallel item or content+-- part cannot overtake the one still streaming. One Baikai block per item.+visible :: Item -> Text+visible item = go 0+  where+    go n = case IM.lookup n item.parts of+      Nothing -> ""+      Just txt -> txt <> if item.complete || IS.member n item.endedParts then go (n + 1) else ""++pump :: Assembler -> Either Text (Assembler, [E.AssistantMessageEvent])+pump a = case IM.lookup a.cursor a.items of+  Nothing -> Right (a, [])+  Just item -> do+    let txt = visible item+        n = V.length a.assembledContent+    unless (a.emitted `T.isPrefixOf` txt) (Left "Responses snapshot changed emitted content")+    let suffix = T.drop (T.length a.emitted) txt+        start = if a.opened then [] else [startEvent item.kind n]+        deltas = if T.null suffix then [] else [deltaEvent item.kind n suffix]+        openedState = a {opened = True, emitted = txt}+    if item.complete+      then do+        let content = itemContent a.scopeModel True item+            closed = openedState {cursor = a.cursor + 1, opened = False, emitted = "", assembledContent = V.snoc a.assembledContent content}+        (next, events) <- pump closed+        pure (next, start <> deltas <> [endEvent n content] <> events)+      else pure (openedState, start <> deltas)++-- | Close an interrupted stream, retaining every observed item. An item+-- without output_item.done keeps String arguments even when that prefix+-- happens to be parseable JSON; callers must never execute that prefix.+closePartial :: Assembler -> (Assembler, [E.AssistantMessageEvent])+closePartial a = foldl close (a, []) [(n, i) | (n, i) <- IM.toAscList a.items, n >= a.cursor]+  where+    close (s, events) (outputIndex, item) =+      let n = V.length s.assembledContent+          txt = T.concat (IM.elems item.parts)+          suffix = if s.emitted `T.isPrefixOf` txt then T.drop (T.length s.emitted) txt else ""+          content = itemContent s.scopeModel item.complete item+          starts = if s.opened then [] else [startEvent item.kind n]+          deltas = if T.null suffix then [] else [deltaEvent item.kind n suffix]+       in (s {cursor = outputIndex + 1, opened = False, emitted = "", assembledContent = V.snoc s.assembledContent content}, events <> starts <> deltas <> [endEvent n content])++itemContent :: Text -> Bool -> Item -> C.AssistantContent+itemContent m final item =+  let txt = T.concat (IM.elems item.parts)+   in case item.kind of+        "reasoning" -> C.AssistantThinking (C.ThinkingContent txt Nothing False (fmap (C.ThinkingReplay OpenAIResponses m . V.singleton) item.snapshot))+        "function_call" -> C.AssistantToolCall (C.ToolCall item.callId item.functionName (if final && completedStatus item.snapshot then C.toolArgumentsFromText txt else String txt))+        _ -> C.AssistantText (C.TextContent txt)++completedStatus :: Maybe Value -> Bool+completedStatus (Just (Object o)) = case KM.lookup "status" o of+  Nothing -> True -- output_item.done itself supplies completion.+  Just (String "completed") -> True+  _ -> False+completedStatus _ = False++startEvent :: Text -> Int -> E.AssistantMessageEvent+startEvent "reasoning" n = E.ThinkingStart (E.IndexPayload n)+startEvent "function_call" n = E.ToolCallStart (E.IndexPayload n)+startEvent _ n = E.TextStart (E.IndexPayload n)++deltaEvent :: Text -> Int -> Text -> E.AssistantMessageEvent+deltaEvent "reasoning" n txt = E.ThinkingDelta (E.DeltaPayload n txt)+deltaEvent "function_call" n txt = E.ToolCallDelta (E.DeltaPayload n txt)+deltaEvent _ n txt = E.TextDelta (E.DeltaPayload n txt)++endEvent :: Int -> C.AssistantContent -> E.AssistantMessageEvent+endEvent n (C.AssistantThinking c) = E.ThinkingEnd (E.ThinkingEndPayload n c)+endEvent n (C.AssistantToolCall c) = E.ToolCallEnd (E.ToolCallEndPayload n c)+endEvent n (C.AssistantText c) = E.TextEnd (E.BlockEndPayload n c.text)++field :: Key -> Value -> Either Text Value+field k (Object o) = maybe (Left "Responses missing required event field") Right (KM.lookup k o)+field _ _ = Left "Responses event field must be an object"++str :: Key -> Value -> Either Text Text+str k v = field k v >>= \case String t -> Right t; _ -> Left "Responses event field must be text"++nonempty :: Key -> Value -> Either Text Text+nonempty k v = do+  t <- str k v+  unless (not (T.null t)) (Left "Responses item identity must be nonempty")+  pure t++array :: Key -> Value -> Either Text (V.Vector Value)+array k v = field k v >>= \case Array xs -> Right xs; _ -> Left "Responses event field must be an array"++index :: Key -> Value -> Either Text Int+index k v =+  field k v >>= \case+    Number n | n >= 0, n <= fromIntegral (maxBound :: Int), fromInteger (floor n) == n -> Right (floor n)+    _ -> Left "Responses event index must be a nonnegative integer"
+ src/Baikai/Provider/OpenAI/Responses/Request.hs view
@@ -0,0 +1,228 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | Internal Responses request mapping; no stability guarantee.+-- The released SDK (mori://MercuryTechnologies/openai/packages/openai,+-- 2.5.4) supplies the ordinary request/tool types. Local JSON below covers+-- its missing assistant input role, json_object format, current+-- effort vocabulary, cache options, and lossless opaque replay items.+module Baikai.Provider.OpenAI.Responses.Request+  ( PreparedRequest (..),+    mapRequest,+    describeThinking,+    validateReplay,+    validateReplayItems,+  )+where++import Baikai.Api (Api (..), normaliseApi)+import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Compat (OpenAIResponsesCompat (..))+import Baikai.Content qualified as C+import Baikai.Context (Context (..))+import Baikai.Evidence qualified as E+import Baikai.Message qualified as M+import Baikai.Model (Model, api, maxOutputTokens, modelId, openaiResponsesCompatFor, reasoning)+import Baikai.Options (Options (..))+import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort)+import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..))+import Baikai.ThinkingLevel (renderThinkingLevel)+import Baikai.Tool qualified as T+import Control.Monad (unless)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Base64 qualified as Base64+import Data.ByteString.Lazy qualified as LBS+import Data.List (nub, sort)+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Data.Vector qualified as V+import GHC.Generics (Generic)+import OpenAI.V1.Models qualified as SDK+import OpenAI.V1.Responses qualified as R++-- | The exact wire body and the description derived while shaping it.+-- No Show instance: a prepared body can contain opaque continuation.+data PreparedRequest = PreparedRequest+  { requestBody :: !Value,+    translation :: !E.ThinkingTranslation+  }+  deriving stock (Eq, Generic)++mapRequest :: Model -> Context -> Options -> Either Text PreparedRequest+mapRequest m ctx opts = do+  unless (normaliseApi m.api == OpenAIResponses) (Left "Responses requires Model.api = OpenAIResponses")+  let compat = openaiResponsesCompatFor m+      unsupported = [name | (name, present) <- [("stopSequences", not (null opts.stopSequences)), ("seed", isJust opts.seed), ("frequencyPenalty", isJust opts.frequencyPenalty), ("presencePenalty", isJust opts.presencePenalty)], present]+  unless (null unsupported) (Left ("Responses cannot encode Options fields: " <> Text.intercalate ", " unsupported))+  case compat.supportedReasoningEfforts of+    Just xs | null xs || xs /= sort (nub xs) -> Left "supportedReasoningEfforts must be nonempty, unique and ordered"+    _ -> pure ()+  metadata <- traverse metadataText opts.metadata+  unless (Map.size metadata <= 16 && all ((<= 64) . Text.length) (Map.keys metadata)) (Left "Responses metadata allows at most 16 keys of at most 64 characters")+  items <- concat <$> traverse (messageItems m) (V.toList ctx.messages)+  let ids = [i | Object item <- items, Just (String i) <- [KM.lookup "id" item]]+  unless (length ids == length (nub ids)) (Left "Responses history contains duplicate item IDs")+  choice <- toolChoiceFields ctx opts+  cache <- cacheFields m opts+  let (reasoning, translation) = thinkingFields m opts+      cap = fromMaybe m.maxOutputTokens opts.maxTokens+      base =+        Aeson.toJSON+          R._CreateResponse+            { R.model = SDK.Model m.modelId,+              R.instructions = ctx.systemPrompt,+              R.store = Just False,+              R.stream = Just True,+              R.include = Just (V.singleton "reasoning.encrypted_content"),+              R.max_output_tokens = if cap == 0 then Nothing else Just cap,+              R.temperature = if compat.supportsSamplingParameters then opts.temperature else Nothing,+              R.top_p = if compat.supportsSamplingParameters then opts.topP else Nothing,+              R.metadata = if Map.null metadata then Nothing else Just metadata,+              R.tools = if V.null ctx.tools then Nothing else Just (V.map sdkTool ctx.tools)+            }+      extras = [("input", Aeson.toJSON items)] <> reasoning <> choice <> cache <> formatFields opts+  case base of+    Object obj -> pure (PreparedRequest (Object (KM.union (KM.fromList extras) obj)) translation)+    _ -> Left "Responses SDK request did not encode as an object"+  where+    metadataText (String t) | Text.length t <= 512 = Right t+    metadataText _ = Left "Responses metadata values must be strings of at most 512 characters"++-- | Both preflight and serialization use this same mapping.+describeThinking :: Model -> Options -> E.ThinkingTranslation+describeThinking m = snd . thinkingFields m++thinkingFields :: Model -> Options -> ([(Aeson.Key, Value)], E.ThinkingTranslation)+thinkingFields m opts = (fields, thought {E.adjustments = thought.adjustments <> sampling})+  where+    compat = openaiResponsesCompatFor m+    (fields, thought) = case opts.thinking of+      Nothing -> ([], E.noThinkingRequested)+      Just lvl | not m.reasoning -> ([], E.ThinkingTranslation (Just lvl) E.ThinkingModeUnsupported Nothing Nothing Nothing Nothing [E.ThinkingDroppedUnsupportedModel lvl])+      Just lvl ->+        let effort = renderThinkingLevel (resolveSupportedEffort compat.supportedReasoningEfforts lvl)+         in ([("reasoning", object ["effort" .= effort])], E.ThinkingTranslation (Just lvl) E.ThinkingModeAdaptive (Just effort) Nothing (Just "reasoning.effort") Nothing [E.EffortClamped lvl effort | effort /= renderThinkingLevel lvl])+    dropped = [name | (name, set) <- [("temperature", isJust opts.temperature), ("top_p", isJust opts.topP)], set]+    sampling = [E.SamplingDroppedUnsupportedModel dropped | not compat.supportsSamplingParameters, not (null dropped)]++sdkTool :: T.Tool -> R.Tool+sdkTool t =+  R.Tool_Function+    { R.name = t.name,+      R.description = Just t.description,+      R.parameters = Just t.parameters,+      R.strict = Just False+    }++toolChoiceFields :: Context -> Options -> Either Text [(Aeson.Key, Value)]+toolChoiceFields ctx opts = case opts.toolChoice of+  Nothing -> pure []+  Just T.ToolChoiceAuto -> pure []+  Just T.ToolChoiceNone -> pure [("tool_choice", String "none")]+  Just T.ToolChoiceRequired+    | V.null ctx.tools -> Left "Responses required tool choice needs at least one declared tool"+    | otherwise -> pure [("tool_choice", String "required")]+  Just (T.ToolChoiceSpecific name)+    | V.any ((== name) . T.name) ctx.tools -> pure [("tool_choice", object ["type" .= ("function" :: Text), "name" .= name])]+    | otherwise -> Left "Responses named tool choice must name a declared tool"++formatFields :: Options -> [(Aeson.Key, Value)]+formatFields opts = case opts.responseFormat of+  Nothing -> []+  Just JsonObject -> [("text", object ["format" .= object ["type" .= ("json_object" :: Text)]])]+  Just (JsonSchema schema) ->+    [ ( "text",+        object+          [ "format"+              .= Aeson.toJSON+                R.TextFormat_JSON_Schema+                  { R.name = schema.name,+                    R.description = Nothing,+                    R.schema = Just schema.schema,+                    R.strict = Just schema.strict+                  }+          ]+      )+    ]++cacheFields :: Model -> Options -> Either Text [(Aeson.Key, Value)]+cacheFields m opts = case opts.cacheRetention of+  Nothing -> pure []+  Just CacheRetentionNone -> pure []+  Just CacheRetentionShort+    | compat.supportsPromptCacheOptions -> pure [("prompt_cache_options", object ["ttl" .= ("30m" :: Text)])]+    | otherwise -> pure [("prompt_cache_retention", String "in_memory")]+  Just CacheRetentionLong+    | compat.supportsPromptCacheOptions || not compat.supportsLongCacheRetention -> Left "This Responses model cannot honor long cache retention"+    | otherwise -> pure [("prompt_cache_retention", String "24h")]+  where+    compat = openaiResponsesCompatFor m++messageItems :: Model -> M.Message -> Either Text [Value]+messageItems m = \case+  M.UserMessage p -> pure [object ["role" .= ("user" :: Text), "content" .= V.map userPart p.content]]+  M.AssistantMessage p -> concat <$> traverse assistantItem (V.toList p.content)+  M.ToolResultMessage p -> do+    parts <- traverse toolResultText p.content+    unless (not (Text.null p.toolCallId)) (Left "Responses tool results need a nonempty call_id")+    let output = (if p.isError then "[error] " else "") <> Text.concat (V.toList parts)+    pure [Aeson.toJSON R.Item_Input_Function_Call_Output {R.id = Nothing, R.call_id = p.toolCallId, R.output = output, R.status = Nothing}]+  where+    assistantItem = \case+      C.AssistantText t -> pure [object ["role" .= ("assistant" :: Text), "content" .= t.text]]+      C.AssistantToolCall tc -> do+        unless (not (Text.null tc.id_) && not (Text.null tc.name)) (Left "Responses tool calls need a nonempty call_id and name")+        unless (not (C.isCutOffToolCall tc)) (Left "Responses cannot replay an incomplete function call")+        pure [Aeson.toJSON R.Item_Input_Function_Call {R.id = Nothing, R.call_id = tc.id_, R.name = tc.name, R.arguments = Text.decodeUtf8 (LBS.toStrict (Aeson.encode tc.arguments)), R.status = Nothing}]+      C.AssistantThinking th -> do+        unless (not th.redacted && th.signature == Nothing) (Left "Responses cannot replay Anthropic thinking signatures or redacted blocks")+        case th.replayState of+          Nothing -> Left "Responses thinking requires its original opaque replay state"+          Just state -> validateReplay m state >> pure (V.toList state.replayItems)++userPart :: C.UserContent -> Value+userPart = \case+  C.UserText t -> Aeson.toJSON (R.Input_Text t.text)+  C.UserImage img ->+    Aeson.toJSON+      R.Input_Image+        { R.image_url = Just ("data:" <> img.mimeType <> ";base64," <> Text.decodeUtf8 (Base64.encode img.imageData)),+          R.file_id = Nothing,+          R.detail = Nothing+        }++toolResultText :: C.ToolResultContent -> Either Text Text+toolResultText = \case+  C.ToolResultText t -> Right t.text+  C.ToolResultImage _ -> Left "Responses adapter cannot encode ToolResultImage yet"++-- | Validate scope and minimum reasoning-item contract without rebuilding+-- the items: preserving original fields and array order is intentional.+validateReplay :: Model -> C.ThinkingReplay -> Either Text ()+validateReplay m state = do+  unless (normaliseApi state.replayApi == OpenAIResponses && state.replayModel == m.modelId) (Left "Reasoning replay belongs to another API or model")+  validateReplayItems state.replayItems++-- | The same wire invariant applies to completed output and next input.+validateReplayItems :: V.Vector Value -> Either Text ()+validateReplayItems items = do+  unless (not (V.null items)) (Left "Reasoning replay must contain at least one item")+  mapM_ item items+  where+    item (Object o)+      | KM.lookup "type" o == Just (String "reasoning"),+        Just (String ident) <- KM.lookup "id" o,+        not (Text.null ident),+        Just (String encrypted) <- KM.lookup "encrypted_content" o,+        not (Text.null encrypted),+        Just (Array summary) <- KM.lookup "summary" o,+        all summaryPart summary =+          pure ()+    item _ = Left "Malformed Responses reasoning replay: expected reasoning type, id, encrypted_content and summary"+    summaryPart (Object o) = KM.lookup "type" o == Just (String "summary_text") && case KM.lookup "text" o of Just (String _) -> True; _ -> False+    summaryPart _ = False
+ src/Baikai/Provider/OpenAI/Responses/Stream.hs view
@@ -0,0 +1,214 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedRecordDot #-}++-- | Internal Responses transport integration; no stability guarantee.+module Baikai.Provider.OpenAI.Responses.Stream+  ( openaiResponsesStreamWith,+    liveResponsesDriver,+  )+where++import Baikai.Content qualified as C+import Baikai.Context (Context)+import Baikai.Cost.Pricing qualified as Pricing+import Baikai.Error (BaikaiError, invalidRequest, providerError)+import Baikai.Evidence qualified as Ev+import Baikai.Evidence.Build qualified as Build+import Baikai.Message qualified as M+import Baikai.Model (Model)+import Baikai.Options (Options)+import Baikai.Provider.Internal.StreamWorker+import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyErrorFrame, classifyException)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver)+import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing+import Baikai.Provider.OpenAI.Responses.Assembler qualified as A+import Baikai.Provider.OpenAI.Responses.Request qualified as R+import Baikai.Provider.OpenAI.Sse (ResponseMetadata, capturedHeaderNames, responsesSseStreamValueWithHeaders)+import Baikai.Provider.OpenAI.Transport qualified as Transport+import Baikai.StopReason (StopReason (..))+import Baikai.Stream.Event qualified as E+import Baikai.Url qualified as Url+import Baikai.Usage qualified as U+import Control.Applicative ((<|>))+import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.Key (Key)+import Data.Aeson.KeyMap qualified as KM+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Data.Time.Clock (UTCTime, getCurrentTime)+import Data.Vector qualified as V+import Data.Version (showVersion)+import Paths_baikai_openai qualified as Paths+import Servant.Client qualified as Client+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream++liveResponsesDriver :: SseDriver+liveResponsesDriver = responsesSseStreamValueWithHeaders++openaiResponsesStreamWith :: SseDriver -> Model -> Context -> Options -> Stream IO E.AssistantMessageEvent+openaiResponsesStreamWith driver m ctx opts = Stream.concatEffect $ do+  setup <- trySync $ do+    req <- either (throwIO . invalidRequest) pure (R.mapRequest m ctx opts)+    let url = resolvedUrl m+    case Url.baseUrlProblem url of+      Just problem -> throwIO (invalidRequest ("Model.baseUrl is not usable: " <> problem))+      Nothing -> pure ()+    key <- Transport.resolveKey url opts+    env <- Transport.getClientEnvCached url+    pure (req, env, Transport.requestHeaders key m opts)+  case setup of+    Left ex -> Stream.fromList <$> immediateError m opts (exceptionToError ex)+    Right (req, env, headers) -> do+      q <- newFrameQueue+      meta <- newIORef Nothing+      start <- getCurrentTime+      let endpoint = T.pack (Client.showBaseUrl (Client.baseUrl env)) <> "/v1/responses"+      evidence <- Build.prepareEvidenceAt endpoint m opts Ev.TransportHttpApi req.translation req.requestBody start+      let worker = do+            result <-+              trySync $+                Transport.runWithTimeout (opts ^. #timeoutMs) $+                  driver env headers req.requestBody (writeIORef meta . Just) (pushFrame q)+            case result of+              Left ex -> pushFrame q (Left (exceptionToError ex))+              Right (Just err) -> pushFrame q (Left err)+              Right Nothing -> pure ()+          initial = State q meta m (A.emptyAssembler (m ^. #modelId)) Nothing [E.EventStart (E.StartPayload (message V.empty U.zeroUsage Stop Nothing start) Nothing)] False evidence+      pure (withFrameWorker q worker (Stream.unfoldrM step initial))++data State = State+  { queue :: !(FrameQueue (Either BaikaiError Value)),+    metadata :: !(IORef (Maybe ResponseMetadata)),+    model :: !Model,+    assembler :: !A.Assembler,+    observed :: !(Maybe Value),+    pending :: ![E.AssistantMessageEvent],+    finished :: !Bool,+    evidence :: !(Maybe (UTCTime -> Ev.CallStatus -> Maybe BaikaiError -> Ev.ModelCallEvidence))+  }++step :: State -> IO (Maybe (E.AssistantMessageEvent, State))+step s+  | e : rest <- s.pending = pure (Just (e, s {pending = rest}))+  | s.finished = pure Nothing+  | otherwise = do+      next <- pullFrame s.queue+      case next of+        Nothing -> terminate (Just (providerError "Responses stream ended without a terminal response")) s+        Just (Left err) -> terminate (Just err) s+        Just (Right raw) -> do+          let obs = mergeObservation s.observed (lookupField "response" raw)+              current = s {observed = obs}+          case responseError raw of+            Just err -> terminate (Just err) current+            Nothing -> case A.advance raw s.assembler of+              Left err -> terminate (Just (providerError err)) current+              Right (assembled, events) -> do+                let updated = current {assembler = assembled, pending = events}+                case A.terminalReason assembled of+                  Nothing -> step updated+                  Just _ -> terminate Nothing updated++-- The terminal is conclusive for Responses: releasing the stream also+-- cancels a driver that keeps waiting after response.completed.+terminate :: Maybe BaikaiError -> State -> IO (Maybe (E.AssistantMessageEvent, State))+terminate err s = do+  now <- getCurrentTime+  md <- readIORef s.metadata+  let (assembled, closes) = case err of+        Nothing -> (s.assembler, [])+        Just _ -> A.closePartial s.assembler+      reason = maybe (fromMaybe Stop (A.terminalReason assembled)) (const ErrorReason) err+      usage = responseUsage s.model s.observed+      payload = M.AssistantPayload (A.assembledContent assembled) usage reason (fmap (^. #message) err) (Just now)+      msg = M.AssistantMessage payload+      rid = s.observed >>= textField "id"+      status = maybe Ev.CallSucceeded (const Ev.CallFailed) err+      proof = fmap (\finish -> observe status md s.observed payload (finish now status err)) s.evidence+      terminal = case err of+        Nothing -> E.EventDone (E.doneTerminal proof rid reason msg)+        Just be -> E.EventError (E.errorTerminal proof rid reason msg be)+  step s {assembler = assembled, pending = s.pending <> closes <> [terminal], finished = True}++message :: V.Vector C.AssistantContent -> U.Usage -> StopReason -> Maybe Text -> UTCTime -> M.Message+message content usage reason note now = M.AssistantMessage (M.AssistantPayload content usage reason note (Just now))++resolvedUrl :: Model -> Text+resolvedUrl m = case m ^. #baseUrl of "" -> "https://api.openai.com"; u -> u++immediateError :: Model -> Options -> BaikaiError -> IO [E.AssistantMessageEvent]+immediateError m opts err = do+  now <- getCurrentTime+  let msg = message V.empty U.zeroUsage ErrorReason (Just (err ^. #message)) now+  proof <- Build.minimalEvidenceAt (resolvedUrl m) m opts Ev.TransportHttpApi (R.describeThinking m opts) (Build.dispatchEnvelope m opts) now now Ev.CallFailed (Just err)+  pure [E.EventStart (E.StartPayload msg Nothing), E.EventError (E.errorTerminal proof Nothing ErrorReason msg err)]++responseError :: Value -> Maybe BaikaiError+responseError raw = case textField "type" raw of+  Just "error" -> classifyErrorFrame (object ["error" .= raw]) <|> Just (providerError "Responses error event")+  Just "response.failed" -> (lookupField "response" raw >>= classifyErrorFrame) <|> Just (providerError "Responses response.failed")+  _ -> classifyErrorFrame raw++mergeObservation :: Maybe Value -> Maybe Value -> Maybe Value+mergeObservation old Nothing = old+mergeObservation (Just (Object old)) (Just (Object new)) =+  let merged = KM.union new old+      usage = Billing.mergeUsage (KM.lookup "usage" old) (KM.lookup "usage" new)+   in Just (Object (maybe merged (\u -> KM.insert "usage" u merged) usage))+mergeObservation _ new = new++-- Known counts and their availability travel together into payload and evidence.+responseUsage :: Model -> Maybe Value -> U.Usage+responseUsage m raw =+  let normalized = U.observeBilling [U.BillingServiceTier tier | Just tier <- [raw >>= textField "service_tier"]] (fromMaybe Billing.unreportedUsage (raw >>= lookupField "usage" >>= Billing.readUsage Billing.ResponsesUsage))+   in normalized & #cost .~ Pricing.computeCostForService Nothing Nothing m normalized++observe :: Ev.CallStatus -> Maybe ResponseMetadata -> Maybe Value -> M.AssistantPayload -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence+observe status md raw payload ev =+  let seenModel = maybe Ev.Unobserved Ev.Observed (raw >>= textField "model")+      rid = maybe Ev.Unobserved Ev.Observed (raw >>= textField "id")+      requestId = case md of+        Nothing -> Ev.Unobserved+        Just meta -> case [v | n <- capturedHeaderNames, Just v <- [lookup (T.decodeUtf8 (CI.foldedCase n)) (meta ^. #headers)]] of+          v : _ -> Ev.Observed v+          [] -> Ev.Unobserved+      allCounts = do+        _ <- raw >>= lookupField "usage" >>= Billing.readUsage Billing.ResponsesUsage+        pure (payload ^. #usage)+      commitment =+        if status == Ev.CallSucceeded+          then Ev.Observed (Ev.commitmentDigest (object ["content" .= (payload ^. #content), "stop_reason" .= (payload ^. #stopReason), "usage" .= Ev.usageEnvelope (payload ^. #usage)]))+          else Ev.Unobserved+   in ev+        & #endpoint . #implementationVersion .~ Just (T.pack (showVersion Paths.version))+        & #observedModel .~ seenModel+        & #responseId .~ rid+        & #providerRequestId .~ requestId+        & #usage .~ maybe Ev.Unobserved Ev.Observed allCounts+        & #responseCommitment .~ commitment+        & #strength .~ Ev.deriveStrength seenModel requestId rid++lookupField :: Key -> Value -> Maybe Value+lookupField k (Object o) = KM.lookup k o+lookupField _ _ = Nothing++textField :: Key -> Value -> Maybe Text+textField k v = lookupField k v >>= \case String t | not (T.null t) -> Just t; _ -> Nothing++trySync :: IO a -> IO (Either SomeException a)+trySync action = do+  result <- try action+  case result of+    Left ex | Just _ <- (fromException ex :: Maybe SomeAsyncException) -> throwIO ex+    _ -> pure result++exceptionToError :: SomeException -> BaikaiError+exceptionToError ex = fromMaybe (classifyException ex) (fromException ex)
src/Baikai/Provider/OpenAI/Shape.hs view
@@ -1,12 +1,19 @@ {-# LANGUAGE LambdaCase #-} --- | Pure request-body shaping for OpenAI-compatible Chat Completions hosts.+-- | __Exposed with no stability guarantees.__ This module is exposed so+-- the test suites can drive the transport without a socket, and so+-- sibling packages can reuse its pieces; it is not part of the public+-- API and may change in /any/ release without a PVP major bump.+--+-- Pure request-body shaping for OpenAI-compatible Chat Completions hosts. module Baikai.Provider.OpenAI.Shape   ( shapeRequestBody,     streamRequestBody,     renameMaxTokens,     dropUnsupportedStrict,     injectThinkingShape,+    describeThinkingShape,+    resolveSupportedEffort,     injectCacheControl,   ) where@@ -18,6 +25,7 @@     OpenAICompletionsCompat       ( cacheControlFormat,         maxTokensField,+        supportedReasoningEfforts,         supportsLongCacheRetention,         supportsStrictMode,         supportsUsageInStreaming,@@ -25,33 +33,59 @@       ),     ThinkingFormat (..),   )-import Baikai.Options (Options, cacheRetention, thinking)+import Baikai.Evidence+  ( ThinkingAdjustment (..),+    ThinkingMode (..),+    ThinkingTranslation (..),+    noThinkingRequested,+  )+import Baikai.Options (Options, cacheRetention, temperature, thinking, topP) import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel)+import Control.Lens ((%~), (&), (^.)) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap (KeyMap) import Data.Aeson.KeyMap qualified as KeyMap+import Data.Generics.Labels ()+import Data.Maybe (isJust) import Data.Text (Text) import Data.Vector (Vector) import Data.Vector qualified as Vector import OpenAI.V1.Chat.Completions qualified as Chat +-- | Reshape a request body for the target host, and describe what the+-- caller's reasoning-effort preference became while doing it.+--+-- The translation travels back out rather than staying inside+-- 'injectThinkingShape' because nothing downstream can recompute it: it+-- depends on the host's 'ThinkingFormat', which only the compat lookup+-- knows. Written as an explicit pipeline rather than the point-free+-- composition it used to be, so the description has somewhere to escape+-- to.+-- The 'Bool' after the compat record is whether the chosen model+-- advertises reasoning support ('Baikai.Model.reasoning'); see+-- 'injectThinkingShape'. shapeRequestBody ::-  OpenAICompletionsCompat -> Options -> Aeson.Value -> Aeson.Value-shapeRequestBody compat opts =-  injectCacheControl compat opts-    . injectThinkingShape compat opts-    . dropUnsupportedStrict compat-    . renameMaxTokens compat+  OpenAICompletionsCompat ->+  Bool ->+  Options ->+  Aeson.Value ->+  (Aeson.Value, ThinkingTranslation)+shapeRequestBody compat modelReasons opts body =+  let renamed = renameMaxTokens compat body+      stripped = dropUnsupportedStrict compat renamed+      (thought, translation) = injectThinkingShape compat modelReasons opts stripped+   in (injectCacheControl compat opts thought, translation)  streamRequestBody ::   OpenAICompletionsCompat ->+  Bool ->   Options ->   Chat.CreateChatCompletion ->-  Aeson.Value-streamRequestBody compat opts req =-  shapeRequestBody compat opts (Aeson.toJSON req')+  (Aeson.Value, ThinkingTranslation)+streamRequestBody compat modelReasons opts req =+  shapeRequestBody compat modelReasons opts (Aeson.toJSON req')   where     req' =       req@@ -87,26 +121,172 @@             adjustKey (key "json_schema") $               mapObject (KeyMap.delete (key "strict")) -injectThinkingShape :: OpenAICompletionsCompat -> Options -> Aeson.Value -> Aeson.Value-injectThinkingShape compat opts body =+-- | Place the caller's reasoning-effort preference in whichever of the+-- seven shapes the host accepts, and describe what that did to it.+--+-- The body this produces is byte-for-byte what it produced before the+-- description existed. The three shapes that express less than the+-- caller asked for now say so: the five non-native effort shapes clamp+-- through 'compatibleEffort', the two toggle shapes carry no depth at+-- all, and 'ThinkingFormatNone' drops the request entirely.+--+-- The native shape preserves each level unless the model explicitly+-- restricts its accepted vocabulary. Any replacement is described by+-- the same mapping that writes the wire field. Host-specific clamping+-- remains separate from this per-model policy.+--+-- The 'Bool' is whether the chosen model advertises reasoning support+-- ('Baikai.Model.reasoning'). It is consulted /before/ the host's+-- 'ThinkingFormat', because the two questions are different and the+-- model's answer is the stronger one: a host may speak a perfectly good+-- reasoning dialect while the model selected on it cannot reason at all.+-- @gpt-4o-mini@ on OpenAI's own host is exactly that, and a level on it+-- used to put @reasoning_effort@ on the wire and take a 400 for it. The+-- level is now dropped and recorded as+-- 'ThinkingDroppedUnsupportedModel', which is what+-- @docs\/user\/model-call-evidence.md@ has always promised baikai-wide+-- and what the Anthropic adapter has always done.+injectThinkingShape ::+  OpenAICompletionsCompat ->+  Bool ->+  Options ->+  Aeson.Value ->+  (Aeson.Value, ThinkingTranslation)+injectThinkingShape compat modelReasons opts body =+  let (shaped, translation) = injectEffort compat modelReasons opts body+      dropped = [name | (name, present) <- [("temperature", isJust (temperature opts)), ("top_p", isJust (topP opts))], present]+   in if compat ^. #supportsSamplingParameters+        then (shaped, translation)+        else+          ( mapObject (KeyMap.delete "temperature" . KeyMap.delete "top_p") shaped,+            translation & #adjustments %~ (<> [SamplingDroppedUnsupportedModel dropped | not (null dropped)])+          )++-- | Resolve to the nearest accepted level at or above the request, or+-- the greatest accepted level when the request exceeds the policy.+-- Invalid empty policies are rejected by request validation.+resolveSupportedEffort :: Maybe [ThinkingLevel] -> ThinkingLevel -> ThinkingLevel+resolveSupportedEffort Nothing lvl = lvl+resolveSupportedEffort (Just []) lvl = lvl+resolveSupportedEffort (Just levels) lvl =+  case filter (>= lvl) levels of+    first : _ -> first+    [] -> last levels++injectEffort :: OpenAICompletionsCompat -> Bool -> Options -> Aeson.Value -> (Aeson.Value, ThinkingTranslation)+injectEffort compat modelReasons opts body =   case thinking opts of-    Nothing -> body+    Nothing -> (body, noThinkingRequested)+    Just lvl+      | not modelReasons ->+          ( body,+            ThinkingTranslation+              { requested = Just lvl,+                mode = ThinkingModeUnsupported,+                effortText = Nothing,+                budgetTokens = Nothing,+                wireField = Nothing,+                displayText = Nothing,+                adjustments = [ThinkingDroppedUnsupportedModel lvl]+              }+          )     Just lvl -> case thinkingFormat compat of       ThinkingFormatOpenAI ->-        insertTop "reasoning_effort" (String (renderThinkingLevel lvl)) body-      ThinkingFormatNone -> body+        let e = renderThinkingLevel (resolveSupportedEffort (supportedReasoningEfforts compat) lvl)+         in ( insertTop "reasoning_effort" (String e) body,+              effortTranslation lvl e "reasoning_effort"+            )+      ThinkingFormatNone ->+        ( body,+          ThinkingTranslation+            { requested = Just lvl,+              mode = ThinkingModeUnsupported,+              effortText = Nothing,+              budgetTokens = Nothing,+              wireField = Nothing,+              displayText = Nothing,+              adjustments = [ThinkingDroppedUnsupportedHost lvl]+            }+        )       ThinkingFormatOpenRouter ->-        insertTop "reasoning" (Aeson.object ["effort" .= compatibleEffort lvl]) body+        let e = compatibleEffort lvl+         in ( insertTop "reasoning" (Aeson.object ["effort" .= e]) body,+              effortTranslation lvl e "reasoning"+            )       ThinkingFormatDeepseek ->-        insertTop "reasoning_effort" (String (compatibleEffort lvl)) $-          insertTop "thinking" (Aeson.object ["type" .= ("enabled" :: Text)]) body+        let e = compatibleEffort lvl+         in ( insertTop "reasoning_effort" (String e) $+                insertTop "thinking" (Aeson.object ["type" .= ("enabled" :: Text)]) body,+              effortTranslation lvl e "reasoning_effort"+            )       ThinkingFormatTogether ->-        insertTop "reasoning_effort" (String (compatibleEffort lvl)) $-          insertTop "reasoning" (Aeson.object ["enabled" .= True]) body+        let e = compatibleEffort lvl+         in ( insertTop "reasoning_effort" (String e) $+                insertTop "reasoning" (Aeson.object ["enabled" .= True]) body,+              effortTranslation lvl e "reasoning_effort"+            )       ThinkingFormatZai ->-        insertTop "enable_thinking" (Bool True) body+        ( insertTop "enable_thinking" (Bool True) body,+          toggleTranslation lvl+        )       ThinkingFormatQwen ->-        insertTop "enable_thinking" (Bool True) body+        ( insertTop "enable_thinking" (Bool True) body,+          toggleTranslation lvl+        )++-- | A host that steers its own depth from an effort word.+--+-- The adjustment list is derived from the word that actually went on+-- the wire, never from a second table beside the mapping: a word equal+-- to the canonical level name expressed the request exactly, and any+-- other word replaced it with something weaker the host accepts. Seven+-- wire shapes share this one derivation precisely so that adding an+-- eighth cannot leave a hand-written table behind.+-- | What this host would do with the caller's reasoning-effort request,+-- without building or sending anything.+--+-- Derived by running the real 'injectThinkingShape' over an empty body+-- and keeping only its description, rather than by reimplementing the+-- seven-shape decision. Two descriptions of one mapping diverge the+-- first time either changes, and the divergence is silent; there is no+-- cheaper way to be sure this agrees with the wire than to ask the+-- function that writes the wire.+-- | What 'injectThinkingShape' would record, without building a body.+-- The 'Bool' is 'Baikai.Model.reasoning', as there.+describeThinkingShape :: OpenAICompletionsCompat -> Bool -> Options -> ThinkingTranslation+describeThinkingShape compat modelReasons opts =+  snd (injectThinkingShape compat modelReasons opts (Aeson.object []))++effortTranslation :: ThinkingLevel -> Text -> Text -> ThinkingTranslation+effortTranslation lvl wire field =+  ThinkingTranslation+    { requested = Just lvl,+      mode = ThinkingModeAdaptive,+      effortText = Just wire,+      budgetTokens = Nothing,+      wireField = Just field,+      displayText = Nothing,+      adjustments =+        [EffortClamped lvl wire | wire /= renderThinkingLevel lvl]+    }++-- | A host that accepts thinking on or off and nothing more.+--+-- Every level collapses, including the ones whose canonical name a+-- richer host would have accepted, because the wire carries no depth:+-- a caller asking for @max@ and a caller asking for @low@ produce+-- byte-identical requests here.+toggleTranslation :: ThinkingLevel -> ThinkingTranslation+toggleTranslation lvl =+  ThinkingTranslation+    { requested = Just lvl,+      mode = ThinkingModeToggle,+      effortText = Nothing,+      budgetTokens = Nothing,+      wireField = Just "enable_thinking",+      displayText = Nothing,+      adjustments = [EffortCollapsedToToggle lvl]+    }  injectCacheControl :: OpenAICompletionsCompat -> Options -> Aeson.Value -> Aeson.Value injectCacheControl compat opts body =
src/Baikai/Provider/OpenAI/Sse.hs view
@@ -1,38 +1,108 @@ {-# LANGUAGE LambdaCase #-} --- | Local SSE transport for OpenAI Chat Completions streams.+-- | __Exposed with no stability guarantees.__ This module is exposed so+-- the test suites can drive the transport without a socket, and so+-- sibling packages can reuse its pieces; it is not part of the public+-- API and may change in /any/ release without a PVP major bump.+--+-- Local SSE transport for OpenAI Chat Completions streams. module Baikai.Provider.OpenAI.Sse   ( openaiSseStream,     openaiSseStreamValue,     openaiSseStreamValueWithHeaders,+    responsesSseStreamValueWithHeaders,     sseFromResponse,+    buildRequest,+    buildResponsesRequest,+    ResponseMetadata (..),+    capturedHeaderNames,   ) where -import Baikai.Error (BaikaiError, decodeError, httpError, parseRetryAfterSeconds)+import Baikai.Error (BaikaiError, decodeError, httpError, parseHttpDate, retryAfterSecondsAt) import Control.Monad (foldM, when) import Data.Aeson qualified as Aeson import Data.ByteString qualified as SBS import Data.ByteString.Char8 qualified as S8+import Data.CaseInsensitive (CI) import Data.CaseInsensitive qualified as CI+import Data.Char (isSpace) import Data.IORef qualified as IORef+import Data.Maybe (fromMaybe) 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 Data.Time.Clock (getCurrentTime)+import GHC.Generics (Generic) import Network.HTTP.Client qualified as HTTP import Network.HTTP.Types.Header (RequestHeaders) import Network.HTTP.Types.Status qualified as Status import OpenAI.V1.Chat.Completions qualified as Chat import Servant.Client qualified as Client +-- | Response-level metadata captured once, before the first chunk.+--+-- Header capture is an allow-list: a response header is recorded only+-- if its name appears in 'capturedHeaderNames'. A denylist would leak+-- whatever header a future gateway decides to add, and this transport+-- speaks to an open-ended set of hosts.+--+-- Names are recorded folded to lowercase, so a reader can look one up+-- without case-folding first.+data ResponseMetadata = ResponseMetadata+  { httpStatus :: !Int,+    headers :: ![(Text, Text)]+  }+  deriving stock (Eq, Show, Generic)++-- | The response headers worth recording across the OpenAI-compatible+-- ecosystem. OpenAI itself issues @x-request-id@; other hosts spell+-- their own identifier @request-id@, and the gateways commonly sitting+-- in front of one of them add @x-amzn-requestid@, @x-ms-request-id@, or+-- @cf-ray@. None can carry a credential: they are values the server+-- chose, not values baikai sent.+--+-- The order is a preference order as well as an allow-list, matching+-- the discipline @Baikai.Provider.Claude.Sse@ established. A consumer+-- picking one correlation identifier out of a response takes the first+-- of these that is present, so the host's own identifier wins over a+-- gateway's when both are there.+capturedHeaderNames :: [CI SBS.ByteString]+capturedHeaderNames =+  [ "x-request-id",+    "request-id",+    "x-amzn-requestid",+    "x-ms-request-id",+    "cf-ray"+  ]++-- | Status and allow-listed headers, read straight off the response.+responseMetadata :: HTTP.Response body -> ResponseMetadata+responseMetadata response =+  ResponseMetadata+    { httpStatus = Status.statusCode (HTTP.responseStatus response),+      headers =+        [ (decodeLenient (CI.foldedCase name), decodeLenient value)+        | (name, value) <- HTTP.responseHeaders response,+          name `elem` capturedHeaderNames+        ]+    }+ -- | POST the request to @/v1/chat/completions@ and feed decoded SSE--- JSON payloads to the callback. A @data: [DONE]@ frame ends the+-- JSON payloads to the second callback. A @data: [DONE]@ frame ends the -- stream without producing a callback value.+--+-- The first callback receives the response's 'ResponseMetadata' exactly+-- once, before any chunk. It is a separate callback rather than a+-- widening of the per-chunk one because the per-chunk callback runs once+-- per SSE frame — potentially thousands of times per call — and+-- response-level data does not belong on that hot path. openaiSseStream ::   Client.ClientEnv ->   Text ->   Chat.CreateChatCompletion ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Aeson.Value -> IO ()) ->   IO () openaiSseStream env apiKey req =@@ -42,6 +112,7 @@   Client.ClientEnv ->   Text ->   Aeson.Value ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Aeson.Value -> IO ()) ->   IO () openaiSseStreamValue env apiKey =@@ -56,40 +127,104 @@   Client.ClientEnv ->   RequestHeaders ->   Aeson.Value ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Aeson.Value -> IO ()) ->   IO ()-openaiSseStreamValueWithHeaders env requestHeaders requestBody onEvent = do-  let base = Client.baseUrl env-      secure = case Client.baseUrlScheme base of+openaiSseStreamValueWithHeaders = sseStreamWith buildRequest++-- | Native Responses uses the same HTTP ownership and SSE framing, but+-- has a distinct URL and event protocol. The Responses assembler owns+-- interpretation of the JSON frames.+responsesSseStreamValueWithHeaders ::+  Client.ClientEnv ->+  RequestHeaders ->+  Aeson.Value ->+  (ResponseMetadata -> IO ()) ->+  (Either BaikaiError Aeson.Value -> IO ()) ->+  IO ()+responsesSseStreamValueWithHeaders = sseStreamWith buildResponsesRequest++sseStreamWith ::+  (Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request) ->+  Client.ClientEnv ->+  RequestHeaders ->+  Aeson.Value ->+  (ResponseMetadata -> IO ()) ->+  (Either BaikaiError Aeson.Value -> IO ()) ->+  IO ()+sseStreamWith makeRequest env requestHeaders requestBody onMetadata onEvent =+  HTTP.withResponse (makeRequest (Client.baseUrl env) requestHeaders requestBody) (Client.manager env) $ \response ->+    sseFromResponse response onMetadata onEvent++-- | The exact request this transport sends.+--+-- Pure and exported so that what goes on the wire — the method, the+-- composed path, and the redirect policy — is assertable without opening+-- a connection.+--+-- The path is the base URL's path plus @/v1/chat/completions@. The base URL+-- reaching here has already been through+-- 'Baikai.Http.canonicalBaseUrl', which strips a trailing @\/v1@+-- segment, so a caller who writes the base URL the way every OpenAI SDK+-- teaches it — @https:\/\/api.deepseek.com\/v1@ — gets one @\/v1@ here+-- rather than two.+buildRequest :: Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request+buildRequest = buildRequestAt "/v1/chat/completions"++buildResponsesRequest :: Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request+buildResponsesRequest = buildRequestAt "/v1/responses"++buildRequestAt :: String -> Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request+buildRequestAt endpoint base requestHeaders requestBody =+  HTTP.defaultRequest+    { HTTP.secure = case Client.baseUrlScheme base of         Client.Http -> False-        Client.Https -> True-      request =-        HTTP.defaultRequest-          { HTTP.secure = secure,-            HTTP.host = S8.pack (Client.baseUrlHost base),-            HTTP.port = Client.baseUrlPort base,-            HTTP.method = "POST",-            HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> "/v1/chat/completions"),-            HTTP.requestHeaders = requestHeaders,-            HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode requestBody),-            -- EP-8 wires Options.timeoutMs through this local transport.-            HTTP.responseTimeout = HTTP.responseTimeoutNone-          }-  HTTP.withResponse request (Client.manager env) (`sseFromResponse` onEvent)+        Client.Https -> True,+      HTTP.host = S8.pack (Client.baseUrlHost base),+      HTTP.port = Client.baseUrlPort base,+      HTTP.method = "POST",+      HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> endpoint),+      HTTP.requestHeaders = requestHeaders,+      HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode requestBody),+      -- This POST has no legitimate redirect, and http-client's default+      -- is to follow up to ten of them with every header intact — which+      -- would re-send the credential to whatever host a Location names.+      -- At zero the 3xx comes back untouched and 'sseFromResponse'+      -- delivers it as the one in-band terminal error, carrying its+      -- status.+      HTTP.redirectCount = 0,+      -- No per-response bound here: Options.timeoutMs is enforced around+      -- the whole call by Transport.runWithTimeout.+      HTTP.responseTimeout = HTTP.responseTimeoutNone+    } +-- | Consume an @http-client@ response as an OpenAI-compatible SSE+-- stream.+--+-- 'onMetadata' fires exactly once, before any chunk, on both the success+-- and the non-2xx path. A failed call's correlation identifier is if+-- anything more valuable than a successful one's, since it is precisely+-- what a provider support request needs. sseFromResponse ::   HTTP.Response HTTP.BodyReader ->+  (ResponseMetadata -> IO ()) ->   (Either BaikaiError Aeson.Value -> IO ()) ->   IO ()-sseFromResponse response onEvent = do+sseFromResponse response onMetadata onEvent = do   let st = HTTP.responseStatus response+  onMetadata (responseMetadata response)   if not (Status.statusIsSuccessful st)     then do       bodyChunks <- HTTP.brConsume (HTTP.responseBody response)+      now <- getCurrentTime       let bodyText = decodeLenient (SBS.concat bodyChunks)-          retryAfter =-            parseRetryAfterSeconds . decodeLenient-              =<< lookup (CI.mk "Retry-After") (HTTP.responseHeaders response)+          headerText name = decodeLenient <$> lookup (CI.mk name) (HTTP.responseHeaders response)+          -- The server's own Date is the reference instant for an+          -- HTTP-date Retry-After, which CDN-fronted hosts send on a+          -- 429; the local clock is the fallback. Using the response's+          -- clock keeps this machine's skew out of the hint.+          reference = fromMaybe now (parseHttpDate =<< headerText "Date")+          retryAfter = retryAfterSecondsAt reference =<< headerText "Retry-After"       onEvent (Left (httpError (Status.statusCode st) retryAfter bodyText))     else do       lineBufRef <- IORef.newIORef SBS.empty@@ -99,12 +234,20 @@             case es of               [] -> pure False               _ -> do-                let payload = S8.concat es-                if payload == "[DONE]"-                  then pure True-                  else case Aeson.eitherDecodeStrict payload of-                    Left err -> onEvent (Left (decodeError (Text.pack err))) >> pure False-                    Right val -> onEvent (Right val) >> pure False+                -- Trailing whitespace is trimmed before the comparison:+                -- hosts send @data: [DONE] @ and @data: [DONE]\r@, and+                -- an exact match against those turned the end of a+                -- healthy stream into a decode error. An empty payload+                -- is a heartbeat, not a frame.+                let payload = S8.dropWhileEnd isSpace (S8.concat es)+                if SBS.null payload+                  then pure False+                  else+                    if payload == "[DONE]"+                      then pure True+                      else case Aeson.eitherDecodeStrict payload of+                        Left err -> onEvent (Left (decodeError (Text.pack err))) >> pure False+                        Right val -> onEvent (Right val) >> pure False            handleLine line =             let l = stripCR line
src/Baikai/Provider/OpenAI/Transport.hs view
@@ -1,3 +1,10 @@+-- | __Exposed with no stability guarantees.__ This module is exposed so+-- the test suites can drive the transport without a socket, and so+-- sibling packages can reuse its pieces; it is not part of the public+-- API and may change in /any/ release without a PVP major bump.+--+-- Transport settings, header assembly and key resolution for+-- OpenAI-compatible Chat Completions hosts. module Baikai.Provider.OpenAI.Transport   ( getClientEnvCached,     cachedClientEnvCount,@@ -8,10 +15,11 @@ where  import Baikai.Auth qualified as Auth-import Baikai.Error (BaikaiError (..), ErrorCategory (..), authError)+import Baikai.Error (BaikaiError (..), ErrorCategory (..), authError, invalidRequest)+import Baikai.Header (HeaderName, renderHeaderName)+import Baikai.Http (cachedClientEnvCount, getClientEnvCached) import Baikai.Model (Model (..)) import Baikai.Options (Options (..))-import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Exception (throwIO) import Control.Lens ((^.)) import Data.CaseInsensitive qualified as CI@@ -20,26 +28,9 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text-import Network.HTTP.Client qualified as HTTP-import Network.HTTP.Client.TLS qualified as TLS import Network.HTTP.Types.Header (RequestHeaders)-import Servant.Client qualified as Client-import System.IO.Unsafe (unsafePerformIO) import System.Timeout qualified as Timeout -getClientEnvCached :: Text -> IO Client.ClientEnv-getClientEnvCached baseUrl =-  modifyMVar clientEnvCache $ \cache ->-    case Map.lookup baseUrl cache of-      Just env -> pure (cache, env)-      Nothing -> do-        env <- newClientEnv baseUrl-        pure (Map.insert baseUrl env cache, env)--cachedClientEnvCount :: IO Int-cachedClientEnvCount =-  modifyMVar clientEnvCache $ \cache -> pure (cache, Map.size cache)- requestHeaders :: Text -> Model -> Options -> RequestHeaders requestHeaders apiKey m opts =   applyHeaderOverrides@@ -59,13 +50,30 @@         authError $           "no default API key env is known for " <> baseUrl <> "; set Options.apiKey explicitly" +-- | Run the transport action under 'Baikai.Options.timeoutMs'.+--+-- 'Nothing' is no bound. A non-positive bound is a caller error and is+-- refused as 'InvalidRequest' /without running the action/, so no+-- connection is opened: 'System.Timeout.timeout' returns immediately at+-- zero and runs unbounded below it, and both spellings used to fail as+-- a retryable 'TransientError' — a classification a retry loop will+-- re-issue forever for a configuration mistake. runWithTimeout :: Maybe Int -> IO () -> IO (Maybe BaikaiError) runWithTimeout Nothing action = action >> pure Nothing-runWithTimeout (Just ms) action = do-  result <- Timeout.timeout (max 0 ms * 1000) action-  pure $ case result of-    Just () -> Nothing-    Nothing -> Just (timeoutError ms)+runWithTimeout (Just ms) action+  | ms <= 0 =+      pure . Just . invalidRequest $+        "Options.timeoutMs must be positive, got "+          <> Text.pack (show ms)+          <> "; use Nothing for no bound"+  -- ms * 1000 would wrap negative, and a negative interval is silently+  -- "no bound". A bound this large is one in practice.+  | ms > maxBound `div` 1000 = action >> pure Nothing+  | otherwise = do+      result <- Timeout.timeout (ms * 1000) action+      pure $ case result of+        Just () -> Nothing+        Nothing -> Just (timeoutError ms)  timeoutError :: Int -> BaikaiError timeoutError ms =@@ -74,31 +82,22 @@       message = "provider stream exceeded timeoutMs=" <> Text.pack (show ms),       httpStatus = Nothing,       retryAfterSeconds = Nothing,-      exitCode = Nothing+      exitCode = Nothing,+      refusalCategory = Nothing     } -newClientEnv :: Text -> IO Client.ClientEnv-newClientEnv baseUrl = do-  parsed <- Client.parseBaseUrl (Text.unpack baseUrl)-  manager <--    TLS.newTlsManagerWith-      TLS.tlsManagerSettings-        { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone-        }-  pure (Client.mkClientEnv manager parsed)-+-- | Apply caller overrides over the provider's own headers.+--+-- The key type already carries the case-insensitivity rule, so the+-- overrides cannot contain two spellings of one name and the fold only+-- has to replace what the provider set. applyHeaderOverrides ::   RequestHeaders ->-  [(Text, Text)] ->+  [(HeaderName, Text)] ->   RequestHeaders applyHeaderOverrides =   foldl addHeader   where     addHeader headers (name, value) =-      let nameBytes = Text.encodeUtf8 name-          ciName = CI.mk nameBytes+      let ciName = CI.mk (Text.encodeUtf8 (renderHeaderName name))        in (ciName, Text.encodeUtf8 value) : filter ((/= ciName) . fst) headers--{-# NOINLINE clientEnvCache #-}-clientEnvCache :: MVar (Map.Map Text Client.ClientEnv)-clientEnvCache = unsafePerformIO (newMVar Map.empty)
+ test/BillingSpec.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedRecordDot #-}++module BillingSpec (tests) where++import Baikai qualified as B+import Baikai.Cost qualified as C+import Baikai.Cost.Pricing (computeCost)+import Baikai.Evidence (commitmentDigest, usageEnvelope)+import Baikai.Models.Generated qualified as Models+import Baikai.Provider.OpenAI.Internal.Stream qualified as Chat+import Baikai.Provider.OpenAI.Internal.Usage+import Baikai.Usage qualified as U+import Baikai.Usage.Normalize qualified as N+import Control.Lens ((&), (.~))+import Control.Monad (forM_)+import Data.Aeson (Value, object, (.=))+import Data.Aeson.Key (Key)+import Data.Aeson.Types qualified+import Data.Set qualified as Set+import Data.Text (Text)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Billing normalization"+    [ testCase "Chat observes the reported tier and discloses unsupported pricing" $+        forM_ [("default", Set.empty), ("priority", Set.singleton (C.UnsupportedServiceTier "priority"))] $ \(tier, reasons) -> do+          let frame = object ["service_tier" .= (tier :: Text), "usage" .= wire ChatUsage 1000 ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (0 :: Int)], "choices" .= [object ["finish_reason" .= ("stop" :: Text), "delta" .= object []]]]+              driver _ _ _ _ emit = emit (Right frame)+              model = Models.openai_gpt_6_astra & #api .~ B.OpenAIChatCompletions & #compat .~ B.CompatNone+          response <- B.streamingComplete (Chat.openaiChatStreamWith driver) model B.emptyContext (B.emptyOptions & #apiKey .~ Just (B.ApiKeyLiteral "offline"))+          response.message.usage.cost.basis.estimateReasons @?= reasons+          U.billingFacts <$> response.message.usage.availability @?= Just (Set.singleton (U.BillingServiceTier tier)),+      testCase "both endpoints subtract reported reads and writes exactly once" $+        forM_ [ChatUsage, ResponsesUsage] $ \endpoint -> do+          u <- parsed endpoint (wire endpoint 15000 ["cached_tokens" .= (12000 :: Int), "cache_write_tokens" .= (3000 :: Int)])+          (u.inputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.outputTokens, u.totalTokens) @?= (0, 12000, 3000, 100, 15100)+          u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty)+          (computeCost Models.openai_gpt_6_astra u).usd @?= 109 / 2000,+      testCase "missing writes retain counts but make cost an explicit estimate" $ do+        missing <- parsed ResponsesUsage (wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int)])+        zero <- parsed ResponsesUsage (wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int), "cache_write_tokens" .= (0 :: Int)])+        missing.inputTokens @?= 3000+        missing.totalTokens @?= zero.totalTokens+        (computeCost Models.openai_gpt_6_astra missing).basis.estimateReasons @?= Set.singleton C.CacheWriteUsageNotReported+        (computeCost Models.openai_gpt_6_astra zero).basis.estimateReasons @?= Set.empty+        assertBool "provider commitments distinguish omitted and zero counters" (commitmentDigest (usageEnvelope missing) /= commitmentDigest (usageEnvelope zero)),+      testCase "empty usage is unreported but explicit zero is reported" $ do+        readUsage ResponsesUsage (object []) @?= Nothing+        (computeCost Models.openai_gpt_6_astra unreportedUsage).basis.estimateReasons @?= Set.singleton C.UsageNotReported+        zero <- parsed ResponsesUsage (object ["input_tokens" .= (0 :: Int), "output_tokens" .= (0 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (0 :: Int)]])+        zero.totalTokens @?= 0+        (computeCost Models.openai_gpt_6_astra zero).basis.estimateReasons @?= Set.empty,+      testCase "partial usage retains its reported categories" $ do+        u <- parsed ChatUsage (object ["completion_tokens" .= (50 :: Int)])+        u.outputTokens @?= 50+        u.availability @?= Just (U.UsageAvailability (Set.fromList [U.InputUsage, U.CacheReadUsage, U.CacheWriteUsage]) False Set.empty),+      testCase "invalid and inconsistent counters are never exact" $+        forM_ [wire ResponsesUsage 100 ["cached_tokens" .= (120 :: Int)], wire ResponsesUsage 100 ["cache_write_tokens" .= (-1 :: Int)], wire ResponsesUsage 100 ["cached_tokens" .= (1.5 :: Double)]] $ \raw -> do+          u <- parsed ResponsesUsage raw+          assertBool "inconsistency survives into calculation basis" (C.InconsistentUsage `Set.member` (computeCost Models.openai_gpt_6_astra u).basis.estimateReasons),+      testCase "exclusive input sums cache categories and reasoning stays a subset" $ do+        let u = N.normalizeUsage N.ExclusiveInput (N.ReportedUsage (Just 10) (Just 100) (Just 20) (Just 30) (Just 80))+        (u.inputTokens, u.totalTokens) @?= (10, 160)+        u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty),+      testCase "cumulative snapshots retain missing fields and never double counts" $ do+        let initial = wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int)]+            final = object ["output_tokens" .= (200 :: Int), "input_tokens_details" .= object ["cache_write_tokens" .= (3000 :: Int)]]+            snapshot = mergeUsage (Just initial) (Just final)+        mergeUsage snapshot (Just final) @?= snapshot+        u <- maybe (assertFailure "missing merged usage") (parsed ResponsesUsage) snapshot+        (u.inputTokens, u.outputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.totalTokens) @?= (0, 200, 12000, 3000, 15200)+        u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty),+      testCase "availability aggregation retains unknown categories and monoid identity" $ do+        a <- parsed ResponsesUsage (wire ResponsesUsage 100 [])+        b <- parsed ResponsesUsage (wire ResponsesUsage 100 ["cached_tokens" .= (120 :: Int)])+        mempty <> a @?= a+        a <> mempty @?= a+        (a <> b) <> a @?= a <> (b <> a)+        U.inconsistent <$> (a <> b).availability @?= Just True+    ]++wire :: UsageEndpoint -> Int -> [Data.Aeson.Types.Pair] -> Value+wire endpoint input details =+  let (i, o, d) = case endpoint of ChatUsage -> ("prompt_tokens", "completion_tokens", "prompt_tokens_details"); ResponsesUsage -> ("input_tokens", "output_tokens", "input_tokens_details")+   in object [(i :: Key) .= input, o .= (100 :: Int), d .= object details]++parsed :: UsageEndpoint -> Value -> IO U.Usage+parsed endpoint raw = maybe (assertFailure "expected usage") pure (readUsage endpoint raw)
+ test/CliEvidenceSpec.hs view
@@ -0,0 +1,350 @@+-- | End-to-end model-call evidence for the @codex exec --json@+-- subprocess provider.+--+-- Every case here runs a real child process — a few lines of @sh@+-- written into a temporary directory that print a recorded @codex@+-- event stream and exit. Nothing is stubbed: the argument vector is+-- rendered by 'CodexCli.codexCliCommand', the process is spawned by the+-- real provider, the event stream is folded by the real parser, and the+-- evidence is assembled and emitted through the real trace path. No+-- credential and no coding-agent binary is required.+--+-- Assertions go through the encoded JSON rather than through Haskell+-- record accessors, because the JSON is the contract other systems pin+-- against, and it spells its fields in snake_case where a Haskell+-- mirror would silently paper over a rename.+module CliEvidenceSpec (tests) where++import Baikai+import Baikai.Provider.OpenAI.Cli qualified as CodexCli+import Baikai.Trace (withTraceStreamWith)+import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..))+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Generics.Labels ()+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as TextIO+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import System.Directory (getPermissions, setOwnerExecutable, setPermissions)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    -- Named so a documented @--test-options='--pattern CliEvidence'@+    -- actually selects it. A pattern that matches nothing reports+    -- "All 0 tests passed".+    "CliEvidenceSpec: Codex CLI model-call evidence"+    [ successEvidenceTest,+      silentToolTest,+      everyLevelSurvivesTest,+      partiallyObservedFailureTest,+      optOutTest+    ]++-- ============================================================+-- The cases+-- ============================================================++successEvidenceTest :: TestTree+successEvidenceTest =+  testCase "a recorded run records what the tool reported, and no more" $ do+    outcome <- replay recordedEvents baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "succeeded")+    field "run_id" ev @?= Just (String "run-55")+    field "requested_model" ev @?= Just (String "gpt-5.6")++    -- The thread identifier the parser used to filter out of the event+    -- stream along with everything that was not an agent_message.+    field "response_id" ev @?= Just (observedJson "019fd471-4a48-7c83-be67-6b7c49646e43")++    -- THE CODEX-SPECIFIC LIMIT. codex-cli 0.146.0 names no model+    -- anywhere in its event stream, so no codex run can reach+    -- model_observed however well it goes. Backfilling the --model+    -- flag baikai passed would report the request as an observation,+    -- and would make this transport look as strong as the API one.+    field "observed_model" ev @?= Just (String "unobserved")+    -- Tied to the declaration mechanically: raising declaredStrength for+    -- this transport without the transport reaching it fails here.+    field "strength" ev @?= Just (Aeson.toJSON (declaredStrength OpenAICompletionsCli))++    field "provider_request_id" ev @?= Just (String "unobserved")+    field "observed_thinking" ev @?= Just (String "unobserved")++    assertDigest "request_commitment" ev+    assertDigest "request_configuration" ev+    assertObservedDigest "response_commitment" ev++    -- Not zeroUsage, and normalized: codex reports OpenAI-style+    -- inclusive prompt counts, so the cached tokens come out of+    -- input_tokens (16071 - 6912).+    case observedObject "usage" ev of+      Nothing -> assertFailure ("expected an observed usage, got: " <> show (field "usage" ev))+      Just u -> do+        KeyMap.lookup "input_tokens" u @?= Just (Number 9159)+        KeyMap.lookup "cache_read_tokens" u @?= Just (Number 6912)+        KeyMap.lookup "output_tokens" u @?= Just (Number 5)+        KeyMap.lookup "reasoning_tokens" u @?= Just (Number 0)++    case field "endpoint" ev of+      Just (Object o) -> do+        KeyMap.lookup "transport" o @?= Just (String "subprocess")+        KeyMap.lookup "endpoint" o @?= Just (String (Text.pack (outcome ^. #executable)))+        KeyMap.lookup "implementation_version" o @?= Just (String "codex-cli 9.9.9")+      other -> assertFailure ("expected an endpoint object, got: " <> show other)++silentToolTest :: TestTree+silentToolTest =+  testCase "A ZERO EXIT WITH NO IDENTIFIER AND NO MODEL STAYS AT requested_only" $ do+    -- IR-3's rule and the reason this plan exists. A coding-agent CLI+    -- that exits zero has demonstrated that it ran and did not crash.+    -- Subprocess calls almost always exit zero, so encoding that as+    -- corroboration would make the weakest evidence in the system look+    -- like the strongest.+    outcome <- replay silentEvents baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "succeeded")+    field "strength" ev @?= Just (String "requested_only")+    field "response_id" ev @?= Just (String "unobserved")+    field "observed_model" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")++everyLevelSurvivesTest :: TestTree+everyLevelSurvivesTest =+  testGroup+    -- Codex is the only transport in baikai that expresses all six+    -- levels exactly, which is worth asserting precisely because every+    -- other transport clamps, collapses, or drops something.+    "every canonical level reaches the command line verbatim"+    [ testCase (Text.unpack (renderThinkingLevel level)) $ do+        outcome <- replay recordedEvents (baseOptions & #thinking .~ Just level)+        let expected = "model_reasoning_effort=" <> renderThinkingLevel level+        assertBool+          ("the argument vector must carry " <> Text.unpack expected <> ": " <> show (outcome ^. #argv))+          (["-c", expected] `isSublistOf` (outcome ^. #argv))+        ev <- oneEvidence (outcome ^. #events)+        case field "thinking" ev of+          Just (Object t) -> do+            KeyMap.lookup "requested" t @?= Just (String (renderThinkingLevel level))+            KeyMap.lookup "mode" t @?= Just (String "flag")+            KeyMap.lookup "effort_text" t @?= Just (String (renderThinkingLevel level))+            KeyMap.lookup "wire_field" t @?= Just (String "model_reasoning_effort")+            KeyMap.lookup "budget_tokens" t @?= Just Null+            -- Nothing happened to the request on the way to the wire.+            KeyMap.lookup "adjustments" t @?= Just (Array Vector.empty)+          other -> assertFailure ("expected a thinking translation, got: " <> show other)+    | level <-+        [ ThinkingMinimal,+          ThinkingLow,+          ThinkingMedium,+          ThinkingHigh,+          ThinkingXHigh,+          ThinkingMax+        ]+    ]++partiallyObservedFailureTest :: TestTree+partiallyObservedFailureTest =+  testCase "a failed run keeps the identifier it saw and commits to no response" $ do+    -- The event stream is drained before the exit status is known, so a+    -- run that named its thread and then failed really did name it.+    -- Discarding that would throw away the single most useful thing to+    -- have when opening a vendor support request.+    outcome <- replay failingEvents baseOptions+    ev <- oneEvidence (outcome ^. #events)+    field "status" ev @?= Just (String "failed")+    field "response_id" ev @?= Just (observedJson "019fd471-dead-7c83-be67-6b7c49646e43")+    field "strength" ev @?= Just (String "correlated")+    -- No complete response exists, so there is nothing to commit to. A+    -- digest of an empty envelope would be a real-looking value+    -- standing for a response that never arrived.+    field "response_commitment" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")++optOutTest :: TestTree+optOutTest =+  testCase "a call that asked for no evidence emits none" $ do+    outcome <- replay recordedEvents emptyOptions+    [e | e@CallEvidence {} <- outcome ^. #events] @?= []+    length [e | e@CallStarted {} <- outcome ^. #events] @?= 1+    length [e | e@CallFinished {} <- outcome ^. #events] @?= 1++-- ============================================================+-- Replay harness+-- ============================================================++-- | What one replayed call produced.+data Replay = Replay+  { events :: ![TraceEvent],+    -- | The argument vector the fake executable actually received.+    argv :: ![Text],+    -- | The path the fake executable was written to.+    executable :: !FilePath+  }+  deriving stock (Generic)++-- | Run one call against a fake @codex@ that prints the given+-- newline-delimited event stream on standard output.+replay :: ([Text], Int) -> Options -> IO Replay+replay recording opts =+  withSystemTempDirectory "baikai-openai-cli-evidence" $ \dir -> do+    let argvPath = dir </> "argv"+    exe <- writeFakeExecutable dir "codex" (fakeCodex argvPath recording)+    reg <- newProviderRegistry+    registerApiProviderWith+      reg+      ( CodexCli.codexCliProvider+          CodexCli.defaultCodexCliConfig {CodexCli.executable = exe}+      )+    (ref, sink) <- memorySink+    _ <- Stream.fold Fold.drain (withTraceStreamWith reg sink testModel testContext opts)+    recorded <- reverse <$> readTVarIO ref+    received <- Text.lines <$> TextIO.readFile argvPath+    pure Replay {events = recorded, argv = received, executable = exe}++-- | A fake @codex@ in a few lines of @sh@: the recorded event lines and+-- the exit status to leave with.+--+-- It answers @--version@ before recording anything, exactly as the real+-- tool does. That is not decoration: the evidence path probes the+-- executable's version with a second invocation, and a fake that+-- recorded that invocation's argument vector would overwrite the one+-- the test is about to assert on.+fakeCodex :: FilePath -> ([Text], Int) -> String+fakeCodex argvPath (eventLines, status) =+  unlines+    ( [ "#!/bin/sh",+        "if [ \"$1\" = \"--version\" ]; then echo 'codex-cli 9.9.9'; exit 0; fi",+        "printf '%s\\n' \"$@\" > '" <> argvPath <> "'",+        "cat <<'BAIKAI_FIXTURE'"+      ]+        <> map Text.unpack eventLines+        <> [ "BAIKAI_FIXTURE",+             "exit " <> show status+           ]+    )++writeFakeExecutable :: FilePath -> String -> String -> IO FilePath+writeFakeExecutable dir name body = do+  let path = dir </> name+  writeFile path body+  perms <- getPermissions path+  setPermissions path (setOwnerExecutable True perms)+  pure path++memorySink :: IO (TVar [TraceEvent], TraceSink)+memorySink = do+  ref <- newTVarIO []+  let step () e = atomically (modifyTVar' ref (e :))+  pure (ref, TraceSink (Fold.foldlM' step (pure ())))++-- ============================================================+-- Fixtures+-- ============================================================++testModel :: Model+testModel =+  emptyModel+    & #modelId .~ "gpt-5.6"+    & #api .~ OpenAICompletionsCli+    & #provider .~ "openai"++testContext :: Context+testContext = emptyContext & #messages .~ Vector.singleton (user "PROMPT-BODY-MARKER")++baseOptions :: Options+baseOptions = emptyOptions & #evidence .~ Just (evidenceRequest "run-55")++-- | The event stream @codex-cli 0.146.0@ emits, with the thread+-- identifier kept exactly as recorded.+recordedEvents :: ([Text], Int)+recordedEvents =+  ( [ "{\"type\":\"thread.started\",\"thread_id\":\"019fd471-4a48-7c83-be67-6b7c49646e43\"}",+      "{\"type\":\"turn.started\"}",+      "{\"type\":\"item.completed\",\"item\":{\"id\":\"item_0\",\"type\":\"agent_message\",\"text\":\"ok\"}}",+      "{\"type\":\"turn.completed\",\"usage\":{\"input_tokens\":16071,\"cached_input_tokens\":6912,\+      \\"cache_write_input_tokens\":0,\"output_tokens\":5,\"reasoning_output_tokens\":0}}"+    ],+    0+  )++-- | A run that succeeded and said nothing about itself.+silentEvents :: ([Text], Int)+silentEvents =+  ( ["{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"ok\"}}"],+    0+  )++-- | A run that named its thread and then failed.+failingEvents :: ([Text], Int)+failingEvents =+  ( ["{\"type\":\"thread.started\",\"thread_id\":\"019fd471-dead-7c83-be67-6b7c49646e43\"}"],+    4+  )++-- ============================================================+-- Assertions on the encoded record+-- ============================================================++oneEvidence :: [TraceEvent] -> IO ModelCallEvidence+oneEvidence recorded = case [ev | CallEvidence {evidence = ev} <- recorded] of+  [ev] -> pure ev+  other ->+    assertFailure+      ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show recorded)++field :: Text -> ModelCallEvidence -> Maybe Value+field k ev = case Aeson.toJSON ev of+  Object o -> KeyMap.lookup (Key.fromText k) o+  _ -> Nothing++-- | How 'Baikai.Evidence.Observed' encodes a present value.+observedJson :: Text -> Value+observedJson v = Object (KeyMap.singleton "observed" (String v))++observedObject :: Text -> ModelCallEvidence -> Maybe (KeyMap.KeyMap Value)+observedObject k ev = case field k ev of+  Just (Object o) -> case KeyMap.lookup "observed" o of+    Just (Object inner) -> Just inner+    _ -> Nothing+  _ -> Nothing++assertDigest :: Text -> ModelCallEvidence -> IO ()+assertDigest k ev = case field k ev of+  Just (String d) -> assertSha256 k d+  other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other)++assertObservedDigest :: Text -> ModelCallEvidence -> IO ()+assertObservedDigest k ev = case field k ev of+  Just (Object o) -> case KeyMap.lookup "observed" o of+    Just (String d) -> assertSha256 k d+    other -> assertFailure (Text.unpack k <> " not a digest: " <> show other)+  other -> assertFailure ("expected an observed " <> Text.unpack k <> ", got: " <> show other)++assertSha256 :: Text -> Text -> IO ()+assertSha256 k d =+  assertBool+    (Text.unpack k <> " must be a sha256 digest, got: " <> show d)+    ("sha256:" `Text.isPrefixOf` d && Text.length d == 71)++isSublistOf :: (Eq a) => [a] -> [a] -> Bool+isSublistOf needle haystack =+  any (\suffix -> needle == take (length needle) suffix) (suffixes haystack)+  where+    suffixes xs =+      xs : case xs of+        [] -> []+        (_ : rest) -> suffixes rest
+ test/Contract.hs view
@@ -0,0 +1,45 @@+-- | The stream protocol, as an assertion.+--+-- Lives in its own module rather than in @Main@ because three suites+-- need it — the end-to-end cases in @Main@, the failure-stream cases in+-- @SseSpec@, and the evidence cases in @EvidenceSpec@ — and a protocol+-- asserted three slightly different ways is not asserted at all.+module Contract (assertErrorContract, assertOneErrorTerminal) where++import Baikai.Stream.Event+  ( AssistantMessageEvent (..),+    StartPayload (..),+    TerminalPayload (..),+    isTerminal,+  )+import Test.Tasty.HUnit (Assertion, assertFailure, (@?=))++-- | The whole documented protocol for a failing stream: exactly one+-- 'EventStart', first; exactly one terminal; and that terminal an+-- 'EventError' carrying structured 'errorInfo'.+--+-- Use this on anything that drains a provider stream. A fragment folded+-- straight through @translate@ never carried a start event, so it gets+-- 'assertOneErrorTerminal' instead.+assertErrorContract :: [AssistantMessageEvent] -> Assertion+assertErrorContract events = do+  case events of+    EventStart StartPayload {} : _ -> pure ()+    other -> assertFailure ("stream must begin with EventStart, got: " <> show (take 1 other))+  length [() | EventStart {} <- events] @?= 1+  assertOneErrorTerminal events+  case reverse events of+    (EventError TerminalPayload {} : _) -> pure ()+    other -> assertFailure ("stream must end with EventError, got: " <> show (take 1 other))++-- | The terminal half of 'assertErrorContract', for translator-level+-- fragments that never carried a start event.+assertOneErrorTerminal :: [AssistantMessageEvent] -> Assertion+assertOneErrorTerminal events = do+  let terminals = filter isTerminal events+  length terminals @?= 1+  case terminals of+    [EventError TerminalPayload {errorInfo = Nothing}] ->+      assertFailure "terminal EventError omitted errorInfo"+    [EventError TerminalPayload {errorInfo = Just _}] -> pure ()+    other -> assertFailure ("expected exactly one terminal EventError, got: " <> show other)
+ test/EndpointModels.hs view
@@ -0,0 +1,20 @@+-- | Explicit Chat capability fixture, independent of catalog routing.+module EndpointModels (chatRestrictedModel) where++import Baikai+import Control.Lens ((&), (.~))++chatRestrictedModel :: Model+chatRestrictedModel =+  emptyModel+    & #api .~ OpenAIChatCompletions+    & #provider .~ "openai"+    & #modelId .~ "restricted-chat-model"+    & #reasoning .~ True+    & #compat+      .~ CompatOpenAICompletions+        ( defaultOpenAICompletionsCompat+            & #supportsToolCalls .~ False+            & #supportsSamplingParameters .~ False+            & #supportedReasoningEfforts .~ Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax]+        )
test/ErrorClassSpec.hs view
@@ -2,20 +2,17 @@  import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable) import Baikai.Provider.OpenAI.Internal.ErrorClass-  ( classifyErrorText,+  ( classifyErrorFrame,     classifyException,-    responseToError,   ) import Control.Exception (toException)-import Data.ByteString (ByteString)+import Data.Aeson (Value)+import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as LBS-import Data.CaseInsensitive qualified as CI-import Data.Sequence qualified as Seq import Data.Text qualified as Text+import Foreign.C.Error (Errno (..), eCONNRESET)+import GHC.IO.Exception qualified as IOE import Network.HTTP.Client qualified as HTTP-import Network.HTTP.Types.Status (mkStatus)-import Network.HTTP.Types.Version (http11)-import Servant.Client (ResponseF (..)) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) @@ -23,56 +20,41 @@ tests =   testGroup     "Baikai.Provider.OpenAI.Internal.ErrorClass"-    [ httpStatusTests,-      sdkTextTests,+    [ errorFrameTests,       streamedErrorTests,       fallbackTests     ] -mkResp :: Int -> [(ByteString, ByteString)] -> LBS.ByteString -> ResponseF LBS.ByteString-mkResp status hdrs body =-  Response-    { responseStatusCode = mkStatus status "",-      responseHeaders = Seq.fromList [(CI.mk n, v) | (n, v) <- hdrs],-      responseHttpVersion = http11,-      responseBody = body-    }--httpStatusTests :: TestTree-httpStatusTests =-  testGroup-    "responseToError (HTTP status)"-    [ testCase "429 + Retry-After -> RateLimited with hint" $ do-        let e = responseToError (mkResp 429 [("Retry-After", "12")] "slow down")-        category e @?= RateLimited-        httpStatus e @?= Just 429-        retryAfterSeconds e @?= Just 12,-      testCase "401 -> AuthError" $-        category (responseToError (mkResp 401 [] "bad key")) @?= AuthError,-      testCase "400 with overflow body -> ContextOverflow" $-        category (responseToError (mkResp 400 [] "maximum context length is 8192 tokens"))-          @?= ContextOverflow,-      testCase "400 ordinary -> InvalidRequest" $-        category (responseToError (mkResp 400 [] "unknown parameter")) @?= InvalidRequest,-      testCase "500 -> TransientError" $-        category (responseToError (mkResp 500 [] "")) @?= TransientError-    ]-+-- | The phrase table, pinned through the entry point the runtime uses.+--+-- These four phrases used to be fed to a bare-'Text' classifier that no+-- production path called. They still classify the same way, but now as+-- the @message@ of a frame the transport can actually deliver. streamedErrorTests :: TestTree streamedErrorTests =   testGroup-    "classifyErrorText (mid-stream error text)"+    "classifyErrorFrame (message phrase fallback)"     [ testCase "rate limit text -> RateLimited" $-        fmap category (classifyErrorText "Rate limit reached for requests") @?= Just RateLimited,+        fmap category (classifyErrorFrame (frameWithMessage "Rate limit reached for requests"))+          @?= Just RateLimited,       testCase "context length text -> ContextOverflow" $-        fmap category (classifyErrorText "This model's maximum context length is 4096 tokens")+        fmap+          category+          (classifyErrorFrame (frameWithMessage "This model's maximum context length is 4096 tokens"))           @?= Just ContextOverflow,       testCase "invalid api key text -> AuthError" $-        fmap category (classifyErrorText "Incorrect API key provided") @?= Just AuthError,+        fmap category (classifyErrorFrame (frameWithMessage "Incorrect API key provided"))+          @?= Just AuthError,       testCase "unknown text -> OtherError" $-        fmap category (classifyErrorText "something odd happened") @?= Just OtherError,-      testCase "blank text -> Nothing" $-        classifyErrorText "   " @?= Nothing+        fmap category (classifyErrorFrame (frameWithMessage "something odd happened"))+          @?= Just OtherError,+      -- A blank message is still a frame: the error key is what makes it+      -- one, and dropping it would put the call back on the "stream+      -- ended without finish_reason" path this milestone exists to fix.+      testCase "a frame whose message is blank still classifies" $ do+        let parsed = classifyErrorFrame (frameWithMessage "   ")+        fmap category parsed @?= Just OtherError+        fmap message parsed @?= Just "provider sent an error frame without a message"     ]  fallbackTests :: TestTree@@ -97,24 +79,91 @@                     HTTP.ResponseTimeout         category e @?= TransientError         assertBool "response timeout is retryable" (isRetryable e),-      testCase "non-ClientError exception -> OtherError, text preserved" $ do+      -- The delegation itself, through the provider's entry point: a+      -- reset raised from the body read reaches the worker as a raw+      -- IOException, which no HttpException branch would have matched.+      testCase "a body-read reset is transient through classifyException" $ do+        let e =+              classifyException . toException $+                IOE.IOError+                  { IOE.ioe_handle = Nothing,+                    IOE.ioe_type = IOE.ResourceVanished,+                    IOE.ioe_location = "Network.Socket.recvBuf",+                    IOE.ioe_description = "Connection reset by peer",+                    IOE.ioe_errno = Just (case eCONNRESET of Errno n -> n),+                    IOE.ioe_filename = Nothing+                  }+        category e @?= TransientError+        assertBool "a mid-stream reset is retryable" (isRetryable e),+      testCase "non-transport exception -> OtherError, text preserved" $ do         let e = classifyException (toException (userError "weird failure"))         category e @?= OtherError         assertBool "message keeps the original text" $           "weird failure" `Text.isInfixOf` message e     ] -sdkTextTests :: TestTree-sdkTextTests =+-- | The frames a compatible host actually sends on a 2xx stream.+errorFrameTests :: TestTree+errorFrameTests =   testGroup-    "classifyErrorText (SDK HTTP text)"-    [ testCase "429 SDK text -> RateLimited with status" $ do+    "classifyErrorFrame (in-band error frames)"+    [ -- OpenRouter forwards the upstream HTTP status as a *number* in+      -- `code`, and sends a `choices` array beside the error, so+      -- detection cannot key on the absence of `choices`.+      testCase "an OpenRouter upstream 502 frame is TransientError with httpStatus 502" $ do         let parsed =-              classifyErrorText-                "HTTP error 429 Too Many Requests: {\"error\":{\"message\":\"Rate limit reached...\",\"type\":\"tokens\"}}"+              classifyErrorFrame . decode $+                "{\"error\":{\"message\":\"Provider returned error\",\"code\":502,\+                \\"metadata\":{\"provider_name\":\"x\"}},\+                \\"choices\":[{\"index\":0,\"finish_reason\":\"error\",\"delta\":{}}]}"+        fmap category parsed @?= Just TransientError+        fmap httpStatus parsed @?= Just (Just 502)+        fmap message parsed @?= Just "Provider returned error"+        fmap isRetryable parsed @?= Just True,+      testCase "an OpenAI insufficient_quota frame is AuthError and not retryable" $ do+        let parsed =+              classifyErrorFrame . decode $+                "{\"error\":{\"message\":\"You exceeded your current quota\",\+                \\"type\":\"insufficient_quota\",\"code\":\"insufficient_quota\"}}"+        fmap category parsed @?= Just AuthError+        fmap isRetryable parsed @?= Just False,+      testCase "a rate_limit_exceeded code is RateLimited" $+        fmap+          category+          ( classifyErrorFrame . decode $+              "{\"error\":{\"message\":\"slow down\",\"code\":\"rate_limit_exceeded\"}}"+          )+          @?= Just RateLimited,+      testCase "a context_length_exceeded code is ContextOverflow" $+        fmap+          category+          ( classifyErrorFrame . decode $+              "{\"error\":{\"message\":\"too big\",\"code\":\"context_length_exceeded\"}}"+          )+          @?= Just ContextOverflow,+      testCase "an upstream 429 status wins over the message text" $ do+        let parsed =+              classifyErrorFrame . decode $+                "{\"error\":{\"message\":\"something odd\",\"status\":429}}"         fmap category parsed @?= Just RateLimited         fmap httpStatus parsed @?= Just (Just 429),-      testCase "401 SDK text -> AuthError" $-        fmap category (classifyErrorText "HTTP error 401 Unauthorized: {\"error\":{\"message\":\"bad key\"}}")-          @?= Just AuthError+      testCase "a string-valued error is a frame" $ do+        let parsed = classifyErrorFrame (decode "{\"error\":\"Rate limit reached\"}")+        fmap category parsed @?= Just RateLimited+        fmap message parsed @?= Just "Rate limit reached",+      testCase "a chunk without an error key is not a frame" $+        classifyErrorFrame (decode "{\"choices\":[]}") @?= Nothing,+      testCase "a non-object payload is not a frame" $+        classifyErrorFrame (decode "[1,2,3]") @?= Nothing     ]++-- | The minimal frame: an error object carrying only a message.+frameWithMessage :: Text.Text -> Value+frameWithMessage msg = Aeson.object ["error" Aeson..= Aeson.object ["message" Aeson..= msg]]++-- | Fixtures are written as the JSON the host sends, so what is under+-- test is the shape on the wire rather than a hand-built 'Value'.+decode :: LBS.ByteString -> Value+decode raw = case Aeson.eitherDecode raw of+  Right v -> v+  Left err -> error ("fixture is not valid JSON: " <> err)
+ test/EvidenceSpec.hs view
@@ -0,0 +1,526 @@+-- | End-to-end model-call evidence for the OpenAI-compatible Chat+-- Completions provider.+--+-- Every case here replays a recorded HTTP response through the real+-- adapter and reads the evidence back out of a trace sink. Nothing is+-- stubbed but the socket: the request is built by @mapRequest@ and+-- shaped by @streamRequestBody@, the response is decoded by+-- @sseFromResponse@, the headers are captured by the real allow-list,+-- and the record is assembled and emitted by the real trace path.+--+-- Assertions go through the encoded JSON rather than through Haskell+-- record accessors, because the JSON is the contract other systems pin+-- against, and it spells its fields in snake_case where a Haskell+-- mirror would silently paper over a rename.+module EvidenceSpec (tests) where++import Baikai+import Baikai.Models.Generated (openai_gpt_4o_mini)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver, openaiChatStreamWith)+import Baikai.Provider.OpenAI.Shape (describeThinkingShape)+import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Baikai.Trace (withTraceStreamWith)+import Baikai.Trace.Event (TraceEvent (..))+import Baikai.Trace.Sink (TraceSink (..))+import Contract (assertErrorContract)+import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..))+import Data.Aeson qualified as Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.ByteString (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import EndpointModels (chatRestrictedModel)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    -- Named so this plan's documented+    -- @--test-options='--pattern Evidence'@ actually selects it. A+    -- pattern that matches nothing reports "All 0 tests passed".+    "EvidenceSpec: OpenAI-compatible model-call evidence"+    [ endpointEvidenceTest,+      successEvidenceTest,+      rateLimitEvidenceTest,+      toggleHostIndistinguishabilityTest,+      nonReasoningModelEvidenceTest,+      immediateErrorRecordsThinkingTest,+      defaultHostEndpointTest,+      responseIdCountsAsCorrelationTest,+      optOutTest+    ]++-- ============================================================+-- The cases+-- ============================================================++successEvidenceTest :: TestTree+successEvidenceTest =+  testCase "a replayed successful call records what the host reported" $ do+    ev <- oneEvidence =<< replayEvents 200 successHeaders successBody baseOptions+    field "status" ev @?= Just (String "succeeded")+    field "error_info" ev @?= Just Null+    field "run_id" ev @?= Just (String "run-54")++    -- The heart of it: requested and observed are different values, and+    -- the observed one came from the host's own chunks.+    field "requested_model" ev @?= Just (String (openai_gpt_4o_mini ^. #modelId))+    field "observed_model" ev @?= Just (observedJson "gpt-4o-mini-20990101-server-side")+    assertBool+      "observed_model must not be the configured model"+      (field "observed_model" ev /= Just (observedJson (openai_gpt_4o_mini ^. #modelId)))++    field "provider_request_id" ev @?= Just (observedJson "req_success_1")+    field "response_id" ev @?= Just (observedJson "chatcmpl-observed")+    -- Tied to the declaration mechanically: raising declaredStrength+    -- for this transport without the transport reaching it fails here.+    field "strength" ev @?= Just (Aeson.toJSON (declaredStrength OpenAIChatCompletions))++    -- No OpenAI-compatible host echoes the reasoning configuration it+    -- applied, so this transport cannot reach fully_observed and must+    -- not pretend a reasoning-token count is such an echo.+    field "observed_thinking" ev @?= Just (String "unobserved")++    assertDigest "request_commitment" ev+    assertDigest "request_configuration" ev+    case field "response_commitment" ev of+      Just (Object o) -> case KeyMap.lookup "observed" o of+        Just (String d) -> assertSha256 "response_commitment" d+        other -> assertFailure ("response_commitment not a digest: " <> show other)+      other -> assertFailure ("expected an observed response_commitment, got: " <> show other)++    -- Usage is Observed because the host reported it, and carries the+    -- fixture's counts rather than the assembler's initial zeroes.+    case field "usage" ev of+      Just (Object o) -> case KeyMap.lookup "observed" o of+        Just (Object u) -> do+          KeyMap.lookup "input_tokens" u @?= Just (Number 11)+          KeyMap.lookup "output_tokens" u @?= Just (Number 5)+        other -> assertFailure ("usage.observed not an object: " <> show other)+      other -> assertFailure ("expected an observed usage, got: " <> show other)++    -- The endpoint names this package's own version, read from the+    -- cabal-generated module, and carries no query string.+    case field "endpoint" ev of+      Just (Object o) -> do+        KeyMap.lookup "transport" o @?= Just (String "http_api")+        KeyMap.lookup "endpoint" o @?= Just (String "https://api.openai.com")+        case KeyMap.lookup "implementation_version" o of+          Just (String v) ->+            assertBool "implementation_version must not be empty" (not (Text.null v))+          other -> assertFailure ("expected an implementation_version, got: " <> show other)+      other -> assertFailure ("expected an endpoint object, got: " <> show other)++rateLimitEvidenceTest :: TestTree+rateLimitEvidenceTest =+  testCase "a replayed 429 records the correlation id and observes nothing else" $ do+    ev <-+      oneEvidence+        =<< replayEvents+          429+          [("x-request-id", "req_rate_limited"), ("Retry-After", "7")]+          ["{\"error\":{\"message\":\"slow down\",\"type\":\"tokens\"}}"]+          baseOptions+    field "status" ev @?= Just (String "failed")+    case field "error_info" ev of+      Just (Object o) ->+        assertBool+          ("expected the rate-limit message, got: " <> show o)+          (KeyMap.member "message" o)+      other -> assertFailure ("expected a populated error_info, got: " <> show other)++    -- The header is present on errors too, and it is the single most+    -- useful thing to have when opening a provider support request.+    field "provider_request_id" ev @?= Just (observedJson "req_rate_limited")++    -- Absent metadata stays absent. None of these is backfilled.+    field "observed_model" ev @?= Just (String "unobserved")+    field "response_id" ev @?= Just (String "unobserved")+    field "response_commitment" ev @?= Just (String "unobserved")+    field "usage" ev @?= Just (String "unobserved")+    field "strength" ev @?= Just (String "correlated")++    -- The same replay as a stream: an HTTP failure that arrives before+    -- the first chunk still begins with 'EventStart'.+    assertErrorContract+      =<< replayStreamEvents+        429+        [("x-request-id", "req_rate_limited"), ("Retry-After", "7")]+        ["{\"error\":{\"message\":\"slow down\",\"type\":\"tokens\"}}"]+        baseOptions++-- | Two calls a toggle host cannot tell apart, which baikai's record+-- can.+--+-- Z.ai and Qwen accept @enable_thinking: true@ and carry no depth, so a+-- caller asking for @max@ and a caller asking for @low@ put the same+-- bytes on the wire. Without the translation there is nothing anywhere+-- in baikai's output that distinguishes the two; with it, the request+-- each caller made is recorded beside the request that was actually+-- sent.+toggleHostIndistinguishabilityTest :: TestTree+toggleHostIndistinguishabilityTest =+  testCase "a toggle host receives identical bytes for max and for low" $ do+    (lowBody, lowEv) <- toggleCall ThinkingLow+    (maxBody, maxEv) <- toggleCall ThinkingMax++    Aeson.encode lowBody @?= Aeson.encode maxBody+    lookupIn "enable_thinking" lowBody @?= Just (Bool True)+    lookupIn "reasoning_effort" lowBody @?= Nothing++    thinkingOf lowEv "requested" @?= Just (String "low")+    thinkingOf maxEv "requested" @?= Just (String "max")+    thinkingOf lowEv "mode" @?= Just (String "toggle")+    thinkingOf lowEv "wire_field" @?= Just (String "enable_thinking")+    thinkingOf lowEv "effort_text" @?= Just Null++    collapsedLevels lowEv @?= ["low"]+    collapsedLevels maxEv @?= ["max"]+  where+    toggleCall lvl = do+      bodyRef <- newIORef Null+      events <-+        replayWith+          bodyRef+          toggleModel+          200+          successHeaders+          successBody+          (baseOptions & #thinking .~ Just lvl)+      ev <- oneEvidence events+      body <- readIORef bodyRef+      pure (body, ev)++    -- Every adjustment must be the collapse, and this returns the level+    -- each one names — so a run that recorded some other adjustment+    -- fails rather than quietly matching an empty list.+    collapsedLevels ev = case thinkingOf ev "adjustments" of+      Just (Array adjs) ->+        [ lvl+        | Object a <- Vector.toList adjs,+          KeyMap.lookup "kind" a == Just (String "effort_collapsed_to_toggle"),+          Just (String lvl) <- [KeyMap.lookup "requested" a]+        ]+      _ -> []++-- | A call refused before the request was built still records the level+-- the caller asked for, described by the adapter's own describer.+--+-- 'Transport.resolveKey' refuses an unknown host rather than reading an+-- environment variable, so 'prepareCall' fails with an AuthError+-- whatever the developer's shell holds, the adapter takes+-- 'immediateError', and the replay driver is never reached.+immediateErrorRecordsThinkingTest :: TestTree+immediateErrorRecordsThinkingTest =+  testCase "a call refused before the request was built still records the requested level" $ do+    bodyRef <- newIORef Null+    let model = testModel & #baseUrl .~ "https://unknown-host.example"+        opts =+          emptyOptions+            & #evidence .~ Just (evidenceRequest "run-54")+            & #thinking .~ Just ThinkingHigh+    ev <-+      oneEvidence+        =<< replayWith bodyRef model 200 successHeaders successBody opts+    field "status" ev @?= Just (String "failed")+    thinkingOf ev "requested" @?= Just (String "high")+    let described =+          describeThinkingShape (openaiCompletionsCompatFor model) (model ^. #reasoning) opts+        expectedMode = case Aeson.toJSON described of+          Object d -> KeyMap.lookup "mode" d+          _ -> Nothing+    thinkingOf ev "mode" @?= expectedMode+    assertBool+      "the mode must not collapse the request into absent"+      (thinkingOf ev "mode" /= Just (String "absent"))++-- | A model carrying no base URL still records the host the call went+-- to. See the Anthropic twin for why.+defaultHostEndpointTest :: TestTree+defaultHostEndpointTest =+  testCase "a call with no base URL records the default host it went to" $ do+    bodyRef <- newIORef Null+    ev <-+      oneEvidence+        =<< replayWith bodyRef (testModel & #baseUrl .~ "") 200 successHeaders successBody baseOptions+    case field "endpoint" ev of+      Just (Object e) -> KeyMap.lookup "endpoint" e @?= Just (String "https://api.openai.com")+      other -> assertFailure ("expected an endpoint identity, got: " <> show other)++-- | A host that names its model and its response id on every chunk but+-- sends no correlation header still reaches @model_observed@.+--+-- This is the shape the three drifted strength functions disagreed+-- about: the API copies looked only at the captured header, so such a+-- host landed at @requested_only@ — below a host that sent only a+-- header and named nothing. A response id locates the call in the+-- provider's own records, which is what correlation means.+responseIdCountsAsCorrelationTest :: TestTree+responseIdCountsAsCorrelationTest =+  testCase "A RESPONSE ID WITH NO HEADER STILL REACHES model_observed" $ do+    ev <- oneEvidence =<< replayEvents 200 [] successBody baseOptions+    field "provider_request_id" ev @?= Just (String "unobserved")+    field "response_id" ev @?= Just (observedJson "chatcmpl-observed")+    field "observed_model" ev @?= Just (observedJson "gpt-4o-mini-20990101-server-side")+    field "strength" ev @?= Just (String "model_observed")++optOutTest :: TestTree+optOutTest =+  testCase "a call that asked for no evidence emits none" $ do+    events <- replayEvents 200 successHeaders successBody emptyCallOptions+    [e | e@CallEvidence {} <- events] @?= []+    -- The call itself still succeeded and still traced normally.+    length [e | e@CallStarted {} <- events] @?= 1+    length [e | e@CallFinished {} <- events] @?= 1++-- ============================================================+-- Replay harness+-- ============================================================++-- | Run one recorded response through the real adapter and the real+-- trace path, and return every trace event it produced.+replayEvents :: Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [TraceEvent]+replayEvents status headers chunks opts = do+  sink <- newIORef Null+  replayWith sink testModel status headers chunks opts++-- | 'replayEvents' against an explicit model, recording the request body+-- the adapter handed to the transport.+replayWith ::+  IORef Value ->+  Model ->+  Int ->+  [(ByteString, ByteString)] ->+  [ByteString] ->+  Options ->+  IO [TraceEvent]+replayWith bodyRef model status headers chunks opts = do+  reg <- newProviderRegistry+  let driver = replayDriver bodyRef status headers chunks+      provider =+        apiProviderWith+          OpenAIChatCompletions+          (openaiChatStreamWith driver)+          (streamingComplete (openaiChatStreamWith driver))+          & #describeThinking .~ (\m opts' -> describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning) opts')+          & #strengthCeiling .~ (declaredStrength OpenAIChatCompletions)+  registerApiProviderWith reg provider+  (ref, sink) <- memorySink+  _ <-+    Stream.fold+      Fold.drain+      (withTraceStreamWith reg sink model emptyContext opts)+  reverse <$> readTVarIO ref++-- | The same recorded response, drained as the provider stream itself+-- rather than through the trace path.+--+-- The evidence cases assert what the record says; this asserts that the+-- stream carrying it was protocol-conformant. One replay cannot do both,+-- because 'withTraceStreamWith' hands back trace events, not stream+-- events.+replayStreamEvents ::+  Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [AssistantMessageEvent]+replayStreamEvents status headers chunks opts = do+  bodyRef <- newIORef Null+  Stream.toList+    (openaiChatStreamWith (replayDriver bodyRef status headers chunks) testModel emptyContext opts)++-- | A transport driver that serves a recorded response instead of+-- opening a socket, and records the request body it was given.+--+-- It goes through 'sseFromResponse', so the status classification,+-- header allow-list, and SSE frame decoding under test are the ones+-- production uses. Only 'HTTP.withResponse' is replaced.+replayDriver ::+  IORef Value -> Int -> [(ByteString, ByteString)] -> [ByteString] -> SseDriver+replayDriver bodyRef status headers chunks _env _headers body onMetadata onEvent = do+  writeIORef bodyRef body+  resp <- mkResponse status headers chunks+  sseFromResponse resp onMetadata onEvent++mkResponse ::+  Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader)+mkResponse status headers chunks = do+  ref <- newIORef chunks+  let bodyReader = do+        remaining <- readIORef ref+        case remaining of+          [] -> pure ""+          (x : xs) -> writeIORef ref xs >> pure x+  pure+    HTTP.Response+      { HTTP.responseStatus = mkStatus status "",+        HTTP.responseVersion = http11,+        HTTP.responseHeaders = [(CI.mk k, v) | (k, v) <- headers],+        HTTP.responseBody = bodyReader,+        HTTP.responseCookieJar = HTTP.createCookieJar [],+        HTTP.responseClose' = HTTP.ResponseClose (pure ()),+        HTTP.responseOriginalRequest = HTTP.defaultRequest,+        HTTP.responseEarlyHints = []+      }++memorySink :: IO (TVar [TraceEvent], TraceSink)+memorySink = do+  ref <- newTVarIO []+  let step () e = atomically (modifyTVar' ref (e :))+  pure (ref, TraceSink (Fold.foldlM' step (pure ())))++-- ============================================================+-- Fixtures+-- ============================================================++testModel :: Model+testModel =+  openai_gpt_4o_mini+    & #api .~ OpenAIChatCompletions+    & #baseUrl .~ "https://api.openai.com"++-- | The same model pinned to a host that accepts a bare thinking+-- toggle, which is the shape the indistinguishability case is about.+--+-- @reasoning@ is forced on: 'testModel' is @gpt-4o-mini@, which cannot+-- reason, and a level on such a model is now dropped before the host's+-- shape is consulted. The case is about the /host/ collapsing every+-- level onto one toggle, so it needs a model that reaches the host at+-- all. 'ShapeSpec.nonReasoningModelGateTest' covers the other half.+toggleModel :: Model+toggleModel =+  testModel+    & #reasoning .~ True+    & #compat+      .~ CompatOpenAICompletions+        defaultOpenAICompletionsCompat {thinkingFormat = ThinkingFormatZai}++-- | A literal key, so 'prepareCall' resolves one without reading the+-- environment. It never reaches the replayed response.+emptyCallOptions :: Options+emptyCallOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key")++baseOptions :: Options+baseOptions = emptyCallOptions & #evidence .~ Just (evidenceRequest "run-54")++successHeaders :: [(ByteString, ByteString)]+successHeaders = [("x-request-id", "req_success_1")]++-- | A complete successful stream whose reported model is deliberately+-- not any model in the catalog, so it cannot be confused with a+-- configured one.+successBody :: [ByteString]+successBody =+  [ "data: {\"id\":\"chatcmpl-observed\",\"object\":\"chat.completion.chunk\",",+    "\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[{\"index\":0,\"delta\":{\"content\":\"pong\"}}]}\n\n",+    "data: {\"id\":\"chatcmpl-observed\",\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"stop\"}]}\n\n",+    "data: {\"id\":\"chatcmpl-observed\",\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[],\"usage\":{\"prompt_tokens\":11,\"completion_tokens\":5}}\n\n",+    "data: [DONE]\n\n"+  ]++nonReasoningModelEvidenceTest :: TestTree+nonReasoningModelEvidenceTest =+  testCase "a level on a non-reasoning model is dropped and the record says so" $ do+    -- gpt-4o-mini cannot reason. Before this, a level on it put+    -- reasoning_effort on the wire and took a 400; now nothing is sent+    -- and the record names the drop, which is what+    -- docs/user/model-call-evidence.md has always promised baikai-wide.+    bodyRef <- newIORef Null+    events <-+      replayWith+        bodyRef+        testModel+        200+        successHeaders+        successBody+        (baseOptions & #thinking .~ Just ThinkingMax)+    ev <- oneEvidence events+    body <- readIORef bodyRef+    lookupIn "reasoning_effort" body @?= Nothing+    thinkingOf ev "mode" @?= Just (String "unsupported")+    thinkingOf ev "requested" @?= Just (String "max")+    thinkingOf ev "wire_field" @?= Just Null+    case thinkingOf ev "adjustments" of+      Just (Array adjustments) -> case Vector.toList adjustments of+        [Object a] -> do+          KeyMap.lookup "kind" a @?= Just (String "thinking_dropped_unsupported_model")+          KeyMap.lookup "requested" a @?= Just (String "max")+        other -> assertFailure ("expected exactly one adjustment, got: " <> show other)+      other -> assertFailure ("expected an adjustments array, got: " <> show other)++-- ============================================================+-- Assertions on the encoded record+-- ============================================================++oneEvidence :: [TraceEvent] -> IO ModelCallEvidence+oneEvidence events = case [ev | CallEvidence {evidence = ev} <- events] of+  [ev] -> pure ev+  other ->+    assertFailure+      ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show events)++field :: Text -> ModelCallEvidence -> Maybe Value+field k ev = lookupIn k (Aeson.toJSON ev)++lookupIn :: Text -> Value -> Maybe Value+lookupIn k = \case+  Object o -> KeyMap.lookup (Key.fromText k) o+  _ -> Nothing++thinkingOf :: ModelCallEvidence -> Text -> Maybe Value+thinkingOf ev k = field "thinking" ev >>= lookupIn k++-- | How 'Baikai.Evidence.Observed' encodes a present value.+observedJson :: Text -> Value+observedJson v = Object (KeyMap.singleton "observed" (String v))++assertDigest :: Text -> ModelCallEvidence -> IO ()+assertDigest k ev = case field k ev of+  Just (String d) -> assertSha256 k d+  other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other)++assertSha256 :: Text -> Text -> IO ()+assertSha256 k d =+  assertBool+    (Text.unpack k <> " must be a sha256 digest, got: " <> show d)+    ("sha256:" `Text.isPrefixOf` d && Text.length d == 71)++endpointEvidenceTest :: TestTree+endpointEvidenceTest = testCase "Astra text shaping and strict refusal agree with evidence" $ do+  bodyRef <- newIORef Null+  let model = chatRestrictedModel & #modelId .~ "renamed-astra"+      opts =+        baseOptions+          & #thinking .~ Just ThinkingMinimal+          & #temperature .~ Just 0.5+          & #topP .~ Just 0.9+          & #toolChoice .~ Just ToolChoiceAuto+  ev <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody opts+  body <- readIORef bodyRef+  lookupIn "reasoning_effort" body @?= Just (String "low")+  lookupIn "temperature" body @?= Nothing+  lookupIn "top_p" body @?= Nothing+  thinkingOf ev "effort_text" @?= Just (String "low")+  let described = describeThinkingShape (openaiCompletionsCompatFor model) True opts+  field "thinking" ev @?= Just (Aeson.toJSON described)+  described ^. #adjustments @?= [EffortClamped ThinkingMinimal "low", SamplingDroppedUnsupportedModel ["temperature", "top_p"]]+  samplingOnly <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody (opts & #thinking .~ Nothing)+  thinkingOf samplingOnly "adjustments" @?= Just (Aeson.toJSON [SamplingDroppedUnsupportedModel ["temperature", "top_p"]])+  writeIORef bodyRef Null+  let strict = opts & #evidence .~ Just (evidenceRequest "strict-astra" & #strictness .~ EvidenceRequired EvidenceRequestedOnly)+  refused <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody strict+  readIORef bodyRef >>= (@?= Null)+  field "status" refused @?= Just (String "failed")
+ test/LifecycleSpec.hs view
@@ -0,0 +1,235 @@+-- | What happens to the worker thread and the HTTP connection when the+-- consumer stops.+--+-- The driver below is the real 'sseFromResponse' over a fake response+-- whose body reader never ends and whose close hook is observable, so a+-- worker killed mid-read provably closes the response exactly as+-- production's @HTTP.withResponse@ bracket would.+--+-- "Baikai.Provider.Internal.StreamWorker" states the three cleanup+-- strengths these four cases pin: bounded read then eventual release on+-- abandonment, immediate release on cancellation, and a worker that+-- cannot strand its consumer however it dies.+module LifecycleSpec (tests) where++import Baikai+import Baikai.Models.Generated (openai_gpt_4o_mini, openai_gpt_6_astra)+import Baikai.Provider.Internal.StreamWorker (frameQueueCapacity)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver, openaiChatStreamWith)+import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith)+import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Control.Concurrent (forkIO, threadDelay, throwTo)+import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar)+import Control.Exception (AsyncException (ThreadKilled), SomeException, bracket, fromException, throwIO, try)+import Control.Lens ((&), (.~), (^.))+import Data.ByteString (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11)+import Streamly.Data.Stream (Stream)+import Streamly.Data.Stream qualified as Stream+import System.Mem (performMajorGC)+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "OpenAI worker lifecycle"+    [ backendTests "Chat lifecycle" chatBackend,+      backendTests "Responses lifecycle" responsesBackend+    ]++backendTests :: String -> Backend -> TestTree+backendTests title backend =+  testGroup+    title+    [ boundedReadTest backend,+      abandonedReleasesAfterGcTest backend,+      cancellationReleasesWithoutGcTest backend,+      workerDeathCannotStrandTest backend+    ]++data Backend = Backend+  { streamWith :: SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent,+    modelFor :: Model,+    initialFrame :: ByteString,+    nextFrame :: ByteString,+    eofMessage :: Text+  }++-- | The bound alone stops the socket read: no garbage collection and no+-- timer is involved. Before the frame queue the counter grew without+-- limit, because the worker drained an endless body into an unbounded+-- channel.+boundedReadTest :: Backend -> TestTree+boundedReadTest backend =+  testCase "a consumer that stops after three events stops the body reader within the queue bound" $ do+    reads' <- newIORef (0 :: Int)+    closedRef <- newIORef False+    events <-+      Stream.toList+        ( Stream.take+            3+            (streamWith backend (countingDriver backend reads' closedRef Nothing) (modelFor backend) emptyContext testOptions)+        )+    length events @?= 3+    settled <- awaitSettled reads'+    assertBool+      ("body reader should stop within the queue bound, read " <> show settled <> " frames")+      (settled <= fromIntegral frameQueueCapacity + 8)++-- | The eventual guarantee. Nothing runs at the moment a consumer walks+-- away; streamly's finaliser kills the worker at the next major+-- collection, and that is when the connection goes back.+abandonedReleasesAfterGcTest :: Backend -> TestTree+abandonedReleasesAfterGcTest backend =+  testCase "an abandoned stream releases its connection after a major GC" $ do+    reads' <- newIORef (0 :: Int)+    closedRef <- newIORef False+    _ <-+      Stream.toList+        ( Stream.take+            3+            (streamWith backend (countingDriver backend reads' closedRef Nothing) (modelFor backend) emptyContext testOptions)+        )+    released <- pollFor 100 50000 (performMajorGC >> readIORef closedRef)+    assertBool "an abandoned stream's connection is released at a major GC" released++-- | The immediate guarantee. The exception lands while the consumer is+-- inside the stream's step, which is inside the bracket, so streamly+-- runs the release synchronously.+cancellationReleasesWithoutGcTest :: Backend -> TestTree+cancellationReleasesWithoutGcTest backend =+  testCase "cancelling the consumer releases the connection without a GC" $ do+    reads' <- newIORef (0 :: Int)+    closedRef <- newIORef False+    gate <- newEmptyMVar+    outcome <- newEmptyMVar+    tid <-+      forkIO $ do+        r <-+          try+            ( Stream.toList+                (streamWith backend (countingDriver backend reads' closedRef (Just gate)) (modelFor backend) emptyContext testOptions)+            )+        putMVar outcome (r :: Either SomeException [AssistantMessageEvent])+    threadDelay 100000+    throwTo tid ThreadKilled+    released <- pollFor 100 10000 (readIORef closedRef)+    assertBool "cancellation releases the connection without a GC" released+    r <- takeMVar outcome+    case r of+      Left e | Just ThreadKilled <- fromException e -> pure ()+      other -> assertFailure ("expected the drained thread to die by ThreadKilled, got: " <> show (fmap length other))++-- | The queue's closed flag is set by the fork's own @finally@, so a+-- worker that dies by asynchronous exception still ends the stream.+-- Before the frame queue the consumer blocked until the runtime's+-- deadlock detector fired.+workerDeathCannotStrandTest :: Backend -> TestTree+workerDeathCannotStrandTest backend =+  testCase "an asynchronous exception in the worker still closes the channel" $ do+    let dyingDriver :: SseDriver+        dyingDriver _env _headers _body _onMetadata _onEvent = throwIO ThreadKilled+    got <-+      timeout+        2000000+        (Stream.toList (streamWith backend dyingDriver (modelFor backend) emptyContext testOptions))+    case got of+      Nothing -> assertFailure "a worker killed asynchronously left the consumer blocked"+      Just events -> case reverse events of+        -- 'errorInfo' is a 'Maybe': whether a stream error carries a+        -- typed error at all is itself worth asserting.+        (EventError p : _) ->+          fmap (^. #message) (p ^. #errorInfo) @?= Just (eofMessage backend)+        other -> assertFailure ("expected a terminal EventError, got: " <> show (take 1 other))++-- --------------------------------------------------------------------+-- Harness+-- --------------------------------------------------------------------++-- | A driver whose body reader is generated on demand and whose close+-- hook is observable. The bracket is the shape 'HTTP.withResponse' has,+-- so a worker killed mid-read closes the response as production would.+--+-- With a gate, the reader blocks forever from the fourth read on, which+-- is the state a cancelled consumer must be able to interrupt. Without+-- one, the body never ends, which is what makes the queue bound visible.+countingDriver :: Backend -> IORef Int -> IORef Bool -> Maybe (MVar ()) -> SseDriver+countingDriver backend reads' closedRef gate _env _headers _body onMetadata onEvent =+  bracket mkFakeResponse HTTP.responseClose $ \resp ->+    sseFromResponse resp onMetadata onEvent+  where+    mkFakeResponse =+      pure+        HTTP.Response+          { HTTP.responseStatus = mkStatus 200 "",+            HTTP.responseVersion = http11,+            HTTP.responseHeaders = [(CI.mk "x-request-id", "req-lifecycle")],+            HTTP.responseBody = bodyReader,+            HTTP.responseCookieJar = HTTP.createCookieJar [],+            HTTP.responseClose' = HTTP.ResponseClose (writeIORef closedRef True),+            HTTP.responseOriginalRequest = HTTP.defaultRequest,+            HTTP.responseEarlyHints = []+          }+    bodyReader = do+      n <- atomicModifyIORef' reads' (\k -> (k + 1, k))+      case gate of+        Just g | n >= 3 -> takeMVar g >> pure ""+        _ -> pure (if n == 0 then initialFrame backend else nextFrame backend)++-- | An endless stream of visible-text deltas.+contentFrame :: ByteString+contentFrame =+  "data: {\"id\":\"chatcmpl-lifecycle\",\"model\":\"gpt-lifecycle\","+    <> "\"choices\":[{\"index\":0,\"delta\":{\"content\":\"x\"}}]}\n\n"++-- | Poll the counter until it has not moved for four consecutive reads,+-- then report where it stopped. A counter that never settles fails the+-- caller's bound rather than hanging: the ceiling is generous and+-- finite.+awaitSettled :: IORef Int -> IO Int+awaitSettled ref = go (200 :: Int) (-1) (0 :: Int)+  where+    go 0 _ _ = readIORef ref+    go budget lastSeen stableFor = do+      threadDelay 50000+      n <- readIORef ref+      if n == lastSeen+        then if stableFor >= 3 then pure n else go (budget - 1) n (stableFor + 1)+        else go (budget - 1) n 0++pollFor :: Int -> Int -> IO Bool -> IO Bool+pollFor 0 _ _ = pure False+pollFor n delay act = do+  ok <- act+  if ok+    then pure True+    else threadDelay delay >> pollFor (n - 1) delay act++testModel :: Model+testModel =+  openai_gpt_4o_mini+    & #api .~ OpenAIChatCompletions+    & #baseUrl .~ "https://api.openai.com"++testOptions :: Options+testOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key")++chatBackend :: Backend+chatBackend = Backend openaiChatStreamWith testModel contentFrame contentFrame "openai stream ended without finish_reason"++responsesBackend :: Backend+responsesBackend =+  Backend+    openaiResponsesStreamWith+    openai_gpt_6_astra+    "data: {\"type\":\"response.output_item.added\",\"output_index\":0,\"item\":{\"type\":\"message\",\"id\":\"msg\",\"content\":[]}}\n\n"+    "data: {\"type\":\"response.output_text.delta\",\"output_index\":0,\"content_index\":0,\"item_id\":\"msg\",\"delta\":\"x\"}\n\n"+    "Responses stream ended without a terminal response"
test/Main.hs view
@@ -1,20 +1,37 @@ module Main (main) where  import Baikai+import Baikai.Agent+  ( AgentCapability (..),+    AgentCommand,+    AgentOutputFormat (..),+    AgentPromptTransport (..),+    AgentProvider (..),+    AgentRenderError (..),+    AgentRunRequest,+    agentRunRequest,+    agentSafety,+    renderAgentRenderError,+  ) import Baikai.Cost qualified as Cost import Baikai.Cost.Pricing (computeCost)-import Baikai.Provider.OpenAI.Api+import Baikai.Provider.OpenAI.Agent qualified as CodexAgent+import Baikai.Provider.OpenAI.Api (openaiChatStream)+import Baikai.Provider.OpenAI.Cli qualified as CodexCli+import Baikai.Provider.OpenAI.Interactive+import Baikai.Provider.OpenAI.Internal.Request (mapRequest)+import Baikai.Provider.OpenAI.Internal.Stream   ( RawChunk (..),     closeOpenStream,     emptyAssembler,-    openaiChatStream,     parseUsage,     rawUsageToUsage,     translate,   )-import Baikai.Provider.OpenAI.Cli qualified as CodexCli-import Baikai.Provider.OpenAI.Interactive-import Baikai.Provider.OpenAI.Internal.Request (mapRequest)+import Baikai.Provider.OpenAI.Shape (describeThinkingShape)+import BillingSpec qualified+import CliEvidenceSpec qualified+import Contract (assertErrorContract, assertOneErrorTerminal) import Control.Exception (bracket) import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson@@ -24,9 +41,18 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import ErrorClassSpec qualified+import EvidenceSpec qualified+import LifecycleSpec qualified+import MidStreamSpec qualified import OpenAI.V1.Chat.Completions qualified as Chat import OpenAI.V1.ResponseFormat qualified as RF+import PublicSurfaceSpec qualified import ReasoningSpec qualified+import ResponsesAssemblerSpec qualified+import ResponsesEvidenceSpec qualified+import ResponsesSpec qualified+import ResponsesStreamSpec qualified+import ResponsesTransportSpec qualified import ShapeSpec qualified import SseSpec qualified import Streamly.Data.Stream qualified as Stream@@ -35,7 +61,7 @@ import System.FilePath ((</>)) import System.Timeout (timeout) import Test.Tasty (TestTree, defaultMain, testGroup)-import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import TransportSpec qualified  main :: IO ()@@ -45,6 +71,20 @@       "Baikai.Provider.OpenAI"       [ commandRenderingTest,         effortRenderingTests,+        safetyRefusalTest,+        refusesRejectedApprovalPoliciesTest,+        safetyStillRendersTest,+        agentCommandRenderingTest,+        agentOutputFormatTest,+        agentCapabilityRenderingTests,+        agentEffortRenderingTests,+        agentThinkingTranslationTests,+        strictEvidenceTests,+        agentToolRestrictionRefusalTest,+        agentPromptTransportTest,+        agentBlankModelTest,+        agentConfigBooleanTest,+        agentProviderGuardTest,         batchCommandRenderingTest,         batchEffortRenderingTest,         batchSystemPromptTest,@@ -58,8 +98,19 @@         finishReasonTests,         responseFormatMappingTest,         optionsMappingTest,+        BillingSpec.tests,+        CliEvidenceSpec.tests,         ErrorClassSpec.tests,+        EvidenceSpec.tests,+        LifecycleSpec.tests,+        MidStreamSpec.tests,+        PublicSurfaceSpec.tests,         ReasoningSpec.tests,+        ResponsesAssemblerSpec.tests,+        ResponsesEvidenceSpec.tests,+        ResponsesSpec.tests,+        ResponsesStreamSpec.tests,+        ResponsesTransportSpec.tests,         ShapeSpec.tests,         SseSpec.tests,         TransportSpec.tests@@ -92,7 +143,7 @@         opts =           emptyOptions             & #responseFormat-              .~ Just (JsonSchema {name = "person", schema = personSchema, strict = True})+              .~ Just (JsonSchema (jsonSchemaFormat "person" personSchema) {strict = True})     case mapRequest model ctx opts of       Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e)       Right req -> case Chat.response_format req of@@ -114,7 +165,7 @@         opts =           emptyOptions             & #topP .~ Just 0.9-            & #stopSequences .~ Just (Vector.fromList ["END", "STOP"])+            & #stopSequences .~ ["END", "STOP"]             & #seed .~ Just 7             & #frequencyPenalty .~ Just 0.2             & #presencePenalty .~ Just 0.3@@ -215,6 +266,381 @@           cacheWriteCost = 5 / 4         } +-- | Render an unattended command or fail the test with the refusal's+-- own message.+renderedAgentCommand ::+  CodexAgent.CodexAgentConfig -> AgentRunRequest -> IO AgentCommand+renderedAgentCommand cfg req = fst <$> renderedAgentPair cfg req++-- | The command and the reasoning-effort translation the renderer+-- produced together.+renderedAgentPair ::+  CodexAgent.CodexAgentConfig ->+  AgentRunRequest ->+  IO (AgentCommand, ThinkingTranslation)+renderedAgentPair cfg req =+  either+    (assertFailure . Text.unpack . renderAgentRenderError)+    pure+    (CodexAgent.codexAgentCommand cfg req)++agentCommandRenderingTest :: TestTree+agentCommandRenderingTest =+  testCase "unattended codex argv renders every structured flag in a fixed order" $ do+    let cfg =+          CodexAgent.defaultCodexAgentConfig+            & #executable .~ "/bin/codex"+            & #extraArgs .~ ["--color", "never"]+        req =+          agentRunRequest AgentCodex "/work/project" "reconcile the grammar"+            & #modelId .~ Just "gpt-5.6-terra"+            & #effort .~ Just ThinkingMedium+            & #extraDirs .~ ["/work/shared"]+            & #safety .~ agentSafety AgentEditWorkspace+    cmd <- renderedAgentCommand cfg req+    cmd ^. #executable @?= "/bin/codex"+    cmd ^. #arguments+      @?= [ "exec",+            "--model",+            "gpt-5.6-terra",+            "-c",+            "model_reasoning_effort=medium",+            "--sandbox",+            "workspace-write",+            "--cd",+            "/work/project",+            "--add-dir",+            "/work/shared",+            "--skip-git-repo-check",+            "--ephemeral",+            "--color",+            "never"+          ]+    cmd ^. #promptTransport @?= PromptOnStdin+    cmd ^. #promptText @?= "reconcile the grammar"++-- | @codex exec --json@ prints its events as JSONL, which is the shape+-- the runner already parses; without it the tool prints a transcript+-- meant for a person and an evidence record can observe nothing.+agentOutputFormatTest :: TestTree+agentOutputFormatTest =+  testCase "unattended codex argv asks for structured events, and only when asked" $ do+    let base = agentRunRequest AgentCodex "/work/project" "reconcile the grammar"+    textual <- renderedAgentCommand CodexAgent.defaultCodexAgentConfig base+    textual ^. #arguments+      @?= [ "exec",+            "--sandbox",+            "read-only",+            "--cd",+            "/work/project",+            "--skip-git-repo-check",+            "--ephemeral"+          ]+    structured <-+      renderedAgentCommand CodexAgent.defaultCodexAgentConfig (base & #outputFormat .~ JsonFormat)+    structured ^. #arguments+      @?= [ "exec",+            "--json",+            "--sandbox",+            "read-only",+            "--cd",+            "/work/project",+            "--skip-git-repo-check",+            "--ephemeral"+          ]++agentCapabilityRenderingTests :: TestTree+agentCapabilityRenderingTests =+  testGroup+    "unattended codex argv maps every capability onto a sandbox mode"+    [ testCase name $ do+        let req =+              agentRunRequest AgentCodex "/work/project" "prompt"+                & #safety .~ agentSafety cap+        cmd <- renderedAgentCommand CodexAgent.defaultCodexAgentConfig req+        cmd ^. #arguments+          @?= [ "exec",+                "--sandbox",+                expected,+                "--cd",+                "/work/project",+                "--skip-git-repo-check",+                "--ephemeral"+              ]+    | (name, cap, expected) <-+        [ ("read-only", AgentReadOnly, "read-only"),+          ("edit-workspace as workspace-write", AgentEditWorkspace, "workspace-write"),+          ("full-access as danger-full-access", AgentFullAccess, "danger-full-access")+        ]+    ]++-- | Codex accepts all six canonical levels through its config+-- override, so nothing is clamped here — unlike Claude, whose+-- @--effort@ has no @minimal@ value. Pinning both sides stops someone+-- later \"unifying\" them.+agentEffortRenderingTests :: TestTree+agentEffortRenderingTests =+  testGroup+    "unattended codex argv passes every reasoning level through unclamped"+    [ testCase name $ do+        let req =+              agentRunRequest AgentCodex "/work/project" "prompt"+                & #effort .~ Just level+        cmd <- renderedAgentCommand CodexAgent.defaultCodexAgentConfig req+        cmd ^. #arguments+          @?= [ "exec",+                "-c",+                "model_reasoning_effort=" <> expected,+                "--sandbox",+                "read-only",+                "--cd",+                "/work/project",+                "--skip-git-repo-check",+                "--ephemeral"+              ]+    | (name, level, expected) <-+        [ ("minimal", ThinkingMinimal, "minimal"),+          ("low", ThinkingLow, "low"),+          ("medium", ThinkingMedium, "medium"),+          ("high", ThinkingHigh, "high"),+          ("xhigh", ThinkingXHigh, "xhigh"),+          ("max", ThinkingMax, "max")+        ]+    ]++-- | @codex exec@ has no tool allow-list flag, so a narrowed tool set is+-- refused rather than run with every tool available. The message must+-- name the alternative.+agentToolRestrictionRefusalTest :: TestTree+agentToolRestrictionRefusalTest =+  testCase "the codex renderer refuses a tool allow-list it cannot express" $ do+    let req =+          agentRunRequest AgentCodex "/work/project" "prompt"+            & #safety .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read", "Edit"])+    case CodexAgent.codexAgentCommand CodexAgent.defaultCodexAgentConfig req of+      Right (cmd, _) ->+        assertFailure ("expected a refusal, rendered: " <> show (cmd ^. #arguments))+      Left (UnsupportedToolRestriction provider message) -> do+        provider @?= AgentCodex+        assertBool+          ("expected the sandbox alternative in: " <> Text.unpack message)+          ("sandbox" `Text.isInfixOf` message)+      Left other ->+        assertFailure ("unexpected refusal: " <> Text.unpack (renderAgentRenderError other))++-- | The prompt travels on standard input, so a prompt that begins with+-- a dash cannot be parsed as a flag, and Codex's documented+-- @\<stdin\>@-block behavior — which appends piped input when a+-- positional prompt is also given — can never be triggered.+agentPromptTransportTest :: TestTree+agentPromptTransportTest =+  testCase "unattended codex argv never contains the prompt, even a dash-leading one" $ do+    let dashPrompt = "-rm -rf /"+        req =+          agentRunRequest AgentCodex "-/work/dashdir" dashPrompt+            & #extraDirs .~ ["-/work/dashshared"]+    cmd <- renderedAgentCommand CodexAgent.defaultCodexAgentConfig req+    assertBool+      ("prompt leaked into argv: " <> show (cmd ^. #arguments))+      (Text.unpack dashPrompt `notElem` cmd ^. #arguments)+    cmd ^. #promptText @?= dashPrompt+    cmd ^. #promptTransport @?= PromptOnStdin+    cmd ^. #arguments+      @?= [ "exec",+            "--sandbox",+            "read-only",+            "--cd",+            "-/work/dashdir",+            "--add-dir",+            "-/work/dashshared",+            "--skip-git-repo-check",+            "--ephemeral"+          ]++agentBlankModelTest :: TestTree+agentBlankModelTest =+  testCase "unattended codex argv omits --model for a blank model value" $ do+    let req =+          agentRunRequest AgentCodex "/work/project" "prompt"+            & #modelId .~ Just "   "+    cmd <- renderedAgentCommand CodexAgent.defaultCodexAgentConfig req+    cmd ^. #arguments+      @?= [ "exec",+            "--sandbox",+            "read-only",+            "--cd",+            "/work/project",+            "--skip-git-repo-check",+            "--ephemeral"+          ]++agentConfigBooleanTest :: TestTree+agentConfigBooleanTest =+  testCase "unattended codex argv omits the git-check and ephemeral flags when disabled" $ do+    let cfg =+          CodexAgent.defaultCodexAgentConfig+            & #skipGitRepoCheck .~ False+            & #ephemeral .~ False+        req = agentRunRequest AgentCodex "/work/project" "prompt"+    cmd <- renderedAgentCommand cfg req+    cmd ^. #arguments+      @?= ["exec", "--sandbox", "read-only", "--cd", "/work/project"]++-- | The unattended renderer describes what it did with the caller's+-- reasoning-effort request, and the description agrees with the argument+-- vector it produced.+--+-- Every level records an empty adjustment list, because codex is the one+-- tool baikai drives that accepts all six verbatim. That is worth+-- asserting precisely because every other transport clamps, collapses,+-- or drops something.+agentThinkingTranslationTests :: TestTree+agentThinkingTranslationTests =+  testGroup+    "the unattended codex renderer records what model_reasoning_effort received"+    ( testCase+        "no effort requested is not a downgrade"+        ( do+            (cmd, translation) <- renderedAgentPair CodexAgent.defaultCodexAgentConfig (effortRequest Nothing)+            assertBool+              ("no effort override is rendered: " <> show (cmd ^. #arguments))+              (not (any (Text.isInfixOf "model_reasoning_effort" . Text.pack) (cmd ^. #arguments)))+            translation @?= noThinkingRequested+        )+        : [ testCase (Text.unpack (renderThinkingLevel level)) $ do+              (cmd, translation) <-+                renderedAgentPair CodexAgent.defaultCodexAgentConfig (effortRequest (Just level))+              let override = "model_reasoning_effort=" <> Text.unpack (renderThinkingLevel level)+              assertBool+                ("-c " <> override <> " in " <> show (cmd ^. #arguments))+                (["-c", override] `isConsecutiveIn` (cmd ^. #arguments))+              translation+                @?= ThinkingTranslation+                  { requested = Just level,+                    mode = ThinkingModeFlag,+                    effortText = Just (renderThinkingLevel level),+                    budgetTokens = Nothing,+                    wireField = Just "model_reasoning_effort",+                    displayText = Nothing,+                    adjustments = []+                  }+          | level <-+              [ ThinkingMinimal,+                ThinkingLow,+                ThinkingMedium,+                ThinkingHigh,+                ThinkingXHigh,+                ThinkingMax+              ]+          ]+    )+  where+    effortRequest level =+      agentRunRequest AgentCodex "/work/project" "prompt" & #effort .~ level++-- | Whether the needle appears as consecutive elements of the haystack.+isConsecutiveIn :: (Eq a) => [a] -> [a] -> Bool+isConsecutiveIn needle haystack =+  any (\suffix -> needle == take (length needle) suffix) (suffixes haystack)+  where+    suffixes xs =+      xs : case xs of+        [] -> []+        (_ : rest) -> suffixes rest++-- | The pre-dispatch strictness gate, fed by this package's __real__+-- shaping function rather than by hand-built adjustments.+--+-- The generic gate is exhaustively covered in+-- @baikai/test/StrictEvidenceSpec.hs@; what only this package can prove+-- is that its own seven wire shapes actually reach the gate — and,+-- just as importantly, which of them do not.+strictEvidenceTests :: TestTree+strictEvidenceTests =+  testGroup+    "strict evidence refuses this provider's real downgrades"+    [ testCase "a non-native host clamping max to high is refused" $+        expectDowngrade+          (EffortClamped ThinkingMax "high")+          (shapeFor "https://api.deepseek.com" ThinkingMax),+      testCase "a toggle-only host is refused at every level, including max" $+        -- Z.ai accepts a bare enable_thinking with no depth, so a caller+        -- asking for max and a caller asking for low send byte-identical+        -- requests. Only the evidence can tell them apart, which is+        -- exactly what a strict caller is refusing to accept.+        expectDowngrade+          (EffortCollapsedToToggle ThinkingMax)+          (shapeFor "https://api.z.ai/api/paas/v4" ThinkingMax),+      testCase "a host with no reasoning controls is refused" $+        -- No host in the auto-detect table selects ThinkingFormatNone,+        -- so this shape is reachable only through an explicitly+        -- configured compat record. That is exactly the caller who most+        -- needs the refusal: they told baikai the host has no reasoning+        -- controls, and baikai would otherwise drop their level in+        -- silence.+        expectDowngrade+          (ThinkingDroppedUnsupportedHost ThinkingMax)+          ( describeThinkingShape+              (defaultOpenAICompletionsCompat {thinkingFormat = ThinkingFormatNone})+              True+              (emptyOptions & #thinking .~ Just ThinkingMax)+          ),+      testCase "THE NATIVE OPENAI SHAPE IS NOT A DOWNGRADE AND MUST NOT BE REFUSED" $ do+        -- The one OpenAI-compatible configuration that honours every+        -- level in full. It looks like a seventh downgrade site beside+        -- the six real ones, and refusing it would reject the caller+        -- baikai serves best. See plan 54's Decision Log.+        checkEvidenceRequirements+          (EvidenceRequired EvidenceModelObserved)+          (declaredStrength OpenAIChatCompletions)+          (shapeFor "https://api.openai.com/v1" ThinkingXHigh)+          @?= []+        checkEvidenceRequirements+          (EvidenceRequired EvidenceModelObserved)+          (declaredStrength OpenAIChatCompletions)+          (shapeFor "https://api.openai.com/v1" ThinkingMax)+          @?= [],+      testCase "the codex CLI expresses every level, so only its strength refuses" $ do+        -- Nothing is downgraded at any level, but codex names no model,+        -- so a caller requiring model_observed is refused on strength+        -- alone.+        checkEvidenceRequirements+          (EvidenceRequired EvidenceCorrelated)+          (declaredStrength OpenAICompletionsCli)+          (CodexCli.codexCliThinking (emptyOptions & #thinking .~ Just ThinkingMax))+          @?= []+        case checkEvidenceRequirements+          (EvidenceRequired EvidenceModelObserved)+          (declaredStrength OpenAICompletionsCli)+          (CodexCli.codexCliThinking (emptyOptions & #thinking .~ Just ThinkingMax)) of+          [StrengthUnreachable _ declared] -> declared @?= EvidenceCorrelated+          other -> assertFailure ("expected a strength refusal, got: " <> show other)+    ]+  where+    -- reasoning = True throughout: every case in this group is about+    -- what a /host/ shape does to a level. A model that cannot reason+    -- drops the level before the host is consulted at all, which+    -- ShapeSpec.nonReasoningModelGateTest covers separately.+    shapeFor url lvl =+      describeThinkingShape+        (openaiCompletionsCompatFor (emptyModel & #baseUrl .~ url & #api .~ OpenAIChatCompletions))+        True+        (emptyOptions & #thinking .~ Just lvl)+    expectDowngrade expected translation =+      case checkEvidenceRequirements+        (EvidenceRequired EvidenceRequestedOnly)+        (declaredStrength OpenAIChatCompletions)+        translation of+        [ThinkingWouldDowngrade [reported]] -> reported @?= expected+        other -> assertFailure ("expected one downgrade refusal, got: " <> show other)++agentProviderGuardTest :: TestTree+agentProviderGuardTest =+  testCase "the codex renderer refuses a request that names claude" $ do+    let req = agentRunRequest AgentClaude "/work/project" "prompt"+    fmap fst (CodexAgent.codexAgentCommand CodexAgent.defaultCodexAgentConfig req)+      @?= Left (ProviderMismatch AgentCodex AgentClaude)+ commandRenderingTest :: TestTree commandRenderingTest =   testCase "renders model, working directory, extra dirs, sandbox, approval, and extra args" $ do@@ -232,25 +658,125 @@             & #safety .~ CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest             & #extraArgs .~ ["--search"]     codexInteractiveCommand cfg req-      @?= ( "/bin/codex",-            [ "--model",-              "gpt-5-codex",-              "--cd",-              "/work/project",-              "--add-dir",-              "/work/shared",-              "--add-dir",-              "/work/docs",-              "--sandbox",-              "workspace-write",+      @?= Right+        ( "/bin/codex",+          [ "--model",+            "gpt-5-codex",+            "--cd",+            "/work/project",+            "--add-dir",+            "/work/shared",+            "--add-dir",+            "/work/docs",+            "--sandbox",+            "workspace-write",+            "--ask-for-approval",+            "on-request",+            "--no-alt-screen",+            "--search",+            "--",+            "System instructions:\nBe precise.\n\nUser request:\ninspect the repo"+          ]+        )++safetyRefusalTest :: TestTree+safetyRefusalTest =+  testCase "refuses a Claude tool allow-list instead of launching unrestricted" $ do+    let req =+          interactiveLaunchRequest "inspect the repo"+            & #safety .~ ClaudeAllowedTools ["Read"]+    case codexInteractiveCommand defaultCodexInteractiveConfig req of+      Right rendered -> assertFailure ("expected refusal, rendered: " <> show rendered)+      Left err -> do+        case err of+          SafetyNotExpressible p _ -> p @?= AgentCodex+          other -> assertFailure ("expected SafetyNotExpressible, got: " <> show other)+        let message = renderAgentRenderError err+        assertBool "names the provider" ("codex" `Text.isInfixOf` message)+        assertBool "names the rejected tools" ("Read" `Text.isInfixOf` message)+        assertBool "suggests an alternative" ("CodexSandbox" `Text.isInfixOf` message)++-- | An approval policy the installed CLI rejects is refused before a+-- process is created.+--+-- @codex --help@ at 0.149.1 lists exactly two possible values for+-- @--ask-for-approval@. Rendering @untrusted@ or @on-failure@ made the+-- CLI exit with a usage error, which reaches a caller as @Right@+-- carrying a non-zero exit code — a session that ran — rather than as+-- the refusal this module promises. The message has to name both the+-- value that was rejected and one that would work, because an operator+-- reading it is choosing a replacement.+refusesRejectedApprovalPoliciesTest :: TestTree+refusesRejectedApprovalPoliciesTest =+  testGroup+    "refuses the approval policies the installed codex CLI rejects"+    ( [ testCase (Text.unpack spelling) $ do+          let req =+                interactiveLaunchRequest "inspect the repo"+                  & #safety .~ CodexSandbox CodexReadOnly policy+          case codexInteractiveCommand defaultCodexInteractiveConfig req of+            Right rendered -> assertFailure ("expected refusal, rendered: " <> show rendered)+            Left err -> do+              case err of+                SafetyNotExpressible p _ -> p @?= AgentCodex+                other -> assertFailure ("expected SafetyNotExpressible, got: " <> show other)+              let message = renderAgentRenderError err+              assertBool+                ("names the rejected value: " <> Text.unpack message)+                (spelling `Text.isInfixOf` message)+              assertBool+                ("names a policy that works: " <> Text.unpack message)+                ("CodexApprovalOnRequest" `Text.isInfixOf` message)+      | (spelling, policy) <-+          [ ("untrusted", CodexApprovalUntrusted),+            ("on-failure", CodexApprovalOnFailure)+          ]+      ]+        <> [ testCase "an accepted policy still renders" $ do+               let req =+                     interactiveLaunchRequest "inspect"+                       & #safety .~ CodexSandbox CodexWorkspaceWrite CodexApprovalOnRequest+               fmap snd (codexInteractiveCommand defaultCodexInteractiveConfig req)+                 @?= Right+                   [ "--sandbox",+                     "workspace-write",+                     "--ask-for-approval",+                     "on-request",+                     "--",+                     "inspect"+                   ]+           ]+    )++-- | The fix refuses only what Codex cannot express. A sandbox policy is+-- expressible and must still render, and an empty allow-list restricts+-- nothing so it renders no safety flag rather than being refused.+safetyStillRendersTest :: TestTree+safetyStillRendersTest =+  testGroup+    "still renders every safety policy Codex can express"+    [ testCase "a sandbox policy" $ do+        let req =+              interactiveLaunchRequest "inspect"+                & #safety .~ CodexSandbox CodexReadOnly CodexApprovalNever+        fmap snd (codexInteractiveCommand defaultCodexInteractiveConfig req)+          @?= Right+            [ "--sandbox",+              "read-only",               "--ask-for-approval",-              "on-request",-              "--no-alt-screen",-              "--search",+              "never",               "--",-              "System instructions:\nBe precise.\n\nUser request:\ninspect the repo"-            ]-          )+              "inspect"+            ],+      testCase "an empty allow-list renders no safety flag" $ do+        let req = interactiveLaunchRequest "inspect" & #safety .~ ClaudeAllowedTools []+        fmap snd (codexInteractiveCommand defaultCodexInteractiveConfig req)+          @?= Right ["--", "inspect"],+      testCase "DefaultSafety renders no safety flag" $ do+        let req = interactiveLaunchRequest "inspect" & #safety .~ DefaultSafety+        fmap snd (codexInteractiveCommand defaultCodexInteractiveConfig req)+          @?= Right ["--", "inspect"]+    ]  effortRenderingTests :: TestTree effortRenderingTests =@@ -259,9 +785,10 @@     [ testCase name $ do         let req = interactiveLaunchRequest "prompt" & #effort .~ Just level         codexInteractiveCommand defaultCodexInteractiveConfig req-          @?= ( "codex",-                ["-c", "model_reasoning_effort=" <> expected, "--", "prompt"]-              )+          @?= Right+            ( "codex",+              ["-c", "model_reasoning_effort=" <> expected, "--", "prompt"]+            )     | (name, level, expected) <-         [ ("minimal", ThinkingMinimal, "minimal"),           ("low", ThinkingLow, "low"),@@ -455,26 +982,29 @@     [ testCase "content_filter terminates as EventError" $ do         let (_events1, ass1) =               translate-                (Right RawChunk {contentDelta = Just "partial", reasoningDelta = Nothing, finishReason = Nothing, toolDeltas = [], usage = Nothing})+                (Right RawChunk {contentDelta = Just "partial", reasoningDelta = Nothing, finishReason = Nothing, toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing})                 (emptyAssembler openaiTestModel (read "2026-06-05 00:00:00 UTC"))                 (read "2026-06-05 00:00:01 UTC")             (events2, ass2) =               translate-                (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "content_filter", toolDeltas = [], usage = Nothing})+                (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "content_filter", toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing})                 ass1                 (read "2026-06-05 00:00:02 UTC")             (events3, _) = closeOpenStream (read "2026-06-05 00:00:03 UTC") Nothing ass2         let terminalEvents = events2 <> events3-        assertErrorContract terminalEvents+        assertOneErrorTerminal terminalEvents         case last terminalEvents of           EventError TerminalPayload {errorInfo = Just be} -> do-            be ^. #category @?= OtherError+            -- Its own category, so a caller can branch on a filtered+            -- response without matching on the message text.+            be ^. #category @?= ContentFiltered+            isRetryable be @?= False             assertBool "message mentions content_filter" ("content_filter" `Text.isInfixOf` (be ^. #message))           other -> assertFailure ("expected EventError for content_filter, got: " <> show other),       testCase "unknown finish_reason is a successful diagnostic" $ do         let (_events, ass1) =               translate-                (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "mystery", toolDeltas = [], usage = Nothing})+                (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "mystery", toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing})                 (emptyAssembler openaiTestModel (read "2026-06-05 00:00:00 UTC"))                 (read "2026-06-05 00:00:01 UTC")             (terminalEvents, _) = closeOpenStream (read "2026-06-05 00:00:02 UTC") Nothing ass1@@ -499,15 +1029,6 @@     (const (unsetEnv name >> action))   where     restore = maybe (unsetEnv name) (setEnv name)--assertErrorContract :: [AssistantMessageEvent] -> Assertion-assertErrorContract events = do-  let terminals = filter isTerminal events-  length terminals @?= 1-  case terminals of-    [EventError TerminalPayload {errorInfo = Nothing}] ->-      assertFailure "terminal EventError omitted errorInfo"-    _ -> pure ()  assistantText :: Response -> Text.Text assistantText resp =
+ test/MidStreamSpec.hs view
@@ -0,0 +1,311 @@+-- | What the caller sees when a stream that started healthily stops+-- badly.+--+-- Every case here drives the real provider stream — @translate@, the+-- assembler, the worker's error path — over a body reader that raises+-- from @brRead@ after handing out the chunks it was given. That is+-- exactly what a socket reset, a server closing mid-chunk, and a TLS+-- session torn down after the handshake look like to the transport, and+-- it is the shape the classifier could not see before the shared core+-- rule: @http-client@ wraps the connect phase but not the body read, so+-- these exceptions reach the worker raw.+module MidStreamSpec (tests) where++import Baikai+  ( ApiKeySource (..),+    AssistantContent (..),+    AssistantMessageEvent (..),+    AssistantPayload (..),+    Message (..),+    Options,+    TerminalPayload (..),+    TextContent (..),+    emptyContext,+    emptyModel,+    emptyOptions,+  )+import Baikai.Api (Api (..))+import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable)+import Baikai.Model (Model)+import Baikai.Models.Generated (openai_gpt_4o_mini)+import Baikai.Provider.OpenAI.Api (openaiChatStream)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver, openaiChatStreamWith)+import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Contract (assertErrorContract)+import Control.Concurrent (forkIO, killThread)+import Control.Concurrent.MVar (newEmptyMVar, takeMVar, tryPutMVar)+import Control.Exception (SomeException, bracket, finally, handle, throwIO, toException)+import Control.Lens ((&), (.~), (^.))+import Data.ByteString (ByteString)+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Foreign.C.Error (Errno (..), 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.Socket qualified as Socket+import Network.TLS qualified as TLS+import Streamly.Data.Stream qualified as Stream+import System.Timeout qualified as Timeout+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "mid-stream failures (OpenAI-compatible)"+    [ testCase "a connection reset after two chunks ends with a retryable EventError carrying the partial text" $ do+        events <- drainFailing contentChunks (toException connectionReset)+        assertErrorContract events+        be <- terminalError events+        category be @?= TransientError+        assertBool "a mid-stream reset is retryable" (isRetryable be)+        assertBool+          ("the drained text survives the failure: " <> show events)+          ("Hel" `Text.isInfixOf` terminalText events),+      testCase "a chunked-encoding EOF classifies as TransientError" $ do+        events <-+          drainFailing+            contentChunks+            (toException (HTTP.HttpExceptionRequest HTTP.defaultRequest HTTP.InvalidChunkHeaders))+        assertErrorContract events+        be <- terminalError events+        category be @?= TransientError+        assertBool "a mid-chunk close is retryable" (isRetryable be),+      -- Raised raw, as it is from brRead: http-client installs no+      -- wrapper around the body reader that would convert it.+      testCase "a TLS termination mid-body classifies as TransientError" $ do+        events <- drainFailing contentChunks (toException (TLS.PostHandshake TLS.Error_EOF))+        assertErrorContract events+        be <- terminalError events+        category be @?= TransientError+        assertBool "a torn-down TLS session is retryable" (isRetryable be),+      testCase "a stalled socket is cut off by timeoutMs as TransientError" $ do+        (events, _) <- withStalledServer $ \port -> drainLive port (Just 200)+        assertErrorContract events+        be <- terminalError events+        category be @?= TransientError+        assertBool "a timed-out call is retryable" (isRetryable be)+        assertBool+          ("the message names the bound that fired: " <> show (be ^. #message))+          ("timeoutMs=200" `Text.isInfixOf` (be ^. #message)),+      testCase "timeoutMs of zero is rejected as InvalidRequest before any connection" $ do+        (events, accepted) <- withStalledServer $ \port -> drainLive port (Just 0)+        assertErrorContract events+        be <- terminalError events+        category be @?= InvalidRequest+        assertBool "a caller-side mistake is not retryable" (not (isRetryable be))+        accepted @?= 0,+      testCase "a negative timeoutMs is rejected as InvalidRequest" $ do+        (events, accepted) <- withStalledServer $ \port -> drainLive port (Just (-1))+        assertErrorContract events+        be <- terminalError events+        category be @?= InvalidRequest+        assertBool "a caller-side mistake is not retryable" (not (isRetryable be))+        accepted @?= 0,+      testCase "a programming error in the body path stays OtherError" $ do+        events <- drainFailing contentChunks (toException (userError "bug in callback"))+        assertErrorContract events+        be <- terminalError events+        category be @?= OtherError+        assertBool "a callback bug is not retryable" (not (isRetryable be)),+      -- An upstream failure the host only learned about after committing+      -- to a 200. It arrives on a healthy stream and must end the call+      -- with its own classification, not as+      -- OtherError "openai stream ended without finish_reason".+      testCase "an in-band error frame on a 2xx stream terminates with the frame's classification" $ do+        events <-+          drainReplay+            ( take 1 contentChunks+                <> [ "data: {\"error\":{\"message\":\"Provider returned error\",\"code\":502},\+                     \\"choices\":[{\"index\":0,\"finish_reason\":\"error\",\"delta\":{}}]}\n\n",+                     "data: [DONE]\n\n"+                   ]+            )+        assertErrorContract events+        be <- terminalError events+        category be @?= TransientError+        httpStatus be @?= Just 502+        be ^. #message @?= "Provider returned error"+        assertBool "an upstream 502 is retryable" (isRetryable be),+      testCase "an in-band insufficient_quota frame is AuthError and not retryable" $ do+        events <-+          drainReplay+            [ "data: {\"error\":{\"message\":\"You exceeded your current quota\",\+              \\"type\":\"insufficient_quota\",\"code\":\"insufficient_quota\"}}\n\n",+              "data: [DONE]\n\n"+            ]+        assertErrorContract events+        be <- terminalError events+        category be @?= AuthError+        assertBool "an exhausted quota is not retryable" (not (isRetryable be))+    ]++-- ============================================================+-- Fixtures+-- ============================================================++-- | Two ordinary content frames, @"Hel"@ then @"lo"@, with no+-- @finish_reason@: the stream is healthy right up to the failure.+contentChunks :: [ByteString]+contentChunks =+  [ "data: {\"id\":\"chatcmpl-1\",\"model\":\"gpt-4o-mini\",\"choices\":[{\"index\":0,\"delta\":{\"content\":\"Hel\"}}]}\n\n",+    "data: {\"id\":\"chatcmpl-1\",\"model\":\"gpt-4o-mini\",\"choices\":[{\"index\":0,\"delta\":{\"content\":\"lo\"}}]}\n\n"+  ]++-- | The canonical mid-stream reset: the peer sent RST while the+-- response body was still arriving.+connectionReset :: IOE.IOException+connectionReset =+  IOE.IOError+    { IOE.ioe_handle = Nothing,+      IOE.ioe_type = IOE.ResourceVanished,+      IOE.ioe_location = "Network.Socket.recvBuf",+      IOE.ioe_description = "Connection reset by peer",+      IOE.ioe_errno = Just (case eCONNRESET of Errno n -> n),+      IOE.ioe_filename = Nothing+    }++-- | Drain the provider stream over a body reader that yields @chunks@+-- and then raises @ex@ from the next @brRead@.+drainFailing :: [ByteString] -> SomeException -> IO [AssistantMessageEvent]+drainFailing chunks ex =+  Stream.toList (openaiChatStreamWith (failingDriver chunks ex) testModel emptyContext testOptions)++-- | Drain the provider stream over a body reader that ends normally,+-- for the frames that are themselves the failure.+drainReplay :: [ByteString] -> IO [AssistantMessageEvent]+drainReplay chunks =+  Stream.toList (openaiChatStreamWith (replayDriver chunks) testModel emptyContext testOptions)++replayDriver :: [ByteString] -> SseDriver+replayDriver chunks _env _headers _body onMetadata onEvent = do+  resp <- mkReplayResponse chunks+  sseFromResponse resp onMetadata onEvent++failingDriver :: [ByteString] -> SomeException -> SseDriver+failingDriver chunks ex _env _headers _body onMetadata onEvent = do+  resp <- mkFailingResponse chunks ex+  sseFromResponse resp onMetadata onEvent++-- | 'EvidenceSpec.mkResponse' with one difference: the exhausted branch+-- of the body reader raises instead of returning the empty string that+-- means end-of-body.+mkFailingResponse :: [ByteString] -> SomeException -> IO (HTTP.Response HTTP.BodyReader)+mkFailingResponse chunks ex = mkResponseWith chunks (throwIO ex)++-- | The ordinary recorded response: an empty read means end-of-body.+mkReplayResponse :: [ByteString] -> IO (HTTP.Response HTTP.BodyReader)+mkReplayResponse chunks = mkResponseWith chunks (pure "")++mkResponseWith :: [ByteString] -> IO ByteString -> IO (HTTP.Response HTTP.BodyReader)+mkResponseWith chunks onExhausted = do+  ref <- newIORef chunks+  let bodyReader = do+        remaining <- readIORef ref+        case remaining of+          [] -> onExhausted+          (x : xs) -> writeIORef ref xs >> pure x+  pure+    HTTPI.Response+      { HTTPI.responseStatus = mkStatus 200 "OK",+        HTTPI.responseVersion = http11,+        HTTPI.responseHeaders = [(CI.mk "content-type", "text/event-stream")],+        HTTPI.responseBody = bodyReader,+        HTTPI.responseCookieJar = HTTP.createCookieJar [],+        HTTPI.responseClose' = HTTPI.ResponseClose (pure ()),+        HTTPI.responseOriginalRequest = HTTP.defaultRequest,+        HTTPI.responseEarlyHints = []+      }++testModel :: Model+testModel =+  openai_gpt_4o_mini+    & #api .~ OpenAIChatCompletions+    & #baseUrl .~ "https://api.openai.com"++-- | A literal key so no environment variable is consulted.+testOptions :: Options+testOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key")++-- ============================================================+-- Assertions+-- ============================================================++terminalError :: [AssistantMessageEvent] -> IO BaikaiError+terminalError events = case reverse events of+  (EventError TerminalPayload {errorInfo = Just be} : _) -> pure be+  other -> assertFailure ("expected a terminal EventError carrying errorInfo, got: " <> show (take 1 other))++-- | The text the terminal message carries. This is where the drained+-- partial text has to survive: the assembler closes the blocks that+-- were open when the failure landed.+terminalText :: [AssistantMessageEvent] -> Text+terminalText events = case reverse events of+  (EventError TerminalPayload {message = AssistantMessage AssistantPayload {content = blocks}} : _) ->+    Text.concat [t | AssistantText TextContent {text = t} <- Vector.toList blocks]+  _ -> ""++-- ============================================================+-- A socket that never answers+-- ============================================================++-- | A TCP listener on @127.0.0.1@ that accepts one connection and holds+-- it open without ever reading or writing: an HTTP server that has+-- stalled after the connect succeeded.+--+-- Port @0@ asks the kernel for a free port, so the test never collides+-- with anything else on the machine or with a parallel run of itself.+-- The returned count is how many connections were accepted, which is+-- what proves a refused bound opened no socket at all.+withStalledServer :: (Int -> IO a) -> IO (a, Int)+withStalledServer body = bracket open Socket.close $ \listener -> do+  port <- Socket.socketPort listener+  accepted <- newIORef (0 :: Int)+  release <- newEmptyMVar+  acceptor <- forkIO . handle (\(_ :: SomeException) -> pure ()) $ do+    (conn, _) <- Socket.accept listener+    modifyIORef' accepted (+ 1)+    takeMVar release+    Socket.close conn+  result <- body (fromIntegral port) `finally` (tryPutMVar release () >> killThread acceptor)+  count <- readIORef accepted+  pure (result, count)+  where+    open = do+      s <- Socket.socket Socket.AF_INET Socket.Stream Socket.defaultProtocol+      Socket.setSocketOption s Socket.ReuseAddr 1+      Socket.bind s (Socket.SockAddrInet 0 (Socket.tupleToHostAddress (127, 0, 0, 1)))+      Socket.listen s 1+      pure s++-- | Drain the /live/ stream against a local port, under a guard that+-- turns a stuck run into a failure rather than a hung suite.+drainLive :: Int -> Maybe Int -> IO [AssistantMessageEvent]+drainLive port bound = do+  let model = stallModel port+      opts = testOptions & #timeoutMs .~ bound+  result <- Timeout.timeout 10_000_000 (Stream.toList (openaiChatStream model emptyContext opts))+  case result of+    Just events -> pure events+    Nothing -> assertFailure "the ten-second guard fired: timeoutMs never did"++-- | A model pointed at the local listener. Built from 'emptyModel' so no+-- catalog base URL can override the port under test.+stallModel :: Int -> Model+stallModel port =+  emptyModel+    & #modelId+      .~ "stall-test"+    & #provider+      .~ "test"+    & #api+      .~ OpenAIChatCompletions+    & #baseUrl+      .~ Text.pack ("http://127.0.0.1:" <> show port)
+ test/PublicSurfaceSpec.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | A downstream consumer's view of @baikai-openai@, compiled.+--+-- Imports only the four public modules — no @.Internal@, no+-- @Baikai.Prelude@, no lens — and builds everything a consumer builds.+-- The compilation is the test: a name that stops being exported, or a+-- record that can no longer be built without its constructor, fails the+-- build here rather than at a consumer.+module PublicSurfaceSpec (tests) where++import Baikai+import Baikai.Agent (AgentCommand (executable), AgentProvider (AgentCodex), agentRunRequest)+import Baikai.Provider.OpenAI.Agent qualified as Agent+import Baikai.Provider.OpenAI.Api qualified as Api+import Baikai.Provider.OpenAI.Cli qualified as Cli+import Baikai.Provider.OpenAI.Interactive qualified as Interactive+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "public surface (baikai-openai)"+    [ testCase "the provider values carry their API tags" $ do+        Api.openaiChatProvider.apiTag @?= OpenAIChatCompletions+        (Cli.codexCliProvider Cli.defaultCodexCliConfig).apiTag @?= OpenAICompletionsCli,+      testCase "the interactive launcher renders a command without running one" $+        case Interactive.codexInteractiveCommand+          Interactive.defaultCodexInteractiveConfig+          (interactiveLaunchRequest "look around") of+          Left refusal -> assertRefusalIsUnexpected refusal+          Right (executable, _args) -> executable @?= "codex",+      testCase "the unattended renderer renders a command without running one" $+        case Agent.codexAgentCommand+          Agent.defaultCodexAgentConfig+          (agentRunRequest AgentCodex "." "summarise") of+          Left refusal -> assertRefusalIsUnexpected refusal+          Right (cmd, _translation) -> cmd.executable @?= "codex"+    ]+  where+    assertRefusalIsUnexpected refusal =+      fail ("expected a rendered command, got a refusal: " <> show refusal)
test/ReasoningSpec.hs view
@@ -4,22 +4,32 @@  import Baikai import Baikai.Models.Generated-import Baikai.Provider.OpenAI.Api+import Baikai.Provider.OpenAI.Internal.Request (mapRequest)+import Baikai.Provider.OpenAI.Internal.Stream   ( RawChunk (..),     closeOpenStream,     emptyAssembler,+    emptyTagScanState,     parseChunk,+    parseFrame,     scanThinkTags,     translate,-    _TagScanState,   )-import Baikai.Provider.OpenAI.Internal.Request (mapRequest)-import Control.Lens ((&), (.~))+import Baikai.Provider.OpenAI.Shape (describeThinkingShape)+import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as LBS import Data.Generics.Labels ()+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector+import EndpointModels (chatRestrictedModel)+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11) import OpenAI.V1.Chat.Completions qualified as Chat import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=))@@ -28,7 +38,20 @@ tests =   testGroup     "ReasoningSpec"-    [ parseReasoningTests,+    [ testCase "foreign opaque reasoning cannot enter this endpoint" $ do+        let thought = emptyThinkingContent & #replayState .~ Just (ThinkingReplay OpenAIResponses "gpt-6-astra" (Vector.singleton (Aeson.object [])))+            response = emptyResponse & #message . #content .~ Vector.singleton (AssistantThinking thought)+            ctx = addResponse response emptyContext+        case mapRequest openai_gpt_4o_mini ctx emptyOptions of+          Left _ -> pure ()+          Right _ -> assertFailure "foreign state was silently accepted",+      testCase "minimal maps upward by catalog policy with adjustment evidence" $ do+        let model = chatRestrictedModel & #modelId .~ "renamed-policy-test"+            opts = emptyOptions & #thinking .~ Just ThinkingMinimal+            described = describeThinkingShape (openaiCompletionsCompatFor model) True opts+        described ^. #effortText @?= Just "low"+        described ^. #adjustments @?= [EffortClamped ThinkingMinimal "low"],+      parseReasoningTests,       assemblyTests,       tagScannerTests,       taggedTextCompatTest,@@ -79,48 +102,132 @@                 ThinkingContent                   { thinking = "because therefore",                     signature = Nothing,-                    redacted = False+                    redacted = False,+                    replayState = Nothing                   },               AssistantText (TextContent "answer done")             ],-      testCase "whole message shape yields reasoning then text" $ do-        let raw =-              Aeson.object-                [ "choices"-                    Aeson..= [ Aeson.object-                                 [ "message"-                                     Aeson..= Aeson.object-                                       [ "reasoning_content" Aeson..= ("because" :: Text.Text),-                                         "content" Aeson..= ("answer" :: Text.Text)-                                       ],-                                   "finish_reason" Aeson..= ("stop" :: Text.Text)-                                 ]-                             ]-                ]-        chunk <- either (assertFailure . ("parse failed: " <>)) pure (parseChunk raw)-        terminalContent (runChunks deepseek_deepseek_reasoner [chunk])+      testCase "reasoning after visible text closes the text block first" $ do+        -- The other half of the same rule: opening a thinking block+        -- closes an open text block, so at most one of the two is open+        -- at a time and every _End precedes the next _Start. Before+        -- this, reasoning opened at index 1 while text stayed open at+        -- 0, and the later text delta landed back on 0 -- two blocks+        -- open at once and an index revisited after a later one.+        let chunks =+              [ emptyChunk {contentDelta = Just "a"},+                emptyChunk {reasoningDelta = Just "r"},+                emptyChunk {contentDelta = Just "b"},+                emptyChunk {finishReason = Just "stop"}+              ]+            events = runChunks deepseek_deepseek_reasoner chunks+        eventShape events+          @?= [ "TextStart:0",+                "TextDelta:0:a",+                "TextEnd:0:a",+                "ThinkingStart:1",+                "ThinkingDelta:1:r",+                "ThinkingEnd:1:r",+                "TextStart:2",+                "TextDelta:2:b",+                "TextEnd:2:b",+                "EventDone"+              ],+      -- Driven through the transport rather than handed straight to+      -- 'parseChunk', because a `data:` frame is the only way this+      -- object can reach the assembler: a whole-message shape on a+      -- streaming endpoint is what a compatible host sends when it+      -- ignores `stream: true`, and it still arrives framed.+      testCase "a data frame carrying a whole message object yields reasoning then text" $ do+        chunks <- transportChunks [dataFrame wholeMessageObject, "data: [DONE]\n\n"]+        terminalContent (runChunks deepseek_deepseek_reasoner chunks)           @?= Vector.fromList             [ AssistantThinking                 ThinkingContent                   { thinking = "because",                     signature = Nothing,-                    redacted = False+                    redacted = False,+                    replayState = Nothing                   },               AssistantText (TextContent "answer")-            ]+            ],+      -- The honest statement of the transport's limitation: an SSE+      -- transport decodes frames, so a bare JSON body with no @data:@+      -- prefix reaches nothing at all. Pretending 'parseMessageObject'+      -- is reachable for such a body would be pretending.+      testCase "a bare JSON body with no data prefix is not decoded" $ do+        chunks <- transportChunks [LBS.toStrict (Aeson.encode wholeMessageObject)]+        length chunks @?= 0     ] +-- | The shape a compatible host sends when it answers a streaming+-- request with a whole message instead of deltas.+wholeMessageObject :: Aeson.Value+wholeMessageObject =+  Aeson.object+    [ "choices"+        Aeson..= [ Aeson.object+                     [ "message"+                         Aeson..= Aeson.object+                           [ "reasoning_content" Aeson..= ("because" :: Text.Text),+                             "content" Aeson..= ("answer" :: Text.Text)+                           ],+                       "finish_reason" Aeson..= ("stop" :: Text.Text)+                     ]+                 ]+    ]++dataFrame :: Aeson.Value -> ByteString+dataFrame v = "data: " <> LBS.toStrict (Aeson.encode v) <> "\n\n"++-- | Push a recorded 200 body through the real 'sseFromResponse' and the+-- real 'parseFrame', which is the pair the worker runs.+transportChunks :: [ByteString] -> IO [RawChunk]+transportChunks body = do+  eventsRef <- newIORef []+  resp <- mkResponse 200 body+  sseFromResponse resp (const (pure ())) (\ev -> modifyIORef' eventsRef (<> [ev]))+  events <- readIORef eventsRef+  traverse decodeOne [v | Right v <- events]+  where+    decodeOne v = case parseFrame v of+      Right (Right chunk) -> pure chunk+      Right (Left be) -> assertFailure ("expected a chunk, got a classified error: " <> show be)+      Left err -> assertFailure ("parse failed: " <> err)++-- | The same fixture shape both 'SseSpec' and 'EvidenceSpec' keep, so+-- neither suite can silently change another's response.+mkResponse :: Int -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader)+mkResponse status chunks = do+  ref <- newIORef chunks+  let bodyReader = do+        remaining <- readIORef ref+        case remaining of+          [] -> pure ""+          (x : xs) -> writeIORef ref xs >> pure x+  pure+    HTTP.Response+      { HTTP.responseStatus = mkStatus status "",+        HTTP.responseVersion = http11,+        HTTP.responseHeaders = [],+        HTTP.responseBody = bodyReader,+        HTTP.responseCookieJar = HTTP.createCookieJar [],+        HTTP.responseClose' = HTTP.ResponseClose (pure ()),+        HTTP.responseOriginalRequest = HTTP.defaultRequest,+        HTTP.responseEarlyHints = []+      }+ tagScannerTests :: TestTree tagScannerTests =   testGroup     "scanThinkTags"     [ testCase "split tags across deltas" $ do-        let (st1, p1) = scanThinkTags _TagScanState "<th"+        let (st1, p1) = scanThinkTags emptyTagScanState "<th"             (st2, p2) = scanThinkTags st1 "ink>reasoning</thi"             (_st3, p3) = scanThinkTags st2 "nk>answer"         p1 <> p2 <> p3 @?= [Left "reasoning", Right "answer"],       testCase "literal less-than text passes through" $ do-        let (_st, parts) = scanThinkTags _TagScanState "2 < 3"+        let (_st, parts) = scanThinkTags emptyTagScanState "2 < 3"         parts @?= [Right "2 < 3"]     ] @@ -146,7 +253,8 @@             ThinkingContent               { thinking = "reasoning",                 signature = Nothing,-                redacted = False+                redacted = False,+                replayState = Nothing               },           AssistantText (TextContent "answer")         ]@@ -165,7 +273,8 @@                         ThinkingContent                           { thinking = "internal",                             signature = Nothing,-                            redacted = False+                            redacted = False,+                            replayState = Nothing                           },                       AssistantText (TextContent "visible")                     ],@@ -208,7 +317,10 @@       reasoningDelta = Nothing,       finishReason = Nothing,       toolDeltas = [],-      usage = Nothing+      usage = Nothing,+      model = Nothing,+      serviceTier = Nothing,+      responseId = Nothing     }  runChunks :: Model -> [RawChunk] -> [AssistantMessageEvent]
+ test/ResponsesAssemblerSpec.hs view
@@ -0,0 +1,153 @@+{-# LANGUAGE OverloadedRecordDot #-}++module ResponsesAssemblerSpec (tests) where++import Baikai.Content qualified as C+import Baikai.Provider.OpenAI.Responses.Assembler qualified as A+import Baikai.StopReason (StopReason (..))+import Baikai.Stream.Event qualified as E+import Control.Monad (foldM)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.Key (Key)+import Data.Text (Text)+import Data.Vector qualified as V+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Responses assembler"+    [ testCase "streams text immediately and reconciles snapshots without duplication" $ do+        (s, events) <- run [added 0 (message ""), textDelta 0 0 "hello"]+        events @?= [E.TextStart (E.IndexPayload 0), E.TextDelta (E.DeltaPayload 0 "hello")]+        (done, rest) <- step (completed [message "hello world"]) s+        rest @?= [E.TextDelta (E.DeltaPayload 0 " world"), E.TextEnd (E.BlockEndPayload 0 "hello world")]+        A.assembledContent done @?= V.singleton (C.AssistantText (C.TextContent "hello world"))+        A.terminalReason done @?= Just Stop+        (_, again) <- step (completed [message "hello world"]) done+        again @?= [],+      testCase "parallel function calls retain call IDs and serialize blocks" $ do+        (s, events) <-+          run+            [ added 0 (call "item_a" "call_a" "" "in_progress"),+              added 1 (call "item_b" "call_b" "" "in_progress"),+              argDelta 1 "item_b" "{\"b\":2}",+              argDelta 0 "item_a" "{\"a\":1}",+              itemDone 1 (call "item_b" "call_b" "{\"b\":2}" "completed"),+              itemDone 0 (call "item_a" "call_a" "{\"a\":1}" "completed"),+              completed [call "item_a" "call_a" "{\"a\":1}" "completed", call "item_b" "call_b" "{\"b\":2}" "completed"]+            ]+        A.terminalReason s @?= Just ToolUse+        A.assembledContent s+          @?= V.fromList+            [C.AssistantToolCall (C.ToolCall "call_a" "lookup" (object ["a" .= (1 :: Int)])), C.AssistantToolCall (C.ToolCall "call_b" "lookup" (object ["b" .= (2 :: Int)]))]+        [n | E.ToolCallStart (E.IndexPayload n) <- events] @?= [0, 1]+        [n | E.ToolCallEnd (E.ToolCallEndPayload n _) <- events] @?= [0, 1]+        assertBool "second block waits for first end" (case drop 2 events of E.ToolCallEnd _ : E.ToolCallStart _ : _ -> True; _ -> False),+      testCase "empty summary retains the entire encrypted reasoning item" $ do+        (s, _) <- run [added 0 reasoningAdded, itemDone 0 reasoning, completed [reasoning]]+        case V.toList (A.assembledContent s) of+          [C.AssistantThinking t] -> do+            t.thinking @?= ""+            fmap (.replayItems) t.replayState @?= Just (V.singleton reasoning)+            fmap (.replayModel) t.replayState @?= Just "configured-model"+          _ -> assertFailure "missing thinking block",+      testCase "later content parts wait for earlier parts and final snapshots fill gaps" $ do+        (s, _) <- run [added 0 (message ""), textDelta 0 1 "second", textDelta 0 0 "first"]+        let final = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [part "first", part "second"]]+        (done, events) <- step (completed [final]) s+        events @?= [E.TextDelta (E.DeltaPayload 0 "second"), E.TextEnd (E.BlockEndPayload 0 "firstsecond")]+        A.assembledContent done @?= V.singleton (C.AssistantText (C.TextContent "firstsecond")),+      testCase "interrupted parseable function prefix stays cut off" $ do+        (s, _) <- run [added 0 (call "item_a" "call_a" "" "in_progress"), argDelta 0 "item_a" "{}"]+        let (closed, _) = A.closePartial s+        A.assembledContent closed @?= V.singleton (C.AssistantToolCall (C.ToolCall "call_a" "lookup" (String "{}"))),+      testCase "incomplete response does not turn a truncated call into executable JSON" $ do+        let item = call "item_a" "call_a" "{}" "incomplete"+        (s, _) <- run [frame "response.incomplete" ["response" .= object ["output" .= [item], "incomplete_details" .= object ["reason" .= ("max_output_tokens" :: Text)]]]]+        A.terminalReason s @?= Just Length+        A.assembledContent s @?= V.singleton (C.AssistantToolCall (C.ToolCall "call_a" "lookup" (String "{}"))),+      testCase "contradictory snapshots and wrong item identities fail" $ do+        (s, _) <- run [added 0 (message ""), textDelta 0 0 "prefix"]+        rejects (completed [message "replacement"]) s+        rejects (argDelta 0 "wrong" "secret") s+        rejects (added 1 (message "")) s,+      testCase "part done snapshots and item done snapshots never repeat text" $ do+        let textDone = frame "response.output_text.done" ["output_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "content_index" .= (0 :: Int), "text" .= ("hello" :: Text)]+        (s, events) <- run [added 0 (message ""), textDelta 0 0 "hel", textDone, textDone, itemDone 0 (message "hello"), completed [message "hello"]]+        [t | E.TextDelta (E.DeltaPayload _ t) <- events] @?= ["hel", "lo"]+        A.terminalReason s @?= Just Stop,+      testCase "reasoning summaries stream while encrypted state stays out of deltas" $ do+        let summary = object ["type" .= ("summary_text" :: Text), "text" .= ("consider" :: Text)]+            raw = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= [summary], "encrypted_content" .= ("opaque" :: Text)]+            d = frame "response.reasoning_summary_text.delta" ["output_index" .= (0 :: Int), "item_id" .= ("rs" :: Text), "summary_index" .= (0 :: Int), "delta" .= ("consider" :: Text)]+        (s, events) <- run [added 0 reasoningAdded, d, completed [raw]]+        [t | E.ThinkingDelta (E.DeltaPayload _ t) <- events] @?= ["consider"]+        case V.toList (A.assembledContent s) of+          [C.AssistantThinking t] -> fmap (.replayItems) t.replayState @?= Just (V.singleton raw)+          _ -> assertFailure "missing summary",+      testCase "partial text closes with its observed prefix" $ do+        (s, _) <- run [added 0 (message ""), textDelta 0 0 "partial"]+        let (closed, events) = A.closePartial s+        events @?= [E.TextEnd (E.BlockEndPayload 0 "partial")]+        A.assembledContent closed @?= V.singleton (C.AssistantText (C.TextContent "partial"))+        let (_, repeated) = A.closePartial closed+        repeated @?= [],+      testCase "terminal retains exact observed usage including absent cache-write field" $ do+        let raw = object ["id" .= ("r" :: Text), "model" .= ("observed" :: Text), "output" .= [message "ok"], "usage" .= object ["input_tokens" .= (20 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (10 :: Int)]]]+        (s, _) <- run [frame "response.completed" ["response" .= raw]]+        A.observedResponse s @?= Just raw,+      testCase "duplicate call IDs cannot masquerade as separate tool calls" $ do+        (s, _) <- run [added 0 (call "item_a" "same_call" "" "in_progress")]+        rejects (added 1 (call "item_b" "same_call" "" "in_progress")) s+        rejects (completed [call "item_a" "same_call" "{}" "completed", call "item_b" "same_call" "{}" "completed"]) s,+      testCase "successful reasoning must carry replayable continuation" $ do+        rejects (completed [reasoningAdded]) (A.emptyAssembler "m"),+      testCase "failure and malformed frames remain failures" $ do+        mapM_+          (\f -> rejects f (A.emptyAssembler "m"))+          [frame "response.failed" [], frame "error" [], object [], added (-1) (message ""), completed [object ["type" .= ("web_search_call" :: Text), "id" .= ("w" :: Text)]]]+    ]++run :: [Value] -> IO (A.Assembler, [E.AssistantMessageEvent])+run = foldM (\(s, es) f -> do (next, events) <- step f s; pure (next, es <> events)) (A.emptyAssembler "configured-model", [])++step :: Value -> A.Assembler -> IO (A.Assembler, [E.AssistantMessageEvent])+step f s = either (\e -> assertFailure (show e) >> fail "assembly failed") pure (A.advance f s)++rejects :: Value -> A.Assembler -> IO ()+rejects f s = case A.advance f s of Left _ -> pure (); Right _ -> assertFailure "expected schema rejection"++frame :: Text -> [(Key, Value)] -> Value+frame t fields = object (("type" .= t) : fields)++added :: Int -> Value -> Value+added n item = frame "response.output_item.added" ["output_index" .= n, "item" .= item]++itemDone :: Int -> Value -> Value+itemDone n item = frame "response.output_item.done" ["output_index" .= n, "item" .= item]++completed :: [Value] -> Value+completed items = frame "response.completed" ["response" .= object ["id" .= ("resp" :: Text), "model" .= ("observed-model" :: Text), "output" .= items]]++part :: Text -> Value+part t = object ["type" .= ("output_text" :: Text), "text" .= t]++message :: Text -> Value+message t = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [part t]]++textDelta :: Int -> Int -> Text -> Value+textDelta n p t = frame "response.output_text.delta" ["output_index" .= n, "item_id" .= ("msg" :: Text), "content_index" .= p, "delta" .= t]++call :: Text -> Text -> Text -> Text -> Value+call ident callId args status = object ["type" .= ("function_call" :: Text), "id" .= ident, "call_id" .= callId, "name" .= ("lookup" :: Text), "arguments" .= args, "status" .= status]++argDelta :: Int -> Text -> Text -> Value+argDelta n ident t = frame "response.function_call_arguments.delta" ["output_index" .= n, "item_id" .= ident, "delta" .= t]++reasoningAdded :: Value+reasoningAdded = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value])]++reasoning :: Value+reasoning = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("opaque" :: Text), "future_field" .= object ["keep" .= True]]
+ test/ResponsesEvidenceSpec.hs view
@@ -0,0 +1,187 @@+{-# LANGUAGE OverloadedRecordDot #-}++module ResponsesEvidenceSpec (tests) where++import Baikai hiding (describeThinking, model)+import Baikai.Models.Generated (openai_gpt_6_astra)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver)+import Baikai.Provider.OpenAI.Responses.Request (describeThinking)+import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith)+import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Baikai.Trace (withTraceStreamWith)+import Baikai.Trace.Event qualified as Trace+import Baikai.Trace.Sink (TraceSink (..))+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (bracket, finally)+import Control.Lens ((&), (.~))+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson qualified as Aeson+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Vector qualified as V+import Network.HTTP.Client.Internal qualified as HTTP+import Network.HTTP.Types.Status (mkStatus)+import Network.HTTP.Types.Version (http11)+import Streamly.Data.Fold qualified as Fold+import Streamly.Data.Stream qualified as Stream+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Responses strict evidence over SSE bytes"+    [ testCase "strict success observes host facts and commits exact request and replay" $ do+        (response, body) <- replay 200 [wire success] strictOptions+        responseError response @?= Nothing+        ev <- proof response+        ev.observedModel @?= Observed "server-version"+        ev.providerRequestId @?= Observed "req-wire"+        ev.responseId @?= Observed "response-wire"+        ev.requestCommitment @?= commitmentDigest body+        ev.strength @?= EvidenceModelObserved+        ev.usage @?= Unobserved+        case V.toList response.message.content of+          [AssistantThinking t, AssistantText (TextContent "hello")] -> fmap (.replayItems) t.replayState @?= Just (V.singleton reasoningItem)+          _ -> assertFailure "lost reasoning continuation",+      testCase "arbitrary byte fragmentation keeps the same response commitment" $ do+        (whole, _) <- replay 200 [wire success] strictOptions+        (split, _) <- replay 200 (map BS.singleton (BS.unpack (wire success))) strictOptions+        a <- proof whole+        b <- proof split+        a.responseCommitment @?= b.responseCommitment+        split.message.content @?= whole.message.content,+      testCase "minimal effort is refused before transport with strict evidence" $ do+        (response, body) <- replay 200 [wire success] (strictOptions & #thinking .~ Just ThinkingMinimal)+        assertBool "strict adjustment refused" (responseError response /= Nothing)+        body @?= Null+        ev <- proof response+        ev.status @?= CallFailed+        ev.observedModel @?= Unobserved,+      testCase "local request validation still produces a strict evidence record" $ do+        (response, body) <- replay 200 [wire success] (strictOptions & #seed .~ Just 7)+        assertBool "unsupported option refused" (responseError response /= Nothing)+        body @?= Null+        ev <- proof response+        ev.status @?= CallFailed,+      testCase "non-2xx failure uses HTTP classification and captured request ID" $ do+        (response, _) <- replay 429 ["{\"error\":{\"message\":\"slow down\"}}"] strictOptions+        fmap (.category) (responseError response) @?= Just RateLimited+        ev <- proof response+        ev.status @?= CallFailed+        ev.providerRequestId @?= Observed "req-wire"+        ev.observedModel @?= Unobserved+        ev.responseCommitment @?= Unobserved,+      testCase "nested in-band error has one failed evidence record" $ do+        let failure = object ["type" .= ("response.failed" :: Text), "response" .= object ["id" .= ("failed-response" :: Text), "error" .= object ["code" .= ("rate_limit_exceeded" :: Text), "message" .= ("busy" :: Text)]]]+        (response, _) <- replay 200 [wire failure] strictOptions+        fmap (.category) (responseError response) @?= Just RateLimited+        ev <- proof response+        ev.responseId @?= Observed "failed-response"+        ev.status @?= CallFailed,+      testCase "malformed SSE JSON retains the streamed prefix and fails" $ do+        (response, _) <- replay 200 [wire added, wire deltaFrame, "data: {broken}\n\n"] strictOptions+        assertBool "decode failure" (responseError response /= Nothing)+        response.message.content @?= V.singleton (AssistantText (TextContent "partial"))+        ev <- proof response+        ev.status @?= CallFailed,+      testCase "EOF retains prefix without manufacturing a successful response" $ do+        (response, _) <- replay 200 [wire added, wire deltaFrame] strictOptions+        assertBool "EOF failure" (responseError response /= Nothing)+        response.message.content @?= V.singleton (AssistantText (TextContent "partial"))+        ev <- proof response+        ev.responseCommitment @?= Unobserved,+      testCase "observations absent from response remain absent under best effort" $ do+        let silent = object ["type" .= ("response.completed" :: Text), "response" .= object ["output" .= ([] :: [Value])]]+        (response, _) <- replay 200 [wire silent] (strictOptions & #evidence .~ Just (evidenceRequest "silent"))+        ev <- proof response+        ev.observedModel @?= Unobserved+        ev.responseId @?= Unobserved+        ev.usage @?= Unobserved,+      testCase "strict trace cancellation records one abort and releases the worker" $ do+        closed <- newEmptyMVar+        forever <- newEmptyMVar+        captured <- newIORef ([] :: [Trace.TraceEvent])+        recorded <- newEmptyMVar+        let blocked _ _ _ _ emit = (emit (Right added) >> emit (Right deltaFrame) >> takeMVar forever) `finally` putMVar closed ()+            save () e = do+              atomicModifyIORef' captured (\xs -> (e : xs, ()))+              case e of Trace.CallEvidence {} -> putMVar recorded (); _ -> pure ()+            sink = TraceSink (Fold.foldlM' save (pure ()))+        reg <- registryFor blocked+        result <- timeout 100000 (Stream.toList (withTraceStreamWith reg sink openai_gpt_6_astra emptyContext strictOptions))+        assertBool "consumer was cancelled" (case result of Nothing -> True; _ -> False)+        timeout 1000000 (takeMVar closed) >>= (@?= Just ())+        timeout 1000000 (takeMVar recorded) >>= (@?= Just ())+        events <- readIORef captured+        case [ev | Trace.CallEvidence {Trace.evidence = ev} <- events] of+          [ev] -> ev.status @?= CallAborted+          _ -> assertFailure "expected one abort evidence record",+      testCase "opting out does not attach evidence" $ do+        (response, _) <- replay 200 [wire success] (strictOptions & #evidence .~ Nothing)+        response.evidence @?= Nothing+    ]++proof :: Response -> IO ModelCallEvidence+proof response = case response.evidence of Just ev -> pure ev; Nothing -> assertFailure "missing evidence" >> fail "missing evidence"++strictOptions :: Options+strictOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-key") & #evidence .~ Just (evidenceRequest "responses-strict" & #strictness .~ EvidenceRequired EvidenceRequestedOnly)++replay :: Int -> [ByteString] -> Options -> IO (Response, Value)+replay status chunks opts = do+  sent <- newIORef Null+  reg <- registryFor (byteDriver sent status chunks)+  response <- completeRequestWith reg openai_gpt_6_astra emptyContext opts+  body <- readIORef sent+  pure (response, body)++registryFor :: SseDriver -> IO ProviderRegistry+registryFor driver =+  newProviderRegistryFrom+    [ apiProvider OpenAIResponses (openaiResponsesStreamWith driver)+        & #describeThinking .~ describeThinking+        & #strengthCeiling .~ declaredStrength OpenAIResponses+    ]++byteDriver :: IORef Value -> Int -> [ByteString] -> SseDriver+byteDriver sent status chunks _ _ body onMetadata emit = do+  writeIORef sent body+  remaining <- newIORef chunks+  let reader = do+        xs <- readIORef remaining+        case xs of [] -> pure ""; x : rest -> writeIORef remaining rest >> pure x+      response =+        HTTP.Response+          { HTTP.responseStatus = mkStatus status "",+            HTTP.responseVersion = http11,+            HTTP.responseHeaders = [("x-request-id", "req-wire")],+            HTTP.responseBody = reader,+            HTTP.responseCookieJar = HTTP.createCookieJar [],+            HTTP.responseClose' = HTTP.ResponseClose (pure ()),+            HTTP.responseOriginalRequest = HTTP.defaultRequest,+            HTTP.responseEarlyHints = []+          }+  bracket (pure response) HTTP.responseClose (\r -> sseFromResponse r onMetadata emit)++wire :: Value -> ByteString+wire v = "event: response.event\ndata: " <> LBS.toStrict (Aeson.encode v) <> "\n\n"++reasoningItem :: Value+reasoningItem = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("opaque" :: Text), "future" .= True]++item :: Text -> Value+item text = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [object ["type" .= ("output_text" :: Text), "text" .= text]]]++success :: Value+success = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("response-wire" :: Text), "model" .= ("server-version" :: Text), "output" .= [reasoningItem, item "hello"]]]++added :: Value+added = object ["type" .= ("response.output_item.added" :: Text), "output_index" .= (0 :: Int), "item" .= item ""]++deltaFrame :: Value+deltaFrame = object ["type" .= ("response.output_text.delta" :: Text), "output_index" .= (0 :: Int), "content_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "delta" .= ("partial" :: Text)]
+ test/ResponsesSpec.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedRecordDot #-}++module ResponsesSpec (tests) where++import Baikai hiding (model, schema)+import Baikai.Models.Generated (openai_gpt_6_astra)+import Baikai.Provider.OpenAI.Responses.Request qualified as R+import Control.Lens ((&), (.~))+import Control.Monad (forM_)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson qualified as Aeson+import Data.Aeson.KeyMap qualified as KM+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Responses request mapping"+    [ testCase "stateless request carries text, image, system, cap and metadata" $ do+        let ctx =+              (systemUser "system instruction" "hello")+                & #messages .~ V.singleton (UserMessage UserPayload {content = V.fromList [UserText (TextContent "hello"), UserImage (ImageContent "abc" "image/png")], timestamp = Nothing})+            opts = emptyOptions & #maxTokens .~ Just 321 & #metadata .~ Map.singleton "test" (String "value")+        req <- mapped model ctx opts+        field "model" req.requestBody @?= Just (String "renamed-responses-model")+        field "instructions" req.requestBody @?= Just (String "system instruction")+        field "store" req.requestBody @?= Just (Bool False)+        field "stream" req.requestBody @?= Just (Bool True)+        field "max_output_tokens" req.requestBody @?= Just (Number 321)+        field "include" req.requestBody @?= Just (Aeson.toJSON (["reasoning.encrypted_content"] :: [Text]))+        let rendered = Text.pack (show (field "input" req.requestBody))+        assertBool "image encoded inline" ("data:image/png;base64,YWJj" `Text.isInfixOf` rendered)+        assertBool "text is present" ("hello" `Text.isInfixOf` rendered)+        field "metadata" req.requestBody @?= Just (object ["test" .= ("value" :: Text)]),+      testCase "assistant plain text has a valid easy-message input shape" $ do+        req <- mapped model (contextOf [assistant "previous answer"]) emptyOptions+        inputItems req @?= [object ["role" .= ("assistant" :: Text), "content" .= ("previous answer" :: Text)]],+      testCase "empty summary and encrypted items persist into the next tool request" $ do+        let decoded = Aeson.eitherDecode (Aeson.encode thought)+        persisted <- either assertFailure pure decoded+        let response =+              emptyResponse+                & #message . #content .~ V.fromList [AssistantThinking persisted, AssistantToolCall (ToolCall "call_7" "lookup" (object ["x" .= (1 :: Int)]))]+                & #message . #stopReason .~ ToolUse+            ctx = contextOf [user "go"] & #tools .~ V.singleton tool+        next <- appendToolResult ctx response (\_ -> pure (toolResultText "found"))+        req <- mapped model next emptyOptions+        let items = inputItems req+        take 1 (drop 1 items) @?= [reasoningItem]+        field "call_id" (items !! 2) @?= Just (String "call_7")+        field "type" (items !! 2) @?= Just (String "function_call")+        field "call_id" (items !! 3) @?= Just (String "call_7")+        field "output" (items !! 3) @?= Just (String "found")+        field "previous_response_id" req.requestBody @?= Nothing+        req.translation @?= R.describeThinking model emptyOptions,+      testCase "every accepted effort survives; minimal adjusts with evidence" $ do+        forM_ [ThinkingMinimal, ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] $ \level -> do+          let opts = emptyOptions & #thinking .~ Just level+              expected = if level == ThinkingMinimal then "low" else renderThinkingLevel level+          req <- mapped model emptyContext opts+          field "reasoning" req.requestBody @?= Just (object ["effort" .= expected])+          req.translation @?= R.describeThinking model opts+          req.translation.adjustments @?= [EffortClamped ThinkingMinimal "low" | level == ThinkingMinimal],+      testCase "sampling restriction is visible even without thinking" $ do+        let opts = emptyOptions & #temperature .~ Just 0.5 & #topP .~ Just 0.8+        req <- mapped model emptyContext opts+        field "temperature" req.requestBody @?= Nothing+        field "top_p" req.requestBody @?= Nothing+        req.translation.adjustments @?= [SamplingDroppedUnsupportedModel ["temperature", "top_p"]]+        supported <- mapped (model & #compat .~ CompatOpenAIResponses defaultOpenAIResponsesCompat) emptyContext opts+        field "temperature" supported.requestBody @?= Just (Number 0.5),+      testCase "function tools keep permissive schemas and supported choices" $ do+        let ctx = emptyContext & #tools .~ V.singleton tool+        forM_ [ToolChoiceAuto, ToolChoiceNone, ToolChoiceRequired, ToolChoiceSpecific "lookup"] $ \choice -> do+          req <- mapped model ctx (emptyOptions & #toolChoice .~ Just choice)+          field "tool_choice" req.requestBody @?= case choice of+            ToolChoiceAuto -> Nothing+            ToolChoiceNone -> Just (String "none")+            ToolChoiceRequired -> Just (String "required")+            ToolChoiceSpecific name -> Just (object ["type" .= ("function" :: Text), "name" .= name])+          case field "tools" req.requestBody of+            Just (Array tools) -> do+              field "type" (V.head tools) @?= Just (String "function")+              field "strict" (V.head tools) @?= Just (Bool False)+              field "parameters" (V.head tools) @?= Just schema+            _ -> assertFailure "missing tools"+        rejected emptyContext (emptyOptions & #toolChoice .~ Just ToolChoiceRequired)+        rejected ctx (emptyOptions & #toolChoice .~ Just (ToolChoiceSpecific "missing")),+      testCase "JSON schema and JSON object use Responses text.format" $ do+        strict <- mapped model emptyContext (emptyOptions & #responseFormat .~ Just (JsonSchema (jsonSchemaFormat "answer" schema & #strict .~ True)))+        field "text" strict.requestBody @?= Just (object ["format" .= object ["type" .= ("json_schema" :: Text), "name" .= ("answer" :: Text), "schema" .= schema, "strict" .= True]])+        plain <- mapped model emptyContext (emptyOptions & #responseFormat .~ Just JsonObject)+        field "text" plain.requestBody @?= Just (object ["format" .= object ["type" .= ("json_object" :: Text)]]),+      testCase "cache requests follow endpoint TTL contract" $ do+        req <- mapped model emptyContext (emptyOptions & #cacheRetention .~ Just CacheRetentionShort)+        field "prompt_cache_options" req.requestBody @?= Just (object ["ttl" .= ("30m" :: Text)])+        rejected emptyContext (emptyOptions & #cacheRetention .~ Just CacheRetentionLong),+      testCase "unsupported options fail instead of disappearing" $+        forM_ [emptyOptions & #seed .~ Just 1, emptyOptions & #stopSequences .~ ["stop"], emptyOptions & #frequencyPenalty .~ Just 1, emptyOptions & #presencePenalty .~ Just 1, emptyOptions & #metadata .~ Map.singleton "bad" (Number 1)] (rejected emptyContext),+      testCase "foreign, malformed and duplicate replay fails without exposing payload" $ do+        forM_ [replay & #replayApi .~ AnthropicMessages, replay & #replayModel .~ "other", replay & #replayItems .~ V.empty, replay & #replayItems .~ V.singleton (object []), replay & #replayItems .~ V.fromList [reasoningItem, reasoningItem]] $ \bad -> do+          let ctx = addResponse (emptyResponse & #message . #content .~ V.singleton (AssistantThinking (thought & #replayState .~ Just bad))) emptyContext+          case R.mapRequest model ctx emptyOptions of+            Left err -> assertBool "error contains no opaque data" (not ("SECRET" `Text.isInfixOf` err))+            Right _ -> assertFailure "invalid replay accepted",+      testCase "Anthropic state and incomplete calls cannot be replayed" $ do+        forM_ [AssistantThinking (emptyThinkingContent & #signature .~ Just "sig"), AssistantThinking emptyThinkingContent, AssistantToolCall (ToolCall "call_1" "lookup" (String "{"))] $ \block ->+          rejected (addResponse (emptyResponse & #message . #content .~ V.singleton block) emptyContext) emptyOptions+    ]+  where+    rejected ctx opts = case R.mapRequest model ctx opts of+      Left _ -> pure ()+      Right _ -> assertFailure "expected local rejection"++model :: Model+model =+  openai_gpt_6_astra+    & #api .~ OpenAIResponses+    & #modelId .~ "renamed-responses-model"+    & #compat+      .~ CompatOpenAIResponses+        ( defaultOpenAIResponsesCompat+            & #supportedReasoningEfforts .~ Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax]+            & #supportsSamplingParameters .~ False+            & #supportsPromptCacheOptions .~ True+        )++schema :: Value+schema = object ["type" .= ("object" :: Text), "properties" .= object ["x" .= object ["type" .= ("integer" :: Text)]]]++tool :: Tool+tool = mkTool "lookup" "Look up x" schema++reasoningItem :: Value+reasoningItem = object ["type" .= ("reasoning" :: Text), "id" .= ("rs_7" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("SECRET" :: Text), "status" .= ("completed" :: Text)]++replay :: ThinkingReplay+replay = ThinkingReplay OpenAIResponses "renamed-responses-model" (V.singleton reasoningItem)++thought :: ThinkingContent+thought = emptyThinkingContent & #replayState .~ Just replay++mapped :: Model -> Context -> Options -> IO R.PreparedRequest+mapped m ctx opts = either (assertFailure . Text.unpack) pure (R.mapRequest m ctx opts)++field :: Aeson.Key -> Value -> Maybe Value+field k (Object o) = KM.lookup k o+field _ _ = Nothing++inputItems :: R.PreparedRequest -> [Value]+inputItems req = case field "input" req.requestBody of+  Just (Array xs) -> V.toList xs+  _ -> []
+ test/ResponsesStreamSpec.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE OverloadedRecordDot #-}++module ResponsesStreamSpec (tests) where++import Baikai hiding (delta, model)+import Baikai.Models.Generated (openai_gpt_6_astra)+import Baikai.Provider.OpenAI.Internal.Stream (SseDriver)+import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith)+import Baikai.Provider.OpenAI.Sse (ResponseMetadata (..))+import Contract (assertErrorContract)+import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)+import Control.Exception (finally)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.KeyMap qualified as KM+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Vector qualified as V+import Streamly.Data.Stream qualified as Stream+import System.Timeout (timeout)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Responses stream"+    [ testCase "terminal usage merges earlier categories and evidence matches its cost" $ do+        let finished = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("resp_usage" :: Text), "service_tier" .= ("default" :: Text), "output" .= [item "hello"], "usage" .= object ["output_tokens" .= (100 :: Int), "input_tokens_details" .= object ["cache_write_tokens" .= (3000 :: Int)]]]]+        events <- Stream.toList (openaiResponsesStreamWith (driver [usageStarted, finished, finished]) model emptyContext (options & #evidence .~ Just (evidenceRequest "billing")))+        case last events of+          EventDone p -> case p.message of+            AssistantMessage msg -> do+              let u = msg.usage+              (u.inputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.totalTokens) @?= (0, 12000, 3000, 15100)+              u.cost.usd @?= 109 / 2000+              u.cost.basis.estimateReasons @?= Set.empty+              case p.evidence of+                Just ev -> ev.usage @?= Observed u+                Nothing -> assertFailure "missing evidence"+            _ -> assertFailure "expected assistant"+          _ -> assertFailure "expected completion",+      testCase "partial usage survives a failed stream with missing categories explicit" $ do+        events <- run [usageStarted, added, delta]+        assertErrorContract events+        case last events of+          EventError p -> case p.message of+            AssistantMessage msg -> do+              msg.usage.cacheReadTokens @?= 12000+              msg.usage.inputTokens @?= 3000+              msg.usage.cost.basis.estimateReasons @?= Set.fromList [OutputUsageNotReported, CacheWriteUsageNotReported, ServiceTierNotReported]+            _ -> assertFailure "expected assistant"+          _ -> assertFailure "expected failure",+      testCase "complete folds the same stream, including final-only content" $ do+        response <- streamingComplete (openaiResponsesStreamWith (driver [completed])) model emptyContext options+        response.message.content @?= V.singleton (AssistantText (TextContent "hello"))+        response.message.stopReason @?= Stop+        response.responseId @?= Just "resp_actual",+      testCase "EOF after a text delta closes partial content and fails" $ do+        events <- run [added, delta]+        assertErrorContract events+        case last events of+          EventError p -> case p.message of+            AssistantMessage msg -> msg.content @?= V.singleton (AssistantText (TextContent "hel"))+            _ -> assertFailure "wrong message role"+          _ -> assertFailure "expected error",+      testCase "in-band rate limit preserves classification" $ do+        events <- run [object ["type" .= ("error" :: Text), "code" .= ("rate_limit_exceeded" :: Text), "message" .= ("slow down" :: Text)]]+        assertErrorContract events+        case last events of+          EventError p -> fmap (^. #category) p.errorInfo @?= Just RateLimited+          _ -> assertFailure "expected error",+      testCase "failed response preserves its nested error" $ do+        events <- run [object ["type" .= ("response.failed" :: Text), "response" .= object ["id" .= ("failed_id" :: Text), "error" .= object ["code" .= ("rate_limit_exceeded" :: Text), "message" .= ("busy" :: Text)]]]]+        assertErrorContract events+        case last events of+          EventError p -> do+            p.responseId @?= Just "failed_id"+            fmap (^. #category) p.errorInfo @?= Just RateLimited+          _ -> assertFailure "expected error",+      testCase "malformed event becomes a terminal error with partial text" $ do+        events <- run [added, delta, object []]+        assertErrorContract events,+      testCase "completed terminal cancels a driver waiting for more bytes" $ do+        closed <- newEmptyMVar+        let waiting _ _ _ _ emit = (emit (Right completed) >> threadDelay 10000000) `finally` putMVar closed ()+        result <- timeout 2000000 (Stream.toList (openaiResponsesStreamWith waiting model emptyContext options))+        assertBool "stream completed promptly" (maybe False (not . null) result)+        timeout 1000000 (takeMVar closed) >>= (@?= Just ()),+      testCase "consumer timeout releases a driver blocked mid-response" $ do+        closed <- newEmptyMVar+        let waiting _ _ _ _ emit = (emit (Right added) >> emit (Right delta) >> threadDelay 10000000) `finally` putMVar closed ()+        result <- timeout 100000 (Stream.toList (openaiResponsesStreamWith waiting model emptyContext options))+        assertBool "consumer was cancelled" (case result of Nothing -> True; _ -> False)+        timeout 1000000 (takeMVar closed) >>= (@?= Just ()),+      testCase "slow active consumer can drain the complete response" $ do+        result <- timeout 2000000 $ Stream.toList $ Stream.mapM (\e -> threadDelay 20000 >> pure e) (openaiResponsesStreamWith (driver [added, delta, completed]) model emptyContext options)+        case result of+          Just events -> length [() | EventDone _ <- events] @?= 1+          Nothing -> assertFailure "slow consumer did not finish",+      testCase "validation fails before the driver starts" $ do+        called <- newIORef False+        let forbidden _ _ _ _ _ = writeIORef called True+        events <- Stream.toList (openaiResponsesStreamWith forbidden model emptyContext (options & #seed .~ Just 1))+        assertErrorContract events+        readIORef called >>= (@?= False),+      testCase "public two-turn tool loop preserves encrypted reasoning and call identity" $ do+        requests <- newIORef ([] :: [Value])+        let reasoning = object ["type" .= ("reasoning" :: Text), "id" .= ("rs_1" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("encrypted" :: Text), "unknown" .= True]+            call = object ["type" .= ("function_call" :: Text), "id" .= ("item_1" :: Text), "call_id" .= ("call_1" :: Text), "name" .= ("lookup" :: Text), "arguments" .= ("{}" :: Text), "status" .= ("completed" :: Text)]+            first = object ["type" .= ("response.completed" :: Text), "response" .= object ["output" .= [reasoning, call]]]+            scripted _ _ body _ emit = do+              previous <- readIORef requests+              writeIORef requests (previous <> [body])+              emit (Right (if null previous then first else completed))+            provider = apiProvider OpenAIResponses (openaiResponsesStreamWith scripted)+            ctx = systemUser "system" "find it" & #tools .~ V.singleton (mkTool "lookup" "lookup" (object ["type" .= ("object" :: Text)]))+        reg <- newProviderRegistryFrom [provider]+        executed <- newIORef ([] :: [Text])+        (_, result) <- runToolLoopWith reg 3 (\tc -> writeIORef executed [tc.id_] >> pure (toolResultText "found")) model ctx options+        result.message.content @?= V.singleton (AssistantText (TextContent "hello"))+        readIORef executed >>= (@?= ["call_1"])+        bodies <- readIORef requests+        length bodies @?= 2+        case bodies of+          [_, Object second] -> case KM.lookup "input" second of+            Just (Array items) -> do+              items V.! 1 @?= reasoning+              case items V.! 3 of+                Object reply -> do+                  KM.lookup "call_id" reply @?= Just (String "call_1")+                  KM.lookup "output" reply @?= Just (String "found")+                _ -> assertFailure "missing function output"+            _ -> assertFailure "missing input"+          _ -> assertFailure "expected two requests",+      testCase "evidence commits to the exact outgoing request and observed header" $ do+        sent <- newIORef Null+        let capturing _ _ body meta emit = do+              writeIORef sent body+              meta (ResponseMetadata 200 [("x-request-id", "req_observed")])+              emit (Right completed)+        events <- Stream.toList (openaiResponsesStreamWith capturing model emptyContext (options & #evidence .~ Just (evidenceRequest "wire-test")))+        body <- readIORef sent+        case last events of+          EventDone p -> case p.evidence of+            Just ev -> do+              ev.requestCommitment @?= commitmentDigest body+              (ev ^. #endpoint ^. #endpoint) @?= Just "https://api.openai.com/v1/responses"+              ev.providerRequestId @?= Observed "req_observed"+              ev.strength @?= declaredStrength OpenAIResponses+            Nothing -> assertFailure "missing evidence"+          _ -> assertFailure "missing success",+      testCase "evidence uses observed model and exact response content" $ do+        events <- Stream.toList (openaiResponsesStreamWith (driver [completed]) model emptyContext (options & #evidence .~ Just (evidenceRequest "responses-test")))+        case last events of+          EventDone p -> case p.evidence of+            Just ev -> do+              ev.observedModel @?= Observed "server-model"+              ev.responseId @?= Observed "resp_actual"+              ev.usage @?= Unobserved+              assertBool "response commitment exists" (case ev.responseCommitment of Observed _ -> True; _ -> False)+            Nothing -> assertFailure "missing evidence"+          _ -> assertFailure "missing success"+    ]++run :: [Value] -> IO [AssistantMessageEvent]+run frames = Stream.toList (openaiResponsesStreamWith (driver frames) model emptyContext options)++driver :: [Value] -> SseDriver+driver frames _ _ _ _ emit = mapM_ (emit . Right) frames++model :: Model+model = openai_gpt_6_astra & #modelId .~ "configured-model"++options :: Options+options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-test-key")++item :: Text -> Value+item t = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [object ["type" .= ("output_text" :: Text), "text" .= t]]]++added :: Value+added = object ["type" .= ("response.output_item.added" :: Text), "output_index" .= (0 :: Int), "item" .= item ""]++delta :: Value+delta = object ["type" .= ("response.output_text.delta" :: Text), "output_index" .= (0 :: Int), "content_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "delta" .= ("hel" :: Text)]++completed :: Value+completed = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("resp_actual" :: Text), "model" .= ("server-model" :: Text), "output" .= [item "hello"]]]++usageStarted :: Value+usageStarted = object ["type" .= ("response.created" :: Text), "response" .= object ["id" .= ("resp_usage" :: Text), "usage" .= object ["input_tokens" .= (15000 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (12000 :: Int)]]]]
+ test/ResponsesTransportSpec.hs view
@@ -0,0 +1,30 @@+module ResponsesTransportSpec (tests) where++import Baikai.Provider.OpenAI.Sse (buildResponsesRequest)+import Baikai.Provider.OpenAI.Transport (getClientEnvCached)+import Data.Aeson qualified as Aeson+import Network.HTTP.Client qualified as HTTP+import Servant.Client qualified as Client+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertFailure, testCase, (@?=))++tests :: TestTree+tests =+  testGroup+    "Responses HTTP request"+    [ testCase "POST path normalizes one version segment and never redirects" $ do+        mapM_+          ( \url -> do+              env <- getClientEnvCached url+              let body = Aeson.object ["store" Aeson..= False]+                  req = buildResponsesRequest (Client.baseUrl env) [("Authorization", "Bearer fixture")] body+              HTTP.path req @?= "/v1/responses"+              HTTP.method req @?= "POST"+              case HTTP.requestBody req of+                HTTP.RequestBodyLBS encoded -> encoded @?= Aeson.encode body+                _ -> assertFailure "expected the prepared JSON body"+              HTTP.redirectCount req @?= 0+              HTTP.requestHeaders req @?= [("Authorization", "Bearer fixture")]+          )+          ["https://api.openai.com", "https://api.openai.com/v1", "https://api.openai.com/v1/"]+    ]
test/ShapeSpec.hs view
@@ -5,16 +5,16 @@ import Baikai import Baikai.Content qualified as Content import Baikai.Models.Generated qualified as Models-import Baikai.Provider.OpenAI.Api+import Baikai.Provider.OpenAI.Internal.Request (mapRequest)+import Baikai.Provider.OpenAI.Internal.Stream   ( RawChunk (..),     RawToolDelta (..),     closeOpenStream,     emptyAssembler,     translate,   )-import Baikai.Provider.OpenAI.Internal.Request (mapRequest) import Baikai.Provider.OpenAI.Shape (streamRequestBody)-import Control.Lens ((&), (.~))+import Control.Lens ((&), (.~), (^.)) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey@@ -23,6 +23,7 @@ import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector+import EndpointModels (chatRestrictedModel) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -30,30 +31,92 @@ tests =   testGroup     "ShapeSpec"-    [ deepseekShapeTest,+    [ endpointPolicyTests,+      deepseekShapeTest,       nativeHigherEffortTests,       compatibleHigherEffortClampTest,+      translationTableTests,+      nativeVersusCompatibleTests,       openRouterCacheControlTest,       strictModeGateTest,       usageStreamingGateTest,       zeroCapOmissionTest,-      indexlessToolDeltaTest+      indexlessToolDeltaTest,+      nonReasoningModelGateTest     ]  deepseekShapeTest :: TestTree deepseekShapeTest =   testCase "DeepSeek request body uses max_tokens and reasoning shape" $ do+    -- deepseek-reasoner rather than deepseek-chat: the point of this+    -- case is DeepSeek's wire shape, and the shape only reaches the+    -- wire for a model whose catalog entry says it can reason.+    -- deepseek-chat cannot, and is now covered by+    -- 'nonReasoningModelGateTest'. Same host, same compat record.     value <-       shapedBody-        Models.deepseek_deepseek_chat+        Models.deepseek_deepseek_reasoner         (emptyOptions & #thinking .~ Just ThinkingHigh)         emptyContext     lookupTop "max_completion_tokens" value @?= Nothing-    lookupTop "max_tokens" value @?= Just (Number 8192)+    lookupTop "max_tokens" value+      @?= Just (Number (fromIntegral (Models.deepseek_deepseek_reasoner ^. #maxOutputTokens)))     lookupTop "thinking" value       @?= Just (Aeson.object ["type" .= ("enabled" :: Text.Text)])     lookupTop "reasoning_effort" value @?= Just (String "high") +-- | A level on a model that does not advertise reasoning support sends+-- no reasoning control at all, on any host, and says so.+--+-- Before this, @gpt-4o-mini@ plus any level put @reasoning_effort@ on+-- the wire and took a 400 for it, and @deepseek-chat@ took DeepSeek's+-- @thinking@ object. The catalog's @reasoning@ flag is the+-- authoritative capability fact, and this is the check the Anthropic+-- adapter has always made.+nonReasoningModelGateTest :: TestTree+nonReasoningModelGateTest =+  testGroup+    "a level on a non-reasoning model is dropped and recorded"+    [ testCase "deepseek-chat sends neither thinking nor reasoning_effort" $ do+        (value, translation) <-+          shapedCall+            Models.deepseek_deepseek_chat+            (emptyOptions & #thinking .~ Just ThinkingHigh)+            emptyContext+        lookupTop "thinking" value @?= Nothing+        lookupTop "reasoning_effort" value @?= Nothing+        translation ^. #mode @?= ThinkingModeUnsupported+        translation ^. #requested @?= Just ThinkingHigh+        translation ^. #wireField @?= Nothing+        translation ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingHigh],+      testCase "gpt-4o-mini on OpenAI's own host sends no reasoning_effort" $ do+        (value, translation) <-+          shapedCall+            Models.openai_gpt_4o_mini+            (emptyOptions & #thinking .~ Just ThinkingHigh)+            emptyContext+        lookupTop "reasoning_effort" value @?= Nothing+        translation ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingHigh],+      testCase "the model check precedes the host-format check" $ do+        -- A non-reasoning model on a host whose format is None would+        -- record ThinkingDroppedUnsupportedHost if the checks ran the+        -- other way round. The model's answer is the stronger one.+        (_, translation) <-+          shapedCall+            ( Models.openai_gpt_4o_mini+                & #compat+                  .~ CompatOpenAICompletions+                    defaultOpenAICompletionsCompat {thinkingFormat = ThinkingFormatNone}+            )+            (emptyOptions & #thinking .~ Just ThinkingHigh)+            emptyContext+        translation ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingHigh],+      testCase "a non-reasoning model with no level requested records nothing" $ do+        (_, translation) <- shapedCall Models.openai_gpt_4o_mini emptyOptions emptyContext+        translation ^. #mode @?= ThinkingModeAbsent+        translation ^. #adjustments @?= []+    ]+ nativeHigherEffortTests :: TestTree nativeHigherEffortTests =   testGroup@@ -74,13 +137,212 @@ compatibleHigherEffortClampTest :: TestTree compatibleHigherEffortClampTest =   testCase "OpenAI-compatible higher reasoning effort clamps to high" $ do+    -- The reasoning model on the same host: the point is DeepSeek's+    -- effort vocabulary, which is only reached for a model that can+    -- reason at all.     value <-       shapedBody-        Models.deepseek_deepseek_chat+        Models.deepseek_deepseek_reasoner         (emptyOptions & #thinking .~ Just ThinkingMax)         emptyContext     lookupTop "reasoning_effort" value @?= Just (String "high") +-- ============================================================+-- The forty-two-row translation table+-- ============================================================++-- | Every canonical level against every wire shape: what goes on the+-- wire, and what the evidence record says went on it.+--+-- Both halves are asserted on every row. Checking only the description+-- would let it drift away from the request it claims to describe, which+-- is the one failure this whole record exists to prevent.+translationTableTests :: TestTree+translationTableTests =+  testGroup+    "thinking translation across all seven wire shapes"+    [ testCase (shapeName fmt <> " at " <> Text.unpack (renderThinkingLevel lvl)) $ do+        (body, translation) <-+          shapedCall (hostWith fmt) (emptyOptions & #thinking .~ Just lvl) emptyContext+        translation @?= expected+        mapM_ (\(k, v) -> lookupTop k body @?= Just v) present+        mapM_ (\k -> lookupTop k body @?= Nothing) absent+    | (lvl, nativeWord, compatWord, clamps) <- effortRows,+      fmt <- everyThinkingFormat,+      let (expected, present, absent) = expectationFor fmt lvl nativeWord compatWord clamps+    ]++-- | The seven shapes, listed so a new constructor added to+-- 'ThinkingFormat' shows up here as a missing case in 'expectationFor'+-- and 'shapeName' rather than as a silently untested shape.+everyThinkingFormat :: [ThinkingFormat]+everyThinkingFormat =+  [ ThinkingFormatOpenAI,+    ThinkingFormatOpenRouter,+    ThinkingFormatDeepseek,+    ThinkingFormatTogether,+    ThinkingFormatZai,+    ThinkingFormatQwen,+    ThinkingFormatNone+  ]++-- | The exact effort word each of the two vocabularies sends for each+-- canonical level, and the adjustment a clamping vocabulary records.+--+-- Every value is written out rather than computed from the code under+-- test, so this is an independent statement of the intended behaviour+-- and not a second copy of the implementation. The native column never+-- clamps: it forwards the canonical name, which is exactly what an+-- empty adjustment list means.+effortRows :: [(ThinkingLevel, Text.Text, Text.Text, [ThinkingAdjustment])]+effortRows =+  [ (ThinkingMinimal, "minimal", "low", [EffortClamped ThinkingMinimal "low"]),+    (ThinkingLow, "low", "low", []),+    (ThinkingMedium, "medium", "medium", []),+    (ThinkingHigh, "high", "high", []),+    (ThinkingXHigh, "xhigh", "high", [EffortClamped ThinkingXHigh "high"]),+    (ThinkingMax, "max", "high", [EffortClamped ThinkingMax "high"])+  ]++-- | The translation, the body keys that must be present, and the body+-- keys that must be absent, for one shape at one level.+expectationFor ::+  ThinkingFormat ->+  ThinkingLevel ->+  -- | The word the native vocabulary sends.+  Text.Text ->+  -- | The word the compatible vocabulary sends.+  Text.Text ->+  -- | The adjustment the compatible vocabulary records, if any.+  [ThinkingAdjustment] ->+  (ThinkingTranslation, [(Text.Text, Value)], [Text.Text])+expectationFor fmt lvl nativeWord compatWord clamps = case fmt of+  ThinkingFormatOpenAI ->+    ( adaptiveTranslation lvl nativeWord "reasoning_effort" [],+      [("reasoning_effort", String nativeWord)],+      ["reasoning", "thinking", "enable_thinking"]+    )+  ThinkingFormatOpenRouter ->+    ( adaptiveTranslation lvl compatWord "reasoning" clamps,+      [("reasoning", Aeson.object ["effort" .= compatWord])],+      ["reasoning_effort", "thinking", "enable_thinking"]+    )+  ThinkingFormatDeepseek ->+    ( adaptiveTranslation lvl compatWord "reasoning_effort" clamps,+      [ ("reasoning_effort", String compatWord),+        ("thinking", Aeson.object ["type" .= ("enabled" :: Text.Text)])+      ],+      ["reasoning", "enable_thinking"]+    )+  ThinkingFormatTogether ->+    ( adaptiveTranslation lvl compatWord "reasoning_effort" clamps,+      [ ("reasoning_effort", String compatWord),+        ("reasoning", Aeson.object ["enabled" .= True])+      ],+      ["thinking", "enable_thinking"]+    )+  ThinkingFormatZai -> collapsed+  ThinkingFormatQwen -> collapsed+  ThinkingFormatNone ->+    ( ThinkingTranslation+        { requested = Just lvl,+          mode = ThinkingModeUnsupported,+          effortText = Nothing,+          budgetTokens = Nothing,+          wireField = Nothing,+          displayText = Nothing,+          adjustments = [ThinkingDroppedUnsupportedHost lvl]+        },+      [],+      ["reasoning_effort", "reasoning", "thinking", "enable_thinking"]+    )+  where+    -- Z.ai and Qwen carry no depth at all, so every level collapses --+    -- including the ones a richer host would have accepted verbatim.+    collapsed =+      ( ThinkingTranslation+          { requested = Just lvl,+            mode = ThinkingModeToggle,+            effortText = Nothing,+            budgetTokens = Nothing,+            wireField = Just "enable_thinking",+            displayText = Nothing,+            adjustments = [EffortCollapsedToToggle lvl]+          },+        [("enable_thinking", Bool True)],+        ["reasoning_effort", "reasoning", "thinking"]+      )++adaptiveTranslation ::+  ThinkingLevel -> Text.Text -> Text.Text -> [ThinkingAdjustment] -> ThinkingTranslation+adaptiveTranslation lvl wire field adjs =+  ThinkingTranslation+    { requested = Just lvl,+      mode = ThinkingModeAdaptive,+      effortText = Just wire,+      budgetTokens = Nothing,+      wireField = Just field,+      displayText = Nothing,+      adjustments = adjs+    }++shapeName :: ThinkingFormat -> String+shapeName = \case+  ThinkingFormatOpenAI -> "openai-native"+  ThinkingFormatOpenRouter -> "openrouter"+  ThinkingFormatDeepseek -> "deepseek"+  ThinkingFormatTogether -> "together"+  ThinkingFormatZai -> "zai"+  ThinkingFormatQwen -> "qwen"+  ThinkingFormatNone -> "no-reasoning-controls"++-- | A reasoning-capable model pinned to one wire shape, so the table+-- exercises a shape rather than whichever host a catalog entry happens+-- to point at.+hostWith :: ThinkingFormat -> Model+hostWith fmt =+  Models.openai_gpt_5_6_terra+    & #compat+      .~ CompatOpenAICompletions+        defaultOpenAICompletionsCompat {thinkingFormat = fmt}++-- | The same request against a native host and against a clamping one,+-- written side by side because the contrast is the design.+--+-- The native rows are the ones that look wrong at a glance and are not:+-- `xhigh` and `max` reach the wire intact and the translation records no+-- adjustment, because nothing was adjusted. Clamping them here would+-- silently weaken every high-effort request against a current OpenAI+-- model.+nativeVersusCompatibleTests :: TestTree+nativeVersusCompatibleTests =+  testGroup+    "the native vocabulary forwards what the compatible one clamps"+    [ testCase "native xhigh reaches the wire and adjusts nothing" $+        assertEffort Models.openai_gpt_5_6_terra ThinkingXHigh "xhigh" [],+      testCase "deepseek xhigh clamps to high and records it" $+        assertEffort+          Models.deepseek_deepseek_reasoner+          ThinkingXHigh+          "high"+          [EffortClamped ThinkingXHigh "high"],+      testCase "native max reaches the wire and adjusts nothing" $+        assertEffort Models.openai_gpt_5_6_terra ThinkingMax "max" [],+      testCase "deepseek max clamps to high and records it" $+        assertEffort+          Models.deepseek_deepseek_reasoner+          ThinkingMax+          "high"+          [EffortClamped ThinkingMax "high"]+    ]+  where+    assertEffort model lvl wire adjs = do+      (body, translation) <-+        shapedCall model (emptyOptions & #thinking .~ Just lvl) emptyContext+      lookupTop "reasoning_effort" body @?= Just (String wire)+      effortText translation @?= Just wire+      adjustments translation @?= adjs+ openRouterCacheControlTest :: TestTree openRouterCacheControlTest =   testCase "OpenRouter cache marker lands on the system content part with ttl" $ do@@ -105,7 +367,7 @@         opts =           emptyOptions             & #responseFormat-              .~ Just (JsonSchema {name = "shape", schema = schema, strict = True})+              .~ Just (JsonSchema (jsonSchemaFormat "shape" schema) {strict = True})     value <- shapedBody Models.deepseek_deepseek_chat opts emptyContext     lookupPath ["response_format", "json_schema", "strict"] value       @?= Nothing@@ -184,9 +446,14 @@           ]  shapedBody :: Model -> Options -> Context -> IO Value-shapedBody model opts ctx = do+shapedBody model opts ctx = fst <$> shapedCall model opts ctx++-- | The shaped request body together with the description of what the+-- caller's reasoning-effort preference became inside it.+shapedCall :: Model -> Options -> Context -> IO (Value, ThinkingTranslation)+shapedCall model opts ctx = do   req <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts)-  pure (streamRequestBody (openaiCompletionsCompatFor model) opts req)+  pure (streamRequestBody (openaiCompletionsCompatFor model) (model ^. #reasoning) opts req)  lookupTop :: Text.Text -> Value -> Maybe Value lookupTop field = lookupPath [field]@@ -225,7 +492,10 @@       reasoningDelta = Nothing,       finishReason = Nothing,       toolDeltas = [],-      usage = Nothing+      usage = Nothing,+      model = Nothing,+      serviceTier = Nothing,+      responseId = Nothing     }  runChunks :: [RawChunk] -> [AssistantMessageEvent]@@ -243,3 +513,16 @@  testTime :: UTCTime testTime = read "2026-07-03 12:00:00 UTC"++endpointPolicyTests :: TestTree+endpointPolicyTests =+  testGroup+    "endpoint policy"+    [ testCase ("accepted effort " <> show level) $ do+        (body, translation) <- shapedCall fake (emptyOptions & #thinking .~ Just level) emptyContext+        lookupTop "reasoning_effort" body @?= Just (String (renderThinkingLevel level))+        translation ^. #adjustments @?= []+    | level <- [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax]+    ]+  where+    fake = chatRestrictedModel & #modelId .~ "arbitrary-generation"
test/SseSpec.hs view
@@ -1,16 +1,45 @@ module SseSpec (tests) where -import Baikai.Error (ErrorCategory (..), category, httpStatus, retryAfterSeconds)-import Baikai.Provider.OpenAI.Sse (sseFromResponse)+import Baikai+import Baikai.Http qualified as Http+import Baikai.Models.Generated (openai_gpt_4o_mini)+import Baikai.Provider.OpenAI.Internal.Stream+  ( Assembler,+    RawChunk (..),+    SseDriver,+    emptyAssembler,+    openaiChatStreamWith,+    parseFrame,+    translate,+  )+import Baikai.Provider.OpenAI.Sse+  ( ResponseMetadata,+    buildRequest,+    openaiSseStreamValueWithHeaders,+    sseFromResponse,+  )+import Contract (assertErrorContract)+import Control.Lens ((&), (.~), (^.))+import Control.Monad (forM_) import Data.Aeson qualified as Aeson import Data.ByteString (ByteString)+import Data.ByteString qualified as SBS+import Data.ByteString.Char8 qualified as S8+import Data.ByteString.Lazy qualified as LBS import Data.CaseInsensitive qualified as CI-import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Generics.Labels ()+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef)+import Data.Text qualified as Text+import Data.Time.Clock (UTCTime)+import Data.Vector (Vector)+import Data.Vector qualified as Vector import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11)+import Servant.Client qualified as Client+import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=))  tests :: TestTree tests =@@ -18,8 +47,9 @@     "Baikai.Provider.OpenAI.Sse"     [ testCase "non-2xx response preserves Retry-After and status" $ do         eventsRef <- newIORef []+        metaRef <- newIORef []         resp <- mkResponse 429 [("Retry-After", "9")] ["{\"error\":{\"message\":\"rate limited\",\"type\":\"tokens\"}}"]-        sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev]))+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))         events <- readIORef eventsRef         case events of           [Left e] -> do@@ -27,16 +57,351 @@             retryAfterSeconds e @?= Just 9             httpStatus e @?= Just 429           other -> assertFailure ("expected one classified error, got: " <> show other),+      -- CDN-fronted hosts send a date rather than a count on a 429.+      -- The response's own Date is the reference instant, so the hint+      -- does not inherit this machine's clock skew.+      testCase "HTTP-date Retry-After is converted using the response Date header" $ do+        eventsRef <- newIORef []+        metaRef <- newIORef []+        resp <-+          mkResponse+            429+            [ ("Retry-After", "Wed, 21 Oct 2026 07:28:00 GMT"),+              ("Date", "Wed, 21 Oct 2026 07:27:15 GMT")+            ]+            ["{\"error\":{\"message\":\"slow down\"}}"]+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))+        events <- readIORef eventsRef+        case events of+          [Left e] -> do+            category e @?= RateLimited+            retryAfterSeconds e @?= Just 45+          other -> assertFailure ("expected one classified error, got: " <> show other),+      testCase "HTTP-date Retry-After without a Date header uses the current time" $ do+        eventsRef <- newIORef []+        metaRef <- newIORef []+        resp <- mkResponse 429 [("Retry-After", "Wed, 21 Oct 2099 07:28:00 GMT")] [""]+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))+        events <- readIORef eventsRef+        case events of+          [Left e] -> case retryAfterSeconds e of+            Just n -> assertBool ("a date in 2099 is far in the future, got " <> show n) (n > 0)+            Nothing -> assertFailure "expected a converted Retry-After hint"+          other -> assertFailure ("expected one classified error, got: " <> show other),       testCase "[DONE] terminates without emitting a JSON event" $ do         eventsRef <- newIORef []+        metaRef <- newIORef []         resp <- mkResponse 200 [] ["data: {\"choices\":[]}\n\n", "data: [DONE]\n\n", "data: {\"ignored\":true}\n\n"]-        sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev]))+        sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev]))         events <- readIORef eventsRef         case events of           [Right (Aeson.Object _)] -> pure ()-          other -> assertFailure ("expected one JSON event before [DONE], got: " <> show other)+          other -> assertFailure ("expected one JSON event before [DONE], got: " <> show other),+      testCase "an HTTP 401 stream is EventStart then one EventError" $ do+        -- The whole provider stream, not just the transport: what a+        -- consumer sees when the call fails before the first chunk.+        events <- replayStream 401 [] ["{\"error\":{\"message\":\"bad key\",\"type\":\"invalid_request_error\"}}"]+        assertErrorContract events+        case reverse events of+          (EventError TerminalPayload {errorInfo = Just be} : _) -> category be @?= AuthError+          other -> assertFailure ("expected a terminal EventError carrying errorInfo, got: " <> show (take 1 other)),+      observationTests,+      blockClosingTests,+      requestShapeTests,+      redirectTests     ] +-- | How blocks close when something goes wrong, and what the transport+-- does with a frame it was not written for.+blockClosingTests :: TestTree+blockClosingTests =+  testGroup+    "block closing under failure"+    [ testCase "[DONE] with trailing whitespace terminates without a decode error" $ do+        -- Hosts send @data: [DONE] @ and @data: [DONE]\r@; an exact+        -- comparison turned the end of a healthy stream into a decode+        -- error terminal.+        events <-+          transportEvents+            200+            (init successBody <> ["data: [DONE] \n\n"])+        assertAllRight events+        length events @?= 3,+      testCase "an empty data heartbeat is ignored" $ do+        events <- transportEvents 200 ["data:\n\n", "data: {\"choices\":[]}\n\n", "data: [DONE]\n\n"]+        assertAllRight events+        length events @?= 1,+      testCase "a tool call cut off by finish_reason length closes with its raw argument text" $ do+        let chunks =+              [ toolChunk (Just "call_1") (Just "search") (Just "{\"query\":\"hel"),+                "data: {\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"length\"}]}\n\n"+              ]+        events <- replayStream 200 [] chunks+        let calls = [tc | ToolCallEnd ToolCallEndPayload {toolCall = tc} <- events]+        case calls of+          [tc] -> do+            tc ^. #arguments @?= Aeson.String "{\"query\":\"hel"+            assertBool "the call is marked cut off" (isCutOffToolCall tc)+          other -> assertFailure ("expected exactly one ToolCallEnd, got: " <> show (length other))+        case reverse events of+          (EventDone TerminalPayload {reason = r} : _) -> r @?= Length+          other -> assertFailure ("expected a terminal EventDone, got: " <> show (take 1 other)),+      -- An upstream failure the host only learned about after+      -- committing to a 200. Before 'parseFrame' this frame parsed as an+      -- empty chunk, was dropped, and the call ended as+      -- OtherError "openai stream ended without finish_reason".+      testCase "an in-band error frame on a 2xx stream reaches the assembler as a classified Left" $ do+        events <-+          replayStream+            200+            []+            [ "data: {\"id\":\"chatcmpl-1\",\"choices\":[{\"index\":0,\"delta\":{\"content\":\"Hel\"}}]}\n\n",+              openRouterErrorFrame,+              "data: [DONE]\n\n"+            ]+        assertErrorContract events+        case reverse events of+          (EventError TerminalPayload {errorInfo = Just be} : _) -> do+            category be @?= TransientError+            httpStatus be @?= Just 502+            be ^. #message @?= "Provider returned error"+          other -> assertFailure ("expected a classified terminal EventError, got: " <> show (take 1 other)),+      testCase "a mid-stream transport error closes open blocks before the terminal" $ do+        -- Injected through 'translate' rather than the transport,+        -- because what is under test is the assembler's Left path: a+        -- classified error arriving with a text block open.+        let (openEvents, ass) =+              translate+                (Right emptyChunk {contentDelta = Just "partial"})+                (emptyAssembler streamTestModel testTime)+                testTime+            (failEvents, _) = translate (Left (providerUnavailable "connection reset mid-stream")) ass testTime+        assertBool+          ("expected a text block to be open, got: " <> show openEvents)+          (not (null [() | TextStart {} <- openEvents]))+        case failEvents of+          [TextEnd BlockEndPayload {contentIndex = 0, content = body}, EventError TerminalPayload {message = msg}] -> do+            body @?= "partial"+            [t | AssistantText (TextContent t) <- Vector.toList (messageBlocks msg)] @?= ["partial"]+          other -> assertFailure ("expected TextEnd then EventError, got: " <> show other)+    ]++toolChunk :: Maybe Text.Text -> Maybe Text.Text -> Maybe Text.Text -> ByteString+toolChunk tid tname targs =+  "data: "+    <> LBS.toStrict+      ( Aeson.encode+          ( Aeson.object+              [ "choices"+                  Aeson..= [ Aeson.object+                               [ "index" Aeson..= (0 :: Int),+                                 "delta"+                                   Aeson..= Aeson.object+                                     [ "tool_calls"+                                         Aeson..= [ Aeson.object+                                                      [ "index" Aeson..= (0 :: Int),+                                                        "id" Aeson..= tid,+                                                        "type" Aeson..= ("function" :: Text.Text),+                                                        "function"+                                                          Aeson..= Aeson.object+                                                            ["name" Aeson..= tname, "arguments" Aeson..= targs]+                                                      ]+                                                  ]+                                     ]+                               ]+                           ]+              ]+          )+      )+    <> "\n\n"++-- | The raw chunk values the transport produced, with no assembler+-- involved.+transportEvents :: Int -> [ByteString] -> IO [Either BaikaiError Aeson.Value]+transportEvents status chunks = do+  eventsRef <- newIORef []+  resp <- mkResponse status [] chunks+  sseFromResponse resp (const (pure ())) (\ev -> modifyIORef' eventsRef (<> [ev]))+  readIORef eventsRef++assertAllRight :: [Either BaikaiError Aeson.Value] -> Assertion+assertAllRight events =+  case [e | Left e <- events] of+    [] -> pure ()+    errs -> assertFailure ("expected no transport errors, got: " <> show errs)++emptyChunk :: RawChunk+emptyChunk =+  RawChunk+    { contentDelta = Nothing,+      reasoningDelta = Nothing,+      finishReason = Nothing,+      toolDeltas = [],+      usage = Nothing,+      model = Nothing,+      serviceTier = Nothing,+      responseId = Nothing+    }++messageBlocks :: Message -> Vector AssistantContent+messageBlocks = \case+  AssistantMessage AssistantPayload {content = c} -> c+  _ -> Vector.empty++-- | Drain a recorded response as the provider stream a consumer sees.+replayStream :: Int -> [(ByteString, ByteString)] -> [ByteString] -> IO [AssistantMessageEvent]+replayStream status headers chunks = do+  bodyRef <- newIORef Aeson.Null+  Stream.toList+    (openaiChatStreamWith (replayDriver bodyRef status headers chunks) streamTestModel emptyContext streamTestOptions)++-- | A transport driver that serves a recorded response instead of+-- opening a socket. The same shape as @EvidenceSpec.replayDriver@; the+-- two suites keep their own so neither can silently change the other's+-- fixtures.+replayDriver ::+  IORef Aeson.Value -> Int -> [(ByteString, ByteString)] -> [ByteString] -> SseDriver+replayDriver bodyRef status headers chunks _env _headers body onMetadata onEvent = do+  writeIORef bodyRef body+  resp <- mkResponse status headers chunks+  sseFromResponse resp onMetadata onEvent++streamTestModel :: Model+streamTestModel =+  openai_gpt_4o_mini+    & #api .~ OpenAIChatCompletions+    & #baseUrl .~ "https://api.openai.com"++streamTestOptions :: Options+streamTestOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key")++-- | What the transport and the assembler between them can say about+-- what the host reported, as opposed to what was configured.+--+-- The fixture's @model@ deliberately differs from the model the+-- assembler was built with. If they matched, a bug that read the+-- caller's configuration instead of the host's chunk would pass these+-- assertions, which is exactly the substitution the 'Observed' type+-- exists to prevent.+observationTests :: TestTree+observationTests =+  testGroup+    "response observation"+    [ testCase "a 200 response yields one metadata value carrying x-request-id" $ do+        (metas, _) <- replay 200 [("x-request-id", "req_abc123"), ("authorization", "Bearer sk-leak")] successBody+        case metas of+          [md] -> do+            md ^. #httpStatus @?= 200+            -- Allow-list, not denylist: the credential-shaped header the+            -- fixture also carries must not be recorded.+            md ^. #headers @?= [("x-request-id", "req_abc123")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other),+      testCase "the observed model comes from the chunks, not the configured model" $ do+        (_, ass) <- replay 200 [("x-request-id", "req_abc123")] successBody+        ass ^. #observedModel @?= Observed "gpt-4o-mini-20990101-server-side"+        -- Asserted as a difference rather than against a literal catalog+        -- id, which is generated and moves.+        assertBool+          "the fixture's model must differ from the configured one"+          (ass ^. #observedModel /= Observed (openai_gpt_4o_mini ^. #modelId))+        ass ^. #responseId @?= Just "chatcmpl-observed"+        ass ^. #usageReported @?= True,+      testCase "the first reported model wins over a later one" $ do+        (_, ass) <- replay 200 [] disagreeingBody+        ass ^. #observedModel @?= Observed "first-reported-model"+        ass ^. #responseId @?= Just "chatcmpl-first",+      testCase "a failed response still yields metadata, and observes no model" $ do+        (metas, ass) <-+          replay+            429+            [("x-request-id", "req_failed")]+            ["{\"error\":{\"message\":\"rate limited\",\"type\":\"tokens\"}}"]+        case metas of+          [md] -> do+            md ^. #httpStatus @?= 429+            md ^. #headers @?= [("x-request-id", "req_failed")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other)+        ass ^. #observedModel @?= Unobserved+        ass ^. #responseId @?= Nothing+        ass ^. #usageReported @?= False,+      testCase "a gateway header is captured when the host's own is absent" $ do+        (metas, _) <- replay 200 [("cf-ray", "ray-9"), ("x-amzn-requestid", "gw-1")] successBody+        case metas of+          -- Recorded in the order the response listed them; the+          -- adapter's preference order lives in capturedHeaderNames.+          [md] -> md ^. #headers @?= [("cf-ray", "ray-9"), ("x-amzn-requestid", "gw-1")]+          other -> assertFailure ("expected exactly one metadata value, got: " <> show other)+    ]++-- | A complete successful stream whose reported model is not any model+-- in the catalog, so it cannot be confused with a configured one.+successBody :: [ByteString]+successBody =+  [ "data: {\"id\":\"chatcmpl-observed\",\"object\":\"chat.completion.chunk\",",+    "\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[{\"index\":0,\"delta\":{\"content\":\"pong\"}}]}\n\n",+    "data: {\"id\":\"chatcmpl-observed\",\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"stop\"}]}\n\n",+    "data: {\"id\":\"chatcmpl-observed\",\"model\":\"gpt-4o-mini-20990101-server-side\",",+    "\"choices\":[],\"usage\":{\"prompt_tokens\":11,\"completion_tokens\":5}}\n\n",+    "data: [DONE]\n\n"+  ]++-- | Two chunks reporting different identities. Compatible hosts repeat+-- both fields on every chunk and they are expected to agree; this pins+-- which one is kept if one ever does not, so the answer is a recorded+-- decision rather than whichever chunk happened to arrive last.+disagreeingBody :: [ByteString]+disagreeingBody =+  [ "data: {\"id\":\"chatcmpl-first\",\"model\":\"first-reported-model\",",+    "\"choices\":[{\"index\":0,\"delta\":{\"content\":\"a\"}}]}\n\n",+    "data: {\"id\":\"chatcmpl-second\",\"model\":\"second-reported-model\",",+    "\"choices\":[{\"index\":0,\"delta\":{\"content\":\"b\"},\"finish_reason\":\"stop\"}]}\n\n",+    "data: [DONE]\n\n"+  ]++-- | Drive a recorded response through the real transport and fold the+-- chunks it produces through the real parser and translator.+replay ::+  Int -> [(ByteString, ByteString)] -> [ByteString] -> IO ([ResponseMetadata], Assembler)+replay status headers chunks = do+  metaRef <- newIORef []+  eventsRef <- newIORef []+  resp <- mkResponse status headers chunks+  sseFromResponse+    resp+    (\md -> modifyIORef' metaRef (<> [md]))+    (\ev -> modifyIORef' eventsRef (<> [ev]))+  metas <- readIORef metaRef+  events <- readIORef eventsRef+  let ass =+        foldl'+          (\acc ev -> snd (translate (parsed ev) acc testTime))+          (emptyAssembler openai_gpt_4o_mini testTime)+          events+  pure (metas, ass)++-- | OpenRouter's mid-stream failure frame: the upstream status as a+-- number in @code@, and a @choices@ array beside the error, so detection+-- cannot key on the absence of @choices@.+openRouterErrorFrame :: ByteString+openRouterErrorFrame =+  "data: {\"error\":{\"message\":\"Provider returned error\",\"code\":502},\+  \\"choices\":[{\"index\":0,\"finish_reason\":\"error\",\"delta\":{}}]}\n\n"++-- | Frames reach the assembler through 'parseFrame', exactly as the+-- worker sends them — so an in-band error frame is sorted out here, not+-- parsed as an empty chunk.+parsed :: Either BaikaiError Aeson.Value -> Either BaikaiError RawChunk+parsed = \case+  Left e -> Left e+  Right v -> case parseFrame v of+    Left err -> Left (providerError (Text.pack err))+    Right frame -> frame++testTime :: UTCTime+testTime = read "2026-07-03 12:00:00 UTC"+ mkResponse :: Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader) mkResponse status headers chunks = do   ref <- newIORef chunks@@ -56,3 +421,105 @@         HTTP.responseOriginalRequest = HTTP.defaultRequest,         HTTP.responseEarlyHints = []       }++-- --------------------------------------------------------------------+-- What goes on the wire+-- --------------------------------------------------------------------++-- | The composed path and the redirect policy, asserted on the pure+-- request rather than by opening a connection.+--+-- The path cases are the base-URL convention: `Model.baseUrl` is the API+-- root, baikai appends `/v1/chat/completions` itself, and a trailing+-- `/v1` is removed rather than doubled — which is why+-- `https://api.deepseek.com/v1`, the spelling every OpenAI SDK teaches,+-- does not request `/v1/v1/...`.+requestShapeTests :: TestTree+requestShapeTests =+  testGroup+    "the request this transport sends"+    [ testCase "one version segment, whatever spelling the base URL used"+        $ forM_+          [ ("https://api.deepseek.com/v1", "/v1/chat/completions"),+            ("https://api.deepseek.com", "/v1/chat/completions"),+            ("https://openrouter.ai/api", "/api/v1/chat/completions"),+            ("https://openrouter.ai/api/v1/", "/api/v1/chat/completions"),+            ( "https://dashscope-intl.aliyuncs.com/compatible-mode/v1",+              "/compatible-mode/v1/chat/completions"+            )+          ]+        $ \(url, expected) -> case Http.canonicalBaseUrl url of+          Left problem -> assertFailure (Text.unpack (url <> " was refused: " <> problem))+          Right base -> do+            let request = buildRequest base [] (Aeson.object [])+            (url, HTTP.path request) @?= (url, S8.pack expected),+      testCase "the request never follows a redirect" $+        case Http.canonicalBaseUrl "https://h.test" of+          Left problem -> assertFailure (Text.unpack problem)+          Right base -> do+            let request = buildRequest base [] (Aeson.object [])+            HTTP.redirectCount request @?= 0+            HTTP.method request @?= "POST"+    ]++-- --------------------------------------------------------------------+-- A 3xx is an error, not a hop+-- --------------------------------------------------------------------++-- | A 302 is delivered as the terminal error and no second connection is+-- ever opened.+--+-- @http-client@'s default is to follow up to ten redirects with every+-- header intact, so before `redirectCount = 0` this test recorded a+-- second connection — to whatever host the `Location` header named —+-- carrying the caller's bearer token.+--+-- The "server" is an in-process fake built from `managerRawConnection`,+-- which is what lets the case observe /which hosts a connection was+-- opened to/ directly, with no socket and no port.+redirectTests :: TestTree+redirectTests =+  testGroup+    "redirects"+    [ testCase "a 302 is the terminal error and no second host is contacted" $ do+        attemptsRef <- newIORef []+        manager <- fakeRedirectingManager attemptsRef+        case Http.canonicalBaseUrl "http://proxy.test" of+          Left problem -> assertFailure (Text.unpack problem)+          Right base -> do+            let env = Client.mkClientEnv manager base+            eventsRef <- newIORef []+            metaRef <- newIORef []+            openaiSseStreamValueWithHeaders+              env+              [("Authorization", "Bearer sk-test")]+              (Aeson.object [])+              (\md -> modifyIORef' metaRef (<> [md]))+              (\ev -> modifyIORef' eventsRef (<> [ev]))+            attempts <- readIORef attemptsRef+            attempts @?= [("proxy.test", 80)]+            events <- readIORef eventsRef+            case events of+              [Left e] -> httpStatus e @?= Just 302+              other -> assertFailure ("expected one 302 error, got: " <> show other)+    ]++-- | A manager whose every connection answers one 302 pointing at another+-- host, and records the host and port it was opened to.+fakeRedirectingManager :: IORef [(String, Int)] -> IO HTTP.Manager+fakeRedirectingManager attemptsRef =+  HTTP.newManager+    HTTP.defaultManagerSettings+      { HTTP.managerRawConnection = pure open+      }+  where+    open _ host portNumber = do+      modifyIORef' attemptsRef (<> [(host, portNumber)])+      remaining <- newIORef [redirectResponse]+      HTTP.makeConnection+        (atomicModifyIORef' remaining (\chunks -> case chunks of [] -> ([], SBS.empty); (c : cs) -> (cs, c)))+        (\_ -> pure ())+        (pure ())+    redirectResponse =+      S8.pack+        "HTTP/1.1 302 Found\r\nLocation: http://evil.test/steal\r\nContent-Length: 0\r\n\r\n"
test/TransportSpec.hs view
@@ -1,32 +1,58 @@ module TransportSpec (tests) where  import Baikai+import Baikai.Provider.OpenAI.Api (openaiChatStream)+import Baikai.Provider.OpenAI.Internal.Stream (openaiChatStreamWith)+import Baikai.Provider.OpenAI.Shape (describeThinkingShape) import Baikai.Provider.OpenAI.Transport qualified as Transport+import Contract (assertErrorContract) import Control.Concurrent (threadDelay) import Control.Exception (bracket, try) import Control.Lens ((&), (.~), (^.))+import Control.Monad (forM_)+import Data.Aeson qualified as Aeson import Data.CaseInsensitive qualified as CI+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Text.Encoding qualified as Text+import Data.Vector qualified as Vector+import EndpointModels (chatRestrictedModel) import Network.HTTP.Types.Header (RequestHeaders)+import Servant.Client qualified as Client+import Streamly.Data.Stream qualified as Stream import System.Environment (lookupEnv, setEnv, unsetEnv) import Test.Tasty (TestTree, testGroup)-import Test.Tasty.HUnit (assertFailure, testCase, (@?=))+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))  tests :: TestTree tests =   testGroup     "Baikai.Provider.OpenAI.Transport"-    [ clientEnvCacheTest,+    [ endpointRejectionTest,+      clientEnvCacheTest,       requestHeadersTest,       timeoutTest,-      unknownHostKeyTest+      nonPositiveTimeoutTest,+      unknownHostKeyTest,+      unusableBaseUrlTest     ] +-- | One entry per target, and one notion of what a target is.+--+-- Both halves are asserted in a single case because the cache is+-- process-global and this suite runs in parallel: two cases each reading+-- a count and expecting it to move by exactly one would race each other.+--+-- The normalisation half is what makes the count meaningful. The key is+-- the canonical rendering of "Baikai.Url"'s parse rather than the+-- caller's text, so a trailing slash and a capitalised host do not each+-- open their own connection pool to the same host — and the two provider+-- packages, which now share one cache in @Baikai.Http@, cannot disagree+-- about which target a URL names. clientEnvCacheTest :: TestTree clientEnvCacheTest =-  testCase "cached ClientEnv is allocated once for a base URL" $ do+  testCase "the ClientEnv cache allocates once per normalised base URL" $ do     let url = "https://cache-openai.test"     before <- Transport.cachedClientEnvCount     _ <- Transport.getClientEnvCached url@@ -35,6 +61,13 @@     afterSecond <- Transport.cachedClientEnvCount     afterFirst @?= before + 1     afterSecond @?= afterFirst+    -- A different spelling of the same target: capitalised host,+    -- trailing slash.+    env <- Transport.getClientEnvCached "https://Cache-openai.test/"+    afterVariant <- Transport.cachedClientEnvCount+    afterVariant @?= afterSecond+    Client.baseUrlHost (Client.baseUrl env) @?= "cache-openai.test"+    Client.baseUrlPath (Client.baseUrl env) @?= ""  requestHeadersTest :: TestTree requestHeadersTest =@@ -60,6 +93,23 @@         "timeoutMs=1" `Text.isInfixOf` (be ^. #message) @?= True       Nothing -> assertFailure "expected timeout error" +nonPositiveTimeoutTest :: TestTree+nonPositiveTimeoutTest =+  testCase "runWithTimeout rejects a non-positive bound without running the action" $ do+    -- System.Timeout.timeout returns immediately at zero and runs+    -- unbounded below it, so both spellings used to fail instantly as a+    -- retryable TransientError, which a retry loop re-issues forever for+    -- what is a caller-side mistake.+    forM_ [0, -5] $ \ms -> do+      ran <- newIORef False+      result <- Transport.runWithTimeout (Just ms) (writeIORef ran True)+      case result of+        Just be -> do+          be ^. #category @?= InvalidRequest+          isRetryable be @?= False+        Nothing -> assertFailure ("expected an InvalidRequest for timeoutMs=" <> show ms)+      readIORef ran >>= (@?= False)+ unknownHostKeyTest :: TestTree unknownHostKeyTest =   testCase "unknown hosts do not fall back to OPENAI_API_KEY" $@@ -79,3 +129,91 @@     (lookupEnv name <* setEnv name value)     (maybe (unsetEnv name) (setEnv name))     . const++-- | A base URL baikai will not send to is refused before a key is read.+--+-- The order matters as much as the refusal. These cases run with the+-- provider's own key variable *unset*, so an AuthError would prove the+-- check ran too late; an InvalidRequest proves nothing was looked up.+-- The messages also have to say what is wrong without echoing the part+-- of the URL that could be a credential.+unusableBaseUrlTest :: TestTree+unusableBaseUrlTest =+  testCase "an unusable base URL is refused before any key is read"+    $ withoutEnv "OPENAI_OpenAIChatCompletions_KEY"+    $ forM_+      [ ("https://h.test/v1?api-version=2024-01", "query string"),+        ("https://u:pw@h.test", "credentials"),+        ("h.test", "https://"),+        ("https://h.test/v1/chat/completions", "endpoint path")+      ]+    $ \(url, needle) -> do+      let model = emptyModel & #api .~ OpenAIChatCompletions & #baseUrl .~ url+      events <- Stream.toList (openaiChatStream model emptyContext emptyOptions)+      case events of+        [EventStart _, EventError payload] -> case payload ^. #errorInfo of+          Nothing -> assertFailure (Text.unpack url <> ": the error carried no errorInfo")+          Just err -> do+            let message = err ^. #message+            (url, err ^. #category) @?= (url, InvalidRequest)+            assertBool+              (Text.unpack (url <> " should name the problem: " <> message))+              (needle `Text.isInfixOf` message)+            assertBool+              (Text.unpack (url <> " must not echo the query: " <> message))+              (not ("api-version=2024-01" `Text.isInfixOf` message))+            assertBool+              (Text.unpack (url <> " must not echo the password: " <> message))+              (not ("pw@" `Text.isInfixOf` message))+        other ->+          assertFailure+            (Text.unpack url <> ": expected [EventStart, EventError], got: " <> show other)++withoutEnv :: String -> IO a -> IO a+withoutEnv name =+  bracket+    (lookupEnv name <* unsetEnv name)+    (maybe (unsetEnv name) (setEnv name))+    . const++endpointRejectionTest :: TestTree+endpointRejectionTest = testCase "endpoint capability rejection precedes network on complete and stream" $ do+  calls <- newIORef (0 :: Int)+  let driver _ _ _ _ _ = modifyIORef' calls (+ 1)+      stream = openaiChatStreamWith driver+      model = chatRestrictedModel & #modelId .~ "renamed-text-only"+      tool = mkTool "lookup" "lookup" (Aeson.object [])+      provider =+        apiProviderWith OpenAIChatCompletions stream (streamingComplete stream)+          & #describeThinking .~ (\m opts -> describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning) opts)+      options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "unused")+  reg <- newProviderRegistry+  registerApiProviderWith reg provider+  forM_+    [ (emptyContext & #tools .~ Vector.singleton tool, options),+      (emptyContext, options & #toolChoice .~ Just ToolChoiceRequired),+      (emptyContext, options & #toolChoice .~ Just (ToolChoiceSpecific "lookup"))+    ]+    $ \(ctx, opts) -> do+      events <- Stream.toList (streamRequestWith reg model ctx opts)+      assertErrorContract events+      case last events of+        EventError payload -> case payload ^. #errorInfo of+          Just err -> do+            err ^. #category @?= InvalidRequest+            assertBool "actionable Responses explanation" ("Responses" `Text.isInfixOf` (err ^. #message))+          _ -> assertFailure "missing error"+        _ -> assertFailure "expected error terminal"+      response <- completeRequestWith reg model ctx opts+      response ^. (#message . #stopReason) @?= ErrorReason+  let strict =+        options+          & #thinking .~ Just ThinkingMinimal+          & #evidence .~ Just (evidenceRequest "strict-endpoint" & #strictness .~ EvidenceRequired EvidenceRequestedOnly)+  strictEvents <- Stream.toList (streamRequestWith reg model emptyContext strict)+  assertErrorContract strictEvents+  strictResponse <- completeRequestWith reg model emptyContext strict+  case responseError strictResponse of+    Just err -> err ^. #category @?= InvalidRequest+    _ -> assertFailure "strict complete must refuse adjusted reasoning"+  readIORef calls >>= (@?= 0)