diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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..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: ` — 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 ``. `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.

.Api` to + `Baikai.Provider.

.Internal.Stream` — the `SseDriver` seam, `liveSseDriver`, + `

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 + (`//`), 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 `` in any report or structured error. + + New dependencies: `settei`, `settei-env`, `settei-kdl`, and + `settei-optparse-applicative` (all `^>=0.2`, published on Hackage at + `0.2.0.0`), plus `containers` and `filepath`. `settei-formats` is deliberately + excluded, because it bundles Dhall loading and repository configuration is + untrusted input here. + +- `baikai-agent`: the **`baikai` executable**, with the `agent run`, + `agent show`, and `agent list` commands, and the `Baikai.Agent.Cli` module + that implements them. A shell script now invokes one stable command, supplies + a prompt on standard input, and selects Claude Code or Codex entirely through + configuration. + + `agent run` resolves the named job, caps it against the operator ceiling, + renders it through the vendor renderer for its provider, and spawns it. The + agent's own exit code passes through unchanged; Baikai's own failures use 64 + and above following the `sysexits` convention — 64 for a usage error or an + empty prompt, 69 when the executable could not be started, 70 for malformed + output, 75 for a timeout, 77 for a policy refusal, and 78 for a configuration + problem. The prompt comes from `--prompt-stdin`, `--prompt-file`, or + `--prompt`, which are mutually exclusive, and is decoded as UTF-8 explicitly + rather than through the handle's locale encoding. + + `agent show` performs the whole pipeline except spawning and prints each + resolved value with the file, line, and column it came from, the policy + ceiling in force and where it was read, and the exact argument vector that + would be spawned — with `` in place of any raw provider argument. A + job whose policy is refused prints its configuration first and then the + refusal. `agent list` enumerates configured jobs and the scope each came from. + + Every Baikai diagnostic goes to standard error. The agent's own output follows + the job's output mode, so `response=$(baikai agent run job)` yields the + agent's answer alone for a capturing job. `--set KEY=VALUE` overrides one + setting of the selected job through `settei`'s own command-line source, so an + override is attributed with the same fidelity as a file. `--json` emits + exactly one JSON object per command. + + New dependencies for `baikai-agent`: `baikai-claude`, `baikai-openai`, and + `optparse-applicative`. The provider packages are needed only so that + `renderJobCommand`, the single provider dispatch point in the codebase, can + reach both renderers. This is the first dependency in the workspace from + `baikai-agent` onto the provider packages, so `baikai-agent` now publishes + after all three of `baikai`, `baikai-claude`, and `baikai-openai`. + + The user guide `docs/user/unattended-agent-runs.md` documents the whole + surface: the three commands with their flags, exit codes, and stream + discipline; the KDL job format and layer precedence; the operator ceiling and + redaction; the capability mapping tables for both tools; and a before-and-after + migration of a script that embeds provider flags today. + `docs/user/cli-providers.md` and `docs/user/interactive-launches.md` link to + it, and the capability mapping tables moved there from the latter. + +- `baikai-agent`: **an unattended coding-agent run now produces model-call + evidence.** This surface previously had no observability of any kind: no trace + sink, no `Response`, no usage, no identifiers. An operator could show that a + process started, exited, and took some time; they could not show which model + ran, which reasoning effort was applied, or which agent session the run + corresponds to in the vendor's records. + + A record carries the run and call identifiers, the resolved executable and its + own reported version, digests over the request, the requested model and what + the reasoning-effort request became on the command line, whatever the tool + reported about itself, the outcome, and an honest strength. + + **A zero exit status never raises the strength.** On this surface that rule + matters more than anywhere else, because almost every unattended run exits + zero. A coding agent that exits zero has demonstrated that it ran, not which + model served it. + + Two things gate what a record can prove, and neither is the default. The job + must **capture** output — under `inherit` the agent's bytes went to the + operator's terminal and baikai never held them — and the tool must be + configured to print a structured format, which means `--output-format json` + for `claude` or `--json` for `codex exec` through the job's `provider-args`. + Without both, the tool's session identifier, model, and token counts are + genuinely unavailable and the record says `"unobserved"` rather than inferring + anything. A timed-out run records `aborted`; a run that never started records + nothing at all. + +- **Breaking:** `baikai-agent`: `Baikai.Agent.Run.runAgentCommand` takes two new + leading arguments and returns the new outcome type: + `Maybe EvidenceRequest -> ThinkingTranslation -> AgentRunRequest -> AgentCommand -> IO AgentRunOutcome`. + A caller who wants the previous behaviour passes `Nothing` and + `Baikai.Evidence.noThinkingRequested` and reads the `outcome` field; that path + is byte-for-byte what it was, and costs what it cost — no digest is computed, + no call identifier is generated, and the tool is not invoked a second time to + read its version. + +- `baikai-agent`: `baikai agent run` gains `--evidence-file PATH` and + `--run-id TEXT`. Supplying neither leaves the run on the pre-existing path at + the pre-existing cost; supplying either turns recording on, with the job's own + name standing in as the run identifier when only a destination is given. The + file is written atomically — a staging file beside the destination, then a + rename — so a reader polling the path never sees a half-written object, and it + is never appended to. A failed write is reported on standard error and never + changes the exit code, because the agent's own status is what a calling script + branches on. `docs/user/unattended-agent-runs.md` documents both options and, + more importantly, what the record does and does not prove. + +- `baikai-agent`: `baikai agent run` gains `--require-evidence STRENGTH`, taking + `requested_only`, `correlated`, `model_observed`, or `fully_observed` — the + same words a record's `strength` field spells, so what one record showed can + be passed back as the next run's requirement. A job whose configuration cannot + produce evidence of at least that strength is refused before anything is + spawned, exiting 77 — the code a ceiling violation and an inexpressible safety + policy already use, so a script branching on 77 needs no new case. + +## [baikai-claude 0.4.0.1] - 2026-07-30 + +### Fixed + +- Widened the `crypton` bound from `^>=1.0` to `>=1.0 && <1.2` so consumers can + build `baikai-claude` alongside packages that require `crypton` 1.1.x (for + example `pg-migrate-1.1.0.0`), which previously had no solvable build plan. + The only `crypton` use is `Crypto.Hash` (`Digest`, `SHA256`) in + `Baikai.Provider.Claude.Transport`, whose API is identical across the 1.0/1.1 + boundary. No API change. + +## [baikai 0.4.1.0] - 2026-07-20 + +### Changed + +- 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 ` (`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=` 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. diff --git a/baikai-openai.cabal b/baikai-openai.cabal --- a/baikai-openai.cabal +++ b/baikai-openai.cabal @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Agent.hs b/src/Baikai/Provider/OpenAI/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Agent.hs @@ -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 @\@ 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) diff --git a/src/Baikai/Provider/OpenAI/Api.hs b/src/Baikai/Provider/OpenAI/Api.hs --- a/src/Baikai/Provider/OpenAI/Api.hs +++ b/src/Baikai/Provider/OpenAI/Api.hs @@ -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 @@ or @@ 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 = ["", ""] - -closingTags :: [Text] -closingTags = ["", ""] - --- | 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 diff --git a/src/Baikai/Provider/OpenAI/Cli.hs b/src/Baikai/Provider/OpenAI/Cli.hs --- a/src/Baikai/Provider/OpenAI/Cli.hs +++ b/src/Baikai/Provider/OpenAI/Cli.hs @@ -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) diff --git a/src/Baikai/Provider/OpenAI/Interactive.hs b/src/Baikai/Provider/OpenAI/Interactive.hs --- a/src/Baikai/Provider/OpenAI/Interactive.hs +++ b/src/Baikai/Provider/OpenAI/Interactive.hs @@ -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 = diff --git a/src/Baikai/Provider/OpenAI/Internal/ErrorClass.hs b/src/Baikai/Provider/OpenAI/Internal/ErrorClass.hs --- a/src/Baikai/Provider/OpenAI/Internal/ErrorClass.hs +++ b/src/Baikai/Provider/OpenAI/Internal/ErrorClass.hs @@ -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) diff --git a/src/Baikai/Provider/OpenAI/Internal/Request.hs b/src/Baikai/Provider/OpenAI/Internal/Request.hs --- a/src/Baikai/Provider/OpenAI/Internal/Request.hs +++ b/src/Baikai/Provider/OpenAI/Internal/Request.hs @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Internal/Stream.hs b/src/Baikai/Provider/OpenAI/Internal/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Internal/Stream.hs @@ -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 @@ or @@ 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 = ["", ""] + +closingTags :: [Text] +closingTags = ["", ""] + +-- | 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) diff --git a/src/Baikai/Provider/OpenAI/Internal/Usage.hs b/src/Baikai/Provider/OpenAI/Internal/Usage.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Internal/Usage.hs @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Responses.hs b/src/Baikai/Provider/OpenAI/Responses.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses.hs @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Responses/Assembler.hs b/src/Baikai/Provider/OpenAI/Responses/Assembler.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Assembler.hs @@ -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" diff --git a/src/Baikai/Provider/OpenAI/Responses/Request.hs b/src/Baikai/Provider/OpenAI/Responses/Request.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Request.hs @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Responses/Stream.hs b/src/Baikai/Provider/OpenAI/Responses/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Stream.hs @@ -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) diff --git a/src/Baikai/Provider/OpenAI/Shape.hs b/src/Baikai/Provider/OpenAI/Shape.hs --- a/src/Baikai/Provider/OpenAI/Shape.hs +++ b/src/Baikai/Provider/OpenAI/Shape.hs @@ -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 = diff --git a/src/Baikai/Provider/OpenAI/Sse.hs b/src/Baikai/Provider/OpenAI/Sse.hs --- a/src/Baikai/Provider/OpenAI/Sse.hs +++ b/src/Baikai/Provider/OpenAI/Sse.hs @@ -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 diff --git a/src/Baikai/Provider/OpenAI/Transport.hs b/src/Baikai/Provider/OpenAI/Transport.hs --- a/src/Baikai/Provider/OpenAI/Transport.hs +++ b/src/Baikai/Provider/OpenAI/Transport.hs @@ -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) diff --git a/test/BillingSpec.hs b/test/BillingSpec.hs new file mode 100644 --- /dev/null +++ b/test/BillingSpec.hs @@ -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) diff --git a/test/CliEvidenceSpec.hs b/test/CliEvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/CliEvidenceSpec.hs @@ -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 diff --git a/test/Contract.hs b/test/Contract.hs new file mode 100644 --- /dev/null +++ b/test/Contract.hs @@ -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) diff --git a/test/EndpointModels.hs b/test/EndpointModels.hs new file mode 100644 --- /dev/null +++ b/test/EndpointModels.hs @@ -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] + ) diff --git a/test/ErrorClassSpec.hs b/test/ErrorClassSpec.hs --- a/test/ErrorClassSpec.hs +++ b/test/ErrorClassSpec.hs @@ -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) diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/EvidenceSpec.hs @@ -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") diff --git a/test/LifecycleSpec.hs b/test/LifecycleSpec.hs new file mode 100644 --- /dev/null +++ b/test/LifecycleSpec.hs @@ -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" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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 +-- @\@-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 = diff --git a/test/MidStreamSpec.hs b/test/MidStreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/MidStreamSpec.hs @@ -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) diff --git a/test/PublicSurfaceSpec.hs b/test/PublicSurfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/PublicSurfaceSpec.hs @@ -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) diff --git a/test/ReasoningSpec.hs b/test/ReasoningSpec.hs --- a/test/ReasoningSpec.hs +++ b/test/ReasoningSpec.hs @@ -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 "reasoninganswer" 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] diff --git a/test/ResponsesAssemblerSpec.hs b/test/ResponsesAssemblerSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesAssemblerSpec.hs @@ -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]] diff --git a/test/ResponsesEvidenceSpec.hs b/test/ResponsesEvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesEvidenceSpec.hs @@ -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)] diff --git a/test/ResponsesSpec.hs b/test/ResponsesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesSpec.hs @@ -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 + _ -> [] diff --git a/test/ResponsesStreamSpec.hs b/test/ResponsesStreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesStreamSpec.hs @@ -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)]]]] diff --git a/test/ResponsesTransportSpec.hs b/test/ResponsesTransportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesTransportSpec.hs @@ -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/"] + ] diff --git a/test/ShapeSpec.hs b/test/ShapeSpec.hs --- a/test/ShapeSpec.hs +++ b/test/ShapeSpec.hs @@ -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" diff --git a/test/SseSpec.hs b/test/SseSpec.hs --- a/test/SseSpec.hs +++ b/test/SseSpec.hs @@ -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" diff --git a/test/TransportSpec.hs b/test/TransportSpec.hs --- a/test/TransportSpec.hs +++ b/test/TransportSpec.hs @@ -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)