diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2287 @@ +# 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.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-claude.cabal b/baikai-claude.cabal --- a/baikai-claude.cabal +++ b/baikai-claude.cabal @@ -1,18 +1,21 @@ -cabal-version: 3.4 -name: baikai-claude -version: 0.5.0.0 -synopsis: Anthropic Claude providers for the baikai abstraction +cabal-version: 3.4 +name: baikai-claude +version: 0.6.0.0 +synopsis: Anthropic Claude providers for the baikai abstraction description: - Wraps the claude Haskell package as a Baikai Provider for both the Anthropic API and the - claude -p CLI. + Anthropic backends for baikai: the Messages API over SSE, the claude -p batch + provider, a launcher for interactive Claude Code sessions, and the renderer for + unattended claude 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: @@ -53,6 +56,7 @@ Baikai.Provider.Claude.Interactive Baikai.Provider.Claude.Internal.ErrorClass Baikai.Provider.Claude.Internal.Request + Baikai.Provider.Claude.Internal.Stream Baikai.Provider.Claude.Shape Baikai.Provider.Claude.Sse Baikai.Provider.Claude.Transport @@ -61,14 +65,16 @@ autogen-modules: Paths_baikai_claude build-depends: , aeson ^>=2.2 - , baikai ^>=0.5.0 + , baikai ^>=0.6.0 , base >=4.20 && <5 + , base16-bytestring ^>=1.0 , base64-bytestring ^>=1.2 , bytestring ^>=0.12 , case-insensitive ^>=1.2 - , claude ^>=1.4 + , claude ^>=1.5 , containers ^>=0.7 , cradle ^>=0.0 + , cryptohash-sha256 ^>=0.11 , crypton >=1.0 && <1.2 , generic-lens ^>=2.3 , http-client ^>=0.7 @@ -89,8 +95,12 @@ main-is: Main.hs other-modules: CliEvidenceSpec + Contract ErrorClassSpec EvidenceSpec + LifecycleSpec + MidStreamSpec + PublicSurfaceSpec ShapeSpec SseSpec ThinkingSpec @@ -100,7 +110,7 @@ ghc-options: -threaded -with-rtsopts=-N build-depends: , aeson - , baikai ^>=0.5.0 + , baikai ^>=0.6.0 , baikai-claude , base >=4.20 && <5 , bytestring @@ -113,6 +123,7 @@ , http-client , http-types , lens ^>=5.3 + , network , servant-client , stm , streamly @@ -122,4 +133,5 @@ , temporary , text ^>=2.1 , time + , tls , vector diff --git a/src/Baikai/Provider/Claude/Agent.hs b/src/Baikai/Provider/Claude/Agent.hs --- a/src/Baikai/Provider/Claude/Agent.hs +++ b/src/Baikai/Provider/Claude/Agent.hs @@ -25,6 +25,7 @@ import Baikai.Agent ( AgentCapability (..), AgentCommand (..), + AgentOutputFormat (..), AgentPromptTransport (..), AgentProvider (..), AgentRenderError (..), @@ -100,6 +101,7 @@ <> sessionArgs cfg <> modelArgs req <> effortArgs req + <> outputFormatArgs req <> permission <> allowedToolArgs req <> extraDirArgs req @@ -185,8 +187,30 @@ claudeEffortValue ThinkingMinimal = "low" claudeEffortValue lvl = renderThinkingLevel lvl --- | Join tool names with commas into one argument rather than passing --- several values, because @--allowedTools@ is variadic and separate +-- | Ask @claude -p@ for a machine-readable result. +-- +-- @--output-format@ takes @text@ (the default), @json@ (one result +-- object) or @stream-json@. Baikai models the first two: @text@ renders +-- nothing, because a flag that restates the default is noise a reader +-- has to check. The @json@ shape is the one +-- 'Baikai.Provider.Cli.Internal.decodeClaudeCliResult' already parses, +-- which is what lets an evidence record name the session and the model. +outputFormatArgs :: AgentRunRequest -> [String] +outputFormatArgs req = case req ^. #outputFormat of + TextFormat -> [] + JsonFormat -> ["--output-format", "json"] + +-- | Render the request's tool __grants__. +-- +-- @--allowedTools@ pre-approves the named tools: its help reads "list +-- of tool names to allow", so this widens what the permission mode +-- would approve on its own rather than narrowing it. Whether the +-- operator permits each grant has already been decided by +-- 'Baikai.Agent.applyAgentCeiling' before a renderer is reached, so +-- nothing is checked here. +-- +-- The names are joined with commas into one argument rather than passed +-- as several values, because @--allowedTools@ is variadic and separate -- values could absorb a following flag. allowedToolArgs :: AgentRunRequest -> [String] allowedToolArgs req = case req ^. #safety . #allowedTools of diff --git a/src/Baikai/Provider/Claude/Api.hs b/src/Baikai/Provider/Claude/Api.hs --- a/src/Baikai/Provider/Claude/Api.hs +++ b/src/Baikai/Provider/Claude/Api.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} - -- | Provider wrapping the @claude@ package's Messages API. -- -- Call 'register' once (typically from @main@) to install the @@ -13,96 +11,37 @@ -- '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 that preserves HTTP status, --- headers, and body for error classification. Requests start as the --- SDK's typed 'Claude.V1.Messages.CreateMessage' value, then --- 'Baikai.Provider.Claude.Shape.streamRequestBody' patches the raw --- JSON body for tool-schema, @tool_choice@, and tool-cache compat --- before 'Baikai.Provider.Claude.Sse.claudeSseStreamValueWithHeaders' --- sends it with cached transport settings and caller headers. The --- synchronous 'complete' field is derived via 'streamingComplete', --- so callers that drain the stream get the same fully-assembled --- 'Response' they had before. +-- Streaming is the primary entry point. The handler exposes a +-- 'streamly' 'Stream' of 'AssistantMessageEvent' values bridged from a +-- local SSE transport that preserves HTTP status, headers, and body for +-- error classification. 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 assembler and the event translator — lives in +-- "Baikai.Provider.Claude.Internal.Stream", which carries no stability +-- guarantees. module Baikai.Provider.Claude.Api ( register, - registerWithRegistry, claudeMessagesProvider, claudeMessagesStream, - claudeMessagesStreamWith, - SseDriver, - anthropicStrength, - Assembler (..), - emptyAssembler, - translate, ) where import Baikai.Api (Api (..)) -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.Context (Context) import Baikai.Evidence qualified as Ev -import Baikai.Evidence.Build qualified as Build -import Baikai.Message qualified as Msg -import Baikai.Model (Model, anthropicMessagesCompatFor) -import Baikai.Options (Options (..)) -import Baikai.Provider.Claude.Internal.ErrorClass (classifyErrorValue, classifyException) -import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) -import Baikai.Provider.Claude.Shape (streamRequestBody) -import Baikai.Provider.Claude.Sse (claudeSseStreamValueWithHeaders) -import Baikai.Provider.Claude.Sse qualified as Sse -import Baikai.Provider.Claude.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 Claude.V1.Messages qualified as Messages -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.ByteString.Lazy qualified as BSL -import Data.CaseInsensitive qualified as CI +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Provider (ApiProvider, apiProvider) +import Baikai.Provider.Claude.Internal.Request (describeThinkingFor) +import Baikai.Provider.Claude.Internal.Stream (claudeMessagesStreamWith, liveSseDriver) +import Baikai.Provider.Registry (registerApiProvider) +import Baikai.Stream.Event (AssistantMessageEvent) +import Control.Lens ((&), (.~)) 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.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 Data.Version (showVersion) -import GHC.Generics (Generic) -import Network.HTTP.Types.Header (RequestHeaders) -import Paths_baikai_claude qualified as Paths -import Servant.Client qualified as Client import Streamly.Data.Stream (Stream) -import Streamly.Data.Stream qualified as Stream -- | Install the Anthropic Messages handler into the registry. -- Calling 'register' twice keeps only the second handler — the @@ -111,802 +50,46 @@ register = registerApiProvider claudeMessagesProvider -- | First-class Anthropic Messages provider value. Use with --- 'registerApiProviderWith' or 'newProviderRegistryFrom' for explicit --- registries. +-- 'Baikai.Provider.registerApiProviderWith' or +-- 'Baikai.Provider.newProviderRegistryFrom' for explicit registries. claudeMessagesProvider :: ApiProvider claudeMessagesProvider = - ApiProvider - { apiTag = AnthropicMessages, - stream = claudeMessagesStream, - complete = streamingComplete claudeMessagesStream, - -- The same function 'mapRequest' uses, so the gate's answer and - -- the wire's behaviour cannot disagree. - describeThinking = describeThinkingFor - } - --- | Install the Anthropic Messages handler into an explicit registry. -registerWithRegistry :: ProviderRegistry -> IO () -registerWithRegistry reg = - registerApiProviderWith - reg - claudeMessagesProvider -{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg claudeMessagesProvider" #-} + apiProvider AnthropicMessages claudeMessagesStream + -- 'describeThinkingFor' is the same function 'mapRequest' uses, so + -- the gate's answer and the wire's behaviour cannot disagree. + & #describeThinking .~ describeThinkingFor + & #strengthCeiling .~ Ev.declaredStrength AnthropicMessages -- | Streaming producer for the Anthropic Messages API. -- --- Forks one worker thread per call that drives --- the local Claude SSE transport; the worker pushes classified --- errors or typed 'Messages.MessageStreamEvent' values onto a bounded --- 'Chan' terminated by 'Nothing'. The returned 'Stream' is a --- translator: it pulls raw events from the channel and emits zero or --- more 'AssistantMessageEvent' values per upstream event, terminating --- with exactly one 'EventDone' or 'EventError'. +-- Forks one worker thread per call that drives the local Claude SSE +-- transport, pushing classified errors and typed +-- 'Claude.V1.Messages.MessageStreamEvent' values onto a bounded +-- 'Baikai.Provider.Internal.StreamWorker.FrameQueue'. The returned +-- 'Stream' is a translator: it pulls raw events off that queue and emits +-- zero or more 'AssistantMessageEvent' values per upstream event, +-- 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. +-- -- Producer-side exceptions (HTTP failure, decode failure inside the --- SDK, etc.) are caught with 'try' and re-encoded into an --- 'EventError' carrying whatever content was already assembled — --- the masterplan's "partial output is always recoverable" promise. +-- SDK, etc.) are caught and re-encoded into an +-- 'Baikai.Stream.Event.EventError' carrying whatever content was already +-- assembled — the "partial output is always recoverable" promise. claudeMessagesStream :: Model -> Context -> Options -> Stream IO AssistantMessageEvent claudeMessagesStream = claudeMessagesStreamWith liveSseDriver - --- | How a call physically reaches Anthropic. --- --- Production passes 'liveSseDriver'. A test passes one that replays a --- recorded response through the same --- 'Baikai.Provider.Claude.Sse.sseFromResponse' the live driver uses, so --- header capture, status classification, and SSE frame decoding are all --- the real implementations and only the socket is missing. -type SseDriver = - ClaudeCall -> - (Sse.ResponseMetadata -> IO ()) -> - (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> - IO () - -liveSseDriver :: SseDriver -liveSseDriver call = - claudeSseStreamValueWithHeaders - (call ^. #clientEnv) - (call ^. #requestHeaders) - (call ^. #requestBody) - --- | 'claudeMessagesStream' over an explicit transport driver. -claudeMessagesStreamWith :: - SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent -claudeMessagesStreamWith 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 - ch <- newChan :: IO (Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent))) - tref <- newIORef False - mref <- newIORef Nothing - _ <- forkIO (worker driver call mref ch) - 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.prepareEvidence - m - opts - Ev.TransportHttpApi - (call ^. #thinking) - (call ^. #requestBody) - startTime - let initialState = - ProducerState - { chan = ch, - pending = [], - assembler = emptyAssembler m startTime, - finished = False, - terminalRef = tref, - metadataRef = mref, - evidence = mkEvidence - } - pure (Stream.unfoldrM step initialState) - --- | Per-call prepared values, including the shaped JSON request body --- passed to the local streaming transport. -data ClaudeCall = ClaudeCall - { clientEnv :: !Client.ClientEnv, - requestHeaders :: !RequestHeaders, - timeoutMs :: !(Maybe Int), - requestBody :: !Aeson.Value, - -- | What the caller's reasoning-effort preference became on this - -- request, as 'mapRequest' described it. Carried from here rather - -- than recomputed at the terminal: only the request mapper knows - -- the host compat lookup and the max-tokens interaction that - -- produced it. - thinking :: !Ev.ThinkingTranslation - } - deriving stock (Generic) - -prepareCall :: - Model -> Context -> Options -> IO (Either BaikaiError ClaudeCall) -prepareCall m ctx opts = do - case mapRequest m ctx opts of - Left e -> pure (Left (invalidRequest e)) - Right (req, translation) -> do - let url = case m ^. #baseUrl of - "" -> "https://api.anthropic.com" - u -> u - compat = anthropicMessagesCompatFor m - version = Just "2023-06-01" - key <- Transport.resolveKey url opts - env <- Transport.getClientEnvCached url - let body = streamRequestBody compat ctx opts req - headers = Transport.requestHeaders key version compat ctx m opts - pure - ( Right - ClaudeCall - { clientEnv = env, - requestHeaders = headers, - timeoutMs = opts ^. #timeoutMs, - requestBody = body, - thinking = translation - } - ) - --- | Worker body: drive the SDK's typed callback, forwarding events --- onto the channel. Any exception is converted into a synthetic --- @Error@ raw event so the consumer side can translate it through --- the normal channel. After the SDK call returns (success or --- handled failure) we close the channel with 'Nothing'. -worker :: - SseDriver -> - ClaudeCall -> - IORef (Maybe Sse.ResponseMetadata) -> - Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)) -> - IO () -worker driver call metaRef ch = do - r <- - trySync $ - Transport.runWithTimeout (call ^. #timeoutMs) $ - driver - call - (writeIORef metaRef . Just) - (writeChan ch . Just) - 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 - --- | The streaming 'Stream' state. -data ProducerState = ProducerState - { chan :: !(Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent))), - pending :: ![AssistantMessageEvent], - assembler :: !Assembler, - finished :: !Bool, - terminalRef :: !(IORef Bool), - -- | Where the worker leaves the response-level metadata it captured - -- before the first event. 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 Sse.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 <- readChan (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 an event — 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 (ev, ass') = unexpectedEoS now ass0 - sealed <- sealTerminal (s' & #assembler .~ ass') ev - pure - ( Just - ( sealed, - s' & #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) - ) - ) - --- | Mark the stream terminated and attach the call's evidence to the --- terminal event. --- --- Every event this producer yields goes through here, and the three --- sites that can produce a terminal — a translated upstream event, a --- queued event drained from 'pending', and the unexpected-end-of-stream --- recovery — therefore 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 = observeAnthropic 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 provider did not --- make stays 'Ev.Unobserved'. -observeAnthropic :: - Ev.CallStatus -> Assembler -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence -observeAnthropic st ass ev = - ev - & #endpoint . #implementationVersion .~ Just claudePackageVersion - & #observedModel .~ (ass ^. #observedModel) - & #providerRequestId .~ (ass ^. #providerRequestId) - & #responseId .~ maybe Ev.Unobserved Ev.Observed (ass ^. #responseId) - & #usage .~ observedUsage ass - & #responseCommitment .~ responseCommitment st ass - & #strength .~ anthropicStrength (ass ^. #observedModel) (ass ^. #providerRequestId) - --- | How much an Anthropic evidence record proves, derived only from --- what was actually observed. --- --- Anthropic does not echo the thinking configuration it applied, so --- 'Ev.EvidenceFullyObserved' is unreachable on this transport. That is --- a fact about Anthropic's response shape, not a gap to paper over: a --- reasoning-token count corroborates output volume and says nothing --- about which effort setting was in force. --- --- A successful HTTP status deliberately does not raise the strength. A --- 200 means the request was accepted, not that any particular model ran. -anthropicStrength :: Ev.Observed Text -> Ev.Observed Text -> Ev.EvidenceStrength -anthropicStrength observedModel providerRequestId = - case (observedModel, providerRequestId) of - (Ev.Observed _, Ev.Observed _) -> Ev.EvidenceModelObserved - (_, Ev.Observed _) -> Ev.EvidenceCorrelated - _ -> Ev.EvidenceRequestedOnly - --- | The token accounting, but only if Anthropic actually reported it. --- --- The assembler initialises 'usage' to zeroes, so reporting it --- unconditionally would tell a reader the provider 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 frames must produce the same --- digest, and the frame boundaries are a transport detail no verifier --- holding the response could reproduce. -responseEnvelope :: Assembler -> Value -responseEnvelope ass = - Aeson.object - [ "content" Aeson..= blocksInOrder ass, - "stop_reason" Aeson..= (ass ^. #stopReason), - "usage" Aeson..= 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. -claudePackageVersion :: Text -claudePackageVersion = Text.pack (showVersion Paths.version) - --- | 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 Sse.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 - --- | Anthropic's correlation identifier for this response, or a --- gateway's if Anthropic's own is absent. --- --- The preference order is '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 :: Sse.ResponseMetadata -> Ev.Observed Text -correlationId md = - case [v | n <- Sse.capturedHeaderNames, Just v <- [lookup (headerName n) (md ^. #headers)]] of - (v : _) -> Ev.Observed v - [] -> Ev.Unobserved - where - headerName = Text.decodeUtf8 . CI.foldedCase - -terminal :: AssistantMessageEvent -> Bool -terminal = \case - EventDone {} -> True - EventError {} -> True - _ -> False - --- | The recovery path: channel closed before any terminal event. -unexpectedEoS :: - UTCTime -> Assembler -> (AssistantMessageEvent, Assembler) -unexpectedEoS now ass = - let errText = "claude stream ended without message_stop" - msg = finalMessageOnError ass now errText - in (EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg (providerError errText)), ass) - --- | Translation state across one streaming call. --- --- The four fields below @stopReason@ are what this call /observed/, as --- distinct from what it requested. They are kept here rather than --- derived at the terminal because this record is the only state that --- survives from the first event to the last, and because an observation --- that never arrived must stay 'Ev.Unobserved' rather than falling back --- to the caller's configuration. -data Assembler = Assembler - { model :: !Model, - start :: !UTCTime, - responseId :: !(Maybe Text), - closed :: !(IntMap Content.AssistantContent), - textBuf :: !(IntMap Text), - thinkBuf :: !(IntMap Text), - thinkSig :: !(IntMap Text), - redactedBuf :: !(IntMap Text), - toolArgsBuf :: !(IntMap Text), - toolMeta :: !(IntMap (Text, Text)), - usage :: !Usage.Usage, - stopReason :: !Stop.StopReason, - -- | Anthropic's own correlation identifier for this call, from the - -- response headers. - providerRequestId :: !(Ev.Observed Text), - -- | The model identifier Anthropic reported running, from - -- @message_start@. Never the configured model. - observedModel :: !(Ev.Observed Text), - -- | The response's HTTP status. Recorded because the transport has - -- it; 'Baikai.Evidence.ModelCallEvidence' has no field for it, and - -- inventing one is EP-1's decision to make, not this module's. - httpStatus :: !(Maybe Int), - -- | Whether Anthropic actually reported token counts, as opposed to - -- 'usage' still holding the zeroes it was initialised with. Without - -- this a failed call would claim the provider reported consuming - -- nothing. - usageReported :: !Bool - } - deriving stock (Generic) - -emptyAssembler :: Model -> UTCTime -> Assembler -emptyAssembler m s = - Assembler - { model = m, - start = s, - responseId = Nothing, - closed = IntMap.empty, - textBuf = IntMap.empty, - thinkBuf = IntMap.empty, - thinkSig = IntMap.empty, - redactedBuf = IntMap.empty, - toolArgsBuf = IntMap.empty, - toolMeta = IntMap.empty, - usage = Usage.zeroUsage, - stopReason = Stop.Stop, - providerRequestId = Ev.Unobserved, - observedModel = Ev.Unobserved, - httpStatus = Nothing, - usageReported = False - } - -translate :: - Either BaikaiError Messages.MessageStreamEvent -> - Assembler -> - UTCTime -> - ([AssistantMessageEvent], Assembler) -translate raw ass now = case raw of - Left be -> - let msg = finalMessageOnError ass now (be ^. #message) - in ([EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg be)], ass) - Right ev -> translateEvent ev ass now - -translateEvent :: - Messages.MessageStreamEvent -> - Assembler -> - UTCTime -> - ([AssistantMessageEvent], Assembler) -translateEvent raw ass now = case raw of - Messages.Ping -> ([], ass) - Messages.Message_Start {Messages.message = mr} -> - let usage0 = anthroUsageToBaikai (mr ^. #usage) - ass' = - ass - & #responseId .~ Just (mr ^. #id) - -- The provider's value, never the caller's. The SDK's - -- @model@ field is not optional, so a @message_start@ that - -- arrives at all is a genuine observation; a stream that - -- fails before one arrives leaves this 'Ev.Unobserved'. - & #observedModel .~ Ev.Observed (mr ^. #model) - & #usage .~ usage0 - & #usageReported .~ True - skeleton = skeletonMessage ass' now - in ([EventStart StartPayload {partial = skeleton, responseId = Just (mr ^. #id)}], ass') - Messages.Content_Block_Start {Messages.index = idx, Messages.content_block = block} -> - handleBlockStart (fromIntegral idx) block ass - Messages.Content_Block_Delta {Messages.index = idx, Messages.delta = d} -> - handleBlockDelta (fromIntegral idx) d ass - Messages.Content_Block_Stop {Messages.index = idx} -> - handleBlockStop (fromIntegral idx) ass - Messages.Message_Delta {Messages.message_delta = md, Messages.usage = su} -> - let stopR = mapStopReason (md ^. #stop_reason) - u = ass ^. #usage - outputTokensFinal = fromMaybe (u ^. #outputTokens) (Just (su ^. #output_tokens)) - u' = - u - & #outputTokens .~ outputTokensFinal - & #totalTokens - .~ ((u ^. #inputTokens) + outputTokensFinal + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens)) - in ([], ass & #stopReason .~ stopR & #usage .~ u' & #usageReported .~ True) - Messages.Message_Stop -> - let reason = ass ^. #stopReason - refusal = providerError "Anthropic refused to generate a response (stop_reason=refusal)" - msg = - if reason == Stop.ErrorReason - then finalMessageOnError ass now (refusal ^. #message) - else finalMessage ass now - terminalEvent = - if reason == Stop.ErrorReason - then EventError (errorTerminal Nothing (ass ^. #responseId) reason msg refusal) - else EventDone (doneTerminal Nothing (ass ^. #responseId) reason msg) - in ([terminalEvent], ass) - Messages.Error {Messages.error = errVal} -> - let errText = renderAnthropicError errVal - mErr = classifyErrorValue errVal - msg = finalMessageOnError ass now errText - errInfo = fromMaybe (providerError errText) mErr - in ([EventError (errorTerminal Nothing (ass ^. #responseId) Stop.ErrorReason msg errInfo)], ass) - -handleBlockStart :: - Int -> - Messages.ContentBlock -> - Assembler -> - ([AssistantMessageEvent], Assembler) -handleBlockStart i block ass = case block of - Messages.ContentBlock_Text {} -> - ( [TextStart IndexPayload {contentIndex = i}], - ass & #textBuf %~ IntMap.insert i Text.empty - ) - Messages.ContentBlock_Thinking {} -> - ( [ThinkingStart IndexPayload {contentIndex = i}], - ass & #thinkBuf %~ IntMap.insert i Text.empty - ) - Messages.ContentBlock_Redacted_Thinking {Messages.data_ = payload} -> - ( [ThinkingStart IndexPayload {contentIndex = i}], - ass & #redactedBuf %~ IntMap.insert i payload - ) - Messages.ContentBlock_Tool_Use {Messages.id = tid, Messages.name = tn} -> - ( [ToolCallStart IndexPayload {contentIndex = i}], - ass - & #toolArgsBuf %~ IntMap.insert i Text.empty - & #toolMeta %~ IntMap.insert i (tid, tn) - ) - _ -> - -- Server-tool, code-execution-tool, unknown — pass-through with no events. - ([], ass) - -handleBlockDelta :: - Int -> - Messages.ContentBlockDelta -> - Assembler -> - ([AssistantMessageEvent], Assembler) -handleBlockDelta i d ass = case d of - Messages.Delta_Text_Delta {Messages.text = t} -> - if IntMap.member i (ass ^. #textBuf) - then - ( [TextDelta DeltaPayload {contentIndex = i, delta = t}], - ass & #textBuf %~ IntMap.adjust (<> t) i - ) - else ([], ass) - Messages.Delta_Thinking_Delta {Messages.thinking = t} -> - if IntMap.member i (ass ^. #thinkBuf) - then - ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}], - ass & #thinkBuf %~ IntMap.adjust (<> t) i - ) - else ([], ass) - Messages.Delta_Signature_Delta {Messages.signature = sig} -> - -- Signatures are tail-end metadata on thinking blocks; they - -- attach to the ThinkingEnd event's content build, not a public - -- delta event. - if IntMap.member i (ass ^. #thinkBuf) - then - ( [], - ass & #thinkSig %~ IntMap.insertWith (\new old -> old <> new) i sig - ) - else ([], ass) - Messages.Delta_Input_Json_Delta {Messages.partial_json = j} -> - if IntMap.member i (ass ^. #toolArgsBuf) - then - ( [ToolCallDelta DeltaPayload {contentIndex = i, delta = j}], - ass & #toolArgsBuf %~ IntMap.adjust (<> j) i - ) - else ([], ass) - -handleBlockStop :: - Int -> Assembler -> ([AssistantMessageEvent], Assembler) -handleBlockStop i ass - | Just body <- IntMap.lookup i (ass ^. #textBuf) = - let block = Content.AssistantText (Content.TextContent body) - in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}], - ass - & #closed %~ IntMap.insert i block - & #textBuf %~ IntMap.delete i - ) - | Just payload <- IntMap.lookup i (ass ^. #redactedBuf) = - let thinkingContent = - Content.ThinkingContent - { Content.thinking = payload, - Content.signature = Nothing, - Content.redacted = True - } - block = Content.AssistantThinking thinkingContent - in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], - ass - & #closed %~ IntMap.insert i block - & #redactedBuf %~ IntMap.delete i - ) - | Just body <- IntMap.lookup i (ass ^. #thinkBuf) = - let sig = IntMap.lookup i (ass ^. #thinkSig) - thinkingContent = - Content.ThinkingContent - { Content.thinking = body, - Content.signature = if maybe True Text.null sig then Nothing else sig, - Content.redacted = False - } - block = Content.AssistantThinking thinkingContent - in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], - ass - & #closed %~ IntMap.insert i block - & #thinkBuf %~ IntMap.delete i - & #thinkSig %~ IntMap.delete i - ) - | Just argsText <- IntMap.lookup i (ass ^. #toolArgsBuf) = - let (tid, tn) = - -- A tool args buffer is opened together with metadata in - -- handleBlockStart; the fallback is defensive only. - fromMaybe ("", "") (IntMap.lookup i (ass ^. #toolMeta)) - decoded :: Value - decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 argsText) of - Right v -> v - Left _ -> - -- Anthropic sometimes opens a tool_use block with an - -- empty input that never streams any delta. Fall back - -- to an empty object so the resulting ToolCall is - -- well-formed. - Aeson.Object mempty - tc = - Content.ToolCall - { Content.id_ = tid, - Content.name = tn, - Content.arguments = decoded - } - block = Content.AssistantToolCall tc - in ( [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}], - ass - & #closed %~ IntMap.insert i block - & #toolArgsBuf %~ IntMap.delete i - & #toolMeta %~ IntMap.delete i - ) - | otherwise = ([], ass) - --- | The 'EventStart' message skeleton (empty content; usage/etc. --- carried for downstream consumers that want metadata up front). -skeletonMessage :: Assembler -> UTCTime -> Msg.Message -skeletonMessage ass _now = - Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = Vector.empty, - Msg.usage = ass ^. #usage, - Msg.stopReason = Stop.Stop, - Msg.errorMessage = Nothing, - Msg.timestamp = Just (ass ^. #start) - } - --- | The assembler's token accounting with this model's pricing applied. --- Shared so the terminal message and the evidence record cannot report --- two different figures for one call. -finalUsage :: Assembler -> Usage.Usage -finalUsage ass = - let usageBare = ass ^. #usage - in usageBare & #cost .~ Pricing.computeCost (ass ^. #model) usageBare - -finalMessage :: Assembler -> UTCTime -> Msg.Message -finalMessage ass now = - Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = blocksInOrder ass, - Msg.usage = finalUsage ass, - Msg.stopReason = ass ^. #stopReason, - Msg.errorMessage = Nothing, - Msg.timestamp = Just now - } - -finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message -finalMessageOnError ass now reason = - Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = blocksInOrder ass, - Msg.usage = finalUsage ass, - Msg.stopReason = Stop.ErrorReason, - Msg.errorMessage = Just reason, - Msg.timestamp = Just now - } - -blocksInOrder :: Assembler -> Vector Content.AssistantContent -blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed)) - --- | The immediate "request invalid" stream — emitted when --- 'mapRequest' fails or 'prepareCall' is otherwise unable to build --- a valid SDK request. --- | The immediate "request invalid" stream. --- --- 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.minimalEvidence - m - opts - Ev.TransportHttpApi - Ev.noThinkingRequested - (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) - ] - -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) - -renderAnthropicError :: Value -> Text -renderAnthropicError v = case v of - Aeson.String t -> t - _ -> Text.decodeUtf8 (BSL.toStrict (Aeson.encode v)) - --- | Map the Anthropic streaming 'Message_Start.message.usage' value --- into baikai's 'Usage' shape. Cache-related counters are populated --- where present; cost is left at zero (the terminal event --- recomputes it). -anthroUsageToBaikai :: Messages.Usage -> Usage.Usage -anthroUsageToBaikai u = - let i = u ^. #input_tokens - o = u ^. #output_tokens - cr = fromMaybe 0 (u ^. #cache_read_input_tokens) - cw = fromMaybe 0 (u ^. #cache_creation_input_tokens) - in Usage.Usage - { Usage.inputTokens = i, - Usage.outputTokens = o, - Usage.cacheReadTokens = cr, - Usage.cacheWriteTokens = cw, - Usage.reasoningTokens = Nothing, - Usage.totalTokens = i + o + cr + cw, - Usage.cost = zeroCost - } - -mapStopReason :: Maybe Messages.StopReason -> Stop.StopReason -mapStopReason = \case - Just Messages.End_Turn -> Stop.Stop - Just Messages.Max_Tokens -> Stop.Length - Just Messages.Stop_Sequence -> Stop.Stop - Just Messages.Tool_Use -> Stop.ToolUse - Just Messages.Refusal -> Stop.ErrorReason - Just Messages.Model_Context_Window_Exceeded -> Stop.Length - Nothing -> Stop.Stop diff --git a/src/Baikai/Provider/Claude/Cli.hs b/src/Baikai/Provider/Claude/Cli.hs --- a/src/Baikai/Provider/Claude/Cli.hs +++ b/src/Baikai/Provider/Claude/Cli.hs @@ -3,8 +3,8 @@ -- -- Call 'register' once (typically from @main@) to install the -- 'Baikai.Api.AnthropicMessagesCli' handler with default config. --- For non-default executable paths or extra args, use 'registerWith' --- and supply a custom 'ClaudeCliConfig'. +-- For non-default executable paths or extra args, register +-- @claudeCliProvider cfg@ with a custom 'ClaudeCliConfig'. -- -- The 'Response' this provider returns carries whatever the tool -- reported about its own run: the token counts and total cost from the @@ -31,9 +31,6 @@ defaultClaudeCliConfig, claudeCliProvider, register, - registerWith, - registerWithRegistry, - registerWithRegistryAndConfig, ) where @@ -49,9 +46,8 @@ 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 (..)) @@ -99,49 +95,27 @@ register = registerApiProvider (claudeCliProvider defaultClaudeCliConfig) -- | First-class Claude CLI provider value for a caller-supplied config. -claudeCliProvider :: ClaudeCliConfig -> ApiProvider -claudeCliProvider cfg = - ApiProvider - { apiTag = AnthropicMessagesCli, - stream = liftCompleteToStream (runClaudeCli cfg), - complete = runClaudeCli cfg, - -- The model plays no part: this transport's only reasoning - -- control is a command-line flag derived from Options alone. - describeThinking = \_ opts -> claudeCliThinking opts - } - --- | Install the CLI handler with a caller-supplied config. -- -- The CLI binary runs in batch mode; there is no intra-response --- streaming on the wire. The 'stream' field therefore wraps the +-- streaming on the wire. The @stream@ field therefore wraps the -- batch 'runClaudeCli' through 'liftCompleteToStream', producing a -- synthetic one-shot event stream -- (@EventStart, TextStart 0, TextDelta 0 body, TextEnd 0, EventDone@) --- the moment the subprocess returns. 'complete' is left as the --- direct batch path so it preserves 'Response.responseId' and the --- measured 'Response.latencyMs' (going through a --- 'streamingComplete' round trip would lose the former and recompute --- the latter from synthetic events). EP-3's Decision Log explains --- the deviation from the plan's "complete = streamingComplete . --- stream" default. -registerWith :: ClaudeCliConfig -> IO () -registerWith cfg = registerApiProvider (claudeCliProvider cfg) -{-# DEPRECATED registerWith "use registerApiProvider (claudeCliProvider cfg)" #-} - --- | Install the CLI handler with 'defaultClaudeCliConfig' into an explicit --- registry. -registerWithRegistry :: ProviderRegistry -> IO () -registerWithRegistry reg = registerWithRegistryAndConfig reg defaultClaudeCliConfig -{-# DEPRECATED registerWithRegistry "use registerApiProviderWith reg (claudeCliProvider defaultClaudeCliConfig)" #-} - --- | Install the CLI handler with a caller-supplied config into an explicit --- registry. -registerWithRegistryAndConfig :: ProviderRegistry -> ClaudeCliConfig -> IO () -registerWithRegistryAndConfig reg cfg = - registerApiProviderWith - reg - (claudeCliProvider cfg) -{-# DEPRECATED registerWithRegistryAndConfig "use registerApiProviderWith reg (claudeCliProvider cfg)" #-} +-- the moment the subprocess returns. @complete@ is left as the +-- direct batch path so it preserves 'Baikai.Response.responseId' and +-- the measured 'Baikai.Response.latencyMs' (going through a +-- 'Baikai.Stream.streamingComplete' round trip would lose the former +-- and recompute the latter from synthetic events). +claudeCliProvider :: ClaudeCliConfig -> ApiProvider +claudeCliProvider cfg = + apiProviderWith + AnthropicMessagesCli + (liftCompleteToStream (runClaudeCli cfg)) + (runClaudeCli cfg) + -- The model plays no part: this transport's only reasoning + -- control is a command-line flag derived from Options alone. + & #describeThinking .~ (\_ opts -> claudeCliThinking opts) + & #strengthCeiling .~ Ev.declaredStrength AnthropicMessagesCli -- | Render the executable and arguments for a @claude -p@ batch call. -- The prompt is preceded by @--@ so dash-leading prompts and variadic diff --git a/src/Baikai/Provider/Claude/Internal/ErrorClass.hs b/src/Baikai/Provider/Claude/Internal/ErrorClass.hs --- a/src/Baikai/Provider/Claude/Internal/ErrorClass.hs +++ b/src/Baikai/Provider/Claude/Internal/ErrorClass.hs @@ -5,15 +5,14 @@ -- and semantics here may change in minor releases. -- -- Two entry points cover the two ways a failure reaches the provider: --- 'classifyException' for an exception thrown by the @servant-client@ --- HTTP layer, and 'classifyErrorValue' for an Anthropic @error@ event +-- 'classifyException' for 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 — and 'classifyErrorValue' for an Anthropic @error@ event -- that arrives mid-stream as a JSON 'Value'. module Baikai.Provider.Claude.Internal.ErrorClass ( classifyException, - classifyErrorText, classifyErrorValue, - -- | Exposed for testing the HTTP-status mapping without a live call. - responseToError, ) where @@ -21,98 +20,30 @@ ( BaikaiError (..), ErrorCategory (..), bodyIndicatesOverflow, - decodeError, - httpError, - invalidRequest, - parseRetryAfterSeconds, providerError, ) -import Control.Exception (SomeException, displayException, fromException) +import Baikai.Provider.Transport.Classify (classifyTransportException) +import Control.Exception (SomeException, displayException) import Data.Aeson (Value (..)) import Data.Aeson.KeyMap qualified as KeyMap -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 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 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 Anthropic 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 Anthropic 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)) - -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 Anthropic response" - Servant.InvalidContentTypeHeader _ -> decodeError "invalid content-type header in Anthropic response" - Servant.ConnectionError exc -> - (providerError ("connection error: " <> Text.pack (displayException exc))) - { category = TransientError - } - --- | Build a 'BaikaiError' from a non-2xx HTTP response: status code, --- @Retry-After@ header (when integer-valued), and a snippet of the body --- (which also feeds context-overflow detection). -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) - --- | Look up an integer @Retry-After@ header value (seconds). The HTTP --- date form is not parsed and yields 'Nothing'. -parseRetryAfter :: Seq (CI.CI ByteString, ByteString) -> Maybe Int -parseRetryAfter headers = do - raw <- lookup (CI.mk "Retry-After") (toList headers) - parseRetryAfterSeconds (decodeLenient raw) - -fromHttpException :: HTTP.HttpException -> BaikaiError -fromHttpException = \case - HTTP.InvalidUrlException url reason -> - invalidRequest (Text.pack (url <> ": " <> reason)) - HTTP.HttpExceptionRequest _ content -> fromHttpExceptionContent content - -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)) - 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 +classifyException ex = + fromMaybe + (providerError (Text.pack (displayException ex))) + (classifyTransportException ex) -- | Classify a mid-stream Anthropic @error@ event. The value is the -- inner error object, e.g. @{"type":"overloaded_error","message":"…"}@; @@ -133,20 +64,6 @@ stringField k o = case KeyMap.lookup k o of Just (String t) -> Just t _ -> Nothing - --- | Recover HTTP classification from the text shape emitted by the --- upstream SDK's non-2xx path. The local SSE transport preserves --- headers and should be preferred; this is a defense-in-depth parser. -classifyErrorText :: Text -> Maybe BaikaiError -classifyErrorText 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) -- | Map an Anthropic error @type@ string (plus its message, for the -- overflow special case) to a category. diff --git a/src/Baikai/Provider/Claude/Internal/Request.hs b/src/Baikai/Provider/Claude/Internal/Request.hs --- a/src/Baikai/Provider/Claude/Internal/Request.hs +++ b/src/Baikai/Provider/Claude/Internal/Request.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} -- | Internal request mapping for the Anthropic Messages provider. -- @@ -6,10 +7,14 @@ -- compatibility guarantees. Import the public provider module for stable application code. module Baikai.Provider.Claude.Internal.Request ( mapRequest, + planRequest, planThinking, describeThinkingFor, ThinkingPlan (..), + SamplingPlan (..), + uncappedMaxTokensFloor, computeThinking, + normalizeToolCallId, ) where @@ -26,18 +31,20 @@ import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) -import Baikai.ResponseFormat (ResponseFormat (..)) +import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel, thinkingTokenBudget) import Baikai.Tool qualified as Tool import Claude.V1.Messages qualified as Messages import Claude.V1.Tool qualified as ClaudeTool import Control.Lens ((%~), (&), (.~), (^.)) +import Crypto.Hash.SHA256 qualified as SHA256 import Data.Aeson ((.=)) import Data.Aeson qualified as Aeson +import Data.ByteString.Base16 qualified as Base16 import Data.ByteString.Base64 qualified as Base64 import Data.Char (isAlphaNum, isAscii) import Data.Generics.Labels () -import Data.Maybe (fromMaybe) +import Data.Maybe (catMaybes, fromMaybe) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -47,10 +54,16 @@ import Numeric.Natural (Natural) -- ============================================================ --- Request mapping (preserved from EP-2 with minor refactoring to --- accept Context/Options directly). +-- Request mapping: Context and Options onto the SDK's request record. -- ============================================================ +-- | 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 request onto the SDK's 'Messages.CreateMessage', and -- describe what the caller's reasoning-effort preference became on the -- way. @@ -64,12 +77,12 @@ mapRequest :: Model -> Context -> Options -> Either Text (Messages.CreateMessage, ThinkingTranslation) mapRequest m ctx opts = do - msgs <- traverse mapMessage (Vector.toList (ctx ^. #messages)) + msgs <- catMaybes <$> traverse mapMessage (Vector.toList (ctx ^. #messages)) let compat = anthropicMessagesCompatFor m cap = m ^. #maxOutputTokens - baseTokens = fromMaybe cap (opts ^. #maxTokens) + baseTokens = resolveBaseTokens m opts clamp n = if cap == 0 then n else min n cap - (plan, translation) = planThinking m opts + (plan, sampling, translation) = planRequest m opts maxTokensField_ = case budget plan of Just b -> clamp (baseTokens + b) Nothing -> clamp baseTokens @@ -90,9 +103,9 @@ Messages.messages = Vector.fromList msgs, Messages.max_tokens = maxTokensField_, Messages.system = fmap Messages.SystemPromptText (ctx ^. #systemPrompt), - Messages.temperature = opts ^. #temperature, - Messages.top_p = opts ^. #topP, - Messages.stop_sequences = opts ^. #stopSequences, + Messages.temperature = sampling ^. #temperature, + Messages.top_p = sampling ^. #topP, + Messages.stop_sequences = nonEmptyStops (opts ^. #stopSequences), Messages.tools = toolsField, Messages.tool_choice = toolChoiceField, Messages.cache_control = cacheControlField, @@ -102,43 +115,129 @@ translation ) --- | The thinking plan for one request and the description of how it got --- there, including the max-tokens interaction that can discard an --- already-computed budget. +-- | The sampling parameters that will reach the wire, after the compat +-- record's gate. 'Nothing' means the field is omitted — the SDK encodes +-- 'Messages.CreateMessage' with @omitNothingFields = True@, so a +-- 'Nothing' is genuinely absent from the request body rather than a +-- JSON @null@ the provider would reject. +data SamplingPlan = SamplingPlan + { temperature :: !(Maybe Double), + topP :: !(Maybe Double) + } + deriving stock (Eq, Show, Generic) + +-- | The @max_tokens@ sent for a model whose cap is unknown (@0@) when +-- the caller set no 'Baikai.Options.maxTokens'. -- +-- Anthropic requires @max_tokens@ on every request and rejects @0@, so +-- the OpenAI adapter's rule — omit the field entirely — is not +-- available here. 1024 is the SDK's own @_CreateMessage@ default and is +-- accepted by every generation and every known compatible host. +-- +-- This is a default, not a downgrade of anything the caller asked for, +-- so no adjustment is recorded: it is visible in the request body, which +-- the evidence record already digests. An explicit +-- @maxTokens = Just 0@ is forwarded as written. +uncappedMaxTokensFloor :: Natural +uncappedMaxTokensFloor = 1024 + +-- | The output-token base this request resolves to before any thinking +-- budget is added: the caller's 'Baikai.Options.maxTokens' if they set +-- one, the model's cap if it knows one, and 'uncappedMaxTokensFloor' +-- when neither is available. +resolveBaseTokens :: Model -> Options -> Natural +resolveBaseTokens m opts = case opts ^. #maxTokens of + Just n -> n + Nothing + | cap == 0 -> uncappedMaxTokensFloor + | otherwise -> cap + where + cap = m ^. #maxOutputTokens + +-- | Everything 'mapRequest' decides about thinking, sampling and the +-- output ceiling, and the one description of all of it. +-- -- Factored out of 'mapRequest' so the pre-dispatch strictness gate can -- ask what /would/ happen without building a request. Both callers go -- through this one function on purpose: a gate that reimplemented the -- ceiling arithmetic would miss the least discoverable of baikai's -- downgrades the first time either side changed, and it would miss it --- silently. +-- silently. The same argument puts sampling here rather than in +-- 'mapRequest': the adapter that builds the request owns the +-- description of what it translated +-- (@docs\/adr\/0003-the-adapter-owns-the-translation-description.md@), +-- and a dropped @temperature@ is a translation, not an absence +-- (@docs\/adr\/0002-requested-translated-observed-are-never-collapsed.md@). -- --- The interaction it captures: the output-token ceiling this request --- resolves to still has the thinking budget inside it, the budget has to --- fit, and when it does not the entire thinking plan is dropped. A --- caller who lowered @maxTokens@ on a reasoning model silently loses --- thinking, which is why both colliding numbers are recorded in the --- adjustment. +-- The thinking interaction it captures: the output-token ceiling this +-- request resolves to still has the thinking budget inside it, the +-- budget has to fit, and when it does not the entire thinking plan is +-- dropped. A caller who lowered @maxTokens@ on a reasoning model +-- silently loses thinking, which is why both colliding numbers are +-- recorded in the adjustment. +-- +-- The sampling gate: 'Baikai.Compat.supportsSamplingParameters' says +-- whether the model generation accepts @temperature@ and @top_p@ at +-- all. Adaptive-era generations reject them with a 400, so they are +-- dropped and the drop is recorded. Three more sampling controls — +-- @seed@, @frequencyPenalty@ and @presencePenalty@ — have no field in +-- the Anthropic Messages API on any generation, so they are recorded +-- separately: one is a fact about the model, the other about the API. +planRequest :: Model -> Options -> (ThinkingPlan, SamplingPlan, ThinkingTranslation) +planRequest m opts = + (plan, sampling, translation & #adjustments %~ (<> samplingAdjustments)) + where + compat = anthropicMessagesCompatFor m + cap = m ^. #maxOutputTokens + baseTokens = resolveBaseTokens m opts + clamp n = if cap == 0 then n else min n cap + (plan0, translation0) = computeThinking compat m (opts ^. #thinking) + resolvedCeiling = clamp (baseTokens + fromMaybe 0 (budget plan0)) + (plan, translation) = case (budget plan0, translation0 ^. #requested) of + (Just b, Just lvl) + | resolvedCeiling <= b -> + ( emptyThinkingPlan, + dropThinking (ThinkingDroppedBudgetExceeded lvl b resolvedCeiling) translation0 + ) + _ -> (plan0, translation0) + + gated = not (supportsSamplingParameters compat) + sampling + | gated = SamplingPlan {temperature = Nothing, topP = Nothing} + | otherwise = + SamplingPlan {temperature = opts ^. #temperature, topP = opts ^. #topP} + + -- In wire order, and only the ones the caller actually set. + modelDropped = + [name | (name, isSet) <- [("temperature", set_ (opts ^. #temperature)), ("top_p", set_ (opts ^. #topP))], isSet] + apiDropped = + [ name + | (name, isSet) <- + [ ("seed", set_ (opts ^. #seed)), + ("frequency_penalty", set_ (opts ^. #frequencyPenalty)), + ("presence_penalty", set_ (opts ^. #presencePenalty)) + ], + isSet + ] + set_ :: Maybe a -> Bool + set_ = maybe False (const True) + + samplingAdjustments = + [SamplingDroppedUnsupportedModel modelDropped | gated, not (null modelDropped)] + <> [SamplingDroppedUnsupportedApi apiDropped | not (null apiDropped)] + +-- | The thinking half of 'planRequest', for callers that need only it. planThinking :: Model -> Options -> (ThinkingPlan, ThinkingTranslation) -planThinking m opts = - let compat = anthropicMessagesCompatFor m - cap = m ^. #maxOutputTokens - baseTokens = fromMaybe cap (opts ^. #maxTokens) - clamp n = if cap == 0 then n else min n cap - (plan0, translation0) = computeThinking compat m (opts ^. #thinking) - resolvedCeiling = clamp (baseTokens + fromMaybe 0 (budget plan0)) - in case (budget plan0, translation0 ^. #requested) of - (Just b, Just lvl) - | resolvedCeiling <= b -> - ( emptyThinkingPlan, - dropThinking (ThinkingDroppedBudgetExceeded lvl b resolvedCeiling) translation0 - ) - _ -> (plan0, translation0) +planThinking m opts = let (plan, _, translation) = planRequest m opts in (plan, translation) -- | What this provider would do with the caller's reasoning-effort -- request, without building or sending anything. The -- 'Baikai.Provider.Registry.describeThinking' implementation for the -- Anthropic Messages provider. +-- +-- A projection of 'planRequest' rather than its own derivation, so the +-- gate, the builder and the evidence record all read one answer — the +-- sampling drops included. describeThinkingFor :: Model -> Options -> ThinkingTranslation describeThinkingFor m opts = snd (planThinking m opts) @@ -157,7 +256,7 @@ -- schema, which still forces the model to emit a JSON object. mkAnthropicOutputConfig :: ResponseFormat -> Messages.OutputConfig mkAnthropicOutputConfig = \case - JsonSchema {schema = s} -> Messages.jsonSchemaConfig s + JsonSchema f -> Messages.jsonSchemaConfig f.schema JsonObject -> Messages.jsonSchemaConfig (Aeson.object ["type" .= ("object" :: Text)]) @@ -341,37 +440,103 @@ -- Unreachable in typed requests: ToolChoiceNone is injected by the shaper. Tool.ToolChoiceNone -> ClaudeTool.ToolChoice_Auto --- | Anthropic enforces @[a-zA-Z0-9_-]+@ on tool-call ids and caps --- their length at 64 characters. Callers may have used any --- naming convention, so the provider boundary normalizes here --- whenever an id is round-tripped back to Anthropic — both on --- assistant turn replay ('Content_Tool_Use') and on tool-result --- messages ('Content_Tool_Result'). +-- | Anthropic enforces @[a-zA-Z0-9_-]@ on tool-call ids and caps their +-- length at 64 characters. Callers may have used any naming convention, +-- so the provider boundary normalizes here whenever an id is +-- round-tripped back to Anthropic — both on assistant turn replay +-- ('Messages.Content_Tool_Use') and on tool-result messages +-- ('Messages.Content_Tool_Result'). +-- +-- An id that already satisfies the rule passes through byte for byte. +-- That covers every id either provider actually mints — Anthropic's +-- @toolu_…@ and OpenAI's @call_…@ — and it must, because the +-- tool-result side normalizes with this same function and the two have +-- to agree. +-- +-- Any other id is sanitised, truncated to 51 characters and suffixed +-- with @_@ plus twelve lowercase hex characters of the SHA-256 of the +-- /original/. Mapping every disallowed character to @_@ and truncating +-- is not injective: @a.b@ and @a_b@ both became @a_b@, and two ids +-- differing only after character 64 both became the same 64 characters +-- — two distinct calls in one turn collapsing onto one id, which +-- silently misroutes a tool result. Forty-eight bits of hash make a +-- collision among one conversation's calls negligible, and 'mapMessage' +-- turns a remaining collision into a clear error rather than a +-- misrouted result. Refusing non-conforming ids outright was rejected: +-- it would break replay of any conversation begun on a provider with a +-- different id alphabet. normalizeToolCallId :: Text -> Text -normalizeToolCallId = - Text.take 64 . Text.map sanitise +normalizeToolCallId original + | isValid original = original + | otherwise = Text.take 51 (Text.map sanitise original) <> "_" <> suffix where - sanitise c - | isAscii c && isAlphaNum c = c - | c == '_' || c == '-' = c - | otherwise = '_' + isValid t = not (Text.null t) && Text.length t <= 64 && Text.all allowed t + allowed c = (isAscii c && isAlphaNum c) || c == '_' || c == '-' + sanitise c = if allowed c then c else '_' + suffix = + Text.take + 12 + (Text.decodeLatin1 (Base16.encode (SHA256.hash (Text.encodeUtf8 original)))) -mapMessage :: Msg.Message -> Either Text Messages.Message +-- | Map one baikai message onto an SDK message, or say why it cannot +-- be sent, or say that it should not be sent at all. +-- +-- Three outcomes rather than two, because Anthropic rejects both an +-- empty text block and an empty @content@ array, and baikai can produce +-- either from its own bookkeeping: +-- +-- * @Right (Just msg)@ — the ordinary case. +-- +-- * @Right Nothing@ — an /assistant/ turn left with no blocks after +-- empty text was dropped. That turn is baikai's own artifact: a text +-- block that opened and closed with no deltas, or a turn whose only +-- content was unsigned thinking, which replay already omits because +-- Anthropic rejects a thinking block without its signature. Dropping +-- it loses nothing the model said, and Anthropic merges the adjacent +-- user turns itself. A placeholder would fabricate content the model +-- never produced. +-- +-- * @Left reason@ — a /user/ turn left with no blocks. That is a caller +-- error, not baikai's, so it is refused locally with a better message +-- than the provider's 400 and with the same +-- 'Baikai.Error.InvalidRequest' category, which 'prepareCall' already +-- assigns. It is also refused when two @tool_use@ blocks in one +-- assistant turn normalise onto the same id, which would misroute the +-- tool result answering one of them. +mapMessage :: Msg.Message -> Either Text (Maybe Messages.Message) mapMessage = \case Msg.UserMessage Msg.UserPayload {Msg.content = uc} -> - Right - Messages.Message - { Messages.role = Messages.User, - Messages.content = Vector.mapMaybe userContentToBlock uc, - Messages.cache_control = Nothing - } + let blocks = Vector.mapMaybe userContentToBlock uc + in if Vector.null blocks + then + Left + "Anthropic Messages rejects a user turn with no content blocks; \ + \this one had none, or only empty text" + else + Right + ( Just + Messages.Message + { Messages.role = Messages.User, + Messages.content = blocks, + Messages.cache_control = Nothing + } + ) Msg.AssistantMessage Msg.AssistantPayload {Msg.content = ac} -> - Right - Messages.Message - { Messages.role = Messages.Assistant, - Messages.content = Vector.mapMaybe assistantContentToBlock ac, - Messages.cache_control = Nothing - } + let blocks = Vector.mapMaybe assistantContentToBlock ac + in case duplicateToolUseId blocks of + Just dup -> + Left ("duplicate tool_use id after normalisation: " <> dup) + Nothing + | Vector.null blocks -> Right Nothing + | otherwise -> + Right + ( Just + Messages.Message + { Messages.role = Messages.Assistant, + Messages.content = blocks, + Messages.cache_control = Nothing + } + ) Msg.ToolResultMessage Msg.ToolResultPayload { Msg.toolCallId = tid, @@ -382,22 +547,41 @@ Left unsupported -> Left unsupported Right body -> Right - Messages.Message - { Messages.role = Messages.User, - Messages.content = - Vector.singleton - Messages.Content_Tool_Result - { Messages.tool_use_id = normalizeToolCallId tid, - Messages.content = nonEmpty body, - Messages.is_error = Just err - }, - Messages.cache_control = Nothing - } + ( Just + Messages.Message + { Messages.role = Messages.User, + Messages.content = + Vector.singleton + Messages.Content_Tool_Result + { Messages.tool_use_id = normalizeToolCallId tid, + Messages.content = nonEmpty body, + Messages.is_error = Just err + }, + Messages.cache_control = Nothing + } + ) +-- | The first @tool_use@ id that appears twice in one assistant turn, +-- if any. Ids are already normalised at this point, so this catches the +-- residual hash collision as well as a caller that reused an id. +duplicateToolUseId :: Vector Messages.Content -> Maybe Text +duplicateToolUseId = go [] . Vector.toList + where + go _ [] = Nothing + go seen (Messages.Content_Tool_Use {Messages.id = i} : rest) + | i `elem` seen = Just i + | otherwise = go (i : seen) rest + go seen (_ : rest) = go seen rest + +-- | An empty text block is dropped: Anthropic rejects +-- @{"type":"text","text":""}@ outright, and an empty block carries +-- nothing the model or the caller said. userContentToBlock :: Content.UserContent -> Maybe Messages.Content userContentToBlock = \case - Content.UserText (Content.TextContent t) -> - Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} + Content.UserText (Content.TextContent t) + | Text.null t -> Nothing + | otherwise -> + Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} Content.UserImage img -> Just Messages.Content_Image @@ -410,10 +594,16 @@ Messages.cache_control = Nothing } +-- | As 'userContentToBlock' for empty text. Unsigned thinking is also +-- dropped, because Anthropic rejects a thinking block whose signature +-- is missing; a turn left with no blocks at all is then dropped +-- entirely by 'mapMessage'. assistantContentToBlock :: Content.AssistantContent -> Maybe Messages.Content assistantContentToBlock = \case - Content.AssistantText (Content.TextContent t) -> - Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} + Content.AssistantText (Content.TextContent t) + | Text.null t -> Nothing + | otherwise -> + Just Messages.Content_Text {Messages.text = t, Messages.cache_control = Nothing} Content.AssistantThinking th -> if Content.redacted th then Just Messages.Content_Redacted_Thinking {Messages.data_ = Content.thinking th} diff --git a/src/Baikai/Provider/Claude/Internal/Stream.hs b/src/Baikai/Provider/Claude/Internal/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Internal/Stream.hs @@ -0,0 +1,984 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | __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 Anthropic Messages streaming machinery: the SSE driver seam, the +-- event assembler and the translator that turns the SDK's typed +-- 'Claude.V1.Messages.MessageStreamEvent' values into baikai +-- 'AssistantMessageEvent' values. The public entry points built on it +-- live in "Baikai.Provider.Claude.Api". +-- +-- Requests start as the SDK's typed 'Claude.V1.Messages.CreateMessage' +-- value, then 'Baikai.Provider.Claude.Shape.streamRequestBody' patches +-- the raw JSON body for tool-schema, @tool_choice@, and tool-cache +-- compat before +-- 'Baikai.Provider.Claude.Sse.claudeSseStreamValueWithHeaders' sends it +-- with cached transport settings and caller headers. +module Baikai.Provider.Claude.Internal.Stream + ( claudeMessagesStreamWith, + SseDriver, + liveSseDriver, + Assembler (..), + emptyAssembler, + translate, + ) +where + +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, 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, anthropicMessagesCompatFor) +import Baikai.Options (Options (..)) +import Baikai.Provider.Claude.Internal.ErrorClass (classifyErrorValue, classifyException) +import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) +import Baikai.Provider.Claude.Shape (streamRequestBody) +import Baikai.Provider.Claude.Sse (claudeSseStreamValueWithHeaders) +import Baikai.Provider.Claude.Sse qualified as Sse +import Baikai.Provider.Claude.Transport qualified as Transport +import Baikai.Provider.Internal.StreamWorker + ( FrameQueue, + newFrameQueue, + pullFrame, + pushFrame, + withFrameWorker, + ) +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 Claude.V1.Messages qualified as Messages +import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try) +import Control.Lens ((%~), (&), (.~), (^.)) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.ByteString.Lazy qualified as BSL +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.IntSet qualified as IntSet +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 Data.Version (showVersion) +import GHC.Generics (Generic) +import Network.HTTP.Types.Header (RequestHeaders) +import Paths_baikai_claude 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 Anthropic. +-- +-- Production passes 'liveSseDriver'. A test passes one that replays a +-- recorded response through the same +-- 'Baikai.Provider.Claude.Sse.sseFromResponse' the live driver uses, so +-- header capture, status classification, and SSE frame decoding are all +-- the real implementations and only the socket is missing. +type SseDriver = + ClaudeCall -> + (Sse.ResponseMetadata -> IO ()) -> + (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> + IO () + +-- | The production driver: a real HTTPS request through the cached +-- transport settings. +liveSseDriver :: SseDriver +liveSseDriver call = + claudeSseStreamValueWithHeaders + (call ^. #clientEnv) + (call ^. #requestHeaders) + (call ^. #requestBody) + +-- | 'Baikai.Provider.Claude.Api.claudeMessagesStream' over an explicit +-- transport driver. +claudeMessagesStreamWith :: + SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent +claudeMessagesStreamWith 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 Messages.MessageStreamEvent)) + 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, + -- Pre-seeded, exactly as the OpenAI producer does it, + -- so the first event reaches the consumer immediately + -- and carries the request-start timestamp, and so + -- every failure path is 'EventStart'-first without + -- per-path bookkeeping. Anthropic's message id is not + -- known yet; it rides the terminal's @responseId@, + -- which 'Baikai.Stream.reassembleResponse' prefers + -- anyway. + pending = + [ EventStart + StartPayload + { partial = skeletonMessage (emptyAssembler m startTime) 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)) + +-- | Per-call prepared values, including the shaped JSON request body +-- passed to the local streaming transport. +data ClaudeCall = ClaudeCall + { 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 'mapRequest' described it. Carried from here rather + -- than recomputed at the terminal: only the request mapper knows + -- the host compat lookup and the max-tokens interaction that + -- produced it. + thinking :: !Ev.ThinkingTranslation + } + deriving stock (Generic) + +-- | The host this call goes to: the model's base URL, or Anthropic's +-- when it carries none. +resolvedBaseUrl :: Model -> Text +resolvedBaseUrl m = case m ^. #baseUrl of + "" -> "https://api.anthropic.com" + u -> u + +prepareCall :: + Model -> Context -> Options -> IO (Either BaikaiError ClaudeCall) +prepareCall m ctx opts = do + case mapRequest m ctx opts of + Left e -> pure (Left (invalidRequest e)) + Right (req, translation) -> do + let url = resolvedBaseUrl m + compat = anthropicMessagesCompatFor m + version = Just "2023-06-01" + -- 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 body = streamRequestBody compat ctx opts req + headers = Transport.requestHeaders key version compat ctx m opts + pure + ( Right + ClaudeCall + { clientEnv = env, + requestHeaders = headers, + timeoutMs = opts ^. #timeoutMs, + requestBody = body, + baseUrl = url, + thinking = translation + } + ) + +-- | Worker body: drive the SDK's typed callback, forwarding events 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 -> + ClaudeCall -> + IORef (Maybe Sse.ResponseMetadata) -> + FrameQueue (Either BaikaiError Messages.MessageStreamEvent) -> + IO () +worker driver call metaRef q = do + r <- + trySync $ + Transport.runWithTimeout (call ^. #timeoutMs) $ + driver + call + (writeIORef metaRef . Just) + (pushFrame q) + case r of + Right Nothing -> pure () + Right (Just be) -> pushFrame q (Left be) + Left e -> pushFrame q (Left (exceptionToError e)) + +-- | The streaming 'Stream' state. +data ProducerState = ProducerState + { chan :: !(FrameQueue (Either BaikaiError Messages.MessageStreamEvent)), + pending :: ![AssistantMessageEvent], + assembler :: !Assembler, + finished :: !Bool, + terminalRef :: !(IORef Bool), + -- | Where the worker leaves the response-level metadata it captured + -- before the first event. 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 Sse.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 an event — 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') = unexpectedEoS now 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) + ) + ) + +-- | Mark the stream terminated and attach the call's evidence to the +-- terminal event. +-- +-- Every event this producer yields goes through here, and the three +-- sites that can produce a terminal — a translated upstream event, a +-- queued event drained from 'pending', and the unexpected-end-of-stream +-- recovery — therefore 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 = observeAnthropic 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 provider did not +-- make stays 'Ev.Unobserved'. +observeAnthropic :: + Ev.CallStatus -> Assembler -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence +observeAnthropic st ass ev = + ev + & #endpoint . #implementationVersion .~ Just claudePackageVersion + & #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 Anthropic actually reported it. +-- +-- The assembler initialises 'usage' to zeroes, so reporting it +-- unconditionally would tell a reader the provider 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 frames must produce the same +-- digest, and the frame boundaries are a transport detail no verifier +-- holding the response could reproduce. +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. +claudePackageVersion :: Text +claudePackageVersion = Text.pack (showVersion Paths.version) + +-- | 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 Sse.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 + +-- | Anthropic's correlation identifier for this response, or a +-- gateway's if Anthropic's own is absent. +-- +-- The preference order is '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 :: Sse.ResponseMetadata -> Ev.Observed Text +correlationId md = + case [v | n <- Sse.capturedHeaderNames, Just v <- [lookup (headerName n) (md ^. #headers)]] of + (v : _) -> Ev.Observed v + [] -> Ev.Unobserved + where + headerName = Text.decodeUtf8 . CI.foldedCase + +terminal :: AssistantMessageEvent -> Bool +terminal = \case + EventDone {} -> True + EventError {} -> True + _ -> False + +-- | The recovery path: the frame queue closed before any terminal event. +-- +-- Returns the block-closing events first and then the terminal, so a +-- consumer reading raw events and a consumer reassembling them see the +-- same partial output. +unexpectedEoS :: + UTCTime -> Assembler -> ([AssistantMessageEvent], Assembler) +unexpectedEoS now ass = + let (closeEvents, ass') = closeOpenBlocks ass + errText = "claude stream ended without message_stop" + msg = finalMessageOnError ass' now errText + in ( closeEvents + <> [EventError (errorTerminal Nothing (ass' ^. #responseId) Stop.ErrorReason msg (providerError errText))], + ass' + ) + +-- | Close every still-open block in ascending index order, exactly as a +-- @content_block_stop@ for each would. +-- +-- Used on every failure path, because the terminal message is built from +-- 'blocksInOrder' — the /closed/ blocks — and a failure that left text, +-- thinking or tool arguments open would otherwise drop them from both +-- the events and the message. Core's reassembler recovers open buffers +-- on its own; a consumer reading raw events had no such recourse. +closeOpenBlocks :: Assembler -> ([AssistantMessageEvent], Assembler) +closeOpenBlocks ass = foldl' close ([], ass) openIndices + where + openIndices = + IntSet.toAscList . IntSet.unions $ + map + IntMap.keysSet + [ ass ^. #textBuf, + ass ^. #thinkBuf, + ass ^. #redactedBuf, + ass ^. #toolArgsBuf + ] + close (acc, a) i = let (evs, a') = handleBlockStop i a in (acc <> evs, a') + +-- | Translation state across one streaming call. +-- +-- The four fields below @stopReason@ are what this call /observed/, as +-- distinct from what it requested. They are kept here rather than +-- derived at the terminal because this record is the only state that +-- survives from the first event to the last, and because an observation +-- that never arrived must stay 'Ev.Unobserved' rather than falling back +-- to the caller's configuration. +data Assembler = Assembler + { model :: !Model, + start :: !UTCTime, + responseId :: !(Maybe Text), + closed :: !(IntMap Content.AssistantContent), + textBuf :: !(IntMap Text), + thinkBuf :: !(IntMap Text), + thinkSig :: !(IntMap Text), + redactedBuf :: !(IntMap Text), + toolArgsBuf :: !(IntMap Text), + toolMeta :: !(IntMap (Text, Text)), + usage :: !Usage.Usage, + stopReason :: !Stop.StopReason, + -- | Anthropic's own correlation identifier for this call, from the + -- response headers. + providerRequestId :: !(Ev.Observed Text), + -- | The model identifier Anthropic reported running, from + -- @message_start@. Never the configured model. + observedModel :: !(Ev.Observed Text), + -- | The response's HTTP status. Recorded because the transport has + -- it; 'Baikai.Evidence.ModelCallEvidence' has no field for it, and + -- adding one to the evidence schema is a core decision, not this + -- module's. + httpStatus :: !(Maybe Int), + -- | Whether Anthropic actually reported token counts, as opposed to + -- 'usage' still holding the zeroes it was initialised with. Without + -- this a failed call would claim the provider reported consuming + -- nothing. + usageReported :: !Bool + } + deriving stock (Generic) + +emptyAssembler :: Model -> UTCTime -> Assembler +emptyAssembler m s = + Assembler + { model = m, + start = s, + responseId = Nothing, + closed = IntMap.empty, + textBuf = IntMap.empty, + thinkBuf = IntMap.empty, + thinkSig = IntMap.empty, + redactedBuf = IntMap.empty, + toolArgsBuf = IntMap.empty, + toolMeta = IntMap.empty, + usage = Usage.zeroUsage, + stopReason = Stop.Stop, + providerRequestId = Ev.Unobserved, + observedModel = Ev.Unobserved, + httpStatus = Nothing, + usageReported = False + } + +translate :: + Either BaikaiError Messages.MessageStreamEvent -> + Assembler -> + UTCTime -> + ([AssistantMessageEvent], Assembler) +translate raw ass now = case raw of + Left be -> + let (closeEvents, ass') = closeOpenBlocks ass + msg = finalMessageOnError ass' now (be ^. #message) + in ( closeEvents + <> [EventError (errorTerminal Nothing (ass' ^. #responseId) Stop.ErrorReason msg be)], + ass' + ) + Right ev -> translateEvent ev ass now + +translateEvent :: + Messages.MessageStreamEvent -> + Assembler -> + UTCTime -> + ([AssistantMessageEvent], Assembler) +translateEvent raw ass now = case raw of + Messages.Ping -> ([], ass) + -- Updates the assembler and emits nothing: the stream's one + -- 'EventStart' was pre-seeded before the first wire read, so that a + -- failure arriving before this frame — a 401, a rate limit, an + -- in-band error event, an EOF — still begins the stream the way the + -- protocol says every stream begins. + Messages.Message_Start {Messages.message = mr} -> + let usage0 = anthroUsageToBaikai (mr ^. #usage) + ass' = + ass + & #responseId .~ Just (mr ^. #id) + -- The provider's value, never the caller's. The SDK's + -- @model@ field is not optional, so a @message_start@ that + -- arrives at all is a genuine observation; a stream that + -- fails before one arrives leaves this 'Ev.Unobserved'. + & #observedModel .~ Ev.Observed (mr ^. #model) + & #usage .~ usage0 + & #usageReported .~ True + in ([], ass') + Messages.Content_Block_Start {Messages.index = idx, Messages.content_block = block} -> + handleBlockStart (fromIntegral idx) block ass + Messages.Content_Block_Delta {Messages.index = idx, Messages.delta = d} -> + handleBlockDelta (fromIntegral idx) d ass + Messages.Content_Block_Stop {Messages.index = idx} -> + handleBlockStop (fromIntegral idx) ass + Messages.Message_Delta {Messages.message_delta = md, Messages.usage = su} -> + let stopR = mapStopReason (md ^. #stop_reason) + u = ass ^. #usage + -- @message_delta@ carries the call's final counts. Older models + -- send only @output_tokens@; Claude 5 repeats the prompt-side + -- classes too, which matters because a server-side tool run + -- grows them after @message_start@. An absent field keeps what + -- @message_start@ reported rather than zeroing it. + -- + -- 'Messages.StreamUsage' has no 'GHC.Generics.Generic' instance, + -- so these are record dots rather than the generic-lens labels + -- used for 'Messages.Usage'. + inputFinal = fromMaybe (u ^. #inputTokens) su.stream_input_tokens + outputFinal = su.output_tokens + cacheReadFinal = fromMaybe (u ^. #cacheReadTokens) su.stream_cache_read_input_tokens + cacheWriteFinal = fromMaybe (u ^. #cacheWriteTokens) su.stream_cache_creation_input_tokens + reasoningFinal = case su.stream_output_tokens_details of + Just d -> Just d.thinking_tokens + Nothing -> u ^. #reasoningTokens + u' = + u + & #inputTokens .~ inputFinal + & #outputTokens .~ outputFinal + & #cacheReadTokens .~ cacheReadFinal + & #cacheWriteTokens .~ cacheWriteFinal + & #reasoningTokens .~ reasoningFinal + & #totalTokens .~ (inputFinal + outputFinal + cacheReadFinal + cacheWriteFinal) + in ([], ass & #stopReason .~ stopR & #usage .~ u' & #usageReported .~ True) + Messages.Message_Stop -> + let reason = ass ^. #stopReason + -- A refusal is a filter: the content, not the transport, is + -- the problem, and a caller can branch on the category. + refusal = contentFiltered "Anthropic refused to generate a response (stop_reason=refusal)" + msg = + if reason == Stop.ErrorReason + then finalMessageOnError ass now (refusal ^. #message) + else finalMessage ass now + terminalEvent = + if reason == Stop.ErrorReason + then EventError (errorTerminal Nothing (ass ^. #responseId) reason msg refusal) + else EventDone (doneTerminal Nothing (ass ^. #responseId) reason msg) + in ([terminalEvent], ass) + Messages.Error {Messages.error = errVal} -> + let (closeEvents, ass') = closeOpenBlocks ass + errText = renderAnthropicError errVal + mErr = classifyErrorValue errVal + msg = finalMessageOnError ass' now errText + errInfo = fromMaybe (providerError errText) mErr + in ( closeEvents + <> [EventError (errorTerminal Nothing (ass' ^. #responseId) Stop.ErrorReason msg errInfo)], + ass' + ) + +handleBlockStart :: + Int -> + Messages.ContentBlock -> + Assembler -> + ([AssistantMessageEvent], Assembler) +handleBlockStart i block ass = case block of + Messages.ContentBlock_Text {} -> + ( [TextStart IndexPayload {contentIndex = i}], + ass & #textBuf %~ IntMap.insert i Text.empty + ) + Messages.ContentBlock_Thinking {} -> + ( [ThinkingStart IndexPayload {contentIndex = i}], + ass & #thinkBuf %~ IntMap.insert i Text.empty + ) + Messages.ContentBlock_Redacted_Thinking {Messages.data_ = payload} -> + ( [ThinkingStart IndexPayload {contentIndex = i}], + ass & #redactedBuf %~ IntMap.insert i payload + ) + Messages.ContentBlock_Tool_Use {Messages.id = tid, Messages.name = tn} -> + ( [ToolCallStart IndexPayload {contentIndex = i}], + ass + & #toolArgsBuf %~ IntMap.insert i Text.empty + & #toolMeta %~ IntMap.insert i (tid, tn) + ) + _ -> + -- Server-tool, code-execution-tool, unknown — pass-through with no events. + ([], ass) + +handleBlockDelta :: + Int -> + Messages.ContentBlockDelta -> + Assembler -> + ([AssistantMessageEvent], Assembler) +handleBlockDelta i d ass = case d of + Messages.Delta_Text_Delta {Messages.text = t} -> + if IntMap.member i (ass ^. #textBuf) + then + ( [TextDelta DeltaPayload {contentIndex = i, delta = t}], + ass & #textBuf %~ IntMap.adjust (<> t) i + ) + else ([], ass) + Messages.Delta_Thinking_Delta {Messages.thinking = t} -> + if IntMap.member i (ass ^. #thinkBuf) + then + ( [ThinkingDelta DeltaPayload {contentIndex = i, delta = t}], + ass & #thinkBuf %~ IntMap.adjust (<> t) i + ) + else ([], ass) + Messages.Delta_Signature_Delta {Messages.signature = sig} -> + -- Signatures are tail-end metadata on thinking blocks; they + -- attach to the ThinkingEnd event's content build, not a public + -- delta event. + if IntMap.member i (ass ^. #thinkBuf) + then + ( [], + ass & #thinkSig %~ IntMap.insertWith (\new old -> old <> new) i sig + ) + else ([], ass) + Messages.Delta_Input_Json_Delta {Messages.partial_json = j} -> + if IntMap.member i (ass ^. #toolArgsBuf) + then + ( [ToolCallDelta DeltaPayload {contentIndex = i, delta = j}], + ass & #toolArgsBuf %~ IntMap.adjust (<> j) i + ) + else ([], ass) + +handleBlockStop :: + Int -> Assembler -> ([AssistantMessageEvent], Assembler) +handleBlockStop i ass + | Just body <- IntMap.lookup i (ass ^. #textBuf) = + let block = Content.AssistantText (Content.TextContent body) + in ( [TextEnd BlockEndPayload {contentIndex = i, content = body}], + ass + & #closed %~ IntMap.insert i block + & #textBuf %~ IntMap.delete i + ) + | Just payload <- IntMap.lookup i (ass ^. #redactedBuf) = + let thinkingContent = + Content.ThinkingContent + { Content.thinking = payload, + Content.signature = Nothing, + Content.redacted = True + } + block = Content.AssistantThinking thinkingContent + in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], + ass + & #closed %~ IntMap.insert i block + & #redactedBuf %~ IntMap.delete i + ) + | Just body <- IntMap.lookup i (ass ^. #thinkBuf) = + let sig = IntMap.lookup i (ass ^. #thinkSig) + thinkingContent = + Content.ThinkingContent + { Content.thinking = body, + Content.signature = if maybe True Text.null sig then Nothing else sig, + Content.redacted = False + } + block = Content.AssistantThinking thinkingContent + in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], + ass + & #closed %~ IntMap.insert i block + & #thinkBuf %~ IntMap.delete i + & #thinkSig %~ IntMap.delete i + ) + | Just argsText <- IntMap.lookup i (ass ^. #toolArgsBuf) = + let (tid, tn) = + -- A tool args buffer is opened together with metadata in + -- handleBlockStart; the fallback is defensive only. + fromMaybe ("", "") (IntMap.lookup i (ass ^. #toolMeta)) + -- One rule, shared with the OpenAI assembler and with core's + -- stream recovery: empty text is an empty object (Anthropic + -- opens a tool_use block with no input and streams no delta), + -- and text that does not decode is kept verbatim as a String, + -- marking the call cut off. This module used to answer @{}@ + -- to both, which handed a tool loop a well-formed call the + -- model never finished asking for. + decoded :: Value + decoded = Content.toolArgumentsFromText argsText + tc = + Content.ToolCall + { Content.id_ = tid, + Content.name = tn, + Content.arguments = decoded + } + block = Content.AssistantToolCall tc + in ( [ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc}], + ass + & #closed %~ IntMap.insert i block + & #toolArgsBuf %~ IntMap.delete i + & #toolMeta %~ IntMap.delete i + ) + | otherwise = ([], ass) + +-- | The 'EventStart' message skeleton (empty content; usage/etc. +-- carried for downstream consumers that want metadata up front). +skeletonMessage :: Assembler -> UTCTime -> Msg.Message +skeletonMessage ass _now = + Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = Vector.empty, + Msg.usage = ass ^. #usage, + Msg.stopReason = Stop.Stop, + Msg.errorMessage = Nothing, + Msg.timestamp = Just (ass ^. #start) + } + +-- | The assembler's token accounting with this model's pricing applied. +-- Shared so the terminal message and the evidence record cannot report +-- two different figures for one call. +-- +-- __Known limitation: cache writes are priced at one rate.__ Anthropic +-- bills a one-hour ('Baikai.CacheRetention.CacheRetentionLong') cache +-- write at roughly twice the five-minute rate, but the catalog carries a +-- single @cacheWriteCost@ — the five-minute one — and the SDK's +-- 'Messages.Usage' reports a single @cache_creation_input_tokens@ with +-- no per-TTL split (see 'anthroUsageToBaikai'). A long-retention write +-- is therefore /under-stated/ here. Token counts are unaffected; only +-- the dollar figure is low. Fixing it needs a second value carried off +-- the worker channel, a second field inside the evidence record, and a +-- second rate models.dev does not publish. +finalUsage :: Assembler -> Usage.Usage +finalUsage ass = + let usageBare = ass ^. #usage + in usageBare & #cost .~ Pricing.computeCost (ass ^. #model) usageBare + +finalMessage :: Assembler -> UTCTime -> Msg.Message +finalMessage ass now = + Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = blocksInOrder ass, + Msg.usage = finalUsage ass, + Msg.stopReason = ass ^. #stopReason, + Msg.errorMessage = Nothing, + Msg.timestamp = Just now + } + +finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message +finalMessageOnError ass now reason = + Msg.AssistantMessage + Msg.AssistantPayload + { Msg.content = blocksInOrder ass, + Msg.usage = finalUsage ass, + Msg.stopReason = Stop.ErrorReason, + Msg.errorMessage = Just reason, + Msg.timestamp = Just now + } + +blocksInOrder :: Assembler -> Vector Content.AssistantContent +blocksInOrder ass = Vector.fromList (IntMap.elems (ass ^. #closed)) + +-- | The immediate "request invalid" stream, emitted when 'mapRequest' +-- fails or 'prepareCall' is otherwise unable to build a valid SDK +-- request. +-- +-- 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 function is the only description + -- ADR 0003 permits anyone to use for this provider. + (describeThinkingFor m 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) + ] + +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) + +renderAnthropicError :: Value -> Text +renderAnthropicError v = case v of + Aeson.String t -> t + _ -> Text.decodeUtf8 (BSL.toStrict (Aeson.encode v)) + +-- | Map the Anthropic streaming 'Message_Start.message.usage' value +-- into baikai's 'Usage' shape. Cache-related counters are populated +-- where present; cost is left at zero (the terminal event +-- recomputes it). A thinking-token breakdown, when Anthropic reports +-- one, becomes 'Usage.reasoningTokens' — an informational subset of the +-- output tokens rather than a billed class of its own, so it moves no +-- total. +-- +-- @cache_creation_input_tokens@ is one number covering both cache-write +-- TTLs. The SDK's 'Messages.Usage' has no per-TTL breakdown, so baikai +-- cannot tell a five-minute write from a one-hour one and prices both at +-- the catalog's single @cacheWriteCost@; see 'finalUsage' and +-- @docs\/user\/prompt-caching.md@. +anthroUsageToBaikai :: Messages.Usage -> Usage.Usage +anthroUsageToBaikai u = + let i = u ^. #input_tokens + o = u ^. #output_tokens + cr = fromMaybe 0 (u ^. #cache_read_input_tokens) + cw = fromMaybe 0 (u ^. #cache_creation_input_tokens) + in Usage.Usage + { Usage.inputTokens = i, + Usage.outputTokens = o, + Usage.cacheReadTokens = cr, + Usage.cacheWriteTokens = cw, + Usage.reasoningTokens = fmap (^. #thinking_tokens) (u ^. #output_tokens_details), + Usage.totalTokens = i + o + cr + cw, + Usage.cost = zeroCost + } + +mapStopReason :: Maybe Messages.StopReason -> Stop.StopReason +mapStopReason = \case + Just Messages.End_Turn -> Stop.Stop + Just Messages.Max_Tokens -> Stop.Length + Just Messages.Stop_Sequence -> Stop.Stop + Just Messages.Tool_Use -> Stop.ToolUse + -- The turn was suspended mid-flight (a long-running server-side tool) + -- and Anthropic expects the caller to send the message back to + -- continue it. Nothing failed, so this is a stop, not an error; + -- baikai's 'Stop.StopReason' has no constructor that says "resume me". + Just Messages.Pause_Turn -> Stop.Stop + Just Messages.Refusal -> Stop.ErrorReason + Just Messages.Model_Context_Window_Exceeded -> Stop.Length + Nothing -> Stop.Stop diff --git a/src/Baikai/Provider/Claude/Shape.hs b/src/Baikai/Provider/Claude/Shape.hs --- a/src/Baikai/Provider/Claude/Shape.hs +++ b/src/Baikai/Provider/Claude/Shape.hs @@ -1,6 +1,11 @@ {-# LANGUAGE LambdaCase #-} --- | Pure request-body shaping for Anthropic-compatible Messages 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 Anthropic-compatible Messages hosts. module Baikai.Provider.Claude.Shape ( shapeRequestBody, streamRequestBody, diff --git a/src/Baikai/Provider/Claude/Sse.hs b/src/Baikai/Provider/Claude/Sse.hs --- a/src/Baikai/Provider/Claude/Sse.hs +++ b/src/Baikai/Provider/Claude/Sse.hs @@ -1,7 +1,12 @@ {-# LANGUAGE LambdaCase #-} --- | Local SSE transport for Anthropic Messages 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 Anthropic Messages streams. +-- -- The upstream @claude@ SDK exposes the right event decoder, but its -- non-2xx path collapses status, headers, and body into plain text. This -- wrapper keeps the SDK's request and SSE parsing shape while surfacing @@ -11,24 +16,30 @@ claudeSseStreamValue, claudeSseStreamValueWithHeaders, sseFromResponse, + decodeFrame, + buildRequest, ResponseMetadata (..), capturedHeaderNames, ) where -import Baikai.Error (BaikaiError, decodeError, httpError, parseRetryAfterSeconds) +import Baikai.Error (BaikaiError, decodeError, httpError, parseHttpDate, retryAfterSecondsAt) import Claude.V1.Messages qualified as Messages import Control.Monad (foldM, when) import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as Aeson.Key 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) @@ -123,25 +134,45 @@ (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> IO () claudeSseStreamValueWithHeaders env requestHeaders requestBody onMetadata onEvent = do - let base = Client.baseUrl env - 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/messages"), - 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) $ \response -> + HTTP.withResponse (buildRequest (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/messages@. 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 base requestHeaders requestBody = + HTTP.defaultRequest + { HTTP.secure = case Client.baseUrlScheme base of + Client.Http -> False + 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) <> "/v1/messages"), + 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 Anthropic SSE stream. -- -- 'onMetadata' fires exactly once, before any event, on both the @@ -159,10 +190,15 @@ 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 @@ -172,12 +208,14 @@ case es of [] -> pure False _ -> do - let payload = S8.concat es - case Aeson.eitherDecodeStrict payload of - Left err -> onEvent (Left (decodeError (Text.pack err))) >> pure False - Right val -> case Aeson.fromJSON val of - Aeson.Error err -> onEvent (Left (decodeError (Text.pack err))) >> pure False - Aeson.Success ev -> onEvent (Right ev) >> pure False + let payload = S8.dropWhileEnd isSpace (S8.concat es) + if SBS.null payload + then -- An empty @data:@ line is a heartbeat, not a frame. + pure False + else case decodeFrame payload of + Left e -> onEvent (Left e) >> pure False + Right Nothing -> pure False + Right (Just ev) -> onEvent (Right ev) >> pure False handleLine line = let l = stripCR line @@ -212,6 +250,62 @@ stop <- foldM (\acc ln -> if acc then pure True else handleLine ln) False completeLines if stop then pure () else loop loop + +-- | Decode one SSE frame. +-- +-- @Right Nothing@ is a frame this transport deliberately skips: an event +-- @type@, or a @content_block_delta@ whose @delta.type@, that the SDK +-- has no constructor for. The SDK decodes both with aeson's tagged-object +-- encoding and no unknown-tag fallback, so an unrecognised tag is a +-- decode /failure/ there — and a new frame type from Anthropic must not +-- end an otherwise healthy stream. A frame of a __known__ type that +-- still fails to decode is a genuine fault and stays a 'decodeError'. +-- +-- Both tag lists are copied from the SDK's @constructorTagModifier@ +-- tables in @Claude.V1.Messages@. A frame carrying no @type@ field at +-- all is not "unknown" — it is malformed, and fails as before. +decodeFrame :: SBS.ByteString -> Either BaikaiError (Maybe Messages.MessageStreamEvent) +decodeFrame payload = case Aeson.eitherDecodeStrict payload of + Left err -> Left (decodeError (Text.pack err)) + Right val + | frameIsUnknown val -> Right Nothing + | otherwise -> case Aeson.fromJSON val of + Aeson.Error err -> Left (decodeError (Text.pack err)) + Aeson.Success ev -> Right (Just ev) + +-- | Whether this frame names a type the SDK has no constructor for. +frameIsUnknown :: Aeson.Value -> Bool +frameIsUnknown val = case val of + Aeson.Object o -> case Aeson.Key.lookup "type" o of + Just (Aeson.String "content_block_delta") -> + case Aeson.Key.lookup "delta" o of + Just (Aeson.Object d) -> case Aeson.Key.lookup "type" d of + Just (Aeson.String dt) -> dt `notElem` knownDeltaTypes + _ -> False + _ -> False + Just (Aeson.String t) -> t `notElem` knownEventTypes + _ -> False + _ -> False + +knownEventTypes :: [Text] +knownEventTypes = + [ "message_start", + "content_block_start", + "content_block_delta", + "content_block_stop", + "message_delta", + "message_stop", + "ping", + "error" + ] + +knownDeltaTypes :: [Text] +knownDeltaTypes = + [ "text_delta", + "input_json_delta", + "thinking_delta", + "signature_delta" + ] normalizePath :: String -> String normalizePath = \case diff --git a/src/Baikai/Provider/Claude/Transport.hs b/src/Baikai/Provider/Claude/Transport.hs --- a/src/Baikai/Provider/Claude/Transport.hs +++ b/src/Baikai/Provider/Claude/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 the +-- Anthropic Messages API. module Baikai.Provider.Claude.Transport ( getClientEnvCached, cachedClientEnvCount, @@ -12,11 +19,12 @@ import Baikai.Compat (AnthropicMessagesCompat (..)) import Baikai.Content qualified as Content import Baikai.Context (Context (..)) -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.Message qualified as Msg import Baikai.Model (Model (..)) import Baikai.Options (Options (..)) -import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) import Control.Exception (throwIO) import Control.Lens ((^.)) import Crypto.Hash (Digest, SHA256) @@ -28,26 +36,9 @@ import Data.Text qualified as Text import Data.Text.Encoding qualified as Text import Data.Vector qualified as Vector -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 -> Maybe Text -> @@ -85,13 +76,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) sessionAffinityValue :: Context -> Text sessionAffinityValue ctx = @@ -137,28 +145,18 @@ exitCode = 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/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/ErrorClassSpec.hs b/test/ErrorClassSpec.hs --- a/test/ErrorClassSpec.hs +++ b/test/ErrorClassSpec.hs @@ -2,22 +2,15 @@ import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable) import Baikai.Provider.Claude.Internal.ErrorClass - ( classifyErrorText, - classifyErrorValue, + ( classifyErrorValue, classifyException, - responseToError, ) import Control.Exception (toException) import Data.Aeson (Value, object, (.=)) -import Data.ByteString (ByteString) -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, (@?=)) @@ -25,50 +18,10 @@ tests = testGroup "Baikai.Provider.Claude.Internal.ErrorClass" - [ httpStatusTests, - sdkTextTests, - streamedErrorTests, + [ streamedErrorTests, fallbackTests ] --- | Build a synthetic servant 'ResponseF' for the HTTP-status mapper. -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", "30")] "slow down") - category e @?= RateLimited - httpStatus e @?= Just 429 - retryAfterSeconds e @?= Just 30, - testCase "429 without Retry-After -> RateLimited, no hint" $ do - let e = responseToError (mkResp 429 [] "slow down") - category e @?= RateLimited - retryAfterSeconds e @?= Nothing, - testCase "401 -> AuthError" $ - category (responseToError (mkResp 401 [] "bad key")) @?= AuthError, - testCase "400 with overflow body -> ContextOverflow" $ - category (responseToError (mkResp 400 [] "prompt is too long: 9000 tokens")) - @?= ContextOverflow, - testCase "400 with ordinary body -> InvalidRequest" $ - category (responseToError (mkResp 400 [] "missing field model")) - @?= InvalidRequest, - testCase "503 -> TransientError" $ - category (responseToError (mkResp 503 [] "")) @?= TransientError, - testCase "non-integer Retry-After is ignored" $ - retryAfterSeconds (responseToError (mkResp 429 [("Retry-After", "Wed, 21 Oct 2026 07:28:00 GMT")] "")) - @?= Nothing - ] - streamedErrorTests :: TestTree streamedErrorTests = testGroup @@ -114,28 +67,27 @@ 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 = - testGroup - "classifyErrorText (SDK HTTP text)" - [ testCase "429 text -> RateLimited" $ do - let parsed = - classifyErrorText - "HTTP error 429 Too Many Requests: {\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}" - fmap category parsed @?= Just RateLimited - fmap httpStatus parsed @?= Just (Just 429), - testCase "529 text -> TransientError" $ - fmap category (classifyErrorText "HTTP error 529 ") - @?= Just TransientError, - testCase "non-matching text -> Nothing" $ - classifyErrorText "ordinary stream error" @?= Nothing ] -- | The inner error object Anthropic streams as the @error@ field. diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -15,12 +15,13 @@ import Baikai import Baikai.Models.Generated (anthropic_claude_haiku_4_5) -import Baikai.Provider.Claude.Api (SseDriver, claudeMessagesStreamWith) import Baikai.Provider.Claude.Internal.Request (describeThinkingFor) +import Baikai.Provider.Claude.Internal.Stream (SseDriver, claudeMessagesStreamWith) import Baikai.Provider.Claude.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 (..)) @@ -52,6 +53,11 @@ [ successEvidenceTest, rateLimitEvidenceTest, thinkingEvidenceTest, + samplingEvidenceTest, + cacheUsageEvidenceTest, + immediateErrorRecordsThinkingTest, + defaultHostEndpointTest, + responseIdCountsAsCorrelationTest, optOutTest ] @@ -144,6 +150,15 @@ field "usage" ev @?= Just (String "unobserved") field "strength" ev @?= Just (String "correlated") + -- The same replay as a stream: an HTTP failure that arrives before + -- @message_start@ still begins with 'EventStart'. + assertErrorContract + =<< replayStreamEvents + 429 + [("request-id", "req_rate_limited"), ("Retry-After", "7")] + ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"] + baseOptions + thinkingEvidenceTest :: TestTree thinkingEvidenceTest = testCase "the evidence carries the thinking translation the request actually used" $ do @@ -166,6 +181,64 @@ KeyMap.lookup "adjustments" t @?= Just (Array Vector.empty) other -> assertFailure ("expected a thinking translation, got: " <> show other) +-- | 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 + let model = testModel & #baseUrl .~ "https://unknown-host.example" + opts = + emptyOptions + & #evidence .~ Just (evidenceRequest "run-53") + & #thinking .~ Just ThinkingHigh + ev <- oneEvidence =<< replayWith model 200 successHeaders successBody opts + field "status" ev @?= Just (String "failed") + case field "thinking" ev of + Just (Object t) -> do + KeyMap.lookup "requested" t @?= Just (String "high") + let expectedMode = case Aeson.toJSON (describeThinkingFor model opts) of + Object d -> KeyMap.lookup "mode" d + _ -> Nothing + KeyMap.lookup "mode" t @?= expectedMode + assertBool + "the mode must not collapse the request into absent" + (KeyMap.lookup "mode" t /= Just (String "absent")) + other -> assertFailure ("expected a thinking translation, got: " <> show other) + +-- | A model carrying no base URL still records the host the call went +-- to. +-- +-- The adapter substitutes Anthropic's host inside 'prepareCall', so the +-- call had a perfectly definite destination while the record said +-- @endpoint: null@. The replay driver ignores the URL, so this asserts +-- what was recorded rather than where the bytes went. +defaultHostEndpointTest :: TestTree +defaultHostEndpointTest = + testCase "a call with no base URL records the default host it went to" $ do + ev <- + oneEvidence + =<< replayWith (testModel & #baseUrl .~ "") 200 successHeaders successBody baseOptions + case field "endpoint" ev of + Just (Object e) -> KeyMap.lookup "endpoint" e @?= Just (String "https://api.anthropic.com") + other -> assertFailure ("expected an endpoint identity, got: " <> show other) + +-- | A response that names its model and its message id but carries no +-- @request-id@ header still reaches @model_observed@. See the +-- OpenAI-compatible twin for why this shape matters. +responseIdCountsAsCorrelationTest :: TestTree +responseIdCountsAsCorrelationTest = + testCase "A RESPONSE ID WITH NO HEADER STILL REACHES model_observed" $ do + ev <- oneEvidence =<< replay 200 [] successBody baseOptions + field "provider_request_id" ev @?= Just (String "unobserved") + field "response_id" ev @?= Just (observedJson "msg_observed") + field "observed_model" ev @?= Just (observedJson "claude-haiku-4-5-20990101-server-side") + field "strength" ev @?= Just (String "model_observed") + optOutTest :: TestTree optOutTest = testCase "a call that asked for no evidence emits none" $ do @@ -182,24 +255,43 @@ -- | Run one recorded response through the real adapter and the real -- trace path, and return every trace event it produced. replay :: Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [TraceEvent] -replay status headers chunks opts = do +replay = replayWith testModel + +-- | 'replay' against a model of the caller's choosing, for the cases +-- whose point is a fact of the model's compat record. +replayWith :: + Model -> Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [TraceEvent] +replayWith model status headers chunks opts = do reg <- newProviderRegistry let driver = replayDriver status headers chunks provider = - ApiProvider - { apiTag = AnthropicMessages, - stream = claudeMessagesStreamWith driver, - complete = streamingComplete (claudeMessagesStreamWith driver), - describeThinking = describeThinkingFor - } + apiProviderWith + AnthropicMessages + (claudeMessagesStreamWith driver) + (streamingComplete (claudeMessagesStreamWith driver)) + & #describeThinking .~ (describeThinkingFor) + & #strengthCeiling .~ (declaredStrength AnthropicMessages) registerApiProviderWith reg provider (ref, sink) <- memorySink _ <- Stream.fold Fold.drain - (withTraceStreamWith reg sink testModel emptyContext opts) + (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 = + Stream.toList + (claudeMessagesStreamWith (replayDriver status headers chunks) testModel emptyContext opts) + -- | A transport driver that serves a recorded response instead of -- opening a socket. -- @@ -268,6 +360,79 @@ "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-haiku-4-5-20990101-server-side\",", "\"stop_reason\":null,\"stop_sequence\":null,", "\"usage\":{\"input_tokens\":11,\"output_tokens\":0}}}\n\n", + "data: {\"type\":\"content_block_start\",\"index\":0,", + "\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n", + "data: {\"type\":\"content_block_delta\",\"index\":0,", + "\"delta\":{\"type\":\"text_delta\",\"text\":\"pong\"}}\n\n", + "data: {\"type\":\"content_block_stop\",\"index\":0}\n\n", + "data: {\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},", + "\"usage\":{\"output_tokens\":5}}\n\n", + "data: {\"type\":\"message_stop\"}\n\n" + ] + +samplingEvidenceTest :: TestTree +samplingEvidenceTest = + testCase "a dropped sampling parameter appears in the evidence record" $ do + -- The generation rejects temperature with a 400, so baikai omits + -- it. What must not happen is that it vanishes: the caller set a + -- value, and the record says what became of it. The thinking mode + -- is "absent" here — nothing about thinking was asked — which is + -- exactly the case a reader would misread as "nothing happened". + let model = + testModel + & #compat + .~ CompatAnthropicMessages + (defaultAnthropicMessagesCompat {supportsSamplingParameters = False}) + ev <- + oneEvidence + =<< replayWith + model + 200 + successHeaders + successBody + (baseOptions & #temperature .~ Just 0.2) + case field "thinking" ev of + Just (Object t) -> do + KeyMap.lookup "mode" t @?= Just (String "absent") + KeyMap.lookup "requested" t @?= Just Null + case KeyMap.lookup "adjustments" t of + Just (Array adjustments) -> case Vector.toList adjustments of + [Object a] -> do + KeyMap.lookup "kind" a + @?= Just (String "sampling_dropped_unsupported_model") + KeyMap.lookup "fields" a + @?= Just (Array (Vector.fromList [String "temperature"])) + other -> assertFailure ("expected exactly one adjustment, got: " <> show other) + other -> assertFailure ("expected an adjustments array, got: " <> show other) + other -> assertFailure ("expected a thinking object, got: " <> show other) + +cacheUsageEvidenceTest :: TestTree +cacheUsageEvidenceTest = + testCase "cache-write and cache-read counts reach the observed usage" $ do + -- The counts are what the whole cache-pricing story rests on, and + -- nothing pinned them: cache_creation_input_tokens is what baikai + -- prices at the catalog's single cacheWriteCost, and totalTokens + -- must count both cache classes as billed input. + ev <- oneEvidence =<< replay 200 successHeaders cachedBody baseOptions + case field "usage" ev of + Just (Object u) -> case KeyMap.lookup "observed" u of + Just (Object o) -> do + KeyMap.lookup "input_tokens" o @?= Just (Number 11) + KeyMap.lookup "cache_write_tokens" o @?= Just (Number 40) + KeyMap.lookup "cache_read_tokens" o @?= Just (Number 60) + KeyMap.lookup "output_tokens" o @?= Just (Number 5) + KeyMap.lookup "total_tokens" o @?= Just (Number (11 + 40 + 60 + 5)) + other -> assertFailure ("expected an observed usage object, got: " <> show other) + other -> assertFailure ("expected a usage object, got: " <> show other) + +-- | 'successBody' with cache counters on its @message_start@. +cachedBody :: [ByteString] +cachedBody = + [ "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_observed\",\"type\":\"message\",", + "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-haiku-4-5-20990101-server-side\",", + "\"stop_reason\":null,\"stop_sequence\":null,", + "\"usage\":{\"input_tokens\":11,\"output_tokens\":0,", + "\"cache_creation_input_tokens\":40,\"cache_read_input_tokens\":60}}}\n\n", "data: {\"type\":\"content_block_start\",\"index\":0,", "\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n", "data: {\"type\":\"content_block_delta\",\"index\":0,", diff --git a/test/LifecycleSpec.hs b/test/LifecycleSpec.hs new file mode 100644 --- /dev/null +++ b/test/LifecycleSpec.hs @@ -0,0 +1,213 @@ +-- | 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 (anthropic_claude_haiku_4_5) +import Baikai.Provider.Claude.Internal.Stream (SseDriver, claudeMessagesStreamWith) +import Baikai.Provider.Claude.Sse (sseFromResponse) +import Baikai.Provider.Internal.StreamWorker (frameQueueCapacity) +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 Network.HTTP.Client.Internal qualified as HTTP +import Network.HTTP.Types.Status (mkStatus) +import Network.HTTP.Types.Version (http11) +import Streamly.Data.Stream qualified as Stream +import System.Mem (performMajorGC) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Provider.Claude lifecycle" + [ boundedReadTest, + abandonedReleasesAfterGcTest, + cancellationReleasesWithoutGcTest, + workerDeathCannotStrandTest + ] + +-- | 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 :: TestTree +boundedReadTest = + 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 + (claudeMessagesStreamWith (countingDriver reads' closedRef Nothing) testModel 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 :: TestTree +abandonedReleasesAfterGcTest = + testCase "an abandoned stream releases its connection after a major GC" $ do + reads' <- newIORef (0 :: Int) + closedRef <- newIORef False + _ <- + Stream.toList + ( Stream.take + 3 + (claudeMessagesStreamWith (countingDriver reads' closedRef Nothing) testModel 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 :: TestTree +cancellationReleasesWithoutGcTest = + 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 + (claudeMessagesStreamWith (countingDriver reads' closedRef (Just gate)) testModel 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 :: TestTree +workerDeathCannotStrandTest = + testCase "an asynchronous exception in the worker still closes the channel" $ do + let dyingDriver :: SseDriver + dyingDriver _call _onMetadata _onEvent = throwIO ThreadKilled + got <- + timeout + 2000000 + (Stream.toList (claudeMessagesStreamWith dyingDriver testModel 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 "claude stream ended without message_stop" + 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 :: IORef Int -> IORef Bool -> Maybe (MVar ()) -> SseDriver +countingDriver reads' closedRef gate _call 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 "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 (frameAt n) + +-- | An endless stream: a @message_start@, a text block start, then text +-- deltas without end. +frameAt :: Int -> ByteString +frameAt 0 = + "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_lifecycle\",\"type\":\"message\"," + <> "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-lifecycle\"," + <> "\"stop_reason\":null,\"stop_sequence\":null," + <> "\"usage\":{\"input_tokens\":1,\"output_tokens\":0}}}\n\n" +frameAt 1 = + "data: {\"type\":\"content_block_start\",\"index\":0," + <> "\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n" +frameAt _ = + "data: {\"type\":\"content_block_delta\",\"index\":0," + <> "\"delta\":{\"type\":\"text_delta\",\"text\":\"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 = + anthropic_claude_haiku_4_5 + & #api .~ AnthropicMessages + & #baseUrl .~ "https://api.anthropic.com" + +testOptions :: Options +testOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key") diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -4,6 +4,7 @@ import Baikai.Agent ( AgentCapability (..), AgentCommand, + AgentOutputFormat (..), AgentPromptTransport (..), AgentProvider (..), AgentRenderError (..), @@ -19,6 +20,7 @@ import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) import Claude.V1.Messages qualified as Messages import CliEvidenceSpec qualified +import Contract (assertErrorContract) import Control.Exception (bracket) import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson @@ -28,6 +30,9 @@ import Data.Vector qualified as Vector import ErrorClassSpec qualified import EvidenceSpec qualified +import LifecycleSpec qualified +import MidStreamSpec qualified +import PublicSurfaceSpec qualified import ShapeSpec qualified import SseSpec qualified import Streamly.Data.Stream qualified as Stream @@ -36,7 +41,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 ThinkingSpec qualified import TransportSpec qualified @@ -50,6 +55,7 @@ safetyRefusalTest, safetyStillRendersTest, agentCommandRenderingTest, + agentOutputFormatTest, agentCapabilityRenderingTests, agentEffortRenderingTests, agentThinkingTranslationTests, @@ -71,6 +77,9 @@ CliEvidenceSpec.tests, ErrorClassSpec.tests, EvidenceSpec.tests, + LifecycleSpec.tests, + MidStreamSpec.tests, + PublicSurfaceSpec.tests, ShapeSpec.tests, SseSpec.tests, ThinkingSpec.tests, @@ -104,11 +113,11 @@ 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, _) -> - Messages.output_config req + req ^. #output_config @?= Just (Messages.jsonSchemaConfig personSchema) optionsMappingTest :: TestTree @@ -122,15 +131,24 @@ 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 case mapRequest model emptyContext opts of Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e) - Right (req, _) -> do + Right (req, translation) -> do Messages.top_p req @?= Just 0.9 Messages.stop_sequences req @?= Just (Vector.fromList ["END", "STOP"]) + -- seed, frequencyPenalty and presencePenalty have no Anthropic + -- Messages field on any generation. They are dropped, but the + -- drop is recorded rather than silent — the whole point of the + -- adjustment list. + translation + ^. #adjustments + @?= [ SamplingDroppedUnsupportedApi + ["seed", "frequency_penalty", "presence_penalty"] + ] commandRenderingTest :: TestTree commandRenderingTest = @@ -284,6 +302,31 @@ cmd ^. #promptTransport @?= PromptOnStdin cmd ^. #promptText @?= "reconcile the grammar" +-- | @output-format "json"@ is what lets an evidence record observe the +-- session, the model and the token usage of a run. Before it existed the +-- only way to ask was through the raw-argument channel, which an +-- operator ceiling closes by default — so a job needed a privileged +-- channel opened to produce a record. +agentOutputFormatTest :: TestTree +agentOutputFormatTest = + testCase "unattended claude argv asks for a structured result, and only when asked" $ do + let base = agentRunRequest AgentClaude "/work/project" "reconcile the grammar" + textual <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig base + -- The tool already defaults to text, so a flag restating it would be + -- noise a reader has to check. + textual ^. #arguments + @?= ["-p", "--no-session-persistence", "--permission-mode", "plan"] + structured <- + renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig (base & #outputFormat .~ JsonFormat) + structured ^. #arguments + @?= [ "-p", + "--no-session-persistence", + "--output-format", + "json", + "--permission-mode", + "plan" + ] + agentCapabilityRenderingTests :: TestTree agentCapabilityRenderingTests = testGroup @@ -482,7 +525,7 @@ other -> assertFailure ("expected a budget drop, got: " <> show other) assertBool "the gate must refuse it" - (not (null (checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) AnthropicMessages (describeThinkingFor m opts)))), + (not (null (checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) (declaredStrength AnthropicMessages) (describeThinkingFor m opts)))), testCase "the claude CLI's minimal collapse is refused" $ expectDowngrade (EffortClamped ThinkingMinimal "low") @@ -497,7 +540,7 @@ opts = emptyOptions & #thinking .~ Just ThinkingMedium checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - AnthropicMessages + (declaredStrength AnthropicMessages) (describeThinkingFor m opts) @?= [] ] @@ -505,7 +548,7 @@ expectDowngrade expected translation = case checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) - AnthropicMessages + (declaredStrength AnthropicMessages) translation of [ThinkingWouldDowngrade [reported]] -> reported @?= expected other -> assertFailure ("expected one downgrade refusal, got: " <> show other) @@ -746,15 +789,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,268 @@ +-- | 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 (anthropic_claude_haiku_4_5) +import Baikai.Provider.Claude.Api (claudeMessagesStream) +import Baikai.Provider.Claude.Internal.Stream (SseDriver, claudeMessagesStreamWith) +import Baikai.Provider.Claude.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 (Anthropic Messages)" + [ 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)) + ] + +-- ============================================================ +-- Fixtures +-- ============================================================ + +-- | A @message_start@, a text block opened at index 0, and one delta of +-- @"Hel"@: the stream is healthy right up to the failure, and one block +-- is still open when it lands. +contentChunks :: [ByteString] +contentChunks = + [ "data: {\"type\":\"message_start\",\"message\":{\"id\":\"msg_observed\",\"type\":\"message\",", + "\"role\":\"assistant\",\"content\":[],\"model\":\"claude-haiku-4-5-20990101-server-side\",", + "\"stop_reason\":null,\"stop_sequence\":null,", + "\"usage\":{\"input_tokens\":11,\"output_tokens\":0}}}\n\n", + "data: {\"type\":\"content_block_start\",\"index\":0,\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n", + "data: {\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"text_delta\",\"text\":\"Hel\"}}\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 (claudeMessagesStreamWith (failingDriver chunks ex) testModel emptyContext testOptions) + +failingDriver :: [ByteString] -> SomeException -> SseDriver +failingDriver chunks ex _call 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 = do + ref <- newIORef chunks + let bodyReader = do + remaining <- readIORef ref + case remaining of + [] -> throwIO ex + (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 = + anthropic_claude_haiku_4_5 + & #api .~ AnthropicMessages + & #baseUrl .~ "https://api.anthropic.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 (claudeMessagesStream 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 + .~ AnthropicMessages + & #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-claude@, 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 (AgentClaude), agentRunRequest) +import Baikai.Provider.Claude.Agent qualified as Agent +import Baikai.Provider.Claude.Api qualified as Api +import Baikai.Provider.Claude.Cli qualified as Cli +import Baikai.Provider.Claude.Interactive qualified as Interactive +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "public surface (baikai-claude)" + [ testCase "the provider values carry their API tags" $ do + Api.claudeMessagesProvider.apiTag @?= AnthropicMessages + (Cli.claudeCliProvider Cli.defaultClaudeCliConfig).apiTag @?= AnthropicMessagesCli, + testCase "the interactive launcher renders a command without running one" $ + case Interactive.claudeInteractiveCommand + Interactive.defaultClaudeInteractiveConfig + (interactiveLaunchRequest "look around") of + Left refusal -> assertRefusalIsUnexpected refusal + Right (executable, _args) -> executable @?= "claude", + testCase "the unattended renderer renders a command without running one" $ + case Agent.claudeAgentCommand + Agent.defaultClaudeAgentConfig + (agentRunRequest AgentClaude "." "summarise") of + Left refusal -> assertRefusalIsUnexpected refusal + Right (cmd, _translation) -> cmd.executable @?= "claude" + ] + where + assertRefusalIsUnexpected refusal = + fail ("expected a rendered command, got a refusal: " <> show refusal) diff --git a/test/SseSpec.hs b/test/SseSpec.hs --- a/test/SseSpec.hs +++ b/test/SseSpec.hs @@ -1,22 +1,37 @@ module SseSpec (tests) where -import Baikai.Error (ErrorCategory (..), category, httpStatus, retryAfterSeconds) -import Baikai.Evidence (Observed (..)) +import Baikai +import Baikai.Http qualified as Http import Baikai.Models.Generated (anthropic_claude_haiku_4_5) -import Baikai.Provider.Claude.Api (Assembler, emptyAssembler, translate) -import Baikai.Provider.Claude.Sse (ResponseMetadata, sseFromResponse) +import Baikai.Provider.Claude.Internal.Stream (Assembler, SseDriver, claudeMessagesStreamWith, emptyAssembler, translate) +import Baikai.Provider.Claude.Sse + ( ResponseMetadata, + buildRequest, + claudeSseStreamValueWithHeaders, + sseFromResponse, + ) import Claude.V1.Messages qualified as Messages -import Control.Lens ((^.)) +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.CaseInsensitive qualified as CI import Data.Generics.Labels () -import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) +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 (assertBool, assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) tests :: TestTree tests = @@ -34,6 +49,37 @@ retryAfterSeconds e @?= Just 7 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 "200 response decodes split SSE data frames in order" $ do eventsRef <- newIORef [] metaRef <- newIORef [] @@ -52,7 +98,9 @@ [Right Messages.Message_Start {Messages.message = msg}, Right Messages.Message_Stop] -> msg ^. #id @?= "msg_1" other -> assertFailure ("expected message_start then message_stop, got: " <> show other), - observationTests + observationTests, + requestShapeTests, + redirectTests ] -- | What the transport and the assembler between them can say about @@ -105,9 +153,248 @@ -- Recorded in the order the response listed them; the -- adapter's preference order lives in capturedHeaderNames. [md] -> md ^. #headers @?= [("cf-ray", "ray-9"), ("x-request-id", "gw-1")] - other -> assertFailure ("expected exactly one metadata value, got: " <> show other) + other -> assertFailure ("expected exactly one metadata value, got: " <> show other), + failureStreamTests, + blockClosingTests ] +-- | How blocks close when something goes wrong, and what the transport +-- does with a frame it was not written for. +-- +-- The point of the group is that a consumer reading raw events and a +-- consumer reassembling them see the same partial output, and that a +-- frame Anthropic adds later does not end a healthy stream. +blockClosingTests :: TestTree +blockClosingTests = + testGroup + "block closing under failure" + [ testCase "a tool call cut off by max_tokens closes with its raw argument text" $ do + events <- replayStream 200 [] cutOffToolBody + 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, message = msg} : _) -> do + r @?= Length + [tc | AssistantToolCall tc <- Vector.toList (messageBlocks msg)] @?= calls + other -> assertFailure ("expected a terminal EventDone, got: " <> show (take 1 other)), + testCase "a refusal stop is ContentFiltered, not an unclassified provider error" $ do + events <- replayStream 200 [] refusalBody + assertErrorContract events + case reverse events of + (EventError TerminalPayload {errorInfo = Just be} : _) -> do + -- The content, not the transport, is the problem: its own + -- category, and not retryable as sent. + be ^. #category @?= ContentFiltered + isRetryable be @?= False + other -> assertFailure ("expected a terminal EventError, got: " <> show (take 1 other)), + testCase "a mid-stream transport error closes open blocks before the terminal" $ do + -- The failure is 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. + (openEvents, ass) <- replayTranslate openTextBody + let (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), + testCase "an unknown event type is skipped without ending the stream" $ do + events <- + transportEvents + 200 + [ frameOf "{\"type\":\"message_stop\"}", + frameOf "{\"type\":\"message_checkpoint\",\"checkpoint\":\"abc\"}", + frameOf "{\"type\":\"ping\"}" + ] + assertAllRight events + length events @?= 2, + testCase "an unknown delta type is skipped without ending the stream" $ do + events <- + transportEvents + 200 + [ frameOf "{\"type\":\"message_stop\"}", + frameOf "{\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"citations_delta\",\"citation\":{}}}", + frameOf "{\"type\":\"ping\"}" + ] + assertAllRight events + length events @?= 2, + testCase "an empty data heartbeat is ignored" $ do + events <- transportEvents 200 ["data:\n\n", frameOf "{\"type\":\"message_stop\"}"] + assertAllRight events + length events @?= 1 + ] + +-- | A stream that opens a tool call, streams half its arguments, and is +-- cut off by the output cap. +cutOffToolBody :: [ByteString] +cutOffToolBody = + [ frameOf + "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_cutoff\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-cutoff\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":4,\"output_tokens\":0}}}", + frameOf + "{\"type\":\"content_block_start\",\"index\":0,\"content_block\":{\"type\":\"tool_use\",\"id\":\"toolu_1\",\"name\":\"search\",\"input\":{}}}", + frameOf + "{\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"input_json_delta\",\"partial_json\":\"{\\\"query\\\":\\\"hel\"}}", + frameOf "{\"type\":\"content_block_stop\",\"index\":0}", + frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"max_tokens\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":9}}", + frameOf "{\"type\":\"message_stop\"}" + ] + +-- | A stream Anthropic ends with @stop_reason: "refusal"@: the model +-- declined to answer. Nothing failed on the wire. +refusalBody :: [ByteString] +refusalBody = + [ frameOf + "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_refusal\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-refusal\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":3,\"output_tokens\":0}}}", + frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"refusal\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":1}}", + frameOf "{\"type\":\"message_stop\"}" + ] + +-- | A stream that opens a text block and streams one delta into it, +-- and stops there: the state a mid-stream failure finds. +openTextBody :: [ByteString] +openTextBody = + [ frameOf + "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_open\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-open\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":2,\"output_tokens\":0}}}", + frameOf "{\"type\":\"content_block_start\",\"index\":0,\"content_block\":{\"type\":\"text\",\"text\":\"\"}}", + frameOf "{\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"text_delta\",\"text\":\"partial\"}}" + ] + +frameOf :: ByteString -> ByteString +frameOf body = "data: " <> body <> "\n\n" + +-- | The raw events the transport produced, with no assembler involved. +transportEvents :: + Int -> [ByteString] -> IO [Either BaikaiError Messages.MessageStreamEvent] +transportEvents status chunks = do + eventsRef <- newIORef [] + resp <- mkResponse status [] chunks + sseFromResponse resp (const (pure ())) (\ev -> modifyIORef' eventsRef (<> [ev])) + readIORef eventsRef + +assertAllRight :: [Either BaikaiError Messages.MessageStreamEvent] -> Assertion +assertAllRight events = + case [e | Left e <- events] of + [] -> pure () + errs -> assertFailure ("expected no transport errors, got: " <> show errs) + +-- | Replay through the real transport and fold the result through the +-- real translator, returning both the events emitted and the assembler +-- state they left behind. +replayTranslate :: [ByteString] -> IO ([AssistantMessageEvent], Assembler) +replayTranslate chunks = do + raw <- transportEvents 200 chunks + pure + ( foldl' + ( \(acc, a) ev -> + let (evs, a') = translate ev a testTime in (acc <> evs, a') + ) + ([], emptyAssembler anthropic_claude_haiku_4_5 testTime) + raw + ) + +messageBlocks :: Message -> Vector AssistantContent +messageBlocks = \case + AssistantMessage AssistantPayload {content = c} -> c + _ -> Vector.empty + +-- | Every way a Claude stream can fail before Anthropic has said +-- anything about the response. +-- +-- The point of the group is one invariant: the protocol's +-- "'EventStart' first, exactly one terminal" holds even when the +-- failure precedes @message_start@, which is the frame that used to +-- carry the start event. Each case drains the whole provider stream +-- through the real transport, so what is asserted is what a consumer +-- would actually see. +failureStreamTests :: TestTree +failureStreamTests = + testGroup + "failure streams are protocol-conformant" + [ testCase "an HTTP 401 before message_start is EventStart then one EventError" $ do + events <- + replayStream + 401 + [] + ["{\"type\":\"error\",\"error\":{\"type\":\"authentication_error\",\"message\":\"bad key\"}}"] + assertErrorContract events + terminalError events >>= \be -> category be @?= AuthError, + testCase "an HTTP 429 before message_start keeps EventStart first and Retry-After on the terminal" $ do + events <- + replayStream + 429 + [("Retry-After", "7")] + ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"] + assertErrorContract events + be <- terminalError events + category be @?= RateLimited + retryAfterSeconds be @?= Just 7, + testCase "an in-band error event before message_start is EventStart then one EventError" $ do + events <- + replayStream + 200 + [] + ["data: {\"type\":\"error\",\"error\":{\"type\":\"overloaded_error\",\"message\":\"busy\"}}\n\n"] + assertErrorContract events + terminalError events >>= \be -> category be @?= TransientError, + testCase "EOF before message_start is EventStart then one EventError" $ do + events <- replayStream 200 [] [] + assertErrorContract events + be <- terminalError events + be ^. #message @?= "claude stream ended without message_stop", + testCase "message_start updates the skeleton and emits no second EventStart" $ do + events <- replayStream 200 [] successBody + length [() | EventStart {} <- events] @?= 1 + case events of + -- The pre-seeded start carries no id: Anthropic has not sent + -- one yet when it is emitted. + (EventStart StartPayload {responseId = rid} : _) -> rid @?= Nothing + other -> assertFailure ("expected EventStart first, got: " <> show (take 1 other)) + case reverse events of + (EventDone TerminalPayload {responseId = rid} : _) -> rid @?= Just "msg_observed" + other -> assertFailure ("expected a terminal EventDone, got: " <> show (take 1 other)) + resp <- Stream.fold (reassembleResponse testModel) (Stream.fromList events) + resp ^. #responseId @?= Just "msg_observed" + ] + +-- | Drain a recorded response as the provider stream a consumer sees. +replayStream :: Int -> [(ByteString, ByteString)] -> [ByteString] -> IO [AssistantMessageEvent] +replayStream status headers chunks = + Stream.toList + (claudeMessagesStreamWith (replayDriver status headers chunks) testModel emptyContext testOptions) + +-- | A transport driver that serves a recorded response instead of +-- opening a socket. The same eleven lines as +-- @EvidenceSpec.replayDriver@; the two suites keep their own so neither +-- can silently change the other's fixtures. +replayDriver :: Int -> [(ByteString, ByteString)] -> [ByteString] -> SseDriver +replayDriver status headers chunks _call onMetadata onEvent = do + resp <- mkResponse status headers chunks + sseFromResponse resp onMetadata onEvent + +-- | The typed error on a stream's terminal. 'errorInfo' is a 'Maybe'; +-- whether a failed stream carries a typed error at all is part of what +-- these cases assert. +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)) + +testModel :: Model +testModel = + anthropic_claude_haiku_4_5 + & #api .~ AnthropicMessages + & #baseUrl .~ "https://api.anthropic.com" + +testOptions :: Options +testOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key") + -- | 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] @@ -164,3 +451,102 @@ 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/messages` 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.anthropic.com/v1", "/v1/messages"), + ("https://api.anthropic.com", "/v1/messages"), + ("https://gateway.test/anthropic", "/anthropic/v1/messages"), + ("https://gateway.test/anthropic/v1/", "/anthropic/v1/messages") + ] + $ \(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 [] + claudeSseStreamValueWithHeaders + 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/ThinkingSpec.hs b/test/ThinkingSpec.hs --- a/test/ThinkingSpec.hs +++ b/test/ThinkingSpec.hs @@ -4,14 +4,21 @@ import Baikai import Baikai.Models.Generated -import Baikai.Provider.Claude.Api (Assembler, emptyAssembler, translate) -import Baikai.Provider.Claude.Internal.Request (mapRequest) +import Baikai.Provider.Claude.Internal.Request + ( describeThinkingFor, + mapRequest, + normalizeToolCallId, + uncappedMaxTokensFloor, + ) +import Baikai.Provider.Claude.Internal.Stream (Assembler, emptyAssembler, translate) import Claude.V1.Messages qualified as Messages import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BSL +import Data.Char qualified as Char import Data.Generics.Labels () import Data.IntMap.Strict qualified as IntMap +import Data.List qualified as List import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector @@ -33,19 +40,36 @@ tooSmallCapDropsThinkingTest, mergedOutputConfigTest, explicitCompatOverridesDefaultTest, + anthropicModelsCoverCatalogTest, + samplingTests, + claude15UsageTests, + zeroCapFloorTests, + replaySanitationTests, + toolIdTests, streamFidelityTests ] -anthropicModels :: [(String, Model, AnthropicThinkingStyle)] +-- | Every Anthropic model in the generated catalog, with the two +-- request-shaping facts its compat record states. Written out by hand +-- rather than read off the record, so a catalog refresh that changes a +-- generation's wire shape fails a row here instead of quietly agreeing +-- with itself. The last column is +-- 'Baikai.Compat.supportsSamplingParameters'. +-- +-- @anthropicModelsCoverCatalogTest@ ties the table to @allModels@, so a +-- newly curated model cannot arrive unpinned. +anthropicModels :: [(String, Model, AnthropicThinkingStyle, Bool)] anthropicModels = - [ ("claude-fable-5", anthropic_claude_fable_5, AnthropicThinkingAdaptive), - ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget), - ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget), - ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive), - ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive), - ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive), - ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget), - ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingBudget) + [ ("claude-fable-5", anthropic_claude_fable_5, AnthropicThinkingAdaptive, False), + ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget, True), + ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget, True), + ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive, True), + ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive, False), + ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive, False), + ("claude-opus-5", anthropic_claude_opus_5, AnthropicThinkingAdaptive, False), + ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget, True), + ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingAdaptive, True), + ("claude-sonnet-5", anthropic_claude_sonnet_5, AnthropicThinkingAdaptive, False) ] thinkingLevels :: [(String, ThinkingLevel)] @@ -62,9 +86,9 @@ neverExceedsCapTests = [ testCase (name <> " " <> levelName <> " stays within catalog cap") $ do req <- requestFor model (emptyOptions & #thinking .~ Just level) - Messages.max_tokens req <= model ^. #maxOutputTokens + req ^. #max_tokens <= model ^. #maxOutputTokens @?= True - | (name, model, _) <- anthropicModels, + | (name, model, _, _) <- anthropicModels, (levelName, level) <- thinkingLevels ] @@ -79,13 +103,13 @@ @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = expectedBudget} assertBool "max_tokens leaves visible-output room beyond budget" - (Messages.max_tokens req > expectedBudget) + (req ^. #max_tokens > expectedBudget) AnthropicThinkingAdaptive -> do requestThinking req @?= Just Messages.ThinkingAdaptive - Messages.max_tokens req @?= model ^. #maxOutputTokens - (Messages.output_config req >>= Messages.effort) + req ^. #max_tokens @?= model ^. #maxOutputTokens + (req ^. #output_config >>= Messages.effort) @?= adaptiveEffort level - | (name, model, style) <- anthropicModels, + | (name, model, style, _) <- anthropicModels, (levelName, level) <- thinkingLevels ] @@ -182,7 +206,7 @@ opts = emptyOptions & #thinking .~ Just ThinkingMinimal req <- requestFor model opts requestThinking req @?= Nothing - Messages.max_tokens req @?= 1000 + req ^. #max_tokens @?= 1000 t <- translationFor model opts t ^. #requested @?= Just ThinkingMinimal t ^. #mode @?= ThinkingModeUnsupported @@ -203,7 +227,7 @@ anthropic_claude_opus_4_7 (emptyOptions & #thinking .~ Just level) requestThinking req @?= Just Messages.ThinkingAdaptive - (Messages.output_config req >>= Messages.effort) @?= Just expected + (req ^. #output_config >>= Messages.effort) @?= Just expected | (name, level, expected) <- [ ("xhigh is preserved", ThinkingXHigh, "xhigh"), ("max is preserved", ThinkingMax, "max") @@ -221,7 +245,7 @@ @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = 32768} assertBool "max_tokens leaves visible-output room beyond the max thinking budget" - (Messages.max_tokens req > 32768) + (req ^. #max_tokens > 32768) explicitMaxTokensTest :: TestTree explicitMaxTokensTest = @@ -234,7 +258,7 @@ req <- requestFor anthropic_claude_haiku_4_5 opts requestThinking req @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = budget} - Messages.max_tokens req @?= anthropic_claude_haiku_4_5 ^. #maxOutputTokens + req ^. #max_tokens @?= anthropic_claude_haiku_4_5 ^. #maxOutputTokens handRolledUnclampedTest :: TestTree handRolledUnclampedTest = @@ -252,7 +276,7 @@ & #maxTokens .~ Just 100 expected = 100 + thinkingTokenBudget ThinkingLow req <- requestFor model opts - Messages.max_tokens req @?= expected + req ^. #max_tokens @?= expected tooSmallCapDropsThinkingTest :: TestTree tooSmallCapDropsThinkingTest = @@ -263,7 +287,7 @@ opts = emptyOptions & #thinking .~ Just ThinkingMinimal req <- requestFor model opts requestThinking req @?= Nothing - Messages.max_tokens req @?= 1000 + req ^. #max_tokens @?= 1000 mergedOutputConfigTest :: TestTree mergedOutputConfigTest = @@ -273,11 +297,11 @@ emptyOptions & #thinking .~ Just ThinkingMedium & #responseFormat - .~ Just (JsonSchema {name = "answer", schema = schema, strict = True}) + .~ Just (JsonSchema (jsonSchemaFormat "answer" schema) {strict = True}) expected = (Messages.jsonSchemaConfig schema) {Messages.effort = Just "medium"} req <- requestFor anthropic_claude_opus_4_6 opts requestThinking req @?= Just Messages.ThinkingAdaptive - Messages.output_config req @?= Just expected + req ^. #output_config @?= Just expected explicitCompatOverridesDefaultTest :: TestTree explicitCompatOverridesDefaultTest = @@ -292,7 +316,7 @@ opts = emptyOptions & #thinking .~ Just ThinkingLow req <- requestFor model opts requestThinking req @?= Just Messages.ThinkingAdaptive - (Messages.output_config req >>= Messages.effort) @?= Just "low" + (req ^. #output_config >>= Messages.effort) @?= Just "low" requestFor :: Model -> Options -> IO Messages.CreateMessage requestFor model opts = fst <$> mappedFor model emptyContext opts @@ -318,6 +342,335 @@ ThinkingXHigh -> Just "xhigh" ThinkingMax -> Just "max" +-- | The pinned table above must name exactly the catalog's Anthropic +-- ids. Without this, curating a new generation into the catalog adds a +-- model nothing checks, which is how @claude-sonnet-5@ shipped with the +-- wrong thinking shape in the first place. +anthropicModelsCoverCatalogTest :: TestTree +anthropicModelsCoverCatalogTest = + testCase "anthropicModels covers exactly the catalog's Anthropic ids" $ + List.sort [m ^. #modelId | (_, m, _, _) <- anthropicModels] + @?= List.sort [m ^. #modelId | m <- allModels, m ^. #api == AnthropicMessages] + +-- | Sampling parameters against the catalog's own record. +-- +-- The adaptive-era generations reject @temperature@, @top_p@ and +-- @top_k@ with a 400, so baikai omits them and records the omission +-- rather than sending a request it knows will fail. The generations +-- that accept them get them verbatim, and nothing is recorded. +samplingTests :: TestTree +samplingTests = + testGroup + "sampling parameters follow the catalog record" + ( [ testCase (name <> " " <> verb) $ do + let opts = emptyOptions & #temperature .~ Just 0.2 & #topP .~ Just 0.9 + req <- requestFor model opts + t <- translationFor model opts + if supported + then do + Messages.temperature req @?= Just 0.2 + Messages.top_p req @?= Just 0.9 + filter isSamplingAdjustment (t ^. #adjustments) @?= [] + else do + Messages.temperature req @?= Nothing + Messages.top_p req @?= Nothing + filter isSamplingAdjustment (t ^. #adjustments) + @?= [SamplingDroppedUnsupportedModel ["temperature", "top_p"]] + | (name, model, _, supported) <- anthropicModels, + let verb = if supported then "forwards temperature and top_p" else "drops temperature and top_p and records it" + ] + <> [ testCase "sampling is dropped and recorded even when no thinking level is set" $ do + -- The adjustment list is not only about thinking. A call + -- that asked for no thinking at all still reports what + -- happened to its sampling parameters. + let opts = emptyOptions & #temperature .~ Just 0.2 + req <- requestFor anthropic_claude_sonnet_5 opts + t <- translationFor anthropic_claude_sonnet_5 opts + Messages.temperature req @?= Nothing + t ^. #mode @?= ThinkingModeAbsent + t ^. #requested @?= Nothing + t ^. #adjustments @?= [SamplingDroppedUnsupportedModel ["temperature"]], + testCase "only the parameters the caller actually set are named" $ do + let opts = emptyOptions & #topP .~ Just 0.9 + t <- translationFor anthropic_claude_sonnet_5 opts + t ^. #adjustments @?= [SamplingDroppedUnsupportedModel ["top_p"]], + testCase "seed and penalties are recorded as API-level drops" $ do + -- These three have no Anthropic Messages field on any + -- generation, so they are dropped even on a model that + -- accepts temperature. + let opts = + emptyOptions + & #seed .~ Just 7 + & #presencePenalty .~ Just 0.3 + t <- translationFor anthropic_claude_haiku_4_5 opts + t ^. #adjustments + @?= [SamplingDroppedUnsupportedApi ["seed", "presence_penalty"]], + testCase "a sampling drop does not refuse a strict call" $ + -- The gate refuses a call whose thinking would be + -- weakened. A parameter the API never had is not that. + checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + (declaredStrength AnthropicMessages) + (describeThinkingFor anthropic_claude_sonnet_5 (emptyOptions & #temperature .~ Just 0.2)) + @?= [] + ] + ) + +isSamplingAdjustment :: ThinkingAdjustment -> Bool +isSamplingAdjustment = \case + SamplingDroppedUnsupportedModel {} -> True + SamplingDroppedUnsupportedApi {} -> True + _ -> False + +-- | A model whose cap is unknown still needs a @max_tokens@. +-- +-- Anthropic requires the field and rejects @0@, so a hand-rolled model +-- built from 'emptyModel' used to send @"max_tokens":0@ — and, with +-- thinking set, to have its whole thinking plan discarded because the +-- budget could not fit inside a ceiling of zero. +zeroCapFloorTests :: TestTree +zeroCapFloorTests = + testGroup + "a model with an unknown output cap sends the documented floor" + [ testCase "hand-rolled model with unknown cap sends the 1024 floor" $ do + req <- requestFor uncappedModel emptyOptions + req ^. #max_tokens @?= uncappedMaxTokensFloor, + testCase "the floor leaves room for a thinking budget" $ do + let opts = emptyOptions & #thinking .~ Just ThinkingLow + req <- requestFor uncappedModel opts + t <- translationFor uncappedModel opts + req ^. #max_tokens @?= uncappedMaxTokensFloor + thinkingTokenBudget ThinkingLow + requestThinking req + @?= Just Messages.ThinkingEnabled {Messages.budget_tokens = thinkingTokenBudget ThinkingLow} + t ^. #adjustments @?= [], + testCase "an explicit maxTokens of zero is forwarded as written" $ do + -- The floor stands in for an unknown cap, not for a caller's + -- own choice. Someone who wrote Just 0 gets 0. + req <- requestFor uncappedModel (emptyOptions & #maxTokens .~ Just 0) + req ^. #max_tokens @?= 0 + ] + where + uncappedModel = + emptyModel + & #modelId .~ "custom-claude" + & #api .~ AnthropicMessages + & #reasoning .~ True + & #maxOutputTokens .~ 0 + +-- | Anthropic rejects an empty text block and an empty content array. +-- baikai can produce either from its own bookkeeping, so replay strips +-- them before they reach the wire. +replaySanitationTests :: TestTree +replaySanitationTests = + testGroup + "replay never sends an empty block or an empty turn" + [ testCase "an assistant turn of only empty text is dropped entirely" $ do + msgs <- mappedMessages [assistantBlocks [AssistantText (TextContent "")], user "next"] + Vector.length msgs @?= 1 + (messageRole <$> (msgs Vector.!? 0)) @?= Just Messages.User, + testCase "an empty text block beside a real one is dropped, the turn kept" $ do + msgs <- mappedMessages [assistantBlocks [AssistantText (TextContent ""), AssistantText (TextContent "visible")]] + Vector.length msgs @?= 1 + case msgs Vector.!? 0 of + Just m -> Vector.length (messageContent m) @?= 1 + Nothing -> assertFailure "expected one message", + testCase "an assistant turn of only unsigned thinking is dropped" $ do + -- Unsigned thinking is already omitted block by block, because + -- Anthropic rejects a thinking block without its signature. + -- What is new is that the empty turn left behind goes too. + msgs <- + mappedMessages + [ assistantBlocks + [AssistantThinking ThinkingContent {thinking = "hmm", signature = Nothing, redacted = False}], + user "next" + ] + Vector.length msgs @?= 1, + testCase "a tool call keeps its turn even beside empty text" $ do + msgs <- + mappedMessages + [assistantBlocks [AssistantToolCall (ToolCall "toolu_1" "f" (Aeson.object [])), AssistantText (TextContent "")]] + Vector.length msgs @?= 1 + case msgs Vector.!? 0 of + Just m -> Vector.length (messageContent m) @?= 1 + Nothing -> assertFailure "expected one message", + testCase "a user turn with nothing left in it is refused locally" $ + -- The caller's error, not baikai's: refused here with a better + -- message than the provider's 400, and with the same category. + case mapRequest anthropic_claude_haiku_4_5 (contextOf [userBlocks [UserText (TextContent "")]]) emptyOptions of + Left e -> assertBool ("mentions the user turn: " <> Text.unpack e) ("user turn" `Text.isInfixOf` e) + Right _ -> assertFailure "expected a user turn with no blocks to be refused" + ] + +-- | Tool-call ids are normalised on both sides of the round trip, so +-- the normalisation has to be injective enough that two distinct calls +-- in one turn never collapse onto one id. +toolIdTests :: TestTree +toolIdTests = + testGroup + "tool-call ids normalise without colliding" + [ testCase "an Anthropic-minted id passes through unchanged" $ + normalizeToolCallId "toolu_01ABCdef" @?= "toolu_01ABCdef", + testCase "an OpenAI-minted id passes through unchanged" $ + normalizeToolCallId "call_abc-123_x" @?= "call_abc-123_x", + testCase "ids that used to collide no longer do" $ do + -- Both used to sanitise to "a_b". + normalizeToolCallId "a.b" /= normalizeToolCallId "a_b" @?= True + assertValidId (normalizeToolCallId "a.b") + assertValidId (normalizeToolCallId "a_b"), + testCase "a long id is truncated to the limit with its hash suffix" $ do + let long = Text.replicate 70 "x" + normalised = normalizeToolCallId long + Text.length normalised @?= 64 + Text.index normalised 51 @?= '_' + assertValidId normalised, + testCase "ids differing only past character 64 stay distinct" $ + normalizeToolCallId (Text.replicate 64 "x" <> "a") + /= normalizeToolCallId (Text.replicate 64 "x" <> "b") + @?= True, + testCase "a call and the result answering it normalise to the same id" $ do + msgs <- + mappedMessages + [ assistantBlocks [AssistantToolCall (ToolCall "a.b" "f" (Aeson.object []))], + toolResult "a.b" "f" "done" False + ] + toolUseIds msgs @?= toolResultIds msgs, + testCase "two tool calls with one id in a turn are refused" $ + case mapRequest + anthropic_claude_haiku_4_5 + ( contextOf + [ assistantBlocks + [ AssistantToolCall (ToolCall "dup" "f" (Aeson.object [])), + AssistantToolCall (ToolCall "dup" "g" (Aeson.object [])) + ] + ] + ) + emptyOptions of + Left e -> assertBool ("mentions the duplicate: " <> Text.unpack e) ("duplicate" `Text.isInfixOf` e) + Right _ -> assertFailure "expected duplicate tool_use ids to be refused" + ] + where + assertValidId i = do + assertBool ("within 64 characters: " <> Text.unpack i) (Text.length i <= 64) + assertBool ("no character outside the alphabet: " <> Text.unpack i) (Text.all ok i) + ok c = (Char.isAscii c && Char.isAlphaNum c) || c == '_' || c == '-' + toolUseIds msgs = + [i | m <- Vector.toList msgs, Messages.Content_Tool_Use {Messages.id = i} <- Vector.toList (messageContent m)] + toolResultIds msgs = + [ i + | m <- Vector.toList msgs, + Messages.Content_Tool_Result {Messages.tool_use_id = i} <- Vector.toList (messageContent m) + ] + +-- | An assistant turn carrying exactly these blocks. +assistantBlocks :: [AssistantContent] -> Message +assistantBlocks blocks = + AssistantMessage + AssistantPayload + { content = Vector.fromList blocks, + usage = zeroUsage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = Just testTime + } + +-- | A user turn carrying exactly these blocks. +userBlocks :: [UserContent] -> Message +userBlocks blocks = + UserMessage + UserPayload + { content = Vector.fromList blocks, + timestamp = Just testTime + } + +mappedMessages :: [Message] -> IO (Vector.Vector Messages.Message) +mappedMessages msgs = + requestMessages <$> requestForContext anthropic_claude_haiku_4_5 (contextOf msgs) emptyOptions + +messageRole :: Messages.Message -> Messages.Role +messageRole Messages.Message {Messages.role = r} = r + +-- | What @claude@ 1.5.0 added to the Messages response and what baikai +-- now reads off it. Each of these was unreadable before the bump: +-- 'Messages.Usage' had no thinking-token breakdown, +-- 'Messages.StreamUsage' carried only @output_tokens@, and +-- 'Messages.StopReason' had no @pause_turn@. +claude15UsageTests :: TestTree +claude15UsageTests = + testGroup + "the counts and stop reasons claude 1.5 reports" + [ testCase "thinking tokens at message_start reach reasoningTokens" $ do + let (_, ass) = + runClaudeEvents + [ messageStartWith + (startUsage 10) + { Messages.output_tokens_details = + Just Messages.OutputTokensDetails {Messages.thinking_tokens = 7} + } + ] + ass ^. #usage . #reasoningTokens @?= Just 7, + testCase "no thinking-token breakdown leaves reasoningTokens unset" $ do + let (_, ass) = runClaudeEvents [messageStart] + ass ^. #usage . #reasoningTokens @?= Nothing, + testCase "a message_delta's prompt-side counts replace the message_start figures" $ do + -- A server-side tool run grows the prompt after message_start, + -- and the final delta is the only place that says by how much. + let (_, ass) = + runClaudeEvents + [ messageStartWith (startUsage 10), + messageDelta + (Just Messages.End_Turn) + (outputOnlyStreamUsage 12) + { Messages.stream_input_tokens = Just 40, + Messages.stream_cache_read_input_tokens = Just 5, + Messages.stream_cache_creation_input_tokens = Just 3, + Messages.stream_output_tokens_details = + Just Messages.OutputTokensDetails {Messages.thinking_tokens = 9} + } + ] + u = ass ^. #usage + u ^. #inputTokens @?= 40 + u ^. #outputTokens @?= 12 + u ^. #cacheReadTokens @?= 5 + u ^. #cacheWriteTokens @?= 3 + u ^. #reasoningTokens @?= Just 9 + u ^. #totalTokens @?= 60, + testCase "a message_delta that omits them keeps the message_start figures" $ do + -- The pre-1.5 wire shape. Absent is not zero. + let (_, ass) = + runClaudeEvents + [ messageStartWith + (startUsage 10) + { Messages.cache_read_input_tokens = Just 5, + Messages.cache_creation_input_tokens = Just 3 + }, + messageDelta (Just Messages.End_Turn) (outputOnlyStreamUsage 12) + ] + u = ass ^. #usage + u ^. #inputTokens @?= 10 + u ^. #outputTokens @?= 12 + u ^. #cacheReadTokens @?= 5 + u ^. #cacheWriteTokens @?= 3 + u ^. #totalTokens @?= 30, + testCase "a paused turn ends the stream as a stop, not an error" $ do + -- Anthropic suspends the turn for a long-running server-side + -- tool and expects the message back to continue it. Nothing + -- failed, so the caller must not be handed an error. + let (events, ass) = + runClaudeEvents + [ messageStart, + messageDelta (Just Messages.Pause_Turn) (outputOnlyStreamUsage 12), + Messages.Message_Stop + ] + ass ^. #stopReason @?= Stop + case last events of + EventDone TerminalPayload {reason = r, message = msg} -> do + r @?= Stop + case msg of + AssistantMessage AssistantPayload {errorMessage = err} -> err @?= Nothing + _ -> assertFailure "terminal message was not an assistant message" + _ -> assertFailure "a paused turn produced a terminal error" + ] + streamFidelityTests :: TestTree streamFidelityTests = testGroup @@ -456,9 +809,10 @@ { Messages.message_delta = Messages.MessageDelta { Messages.stop_reason = Just Messages.End_Turn, - Messages.stop_sequence = Nothing + Messages.stop_sequence = Nothing, + Messages.stop_details = Nothing }, - Messages.usage = Messages.StreamUsage {Messages.output_tokens = 12} + Messages.usage = outputOnlyStreamUsage 12 }, Messages.Message_Stop ] @@ -475,14 +829,78 @@ Messages.model = "claude-haiku-4-5", Messages.stop_reason = Nothing, Messages.stop_sequence = Nothing, - Messages.usage = - Messages.Usage - { Messages.input_tokens = 10, - Messages.output_tokens = 0, - Messages.cache_creation_input_tokens = Nothing, - Messages.cache_read_input_tokens = Nothing, - Messages.server_tool_use = Nothing - }, + Messages.stop_details = Nothing, + Messages.usage = startUsage 10, + Messages.container = Nothing + } + } + +-- | A @message_start@ usage reporting the given prompt tokens and +-- nothing else. Refine it by record update rather than respelling ten +-- fields; the ones this provider never reads — @inference_geo@, +-- @service_tier@, @speed@, @iterations@ — stay 'Nothing' so a test says +-- only what it means to say. The prompt count is an argument rather +-- than an update because @input_tokens@ alone does not name one record +-- in @claude@ 1.5.0, and a single-field update on it is ambiguous. +startUsage :: Natural -> Messages.Usage +startUsage inputTokens = + Messages.Usage + { Messages.input_tokens = inputTokens, + Messages.output_tokens = 0, + Messages.cache_creation_input_tokens = Nothing, + Messages.cache_read_input_tokens = Nothing, + Messages.server_tool_use = Nothing, + Messages.inference_geo = Nothing, + Messages.output_tokens_details = Nothing, + Messages.service_tier = Nothing, + Messages.speed = Nothing, + Messages.iterations = Nothing + } + +-- | A @message_delta@ usage reporting output tokens and nothing else, +-- which is everything a pre-Claude-5 generation sends. Refine it by +-- record update to model a generation that also repeats the +-- prompt-side counts. +outputOnlyStreamUsage :: Natural -> Messages.StreamUsage +outputOnlyStreamUsage n = + Messages.StreamUsage + { Messages.stream_input_tokens = Nothing, + Messages.output_tokens = n, + Messages.stream_cache_creation_input_tokens = Nothing, + Messages.stream_cache_read_input_tokens = Nothing, + Messages.stream_server_tool_use = Nothing, + Messages.stream_output_tokens_details = Nothing, + Messages.stream_iterations = Nothing + } + +-- | A @message_delta@ event carrying a stop reason and a usage. +messageDelta :: Maybe Messages.StopReason -> Messages.StreamUsage -> Messages.MessageStreamEvent +messageDelta reason su = + Messages.Message_Delta + { Messages.message_delta = + Messages.MessageDelta + { Messages.stop_reason = reason, + Messages.stop_sequence = Nothing, + Messages.stop_details = Nothing + }, + Messages.usage = su + } + +-- | A @message_start@ event whose usage is the caller's. +messageStartWith :: Messages.Usage -> Messages.MessageStreamEvent +messageStartWith u = + Messages.Message_Start + { Messages.message = + Messages.MessageResponse + { Messages.id = "msg_test", + Messages.type_ = "message", + Messages.role = Messages.Assistant, + Messages.content = Vector.empty, + Messages.model = "claude-haiku-4-5", + Messages.stop_reason = Nothing, + Messages.stop_sequence = Nothing, + Messages.stop_details = Nothing, + Messages.usage = u, Messages.container = Nothing } } diff --git a/test/TransportSpec.hs b/test/TransportSpec.hs --- a/test/TransportSpec.hs +++ b/test/TransportSpec.hs @@ -1,19 +1,24 @@ module TransportSpec (tests) where import Baikai +import Baikai.Provider.Claude.Api (claudeMessagesStream) import Baikai.Provider.Claude.Transport qualified as Transport import Control.Concurrent (threadDelay) import Control.Exception (bracket, try) import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) import Data.CaseInsensitive qualified as CI +import Data.IORef (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 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 = @@ -23,12 +28,26 @@ requestHeadersTest, sessionAffinityTest, 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-anthropic.test" before <- Transport.cachedClientEnvCount _ <- Transport.getClientEnvCached url @@ -37,6 +56,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-Anthropic.test/" + afterVariant <- Transport.cachedClientEnvCount + afterVariant @?= afterSecond + Client.baseUrlHost (Client.baseUrl env) @?= "cache-anthropic.test" + Client.baseUrlPath (Client.baseUrl env) @?= "" requestHeadersTest :: TestTree requestHeadersTest = @@ -75,6 +101,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 ANTHROPIC_API_KEY" $ @@ -92,5 +135,51 @@ withEnv name value = bracket (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 "ANTHROPIC_AnthropicMessages_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/messages", "endpoint path") + ] + $ \(url, needle) -> do + let model = emptyModel & #api .~ AnthropicMessages & #baseUrl .~ url + events <- Stream.toList (claudeMessagesStream 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