diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,2487 @@ +# Changelog + +All notable changes to baikai are recorded here. + +The format follows [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and +this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). + +## [Unreleased] + +## [baikai 0.7.0.0] - 2026-09-08 + +### Added + +- `BaikaiError.refusalCategory` preserves an Anthropic refusal's + provider category. JSON adds `refusal_category`; older errors still decode. + Evidence schema 2.5 records the addition without changing digest inputs. + __Breaking__ to construct a `BaikaiError` from its full field list. + +- `Speed`, `Options.speed`, catalog-owned fast rates and + `computeCostAtSpeed`. Anthropic gates fast mode by model capability, adds the + beta header and records unsupported drops. Terminal pricing uses observed + speed, including cache duration; unreported speed is an explicit estimate. + Older `Model` JSON defaults the new fields safely. __Breaking__: public + records and sum types gain fields and constructors. + +- API usage now records observed service tiers, inference speed and server-tool + use in optional billing facts covered by evidence schema 2.2. Missing service + information and uncurated products produce explicit standard-rate estimates. + `computeCostForService` separates requested and observed service, while + `computeCostAtRates` prices a resolved rate set once for future speed policies. + Empty billing facts preserve legacy availability JSON; a CLI-reported zero + cost retains its reported-total source. __Breaking__: the public vocabulary + and records gain members. + +- Failed trace terminals now retain partial response token counts, cost basis, + usage availability and USD totals. Synthetic aborts leave unreported billing + absent; legacy failed trace JSON still decodes. __Breaking__: `TraceEvent`'s + `CallFailed` gains fields. See `baikai-trace-otel 0.4.0.1` for the export. + +- Successful trace terminals and call-log records carry optional cost basis and + usage availability; call logs also carry cache-write counts. Old JSON decodes + with absent metadata and empty additive-zero bases stay omitted from traces. + __Breaking__: `CallFinished` and the call-log record gain fields. + +- Optional `Usage.availability` and shared inclusive/exclusive billing + normalization, in the new `Baikai.Usage.Normalize`. OpenAI Chat/Responses and + Claude preserve missing cache counters as explicit estimation reasons, + distinguish reported zeroes, and merge cumulative usage without + double-counting. Schema 2.2 commits provider availability while preserving + legacy usage digests. __Breaking__: `Usage` gains a field. + +- Optional `Model.pricingPolicy`, exact whole-request context tiers, + and an explicit cache-duration rate resolver. Generated Astra pricing changes + above 272000 input tokens; Fable exposes its one-hour write price. `Cost.basis` + preserves calculation sources and estimation reasons when summed. Evidence + schema 2.2 serializes the local basis without including local pricing metadata + in provider commitments. __Breaking__: `Model` and `Cost` gain fields. + +- Separate `OpenAIResponses` dispatch and compatibility types, and + optional provider/model-scoped `ThinkingContent.replayState` with opaque + diagnostic output and backward-compatible JSON decoding. Evidence schema 2.2 + includes replay state and optional billing facts in commitments while preserving + legacy encodings when those fields are absent. __Breaking__ for a `case` over + `Api` that is exhaustive without a wildcard. + +- `Baikai.Evidence.ThinkingTranslation` gains `displayText` and + `ThinkingAdjustment` gains `ThinkingSummaryUnavailable`, so a transport can + record the thinking display setting it asked for and diagnose a successful + response whose thinking blocks carry no readable summary. `Baikai.Compat` + gains `supportsForcedToolChoice`; legacy JSON defaults it to True. + __Breaking__ for an exhaustive `case` over `ThinkingAdjustment`. + +- GPT-6 Astra and Claude Fable 5.1 catalog bindings, with verified + pricing, token limits, and Anthropic thinking/sampling compatibility. + +- Repository `update-models` skill for verifying provider releases and refreshing + the curated JSON and generated Haskell catalog. + +### Fixed + +- Preserve OpenAI endpoint capability facts through catalog refreshes. + +- Chat and Claude reject provider-scoped reasoning replay they cannot encode. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +## [baikai-claude 0.7.0.0] - 2026-09-08 + +### Changed + +- Refusal messages include the reported category and explanation, + retaining the original message when neither exists. Classification remains + non-retryable `ContentFiltered`. Server-side fallbacks remain deliberately + unsupported, as recorded in ADR 0005. + +- Adaptive reasoning requests explicitly ask for summarized + thinking. Evidence schema 2.4 records the display setting and diagnoses + successful responses whose thinking blocks contain no readable summary. + Budget and absent-thinking request shapes, signed empty blocks, redacted + content and multi-turn replay are preserved. + +- Fast mode is gated by the generated model capability: it adds the Anthropic + beta header for a model that advertises it and records an evidence adjustment + for one that does not. + +### Fixed + +- Price Fable cache writes using the TTL in the shaped request, + including compatibility downgrades. Missing write-duration context is explicit + in the cost basis. + +- Reject forced tool choices locally on Fable 5.1, using the + generated `supportsForcedToolChoice` capability. Automatic tool rounds retain + signed empty/visible thinking, redacted blocks and prior-message order. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-openai 0.7.0.0] - 2026-09-08 + +### Added + +- Explicit `Baikai.Provider.OpenAI.Responses` registration and + stream/complete provider with stateless reasoning replay, function tool turns, + structured output and bounded worker cleanup, across the new + `Baikai.Provider.OpenAI.Responses.{Request,Stream,Assembler}` modules. Astra + now selects this provider through a per-model catalog override; callers must + register it explicitly. Cache writes, billing availability and context pricing + are integrated. + +- `Baikai.Provider.OpenAI.Internal.Usage`, the shared usage mapping both the + Chat Completions and Responses transports read. + +### Fixed + +- Reject tools locally for models whose Chat Completions endpoint + disallows them, including GPT-6 Astra. Respect generated effort policies and + sampling restrictions, with matching translation evidence and strict refusal. + +- Validate Responses terminals and enforce the stream contracts. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-trace-otel 0.4.0.1] - 2026-09-08 + +### Added + +- Successful and failed spans export `baikai.cost.basis` and + `baikai.usage.availability` as canonically encoded JSON. A failed span now + also carries the input/output token counts and USD total that + `baikai 0.7.0.0` retains on `CallFailed`, alongside its error status. + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, and now depends on `aeson ^>=2.2` to encode the + two new attributes. + +## [baikai-effectful 0.4.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-kit 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-agent 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, `baikai-claude ^>=0.7` and + `baikai-openai ^>=0.7`. No API change. + +## [baikai 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4. The 0.4 API retains the + manager functions this package uses and belongs to the same TLS 2.x / Crypton + 1.1 dependency cohort as baikai 0.6; the old `^>=0.3` cap made baikai 0.6 + impossible to solve in applications that require Crypton 1.1. + +## [baikai-claude 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4, allowing applications that + require Crypton 1.1 to solve the dependency set. + +## [baikai-openai 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4, allowing applications that + require Crypton 1.1 to solve the dependency set. + +## [baikai 0.6.0.0] - 2026-08-28 + +### Added + +- `baikai`: `Baikai.ThinkingLevel.parseThinkingLevel :: Text -> Maybe + ThinkingLevel` and `Baikai.Evidence.parseEvidenceStrength :: Text -> Maybe + EvidenceStrength`, each beside its renderer. Three hand-copied tables — the + evidence schema's level parser, `baikai-agent`'s KDL `effort` decoder, and its + `--require-evidence` parser — now read them instead, so a level or strength + added later cannot be added in one place and missed in three. (REV-2 G.6.) + +- `baikai`: `Baikai.Agent.AgentRunResult` exports its selectors (`provider`, + `exitCode`, `stdout`, `stderr`, `duration`). It exported neither them nor its + constructor, so a consumer without generic-lens could not read a run's exit + code at all. (REV-2 G.6.) + +- `baikai`: `Baikai.Api.normaliseApi :: Api -> Api`, which collapses a `Custom` + tag that spells a built-in API onto that constructor. The registry applies it + to the key it stores and to the tag it is asked for, so a handler registered + under `Custom "anthropic-messages"` answers a model tagged `AnthropicMessages` + and the reverse; the two used to be separate entries and dispatch depended on + which spelling the model happened to carry. Derived `Eq`/`Ord` on `Api` are + deliberately unchanged: altering them would silently rearrange every + `Map Api` a consumer holds. (REV-2 G.4.) + +- `baikai`: `Baikai.Header`, a new module exporting `HeaderName` with + `headerName` and `renderHeaderName`. See the `headers` retype under Changed. + +- `baikai`: `Baikai.Error.ErrorCategory` gains `ContentFiltered` (wire tag + `content_filtered`, never retryable) with the smart constructor + `contentFiltered`. OpenAI's `finish_reason: "content_filter"` and Anthropic's + `refusal` stop now carry it. Both used to be `OtherError`, so the only way to + tell a filtered response from any other non-retryable failure was to match on + the message text. __Breaking__ for a consumer whose `case` over + `ErrorCategory` is exhaustive without a wildcard. (REV-1 1.7 residual.) + +- `baikai` (breaking to construct, not to read): every record that can still + grow a field is now built from an exported base value and refined by record + update, and its constructor is no longer exported — + `Baikai.Provider.Registry.ApiProvider` (`apiProvider` /`apiProviderWith`), + `Baikai.Evidence.ModelCallEvidence` (`baseEvidence`), + `Baikai.Evidence.EvidenceRequest` (`evidenceRequest`), `Baikai.Tool.Tool` + (`mkTool`, with `emptyTool` kept for fixtures), + `Baikai.Embedding.EmbeddingModel` (`emptyEmbeddingModel`), + `Baikai.Cost.Log.CallLogConfig` (`callLogConfig`), + `baikai-trace-otel`'s `OtelSinkOptions` (`defaultOtelSinkOptions`), and + `baikai-agent`'s `AgentCliOptions` (`agentCliOptions`), `AgentCliRun` + (`agentCliRun`), `AgentJob` (`agentJob`) and `AgentConfigPaths` + (`emptyAgentConfigPaths`). Selectors, record update, `OverloadedRecordDot` + reads and generic-lens labels all keep working; only construction from the + constructor stops. Adding `describeThinking` to `ApiProvider` in 0.5.0.0 broke + every third-party registration site, and `strengthCeiling` would have broken + them again; from this release such an addition is a minor bump. (REV-2 G.1.) + +- `baikai`: `Baikai.Provider.apiProvider`, which builds an `ApiProvider` from an + `Api` tag and a streaming producer, deriving `complete` with + `streamingComplete`; and `Baikai.Provider.Registry.apiProviderWith`, which + takes the completer explicitly. Both default `describeThinking` to + "nothing requested, nothing translated" and `strengthCeiling` to + `EvidenceRequestedOnly`, matching `declaredStrength (Custom _)`. + +- `baikai`: `Baikai.Tool.mkTool` — a tool from its name, description and JSON + Schema. A tool built from `emptyTool` and sent unchanged reaches the wire with + `input_schema: null`; `mkTool` has no such shape. + +- `baikai`: `Baikai.Agent.AgentOutputFormat` (`TextFormat`, `JsonFormat`) with + `renderAgentOutputFormat` and `parseAgentOutputFormat`, and + `AgentRunRequest.outputFormat`, defaulting to `TextFormat`. `baikai-claude` + renders `--output-format json` and `baikai-openai` renders `--json`, both + right after the effort flags; `baikai-agent` reads it from + `jobs..output-format`. This is the one setting an evidence record needs + in order to observe a run's session, model and usage, and asking for it used + to require the `provider-args` channel that an operator ceiling closes by + default — an operator should not have to open a privileged channel to get a + record. (REV-2 F.14.) + +- `baikai`: `Baikai.Agent.AgentCeiling` gains three fields and the module gains + the vocabulary they need. `allowedTools :: [Text]` names tool grants the + operator permits beyond the ones `toolGrantsImpliedBy` (also new) says a + capability implies on its own; `maxTimeout :: Maybe NominalDiffTime` and + `maxOutputLimit :: Maybe Int` bound what any job may request, the second + defaulting to the new `defaultMaxOutputLimit` (67108864, sixty-four + mebibytes). `Baikai.Agent.ceilingViolations` is `applyAgentCeiling`'s violation + list on its own, so a caller can concatenate it with violations of its own. + (REV-2 F.3.) + +- `baikai`: `Baikai.Content.toolArgumentsFromText` and + `Baikai.Content.isCutOffToolCall`. The first is the single rule that turns a + tool call's accumulated argument text into its `arguments` value — empty text + is an empty object, non-empty text that does not decode is kept verbatim as a + `String` — and both provider assemblers and core's stream-recovery path now + use it, so the second means the same thing at every layer. + +- `baikai`: new exposed module `Baikai.Provider.Internal.StreamWorker` — the + bounded hand-off both HTTP providers now use between their SSE worker thread + and the consumer draining the stream. `FrameQueue` is a 64-slot `TBQueue` plus + a closed flag; `forkFrameWorker` closes the queue however the body ends, and + `withFrameWorker` runs the consumer under `Stream.bracketIO` so the worker is + killed when the stream stops. The module is exposed like + `Baikai.Provider.Cli.Internal`, outside the PVP promise. See + [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md). + +- `baikai`: every Anthropic model in the generated catalog now carries an + explicit `CompatAnthropicMessages` record stating the two request-shaping + facts of its generation: `AnthropicMessagesCompat.thinkingStyle` (which + extended-thinking wire shape it accepts) and the new + `AnthropicMessagesCompat.supportsSamplingParameters` (whether it accepts + `temperature`, `top_p` and `top_k`). Both are sourced from + `baikai/data/models/anthropic.json`, which the fetcher writes from its + curated `anthropicInclude` table, and `baikai-gen-models` now refuses an + `anthropic-messages` entry that reaches it without a `compat` block rather + than falling back to host auto-detection, which cannot know a generation. + This is what fixes `claude-sonnet-5`, whose thinking requests were shaped by + a prefix table that did not know the id. See + [docs/adr/0009](docs/adr/0009-provider-capability-facts-live-in-the-generated-catalog-record.md). + +- `baikai`: two new `Baikai.Evidence.ThinkingAdjustment` constructors, + `SamplingDroppedUnsupportedModel` and `SamplingDroppedUnsupportedApi`, encoding as + `{"kind":"sampling_dropped_unsupported_model","fields":["temperature","top_p"]}` and + `{"kind":"sampling_dropped_unsupported_api","fields":["seed"]}`. They record sampling + parameters removed because the model generation rejects them, or because the API has no + such field on any generation. Both carry a `fields` array and no `requested` level, so + they can appear on a call whose thinking mode is `absent`. + +- `baikai`: `Baikai.Evidence.weakensThinking`, which says whether an adjustment weakens the + thinking the caller asked for. Strict evidence mode filters through it, so a dropped + sampling parameter is recorded without refusing the call — the documented contract is + refusing a call that would weaken the requested *thinking level*. + +- `baikai`: new exposed module `Baikai.Url` — the one place baikai turns a URL + into a host name. `parseUrl` yields a `UrlParts` record with the scheme, host, + port and path, plus flags saying whether userinfo, a query string or a + fragment were present; it never holds their text, so the value cannot carry a + secret into a log line. Alongside it: `urlHost`, `hostMatchesSuffix` (moved + from `Baikai.Compat`, which now re-exports both), `renderEndpoint`, + `stripApiVersion`, and `baseUrlProblem`, which says why a URL is unusable as a + `Model.baseUrl` and what to do instead. See + [docs/adr/0008](docs/adr/0008-one-url-host-parser-and-every-consumer-uses-it.md). + +- `baikai`: new exposed module `Baikai.Provider.Transport.Classify` — the one + rule every HTTP provider uses to classify a transport failure, exporting + `classifyTransportException` plus the per-type functions it composes. The rule + is *where* the failure happened, not what type it is: anything that breaks or + ends the connection after the request went out is `TransientError`, anything + that says the request or the configuration is wrong is not retryable, and a + programming error stays `OtherError`. It understands all three shapes + `http-client` can deliver — an `HttpException` of any constructor, a raw socket + `IOException`, and a raw or wrapped `TLSException` — because the manager wraps + the connect phase but not the body reader. Core gains direct `build-depends` on + `http-types` and `tls`, both already in its install plan. Written for + third-party `Custom` providers built on `http-client` as much as for baikai's + own two. See + [docs/adr/0011](docs/adr/0011-core-owns-transport-failure-classification.md). + +- `baikai`: `Baikai.Error.parseHttpDate` and `Baikai.Error.retryAfterSecondsAt`. + The first parses an HTTP-date in the IMF-fixdate form servers must send plus + the two obsolete forms a recipient must accept; the second converts a + `Retry-After` header in either of its forms to seconds against a reference + instant, clamping a date already in the past to `0`. + `parseRetryAfterSeconds` keeps its integer-only contract, now a deliberate + division of labour rather than a limitation. + +- `baikai`: new exposed module `Baikai.Http` — `canonicalBaseUrl`, + `getClientEnvCached` and `cachedClientEnvCount`, the process-global + `ClientEnv` cache that both HTTP provider packages now share instead of each + keeping its own. Core gains direct `build-depends` on `servant-client`, + `http-client` and `http-client-tls`, which were already in its install plan + through the `openai` SDK. + +- `baikai`: `Baikai.Evidence.ThinkingModeNotTranslated`, encoded as + `"not_translated"`, and `Baikai.Evidence.untranslatedThinking`; and + `Baikai.Evidence.Build.requestedTranslation`. A path where no adapter ran to + translate the caller's level now records the level and says the translation is + unknown, instead of saying nothing was asked. (REV-2 D.2.) + +- `baikai`: `Baikai.Evidence.Build.missingEvidenceError`, + `Baikai.Evidence.Build.strictnessOf` (moved here from `Baikai.Trace`, where it + was private), `Baikai.Stream.requireEvidenceOnTerminal` and + `Baikai.Provider.Registry.requireEvidenceOnResponse`. (REV-2 D.3.) + +- `baikai`: `Baikai.Evidence.usageEnvelope`, and + `Baikai.Evidence.Build.endpointIdentityAt`, `prepareEvidenceAt` and + `minimalEvidenceAt`, which take the base URL the adapter actually resolved. + The three unsuffixed functions remain and pass the model's own field. + (REV-2 D.8, D.11.) + +- `baikai`: `Baikai.Evidence.deriveStrength`, the single rule that turns an + observed model, a provider request id and a response id into an + `EvidenceStrength`. (REV-2 D.10.) + +### Changed + +- `baikai`: catalog refresh. `claude-opus-5` joins the curated Anthropic include + set (adaptive thinking, sampling parameters rejected — the facts + `docs/plans/60-make-anthropic-thinking-style-and-sampling-support-catalog-driven.md` + said whoever curated it in would have to state), and the `gpt-5.6` family + picks up its price cut: `gpt-5.6` and `gpt-5.6-sol` to $4.00/$20.00, + `gpt-5.6-terra` to $2.00/$12.00, `gpt-5.6-luna` to $0.20/$1.20 per Mtok, cache + rates in step. `Baikai.Models.Generated` gains `anthropic_claude_opus_5` and + now carries 36 enabled models. No OpenAI id was added: the `gpt-5.6` family is + still the newest one models.dev reports that speaks + `openai-chat-completions`. + +- `baikai` (breaking): `ResponseFormat`'s `JsonSchema` carries a + `JsonSchemaFormat` record — `name`, `schema`, `strict`, exported + selector-only with the base `jsonSchemaFormat name schema` — instead of + holding the three fields directly. As fields of a sum they were partial + selectors: `name f` on a `JsonObject` crashed at runtime rather than failing to + typecheck, which contradicted the module's own documentation. + `-Wno-partial-fields` is dropped from the module. The JSON encoding is + deliberately unchanged (`{"tag":"JsonSchema","name":…,"schema":…,"strict":…}`) + and is now pinned by a test, because `Options` derives `ToJSON` through it and + at least one consumer keys a cache on the result. (REV-2 G.2.) + +- `baikai`: `Baikai.Context.appendToolResult` returns its input context + unchanged, and runs no dispatcher, when the response is error-shaped. A failed + call has no assistant turn worth replaying and no tool calls to answer; + appending its empty message put a turn into the transcript the model never + took. `runToolLoop` has always stopped on such a response — the documented + direct round trip in `docs/user/tools.md` reaches `appendToolResult` instead, + and now behaves the same way. Its Haddock also stops claiming multi-call + concurrency lives in the dispatcher: the calls are traversed in order. + (REV-2 G.7.) + +- Release metadata (REV-2 G.8): every publishable package now declares + `tested-with: GHC ==9.12.4` and ships its `CHANGELOG.md` (a symlink to the + root one, as `baikai` already did) via `extra-doc-files`, so Hackage shows a + changelog and a tested compiler for all seven. `baikai-claude` and + `baikai-openai` describe what they actually contain — four surfaces each, not + "wraps package X" — and `baikai-trace-otel`'s `streamly-core` bound is + `>=0.3 && <0.5`, matching every other package in the workspace rather than + excluding the 0.4 series the others accept. + +- `baikai` (breaking): `Options.headers` and `Model.headers` are keyed on + `Baikai.Header.HeaderName` — a newtype over a case-insensitive `CI Text` that + keeps the original spelling — instead of `Text`. A header name is + case-insensitive on the wire, so a `Map Text Text` holding both + `Authorization` and `authorization` sent whichever the assembling fold reached + last; the map now holds one entry per header and the last write wins, as a + caller writing two spellings would expect. `HeaderName` has an `IsString` + instance, so `Map.singleton "x-test" "1"` and `#headers` updates keep + compiling; the spelling given is what goes out on the wire and into JSON. + (REV-2 G.5.) + +- `baikai` (breaking): `Options.stopSequences` is `[Text]`, where empty means + "send nothing", instead of `Maybe (Vector Text)` — `Nothing` and `Just []` + were indistinguishable on the wire and only one of them could be right. Plan + 43's rule is lists for caller-side configuration and `Vector` for + provider-bound sequences; this was the one field breaking it. `Options.seed` + is `Maybe Int` rather than `Maybe Integer`: a seed is a machine integer at + every provider that accepts one, and it now sits beside + `timeoutMs :: Maybe Int`. (REV-2 G.5, R14.) + +- `baikai` (breaking): `StopReason.Aborted` is removed. Nothing produced it — + timeouts are `ErrorReason`/`TransientError`, and a consumer abort is recorded + as evidence `CallAborted` — while `responseError`, `eventsFor` and + `runToolLoop` all treated it as a *success*, so a value that reached any of + them would have been silently mishandled. Since 0.6.0.0 a stream consumer that + stops cancels the producer, so no consumer is left to receive such a terminal + either. (REV-2 B.6.) + +- `baikai`: dispatching a model whose `api` is still `emptyModel`'s + `Custom ""` says so — `No provider registered for API: ` — where the message used to end after the + colon. `emptyModel`'s Haddock says the same thing. (REV-2 G.4.) + +- `baikai`: `withTrace` and `withTraceStream` wait at most one second for the + trace sink after writing the shutdown sentinel. On expiry the worker is + abandoned — not killed, which would abort the sink's fold mid-step and lose + its end-of-stream action — the call proceeds, and one stderr line reports + `the trace sink did not confirm delivery within 1000 ms; its worker was + abandoned, and events already queued may still be delivered later`. A sink + that blocked forever used to hold the call forever and swallow the first + attempt to cancel it. A caller under `EvidenceRequired` whose sink did not + confirm delivery gets a failed call, through the same path a throwing sink + takes; `Baikai.Evidence.Build.sinkFailureError` now says "its record was not + confirmed written" rather than "not written", which is the honest claim for + an abandoned worker whose events are still queued. The synthetic terminal a + consumer's abort produces is delivered from a garbage-collection hook and is + not guaranteed before process exit; that was always true and is now stated in + `docs/user/model-call-evidence.md`, `docs/capabilities/call-tracing.md` and + the `Baikai.Trace` module documentation, with the pattern for callers who need + the record. See + [docs/adr/0015](docs/adr/0015-trace-cleanup-is-bounded-and-abort-cleanup-is-gc-eventual.md). + (REV-2 D.5, Theme 7.3.) + +- `baikai`: `Baikai.Trace.Sink.multiSink` runs each member on its own drain + thread behind its own unbounded channel, instead of folding `Fold.tee` across + the list. `Fold.tee` runs one member then the other and lets either's + exception escape, so a single throwing member stopped delivery to every + sibling for the rest of the call and skipped their end-of-stream actions — an + OpenTelemetry span paired with an unwritable file sink was opened and never + ended, and nothing was exported. The step never blocks; the final action sends + every member the sentinel, waits for every member, and reports one aggregate + failure naming each failed member by zero-based index + (`1 of 2 member sinks failed: member 0: …`). (REV-2 D.6.) + +- `baikai`: `AgentSafety.allowedTools` is documented as the __grant__ it is. + On Claude Code it renders `--allowedTools`, whose help reads "list of tool + names to allow": it pre-approves tools the permission mode would otherwise + raise a request for, and in an unattended run a request nobody answers is + denied. The old Haddock called it "optional narrowing of the provider's tool + set", which was the opposite, and `applyAgentCeiling` never looked at it. It + is now bounded: a grant passes when the maximum capability implies it + (`read-only` implies `Read`, `Glob`, `Grep`, `NotebookRead`, `TodoWrite`; + `edit-workspace` adds `Edit`, `MultiEdit`, `Write`, `NotebookEdit`; + `full-access` implies every grant) or when the operator named it in + `policy.allowed-tools`. Matching is exact, so `Bash(git *)` is not `Bash`. + A repository job that grants itself `Bash` under `edit-workspace` — which + passed unexamined before — is now refused with exit 77 before any process is + created. (REV-2 F.3.) + +- `baikai` (breaking): `Baikai.Agent.CeilingViolation` gains five constructors: + `ToolGrantForbidden`, `TimeoutExceeded`, `OutputLimitExceeded`, + `RepositoryScopeForbidden` and `WorkingDirOutsideRepository`. A `case` over + the type that was exhaustive is no longer. + +- `baikai` (behaviour): the default ceiling has a finite `maxOutputLimit`, so + `applyAgentCeiling defaultAgentCeiling` now refuses a request whose + `outputLimit` is `Nothing` — capture without bound is exactly what the + maximum exists to refuse. Jobs resolved through `baikai-agent` are unaffected: + that layer's own default supplies a finite limit, and only an explicit + `output-limit "unlimited"` reaches the ceiling as `Nothing`. + +- `baikai`: a tool call cut off by the output cap is no longer executed. + `runToolLoop` stops with the response and its tool calls intact when any call + is cut off, and `appendToolResult` appends a `ToolResultMessage` with + `isError = True` explaining why instead of calling the dispatcher. Previously + both assemblers replaced truncated arguments with `{}` and a tool loop + happily ran the call with no arguments at all. (REV-2 B.2.) + +- `baikai`: `Baikai.Model.anthropicMessagesCompatFor` no longer overlays a + thinking style guessed from the model id onto a model whose `compat` is + `CompatNone`. `CompatNone` now means host auto-detection alone — the budget + thinking shape, sampling parameters supported. Every catalog model carries an + explicit record, so this changes nothing for them; a **hand-rolled** model + naming an adaptive-era id (`claude-sonnet-5`, `claude-opus-4-7`, + `claude-opus-4-8`, `claude-fable-5`) must now carry + `CompatAnthropicMessages (defaultAnthropicMessagesCompat {thinkingStyle = AnthropicThinkingAdaptive, supportsSamplingParameters = False})` + or start from the catalog value. + +- `baikai`: `Baikai.Evidence.evidenceSchemaVersion` is now + `baikai.model-call-evidence/1.1`. A minor bump: the two sampling adjustment kinds are a + compatible addition, and no previously recorded digest changes. + +- `baikai`: HTTP 413 classifies as `ContextOverflow` rather than `OtherError`, + from the status alone and whatever the body says. 413 *is* the size-limit + status and the caller's remedy — shrink the input — is the same either way; + making the category depend on body wording would recreate for 413 the + inconsistency this release fixes for connection resets. (REV-2 A.7.) + +- `baikai`, `baikai-claude`, `baikai-openai`: an HTTP-date `Retry-After` is + converted to seconds instead of ignored. Both transports use the response's own + `Date` header as the reference instant, falling back to the local clock, so a + CDN-fronted `429` — the common case for a date-valued `Retry-After` — now + carries a hint rather than leaving the caller to guess. (REV-2 A.9.) + +- `baikai`: **breaking.** `Baikai.Embedding.EmbeddingModel.apiKey` is now + `Maybe ApiKeySource` rather than `ApiKeySource`. `Nothing` means the + conventional environment variable for the model's host, from + `defaultApiKeyEnvForBaseUrl` — the same table the chat providers use — and a + host that table does not know refuses with an `AuthError` naming + `EmbeddingModel.apiKey`. Migration: `apiKey = source` becomes + `apiKey = Just source`. `EmbeddingModel` also derives `Eq` and `Generic`, so + the `#field .~ value` idiom works on it as it does on every other record. + (REV-2 E.3.) + +- `baikai`: **breaking.** `AgentRunFailure`'s `RunTimedOut` constructor now + carries a new record `AgentTimedOut` — the configured `limit` plus the + `stdout` and `stderr` a timed-out run drained before its process group was + killed — instead of a bare `NominalDiffTime`. A caller matching + `RunTimedOut limit` becomes `RunTimedOut timedOut` and reads `timedOut ^. + #limit`; `renderAgentRunFailure` is unchanged in what it says. The bytes were + always there, drained from the moment the child was spawned, and were simply + dropped on the timeout path — which is the run an operator most wants an + account of, because the tool started, may have consumed tokens, and may + already have changed the working tree. + +- `baikai`: under `EvidenceRequired`, a successful terminal that carries no + evidence record fails the call with `missingEvidenceError` rather than + returning a silent success with zero `call_evidence` lines. Strict mode + guaranteed that a record which was built and then lost fails the call; it did + not guarantee that one was built. The rule is applied at both dispatch points, + so `completeRequest` with no sink gets the same guarantee as a streaming call; + a failed call keeps the provider's own error, and best effort is unchanged. + See `docs/adr/0014-strict-evidence-means-a-record-exists.md`. (REV-2 D.3.) + +- `baikai`: a caller's thinking level is recorded on every evidence path — the + consumer abort, an unregistered provider, a `complete` handler that threw, and + each provider's `immediateError`. The abort path asks the registered adapter's + own `describeThinking`; the others record `not_translated`. All four used to + record the caller's request as `absent`, which + `docs/adr/0002-requested-translated-observed-are-never-collapsed.md` forbids. + (REV-2 D.2.) + +- **`baikai.model-call-evidence/2.0`.** Two digests cover different bytes, so a + verifier must now select its rules by `schema_version`. `response_commitment` + covers the provider-reported token counts and never baikai's computed cost: + the cost comes from the caller's catalog rates rather than from the response, + so the digest used to change whenever a price was edited and a verifier + holding only the response could not recompute it. `request_configuration` + summarises `output_config` and `response_format` as it already summarised + `tools`, because a structured-output JSON schema carries author-written + `description` strings and is content wherever it appears — the same schema was + stripped from `tools[].input_schema` and survived verbatim through the other + two keys. `thinking.mode` may also now be `"not_translated"`, which is a + compatible addition. (REV-2 D.7, D.11.) + +- **Breaking.** `baikai`: `Baikai.Provider.Registry.ApiProvider` gains a fifth + field, `strengthCeiling :: EvidenceStrength`, and + `Baikai.Evidence.Build.checkEvidenceRequirements` takes that ceiling where it + took an `Api`. The gate compared against `declaredStrength`, a table keyed by + the API tag, which necessarily answered `EvidenceRequestedOnly` for every + `Custom` transport — so a gateway that genuinely observes a model could never + satisfy a strict caller who required that it did. Only a provider knows what + its evidence reaches. `EvidenceRequestedOnly` reproduces the old behaviour for + any custom provider; the four built-in providers fill the field from + `declaredStrength`, which is unchanged in value and still used by the + unattended-agent surface. (REV-2 D.10, G.1.) + +- `baikai`, `baikai-claude`, `baikai-openai`: one strength derivation replaces + three. An observed **response id** now counts as correlation alongside a + captured request-id header, so a host that names its model and its response id + on every chunk but sends no header reaches `model_observed` instead of + `requested_only` — which had put it *below* a host that sent only a header and + named nothing. `anthropicStrength` and `openaiStrength` are removed; + `Baikai.Provider.Cli.Internal.subprocessStrength` keeps its signature and + delegates. (REV-2 D.10.) + +### Removed + +- `baikai` **0.6.0.0** (breaking): the sixteen `_Type` base-value aliases deprecated in + 0.3.0.0 — `_Options`, `_Context`, `_Model`, `_ModelCost`, `_Response`, + `_Usage`, `_Cost`, `_CostBreakdown`, `_Tool`, `_TextContent`, + `_ThinkingContent`, `_ToolCall`, `_ImageContent`, `_EmbeddingModel`, + `_InteractiveLaunchRequest` and `_InteractiveLaunchResult`. Each has an + `empty…` or `zero…` replacement of the same value, named in the pragma that + has been on it since 0.3.0.0. The 0.3.0.0 entry said they remained "for this + release"; 0.4.0.0 and 0.5.0.0 shipped without removing them because no entry + named a version. + `docs/adr/0016-deprecated-names-are-removed-at-the-next-major.md` now fixes + the rule: a name deprecated in `A.B.0.0` is removed in `A.(B+1).0.0`, and + every pragma says so. (REV-2 G.3.) + +- `baikai` **0.6.0.0** (breaking): `Baikai.Trace.newEventId`. It has delegated to + `Baikai.Evidence.newCallId` since 0.5.0.0; call that. (REV-2 G.3.) + +- `baikai` **0.6.0.0** (breaking): `Baikai.Compat.defaultAnthropicThinkingStyle`, deprecated + earlier in this cycle. Nothing in baikai consults it — the thinking style of a + first-party Anthropic model is a field of its generated catalog record + (`Baikai.Models.Generated`); start from that value, or set + `CompatAnthropicMessages` explicitly. + +- `baikai` (breaking): `AgentRunRequest.envPassthrough` is renamed `envRequires`. + The field is a list of variables the job declares it requires, checked as a + precondition; it has never passed anything through, and the KDL key has said + `env-requires` since the setting existed. + +- `baikai` (breaking): `AgentRunFailure.OutputMalformed`, and with it + `baikai-agent`'s exit code 70 and its `internalExitCode` export. Nothing ever + constructed the constructor, and giving it a producer would have been wrong: + the runner treats the tool's output as best-effort observation and its + deliverable is the changed working tree, so a run that edited files correctly + and then printed an unparseable final line would have been reported as a + failure with its exit code and output discarded. A record's `strength` and + `unobserved` fields already say when output could not be read. (REV-2 F.13.) + +### Fixed + +- `baikai`: the terminal event and its evidence record are pushed to the trace + sink exactly once under asynchronous exceptions. The terminal path pushed the + evidence record, pushed the terminal event and only then set the + already-sent flag; an exception delivered between the last two made the + stream finaliser read the flag as unset and push a second `CallEvidence` and + an `aborted` `CallFailed` after the real `CallFinished`, so a sink saw two + records and two contradictory terminals for one call. All three writes now + run inside one `uninterruptibleMask_` with the flag first. (REV-2 D.4.) + +- `baikai`: `Baikai.Cost.Log.closeCallLog` is idempotent. The first caller + claims the handle and waits for the worker; a second returns at once instead + of blocking forever on an `MVar` the worker had already emptied — a shape + `withCallLog` makes easy to reach, since its bracket closes a handle the body + may also have closed. An `appendEntry` after the close enqueues nothing. + +- `baikai`: `reassembleResponse` is total under duplicated, late and + timestamp-less input. The first `EventStart` wins the skeleton and + `responseId` merges with `<|>`, so a later `Nothing` cannot erase an id an + earlier event supplied; events after the first terminal are ignored, so a + producer that keeps talking cannot rewrite the answer; and `latencyMs` falls + back to the reassembler's own wall clock when neither the skeleton nor the + terminal carries a provider timestamp, instead of reporting a zero that reads + as "instant". (REV-2 B.7.) + +- `baikai`: an `EmbeddingModel` pointed at a non-OpenAI host no longer sends + `OPENAI_API_KEY` to it. The default key source was that variable whatever the + base URL said, so pointing the client at DeepSeek handed DeepSeek an OpenAI + credential. It now resolves per host, and refuses an unknown one. New + `resolveEmbeddingKey` and `embeddingClientEnv` expose both decisions without + making a request. (REV-2 E.3.) + +- `baikai`: `Baikai.Embedding.embed` no longer allocates a TLS manager per call. + It used the `openai` SDK's own `getClientEnv`, which builds a fresh manager + every time; it now takes one from `Baikai.Http`'s process-global cache, the + same one the chat providers use, so an embedding call and a chat call to one + host share a connection pool. + +- `baikai`: **a credential in a header is no longer printed.** `Options.headers` + and `Model.headers` went through derived `Show` and `ToJSON` instances that + rendered every value verbatim — while `Baikai.Options`' own documentation + invites callers to put a gateway's `Authorization` header there and the + getting-started guide tells them to `print resp`, which renders the embedded + `Model`. Both types now have hand-written instances that render exactly what + the derived ones did, except that the value of a header whose name looks + credential-carrying (`authorization`, `api-key`, `apikey`, `token`, `secret`, + `cookie`, `password`, or any name ending in `-key`, case-insensitively) prints + as ``. `Baikai.Auth` exports the three pieces — `redactedMarker`, + `isCredentialHeader`, `redactHeaderValues` — so a caller can apply the same + rule to its own logging. Only the rendering changes: the field is untouched, + `Eq` is untouched, and the header is still sent as written. A JSON round trip + of a `Model` is deliberately lossy, since a serialised `Model` is exactly the + thing that should not carry a key. (REV-2 E.2.) + +- `baikai`: an API-key environment variable set to the empty string, or to + nothing but whitespace, now counts as **unset**. `ApiKeyEnv` fails with an + `AuthError` naming the variable and saying it is not set or is empty; + `ApiKeyEnvChain` skips it and continues, and reports every name when none + yields a key. Previously an empty variable resolved to an empty key, which + short-circuited a chain and produced `Authorization: Bearer ` and a provider + 401 that said nothing about the cause. A key with real content is still passed + through untrimmed. (REV-2 E.6.) + +- `baikai`: **the host parse no longer lets a base URL choose which key baikai + sends.** `urlHost` took the text after the *last* `@` anywhere in a URL, so + `https://proxy.example.com/v1?u=@api.openai.com` named the host + `api.openai.com`: `defaultApiKeyEnvForBaseUrl` resolved `OPENAI_API_KEY`, + `autoDetectOpenAICompletions` returned OpenAI's own compatibility record, and + the bearer token went to `proxy.example.com`. Anyone who could set `baseUrl` — + a `Model` decoded from JSON, a proxy override — could pick which provider's + credential to be handed. The same defect broke the benign direction: + `https://api.openai.com/v1/@x` named the host `x` and resolved no key at all. + The authority now ends at the first `/`, `?` or `#`, and userinfo is only ever + the last `@` inside it. (REV-2 A.1 / E.1.) + +- `baikai`: `Baikai.Evidence.Build.sanitizeEndpoint` was a second, separately + written parser that bounded the authority at the first `/` only, so a URL with + a query and no path recorded the wrong host. It is now `renderEndpoint <$> + parseUrl`, which also means a recorded endpoint has a lower-cased scheme and + host; the path keeps its case and trailing slash. + +- `baikai`: `parseCodexJsonlStream` assembles lines in **linear time**. It + previously unpacked every chunk into a stream of bytes and appended them one + at a time with `BS.snoc`, copying the whole accumulator per byte — quadratic + in line length, so one codex event carrying a two-million-character message + cost on the order of a trillion byte moves and in practice never finished. + Lines are now cut out of each chunk with `BS.elemIndex` and `BS.splitAt`, and + the pieces of a line that spans a chunk boundary are joined once. Behaviour is + unchanged: a non-JSON line is still skipped, and a last line without a + trailing newline is still parsed. + +- `baikai`: a Codex custom agent's instructions body renders as a TOML + **literal** multi-line string (`'''`), which interprets nothing, instead of a + basic one (`"""`), which interprets backslash escapes. As a basic string an + instruction as ordinary as "match `\d+`" made Codex refuse to load the file; + `tomllib` rejects the old output with `Unescaped '\' in a string`. A body a + literal string cannot hold — one containing three apostrophes, a bare carriage + return, or a control character other than tab and newline — falls back to a + fully escaped basic string. `tomlString`, which renders `name` and + `description`, now escapes every control character as TOML 1.0 requires + instead of only the five it happened to name. + +- Documentation: `baikai`'s Haddock no longer describes behaviour the code left + behind. The trace event's token counts are `Maybe` because a non-assistant + terminal has no usage, not because the CLI providers report nothing — since + 0.5.0.0 both carry what the tool reported. `EventStart`'s `partial` is a + message skeleton with empty content, zero usage and no stop reason; the api, + provider and model id live on the `Response`. A lifted stream's `EventStart` + carries the final usage and stop reason already filled in, because the + response is complete before the stream begins. `Baikai.CacheRetention` no + longer mentions an OpenAI Responses 24-hour bucket no code emits. System + prompts are documented as living on `Context.systemPrompt` rather than on a + `Baikai.Request` module that no longer exists, `emptyModel`'s `compat` is + described as auto-detection rather than a placeholder, tool dispatch says + calls run one at a time in order, and every reference to a plan number is + gone. (REV-2 H.4.) + +## [baikai-claude 0.6.0.0] - 2026-08-28 + +### Added + +- `baikai-claude`: `Baikai.Provider.Claude.Internal.Request` exports `planRequest`, + `SamplingPlan`, `uncappedMaxTokensFloor` and `normalizeToolCallId` as test seams. + `planThinking` and `describeThinkingFor` are now projections of `planRequest`, so the + strict gate, the request builder and the evidence record read one answer. + +### Changed + +- `baikai-claude`, `baikai-openai` (breaking): each provider's streaming + machinery moved from `Baikai.Provider.

.Api` to + `Baikai.Provider.

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

StreamWith`, `Assembler`, `emptyAssembler`, `translate`, and on the OpenAI + side `RawChunk`, `RawToolDelta`, `parseChunk`, `parseFrame`, `TagScanState`, + `scanThinkTags`, `closeOpenStream`, `RawUsage`, `parseUsage` and + `rawUsageToUsage`. `Api` now exports exactly `register`, the provider value + and the live stream function. The `.Internal` module is exposed for the test + suites and sibling packages and, like every `.Internal` module, may change in + any release without a major bump — so changing the assembler stops being a + documented break. `Shape`, `Sse` and `Transport` keep their names and gain the + same no-guarantees header. `_TagScanState` is renamed `emptyTagScanState`. + (REV-2 G.1.) + +- `baikai-claude`, `baikai-openai`: a consumer that stops reading now stops the + provider. Both packages fork their SSE worker under `Stream.bracketIO` and + hand frames through the bounded `FrameQueue` above instead of an unbounded + `Chan`. A consumer that cancels — `Ctrl-C`, `System.Timeout.timeout`, + `cancel` — releases the HTTP connection immediately; a consumer that abandons + the stream (`Stream.take 3`) stops the socket read within 64 further frames + and releases the connection at the next major garbage collection. Previously + the worker read the entire generation into memory for a consumer that would + never look at it, and the provider billed all of it. The three cleanup + strengths are stated in + [docs/adr/0010](docs/adr/0010-a-stream-consumer-that-stops-owns-cancelling-the-producer.md) + and in caller terms in `docs/user/streaming.md`. + +- `baikai-claude`: `anthropic_claude_sonnet_4_6` now sends the adaptive + thinking shape rather than `budget_tokens`. The budget shape is deprecated + for that generation; baikai sends the shape Anthropic documents as current. + +- `baikai-claude`, `baikai-openai`: **behaviour change.** `Options.timeoutMs` of + `Just n` with `n <= 0` is refused as `InvalidRequest` before the action runs, so + no connection is opened. `System.Timeout.timeout` returns immediately at zero + and runs unbounded below it, and the previous `max 0` clamp made both spellings + fail instantly as a *retryable* `TransientError` — a classification a caller's + retry loop re-issues forever for what is a configuration mistake. `Nothing` + remains the only spelling of "no bound". (REV-2 A.10.) + +- `baikai-claude`, `baikai-openai`: an evidence record's `endpoint` names the + host the call actually went to. Both adapters substitute a vendor default for + an empty `Model.baseUrl` inside `prepareCall`, so a call with a perfectly + definite destination recorded `endpoint: null`. Where no adapter ran, `null` + remains the truthful answer. (REV-2 D.8.) + +- `baikai-claude`: the `claude` dependency moves from `^>=1.4` to `^>=1.5`. + 1.5.0 adds a `Pause_Turn` constructor to `Claude.V1.Messages.StopReason`, and + `mapStopReason` matches that type with no wildcard under + `-Werror=incomplete-patterns`, so the bump forced a decision. A paused turn + maps to `Stop`: Anthropic suspends the turn mid-flight for a long-running + server-side tool and expects the caller to send the message back to continue + it, so nothing failed, and `Baikai.StopReason` has no constructor that says + "resume me". Widening that public sum is a breaking change for every consumer + who matches on it exhaustively, and it is not this bump's to make. The general + rule is + [ADR 0018](docs/adr/0018-a-provider-stop-reason-with-no-baikai-equivalent-maps-to-the-nearest-truthful-one.md): + a provider stop reason with no baikai equivalent maps to the constructor that + is truthful about whether the call failed, and the sum widens only when baikai + would behave differently for it. + +- `baikai-claude`: `Messages.StreamUsage` lost its `Generic` instance in `claude` + 1.5.0, so the `message_delta` usage is read through `OverloadedRecordDot` + rather than a generic-lens label. `Messages.max_tokens` and + `Messages.output_config` became ambiguous selectors — `Messages.Fallback` + carries both names — so the provider's tests read them through `^. #max_tokens` + and `^. #output_config` instead. + +### Removed + +- `baikai-claude`, `baikai-openai` **0.6.0.0** (breaking): the eight registration shims — + `registerWith`, `registerWithRegistry` and `registerWithRegistryAndConfig` in + both `Cli` modules, and `registerWithRegistry` in both `Api` modules. Register + the exported provider value instead: + `registerApiProvider (claudeCliProvider cfg)`, + `registerApiProviderWith reg (codexCliProvider cfg)`, + `registerApiProviderWith reg claudeMessagesProvider`. The batch-mode note that + had accumulated on `registerWith` — why `complete` stays on the direct path + rather than going through `streamingComplete` — moves to the provider value it + describes. (REV-2 G.3.) + +- `baikai-claude`, `baikai-openai`: `responseToError` and `classifyErrorText` + (and its private `classifySdkHttpText` half) from both + `.Internal.ErrorClass` modules. Neither package runs a `servant-client` client + on the chat path any more, so the `ClientError` branch was unreachable, and the + text classifiers parsed a string shape the local SSE transports stopped + producing in July. The phrase table `classifyErrorText` held survives as the + message fallback inside `classifyErrorFrame`, pinned through the entry point the + runtime actually uses. Both modules are documented as outside the PVP-stable + surface, so this is not a major bump; version bumps are recorded once, later. + +- **Breaking.** `baikai-claude`: `Baikai.Provider.Claude.Api.anthropicStrength` + and `baikai-openai`: `Baikai.Provider.OpenAI.Api.openaiStrength`, both replaced + by `Baikai.Evidence.deriveStrength`. + +### Fixed + +- `baikai-claude`, `baikai-openai`: a failure that lands while the response body + is streaming is classified as the transient failure it is. A connection reset, + a server closing the socket mid-chunk, a body shorter than its declared length + and a TLS session torn down after the handshake all now terminate the stream + with `TransientError` and `isRetryable = True`, carrying whatever text had + already been drained. Every one of them used to be `OtherError` with + `isRetryable = False`, while the identical failure at connect time was + transient — because `http-client` wraps the connect phase with the manager's + exception wrapper and the body reader with nothing that converts a socket + `IOException` or a `TLSException`, so those reached the worker raw and missed + the `HttpException` branch entirely. (REV-2 A.2.) + +- `baikai-claude`, `baikai-openai`: a transport failure mid-stream now closes + the blocks that were open when it arrived, on both providers, so a consumer + reading raw events and a consumer reassembling them see the same partial + output. Both providers built their terminal from the closed blocks alone and + silently dropped open text, thinking and tool arguments. On the Claude side + this covers `translate (Left …)`, the in-band `error` frame, and the + unexpected end of stream. (REV-2 B.3.) + +- `baikai-claude`: an SSE frame whose event `type` — or whose + `content_block_delta` `delta.type` — the SDK has no constructor for is now + skipped instead of ending the stream with a decode error. The SDK decodes both + with no unknown-tag fallback, so a new frame type from Anthropic used to be a + terminal fault. A frame of a *known* type that still fails to decode remains + one. `Baikai.Provider.Claude.Sse` exports the new `decodeFrame`. (REV-2 B.5.) + +- `baikai-claude`, `baikai-openai`: an empty `data:` heartbeat is ignored, and + on the OpenAI side `[DONE]` is compared after trailing whitespace is trimmed, + so `data: [DONE] ` and `data: [DONE]\r` end the stream rather than failing to + decode. (REV-2 A.8.) + +- `baikai-claude`: every failing stream now begins with `EventStart`. The + producer pre-seeds the start event before the first wire read, exactly as the + OpenAI producer already did, and `message_start` updates the assembler without + emitting a second one. Previously a 401, a rate limit, an in-band `error` + frame or an EOF arriving before `message_start` produced a lone `EventError`, + breaking the protocol `Baikai.Stream.Event` documents. `StartPayload.responseId` + is consequently `Nothing` on both HTTP providers; the provider's message id + rides `TerminalPayload.responseId`, which `reassembleResponse` already prefers. + (REV-2 A.4, REV-1 Theme 1.1.) + +- `baikai-claude`, `baikai-openai`: an asynchronous exception delivered to the + stream worker can no longer strand its consumer. End-of-frames is a flag set + by the worker fork's own `finally` rather than a sentinel value pushed onto + the channel, so a worker that dies without running its normal exit path still + ends the stream in an `EventError`. Previously the consumer blocked until the + runtime's deadlock detector noticed. + +- `baikai-smoke`: two keyed cases against `claude-sonnet-5` — one asking for + thinking (which is a 400 before this release) and one setting `temperature` — plus + `deepseek-chat` and `openrouter/openai/gpt-4o-mini` in `apiCases`, so the tool and + structured-output smokes run against a compatible host that is not OpenAI. + `CompatSmoke` now asserts DeepSeek honoured the output cap rather than only that it + answered, and `CacheSmoke` asserts the cached token classes cost something. + +- `baikai-claude`: a thinking request on `claude-sonnet-5` no longer 400s. It sends + `"thinking":{"type":"adaptive"}` and no `budget_tokens`, because the shape is read off + the model's catalog record rather than guessed from its id. (REV-2 C.1.) + +- `baikai-claude`: `temperature` and `top_p` are no longer sent to a model generation that + rejects them with a 400. They are omitted and the omission is recorded as + `sampling_dropped_unsupported_model` in the call's evidence. `seed`, `frequencyPenalty` + and `presencePenalty`, which the Anthropic Messages API has no field for on any + generation, are recorded as `sampling_dropped_unsupported_api`. (REV-2 C.1, C.5.) + +- `baikai-claude`: a model whose `maxOutputTokens` is `0` no longer sends + `"max_tokens":0`, which Anthropic rejects — and, with thinking set, no longer had its + whole thinking plan discarded for not fitting inside a ceiling of zero. It sends + `uncappedMaxTokensFloor` (1024, the SDK's own default) instead. An explicit + `maxTokens = Just 0` is still forwarded as written. (REV-2 C.2.) + +- `baikai-claude`: replay no longer sends an empty text block or an empty `content` array, + both of which Anthropic rejects. An empty text block is dropped; an assistant turn left + with nothing is dropped whole (it is baikai's own artifact — a block that closed with no + deltas, or only unsigned thinking, which replay already omits); a user turn left with + nothing is refused locally with a message naming the turn. (REV-2 C.3.) + +- `baikai-claude`: tool-call ids that differ only in characters the alphabet forbids, or + only past character 64, no longer normalise onto the same id and misroute a tool result. + A conforming id passes through unchanged — every id Anthropic and OpenAI actually mint + does — and any other is truncated to 51 characters and suffixed with twelve hex + characters of its SHA-256. Two `tool_use` blocks in one turn that still collide are + refused rather than sent. (REV-2 C.7.) + +- Documentation: `baikai-claude`'s and `baikai-openai`'s Haddock point at the + functions that exist. `Baikai.Compat` named + `Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat`, + `…Api.applyThinkingFormat` and `…Api.translateTextLikeDelta`; the first two + moved to `…Internal.Request` and the third is + `…Internal.Stream.scanThinkTags`. `ThinkingFormat`'s note said the six + non-native shapes all clamp through `compatibleEffort`; three do, Z.ai and + Qwen send a bare toggle, and `ThinkingFormatNone` drops the control. + `immediateError` carried two `-- |` headers where one was intended. + (REV-2 H.4.) + +- `baikai-claude`: an Anthropic call reports its thinking tokens. `Usage.reasoningTokens` + was hard-coded to `Nothing` on this provider because `claude` 1.4.0's + `Messages.Usage` had no breakdown to read; 1.5.0 adds + `output_tokens_details.thinking_tokens`, and both `message_start` and + `message_delta` now fill the field from it. `reasoningTokens` is an + informational subset of `outputTokens`, so no total and no cost moves. + +- `baikai-claude`: the prompt-side token counts survive a server-side tool run. + The final `message_delta` used to contribute only `output_tokens`, and + `inputTokens`, `cacheReadTokens` and `cacheWriteTokens` kept whatever + `message_start` had reported — which is wrong for a call whose prompt grew + mid-stream. `claude` 1.5.0 exposes those three on `Messages.StreamUsage`, and + each is now taken when present. An absent field still keeps the + `message_start` figure rather than zeroing it, so a model that sends only + `output_tokens` is accounted for exactly as before. + +## [baikai-openai 0.6.0.0] - 2026-08-28 + +### Added + +- `baikai-openai`: `Baikai.Provider.OpenAI.Internal.ErrorClass.classifyErrorFrame` + and `Baikai.Provider.OpenAI.Api.parseFrame`, which sort a decoded SSE payload + into a classified in-band error or a completion chunk. + +### Changed + +- `baikai-openai`: **breaking.** `Baikai.Provider.OpenAI.Shape`'s + `injectThinkingShape`, `describeThinkingShape`, `shapeRequestBody` and + `streamRequestBody` take a `Bool` after the compat record — whether the model + advertises reasoning support (`Model.reasoning`). A level on a `reasoning = False` + model now sends no `reasoning_effort`, `reasoning`, `thinking` or `enable_thinking` + key on any host, and records `thinking_dropped_unsupported_model` instead. The model + check runs before the host-format check. This is what stops `gpt-4o-mini` plus a + level from 400ing. (REV-2 C.4.) + +### Fixed + +- `baikai-openai`: an in-band `{"error": …}` frame on a `2xx` stream terminates + the call with the frame's own classification, status and message. Compatible + hosts (OpenRouter, DeepSeek, Together) report an upstream failure they only + learned about after committing to a `200` this way, and `parseChunk` never + looked at `error`. The pre-fix behaviour was worse than a bad category: + OpenRouter's frame carries `choices[0].finish_reason = "error"`, which mapped + to `Stop`, so the call ended as `EventDone` with `errorInfo = Nothing` — a + consumer switching on the terminal saw a *completed* call. A frame with no + `choices` beside the error ended as + `OtherError "openai stream ended without finish_reason"`. (REV-2 A.3.) + +- `baikai-openai`: reasoning that arrives after visible text closes the open + text block before opening the thinking block, so at most one of the two is + open at a time, every `_End` precedes the next `_Start`, and no `contentIndex` + is revisited after a later one. (REV-2 B.4.) + +- `baikai-openai`, `baikai-claude`: **a provider POST no longer follows + redirects.** `http-client`'s default is to follow up to ten with every header + intact, so a 3xx would have re-sent the bearer token (or `x-api-key`) to + whatever host the `Location` header named. `redirectCount` is now zero and the + 3xx is delivered as the one in-band terminal error carrying its status. Each + transport's request builder is exported as `buildRequest`, so the method, the + composed path and the redirect policy are assertable without a connection. + (REV-2 A.5 / E.4.) + +- `baikai-openai`, `baikai-claude`, `baikai`: **the base-URL convention is + stated and enforced.** `Model.baseUrl` and `EmbeddingModel.baseUrl` are the + API *root* — the host, or the prefix a host mounts the API under — because + baikai appends `/v1/chat/completions`, `/v1/messages` or `/v1/embeddings` + itself. A trailing `/v1` is accepted and removed rather than doubled, so + `https://api.deepseek.com/v1` now requests `/v1/chat/completions` instead of + `/v1/v1/chat/completions`. A base URL with no scheme, a scheme other than + `http`/`https`, credentials, a query string, a fragment, or a path that is + already an endpoint is refused as an `InvalidRequest` naming the problem — + and refused *before* a key is read, so an unusable base URL never causes a + credential to be looked up. The message renders the URL without its userinfo + or query, so it is safe to log. `docs/user/models-and-providers.md` gains a + **Base URLs** section stating all of it. (REV-2 A.6.) + +- `baikai-openai`, `baikai-claude`: the `ClientEnv` cache was duplicated in each + package and keyed on the raw base-URL text, so `https://h` and `https://h/` + were two TLS managers and two connection pools to one host. There is now one + cache, in `Baikai.Http`, keyed on the canonical rendering of the parsed base + URL. `Transport.getClientEnvCached` and `Transport.cachedClientEnvCount` are + re-exports of the core functions and keep their signatures. + +- `baikai-openai`: the Codex interactive launcher now **refuses the two approval + policies the installed CLI rejects**. `codex --help` at `codex-cli 0.149.1` + lists exactly `on-request` and `never` for `--ask-for-approval`; + `CodexApprovalUntrusted` and `CodexApprovalOnFailure` are older spellings the + CLI answers with `error: invalid value 'untrusted' for + '--ask-for-approval'`. Rendering them made a launch return `Right` carrying a + non-zero exit code — a session that ran and failed — instead of the `Left + SafetyNotExpressible` this module promises for a policy that cannot be + honoured. They are refused before any process is created, and refused rather + than quietly mapped onto `on-request`, because substituting a different + approval policy would change what the caller asked for. The constructors and + their spellings are unchanged, so code that matches on `CodexApprovalPolicy` + keeps compiling. + +## [baikai-trace-otel 0.4.0.0] - 2026-08-28 + +### Added + +- `baikai-trace-otel`: `OtelSinkOptions` derives `Generic`, so `#spanName` + resolves on it. No `Eq` or `Show`: `OpenTelemetry.Context.Context` has neither, + and an instance that ignored `parentContext` would be a lie. (REV-2 G.6.) + +- `baikai-trace-otel`: `OtelSinkOptions.parentContext :: Maybe Context`, default + `Nothing`. When set, every span the sink opens becomes a child of the span in + that context instead of a root, so a call can be nested under the caller's own + request span. It is a value fixed when the sink is built rather than an action + run per call, because the fold runs on baikai's trace worker thread where the + caller's thread-local context is invisible: capture the context on your own + thread (`ctx <- getContext`, or `Context.insertSpan mySpan Context.empty`) and + build the sink for that request. __Breaking for positional construction__ of + `OtelSinkOptions`; the documented path is a record update on + `defaultOtelSinkOptions`. (REV-2 D.9.) + +### Changed + +- `baikai-trace-otel`: the `baikai.evidence.strength` span attribute is rendered + by `Baikai.Evidence.renderEvidenceStrength`, the function the JSON encoding + uses, instead of a second spelling local to the sink that could drift from it. + +- `baikai-trace-otel`: `gen_ai.response.model` is set only by the evidence + branch, from the model the provider reported. The terminal branch set it from + the *requested* id, and since evidence is pushed before the terminal and + `addAttributes` replaces a key, that both labelled a request as an observation + on every call without evidence and overwrote the genuinely observed value on + every call with one. (REV-2 D.1.) + +## [baikai-effectful 0.4.0.0] - 2026-08-28 + +### Changed + +- `baikai-effectful` (breaking): the version is a **major** bump although this + package's own exports are unchanged. Its `baikai` bound moves to `^>=0.6.0`, + and the `Baikai` effect's three operations are typed in `Model`, `Context`, + `Options` and `Response` — every one of which baikai 0.6.0.0 changes + breakingly. A consumer therefore meets a break through this package even + though nothing in it was renamed, so the number says so rather than making + `0.3.0.4` look like a safe upgrade. + +- `baikai-effectful`: no longer depends on `streamly`. Both stanzas listed it + while every module imports only `Streamly.Data.Fold` and + `Streamly.Data.Stream`, which are `streamly-core`. (REV-2 minor.) + +## [baikai-kit 0.2.0.0] - 2026-08-28 + +### Added + +- `baikai-kit`: `Baikai.Kit.Error` with the closed `KitError` sum, its + `Exception` instance and `renderKitError`; `Baikai.Kit.Path.safeSourcePath`, + which resolves an untrusted relative source below the kit checkout and refuses + a symbolic link in any component or a canonical path outside the checkout; + `Baikai.Kit.Manifest.itemSources`/`ItemSources`, the one pure derivation of an + item's source list, and `supportedManifestVersions`; + `Baikai.Kit.Sidecar.hashEntries`; `Baikai.Kit.Repo.KitRepo`/`RepoRefresh`; + `Baikai.Kit.Install.installFrom`, `renderAvailable` and `UpdateReport`; + `Baikai.Kit.Status.StatusReport`, `UpstreamAvailability` and the now-pure + `renderStatusTable`; `Baikai.Kit.Command.runKitCommand`. `KitState` gains + `KitUpstreamRefused`, rendered `refused`. (REV-2 E.5, F.10, F.11.) + +- `baikai-kit`: `Baikai.Kit.Install.OverwritePolicy` (`KeepLocalEdits`, + `OverwriteLocalEdits`), `reinstallPresent` (the network-free half of + `updateKit`), and `PlannedWrite`/`WriteContent`/`executePlan`/`executePlanWith` + as a test seam. `SidecarMeta` gains `installedFiles` and `installedHash`, + which record what this tool wrote for one provider and the hash of exactly + those bytes; `newSidecarMeta` takes both. `kit update` gains `--force`. + (REV-2 F.12, Theme 8.2.) + +### Changed + +- **Breaking.** `baikai-kit`: every library function returns + `Either KitError a` and prints nothing; only + `Baikai.Kit.Command.runKit` prints `Error: …` and exits 1. `loadManifest`, + `loadManifestMaybe`, `installItem`, `listAvailable`, `uninstallItem`, + `updateKit` and `ensureKitRepo` change shape accordingly, `computeKitHash` + takes the kit root, a base and relative file names, `kitStatus` returns a + `StatusReport` instead of printing, and `KitUpdate`'s report is rendered by + the caller. See `docs/adr/0013-library-code-never-calls-exitfailure.md`. A + consumer that only calls `runKit` and `kitCommandParser` needs no change; one + that calls the library directly binds `Right`. (REV-2 F.11.) + +- `baikai-kit`: a kit is plain files. Install, the content hash and `kit status` + resolve every listed source through `safeSourcePath`, so a kit repository that + commits a symbolic link can no longer have a file read through it and copied + into a provider directory. `kit status` shows such an item as `refused`. + (REV-2 E.5 = F.10.) + +- `baikai-kit`: a manifest whose `version` is not 1 or 2 is refused with + `KitManifestVersionUnsupported` instead of being decoded and installed. + (REV-2 F.12.) + +- `baikai-kit`: an agent that lists several `files` installs all of them. The + first becomes the provider's agent file as before, and each remaining file + goes into a resource directory named after the agent beside it + (`//`), which uninstall removes with the agent. Only + the first file used to be installed. (REV-2 F.12.) + +- `baikai-kit`: `kit update` skips an item whose installed files no longer hash + to what its sidecar recorded, printing the `--force` invocation that would + overwrite them; `kit update --force` reinstalls anyway. Sidecars written + before this release carry no such hash and are updated without the check. + (REV-2 Theme 8.2.) + +### Removed + +- **Breaking.** `baikai-kit`: `Baikai.Kit.Path.safeUnder` (exported and unused), + `Baikai.Kit.Manifest.agentSources` (replaced by `itemSources`) and + `Baikai.Kit.Install.uninstallOutcomes` (absorbed by `uninstallItem`, which now + returns the outcomes for the caller to render). The internal `requireSafe` and + `Baikai.Kit.Status.resolveCacheOrEmpty` are gone with the exits they wrapped. + +### Fixed + +- `baikai-kit`: `kit status` with no cache and no network prints + `No kit items installed.` and exits 0. It used to exit 1: the guard around + `ensureKitRepo` caught `IOException`, which is not what `exitFailure` throws. + (REV-2 F.11.) + +- `baikai-kit`: `Baikai.Kit.Status.upstreamHash` joined the manifest `path` + without validating it, a second unsanitised join that grew after the July + hardening pass validated the first. Both now go through `itemSources` and + `safeSourcePath`. (REV-2 Theme 8.1.) + +- `baikai-kit`: an install that fails while renaming files into place now + restores what was there before, or names the paths it could not restore. + Phase two was a bare loop of renames, so a failure part-way left earlier + renames in place while the message said "no changes were made". Temporary + files are also created with `openTempFile`, so two concurrent installs of one + item no longer clobber each other's staging file, and a destination that is a + directory is refused before anything is written. (REV-2 F.12.) + +- `baikai-kit`: `Baikai.Kit.Install.stripYamlFrontmatter` normalises line + endings to LF on every branch. Input without frontmatter, and input whose + frontmatter is never closed, used to keep their `\r` characters and leak them + into the Codex agent TOML. (REV-2 Theme 8.7.) + +- `baikai-kit`: an `IOException` raised while reinstalling during `kit update` + is returned as `KitWriteFailed` instead of escaping as an uncaught exception. + (REV-2 Theme 8.4.) + +## [baikai-agent 0.2.0.0] - 2026-08-28 + +### Added + +- `baikai-agent`: three operator-only `policy` keys — `policy.allowed-tools`, + `policy.max-timeout` (a duration or `"unlimited"`) and + `policy.max-output-limit` (a byte count or `"unlimited"`) — each defaulting + from `defaultAgentCeiling`, and all six ceiling fields now printed by + `agent show` and carried in its `--json` object. + +- `baikai-agent`: `Baikai.Agent.Config.repositoryScopeViolations`, which reads + the resolution report to say which values the untrusted repository file was + not allowed to supply at all. `Baikai.Agent.Cli` concatenates its answer with + the pure ceiling's, so an operator sees one refusal naming every problem. + +### Changed + +- `baikai-agent` (breaking): `AgentConfigScope`'s constructors are + `AgentUserScope` and `AgentRepositoryScope`. `UserScope` collided with + `baikai-kit`'s `KitScope` constructor of the same name, the one clash between + two baikai-family packages. (REV-2 G.5.) + +- `baikai-agent` (breaking): a relative `working-dir` resolves against the + repository root rather than the process's own directory, so `working-dir "."` + means the checkout whichever file declared it. Resolving against the process + directory made `"."` mean two places when two documents defined one job, since + which one it was depended on which layer won. An absolute path is unchanged. + (REV-2 F.14.) + +- `baikai-agent` (breaking): every `--json` output is now built with `aeson` + rather than a hand-rolled writer, and `agent show --json` always emits one + object with the same seven keys — `job`, `outcome` (`shown`, `refused` or + `failed`), `exitCode`, `message`, `configuration`, `ceiling`, `command` — + with `null` for the parts that do not apply. Previously a refusal emitted a + different shape from a success and a document that would not parse emitted a + bare resolution report or nothing at all, so a reader had to know which + failure mode it was looking at before it could find the exit code. `run --json` + keeps its `outcome` values and `list --json` is unchanged. (REV-2 F.14.) + +- `baikai-agent` (breaking): `--run-id` or `--require-evidence` without either + `--evidence-file` or `--json` is now a usage error (64) naming both fixes. + Before, the record was built — a `--version` probe of the tool and two digests + — and then dropped. Under `--json` the record now travels in the envelope as + `evidence`, encoded by the same `ToJSON` `--evidence-file` writes. + +- `baikai-agent`: `agent show` and `agent run` no longer print another job's + unknown-key warnings, or the operator file's `policy` keys. The declaration + describes one job and the ceiling is a separate declaration, so `settei` warns + about both; neither is a mistake and a document with four jobs printed three + jobs' worth of noise on every run. A misspelled key inside the selected job + still warns, and a `policy` node in the *repository* document earns exactly one + notice saying it has no effect. `Baikai.Agent.Config` exports the two filters, + `relevantWarnings` and `repositoryPolicyNotice`. (REV-2 F.13.) + +- `baikai-agent`: an evidence record's `endpoint` resolves a relative executable + against the job's working directory before probing it, because that is what + the child execs. A job whose `executable` is `./bin/agent` previously reported + a path resolved against the parent's own directory, which does not exist. + `Baikai.Agent.Run` exports `executableForEvidence`. (REV-2 F.13.) + +- `baikai-agent`: a failed run's `error_info.message` keeps the last + `errorInfoStderrTailBytes` (4096) bytes of standard error, prefixed with how + many earlier bytes were dropped, instead of the whole captured stream — which + the output limit allows to reach four mebibytes by default. `Baikai.Agent.Run` + exports the constant. (REV-2 F.13.) + +- `baikai-agent`: `--evidence-file` stages through a uniquely named temporary + file created with `O_EXCL` beside the destination, instead of the destination + plus `.partial`. A symbolic link planted at the old, guessable name was + followed, which let an unattended run overwrite a file of the planter's + choosing. (REV-2 F.13.) + +- `baikai-agent` (breaking): an operator configuration file that lies inside the + repository root is refused with exit 78, naming the file and the root, and no + ceiling is established. The source list already refused the repository + *document*; this closes the shape where the repository supplies the *operator* + document, which both `--user-config .baikai/policy.kdl` and + `XDG_CONFIG_HOME=$PWD/.baikai` produce. `--user-config`, `XDG_CONFIG_HOME` and + `HOME` remain the operator's own inputs: the ceiling is exactly as trustworthy + as the process environment that selects it, and the guide now says so. + (REV-2 F.4.) + +- `baikai-agent` (breaking): an unrecognised key under the operator file's + `policy` node is an error rather than a warning, naming the file and every + such key. Everywhere else a forward-compatible file should not stop an older + binary; under `policy` a misspelling would silently leave the default ceiling + in force, which for the one node whose purpose is limiting authority is + indefensible. Two `AgentConfigError` constructors are added, + `CeilingFileInsideRepository` and `UnknownPolicySetting`. + +- `baikai-agent` (breaking): `AgentConfigPaths` gains `repositoryRoot`, the + directory the process runs in. `--config PATH` chooses which file supplies + repository-scope settings and does not move the root, because the root is what + confines a repository-supplied `working-dir`. + +- `baikai-agent` (breaking): a repository configuration file may no longer set + `executable` or a non-empty `extra-dirs`, and its `working-dir` must resolve — + after following symbolic links — inside the repository root. Each is refused + with exit 77 naming the setting, or naming both directories. The operator's + own file and `--set` may still set all three. `executable` turns configuration + into code execution with the operator's environment and the prompt on standard + input; `extra-dirs` inside the root adds nothing the working directory does not + already give, so the only ones a checkout would ask for are outside it. + (REV-2 F.3.) + +### Removed + +- `baikai-agent` (breaking): the `BAIKAI_AGENT_EXECUTABLE` environment binding. + An environment variable is inherited by every child process and is easy to set + by accident, and naming the program to run is the widest widening there is. + An operator whose installation is not on `PATH` writes `executable` in their + own configuration file or passes `--set`. + +### Fixed + +- `baikai-agent`: a timed-out run now **escalates to `SIGKILL`**. The runner + interrupts the child's whole process group, then terminates it, then kills it, + each of the first two stages bounded by the grace period and ended early once + the leader has been reaped and no member of the group is left. Previously the + last resort was `terminateProcess` followed by an *unbounded* wait, so a + coding agent that ignored `SIGTERM` — or a grandchild holding the output pipe + — hung the run for as long as it chose to live, with the deadline already + past. Polling the group rather than waiting on the leader alone is also what + gives a grandchild the same grace the agent gets. + +- `baikai-agent`: a timed-out run **reports the output it drained**. `baikai + agent run` prints it under the same stream discipline a finished run gets, so + `response=$(baikai agent run job)` under `capture` receives the partial answer + with `$?` set to 75, and `--json`'s failure envelope carries the same + `stdout`, `stdoutTruncated`, `stderr` and `stderrTruncated` fields. A drain + interrupted because something outside the process group still held the pipe + open keeps its bytes too, reported as truncated. + +- `baikai-agent`: the `baikai` command writes its output as **UTF-8 bytes** + rather than through the locale encoding. Where an unattended run actually + happens — cron, a systemd unit, a container — the environment says `LANG=C`, + and on a platform whose locale encoding follows it a single accented character + in the agent's answer made the write throw after the run had already finished: + exit 1, answer lost. This mirrors what the prompt read and the prompt write + have always done. + +- `baikai-agent`: the `baikai` executable now links the **threaded runtime** + (`ghc-options: -threaded` on the `executable baikai` stanza). Without it a + blocking operating-system call — the `waitpid` inside + `System.Process.waitForProcess` — stopped every Haskell thread in the + installed binary, so a job's configured `timeout` could never fire and a + coding agent that wrote more than one pipe buffer deadlocked against the + runner's drain threads. Both defects existed only in the shipped executable: + the test suite was already compiled `-threaded`, so every runner test passed + under a runtime the binary did not have. + + The suite now proves the runtime the binary ships with rather than its own. + `baikai-agent/test/BinaryTests.hs` spawns the built executable — cabal builds + it first and puts it on the suite's `PATH` through + `build-tool-depends: baikai-agent:baikai` — asserts that `baikai +RTS --info` + reports `rts_thr`, and runs `baikai agent run` against a stub agent that + outlives its deadline, requiring exit 75 within seconds and the whole process + group gone. See + [docs/adr/0006](docs/adr/0006-a-process-spawning-executable-ships-on-the-threaded-runtime.md). + +## [baikai 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai`: new exposed module `Baikai.Agent`, the provider-neutral vocabulary + for an **unattended coding-agent run** — a run with no terminal and no human, + which owns its own tool loop, may change files inside directories the caller + authorized, and returns a process result rather than a `Response`. It defines + `AgentRunRequest` (with a required `workingDir`), `AgentRunResult`, the + `AgentCapability` profile (`read-only`, `edit-workspace`, `full-access`), + `AgentSafety`, the `AgentOutputMode` and `AgentCapturedOutput` output + discipline, the `AgentCommand` renderer/runner boundary with an explicit + prompt transport, and the `AgentRenderError` / `AgentRunFailure` taxonomies. + +- `baikai`: the operator policy ceiling — `AgentCeiling`, + `defaultAgentCeiling`, `CeilingViolation`, and the pure `applyAgentCeiling`. + It returns a request unchanged when it is within the ceiling and reports + every violation when it is not; it never clamps an over-broad request to the + permitted value. The default ceiling permits read-only and edit-workspace + authority and refuses full access and raw provider arguments. + + `Baikai.Agent` itself is vocabulary and pure policy algebra only: it spawns no + process and renders no command-line flags. Those live in the vendor packages + and in `baikai-agent`, below. The module is deliberately not re-exported from + the umbrella `Baikai` module, because its field accessors share names with + `Baikai.Interactive`, so `import Baikai` continues to compile unchanged. + +- `baikai`: new exposed module `Baikai.Evidence`, the vocabulary for + **verifiable model-call evidence** — a record of what actually crossed the + boundary to a provider, as opposed to what the process was configured to ask + for. It defines `ModelCallEvidence` and the `evidenceSchemaVersion` string + consumers pin against, `Observed` (a deliberate non-`Maybe` for a value the + provider either did or did not report, with no function that supplies a + default), `ThinkingTranslation` with its `ThinkingMode` and + `ThinkingAdjustment` enumerations describing what a requested + reasoning-effort level actually became on the wire and every clamp, collapse, + or drop applied on the way, `EndpointIdentity` and `TransportKind`, + `CallStatus`, and the ascending `EvidenceStrength` scale. + + It also provides the canonical hashing core: `canonicalEncode` gives a JSON + value exactly one byte representation (object keys sorted, no insignificant + whitespace, numbers normalised so `1`, `1.0`, `1.00`, and `1e0` all encode as + `1`, and a hand-written string escaper so an aeson upgrade cannot silently + invalidate a recorded digest); `commitmentDigest` hashes a full request + envelope, and `configurationDigest` hashes an allow-list projection + (`configurationProjection`) that keeps configuration and replaces content with + structural summaries, so two calls that ask the same model the same way about + different subjects agree. The two digests are separate on purpose: the first + binds a record to a particular request, the second is safe to compare across + runs that legitimately differ in content. + + Nothing constructs a `ModelCallEvidence` from a real call yet, and no existing + behaviour changed. New dependencies: `cryptohash-sha256` and + `base16-bytestring`, both single-purpose packages chosen over a full + cryptographic framework. + +- `baikai`: `Options` gains an `evidence` field carrying an optional + `EvidenceRequest` — the caller's run identifier, retry provenance, and how + strictly they need evidence. A call whose `evidence` is `Nothing`, which is + every call that does not opt in, behaves exactly as it did before: no digest + is computed and no evidence is emitted. + +- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`: **strict + evidence mode**. `EvidenceStrictness` is `EvidenceBestEffort` or + `EvidenceRequired !EvidenceStrength`, and a caller who asks for the second + gets a call that **refuses to start** — before any request is built or any + connection opened — when the configuration cannot reach the strength asked + for: `Baikai.Evidence.Build.checkEvidenceRequirements` compares the + requirement against what the provider can deliver and against the thinking + translation, and `completeRequest` / `streamRequest` return an error-shaped + response or a terminal `EventError` instead of dispatching. The gate is + pre-dispatch by design; that is the only point at which refusing is still + free. + +- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) `baikai`: + **sink-failure semantics under strict mode**. `Baikai.Evidence.Build` + exports `onSinkFailure`, `sinkFailureIsFatal` and `sinkFailureError`: a trace + sink that throws fails an `EvidenceRequired` caller's call, because a record + the sink did not confirm written is not a record, while a best-effort caller's + call succeeds with the failure reported on stderr. + +- (Entry added 2026-08-27; the behaviour shipped in 0.5.0.0.) **Breaking.** + `baikai`: `Baikai.Provider.Registry.ApiProvider` gained a fourth field, + `describeThinking :: Model -> Options -> ThinkingTranslation`, which the + pre-dispatch strictness gate calls to learn what a provider would do with the + caller's reasoning-effort request without sending anything. Every third-party + provider constructed with the `ApiProvider` constructor stopped compiling. + This was not recorded at the time; it is the defect that made 0.6.0.0 hide the + constructor behind `apiProvider` so that the next field addition is a minor + release. + +- `baikai`: model-call evidence is now **produced and emitted**. A caller who + sets `Options.evidence` gets exactly one `call_evidence` line per call from + their trace sink, under every way a call can end: success, provider failure, a + consumer that abandons the stream (status `aborted`, not `failed` — an abort + is the consumer's doing and reporting it as a provider failure would + misattribute it), and dispatch that found no registered handler. + + New exposed module `Baikai.Evidence.Build` bridges the vocabulary to the + `Model` and `Options` records: `minimalEvidence` and `prepareEvidence` build a + record, `dispatchEnvelope` supplies the request envelope for the paths where + no adapter ran, `sanitizeEndpoint` reduces a base URL to scheme/host/port/path + with the query string and any userinfo dropped wholesale, and `onSinkFailure` + is the hook a future release replaces to make a strict caller's call fail when + the trace sink does. + + Every record this release produces has `strength` `requested_only` and every + provider-observed field set to `"unobserved"`. That is not a placeholder: it + is a truthful record for a transport that has not yet been taught to observe + anything. Later releases teach each transport to observe more. + + (Correction added 2026-08-27: the two paragraphs above describe the release + inaccurately and are kept as shipped rather than rewritten. `onSinkFailure` + did not await a future release — it shipped in 0.5.0.0 together with + `sinkFailureIsFatal` and `sinkFailureError`, which already fail a strict + caller's call when the sink throws. And not every 0.5.0.0 record has `strength` + `requested_only`: the provider entries below describe what each transport + reports, and the HTTP adapters reach `correlated` and `model_observed`.) + + **A caller who does not opt in pays nothing.** With `Options.evidence` absent + no digest is computed, no call identifier is generated, no evidence event is + emitted, and the request envelope is never even forced — the gate lives inside + the shared builder rather than at each adapter's call site, and the envelope + parameter is deliberately lazy. Both facts are guarded by tests. + +- `baikai`: `TraceEvent` gains a `CallEvidence` constructor, encoded as + `{"kind":"call_evidence", …}`. A consumer whose pattern match over `TraceEvent` + is exhaustive must add a branch; one with a wildcard is unaffected. Filter for + it with `jq 'select(.kind == "call_evidence") | .evidence'`. Note that a trace + line carries its fields alongside the `kind` discriminator rather than nested + under a `data` key, and that the evidence record inside spells its own fields + in snake_case — the two encodings differ deliberately, because an evidence + record must render an absent field as explicit `null` while a trace line drops + it to stay small. + +- `baikai`: `Baikai.Provider.Cli.Internal` — the module the two subprocess + providers share — gains the vocabulary for reading what a coding-agent CLI + reported about its own run. `CodexRunReport` and the new + `parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport` fold the + `codex exec --json` event stream into its assistant text, its thread + identifier, and its token counts, instead of concatenating agent-message text + and discarding everything else. `ClaudeCliReport` and + `decodeClaudeCliResult` do the same for `claude -p --output-format json`. + Every field but the message text is optional, because both tools' event + schemas have changed across versions and an absent field is a genuine absence + rather than a parse failure. **Breaking** for anyone calling + `parseCodexJsonlStream` directly: its result type is no longer `Text`. This is + an internal module and is documented as outside the PVP guarantee. + +- `baikai`: `Baikai.Provider.Cli.Internal` also gains `ExecutableIdentity` and + `executableIdentity`, which resolve a configured executable name to an + absolute path and read the tool's own `--version` line. The probe is cached + per resolved name for the lifetime of the process, because spawning it per + model call would roughly double the process cost of the cheapest possible + call, and it is bounded by a five-second timeout so a tool that hangs on + `--version` cannot wedge a model call. (Corrected 2026-08-27: the entry said + two seconds; `versionProbeMicros` has always been five.) A probe that fails records the version + as absent rather than failing the call. It is only ever called from inside + the evidence branch: a caller who asked for no evidence must not pay for a + process whose only purpose is to describe a tool they were about to run + anyway. + +- `baikai`: `subprocessStrength` and `cliResponseEnvelope`, also in + `Baikai.Provider.Cli.Internal`. The former derives a subprocess call's + evidence strength from what the tool reported and **nothing else** — the exit + status is deliberately not one of its arguments. The latter spells the + response-commitment envelope with the same three keys, in the same shapes, as + the two API transports build by hand, so a verifier holding a response can + recompute the digest without first knowing which transport served it. + +- `baikai`: `Baikai.Agent` gains `AgentRunOutcome` and `agentRunOutcome`. It + pairs what an unattended run did — the existing + `Either AgentRunFailure AgentRunResult` — with the evidence the runner built + for it. The evidence is a sibling of the outcome rather than a field on + `AgentRunResult` because the run that most needs a record is one that did not + produce a result: a run killed by its own timeout reports + `Left (RunTimedOut …)`, so a record hanging off the `Right` would be + unreachable exactly there. + +### Fixed + +- `baikai`: a `call_evidence` event is now emitted **before** its call's + terminal `call_finished` or `call_failed`, rather than after. The + OpenTelemetry sink ends and removes a call's span on the terminal, so under + the old order its evidence-attribute branch was unreachable from any real + call and every backend saw a span with no evidence on it — nothing failed, + the attributes were simply never there. No consumer can have depended on the + old order, because no consumer has ever seen a `call_evidence` line. + +- `baikai`: the `ThinkingFormatOpenAI` Haddock in `Baikai.Compat` listed the + native `reasoning_effort` vocabulary as `minimal | low | medium | high`, which + predates `xhigh` and `max`. It now lists all six and states that this shape + alone sends the canonical baikai level verbatim while the other six clamp + through `compatibleEffort`. No behaviour changed: the native path's exclusion + from that clamp is deliberate and is guarded by two named tests in + `baikai-openai/test/ShapeSpec.hs`. A reader who consulted the comment to + decide whether `xhigh` was safe to use against OpenAI has until now been told + something untrue. + +### Changed + +- **Breaking:** `baikai`: `TerminalPayload` gains an `evidence` field and the two + terminal smart constructors take it as their new first argument: + `doneTerminal :: Maybe ModelCallEvidence -> Maybe Text -> StopReason -> Message -> TerminalPayload` + and `errorTerminal` likewise. `Response` gains the same field. A custom + provider implementation must pass `Nothing` (or a record it builds through + `Baikai.Evidence.Build`); a custom `Response` built with the record + constructor must add `evidence = Nothing`. Code that only pattern-matches on + these types is unaffected. + +- **Breaking:** `baikai`: `CallFinished` gains `cachedInputTokens`, + `cacheWriteTokens`, `reasoningTokens`, and `totalTokens`. The trace path used + to drop counts that `Baikai.Cost.Log.CallLogEntry` kept from the same `Usage` + value, which made the cost log strictly more faithful than the trace. + +- **Breaking:** `baikai`: a computed cost of **zero is now reported as zero** + rather than suppressed, in `CallFinished` and at all three `CallLogEntry` + construction sites. Previously `usd` was omitted whenever the cost came out at + zero, so "this call was free" and "baikai could not price this call" were + indistinguishable — and the subscription-based CLI providers always price at + zero, so that was the common case rather than a corner. **A cost dashboard + that treated an absent `usd` as "unpriced" will now count those calls as + costing zero.** That is the correct reading, but it changes what such a + dashboard shows. + +- **Breaking:** `baikai`: `FromJSON TraceEvent` is written out by hand instead of + derived. The three pre-existing kinds decode exactly as before; a + `call_evidence` line fails to parse with a message saying to read it as a + plain `Data.Aeson.Value`. `ModelCallEvidence` has no `FromJSON` on purpose — + it embeds a `Cost` whose exact `Rational` amounts encode through an + approximating `Scientific`, so a decoder would return a different value than + was encoded — and manufacturing that fidelity would be the precise failure + this vocabulary exists to eliminate. + +- `baikai`: `Baikai.Trace.Sink.renderHuman` renders a `CallEvidence` event as a + single `EVIDENCE run=… call=… strength=…` line rather than the whole record. A + human-readable sink is for watching calls go by; the full record is meant to + be read out of `fileSink` output by a machine. + +- `baikai`: call identifiers on the trace path are now globally unique. + `Baikai.Evidence.newCallId` produces 32 lowercase hexadecimal characters + carrying 128 bits — 48 bits of Unix time in milliseconds, 48 bits of a + per-process random seed drawn once from `/dev/urandom`, and a 32-bit counter. + The previous generator combined the process-start *second* with a + process-local counter into 16 characters, so two processes started within the + same second emitted identical identifier sequences; its own documentation + claimed only per-process uniqueness. Identifiers still sort chronologically + and are still not secrets. + + `Baikai.Trace.newEventId` keeps its name and signature, delegates to + `newCallId`, and is now deprecated. Anything that pinned the 16-character + width — a log parser, a fixture, a column type — must widen to 32. + +- `baikai`: `renderCeilingViolation` no longer prints the raw provider arguments + a `ProviderArgsForbidden` violation carries. It reports how many were + requested and states that their values are not shown. Raw provider arguments + are the one part of a job description that can hold a credential — the + configuration layer classifies the setting secret for that reason — and a + refusal message that quoted them defeated the classification. The constructor + keeps its `[Text]` payload so a programmatic caller can still inspect it. + +## [baikai-claude 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai-claude`: new exposed module `Baikai.Provider.Claude.Agent` with + `ClaudeAgentConfig`, `defaultClaudeAgentConfig`, and `claudeAgentCommand`, a + pure renderer from an unattended `AgentRunRequest` to the `claude` argument + vector. It maps the capability profile onto `--permission-mode` + (`plan` / `acceptEdits` / `bypassPermissions`), joins a tool allow-list into + one `--allowedTools` argument, repeats `--add-dir` per extra directory, always + emits `-p`, and emits `--no-session-persistence` unless `persistSession` is + set. The prompt travels on standard input and appears nowhere in the argument + vector. A request naming a different provider is refused with + `ProviderMismatch`. Nothing is spawned. + +- `baikai-claude`: the Anthropic Messages provider now fills in the evidence + record it previously left blank. It records the model **Anthropic reported + running** (read from the `message_start` event, which the adapter already + decoded for the response id and then discarded), Anthropic's `request-id` + correlation header, the response id, the token counts Anthropic actually + reported, and a commitment digest over the assembled response. A field the + provider did not report stays `"unobserved"` and is never backfilled from the + request — in particular, a stream that fails before `message_start` reports no + observed model at all. `strength` is `model_observed` when both the model and a + correlation identifier arrived, `correlated` when only the identifier did, and + `requested_only` otherwise; a 2xx status never raises it, because a 200 means + the request was accepted, not that any particular model ran. + `fully_observed` is unreachable on this transport, since Anthropic does not + echo the thinking configuration it applied. + +- `baikai-claude`: an evidence record's `thinking` field now describes what the + caller's reasoning-effort preference actually became on the wire, including + three downgrades that were previously invisible everywhere in baikai's output: + asking for thinking on a model that does not advertise `reasoning` + (`thinking_dropped_unsupported_model`); asking for a level whose token budget + does not fit under the resolved output-token ceiling + (`thinking_dropped_budget_exceeded`, carrying both colliding numbers), which is + reachable by lowering `maxTokens` alone; and asking for `high` on an + adaptive-thinking model, which sends no effort field and so is + wire-indistinguishable from taking Anthropic's default depth + (`effort_omitted`). `minimal` on an adaptive model reports `effort_clamped`, + because Anthropic's adaptive vocabulary has no `minimal`. + +- `baikai-claude`: new exports from `Baikai.Provider.Claude.Sse` — + `ResponseMetadata` and `capturedHeaderNames` — and from + `Baikai.Provider.Claude.Api` — `claudeMessagesStreamWith`, `SseDriver`, and + `anthropicStrength`. Response-header capture is an **allow-list** + (`request-id`, `x-request-id`, `cf-ray`, in that preference order), not a + denylist, so a header a future gateway adds is not recorded by default. + +- `baikai-claude` and `baikai-openai`: both subprocess providers now fill in the + evidence record they previously left blank, and both export the translation + function that describes it — `claudeCliThinking` and `codexCliThinking`. They + record the session or thread identifier the tool reported, the token counts it + reported, the model it named when it names one, the resolved executable path + in place of an endpoint URL, the tool's own `--version` string as the + implementation version (for this transport the tool *is* the implementation), + a request commitment over the rendered argument vector, and a response + commitment over the assembled answer. + + **A zero exit status never raises the strength.** A coding-agent CLI that + exits zero has demonstrated that it ran and did not crash; it has not stated + which model served the request. Subprocess calls almost always exit zero, so + encoding that as corroboration would make the weakest evidence in the system + look like the strongest. `strength` is `model_observed` only when the tool + named both an identifier and a model, `correlated` when it named only an + identifier, and `requested_only` otherwise. + + The two transports differ in how far they can get. `claude` names the model + that consumed tokens in its result event's `modelUsage` map, complete with a + context-window variant marker such as `[1m]`, so a Claude CLI run can reach + `model_observed`. `codex-cli 0.146.0` names no model anywhere in its event + stream, so **no** Codex CLI run can exceed `correlated` — backfilling the + `--model` flag baikai passed would report the request as an observation. + +- `baikai-claude`: an evidence record's `thinking` field now describes what a + reasoning-effort request became on the `claude` command line: mode `flag`, + wire field `--effort`, and an `effort_clamped` adjustment recording the + `minimal` → `low` collapse, because the tool's `--effort` flag has no + `minimal`. A caller asking for `minimal` and a caller asking for `low` produce + byte-identical argument vectors — and therefore identical request commitment + digests — so the translation is the only place that difference survives. + +- **Breaking:** `baikai-claude` and `baikai-openai`: `claudeAgentCommand` and + `codexAgentCommand` return `(AgentCommand, ThinkingTranslation)` rather than + `AgentCommand`. The runner deliberately imports no vendor renderer, so it + cannot derive the translation and has to be handed it. A caller that only + wants the command writes `fmap fst`. Both modules also export the translation + function alone — `claudeAgentThinking` and `codexAgentThinking` — for asking + what a level would become without rendering anything. + +### Fixed + +- **Loud:** `baikai-claude` and `baikai-openai`: both subprocess providers + hardcoded `usage = zeroUsage` on every call, so a cost dashboard saw every + `claude -p` and `codex exec` call as consuming no tokens and costing nothing. + Both tools report their own token counts and baikai now carries them through, + normalized into the disjoint `Usage` convention: `claude`'s counts are + Anthropic-shaped and already disjoint, while `codex` reports OpenAI-style + inclusive prompt counts, so its cached tokens are subtracted out of + `inputTokens`. `claude` additionally reports a `total_cost_usd`, which now + populates `Usage.cost` exactly rather than being reported as zero. + + **A dashboard that read these calls as free will now see real tokens and, for + `claude`, a real cost.** That is the correction, not a regression — but it + changes what existing reports show, and totals over historical data will not + match totals over new data. + +- `baikai-claude`: `Response.responseId` was always `Nothing` on the `claude -p` + transport even though `ClaudeCliResult` decoded the tool's `session_id` one + screen earlier and then dropped it. It now carries that identifier, on both + the successful and the failed terminal. `baikai-openai`: the same for + `codex exec`, whose thread identifier was filtered out of the event stream + along with everything that was not an `agent_message`. These are the handles + each vendor's support tooling looks a run up by. + +### Changed + +- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Sse`'s four streaming + entry points — `claudeSseStream`, `claudeSseStreamValue`, + `claudeSseStreamValueWithHeaders`, and `sseFromResponse` — take a new + `ResponseMetadata -> IO ()` callback immediately before the existing per-event + callback. It fires exactly once, before the first event, on both the success + and the non-2xx path. Pass `(\_ -> pure ())` to keep the previous behaviour. + The callback is separate rather than a widening of the per-event one because + the per-event callback runs once per SSE frame and response-level data does not + belong on that path. + +- **Breaking:** `baikai-claude`: `Baikai.Provider.Claude.Internal.Request`'s + `mapRequest` now returns + `Either Text (Messages.CreateMessage, ThinkingTranslation)` and + `computeThinking` returns `(ThinkingPlan, ThinkingTranslation)`. Take `fst` to + keep the previous value. This module is exposed for provider tests and + debugging and its header states it is not covered by PVP compatibility + guarantees, but the change is recorded here because that is not a licence to + break a consumer silently. + +- **Breaking:** `baikai-claude`: `claudeInteractiveCommand` now returns + `Either AgentRenderError (FilePath, [String])` and `launchClaudeInteractive` + returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request + whose `safety` is a `CodexSandbox` policy — which Claude Code cannot express + — is refused with `SafetyNotExpressible AgentClaude`, naming the rejected + sandbox mode and approval policy and suggesting `ClaudeAllowedTools` or + `DefaultSafety`. Previously the policy was silently discarded and an + **unrestricted** Claude session was started and reported as a success. A + `Left` means no process was started; a `Right` with a non-zero exit code + means the session ran and exited non-zero. `DefaultSafety` and an empty + `ClaudeAllowedTools` list still render no safety flag and are never refused, + and no previously rendered argument vector changed. Callers must handle the + refusal branch. + +## [baikai-openai 0.5.0.0] - 2026-08-05 + +### Added + +- `baikai-openai`: new exposed module `Baikai.Provider.OpenAI.Agent` with + `CodexAgentConfig`, `defaultCodexAgentConfig`, and `codexAgentCommand`, the + same renderer for `codex exec`. It maps the capability profile onto + `--sandbox` (`read-only` / `workspace-write` / `danger-full-access`), emits + `--cd` for the working root, and defaults `--skip-git-repo-check` and + `--ephemeral` on. A request carrying a tool allow-list is **refused** with + `UnsupportedToolRestriction`, because `codex exec` has no such flag and running + it with unrestricted tools would grant more authority than the caller asked + for. Nothing is spawned. + +- `baikai-openai`: an evidence record's `thinking` field now describes what the + caller's reasoning-effort preference became on the wire for the specific host + the call went to, across **all seven** OpenAI-compatible wire shapes. The + OpenAI-native shape sends the canonical level verbatim and records no + adjustment, because it expresses every level exactly. The four shapes that + carry an effort word for a non-native host record `effort_clamped` whenever + the word differs from the canonical name — `minimal` becomes `low`, and both + `xhigh` and `max` become `high`. Z.ai and Qwen accept a bare + `enable_thinking: true` with no depth, so **every** level records + `effort_collapsed_to_toggle`: a caller asking for `max` and a caller asking + for `low` produce byte-identical requests there, and only the evidence record + can tell them apart. A host with no reasoning controls records + `thinking_dropped_unsupported_host` where the option previously vanished with + no trace. A forty-two-row table test pins the translation and the shaped + request body for every shape at every level. + +- `baikai-openai`: the Chat Completions provider now fills in the evidence record + it previously left blank. It records the model **the host reported running** + (read from the first streamed chunk carrying a top-level `model` field and + never overwritten by a later one), the host's `x-request-id` correlation + header, the response id, the token counts the host actually reported, and a + commitment digest over the assembled response. A field the host did not report + stays `"unobserved"` and is never backfilled from the request — in particular, + a call that fails before any chunk arrives reports no observed model at all. + `strength` is `model_observed` when both the model and a correlation + identifier arrived, `correlated` when only the identifier did, and + `requested_only` otherwise; a 2xx status never raises it, because a 200 means + the request was accepted, not that any particular model ran. + `fully_observed` is unreachable on this transport, since no host in this + ecosystem echoes the reasoning configuration it applied. + +- `baikai-openai`: new exports from `Baikai.Provider.OpenAI.Sse` — + `ResponseMetadata` and `capturedHeaderNames` — and from + `Baikai.Provider.OpenAI.Api` — `openaiChatStreamWith` and `SseDriver`. + Response-header capture is an **allow-list** (`x-request-id`, `request-id`, + `x-amzn-requestid`, `x-ms-request-id`, `cf-ray`, in that preference order), + not a denylist, so a header a future gateway adds is not recorded by default. + The list is longer than the Anthropic one because this transport speaks to an + open-ended set of hosts and the gateways commonly in front of them. + +- `baikai-openai`: the same field for `codex exec`: mode `flag`, wire field + `model_reasoning_effort`, and **no** adjustments at any level. Codex is the + only transport in baikai that expresses all six canonical levels exactly, and + a test asserts each one reaches the command line verbatim. + +### Fixed + +- `baikai-openai`: `Response.responseId` was always `Nothing` on the Chat + Completions transport, although every compatible host sends a top-level `id` + on every streamed chunk. It now carries the identifier the host reported, on + both the successful and the failed terminal. + +### Changed + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Sse`'s four streaming + entry points — `openaiSseStream`, `openaiSseStreamValue`, + `openaiSseStreamValueWithHeaders`, and `sseFromResponse` — take a new + `ResponseMetadata -> IO ()` callback immediately before the existing per-chunk + callback. It fires exactly once, before the first chunk, on both the success + and the non-2xx path — a failed call's correlation identifier is if anything + more valuable than a successful one's. Pass `(\_ -> pure ())` to keep the + previous behaviour. The callback is separate rather than a widening of the + per-chunk one because that one runs once per SSE frame and response-level data + does not belong on that path. + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Api`'s `RawChunk` gains + `model` and `responseId` fields, both `Maybe Text`. Code that pattern-matches + on `RawChunk` is unaffected; code that constructs one with record syntax must + add them. + +- **Breaking:** `baikai-openai`: `Baikai.Provider.OpenAI.Shape`'s + `shapeRequestBody`, `streamRequestBody`, and `injectThinkingShape` now return + `(Aeson.Value, ThinkingTranslation)` instead of a bare body. Take `fst` to + keep the previous value. The description has to travel out of the shaping step + because nothing downstream can recompute it: it depends on the host's + `ThinkingFormat`, which only the compat lookup knows. **No request body + changed** — every one of the seven shapes puts exactly the same bytes on the + wire as before. + +- **Breaking:** `baikai-openai`: `codexInteractiveCommand` now returns + `Either AgentRenderError (FilePath, [String])` and `launchCodexInteractive` + returns `IO (Either AgentRenderError InteractiveLaunchResult)`. A request + whose `safety` is a non-empty `ClaudeAllowedTools` list — which `codex` has + no flag for — is refused with `SafetyNotExpressible AgentCodex`, quoting the + rejected tools and suggesting `CodexSandbox` or `DefaultSafety`. Previously + the allow-list was silently discarded and Codex was started with its default + sandbox. The same `Left`/`Right` reading applies, `DefaultSafety` and an + empty allow-list are never refused, and no previously rendered argument + vector changed. Callers must handle the refusal branch. + + Both changes make the interactive surface honor the same contract as the new + unattended surface: a safety policy the chosen provider cannot express fails + visibly instead of silently becoming a weaker policy. Downstream consumers + must adapt before upgrading; the known one is `shinzui/seihou`, whose + `Seihou.CLI.AgentLaunchExec` module builds interactive launch requests. + +## [baikai-trace-otel 0.3.0.3] - 2026-08-05 + +### Added + +- `baikai-trace-otel`: the sink attaches an evidence record's salient fields to + the open span as flat attributes (`baikai.evidence.run_id`, + `baikai.evidence.call_id`, `baikai.evidence.strength`, the two digests, and + `gen_ai.response.model` only when the provider actually reported one) rather + than serialising the record into one blob. A `CallEvidence` event neither + opens nor closes a span. + +### Changed + +- `baikai-trace-otel`: widened its `baikai` bound to admit `0.5`. No API change. + +## [baikai-effectful 0.3.0.3] - 2026-08-05 + +### Changed + +- Widened its `baikai` bound to admit `0.5`. No API change; the package's + own surface is untouched. + +## [baikai-kit 0.1.0.4] - 2026-08-05 + +### Changed + +- Widened its `baikai` bound to admit `0.5`. No API change; the package's + own surface is untouched. + +## [baikai-agent 0.1.0.0] - 2026-08-05 + +### Added + +- `baikai-agent`: **new package** (`0.1.0.0`) holding the unattended + coding-agent runner. `Baikai.Agent.Run.runAgentCommand` takes an + `AgentRunRequest` and an already-rendered `AgentCommand` and spawns the tool + with no terminal and no human present. It delivers the prompt on standard + input and closes the handle, drains standard output and standard error + concurrently so a chatty agent cannot deadlock on a full pipe, retains at most + `outputLimit` bytes per stream while reading and discarding the excess, and + honors the three output disciplines. Preconditions run before any spawn: a + missing working directory is `WorkingDirMissing` and unset or empty declared + variables are `MissingEnvironment`, listing all of them at once. On timeout + the child's whole process group is interrupted, given a grace period, and then + terminated, so the agent's own child processes go with it; the failure reports + the configured limit. A non-zero exit code is a successful run carrying that + code, not a failure. The runner consumes an already-rendered `AgentCommand` + and never imports a vendor renderer, so it is exercised entirely with + hand-written argument vectors. Its POSIX-signal escalation is conditional on a + non-Windows build. + +- `baikai-agent`: new exposed module `Baikai.Agent.Config`, the layered + configuration layer. `resolveAgentJob` resolves one named job across five + layers — built-in defaults, the operator file, the repository file, the + environment, then command-line overrides, later layers winning — and returns + the resolved `AgentJob` together with a report attributing every value to the + file, line, and column it came from. `agentJobRequest` converts a job into an + `AgentRunRequest`, taking the prompt at call time. `listAgentJobs` enumerates + configured job names, sorted, each attributed to the highest-precedence scope + defining it. `defaultAgentConfigPaths` locates + `$XDG_CONFIG_HOME/baikai/agents.kdl` (or `$HOME/.config/baikai/agents.kdl`) + and `./.baikai/agents.kdl`, with no upward search through parent directories. + + The **policy ceiling** is loaded by a separate function, `loadAgentCeiling`, + against a separate source list containing the operator file and nothing else: + no repository file, environment variable, or command-line override can raise + it. `applyCeilingToJob` refuses an over-broad request with `CeilingRejected` + rather than clamping it. With no operator file the ceiling is + `defaultAgentCeiling`. `safety.provider-args` is classified secret and renders + as `` in any report or structured error. + + New dependencies: `settei`, `settei-env`, `settei-kdl`, and + `settei-optparse-applicative` (all `^>=0.2`, published on Hackage at + `0.2.0.0`), plus `containers` and `filepath`. `settei-formats` is deliberately + excluded, because it bundles Dhall loading and repository configuration is + untrusted input here. + +- `baikai-agent`: the **`baikai` executable**, with the `agent run`, + `agent show`, and `agent list` commands, and the `Baikai.Agent.Cli` module + that implements them. A shell script now invokes one stable command, supplies + a prompt on standard input, and selects Claude Code or Codex entirely through + configuration. + + `agent run` resolves the named job, caps it against the operator ceiling, + renders it through the vendor renderer for its provider, and spawns it. The + agent's own exit code passes through unchanged; Baikai's own failures use 64 + and above following the `sysexits` convention — 64 for a usage error or an + empty prompt, 69 when the executable could not be started, 70 for malformed + output, 75 for a timeout, 77 for a policy refusal, and 78 for a configuration + problem. The prompt comes from `--prompt-stdin`, `--prompt-file`, or + `--prompt`, which are mutually exclusive, and is decoded as UTF-8 explicitly + rather than through the handle's locale encoding. + + `agent show` performs the whole pipeline except spawning and prints each + resolved value with the file, line, and column it came from, the policy + ceiling in force and where it was read, and the exact argument vector that + would be spawned — with `` in place of any raw provider argument. A + job whose policy is refused prints its configuration first and then the + refusal. `agent list` enumerates configured jobs and the scope each came from. + + Every Baikai diagnostic goes to standard error. The agent's own output follows + the job's output mode, so `response=$(baikai agent run job)` yields the + agent's answer alone for a capturing job. `--set KEY=VALUE` overrides one + setting of the selected job through `settei`'s own command-line source, so an + override is attributed with the same fidelity as a file. `--json` emits + exactly one JSON object per command. + + New dependencies for `baikai-agent`: `baikai-claude`, `baikai-openai`, and + `optparse-applicative`. The provider packages are needed only so that + `renderJobCommand`, the single provider dispatch point in the codebase, can + reach both renderers. This is the first dependency in the workspace from + `baikai-agent` onto the provider packages, so `baikai-agent` now publishes + after all three of `baikai`, `baikai-claude`, and `baikai-openai`. + + The user guide `docs/user/unattended-agent-runs.md` documents the whole + surface: the three commands with their flags, exit codes, and stream + discipline; the KDL job format and layer precedence; the operator ceiling and + redaction; the capability mapping tables for both tools; and a before-and-after + migration of a script that embeds provider flags today. + `docs/user/cli-providers.md` and `docs/user/interactive-launches.md` link to + it, and the capability mapping tables moved there from the latter. + +- `baikai-agent`: **an unattended coding-agent run now produces model-call + evidence.** This surface previously had no observability of any kind: no trace + sink, no `Response`, no usage, no identifiers. An operator could show that a + process started, exited, and took some time; they could not show which model + ran, which reasoning effort was applied, or which agent session the run + corresponds to in the vendor's records. + + A record carries the run and call identifiers, the resolved executable and its + own reported version, digests over the request, the requested model and what + the reasoning-effort request became on the command line, whatever the tool + reported about itself, the outcome, and an honest strength. + + **A zero exit status never raises the strength.** On this surface that rule + matters more than anywhere else, because almost every unattended run exits + zero. A coding agent that exits zero has demonstrated that it ran, not which + model served it. + + Two things gate what a record can prove, and neither is the default. The job + must **capture** output — under `inherit` the agent's bytes went to the + operator's terminal and baikai never held them — and the tool must be + configured to print a structured format, which means `--output-format json` + for `claude` or `--json` for `codex exec` through the job's `provider-args`. + Without both, the tool's session identifier, model, and token counts are + genuinely unavailable and the record says `"unobserved"` rather than inferring + anything. A timed-out run records `aborted`; a run that never started records + nothing at all. + +- **Breaking:** `baikai-agent`: `Baikai.Agent.Run.runAgentCommand` takes two new + leading arguments and returns the new outcome type: + `Maybe EvidenceRequest -> ThinkingTranslation -> AgentRunRequest -> AgentCommand -> IO AgentRunOutcome`. + A caller who wants the previous behaviour passes `Nothing` and + `Baikai.Evidence.noThinkingRequested` and reads the `outcome` field; that path + is byte-for-byte what it was, and costs what it cost — no digest is computed, + no call identifier is generated, and the tool is not invoked a second time to + read its version. + +- `baikai-agent`: `baikai agent run` gains `--evidence-file PATH` and + `--run-id TEXT`. Supplying neither leaves the run on the pre-existing path at + the pre-existing cost; supplying either turns recording on, with the job's own + name standing in as the run identifier when only a destination is given. The + file is written atomically — a staging file beside the destination, then a + rename — so a reader polling the path never sees a half-written object, and it + is never appended to. A failed write is reported on standard error and never + changes the exit code, because the agent's own status is what a calling script + branches on. `docs/user/unattended-agent-runs.md` documents both options and, + more importantly, what the record does and does not prove. + +- `baikai-agent`: `baikai agent run` gains `--require-evidence STRENGTH`, taking + `requested_only`, `correlated`, `model_observed`, or `fully_observed` — the + same words a record's `strength` field spells, so what one record showed can + be passed back as the next run's requirement. A job whose configuration cannot + produce evidence of at least that strength is refused before anything is + spawned, exiting 77 — the code a ceiling violation and an inexpressible safety + policy already use, so a script branching on 77 needs no new case. + +## [baikai-claude 0.4.0.1] - 2026-07-30 + +### Fixed + +- Widened the `crypton` bound from `^>=1.0` to `>=1.0 && <1.2` so consumers can + build `baikai-claude` alongside packages that require `crypton` 1.1.x (for + example `pg-migrate-1.1.0.0`), which previously had no solvable build plan. + The only `crypton` use is `Crypto.Hash` (`Digest`, `SHA256`) in + `Baikai.Provider.Claude.Transport`, whose API is identical across the 1.0/1.1 + boundary. No API change. + +## [baikai 0.4.1.0] - 2026-07-20 + +### Changed + +- Version bump only; no library API or code changes. Released so the umbrella + release tag `baikai-0.4.1.0` names a fresh core version alongside the breaking + `baikai-claude` / `baikai-openai` 0.4.0.0 releases, matching the tag + convention downstream consumers pin against. + +## [baikai-claude 0.4.0.0] - 2026-07-20 + +### Changed + +- **Breaking:** `claudeCliCommand` now takes the `Options` record and forwards + `Options.thinking` to batch `claude -p` as `--effort ` (`minimal` + collapses to `low`, matching the interactive launcher and the claude CLI's + lack of a `minimal` value). `thinking = Nothing` emits no effort flag, keeping + existing argv byte-for-byte. The added parameter is a PVP-major signature + change. + +## [baikai-openai 0.4.0.0] - 2026-07-20 + +### Changed + +- **Breaking:** `codexCliCommand` now takes the `Options` record and forwards + `Options.thinking` to `codex exec` as `-c model_reasoning_effort=` for + all six effort levels. `thinking = Nothing` emits no override, keeping + existing argv byte-for-byte. The added parameter is a PVP-major signature + change. + +## [baikai 0.4.0.0] - 2026-07-20 + +### Added + +- Added `ThinkingXHigh` and `ThinkingMax` to the exported `ThinkingLevel` + vocabulary and added a defaulted `InteractiveLaunchRequest.effort` field. + Extending the closed sum type is a PVP-major API change for downstream + exhaustive matches. + +## [baikai-claude 0.3.0.2] - 2026-07-20 + +### Added + +- Added `--effort` rendering to interactive Claude Code launches and preserved + `xhigh` / `max` on native adaptive Anthropic API requests, with larger fixed + budgets for manual-thinking models. + +### Changed + +- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the + baikai 0.4.0.0 release. + +## [baikai-openai 0.3.0.2] - 2026-07-20 + +### Added + +- Added `model_reasoning_effort` overrides to interactive Codex launches and + preserved `xhigh` / `max` in native OpenAI request JSON; non-native + OpenAI-compatible request shapes continue to clamp them to `high`. + +### Changed + +- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the + baikai 0.4.0.0 release. + +## [baikai-trace-otel 0.3.0.2] - 2026-07-20 + +### Changed + +- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the + baikai 0.4.0.0 release. No API changes. + +## [baikai-effectful 0.3.0.2] - 2026-07-20 + +### Changed + +- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the + baikai 0.4.0.0 release. No API changes. + +## [baikai-kit 0.1.0.3] - 2026-07-20 + +### Changed + +- Bumped the internal `baikai` dependency bound to `^>=0.4.0` for the + baikai 0.4.0.0 release. No API changes. + +## [baikai 0.3.1.0] - 2026-07-15 + +### Added + +- Added `claude-sonnet-5` to the Anthropic model catalog (1M context window, + 128k max output, `tool_call` + reasoning). +- Added the `gpt-5.6` family — `gpt-5.6`, `gpt-5.6-luna`, `gpt-5.6-sol`, and + `gpt-5.6-terra` — to the OpenAI model catalog (chat-completions with + `tool_call` support). + +### Changed + +- Corrected `claude-sonnet-4-5` context window to 1M tokens and + `claude-sonnet-4-6` max output to 128k tokens in the catalog. +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai-claude 0.3.0.1] - 2026-07-15 + +### Changed + +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai-openai 0.3.0.1] - 2026-07-15 + +### Changed + +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai-trace-otel 0.3.0.1] - 2026-07-15 + +### Changed + +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai-effectful 0.3.0.1] - 2026-07-15 + +### Changed + +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai-kit 0.1.0.2] - 2026-07-15 + +### Changed + +- Added PVP-compliant upper bounds to all previously-unbounded library and + executable dependencies. + +## [baikai 0.3.0.0] - 2026-07-03 + +### Added + +- Added the documented record-update bases `emptyOptions`, `emptyContext`, + `emptyModel`, `emptyResponse`, `emptyTool`, `emptyTextContent`, + `emptyThinkingContent`, `emptyToolCall`, `emptyImageContent`, + `emptyEmbeddingModel`, plus zero-valued bases `zeroUsage`, `zeroCost`, + `zeroCostBreakdown`, and `zeroModelCost`. +- Added `firstEmbedding`, a total accessor for OpenAI-compatible embedding + responses. +- Added `responseError`, `errorResponse`, `httpError`, and + `parseRetryAfterSeconds` for the in-band error contract. + +### Changed + +- **Breaking:** Constructors for evolvable records are no longer exported: + `Options`, `Context`, `Model`, `OpenAICompletionsCompat`, + `AnthropicMessagesCompat`, and `InteractiveLaunchRequest` are built from + exported base values plus record updates. +- **Breaking:** The `_X` base values are deprecated in favor of the new + `empty*` and `zero*` names; the aliases remain for this release. +- **Breaking:** Removed `unModel`; use `mkModel` or `emptyModel` record + updates. +- **Breaking:** Renamed `InteractiveLaunchRequest.model` to `modelId`. +- **Breaking:** `Response.latencyMs` and trace event `latencyMs` fields are + now `Int`. +- **Breaking:** `completeRequest` / `completeRequestWith` no longer throw + `BaikaiError` for unregistered API tags; they return an error-shaped + `Response`. +- **Breaking:** CLI providers now report subprocess/decode/provider failures + in-band as error-shaped `Response`s. +- **Breaking:** `errorTerminal` now requires a `BaikaiError`, enforcing + structured error details for `EventError` construction sites. +- Documented that `Baikai.Prelude` is a convenience module outside the PVP + stability contract and that `.Internal` modules have no compatibility + guarantees. + +### Fixed + +- Empty embedding `data` arrays now produce a typed `decodeError` instead of + crashing on an empty vector. +- The model-fetch JSON renderer now delegates string escaping to aeson. +- The model generator now fails on sanitized Haskell identifier collisions + instead of rendering duplicate bindings. +- Live HTTP status, `Retry-After`, and network-failure classification now + works on both API providers. +- `content_filter` / Anthropic refusals terminate as classified `EventError` + terminals, and `liftCompleteToStream` preserves error-shaped responses. + +## [baikai-claude 0.3.0.0] - 2026-07-03 + +### Changed + +- **Breaking:** `Baikai.Provider.Claude.ErrorClass` moved to + `Baikai.Provider.Claude.Internal.ErrorClass`. +- **Breaking:** `mapRequest` and pure request-shaping helpers moved from + `Baikai.Provider.Claude.Api` to + `Baikai.Provider.Claude.Internal.Request`. +- **Breaking:** `ClaudeCliConfig` and `ClaudeInteractiveConfig` constructors + are no longer exported; start from their default config values and update + fields. +- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`. + +## [baikai-openai 0.3.0.0] - 2026-07-03 + +### Changed + +- **Breaking:** `Baikai.Provider.OpenAI.ErrorClass` moved to + `Baikai.Provider.OpenAI.Internal.ErrorClass`. +- **Breaking:** `mapRequest` and pure request-shaping helpers moved from + `Baikai.Provider.OpenAI.Api` to + `Baikai.Provider.OpenAI.Internal.Request`. +- **Breaking:** `CodexCliConfig` and `CodexInteractiveConfig` constructors are + no longer exported; start from their default config values and update fields. +- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`. + +## [baikai-trace-otel 0.3.0.0] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. +- Adjusted to the core trace event `latencyMs :: Int` type. + +## [baikai-effectful 0.3.0.0] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. + +## [baikai-kit 0.1.0.1] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. + +## [baikai 0.2.0.0] - 2026-06-21 + +### Added + +- `Usage`, `Cost`, and `CostBreakdown` now have `Semigroup`/`Monoid` + instances that add field-by-field, plus `sumUsage :: Foldable f => f + Usage -> Usage`, so callers can total per-call usage and cost. + `reasoningTokens` combines as presence-wins (`Nothing` only when both + operands are `Nothing`). +- A categorised error model: `BaikaiError` is now a record carrying an + `ErrorCategory` (`AuthError`, `RateLimited`, `ContextOverflow`, + `InvalidRequest`, `TransientError`, `DecodeFailure`, `ProcessFailure`, + `ProviderUnavailable`, `OtherError`), an optional HTTP `httpStatus`, a + `retryAfterSeconds` hint, and a subprocess `exitCode`. New smart + constructors (`providerError`, `invalidRequest`, `decodeError`, + `processError`, `rateLimited`, `authError`, `providerUnavailable`), + the `isRetryable` predicate, and the pure `classifyHttpStatus` / + `classifyHttpStatusWithBody` helpers let callers implement retry + policy without parsing error text. `ErrorCategory` and `BaikaiError` + serialize to JSON. +- `Response` and the streaming `EventError`'s `TerminalPayload` now + carry `errorInfo :: Maybe BaikaiError`, so a failed `completeRequest` + (or a drained stream) exposes the structured category/retry hint + in-band. `Baikai.Stream.Event` gains `doneTerminal` / `errorTerminal` + constructors. + +### Changed + +- **Breaking:** `BaikaiError`'s four flat constructors + (`ProviderError`, `RequestInvalid`, `DecodeError`, `ProcessError`) + were replaced by the record above. Migrate by lowercasing to the + smart constructors — `ProviderError "x"` becomes `providerError "x"`, + `ProcessError n "x"` becomes `processError n "x"`, etc. +- **Breaking:** `Baikai.Stream.Event.TerminalPayload` and + `Baikai.Response.Response` gained an `errorInfo` field; build + `TerminalPayload` via `doneTerminal` / `errorTerminal`. + +### Fixed + +- Restored JSON decoding for `BaikaiError` values with omitted optional + metadata fields. + +## [baikai-claude 0.2.0.0] - 2026-06-21 + +### Added + +- The Anthropic API and `claude -p` CLI providers now classify failures + into the typed `BaikaiError` categories: HTTP errors (via the caught + `servant-client` `ClientError`) map status/`Retry-After`/body onto + `AuthError` / `RateLimited` / `ContextOverflow` / `InvalidRequest` / + `TransientError`, and mid-stream Anthropic `error` events are + classified by their error type. The result is surfaced on + `Response.errorInfo`. + +## [baikai-openai 0.2.0.0] - 2026-06-21 + +### Added + +- The OpenAI/OpenAI-compatible API and `codex exec` CLI providers now + classify failures into the typed `BaikaiError` categories the same way + as `baikai-claude` (HTTP `ClientError` for status-based errors, + streamed error text for mid-stream errors), surfaced on + `Response.errorInfo`. + +## [baikai-trace-otel 0.2.0.0] - 2026-06-21 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with + the `baikai 0.2.0.0` breaking API release. + +## [baikai-effectful 0.2.0.0] - 2026-06-21 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with + the `baikai 0.2.0.0` breaking API release. + +## [baikai 0.1.1.0] - 2026-06-12 + +### Added + +- Added provider-agnostic `ResponseFormat` support on `Options`, including + plain JSON-object mode and named JSON-schema mode. +- Added `Baikai.Embedding`, an OpenAI `/v1/embeddings` client for text + embeddings. + +## [baikai-claude 0.1.1.0] - 2026-06-12 + +### Added + +- Mapped baikai `ResponseFormat` options onto Anthropic `output_config` for + Claude API requests. +- Exported `mapRequest` for request-mapping tests and downstream inspection. + +## [baikai-openai 0.1.1.0] - 2026-06-12 + +### Added + +- Mapped baikai `ResponseFormat` options onto OpenAI Chat Completions + `response_format`. +- Exported `mapRequest` for request-mapping tests and downstream inspection. + +## [baikai-effectful 0.1.0.0] - 2026-06-12 + +### Added + +- Initial release: effectful binding for baikai with the `Baikai` dynamic + effect, `complete`, `streamCollect`, `streamEach`, and registry-backed + interpreters. + +## [baikai 0.1.0.0] - 2026-06-04 + +### Added + +- Initial release: unified Haskell interface for working with multiple AI + providers. Core modules including `Baikai`, `Baikai.Prelude`, `Baikai.Api`, + `Baikai.Provider`, `Baikai.Provider.Registry`, `Baikai.Response`, + `Baikai.Stream`, `Baikai.Tool`, `Baikai.Trace`, and the cost/usage modules. +- Depends on released `streamly` (`>=0.11 && <0.13`) and `streamly-core` + (`>=0.3 && <0.5`) from Hackage, so all dependencies resolve from Hackage. + +## [baikai-claude 0.1.0.0] - 2026-06-04 + +### Added + +- Initial release: Anthropic Claude providers for the baikai abstraction, + wrapping the `claude` package for both the Anthropic API and the `claude -p` + CLI (`Baikai.Provider.Claude.Api`, `.Cli`, `.Interactive`). + +## [baikai-openai 0.1.0.0] - 2026-06-04 + +### Added + +- Initial release: OpenAI providers for the baikai abstraction, wrapping the + `openai` package for OpenAI's Chat Completions API + (`Baikai.Provider.OpenAI.Api`, `.Cli`, `.Interactive`). + +## [baikai-trace-otel 0.1.0.0] - 2026-06-04 + +### Added + +- Initial release: OpenTelemetry `TraceSink` adapter for baikai + (`Baikai.Trace.Sink.OpenTelemetry`), emitting one OTel span per provider call + with GenAI semantic-convention attributes plus baikai cost and latency. diff --git a/baikai-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.4.0.1 -synopsis: Anthropic Claude providers for the baikai abstraction +cabal-version: 3.4 +name: baikai-claude +version: 0.7.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: @@ -21,6 +24,21 @@ -fhide-source-paths -Wmissing-export-lists -Wpartial-fields -Wmissing-deriving-strategies + -- Exhaustiveness is an error, not a warning. A non-exhaustive match + -- is a crash the compiler already found: it fails at runtime, on + -- whichever input reaches the missing branch, usually in front of a + -- user. This is not hypothetical here — adding a constructor to + -- AgentRunFailure left `failureExitCode` non-exhaustive and shipped a + -- pattern-match failure on `baikai agent run --require-evidence`, + -- because the warning scrolled past in a build log. + -- + -- Promoted individually rather than through -Werror, which would also + -- fail the build on warnings that are stylistic or that a future GHC + -- invents, and would push people toward blanket suppression. + ghc-options: + -Werror=incomplete-patterns -Werror=incomplete-uni-patterns + -Werror=incomplete-record-updates + default-language: GHC2024 default-extensions: DeriveAnyClass @@ -32,29 +50,35 @@ import: common-options hs-source-dirs: src exposed-modules: + Baikai.Provider.Claude.Agent Baikai.Provider.Claude.Api Baikai.Provider.Claude.Cli 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 + other-modules: Paths_baikai_claude + autogen-modules: Paths_baikai_claude build-depends: , aeson ^>=2.2 - , baikai ^>=0.4.0 + , baikai ^>=0.7.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 - , http-client-tls ^>=0.3 + , http-client-tls >=0.3 && <0.5 , http-types ^>=0.12 , lens ^>=5.3 , servant-client ^>=0.20 @@ -70,7 +94,14 @@ hs-source-dirs: test main-is: Main.hs other-modules: + CliEvidenceSpec + Contract ErrorClassSpec + EvidenceSpec + FableContractsSpec + LifecycleSpec + MidStreamSpec + PublicSurfaceSpec ShapeSpec SseSpec ThinkingSpec @@ -80,7 +111,7 @@ ghc-options: -threaded -with-rtsopts=-N build-depends: , aeson - , baikai ^>=0.4.0 + , baikai ^>=0.7.0 , baikai-claude , base >=4.20 && <5 , bytestring @@ -93,10 +124,15 @@ , http-client , http-types , lens ^>=5.3 + , network , servant-client + , stm + , streamly , streamly-core >=0.3 && <0.5 , tasty , tasty-hunit + , temporary , text ^>=2.1 , time + , tls , vector diff --git a/src/Baikai/Provider/Claude/Agent.hs b/src/Baikai/Provider/Claude/Agent.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Claude/Agent.hs @@ -0,0 +1,227 @@ +-- | Render the argument vector for an __unattended__ Claude Code run +-- from Baikai's provider-neutral unattended request type. +-- +-- This module is intentionally separate from the other two Claude +-- surfaces. "Baikai.Provider.Claude.Cli" drives @claude -p@ as a batch +-- completion provider and returns a parsed response. +-- "Baikai.Provider.Claude.Interactive" starts the interactive terminal +-- UI and returns when the human quits. This module describes a run with +-- no terminal and no human, whose deliverable is the changed working +-- tree. +-- +-- Every function here is pure: nothing is spawned, and the prompt is +-- carried as data rather than as an argument. A policy Claude Code +-- cannot express is refused with an 'AgentRenderError' before a process +-- would ever be created; it is never approximated with a near-miss +-- flag. +module Baikai.Provider.Claude.Agent + ( ClaudeAgentConfig (executable, extraArgs, persistSession), + defaultClaudeAgentConfig, + claudeAgentCommand, + claudeAgentThinking, + ) +where + +import Baikai.Agent + ( AgentCapability (..), + AgentCommand (..), + AgentOutputFormat (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRenderError (..), + AgentRunRequest, + ) +import Baikai.Evidence + ( ThinkingAdjustment (..), + ThinkingMode (..), + ThinkingTranslation (..), + noThinkingRequested, + ) +import Baikai.Prelude +import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Data.Generics.Labels () +import Data.Text qualified as Text + +-- | Configuration for the unattended @claude@ process. +data ClaudeAgentConfig = ClaudeAgentConfig + { -- | The program to run, either a bare name resolved on @PATH@ or + -- an explicit path. + executable :: !FilePath, + -- | Raw provider defaults an application always wants. Rendered + -- after every structured flag and before the request's own raw + -- arguments. + extraArgs :: ![Text], + -- | Whether the run may leave a resumable session on disk. + -- Defaults to 'False', which emits @--no-session-persistence@: + -- automation runs are one-shot, and a session file nobody will + -- clean up is just litter. The flag only works together with @-p@, + -- which this renderer always emits. + persistSession :: !Bool + } + deriving stock (Eq, Show, Generic) + +defaultClaudeAgentConfig :: ClaudeAgentConfig +defaultClaudeAgentConfig = + ClaudeAgentConfig + { executable = "claude", + extraArgs = mempty, + persistSession = False + } + +-- | Render the executable, argument vector, and prompt transport for an +-- unattended Claude Code run, or refuse the request. +-- +-- The prompt appears nowhere in the argument vector: the transport is +-- 'PromptOnStdin', so a prompt beginning with a dash cannot be mistaken +-- for a flag and cannot be swallowed by a preceding variadic flag such +-- as @--allowedTools@ or @--add-dir@. +-- +-- No working-directory flag is rendered, because Claude Code has none. +-- The runner sets the child's working directory from the request's +-- @workingDir@ field. +-- +-- The second half of the pair describes what the request's reasoning +-- effort became on that command line, including the one collapse this +-- renderer applies. The runner cannot derive it — it never imports a +-- vendor renderer — so it travels alongside the command. +claudeAgentCommand :: + ClaudeAgentConfig -> + AgentRunRequest -> + Either AgentRenderError (AgentCommand, ThinkingTranslation) +claudeAgentCommand cfg req + | req ^. #provider /= AgentClaude = + Left (ProviderMismatch AgentClaude (req ^. #provider)) + | otherwise = do + permission <- permissionModeArgs (req ^. #safety . #capability) + pure + ( AgentCommand + { executable = cfg ^. #executable, + arguments = + ["-p"] + <> sessionArgs cfg + <> modelArgs req + <> effortArgs req + <> outputFormatArgs req + <> permission + <> allowedToolArgs req + <> extraDirArgs req + <> fmap Text.unpack (cfg ^. #extraArgs) + <> fmap Text.unpack (req ^. #safety . #providerArgs), + promptTransport = PromptOnStdin, + promptText = req ^. #prompt + }, + claudeAgentThinking req + ) + +-- | What the request's reasoning effort became on the @claude@ command +-- line. +-- +-- The adjustment is derived from 'claudeEffortValue' itself — recorded +-- exactly when the word that reaches @--effort@ differs from the +-- canonical level name — rather than from a table written beside it, so +-- the description cannot drift away from what the argument vector +-- actually carries. Today that is the single @minimal@ collapse, which +-- makes a run at @minimal@ and a run at @low@ produce byte-identical +-- command lines. +-- +-- A request with no effort at all yields 'noThinkingRequested'. That is +-- a different fact from a request whose level the tool weakened: the +-- tool then applies its own default, and nothing was downgraded. +claudeAgentThinking :: AgentRunRequest -> ThinkingTranslation +claudeAgentThinking req = case req ^. #effort of + Nothing -> noThinkingRequested + Just lvl -> + let wire = claudeEffortValue lvl + in ThinkingTranslation + { requested = Just lvl, + mode = ThinkingModeFlag, + effortText = Just wire, + budgetTokens = Nothing, + wireField = Just "--effort", + displayText = Nothing, + adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl] + } + +-- | Map a capability profile onto Claude Code's @--permission-mode@. +-- +-- The result is an 'Either' even though all three capabilities map +-- today. The type is the promise that an unmappable capability would be +-- refused rather than approximated: a later contributor adding a fourth +-- capability gets an incomplete-pattern warning pointing at this +-- decision instead of a silently missing flag. +permissionModeArgs :: AgentCapability -> Either AgentRenderError [String] +permissionModeArgs = \case + -- Claude Code has no mode meaning exactly "may read, must not + -- write". Of its six modes, `manual` and `dontAsk` can block waiting + -- for a human and are unusable unattended, `acceptEdits` and + -- `bypassPermissions` permit writes, and `auto` delegates the + -- decision to a classifier whose behavior is not a stable contract. + -- `plan` is the only mode that reliably does not modify the tree, at + -- the documented cost of also framing the task as producing a plan. + AgentReadOnly -> Right ["--permission-mode", "plan"] + AgentEditWorkspace -> Right ["--permission-mode", "acceptEdits"] + AgentFullAccess -> Right ["--permission-mode", "bypassPermissions"] + +sessionArgs :: ClaudeAgentConfig -> [String] +sessionArgs cfg + | cfg ^. #persistSession = [] + | otherwise = ["--no-session-persistence"] + +-- | A blank model value must not produce @--model ""@, which Claude +-- rejects. +modelArgs :: AgentRunRequest -> [String] +modelArgs req = case Text.strip <$> req ^. #modelId of + Nothing -> [] + Just "" -> [] + Just mid -> ["--model", Text.unpack mid] + +-- | Claude's @--effort@ accepts @low|medium|high|xhigh|max@, but not +-- @minimal@, so the lowest Baikai level maps up to @low@. This matches +-- "Baikai.Provider.Claude.Interactive" exactly so the two surfaces +-- cannot drift. +effortArgs :: AgentRunRequest -> [String] +effortArgs req = case req ^. #effort of + Nothing -> [] + Just lvl -> ["--effort", Text.unpack (claudeEffortValue lvl)] + +claudeEffortValue :: ThinkingLevel -> Text +claudeEffortValue ThinkingMinimal = "low" +claudeEffortValue lvl = renderThinkingLevel lvl + +-- | 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 + [] -> [] + tools -> ["--allowedTools", Text.unpack (Text.intercalate "," tools)] + +-- | On Claude Code @--add-dir@ grants tool /access/ to a directory. The +-- identically named @codex exec@ flag grants /write/ access, so the +-- shared @extraDirs@ field means "directories this run may reach" and +-- the precise authority is provider-dependent. +extraDirArgs :: AgentRunRequest -> [String] +extraDirArgs req = + concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs) diff --git a/src/Baikai/Provider/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,87 +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, - 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.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 (mapRequest) -import Baikai.Provider.Claude.Shape (streamRequestBody) -import Baikai.Provider.Claude.Sse (claudeSseStreamValueWithHeaders) -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 Baikai.Context (Context) +import Baikai.Evidence qualified as Ev +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Provider (ApiProvider, apiProvider) +import Baikai.Provider.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 GHC.Generics (Generic) -import Network.HTTP.Types.Header (RequestHeaders) -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 @@ -102,534 +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 - } - --- | 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 m ctx opts = - Stream.concatEffect $ do - setupResult <- trySync (prepareCall m ctx opts) - let setup = either (Left . exceptionToError) id setupResult - case setup of - Left err -> Stream.fromList <$> immediateError err - Right call -> do - ch <- newChan :: IO (Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent))) - tref <- newIORef False - _ <- forkIO (worker call ch) - startTime <- getCurrentTime - let initialState = - ProducerState - { chan = ch, - pending = [], - assembler = emptyAssembler m startTime, - finished = False, - terminalRef = tref - } - 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 - } - 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 -> 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 - } - ) - --- | 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 :: - ClaudeCall -> - Chan (Maybe (Either BaikaiError Messages.MessageStreamEvent)) -> - IO () -worker call ch = do - r <- - trySync $ - Transport.runWithTimeout (call ^. #timeoutMs) $ - claudeSseStreamValueWithHeaders - (call ^. #clientEnv) - (call ^. #requestHeaders) - (call ^. #requestBody) - (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) - } - deriving stock (Generic) - -step :: ProducerState -> IO (Maybe (AssistantMessageEvent, ProducerState)) -step s - | (e : rest) <- s ^. #pending = do - writeTerminal s e - pure - ( Just - ( e, - s - & #pending .~ rest - & #finished .~ (s ^. #finished || terminal e) - ) - ) - | s ^. #finished = pure Nothing - | otherwise = do - mRaw <- readChan (s ^. #chan) - case mRaw of - Nothing -> do - alreadyTerminal <- readIORef (s ^. #terminalRef) - if alreadyTerminal - then pure Nothing - else do - now <- getCurrentTime - let (ev, ass') = unexpectedEoS now (s ^. #assembler) - writeTerminal s ev - pure - ( Just - ( ev, - s & #assembler .~ ass' & #finished .~ True - ) - ) - Just raw -> do - now <- getCurrentTime - let (events, ass') = translate raw (s ^. #assembler) now - case events of - [] -> step (s & #assembler .~ ass') - (e : rest) -> do - writeTerminal s e - pure - ( Just - ( e, - s - & #pending .~ rest - & #assembler .~ ass' - & #finished .~ (s ^. #finished || terminal e) - ) - ) - -writeTerminal :: ProducerState -> AssistantMessageEvent -> IO () -writeTerminal s ev - | terminal ev = writeIORef (s ^. #terminalRef) True - | otherwise = pure () - -terminal :: AssistantMessageEvent -> Bool -terminal = \case - EventDone {} -> True - EventError {} -> True - _ -> False - --- | 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 (ass ^. #responseId) Stop.ErrorReason msg (providerError errText)), ass) - --- | Translation state across one streaming call. -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 - } - 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 - } - -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 (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) & #usage .~ usage0 - 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') - 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 (ass ^. #responseId) reason msg refusal) - else EventDone (doneTerminal (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 (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) - } - -finalMessage :: Assembler -> UTCTime -> Msg.Message -finalMessage ass now = - let blocks = blocksInOrder ass - m = ass ^. #model - usageBare = ass ^. #usage - computed = Pricing.computeCost m usageBare - usage' = usageBare & #cost .~ computed - in Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = blocks, - Msg.usage = usage', - Msg.stopReason = ass ^. #stopReason, - Msg.errorMessage = Nothing, - Msg.timestamp = Just now - } - -finalMessageOnError :: Assembler -> UTCTime -> Text -> Msg.Message -finalMessageOnError ass now reason = - let blocks = blocksInOrder ass - m = ass ^. #model - usageBare = ass ^. #usage - computed = Pricing.computeCost m usageBare - usage' = usageBare & #cost .~ computed - in Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = blocks, - Msg.usage = usage', - Msg.stopReason = 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. -immediateError :: BaikaiError -> IO [AssistantMessageEvent] -immediateError err = do - now <- getCurrentTime - let errText = err ^. #message - let msg = - Msg.AssistantMessage - Msg.AssistantPayload - { Msg.content = Vector.empty, - Msg.usage = Usage.zeroUsage, - Msg.stopReason = Stop.ErrorReason, - Msg.errorMessage = Just errText, - Msg.timestamp = Just now - } - pure - [ EventStart StartPayload {partial = msg, responseId = Nothing}, - EventError (errorTerminal Nothing Stop.ErrorReason msg err) - ] - -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 +claudeMessagesStream = claudeMessagesStreamWith liveSseDriver 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,52 +3,59 @@ -- -- 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 CLI provider always returns a 'Response' whose embedded --- assistant message carries zero token counts (and therefore zero --- cost): the @claude@ CLI runs under a flat subscription, so --- per-token billing does not apply. CLI providers do not participate --- in tool calling. Provider failures are returned in-band as --- error-shaped responses; the masterplan's Decision Log records the +-- The 'Response' this provider returns carries whatever the tool +-- reported about its own run: the token counts and total cost from the +-- result event's @usage@ block, and the tool's @session_id@ as the +-- response identifier. A tool that reports none of that yields zeroes +-- and 'Nothing', which is an accurate record of its silence rather +-- than a claim that the call was free. CLI providers do not +-- participate in tool calling. Provider failures are returned in-band +-- as error-shaped responses; the masterplan's Decision Log records the -- reasoning. +-- +-- Evidence from this transport is deliberately weaker than from the +-- Messages API. A tool that exits zero has demonstrated that it ran, +-- not which model served the request, so a successful exit never +-- raises the recorded 'Baikai.Evidence.EvidenceStrength' — see +-- 'Baikai.Provider.Cli.Internal.subprocessStrength'. module Baikai.Provider.Claude.Cli ( ClaudeCliConfig, executable, extraArgs, workingDir, claudeCliCommand, + claudeCliThinking, defaultClaudeCliConfig, claudeCliProvider, register, - registerWith, - registerWithRegistry, - registerWithRegistryAndConfig, ) where import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context) -import Baikai.Error (BaikaiError, decodeError, processError, providerError) +import Baikai.Error (BaikaiError, processError, providerError) +import Baikai.Evidence qualified as Ev +import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..)) import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Provider.Cli.Internal qualified as Internal import Baikai.Provider.Registry ( ApiProvider (..), - ProviderRegistry, + apiProviderWith, registerApiProvider, - registerApiProviderWith, ) import Baikai.Response qualified as Resp import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) import Baikai.ThinkingLevel (ThinkingLevel (ThinkingMinimal), renderThinkingLevel) -import Baikai.Usage (zeroUsage) -import Control.Exception (SomeAsyncException (..), SomeException, displayException, fromException, throwIO, try) -import Control.Lens ((^.)) +import Baikai.Usage (Usage, zeroUsage) +import Control.Exception (SomeException, displayException, fromException) +import Control.Lens ((&), (.~), (^.)) import Cradle ( ExitCode (..), StderrRaw (..), @@ -59,18 +66,11 @@ setNoStdin, setWorkingDir, ) -import Data.Aeson (FromJSON, Value (..), eitherDecodeStrict) -import Data.Aeson qualified as Aeson -import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types (parseEither, parseJSON) -import Data.ByteString (ByteString) -import Data.Function ((&)) import Data.Generics.Labels () import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as Text import Data.Time.Clock (UTCTime, diffUTCTime, getCurrentTime) -import Data.Vector (Vector) import Data.Vector qualified as Vector import GHC.Generics (Generic) @@ -95,46 +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 - } - --- | 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 @@ -163,14 +144,31 @@ claudeEffortValue ThinkingMinimal = "low" claudeEffortValue lvl = renderThinkingLevel lvl --- | The shape of @claude -p --output-format json@ stdout. -data ClaudeCliResult = ClaudeCliResult - { result :: !Text, - is_error :: !Bool, - session_id :: !(Maybe Text) - } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON) +-- | What the caller's reasoning-effort preference became on this +-- transport's command line. +-- +-- Derived from 'claudeEffortValue' itself rather than from a table +-- written beside it: the adjustment is recorded exactly when the word +-- that reaches @--effort@ differs from the canonical level name, so the +-- description cannot drift away from what the argument vector actually +-- carries. At present that is the single @minimal -> low@ collapse, and +-- a caller asking for @minimal@ and a caller asking for @low@ produce +-- byte-identical command lines — which is precisely why the collapse +-- has to be written down somewhere. +claudeCliThinking :: Options -> Ev.ThinkingTranslation +claudeCliThinking opts = case opts ^. #thinking of + Nothing -> Ev.noThinkingRequested + Just lvl -> + let wire = claudeEffortValue lvl + in Ev.ThinkingTranslation + { requested = Just lvl, + mode = Ev.ThinkingModeFlag, + effortText = Just wire, + budgetTokens = Nothing, + wireField = Just "--effort", + displayText = Nothing, + adjustments = [Ev.EffortClamped lvl wire | wire /= renderThinkingLevel lvl] + } systemPromptArgs :: Context -> [String] systemPromptArgs ctx = case ctx ^. #systemPrompt of @@ -182,57 +180,110 @@ "" -> [] mid -> ["--model", Text.unpack mid] -decodeResult :: ByteString -> Either BaikaiError ClaudeCliResult -decodeResult bs = case eitherDecodeStrict bs of - Left err -> Left (decodeError (Text.pack err)) - Right (Aeson.Array events) -> case findResultEvent events of - Nothing -> Left (decodeError "claude -p: no result event in stdout array") - Just ev -> case parseEither parseJSON ev of - Left err -> Left (decodeError (Text.pack err)) - Right r -> Right r - Right v@(Aeson.Object _) -> case parseEither parseJSON v of - Left err -> Left (decodeError (Text.pack err)) - Right r -> Right r - Right _ -> Left (decodeError "claude -p: expected JSON object or array") - -findResultEvent :: Vector Value -> Maybe Value -findResultEvent = Vector.find isResult - where - isResult (Aeson.Object o) = case KeyMap.lookup "type" o of - Just (Aeson.String "result") -> True - _ -> False - isResult _ = False - runClaudeCli :: ClaudeCliConfig -> Model -> Context -> Options -> IO Resp.Response runClaudeCli cfg m ctx opts = do let (exe, args) = claudeCliCommand cfg m ctx opts start <- getCurrentTime executed <- - trySync $ + Internal.trySync $ run $ cmd exe & addArgs args & setNoStdin & Internal.maybeApply (cfg ^. #workingDir) setWorkingDir end <- getCurrentTime + -- The argument vector is the envelope: for a subprocess it is what + -- crossed the boundary, and there is nothing else to describe the + -- launch with. Built lazily and dropped unforced when the caller + -- asked for no evidence. + let evidenceFor mReport st mErr = do + prepared <- + Build.minimalEvidence + m + opts + Ev.TransportSubprocess + (claudeCliThinking opts) + (Internal.argvEnvelope exe args) + start + end + st + mErr + traverse (observeClaudeCli exe mReport st) prepared + failedWith mReport err = do + ev <- evidenceFor mReport Ev.CallFailed (Just err) + let resp = Resp.errorResponse m end (millisBetween start end) err + pure resp {Resp.evidence = ev, Resp.responseId = mReport >>= (^. #sessionId)} case executed of - Left ex -> pure (Resp.errorResponse m end (millisBetween start end) (exceptionToError ex)) + Left ex -> failedWith Nothing (exceptionToError ex) Right (exitCode, StdoutRaw out, StderrRaw err) -> case exitCode of - ExitFailure n -> pure (Resp.errorResponse m end (millisBetween start end) (processError n (Internal.decodeUtf8Lenient err))) - ExitSuccess -> case decodeResult out of - Left e -> pure (Resp.errorResponse m end (millisBetween start end) e) + ExitFailure n -> failedWith Nothing (processError n (Internal.decodeUtf8Lenient err)) + ExitSuccess -> case Internal.decodeClaudeCliResult out of + Left e -> failedWith Nothing e Right r -> - if is_error r - then pure (Resp.errorResponse m end (millisBetween start end) (providerError (result r))) - else pure (mkResponse m start end (result r)) + if r ^. #isError + then failedWith (Just r) (providerError (r ^. #result)) + else do + ev <- evidenceFor (Just r) Ev.CallSucceeded Nothing + let resp = mkResponse m start end r + pure resp {Resp.evidence = ev} -mkResponse :: Model -> UTCTime -> UTCTime -> Text -> Resp.Response -mkResponse m start end body = +-- | Fill in what the tool reported and what baikai knows about the +-- process it launched. +-- +-- Only ever reached on a call whose caller asked for evidence, which is +-- what makes the version probe affordable here: it spawns a whole extra +-- subprocess, and charging that to a caller who only wanted an answer +-- from a tool they were about to run anyway would be a visible cost on +-- the cheapest possible call. The parsing it reads is the opposite case +-- and happens unconditionally, because the provider had already decoded +-- the tool's output to find the assistant text. +-- +-- Nothing here consults the request. A field the tool did not report +-- stays 'Ev.Unobserved'. +observeClaudeCli :: + FilePath -> + Maybe Internal.ClaudeCliReport -> + Ev.CallStatus -> + Ev.ModelCallEvidence -> + IO Ev.ModelCallEvidence +observeClaudeCli exe mReport st ev = do + identity <- Internal.executableIdentity exe + let session = observedOf (mReport >>= (^. #sessionId)) + reported = observedOf (mReport >>= (^. #reportedModel)) + used = mReport >>= (^. #usage) + pure $ + ev + -- A subprocess has no endpoint URL. Recording the model's base + -- URL here would suggest an HTTP request that was never made, so + -- the resolved executable path takes its place. + & #endpoint . #endpoint .~ Just (fromMaybe (Text.pack exe) (identity ^. #resolvedPath)) + -- For this transport the tool is the implementation, so its own + -- version is what determines behaviour — not this package's. + & #endpoint . #implementationVersion .~ (identity ^. #version) + & #responseId .~ session + & #observedModel .~ reported + & #usage .~ observedOf used + & #responseCommitment .~ commitment used + & #strength .~ Internal.subprocessStrength session reported + where + commitment used = case (st, mReport) of + (Ev.CallSucceeded, Just r) -> + Ev.Observed + ( Ev.commitmentDigest + (Internal.cliResponseEnvelope (r ^. #result) (fromMaybe zeroUsage used)) + ) + _ -> Ev.Unobserved + +observedOf :: Maybe a -> Ev.Observed a +observedOf = maybe Ev.Unobserved Ev.Observed + +mkResponse :: Model -> UTCTime -> UTCTime -> Internal.ClaudeCliReport -> Resp.Response +mkResponse m start end r = Resp.Response { Resp.message = AssistantPayload - { content = Vector.singleton (AssistantText (TextContent body)), - usage = zeroUsage, + { content = Vector.singleton (AssistantText (TextContent (r ^. #result))), + usage = reportedUsage r, stopReason = Stop, errorMessage = Nothing, timestamp = Just end @@ -240,23 +291,22 @@ Resp.model = m, Resp.api = AnthropicMessagesCli, Resp.provider = m ^. #provider, - Resp.responseId = Nothing, + Resp.responseId = r ^. #sessionId, Resp.latencyMs = millisBetween start end, - Resp.errorInfo = Nothing + Resp.errorInfo = Nothing, + Resp.evidence = Nothing } +-- | The tool's own token counts, or zeroes when it reported none. +-- +-- 'Resp.Response' has nowhere to say "the tool stayed silent", so a +-- silent tool still yields 'zeroUsage' here. The evidence record does +-- have somewhere to say it, and says it: see 'observeClaudeCli'. +reportedUsage :: Internal.ClaudeCliReport -> Usage +reportedUsage r = fromMaybe zeroUsage (r ^. #usage) + millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double)) - -trySync :: IO a -> IO (Either SomeException a) -trySync action = do - r <- try action - case r of - Left e - | Just (SomeAsyncException _) <- (fromException e :: Maybe SomeAsyncException) -> - throwIO e - | otherwise -> pure (Left e) - Right a -> pure (Right a) exceptionToError :: SomeException -> BaikaiError exceptionToError e = fromMaybe (providerError (Text.pack (displayException e))) (fromException e) diff --git a/src/Baikai/Provider/Claude/Interactive.hs b/src/Baikai/Provider/Claude/Interactive.hs --- a/src/Baikai/Provider/Claude/Interactive.hs +++ b/src/Baikai/Provider/Claude/Interactive.hs @@ -5,6 +5,11 @@ -- "Baikai.Provider.Claude.Cli": that module drives @claude -p@ as a -- batch completion provider, while this module starts the interactive -- terminal UI and returns only after the CLI exits. +-- +-- A safety policy Claude Code cannot express is refused before launch +-- rather than dropped: both the pure command builder and the launcher +-- return 'Either' 'AgentRenderError', and a 'Left' means no process was +-- started. module Baikai.Provider.Claude.Interactive ( ClaudeInteractiveConfig, executable, @@ -15,12 +20,15 @@ ) where +import Baikai.Agent (AgentProvider (..), AgentRenderError (..)) import Baikai.Interactive ( InteractiveLaunchRequest, InteractiveLaunchResult, InteractiveProvider (..), InteractiveSafety (..), interactiveLaunchResult, + renderCodexApprovalPolicy, + renderCodexSandboxMode, ) import Baikai.Prelude import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) @@ -46,32 +54,47 @@ -- Code launch. The final positional argument is the initial user -- prompt. The prompt is preceded by @--@ because Claude's -- @--allowedTools@ and @--add-dir@ flags are variadic. +-- +-- Returns 'Left' when the request's safety policy is one Claude Code +-- cannot express, so a caller who asked to be constrained never +-- receives a command that is not. claudeInteractiveCommand :: - ClaudeInteractiveConfig -> InteractiveLaunchRequest -> (FilePath, [String]) -claudeInteractiveCommand cfg req = - ( cfg ^. #executable, - modelArgs req - <> effortArgs req - <> systemPromptArgs req - <> extraDirArgs req - <> safetyArgs req - <> fmap Text.unpack (cfg ^. #extraArgs) - <> fmap Text.unpack (req ^. #extraArgs) - <> ["--", Text.unpack (req ^. #userPrompt)] - ) + ClaudeInteractiveConfig -> + InteractiveLaunchRequest -> + Either AgentRenderError (FilePath, [String]) +claudeInteractiveCommand cfg req = do + safety <- safetyArgs req + pure + ( cfg ^. #executable, + modelArgs req + <> effortArgs req + <> systemPromptArgs req + <> extraDirArgs req + <> safety + <> fmap Text.unpack (cfg ^. #extraArgs) + <> fmap Text.unpack (req ^. #extraArgs) + <> ["--", Text.unpack (req ^. #userPrompt)] + ) -- | Launch Claude Code with inherited stdin, stdout, and stderr so -- the local CLI owns the interactive terminal experience. +-- +-- A 'Left' result means no process was started: the requested safety +-- policy was refused before launch. A 'Right' carrying a non-zero +-- 'System.Exit.ExitCode' means the session ran and exited non-zero. launchClaudeInteractive :: - ClaudeInteractiveConfig -> InteractiveLaunchRequest -> IO InteractiveLaunchResult -launchClaudeInteractive cfg req = do - let (exe, args) = claudeInteractiveCommand cfg req - code <- - run $ - cmd exe - & addArgs args - & maybe id setWorkingDir (req ^. #workingDir) - pure (interactiveLaunchResult InteractiveClaude code) + ClaudeInteractiveConfig -> + InteractiveLaunchRequest -> + IO (Either AgentRenderError InteractiveLaunchResult) +launchClaudeInteractive cfg req = case claudeInteractiveCommand cfg req of + Left err -> pure (Left err) + Right (exe, args) -> do + code <- + run $ + cmd exe + & addArgs args + & maybe id setWorkingDir (req ^. #workingDir) + pure (Right (interactiveLaunchResult InteractiveClaude code)) modelArgs :: InteractiveLaunchRequest -> [String] modelArgs req = case Text.strip <$> req ^. #modelId of @@ -100,10 +123,25 @@ extraDirArgs req = concatMap (\dir -> ["--add-dir", dir]) (req ^. #extraDirs) -safetyArgs :: InteractiveLaunchRequest -> [String] +-- | 'DefaultSafety' means the caller declined to specify a policy, so +-- rendering nothing honors it rather than downgrading it. An empty +-- allow-list restricts nothing, so it too renders nothing. Only a +-- Codex sandbox policy is a restriction Claude Code cannot express, +-- and that is refused. +safetyArgs :: InteractiveLaunchRequest -> Either AgentRenderError [String] safetyArgs req = case req ^. #safety of - ClaudeAllowedTools [] -> [] + DefaultSafety -> Right [] + ClaudeAllowedTools [] -> Right [] ClaudeAllowedTools tools -> - ["--allowedTools", Text.unpack (Text.intercalate "," tools)] - DefaultSafety -> [] - CodexSandbox _ _ -> [] + Right ["--allowedTools", Text.unpack (Text.intercalate "," tools)] + CodexSandbox sandbox approval -> + Left + ( SafetyNotExpressible + AgentClaude + ( "Claude Code cannot express a Codex sandbox policy (" + <> renderCodexSandboxMode sandbox + <> ", " + <> renderCodexApprovalPolicy approval + <> "); use ClaudeAllowedTools, or DefaultSafety to accept Claude's own default" + ) + ) 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,8 +7,15 @@ -- compatibility guarantees. Import the public provider module for stable application code. module Baikai.Provider.Claude.Internal.Request ( mapRequest, + planRequest, + planSpeed, + planThinking, + describeThinkingFor, ThinkingPlan (..), + SamplingPlan (..), + uncappedMaxTokensFloor, computeThinking, + normalizeToolCallId, ) where @@ -15,21 +23,30 @@ import Baikai.Compat (AnthropicMessagesCompat (..), AnthropicThinkingStyle (..)) import Baikai.Content qualified as Content import Baikai.Context (Context (..)) +import Baikai.Evidence + ( ThinkingAdjustment (..), + ThinkingMode (..), + ThinkingTranslation (..), + noThinkingRequested, + ) import Baikai.Message qualified as Msg import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) -import Baikai.ResponseFormat (ResponseFormat (..)) -import Baikai.ThinkingLevel (ThinkingLevel (..), thinkingTokenBudget) +import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) +import Baikai.Speed (Speed (..)) +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 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 @@ -39,23 +56,53 @@ 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. -- ============================================================ -mapRequest :: Model -> Context -> Options -> Either Text Messages.CreateMessage +-- | 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. +-- +-- The 'ThinkingTranslation' is returned rather than reconstructed +-- downstream because this is the only place that knows all of it: the +-- host compatibility lookup, the model's reasoning capability, the +-- adaptive effort vocabulary, and the max-tokens interaction below all +-- feed into it. A trace sink asked to re-derive it would have to +-- reimplement every one of them. +mapRequest :: + Model -> Context -> Options -> Either Text (Messages.CreateMessage, ThinkingTranslation) mapRequest m ctx opts = do - msgs <- traverse mapMessage (Vector.toList (ctx ^. #messages)) + case opts ^. #toolChoice of + Just Tool.ToolChoiceRequired | not (anthropicMessagesCompatFor m).supportsForcedToolChoice -> unsupportedForcedChoice + Just (Tool.ToolChoiceSpecific _) | not (anthropicMessagesCompatFor m).supportsForcedToolChoice -> unsupportedForcedChoice + _ -> pure () + mapM_ + ( \msg -> case msg of + Msg.AssistantMessage payload -> + mapM_ + ( \block -> case block of + Content.AssistantThinking th + | Just _ <- Content.replayState th -> + Left "This endpoint cannot replay provider-scoped reasoning state; use its originating API and model" + _ -> pure () + ) + (payload ^. #content) + _ -> pure () + ) + (ctx ^. #messages) + 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 - plan0 = computeThinking compat m (opts ^. #thinking) - requested = clamp (baseTokens + fromMaybe 0 (budget plan0)) - plan = case budget plan0 of - Just b - | requested <= b -> emptyThinkingPlan - _ -> plan0 + (plan, sampling, translation) = planRequest m opts maxTokensField_ = case budget plan of Just b -> clamp (baseTokens + b) Nothing -> clamp baseTokens @@ -71,21 +118,153 @@ Nothing -> Nothing outputConfigField = mergeEffort (effort plan) (fmap mkAnthropicOutputConfig (opts ^. #responseFormat)) pure - Messages._CreateMessage - { Messages.model = m ^. #modelId, - 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.tools = toolsField, - Messages.tool_choice = toolChoiceField, - Messages.cache_control = cacheControlField, - Messages.thinking = field plan, - Messages.output_config = outputConfigField - } + ( Messages._CreateMessage + { Messages.model = m ^. #modelId, + Messages.messages = Vector.fromList msgs, + Messages.max_tokens = maxTokensField_, + Messages.system = fmap Messages.SystemPromptText (ctx ^. #systemPrompt), + 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, + Messages.speed = fst (planSpeed compat (opts ^. #speed)), + Messages.thinking = field plan, + Messages.output_config = outputConfigField + }, + translation + ) +unsupportedForcedChoice :: Either Text () +unsupportedForcedChoice = Left "This model does not support forced tool choice; use ToolChoiceAuto or ToolChoiceNone" + +-- | 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. 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 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 <> snd (planSpeed compat (opts ^. #speed))))) + 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 (compat ^. #supportsSamplingParameters) + 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 (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) + mergeEffort :: Maybe Text -> Maybe Messages.OutputConfig -> Maybe Messages.OutputConfig mergeEffort Nothing cfg = cfg mergeEffort (Just e) Nothing = Just (Messages.effortConfig e) @@ -101,7 +280,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)]) @@ -156,27 +335,70 @@ budget = Nothing } +-- | Build the SDK's thinking configuration and, beside it, the +-- provider-neutral description of what the caller's level became. +-- +-- The two travel together because they are two views of one decision. +-- Adaptive requests explicitly ask for summarized display, using the catalog +-- thinking style. Budget requests retain their existing provider default. +-- Display changes visibility only; it does not establish reasoning depth. +-- Returning only the first is what this provider used to do, and it is +-- why a caller could never tell an honoured request from a dropped one. computeThinking :: AnthropicMessagesCompat -> Model -> Maybe ThinkingLevel -> - ThinkingPlan -computeThinking _ _ Nothing = emptyThinkingPlan + (ThinkingPlan, ThinkingTranslation) +computeThinking _ _ Nothing = (emptyThinkingPlan, noThinkingRequested) computeThinking compat m (Just lvl) - | not (m ^. #reasoning) = emptyThinkingPlan + | not (m ^. #reasoning) = + ( emptyThinkingPlan, + ThinkingTranslation + { requested = Just lvl, + mode = ThinkingModeUnsupported, + effortText = Nothing, + budgetTokens = Nothing, + wireField = Nothing, + displayText = Nothing, + adjustments = [ThinkingDroppedUnsupportedModel lvl] + } + ) | thinkingStyle compat == AnthropicThinkingAdaptive = - ThinkingPlan - { field = Just Messages.ThinkingAdaptive, - effort = adaptiveEffort lvl, - budget = Nothing - } + let e = adaptiveEffort lvl + in ( ThinkingPlan + { field = Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized), + effort = e, + budget = Nothing + }, + ThinkingTranslation + { requested = Just lvl, + mode = ThinkingModeAdaptive, + effortText = e, + budgetTokens = Nothing, + wireField = Just "thinking", + displayText = Just "summarized", + adjustments = adaptiveAdjustments lvl e + } + ) | otherwise = let b = thinkingTokenBudget lvl - in ThinkingPlan - { field = Just Messages.ThinkingEnabled {Messages.budget_tokens = b}, - effort = Nothing, - budget = Just b - } + in ( ThinkingPlan + { field = Just Messages.ThinkingEnabled {Messages.budget_tokens = b}, + effort = Nothing, + budget = Just b + }, + ThinkingTranslation + { requested = Just lvl, + mode = ThinkingModeBudget, + effortText = Nothing, + budgetTokens = Just b, + -- A budget expresses the requested level exactly, so + -- there is nothing to adjust. + wireField = Just "thinking", + displayText = Nothing, + adjustments = [] + } + ) adaptiveEffort :: ThinkingLevel -> Maybe Text adaptiveEffort = \case @@ -187,6 +409,37 @@ ThinkingXHigh -> Just "xhigh" ThinkingMax -> Just "max" +-- | What Anthropic's adaptive vocabulary did to the requested level. +-- +-- Derived from what 'adaptiveEffort' actually produced rather than from +-- a second table beside it, so the two cannot drift. 'Nothing' means no +-- effort field is sent at all, which leaves the request +-- wire-indistinguishable from a caller who expressed no preference and +-- took Anthropic's own default depth. An effort word that differs from +-- the level's canonical name is a clamp onto the nearest word the +-- adaptive vocabulary has — Anthropic's has no @minimal@. +adaptiveAdjustments :: ThinkingLevel -> Maybe Text -> [ThinkingAdjustment] +adaptiveAdjustments lvl = \case + Nothing -> [EffortOmitted lvl] + Just wire + | wire == renderThinkingLevel lvl -> [] + | otherwise -> [EffortClamped lvl wire] + +-- | Record that, after all, nothing about thinking reached the wire. +-- +-- Every field describing a wire value is cleared, because after the drop +-- there is none. The adjustment is appended rather than replacing the +-- list so a reader sees the order things were applied in. +dropThinking :: ThinkingAdjustment -> ThinkingTranslation -> ThinkingTranslation +dropThinking adj t = + t + & #mode .~ ThinkingModeUnsupported + & #effortText .~ Nothing + & #budgetTokens .~ Nothing + & #wireField .~ Nothing + & #displayText .~ Nothing + & #adjustments %~ (<> [adj]) + -- | Map a baikai 'Tool.Tool' into the upstream Anthropic -- 'ClaudeTool.ToolDefinition'. The SDK helper is used to populate -- the ordinary typed fields; the raw request shaper later restores @@ -218,37 +471,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, @@ -259,22 +578,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 @@ -287,10 +625,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} @@ -324,3 +668,12 @@ nonEmpty t | Text.null t = Nothing | otherwise = Just t + +-- | One capability gate shared by wire mapping, headers and the describer. +planSpeed :: AnthropicMessagesCompat -> Maybe Speed -> (Maybe Messages.Speed, [ThinkingAdjustment]) +planSpeed compat = \case + Nothing -> (Nothing, []) + Just SpeedStandard -> (Just Messages.SpeedStandard, []) + Just SpeedFast + | compat ^. #supportsFastMode -> (Just Messages.SpeedFast, []) + | otherwise -> (Nothing, [FastModeDroppedUnsupportedModel]) 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,1037 @@ +{-# 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.CacheRetention (CacheRetention (..)) +import Baikai.Content qualified as Content +import Baikai.Context (Context (..)) +import Baikai.Cost (CostEstimateReason (CacheDurationNotReported, SpeedNotReported), estimateCost) +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 Baikai.Usage.Normalize qualified as Normalize +import Claude.V1.Messages qualified as Messages +import Control.Applicative ((<|>)) +import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try) +import Control.Lens ((%~), (&), (.~), (^.)) +import Data.Aeson (Value) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap +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.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Vector (Vector) +import Data.Vector qualified as Vector +import Data.Version (showVersion) +import GHC.Generics (Generic) +import Network.HTTP.Types.Header (RequestHeaders) +import Paths_baikai_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 + (Text.pack (Client.showBaseUrl (Client.baseUrl (call ^. #clientEnv))) <> "/v1/messages") + 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 + & #cacheDuration .~ shapedCacheDuration (call ^. #requestBody) + & #fastRequested .~ shapedFastRequested (call ^. #requestBody), + 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. +-- +-- Observed fields never borrow the request. An observation the provider did +-- not make stays 'Ev.Unobserved'. The separate summary diagnostic relates +-- the translated request to completed blocks without claiming observed effort. +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 + & #thinking . #adjustments %~ (<> summaryDiagnostics st ass (ev ^. #thinking)) + & #responseCommitment .~ responseCommitment st ass + & #strength + .~ Ev.deriveStrength + (ass ^. #observedModel) + (ass ^. #providerRequestId) + (maybe Ev.Unobserved Ev.Observed (ass ^. #responseId)) + +-- | Diagnose visibility after a successful response, without inventing an +-- observation of effort or weakening the original translation. Adaptive calls +-- may legitimately contain no thinking blocks. Failed streams may simply have +-- stopped before text arrived, so neither case claims an unavailable summary. +summaryDiagnostics :: Ev.CallStatus -> Assembler -> Ev.ThinkingTranslation -> [Ev.ThinkingAdjustment] +summaryDiagnostics st ass translation + | st == Ev.CallSucceeded, + Just _ <- translation ^. #requested, + translation ^. #mode `elem` [Ev.ThinkingModeAdaptive, Ev.ThinkingModeBudget], + not (null thinkingBlocks), + all unreadable thinkingBlocks = + [Ev.ThinkingSummaryUnavailable] + | otherwise = [] + where + thinkingBlocks = [t | Content.AssistantThinking t <- Vector.toList (blocksInOrder ass)] + unreadable t = t ^. #redacted || Text.null (t ^. #thinking) + +-- | 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, + cacheDuration :: !(Maybe CacheRetention), + fastRequested :: !Bool, + stopReason :: !Stop.StopReason, + -- | Refusal detail reported in the delta, consumed at message_stop. + stopDetails :: !(Maybe Messages.StopDetails), + -- | 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, + cacheDuration = Nothing, + fastRequested = False, + stopReason = Stop.Stop, + stopDetails = Nothing, + 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'. + known category getter = case u ^. #availability of + Just facts | category `Set.notMember` Usage.missingCategories facts -> Just (getter u) + _ -> Nothing + u' = + Usage.observeBilling (maybe [] (Set.toList . Usage.billingFacts) (u ^. #availability) <> toolBilling su.stream_server_tool_use) $ + Normalize.normalizeUsage + Normalize.ExclusiveInput + ( Normalize.ReportedUsage + (su.stream_input_tokens <|> known Usage.InputUsage Usage.inputTokens) + (Just su.output_tokens) + (su.stream_cache_read_input_tokens <|> known Usage.CacheReadUsage Usage.cacheReadTokens) + (su.stream_cache_creation_input_tokens <|> known Usage.CacheWriteUsage Usage.cacheWriteTokens) + ((Messages.thinking_tokens <$> su.stream_output_tokens_details) <|> (u ^. #reasoningTokens)) + ) + in ([], ass & #stopReason .~ stopR & #stopDetails .~ (md ^. #stop_details) & #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. + details = ass ^. #stopDetails + refusalCategory = details >>= (\d -> d.category) + explanation = details >>= (\d -> d.explanation) + refusal = + contentFiltered + ( "Anthropic refused to generate a response (stop_reason=refusal)" + <> maybe "" (\c -> " [category=" <> c <> "]") refusalCategory + <> maybe "" (": " <>) explanation + ) + & #refusalCategory .~ refusalCategory + 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, + Content.replayState = Nothing + } + 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, + Content.replayState = Nothing + } + 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. +-- +-- The duration comes from the shaped request body, so a compatibility +-- downgrade to a short cache cannot accidentally incur the long-write rate. +finalUsage :: Assembler -> Usage.Usage +finalUsage ass = + let usageBare = if ass ^. #usageReported then ass ^. #usage else Normalize.normalizeUsage Normalize.ExclusiveInput (Normalize.ReportedUsage Nothing Nothing Nothing Nothing Nothing) + calculated = Pricing.computeCostForService (ass ^. #cacheDuration) Nothing (ass ^. #model) usageBare + reasons = + [CacheDurationNotReported | usageBare ^. #cacheWriteTokens > 0, Nothing <- [ass ^. #cacheDuration]] + <> [SpeedNotReported | ass ^. #fastRequested, not (any isSpeed (maybe [] (Set.toList . Usage.billingFacts) (usageBare ^. #availability)))] + isSpeed (Usage.BillingSpeed _) = True + isSpeed _ = False + in usageBare & #cost .~ estimateCost reasons calculated + +shapedFastRequested :: Aeson.Value -> Bool +shapedFastRequested (Aeson.Object body) = KeyMap.lookup "speed" body == Just (Aeson.String "fast") +shapedFastRequested _ = False + +shapedCacheDuration :: Aeson.Value -> Maybe CacheRetention +shapedCacheDuration (Aeson.Object body) = case KeyMap.lookup "cache_control" body of + Just (Aeson.Object marker) -> Just $ case KeyMap.lookup "ttl" marker of + Just (Aeson.String "1h") -> CacheRetentionLong + _ -> CacheRetentionShort + _ -> Nothing +shapedCacheDuration _ = Nothing + +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 a total across cache writes. The final +-- calculation uses the duration selected by the actual shaped request body. +anthroUsageToBaikai :: Messages.Usage -> Usage.Usage +anthroUsageToBaikai u = + Usage.observeBilling ([Usage.BillingServiceTier tier | Just tier <- [u ^. #service_tier]] <> [Usage.BillingSpeed speed | Just value <- [u ^. #speed], Aeson.String speed <- [Aeson.toJSON value]] <> toolBilling (u ^. #server_tool_use)) $ + Normalize.normalizeUsage + Normalize.ExclusiveInput + ( Normalize.ReportedUsage + (Just (u ^. #input_tokens)) + (Just (u ^. #output_tokens)) + (u ^. #cache_read_input_tokens) + (u ^. #cache_creation_input_tokens) + (fmap (^. #thinking_tokens) (u ^. #output_tokens_details)) + ) + +-- Server-side tool products are outside the token-rate calculation. +toolBilling :: Maybe Messages.ServerToolUseUsage -> [Usage.BillingFact] +toolBilling Nothing = [] +toolBilling (Just usage) = [Usage.BillingServerToolUse | fromMaybe 0 (usage ^. #web_search_requests) + fromMaybe 0 (usage ^. #tool_search_requests) > 0] + +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,34 +16,90 @@ 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) import Network.HTTP.Types.Status qualified as Status import Servant.Client qualified as Client +-- | Response-level metadata captured once, before the first event. +-- +-- Header capture is an allow-list: a response header is recorded only +-- if its name appears in 'capturedHeaderNames'. A denylist would leak +-- whatever header a future gateway decides to add. +-- +-- Names are recorded folded to lowercase, so a reader can look one up +-- without case-folding first. +data ResponseMetadata = ResponseMetadata + { httpStatus :: !Int, + headers :: ![(Text, Text)] + } + deriving stock (Eq, Show, Generic) + +-- | The response headers worth recording. Anthropic issues +-- @request-id@; gateways in front of it commonly add @x-request-id@ +-- and @cf-ray@. None of these can carry a credential: they are values +-- the server chose, not values baikai sent. +-- +-- The order is a preference order as well as an allow-list. A consumer +-- picking one correlation identifier out of a response should take the +-- first of these that is present, so Anthropic's own identifier wins +-- over a gateway's when both are there. +capturedHeaderNames :: [CI SBS.ByteString] +capturedHeaderNames = ["request-id", "x-request-id", "cf-ray"] + +-- | Status and allow-listed headers, read straight off the response. +responseMetadata :: HTTP.Response body -> ResponseMetadata +responseMetadata response = + ResponseMetadata + { httpStatus = Status.statusCode (HTTP.responseStatus response), + headers = + [ (decodeLenient (CI.foldedCase name), decodeLenient value) + | (name, value) <- HTTP.responseHeaders response, + name `elem` capturedHeaderNames + ] + } + -- | POST the request to @/v1/messages@ with @stream=true@ and feed each --- decoded SSE event to the callback. A non-2xx response is classified --- from status, @Retry-After@, and body and delivered as one 'Left'. +-- decoded SSE event to the second callback. A non-2xx response is +-- classified from status, @Retry-After@, and body and delivered as one +-- 'Left'. +-- +-- The first callback receives the response's 'ResponseMetadata' exactly +-- once, before any event. It is a separate callback rather than a +-- widening of the per-event one because the per-event callback runs +-- once per SSE event — potentially thousands of times per call — and +-- response-level data does not belong on that hot path. claudeSseStream :: Client.ClientEnv -> Text -> Maybe Text -> Messages.CreateMessage -> + (ResponseMetadata -> IO ()) -> (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> IO () claudeSseStream env apiKey anthropicVersion req = @@ -49,6 +110,7 @@ Text -> Maybe Text -> Aeson.Value -> + (ResponseMetadata -> IO ()) -> (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> IO () claudeSseStreamValue env apiKey anthropicVersion = @@ -68,41 +130,75 @@ Client.ClientEnv -> RequestHeaders -> Aeson.Value -> + (ResponseMetadata -> IO ()) -> (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> IO () -claudeSseStreamValueWithHeaders env requestHeaders requestBody onEvent = do - let base = Client.baseUrl env - secure = case Client.baseUrlScheme base of +claudeSseStreamValueWithHeaders env requestHeaders requestBody onMetadata onEvent = do + 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 - 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) (`sseFromResponse` onEvent) + Client.Https -> True, + HTTP.host = S8.pack (Client.baseUrlHost base), + HTTP.port = Client.baseUrlPort base, + HTTP.method = "POST", + HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> "/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 +-- success and the non-2xx path. A failed call's correlation identifier +-- is if anything more valuable than a successful one's, since it is +-- precisely what a provider support request needs. sseFromResponse :: HTTP.Response HTTP.BodyReader -> + (ResponseMetadata -> IO ()) -> (Either BaikaiError Messages.MessageStreamEvent -> IO ()) -> IO () -sseFromResponse response onEvent = do +sseFromResponse response onMetadata onEvent = do let st = HTTP.responseStatus response + onMetadata (responseMetadata response) if not (Status.statusIsSuccessful st) then do bodyChunks <- HTTP.brConsume (HTTP.responseBody response) + now <- getCurrentTime let bodyText = decodeLenient (SBS.concat bodyChunks) - retryAfter = - parseRetryAfterSeconds . decodeLenient - =<< lookup (CI.mk "Retry-After") (HTTP.responseHeaders response) + headerText name = decodeLenient <$> lookup (CI.mk name) (HTTP.responseHeaders response) + -- The server's own Date is the reference instant for an + -- HTTP-date Retry-After, which CDN-fronted hosts send on a + -- 429; the local clock is the fallback. Using the response's + -- clock keeps this machine's skew out of the hint. + reference = fromMaybe now (parseHttpDate =<< headerText "Date") + retryAfter = retryAfterSecondsAt reference =<< headerText "Retry-After" onEvent (Left (httpError (Status.statusCode st) retryAfter bodyText)) else do lineBufRef <- IORef.newIORef SBS.empty @@ -112,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 @@ -152,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,14 @@ 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 Baikai.Provider.Claude.Internal.Request (planSpeed) +import Claude.V1.Messages qualified as Messages import Control.Exception (throwIO) import Control.Lens ((^.)) import Crypto.Hash (Digest, SHA256) @@ -28,26 +38,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 -> @@ -64,12 +57,16 @@ id (\v -> (("anthropic-version", Text.encodeUtf8 v) :)) anthropicVersion - ( sessionHeaders + ( speedHeaders + <> sessionHeaders <> [ ("x-api-key", Text.encodeUtf8 apiKey), ("Accept", "text/event-stream"), ("Content-Type", "application/json") ] ) + speedHeaders = case fst (planSpeed compat (opts ^. #speed)) of + Just Messages.SpeedFast -> [("anthropic-beta", "fast-mode-2026-02-01")] + _ -> [] sessionHeaders = if sendSessionAffinityHeaders compat then [("x-session-affinity", Text.encodeUtf8 (sessionAffinityValue ctx))] @@ -85,13 +82,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 = @@ -134,31 +148,22 @@ message = "provider stream exceeded timeoutMs=" <> Text.pack (show ms), httpStatus = Nothing, retryAfterSeconds = Nothing, - exitCode = Nothing + exitCode = Nothing, + refusalCategory = Nothing } -newClientEnv :: Text -> IO Client.ClientEnv -newClientEnv baseUrl = do - parsed <- Client.parseBaseUrl (Text.unpack baseUrl) - manager <- - TLS.newTlsManagerWith - TLS.tlsManagerSettings - { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone - } - pure (Client.mkClientEnv manager parsed) - +-- | Apply caller overrides over the provider's own headers. +-- +-- The key type already carries the case-insensitivity rule, so the +-- overrides cannot contain two spellings of one name and the fold only +-- has to replace what the provider set. applyHeaderOverrides :: RequestHeaders -> - [(Text, Text)] -> + [(HeaderName, Text)] -> RequestHeaders applyHeaderOverrides = foldl addHeader where addHeader headers (name, value) = - let nameBytes = Text.encodeUtf8 name - ciName = CI.mk nameBytes + let ciName = CI.mk (Text.encodeUtf8 (renderHeaderName name)) in (ciName, Text.encodeUtf8 value) : filter ((/= ciName) . fst) headers - -{-# NOINLINE clientEnvCache #-} -clientEnvCache :: MVar (Map.Map Text Client.ClientEnv) -clientEnvCache = unsafePerformIO (newMVar Map.empty) diff --git a/test/CliEvidenceSpec.hs b/test/CliEvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/CliEvidenceSpec.hs @@ -0,0 +1,397 @@ +-- | End-to-end model-call evidence for the @claude -p@ subprocess +-- provider. +-- +-- Every case here runs a real child process — a few lines of @sh@ +-- written into a temporary directory that print recorded @claude@ JSON +-- and exit. Nothing is stubbed: the argument vector is rendered by +-- 'ClaudeCli.claudeCliCommand', the process is spawned by the real +-- provider, the output is decoded by the real parser, and the evidence +-- is assembled and emitted through the real trace path. No credential +-- and no coding-agent binary is required. +-- +-- Assertions go through the encoded JSON rather than through Haskell +-- record accessors, because the JSON is the contract other systems pin +-- against, and it spells its fields in snake_case where a Haskell +-- mirror would silently paper over a rename. +module CliEvidenceSpec (tests) where + +import Baikai +import Baikai.Provider.Claude.Cli qualified as ClaudeCli +import Baikai.Trace (withTraceStreamWith) +import Baikai.Trace.Event (TraceEvent (..)) +import Baikai.Trace.Sink (TraceSink (..)) +import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.IO qualified as TextIO +import Data.Vector qualified as Vector +import GHC.Generics (Generic) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream +import System.Directory (getPermissions, setOwnerExecutable, setPermissions) +import System.FilePath (()) +import System.IO.Temp (withSystemTempDirectory) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + -- Named so a documented @--test-options='--pattern CliEvidence'@ + -- actually selects it. A pattern that matches nothing reports + -- "All 0 tests passed". + "CliEvidenceSpec: Claude CLI model-call evidence" + [ successEvidenceTest, + silentToolTest, + minimalCollapseTest, + indistinguishableCallsTest, + failedRunTest, + optOutTest + ] + +-- ============================================================ +-- The cases +-- ============================================================ + +successEvidenceTest :: TestTree +successEvidenceTest = + testCase "a recorded run records what the tool reported" $ do + outcome <- replay recordedResult baseOptions + ev <- oneEvidence (outcome ^. #events) + field "status" ev @?= Just (String "succeeded") + field "run_id" ev @?= Just (String "run-55") + field "requested_model" ev @?= Just (String "sonnet") + + -- The session identifier the provider used to decode and then throw + -- away, one line before hardcoding responseId = Nothing. + field "response_id" ev @?= Just (observedJson "01890000-0000-4000-8000-000000000001") + + -- The model the tool named as having consumed tokens, complete with + -- its context-window variant marker, and demonstrably not the + -- model the caller configured. + field "observed_model" ev @?= Just (observedJson "claude-opus-5[1m]") + assertBool + "observed_model must not be the configured model" + (field "observed_model" ev /= Just (observedJson "sonnet")) + + -- A subprocess cannot carry an HTTP correlation header, and the + -- tool does not echo its effort setting. Neither is invented. + field "provider_request_id" ev @?= Just (String "unobserved") + field "observed_thinking" ev @?= Just (String "unobserved") + + -- Tied to the declaration mechanically: raising declaredStrength + -- for this transport without the transport reaching it fails here. + field "strength" ev @?= Just (Aeson.toJSON (declaredStrength AnthropicMessagesCli)) + assertDigest "request_commitment" ev + assertDigest "request_configuration" ev + assertObservedDigest "response_commitment" ev + + -- Not zeroUsage: the tool's own counts, with Anthropic's already + -- disjoint prompt classes carried through unmodified. + case observedObject "usage" ev of + Nothing -> assertFailure ("expected an observed usage, got: " <> show (field "usage" ev)) + Just u -> do + KeyMap.lookup "input_tokens" u @?= Just (Number 2) + KeyMap.lookup "output_tokens" u @?= Just (Number 6) + KeyMap.lookup "cache_read_input_tokens" u @?= Nothing + KeyMap.lookup "cache_read_tokens" u @?= Just (Number 15185) + KeyMap.lookup "cache_write_tokens" u @?= Just (Number 7455) + + -- A subprocess has no endpoint URL, so the resolved executable + -- path stands in its place, and the tool's own version is the + -- implementation version because for this transport the tool is + -- the implementation. + case field "endpoint" ev of + Just (Object o) -> do + KeyMap.lookup "transport" o @?= Just (String "subprocess") + KeyMap.lookup "endpoint" o @?= Just (String (Text.pack (outcome ^. #executable))) + KeyMap.lookup "implementation_version" o @?= Just (String "fake-claude 9.9.9") + other -> assertFailure ("expected an endpoint object, got: " <> show other) + +silentToolTest :: TestTree +silentToolTest = + testCase "A ZERO EXIT WITH NO IDENTIFIER AND NO MODEL STAYS AT requested_only" $ do + -- IR-3's rule and the reason this plan exists. A coding-agent CLI + -- that exits zero has demonstrated that it ran and did not crash. + -- Subprocess calls almost always exit zero, so encoding that as + -- corroboration would make the weakest evidence in the system look + -- like the strongest. + outcome <- replay silentResult baseOptions + ev <- oneEvidence (outcome ^. #events) + field "status" ev @?= Just (String "succeeded") + field "strength" ev @?= Just (String "requested_only") + field "response_id" ev @?= Just (String "unobserved") + field "observed_model" ev @?= Just (String "unobserved") + field "usage" ev @?= Just (String "unobserved") + +minimalCollapseTest :: TestTree +minimalCollapseTest = + testCase "a minimal request records the --effort low collapse it actually sent" $ do + -- The description and the argument vector are asserted together so + -- they cannot drift apart. + outcome <- replay recordedResult (baseOptions & #thinking .~ Just ThinkingMinimal) + assertBool + ("the argument vector must carry --effort low: " <> show (outcome ^. #argv)) + (["--effort", "low"] `isSublistOf` (outcome ^. #argv)) + ev <- oneEvidence (outcome ^. #events) + case field "thinking" ev of + Just (Object t) -> do + KeyMap.lookup "requested" t @?= Just (String "minimal") + KeyMap.lookup "mode" t @?= Just (String "flag") + KeyMap.lookup "effort_text" t @?= Just (String "low") + KeyMap.lookup "wire_field" t @?= Just (String "--effort") + KeyMap.lookup "budget_tokens" t @?= Just Null + KeyMap.lookup "adjustments" t + @?= Just + ( Array + ( Vector.singleton + ( Object + ( KeyMap.fromList + [ ("kind", String "effort_clamped"), + ("requested", String "minimal"), + ("wire", String "low") + ] + ) + ) + ) + ) + other -> assertFailure ("expected a thinking translation, got: " <> show other) + +indistinguishableCallsTest :: TestTree +indistinguishableCallsTest = + testCase "TWO CALLS THE TOOL CANNOT TELL APART PRODUCE EVIDENCE THAT CAN" $ do + -- This is the case that demonstrates why the record exists rather + -- than merely that a field is populated. A caller asking for + -- minimal and a caller asking for low send byte-identical command + -- lines, so nothing downstream of the argument vector could ever + -- recover the difference — including the request commitment digest, + -- which is computed over that vector. The translation is the only + -- place the collapse survives. + withFakeClaude recordedResult $ \runOnce -> do + lowRun <- runOnce (baseOptions & #thinking .~ Just ThinkingLow) + minimalRun <- runOnce (baseOptions & #thinking .~ Just ThinkingMinimal) + minimalRun ^. #argv @?= lowRun ^. #argv + + lowEv <- oneEvidence (lowRun ^. #events) + minimalEv <- oneEvidence (minimalRun ^. #events) + field "request_commitment" minimalEv @?= field "request_commitment" lowEv + + requestedLevel lowEv @?= Just (String "low") + requestedLevel minimalEv @?= Just (String "minimal") + adjustmentCount lowEv @?= Just 0 + adjustmentCount minimalEv @?= Just 1 + +failedRunTest :: TestTree +failedRunTest = + testCase "a tool that exits nonzero records the failure and commits to no response" $ do + outcome <- replay Nothing baseOptions + ev <- oneEvidence (outcome ^. #events) + field "status" ev @?= Just (String "failed") + case field "error_info" ev of + Just (Object o) -> + assertBool + ("expected a populated error_info, got: " <> show o) + (KeyMap.member "message" o) + other -> assertFailure ("expected a populated error_info, got: " <> show other) + -- No parseable result means nothing to commit to. A digest of an + -- empty envelope would be a real-looking value standing for a + -- response that never arrived. + field "response_commitment" ev @?= Just (String "unobserved") + field "usage" ev @?= Just (String "unobserved") + field "strength" ev @?= Just (String "requested_only") + +optOutTest :: TestTree +optOutTest = + testCase "a call that asked for no evidence emits none" $ do + outcome <- replay recordedResult emptyOptions + [e | e@CallEvidence {} <- outcome ^. #events] @?= [] + length [e | e@CallStarted {} <- outcome ^. #events] @?= 1 + length [e | e@CallFinished {} <- outcome ^. #events] @?= 1 + +-- ============================================================ +-- Replay harness +-- ============================================================ + +-- | What one replayed call produced. +data Replay = Replay + { events :: ![TraceEvent], + -- | The argument vector the fake executable actually received. + argv :: ![Text], + -- | The path the fake executable was written to. + executable :: !FilePath + } + deriving stock (Generic) + +-- | Run one call against a fake @claude@ that prints the given JSON on +-- standard output. +-- +-- 'Nothing' makes the fake exit nonzero with a message on standard +-- error, which is how a failed run is replayed. +replay :: Maybe Text -> Options -> IO Replay +replay stdoutJson opts = withFakeClaude stdoutJson ($ opts) + +-- | Write one fake @claude@ and hand back a function that runs calls +-- against it. +-- +-- Two calls compared against each other must go through the __same__ +-- fake, because the argument vector the request commitment digests +-- begins with the executable's path — so two fakes in two temporary +-- directories would differ for a reason that has nothing to do with +-- what the test is about. +withFakeClaude :: Maybe Text -> ((Options -> IO Replay) -> IO a) -> IO a +withFakeClaude stdoutJson k = + withSystemTempDirectory "baikai-claude-cli-evidence" $ \dir -> do + let argvPath = dir "argv" + exe <- writeFakeExecutable dir "claude" (fakeClaude argvPath stdoutJson) + k $ \opts -> do + reg <- newProviderRegistry + registerApiProviderWith + reg + ( ClaudeCli.claudeCliProvider + ClaudeCli.defaultClaudeCliConfig {ClaudeCli.executable = exe} + ) + (ref, sink) <- memorySink + _ <- Stream.fold Fold.drain (withTraceStreamWith reg sink testModel testContext opts) + recorded <- reverse <$> readTVarIO ref + received <- Text.lines <$> TextIO.readFile argvPath + pure Replay {events = recorded, argv = received, executable = exe} + +-- | A fake @claude@ in a few lines of @sh@. +-- +-- It answers @--version@ before recording anything, exactly as the real +-- tool does. That is not decoration: the evidence path probes the +-- executable's version with a second invocation, and a fake that +-- recorded that invocation's argument vector would overwrite the one +-- the test is about to assert on. +fakeClaude :: FilePath -> Maybe Text -> String +fakeClaude argvPath stdoutJson = + unlines + ( [ "#!/bin/sh", + "if [ \"$1\" = \"--version\" ]; then echo 'fake-claude 9.9.9'; exit 0; fi", + "printf '%s\\n' \"$@\" > '" <> argvPath <> "'" + ] + <> case stdoutJson of + Nothing -> ["echo 'the tool refused' >&2", "exit 3"] + Just body -> ["cat <<'BAIKAI_FIXTURE'", Text.unpack body, "BAIKAI_FIXTURE"] + ) + +writeFakeExecutable :: FilePath -> String -> String -> IO FilePath +writeFakeExecutable dir name body = do + let path = dir name + writeFile path body + perms <- getPermissions path + setPermissions path (setOwnerExecutable True perms) + pure path + +memorySink :: IO (TVar [TraceEvent], TraceSink) +memorySink = do + ref <- newTVarIO [] + let step () e = atomically (modifyTVar' ref (e :)) + pure (ref, TraceSink (Fold.foldlM' step (pure ()))) + +-- ============================================================ +-- Fixtures +-- ============================================================ + +testModel :: Model +testModel = + emptyModel + & #modelId .~ "sonnet" + & #api .~ AnthropicMessagesCli + & #provider .~ "anthropic" + +testContext :: Context +testContext = emptyContext & #messages .~ Vector.singleton (user "PROMPT-BODY-MARKER") + +baseOptions :: Options +baseOptions = emptyOptions & #evidence .~ Just (evidenceRequest "run-55") + +-- | The event array @claude 2.1.222@ emits, trimmed to the fields the +-- provider reads and with the identifiers scrubbed. +recordedResult :: Maybe Text +recordedResult = + Just + "[{\"type\":\"system\",\"subtype\":\"init\",\ + \\"session_id\":\"01890000-0000-4000-8000-000000000001\"},\ + \{\"type\":\"result\",\"subtype\":\"success\",\"is_error\":false,\"result\":\"ok\",\ + \\"session_id\":\"01890000-0000-4000-8000-000000000001\",\ + \\"total_cost_usd\":0.0823025,\ + \\"usage\":{\"input_tokens\":2,\"output_tokens\":6,\ + \\"cache_read_input_tokens\":15185,\"cache_creation_input_tokens\":7455},\ + \\"modelUsage\":{\"claude-opus-5[1m]\":{\"inputTokens\":2,\"outputTokens\":6}}}]" + +-- | A run that succeeded and said nothing about itself. +silentResult :: Maybe Text +silentResult = Just "[{\"type\":\"result\",\"is_error\":false,\"result\":\"ok\"}]" + +-- ============================================================ +-- Assertions on the encoded record +-- ============================================================ + +oneEvidence :: [TraceEvent] -> IO ModelCallEvidence +oneEvidence recorded = case [ev | CallEvidence {evidence = ev} <- recorded] of + [ev] -> pure ev + other -> + assertFailure + ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show recorded) + +field :: Text -> ModelCallEvidence -> Maybe Value +field k ev = case Aeson.toJSON ev of + Object o -> KeyMap.lookup (Key.fromText k) o + _ -> Nothing + +-- | How 'Baikai.Evidence.Observed' encodes a present value. +observedJson :: Text -> Value +observedJson v = Object (KeyMap.singleton "observed" (String v)) + +observedObject :: Text -> ModelCallEvidence -> Maybe (KeyMap.KeyMap Value) +observedObject k ev = case field k ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (Object inner) -> Just inner + _ -> Nothing + _ -> Nothing + +requestedLevel :: ModelCallEvidence -> Maybe Value +requestedLevel ev = case field "thinking" ev of + Just (Object t) -> KeyMap.lookup "requested" t + _ -> Nothing + +adjustmentCount :: ModelCallEvidence -> Maybe Int +adjustmentCount ev = case field "thinking" ev of + Just (Object t) -> case KeyMap.lookup "adjustments" t of + Just (Array a) -> Just (Vector.length a) + _ -> Nothing + _ -> Nothing + +assertDigest :: Text -> ModelCallEvidence -> IO () +assertDigest k ev = case field k ev of + Just (String d) -> assertSha256 k d + other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other) + +assertObservedDigest :: Text -> ModelCallEvidence -> IO () +assertObservedDigest k ev = case field k ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (String d) -> assertSha256 k d + other -> assertFailure (Text.unpack k <> " not a digest: " <> show other) + other -> assertFailure ("expected an observed " <> Text.unpack k <> ", got: " <> show other) + +assertSha256 :: Text -> Text -> IO () +assertSha256 k d = + assertBool + (Text.unpack k <> " must be a sha256 digest, got: " <> show d) + ("sha256:" `Text.isPrefixOf` d && Text.length d == 71) + +isSublistOf :: (Eq a) => [a] -> [a] -> Bool +isSublistOf needle haystack = + any (\suffix -> needle == take (length needle) suffix) (suffixes haystack) + where + suffixes xs = + xs : case xs of + [] -> [] + (_ : rest) -> suffixes rest diff --git a/test/Contract.hs b/test/Contract.hs new file mode 100644 --- /dev/null +++ b/test/Contract.hs @@ -0,0 +1,45 @@ +-- | The stream protocol, as an assertion. +-- +-- Lives in its own module rather than in @Main@ because three suites +-- need it — the end-to-end cases in @Main@, the failure-stream cases in +-- @SseSpec@, and the evidence cases in @EvidenceSpec@ — and a protocol +-- asserted three slightly different ways is not asserted at all. +module Contract (assertErrorContract, assertOneErrorTerminal) where + +import Baikai.Stream.Event + ( AssistantMessageEvent (..), + StartPayload (..), + TerminalPayload (..), + isTerminal, + ) +import Test.Tasty.HUnit (Assertion, assertFailure, (@?=)) + +-- | The whole documented protocol for a failing stream: exactly one +-- 'EventStart', first; exactly one terminal; and that terminal an +-- 'EventError' carrying structured 'errorInfo'. +-- +-- Use this on anything that drains a provider stream. A fragment folded +-- straight through @translate@ never carried a start event, so it gets +-- 'assertOneErrorTerminal' instead. +assertErrorContract :: [AssistantMessageEvent] -> Assertion +assertErrorContract events = do + case events of + EventStart StartPayload {} : _ -> pure () + other -> assertFailure ("stream must begin with EventStart, got: " <> show (take 1 other)) + length [() | EventStart {} <- events] @?= 1 + assertOneErrorTerminal events + case reverse events of + (EventError TerminalPayload {} : _) -> pure () + other -> assertFailure ("stream must end with EventError, got: " <> show (take 1 other)) + +-- | The terminal half of 'assertErrorContract', for translator-level +-- fragments that never carried a start event. +assertOneErrorTerminal :: [AssistantMessageEvent] -> Assertion +assertOneErrorTerminal events = do + let terminals = filter isTerminal events + length terminals @?= 1 + case terminals of + [EventError TerminalPayload {errorInfo = Nothing}] -> + assertFailure "terminal EventError omitted errorInfo" + [EventError TerminalPayload {errorInfo = Just _}] -> pure () + other -> assertFailure ("expected exactly one terminal EventError, got: " <> show other) diff --git a/test/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 new file mode 100644 --- /dev/null +++ b/test/EvidenceSpec.hs @@ -0,0 +1,475 @@ +-- | End-to-end model-call evidence for the Anthropic Messages provider. +-- +-- Every case here replays a recorded HTTP response through the real +-- adapter and reads the evidence back out of a trace sink. Nothing is +-- stubbed but the socket: the request is built by @mapRequest@, the +-- response is decoded by @sseFromResponse@, the headers are captured by +-- the real allow-list, and the record is assembled and emitted by the +-- real trace path. +-- +-- Assertions go through the encoded JSON rather than through Haskell +-- record accessors, because the JSON is the contract other systems pin +-- against, and it spells its fields in snake_case where a Haskell +-- mirror would silently paper over a rename. +module EvidenceSpec (tests) where + +import Baikai +import Baikai.Models.Generated (anthropic_claude_haiku_4_5) +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 (..)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key qualified as Key +import Data.Aeson.KeyMap qualified as KeyMap +import Data.ByteString (ByteString) +import Data.CaseInsensitive qualified as CI +import Data.Generics.Labels () +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text qualified as Text +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 Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + -- Named so this plan's documented + -- @--test-options='--pattern Evidence'@ actually selects it. A + -- pattern that matches nothing reports "All 0 tests passed". + "EvidenceSpec: Anthropic model-call evidence" + [ successEvidenceTest, + rateLimitEvidenceTest, + thinkingEvidenceTest, + samplingEvidenceTest, + cacheUsageEvidenceTest, + immediateErrorRecordsThinkingTest, + defaultHostEndpointTest, + responseIdCountsAsCorrelationTest, + optOutTest + ] + +-- ============================================================ +-- The cases +-- ============================================================ + +successEvidenceTest :: TestTree +successEvidenceTest = + testCase "a replayed successful call records what Anthropic reported" $ do + ev <- oneEvidence =<< replay 200 successHeaders successBody baseOptions + field "status" ev @?= Just (String "succeeded") + field "error_info" ev @?= Just Null + field "run_id" ev @?= Just (String "run-53") + + -- The heart of it: requested and observed are different values, and + -- the observed one came from the provider's own message_start. + field "requested_model" ev @?= Just (String (anthropic_claude_haiku_4_5 ^. #modelId)) + field "observed_model" ev @?= Just (observedJson "claude-haiku-4-5-20990101-server-side") + assertBool + "observed_model must not be the configured model" + (field "observed_model" ev /= Just (observedJson (anthropic_claude_haiku_4_5 ^. #modelId))) + + field "provider_request_id" ev @?= Just (observedJson "req_success_1") + field "response_id" ev @?= Just (observedJson "msg_observed") + -- Tied to the declaration mechanically: raising declaredStrength + -- for this transport without the transport reaching it fails here. + field "strength" ev @?= Just (Aeson.toJSON (declaredStrength AnthropicMessages)) + + -- Anthropic never echoes the thinking configuration it applied, so + -- this transport cannot reach fully_observed and must not pretend + -- a reasoning-token count is such an echo. + field "observed_thinking" ev @?= Just (String "unobserved") + + assertDigest "request_commitment" ev + assertDigest "request_configuration" ev + case field "response_commitment" ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (String d) -> assertSha256 "response_commitment" d + other -> assertFailure ("response_commitment not a digest: " <> show other) + other -> assertFailure ("expected an observed response_commitment, got: " <> show other) + + -- Usage is Observed because Anthropic reported it, and carries the + -- fixture's counts rather than the assembler's initial zeroes. + case field "usage" ev of + Just (Object o) -> case KeyMap.lookup "observed" o of + Just (Object u) -> do + KeyMap.lookup "input_tokens" u @?= Just (Number 11) + KeyMap.lookup "output_tokens" u @?= Just (Number 5) + other -> assertFailure ("usage.observed not an object: " <> show other) + other -> assertFailure ("expected an observed usage, got: " <> show other) + + -- The endpoint names this package's own version, read from the + -- cabal-generated module. + case field "endpoint" ev of + Just (Object o) -> do + KeyMap.lookup "transport" o @?= Just (String "http_api") + case KeyMap.lookup "implementation_version" o of + Just (String v) -> + assertBool "implementation_version must not be empty" (not (Text.null v)) + other -> assertFailure ("expected an implementation_version, got: " <> show other) + other -> assertFailure ("expected an endpoint object, got: " <> show other) + +rateLimitEvidenceTest :: TestTree +rateLimitEvidenceTest = + testCase "a replayed 429 records the correlation id and observes nothing else" $ do + ev <- + oneEvidence + =<< replay + 429 + [("request-id", "req_rate_limited"), ("Retry-After", "7")] + ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"] + baseOptions + field "status" ev @?= Just (String "failed") + case field "error_info" ev of + Just (Object o) -> + assertBool + ("expected the rate-limit message, got: " <> show o) + (KeyMap.lookup "message" o /= Nothing) + other -> assertFailure ("expected a populated error_info, got: " <> show other) + + -- The header is present on errors too, and it is the single most + -- useful thing to have when opening a provider support request. + field "provider_request_id" ev @?= Just (observedJson "req_rate_limited") + + -- Absent metadata stays absent. None of these is backfilled. + field "observed_model" ev @?= Just (String "unobserved") + field "response_id" ev @?= Just (String "unobserved") + field "response_commitment" ev @?= Just (String "unobserved") + field "usage" ev @?= Just (String "unobserved") + field "strength" ev @?= Just (String "correlated") + + -- The same replay as a stream: an HTTP failure that arrives before + -- @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 + ev <- + oneEvidence + =<< replay + 200 + successHeaders + successBody + (baseOptions & #thinking .~ Just ThinkingMinimal) + case field "thinking" ev of + Just (Object t) -> do + KeyMap.lookup "requested" t @?= Just (String "minimal") + -- haiku-4-5 is a budget-style model, so the level is expressed + -- exactly and nothing is adjusted. + KeyMap.lookup "mode" t @?= Just (String "budget") + KeyMap.lookup "budget_tokens" t @?= Just (Number 1024) + KeyMap.lookup "effort_text" t @?= Just Null + KeyMap.lookup "wire_field" t @?= Just (String "thinking") + 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/v1/messages") + 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 + events <- replay 200 successHeaders successBody emptyCallOptions + [e | e@CallEvidence {} <- events] @?= [] + -- The call itself still succeeded and still traced normally. + length [e | e@CallStarted {} <- events] @?= 1 + length [e | e@CallFinished {} <- events] @?= 1 + +-- ============================================================ +-- Replay harness +-- ============================================================ + +-- | Run one recorded response through the real adapter and the real +-- trace path, and return every trace event it produced. +replay :: Int -> [(ByteString, ByteString)] -> [ByteString] -> Options -> IO [TraceEvent] +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 = + 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 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. +-- +-- It goes through 'sseFromResponse', so the status classification, +-- header allow-list, and SSE frame decoding under test are the ones +-- production uses. Only 'HTTP.withResponse' is replaced. +replayDriver :: Int -> [(ByteString, ByteString)] -> [ByteString] -> SseDriver +replayDriver status headers chunks _call onMetadata onEvent = do + resp <- mkResponse status headers chunks + sseFromResponse resp onMetadata onEvent + +mkResponse :: + Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader) +mkResponse status headers chunks = do + ref <- newIORef chunks + let bodyReader = do + remaining <- readIORef ref + case remaining of + [] -> pure "" + (x : xs) -> writeIORef ref xs >> pure x + pure + HTTP.Response + { HTTP.responseStatus = mkStatus status "", + HTTP.responseVersion = http11, + HTTP.responseHeaders = [(CI.mk k, v) | (k, v) <- headers], + HTTP.responseBody = bodyReader, + HTTP.responseCookieJar = HTTP.createCookieJar [], + HTTP.responseClose' = HTTP.ResponseClose (pure ()), + HTTP.responseOriginalRequest = HTTP.defaultRequest, + HTTP.responseEarlyHints = [] + } + +memorySink :: IO (TVar [TraceEvent], TraceSink) +memorySink = do + ref <- newTVarIO [] + let step () e = atomically (modifyTVar' ref (e :)) + pure (ref, TraceSink (Fold.foldlM' step (pure ()))) + +-- ============================================================ +-- Fixtures +-- ============================================================ + +testModel :: Model +testModel = + anthropic_claude_haiku_4_5 + & #api .~ AnthropicMessages + & #baseUrl .~ "https://api.anthropic.com" + +-- | A literal key, so 'prepareCall' resolves one without reading the +-- environment. It never reaches the replayed response. +emptyCallOptions :: Options +emptyCallOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key") + +baseOptions :: Options +baseOptions = emptyCallOptions & #evidence .~ Just (evidenceRequest "run-53") + +successHeaders :: [(ByteString, ByteString)] +successHeaders = [("request-id", "req_success_1")] + +-- | A complete successful stream whose reported model is deliberately +-- not any model in the catalog, so it cannot be confused with a +-- configured one. +successBody :: [ByteString] +successBody = + [ "data: {\"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\":\"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,", + "\"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" + ] + +-- ============================================================ +-- Assertions on the encoded record +-- ============================================================ + +oneEvidence :: [TraceEvent] -> IO ModelCallEvidence +oneEvidence events = case [ev | CallEvidence {evidence = ev} <- events] of + [ev] -> pure ev + other -> + assertFailure + ("expected exactly one CallEvidence, got " <> show (length other) <> ": " <> show events) + +field :: Text -> ModelCallEvidence -> Maybe Value +field k ev = case Aeson.toJSON ev of + Object o -> KeyMap.lookup (Key.fromText k) o + _ -> Nothing + +-- | How 'Baikai.Evidence.Observed' encodes a present value. +observedJson :: Text -> Value +observedJson v = Object (KeyMap.singleton "observed" (String v)) + +assertDigest :: Text -> ModelCallEvidence -> IO () +assertDigest k ev = case field k ev of + Just (String d) -> assertSha256 k d + other -> assertFailure (Text.unpack k <> " missing or not a string: " <> show other) + +assertSha256 :: Text -> Text -> IO () +assertSha256 k d = + assertBool + (Text.unpack k <> " must be a sha256 digest, got: " <> show d) + ("sha256:" `Text.isPrefixOf` d && Text.length d == 71) diff --git a/test/FableContractsSpec.hs b/test/FableContractsSpec.hs new file mode 100644 --- /dev/null +++ b/test/FableContractsSpec.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module FableContractsSpec (tests) where + +import Baikai hiding (messages, model) +import Baikai.Models.Generated (anthropic_claude_fable_5_1) +import Baikai.Provider.Claude.Internal.Request qualified as R +import Baikai.Provider.Claude.Internal.Stream (SseDriver, claudeMessagesStreamWith) +import Claude.V1.Messages qualified as C +import Contract (assertErrorContract) +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Fable contracts" + [ summaryTests, + testCase "forced choices fail before the driver for complete and stream, including renamed models" $ + forM_ [model, model & #modelId .~ "renamed-generation"] $ \m -> + forM_ [ToolChoiceRequired, ToolChoiceSpecific "lookup"] $ \choice -> do + sent <- newIORef False + let never _ _ _ = writeIORef sent True + opts = options & #toolChoice .~ Just choice + events <- Stream.toList (claudeMessagesStreamWith never m context opts) + assertErrorContract events + response <- streamingComplete (claudeMessagesStreamWith never) m context opts + fmap (.category) (responseError response) @?= Just InvalidRequest + assertBool "useful correction" (maybe False (T.isInfixOf "ToolChoiceAuto" . (.message)) (responseError response)) + readIORef sent >>= (@?= False), + testCase "auto and none keep their exact wire meaning" $ + forM_ [(ToolChoiceAuto, "auto"), (ToolChoiceNone, "none")] $ \(choice, expected) -> do + body <- newIORef Null + let capture call _ emit = writeIORef body (call ^. #requestBody) >> send finalTurn emit + _ <- streamingComplete (claudeMessagesStreamWith capture) model context (options & #toolChoice .~ Just choice) + raw <- readIORef body + (field "tool_choice" raw >>= field "type") @?= Just (String expected), + testCase "supporting compatibility retains required and named choice" $ + forM_ [(ToolChoiceRequired, "any"), (ToolChoiceSpecific "lookup", "tool")] $ \(choice, expected) -> do + let m = model & #modelId .~ "supporting-generation" & #compat .~ CompatAnthropicMessages (anthropicMessagesCompatFor model & #supportsForcedToolChoice .~ True) + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest m context (options & #toolChoice .~ Just choice)) + (field "tool_choice" (Aeson.toJSON req) >>= field "type") @?= Just (String expected), + testCase "unset effort is no preference and small caps never create a manual budget" $ + forM_ [Nothing, Just ThinkingMinimal, Just ThinkingLow, Just ThinkingMedium, Just ThinkingHigh, Just ThinkingXHigh, Just ThinkingMax] $ \level -> do + let opts = options & #thinking .~ level & #maxTokens .~ Just 1 + (req, translation) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model context opts) + let raw = Aeson.toJSON req + field "max_tokens" raw @?= Just (Number 1) + translation @?= R.describeThinkingFor model opts + case level of + Nothing -> do + field "thinking" raw @?= Nothing + translation @?= noThinkingRequested + Just _ -> do + (field "thinking" raw >>= field "type") @?= Just (String "adaptive") + (field "thinking" raw >>= field "budget_tokens") @?= Nothing, + testCase "legacy serialized compat defaults to supporting forced choice" $ do + let raw = case Aeson.toJSON defaultAnthropicMessagesCompat of Object o -> Object (KM.delete "supportsForcedToolChoice" o); v -> v + case Aeson.fromJSON raw of + Aeson.Success c -> (c :: AnthropicMessagesCompat).supportsForcedToolChoice @?= True + Aeson.Error err -> assertFailure err, + testCase "two consecutive tool rounds preserve signed empty, visible and redacted thinking" $ do + requests <- newIORef ([] :: [Value]) + executed <- newIORef ([] :: [Text]) + let scripted call _ emit = do + previous <- readIORef requests + writeIORef requests (previous <> [call ^. #requestBody]) + send (case length previous of 0 -> toolTurn "" "sig-one" "toolu_1" True; 1 -> toolTurn "visible summary" "sig-two" "toolu_2" False; _ -> finalTurn) emit + reg <- newProviderRegistryFrom [apiProvider AnthropicMessages (claudeMessagesStreamWith scripted)] + (history, response) <- runToolLoopWith reg 4 (\tc -> do xs <- readIORef executed; writeIORef executed (xs <> [tc.id_]); pure (toolResultText "found")) model context summaryOptions + response.message.content @?= V.singleton (AssistantText (TextContent "done")) + readIORef executed >>= (@?= ["toolu_1", "toolu_2"]) + bodies <- readIORef requests + length bodies @?= 3 + case bodies of + [first, second, third] -> do + let a = messages first; b = messages second; c = messages third + V.take (V.length a) b @?= a + V.take (V.length b) c @?= b + field "system" first @?= field "system" third + field "tools" first @?= field "tools" third + forM_ bodies $ \body -> (field "thinking" body >>= field "display") @?= Just (String "summarized") + contentAt 1 b @?= V.fromList [signed "" "sig-one", redactedItem, toolItem "toolu_1"] + contentAt 3 c @?= V.fromList [signed "visible summary" "sig-two", toolItem "toolu_2"] + field "tool_use_id" (contentAt 2 b V.! 0) @?= Just (String "toolu_1") + field "tool_use_id" (contentAt 4 c V.! 0) @?= Just (String "toolu_2") + persisted <- V.mapM persistThinking (history ^. #messages) + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model (history & #messages .~ persisted) summaryOptions) + messages (Aeson.toJSON req) @?= c + _ -> assertFailure "expected three requests", + testCase "error cleanup retains completed signed thinking for persistence" $ do + let partial _ _ emit = send (take 4 (toolTurn "" "sig-one" "toolu_1" False)) emit >> emit (Left (providerError "interrupted")) + response <- streamingComplete (claudeMessagesStreamWith partial) model context options + assertBool "failed response" (responseError response /= Nothing) + case V.toList response.message.content of + [AssistantThinking t] -> do + t.thinking @?= "" + t.signature @?= Just "sig-one" + t.replayState @?= Nothing + _ -> assertFailure "signed state was discarded on error" + ] + +model :: Model +model = anthropic_claude_fable_5_1 + +options :: Options +options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-key") + +context :: Context +context = systemUser "unchanged system" "look twice" & #tools .~ V.singleton (mkTool "lookup" "lookup" (object ["type" .= ("object" :: Text)])) + +send :: [Value] -> (Either BaikaiError C.MessageStreamEvent -> IO ()) -> IO () +send frames emit = forM_ frames $ \raw -> case Aeson.fromJSON raw of + Aeson.Error err -> assertFailure err + Aeson.Success ev -> emit (Right ev) + +start :: Value +start = object ["type" .= ("message_start" :: Text), "message" .= object ["id" .= ("msg" :: Text), "type" .= ("message" :: Text), "role" .= ("assistant" :: Text), "model" .= ("claude-fable-5-1" :: Text), "content" .= ([] :: [Value]), "usage" .= object ["input_tokens" .= (5 :: Int), "output_tokens" .= (0 :: Int)]]] + +block :: Int -> Value -> Value +block n b = object ["type" .= ("content_block_start" :: Text), "index" .= n, "content_block" .= b] + +stopBlock :: Int -> Value +stopBlock n = object ["type" .= ("content_block_stop" :: Text), "index" .= n] + +end :: Text -> [Value] +end reason = [object ["type" .= ("message_delta" :: Text), "delta" .= object ["stop_reason" .= reason], "usage" .= object ["output_tokens" .= (5 :: Int)]], object ["type" .= ("message_stop" :: Text)]] + +signed :: Text -> Text -> Value +signed text sig = object ["type" .= ("thinking" :: Text), "thinking" .= text, "signature" .= sig] + +redactedItem :: Value +redactedItem = object ["type" .= ("redacted_thinking" :: Text), "data" .= ("encrypted-redacted" :: Text)] + +toolItem :: Text -> Value +toolItem ident = object ["type" .= ("tool_use" :: Text), "id" .= ident, "name" .= ("lookup" :: Text), "input" .= object []] + +toolTurn :: Text -> Text -> Text -> Bool -> [Value] +toolTurn text sig ident redacted = + [start, block 0 (signed "" "")] + <> (if T.null text then [] else [object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("thinking_delta" :: Text), "thinking" .= text]]]) + <> [object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("signature_delta" :: Text), "signature" .= sig]], stopBlock 0] + <> (if redacted then [block 1 redactedItem, stopBlock 1] else []) + <> [block (if redacted then 2 else 1) (toolItem ident), stopBlock (if redacted then 2 else 1)] + <> end "tool_use" + +finalTurn :: [Value] +finalTurn = [start, block 0 (object ["type" .= ("text" :: Text), "text" .= ("" :: Text)]), object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("text_delta" :: Text), "text" .= ("done" :: Text)]], stopBlock 0] <> end "end_turn" + +field :: Key -> Value -> Maybe Value +field k (Object o) = KM.lookup k o +field _ _ = Nothing + +messages :: Value -> V.Vector Value +messages raw = case field "messages" raw of Just (Array xs) -> xs; _ -> V.empty + +contentAt :: Int -> V.Vector Value -> V.Vector Value +contentAt n xs = case xs V.!? n >>= field "content" of Just (Array cs) -> cs; _ -> V.empty + +-- Applications own the surrounding history store; ThinkingContent supplies +-- its JSON round trip. Exercise that payload without inventing a Context decoder. +persistThinking :: Message -> IO Message +persistThinking (AssistantMessage payload) = do + blocks <- V.mapM persist (payload ^. #content) + pure (AssistantMessage (payload & #content .~ blocks)) + where + persist (AssistantThinking t) = AssistantThinking <$> either assertFailure pure (Aeson.eitherDecode (Aeson.encode t)) + persist block = pure block +persistThinking other = pure other + +summaryOptions :: Options +summaryOptions = options & #thinking .~ Just ThinkingLow & #evidence .~ Just (evidenceRequest "summary-replay") + +summaryTests :: TestTree +summaryTests = + testGroup + "summary visibility" + [ testCase "summarized reasoning assembles into non-empty thinking content" $ do + response <- completeFrames (toolTurn "visible summary" "signed-summary" "toolu_summary" False) summaryOptions + let blocks = [t | AssistantThinking t <- V.toList (response ^. #message . #content)] + map (^. #thinking) blocks @?= ["visible summary"] + map (^. #signature) blocks @?= [Just "signed-summary"] + ev <- evidenceOf response + ev ^. #thinking . #displayText @?= Just "summarized" + ev ^. #thinking . #adjustments @?= [] + ev ^. #observedThinking @?= Unobserved, + testCase "reasoning requested but returned empty is recorded in the evidence" $ do + forM_ [[signed "" "empty-signature"], [redactedItem], [signed "" "empty-signature", redactedItem]] $ \blocks -> do + response <- completeFrames (blocksTurn blocks) summaryOptions + ev <- evidenceOf response + ev ^. #thinking . #adjustments @?= [ThinkingSummaryUnavailable] + ev ^. #thinking . #displayText @?= Just "summarized" + ev ^. #observedThinking @?= Unobserved + ev ^. #status @?= CallSucceeded + responseError response @?= Nothing + weakensThinking ThinkingSummaryUnavailable @?= False + let actual = [t | AssistantThinking t <- V.toList (response ^. #message . #content)] + length actual @?= length blocks + -- Encrypted payloads and signed empty blocks remain usable history. + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model (emptyContext & #messages .~ V.singleton (AssistantMessage (response ^. #message))) summaryOptions) + contentAt 0 (messages (Aeson.toJSON req)) @?= V.fromList blocks, + testCase "one visible block among empty and redacted blocks is a readable summary" $ do + response <- completeFrames (blocksTurn [signed "" "empty", redactedItem, signed "visible" "visible-signature"]) summaryOptions + ev <- evidenceOf response + ev ^. #thinking . #adjustments @?= [], + testCase "no thinking block and no thinking preference do not invent missing summaries" $ do + noBlocks <- completeFrames finalTurn summaryOptions + ev <- evidenceOf noBlocks + ev ^. #thinking . #adjustments @?= [] + noPreference <- completeFrames (blocksTurn [signed "" "sig"]) (options & #evidence .~ Just (evidenceRequest "no-thinking")) + ev2 <- evidenceOf noPreference + ev2 ^. #thinking @?= noThinkingRequested, + testCase "failed streams do not label partial thinking as a missing completed summary" $ do + let driver _ _ emit = send [start, block 0 (signed "" "sig"), stopBlock 0] emit >> emit (Left (providerError "interrupted")) + response <- streamingComplete (claudeMessagesStreamWith driver) model emptyContext summaryOptions + ev <- evidenceOf response + ev ^. #status @?= CallFailed + ev ^. #thinking . #adjustments @?= [] + assertBool "failure retained" (responseError response /= Nothing) + ] + where + completeFrames frames opts = streamingComplete (claudeMessagesStreamWith (\_ _ emit -> send frames emit)) model emptyContext opts + blocksTurn blocks = [start] <> concat [blockFrames i b | (i, b) <- zip [0 ..] blocks] <> end "end_turn" + blockFrames i b = case (field "type" b, field "thinking" b, field "signature" b) of + (Just (String "thinking"), Just (String text), Just (String sig)) -> + [ block i (signed "" ""), + object ["type" .= ("content_block_delta" :: Text), "index" .= i, "delta" .= object ["type" .= ("thinking_delta" :: Text), "thinking" .= text]], + object ["type" .= ("content_block_delta" :: Text), "index" .= i, "delta" .= object ["type" .= ("signature_delta" :: Text), "signature" .= sig]], + stopBlock i + ] + _ -> [block i b, stopBlock i] + evidenceOf response = maybe (assertFailure "missing evidence" >> fail "evidence") pure (response ^. #evidence) 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 @@ -1,11 +1,26 @@ module Main (main) where import Baikai +import Baikai.Agent + ( AgentCapability (..), + AgentCommand, + AgentOutputFormat (..), + AgentPromptTransport (..), + AgentProvider (..), + AgentRenderError (..), + AgentRunRequest, + agentRunRequest, + agentSafety, + renderAgentRenderError, + ) +import Baikai.Provider.Claude.Agent qualified as ClaudeAgent import Baikai.Provider.Claude.Api import Baikai.Provider.Claude.Cli qualified as ClaudeCli import Baikai.Provider.Claude.Interactive -import Baikai.Provider.Claude.Internal.Request (mapRequest) +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 @@ -14,6 +29,11 @@ import Data.Text qualified as Text import Data.Vector qualified as Vector import ErrorClassSpec qualified +import EvidenceSpec qualified +import FableContractsSpec qualified +import LifecycleSpec qualified +import MidStreamSpec qualified +import PublicSurfaceSpec qualified import ShapeSpec qualified import SseSpec qualified import Streamly.Data.Stream qualified as Stream @@ -22,7 +42,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 @@ -33,6 +53,19 @@ "Baikai.Provider.Claude" [ commandRenderingTest, effortRenderingTests, + safetyRefusalTest, + safetyStillRendersTest, + agentCommandRenderingTest, + agentOutputFormatTest, + agentCapabilityRenderingTests, + agentEffortRenderingTests, + agentThinkingTranslationTests, + strictEvidenceTests, + agentPromptTransportTest, + agentBlankModelTest, + agentSessionPersistenceTest, + agentProviderGuardTest, + agentKeiroFixtureTest, batchCommandRenderingTest, batchEffortRenderingTests, stderrFloodTest, @@ -42,7 +75,13 @@ cliMissingBinaryTest, responseFormatMappingTest, optionsMappingTest, + CliEvidenceSpec.tests, ErrorClassSpec.tests, + EvidenceSpec.tests, + FableContractsSpec.tests, + LifecycleSpec.tests, + MidStreamSpec.tests, + PublicSurfaceSpec.tests, ShapeSpec.tests, SseSpec.tests, ThinkingSpec.tests, @@ -52,7 +91,7 @@ -- | A 'JsonSchema' on 'Options.responseFormat' maps onto Anthropic's -- native @output_config@, forwarding the schema 'Value' verbatim via -- 'Messages.jsonSchemaConfig'. Pure: 'mapRequest' is --- 'Either Text Messages.CreateMessage'. +-- 'Either Text (Messages.CreateMessage, ThinkingTranslation)'. responseFormatMappingTest :: TestTree responseFormatMappingTest = testCase "responseFormat JsonSchema maps onto Anthropic output_config" $ do @@ -76,11 +115,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 + Right (req, _) -> + req ^. #output_config @?= Just (Messages.jsonSchemaConfig personSchema) optionsMappingTest :: TestTree @@ -94,15 +133,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 = @@ -121,24 +169,25 @@ & #safety .~ ClaudeAllowedTools ["Read", "Bash(git status)"] & #extraArgs .~ ["--permission-mode", "plan"] claudeInteractiveCommand cfg req - @?= ( "/bin/claude", - [ "--model", - "sonnet", - "--system-prompt", - "Be terse.", - "--add-dir", - "/work/shared", - "--add-dir", - "/work/docs", - "--allowedTools", - "Read,Bash(git status)", - "--debug", - "--permission-mode", - "plan", - "--", - "inspect the repo" - ] - ) + @?= Right + ( "/bin/claude", + [ "--model", + "sonnet", + "--system-prompt", + "Be terse.", + "--add-dir", + "/work/shared", + "--add-dir", + "/work/docs", + "--allowedTools", + "Read,Bash(git status)", + "--debug", + "--permission-mode", + "plan", + "--", + "inspect the repo" + ] + ) effortRenderingTests :: TestTree effortRenderingTests = @@ -147,7 +196,7 @@ [ testCase name $ do let req = interactiveLaunchRequest "prompt" & #effort .~ Just level claudeInteractiveCommand defaultClaudeInteractiveConfig req - @?= ("claude", ["--effort", expected, "--", "prompt"]) + @?= Right ("claude", ["--effort", expected, "--", "prompt"]) | (name, level, expected) <- [ ("minimal as low", ThinkingMinimal, "low"), ("low", ThinkingLow, "low"), @@ -158,6 +207,400 @@ ] ] +safetyRefusalTest :: TestTree +safetyRefusalTest = + testCase "refuses a Codex sandbox policy instead of launching unrestricted" $ do + let req = + interactiveLaunchRequest "inspect the repo" + & #safety .~ CodexSandbox CodexReadOnly CodexApprovalNever + case claudeInteractiveCommand defaultClaudeInteractiveConfig req of + Right rendered -> assertFailure ("expected refusal, rendered: " <> show rendered) + Left err -> do + case err of + SafetyNotExpressible p _ -> p @?= AgentClaude + other -> assertFailure ("expected SafetyNotExpressible, got: " <> show other) + let message = renderAgentRenderError err + assertBool "names the provider" ("Claude" `Text.isInfixOf` message) + assertBool "names the rejected sandbox mode" ("read-only" `Text.isInfixOf` message) + assertBool "names the rejected approval policy" ("never" `Text.isInfixOf` message) + assertBool "suggests an alternative" ("ClaudeAllowedTools" `Text.isInfixOf` message) + +-- | The fix refuses only what Claude cannot express. An allow-list is +-- expressible and must still render, and an empty allow-list restricts +-- nothing so it renders no safety flag rather than being refused. +safetyStillRendersTest :: TestTree +safetyStillRendersTest = + testGroup + "still renders every safety policy Claude can express" + [ testCase "a non-empty allow-list" $ do + let req = + interactiveLaunchRequest "inspect" + & #safety .~ ClaudeAllowedTools ["Read", "Grep"] + fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req) + @?= Right ["--allowedTools", "Read,Grep", "--", "inspect"], + testCase "an empty allow-list renders no safety flag" $ do + let req = interactiveLaunchRequest "inspect" & #safety .~ ClaudeAllowedTools [] + fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req) + @?= Right ["--", "inspect"], + testCase "DefaultSafety renders no safety flag" $ do + let req = interactiveLaunchRequest "inspect" & #safety .~ DefaultSafety + fmap snd (claudeInteractiveCommand defaultClaudeInteractiveConfig req) + @?= Right ["--", "inspect"] + ] + +-- | Render an unattended command or fail the test with the refusal's +-- own message. +renderedAgentCommand :: + ClaudeAgent.ClaudeAgentConfig -> AgentRunRequest -> IO AgentCommand +renderedAgentCommand cfg req = fst <$> renderedAgentPair cfg req + +-- | The command and the reasoning-effort translation the renderer +-- produced together. +renderedAgentPair :: + ClaudeAgent.ClaudeAgentConfig -> + AgentRunRequest -> + IO (AgentCommand, ThinkingTranslation) +renderedAgentPair cfg req = + either + (assertFailure . Text.unpack . renderAgentRenderError) + pure + (ClaudeAgent.claudeAgentCommand cfg req) + +agentCommandRenderingTest :: TestTree +agentCommandRenderingTest = + testCase "unattended claude argv renders every structured flag in a fixed order" $ do + let cfg = + ClaudeAgent.defaultClaudeAgentConfig + & #executable .~ "/bin/claude" + & #extraArgs .~ ["--debug"] + req = + agentRunRequest AgentClaude "/work/project" "reconcile the grammar" + & #modelId .~ Just "sonnet" + & #effort .~ Just ThinkingHigh + & #extraDirs .~ ["/work/shared", "/work/docs"] + & #safety .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read", "Write"]) + & #safety . #providerArgs .~ ["--betas", "context-1m"] + cmd <- renderedAgentCommand cfg req + cmd ^. #executable @?= "/bin/claude" + cmd ^. #arguments + @?= [ "-p", + "--no-session-persistence", + "--model", + "sonnet", + "--effort", + "high", + "--permission-mode", + "acceptEdits", + "--allowedTools", + "Read,Write", + "--add-dir", + "/work/shared", + "--add-dir", + "/work/docs", + "--debug", + "--betas", + "context-1m" + ] + 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 + "unattended claude argv maps every capability onto a permission mode" + [ testCase name $ do + let req = + agentRunRequest AgentClaude "/work/project" "prompt" + & #safety .~ agentSafety cap + cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + cmd ^. #arguments + @?= ["-p", "--no-session-persistence", "--permission-mode", expected] + | (name, cap, expected) <- + [ ("read-only as plan", AgentReadOnly, "plan"), + ("edit-workspace as acceptEdits", AgentEditWorkspace, "acceptEdits"), + ("full-access as bypassPermissions", AgentFullAccess, "bypassPermissions") + ] + ] + +-- | Claude's @--effort@ has no @minimal@ value, so the lowest level +-- maps up to @low@. Codex passes all six through unchanged; pinning +-- both sides stops someone later \"unifying\" them. +agentEffortRenderingTests :: TestTree +agentEffortRenderingTests = + testGroup + "unattended claude argv clamps minimal effort up to low" + [ testCase name $ do + let req = + agentRunRequest AgentClaude "/work/project" "prompt" + & #effort .~ Just level + cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + cmd ^. #arguments + @?= [ "-p", + "--no-session-persistence", + "--effort", + expected, + "--permission-mode", + "plan" + ] + | (name, level, expected) <- + [ ("minimal as low", ThinkingMinimal, "low"), + ("low", ThinkingLow, "low"), + ("medium", ThinkingMedium, "medium"), + ("high", ThinkingHigh, "high"), + ("xhigh", ThinkingXHigh, "xhigh"), + ("max", ThinkingMax, "max") + ] + ] + +-- | The prompt travels on standard input, so a prompt that begins with +-- a dash cannot be parsed as a flag and cannot be swallowed by a +-- preceding variadic flag. Dash-leading directories still appear as +-- ordinary arguments following their own flag. +agentPromptTransportTest :: TestTree +agentPromptTransportTest = + testCase "unattended claude argv never contains the prompt, even a dash-leading one" $ do + let dashPrompt = "-rm -rf /" + req = + agentRunRequest AgentClaude "-/work/dashdir" dashPrompt + & #extraDirs .~ ["-/work/dashshared"] + & #safety .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read"]) + cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + assertBool + ("prompt leaked into argv: " <> show (cmd ^. #arguments)) + (Text.unpack dashPrompt `notElem` cmd ^. #arguments) + cmd ^. #promptText @?= dashPrompt + cmd ^. #promptTransport @?= PromptOnStdin + cmd ^. #arguments + @?= [ "-p", + "--no-session-persistence", + "--permission-mode", + "acceptEdits", + "--allowedTools", + "Read", + "--add-dir", + "-/work/dashshared" + ] + +agentBlankModelTest :: TestTree +agentBlankModelTest = + testCase "unattended claude argv omits --model for a blank model value" $ do + let req = + agentRunRequest AgentClaude "/work/project" "prompt" + & #modelId .~ Just " " + cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + cmd ^. #arguments + @?= ["-p", "--no-session-persistence", "--permission-mode", "plan"] + +agentSessionPersistenceTest :: TestTree +agentSessionPersistenceTest = + testCase "unattended claude argv persists a session only when asked" $ do + let req = agentRunRequest AgentClaude "/work/project" "prompt" + persisting = ClaudeAgent.defaultClaudeAgentConfig & #persistSession .~ True + byDefault <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + byDefault ^. #arguments + @?= ["-p", "--no-session-persistence", "--permission-mode", "plan"] + persisted <- renderedAgentCommand persisting req + persisted ^. #arguments @?= ["-p", "--permission-mode", "plan"] + +-- | The unattended renderer describes what it did with the caller's +-- reasoning-effort request, and the description agrees with the argument +-- vector it produced. +-- +-- Asserted together on purpose: the whole value of the translation is +-- that it survives a collapse the command line cannot express, and two +-- separate tests could drift apart without either failing. +agentThinkingTranslationTests :: TestTree +agentThinkingTranslationTests = + testGroup + "the unattended claude renderer records what --effort actually received" + ( testCase + "no effort requested is not a downgrade" + ( do + (cmd, translation) <- renderedAgentPair ClaudeAgent.defaultClaudeAgentConfig (effortRequest Nothing) + assertBool + ("no --effort flag is rendered: " <> show (cmd ^. #arguments)) + ("--effort" `notElem` (cmd ^. #arguments)) + translation @?= noThinkingRequested + ) + : [ testCase (Text.unpack (renderThinkingLevel level)) $ do + (cmd, translation) <- + renderedAgentPair ClaudeAgent.defaultClaudeAgentConfig (effortRequest (Just level)) + assertBool + ("--effort " <> Text.unpack wire <> " in " <> show (cmd ^. #arguments)) + (["--effort", Text.unpack wire] `isConsecutiveIn` (cmd ^. #arguments)) + translation + @?= ThinkingTranslation + { requested = Just level, + mode = ThinkingModeFlag, + effortText = Just wire, + budgetTokens = Nothing, + wireField = Just "--effort", + displayText = Nothing, + adjustments = expected + } + | (level, wire, expected) <- + [ -- claude's --effort has no minimal, so the lowest level + -- collapses and a run at minimal is wire-identical to a + -- run at low. + (ThinkingMinimal, "low", [EffortClamped ThinkingMinimal "low"]), + (ThinkingLow, "low", []), + (ThinkingMedium, "medium", []), + (ThinkingHigh, "high", []), + (ThinkingXHigh, "xhigh", []), + (ThinkingMax, "max", []) + ] + ] + ) + where + effortRequest level = + agentRunRequest AgentClaude "/work/project" "prompt" & #effort .~ level + +-- | Whether the needle appears as consecutive elements of the haystack. +isConsecutiveIn :: (Eq a) => [a] -> [a] -> Bool +isConsecutiveIn needle haystack = + any (\suffix -> needle == take (length needle) suffix) (suffixes haystack) + where + suffixes xs = + xs : case xs of + [] -> [] + (_ : rest) -> suffixes rest + +-- | The pre-dispatch strictness gate, fed by this package's __real__ +-- translation functions rather than by hand-built adjustments. +-- +-- The generic gate is exhaustively covered in +-- @baikai/test/StrictEvidenceSpec.hs@; what only this package can prove +-- is that its own downgrade sites actually reach the gate. +strictEvidenceTests :: TestTree +strictEvidenceTests = + testGroup + "strict evidence refuses this provider's real downgrades" + [ testCase "a model that does not advertise reasoning is refused" $ do + let m = + emptyModel + & #modelId .~ "claude-no-reasoning" + & #api .~ AnthropicMessages + & #reasoning .~ False + opts = emptyOptions & #thinking .~ Just ThinkingHigh + expectDowngrade + (ThinkingDroppedUnsupportedModel ThinkingHigh) + (describeThinkingFor m opts), + testCase "A THINKING BUDGET THAT WILL NOT FIT max_tokens IS REFUSED" $ do + -- The least discoverable downgrade in baikai: a caller lowered + -- maxTokens and silently lost thinking on a reasoning model. + let m = + emptyModel + & #modelId .~ "claude-reasoning" + & #api .~ AnthropicMessages + & #reasoning .~ True + & #maxOutputTokens .~ 8192 + opts = + emptyOptions + & #thinking .~ Just ThinkingMax + & #maxTokens .~ Just 128 + case describeThinkingFor m opts ^. #adjustments of + [ThinkingDroppedBudgetExceeded lvl _ _] -> lvl @?= ThinkingMax + other -> assertFailure ("expected a budget drop, got: " <> show other) + assertBool + "the gate must refuse it" + (not (null (checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) (declaredStrength AnthropicMessages) (describeThinkingFor m opts)))), + testCase "the claude CLI's minimal collapse is refused" $ + expectDowngrade + (EffortClamped ThinkingMinimal "low") + (ClaudeCli.claudeCliThinking (emptyOptions & #thinking .~ Just ThinkingMinimal)), + testCase "a level this transport expresses exactly is not refused" $ do + let m = + emptyModel + & #modelId .~ "claude-reasoning" + & #api .~ AnthropicMessages + & #reasoning .~ True + & #maxOutputTokens .~ 64000 + opts = emptyOptions & #thinking .~ Just ThinkingMedium + checkEvidenceRequirements + (EvidenceRequired EvidenceModelObserved) + (declaredStrength AnthropicMessages) + (describeThinkingFor m opts) + @?= [] + ] + where + expectDowngrade expected translation = + case checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + (declaredStrength AnthropicMessages) + translation of + [ThinkingWouldDowngrade [reported]] -> reported @?= expected + other -> assertFailure ("expected one downgrade refusal, got: " <> show other) + +agentProviderGuardTest :: TestTree +agentProviderGuardTest = + testCase "the claude renderer refuses a request that names codex" $ do + let req = agentRunRequest AgentCodex "/work/project" "prompt" + fmap fst (ClaudeAgent.claudeAgentCommand ClaudeAgent.defaultClaudeAgentConfig req) + @?= Left (ProviderMismatch AgentClaude AgentCodex) + +-- | The launch shape this initiative's first consumer embeds today in +-- @scripts/sync-keiro-dsl.sh@ in the @shinzui/keiro-syntax@ repository, +-- rendered from a provider-neutral request instead of Claude-specific +-- flags written into the script. +agentKeiroFixtureTest :: TestTree +agentKeiroFixtureTest = + testCase "the sync-keiro-dsl launch shape renders without script-level claude flags" $ do + let req = + agentRunRequest AgentClaude "/work/keiro-syntax" "reconcile the Keiro DSL" + & #extraDirs .~ ["/work/keiro"] + & #safety + .~ ( agentSafety AgentEditWorkspace + & #allowedTools + .~ [ "Read", + "Write", + "Edit", + "Glob", + "Grep", + "Bash", + "Skill", + "TodoWrite" + ] + ) + cmd <- renderedAgentCommand ClaudeAgent.defaultClaudeAgentConfig req + cmd ^. #executable @?= "claude" + cmd ^. #arguments + @?= [ "-p", + "--no-session-persistence", + "--permission-mode", + "acceptEdits", + "--allowedTools", + "Read,Write,Edit,Glob,Grep,Bash,Skill,TodoWrite", + "--add-dir", + "/work/keiro" + ] + cmd ^. #promptTransport @?= PromptOnStdin + cmd ^. #promptText @?= "reconcile the Keiro DSL" + batchCommandRenderingTest :: TestTree batchCommandRenderingTest = testCase "claude -p argv terminates options before a dash-leading prompt" $ do @@ -349,15 +792,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/ShapeSpec.hs b/test/ShapeSpec.hs --- a/test/ShapeSpec.hs +++ b/test/ShapeSpec.hs @@ -2,13 +2,16 @@ import Baikai import Baikai.Models.Generated qualified as Models -import Baikai.Provider.Claude.Internal.Request (mapRequest) +import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) import Baikai.Provider.Claude.Shape (streamRequestBody) -import Control.Lens ((&), (.~)) +import Baikai.Provider.Claude.Transport qualified as Transport +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Vector qualified as Vector import Test.Tasty (TestTree, testGroup) @@ -18,7 +21,12 @@ tests = testGroup "ShapeSpec" - [ verbatimToolSchemaTest, + [ testCase "server-side fallbacks stay absent from the request" $ do + value <- shapedBody Models.anthropic_claude_opus_5 emptyContext emptyOptions + lookupPath ["fallbacks"] value @?= Nothing, + summaryDisplayTest, + fastSpeedTests, + verbatimToolSchemaTest, toolChoiceNoneTest, toolCacheControlTest, toolCacheControlCompatGateTest @@ -102,7 +110,7 @@ shapedBody :: Model -> Context -> Options -> IO Value shapedBody model ctx opts = do - req <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts) + (req, _) <- either (assertFailure . Text.unpack) pure (mapRequest model ctx opts) pure (streamRequestBody (anthropicMessagesCompatFor model) ctx opts req) objectSchema :: Value @@ -124,3 +132,59 @@ i < Vector.length xs = lookupPath rest (xs Vector.! i) lookupPath _ _ = Nothing + +fastSpeedTests :: TestTree +fastSpeedTests = + testGroup + "speed" + [ testCase "a fast-mode request on claude-opus-5 carries speed and the beta header" $ do + let m = Models.anthropic_claude_opus_5 + opts = emptyOptions & #speed .~ Just SpeedFast + value <- shapedBody m emptyContext opts + lookupPath ["speed"] value @?= Just (String "fast") + lookup "anthropic-beta" (headers m opts) @?= Just "fast-mode-2026-02-01", + testCase "a fast-mode request on claude-sonnet-5 omits speed and records the drop" $ do + let m = Models.anthropic_claude_sonnet_5 + opts = emptyOptions & #speed .~ Just SpeedFast + value <- shapedBody m emptyContext opts + lookupPath ["speed"] value @?= Nothing + lookup "anthropic-beta" (headers m opts) @?= Nothing + case mapRequest m emptyContext opts of + Left err -> assertFailure (show err) + Right (_, translation) -> do + translation @?= describeThinkingFor m opts + translation ^. #adjustments @?= [FastModeDroppedUnsupportedModel] + weakensThinking FastModeDroppedUnsupportedModel @?= False + Aeson.fromJSON (Aeson.toJSON FastModeDroppedUnsupportedModel) @?= Aeson.Success FastModeDroppedUnsupportedModel, + testCase "absent and explicit standard speed remain distinct on unsupported models" $ do + let m = Models.anthropic_claude_sonnet_5 + opts = emptyOptions & #speed .~ Just SpeedStandard + absent <- shapedBody m emptyContext emptyOptions + standard <- shapedBody m emptyContext opts + lookupPath ["speed"] absent @?= Nothing + lookupPath ["speed"] standard @?= Just (String "standard") + lookup "anthropic-beta" (headers m opts) @?= Nothing + describeThinkingFor m opts ^. #adjustments @?= [], + testCase "caller beta headers override model and automatic fast beta headers" $ do + let m = Models.anthropic_claude_opus_5 & #headers .~ Map.singleton "anthropic-beta" "model-beta" + opts = emptyOptions & #speed .~ Just SpeedFast & #headers .~ Map.singleton "Anthropic-Beta" "caller-beta" + lookup "anthropic-beta" (headers m emptyOptions) @?= Just "model-beta" + lookup "anthropic-beta" (headers m opts) @?= Just "caller-beta" + ] + where + headers m opts = Transport.requestHeaders "test-key" Nothing (anthropicMessagesCompatFor m) emptyContext m opts + +summaryDisplayTest :: TestTree +summaryDisplayTest = testCase "adaptive requests ask for summarized display; budget and absent thinking retain their shapes" $ do + let opts = emptyOptions & #thinking .~ Just ThinkingLow + forM_ [Models.anthropic_claude_opus_5, Models.anthropic_claude_opus_4_6, Models.anthropic_claude_fable_5_1, Models.anthropic_claude_opus_5 & #modelId .~ "renamed"] $ \m -> do + body <- shapedBody m emptyContext opts + lookupPath ["thinking"] body @?= Just (Aeson.object ["type" .= ("adaptive" :: Text.Text), "display" .= ("summarized" :: Text.Text)]) + describeThinkingFor m opts ^. #displayText @?= Just "summarized" + absent <- shapedBody m emptyContext emptyOptions + lookupPath ["thinking"] absent @?= Nothing + describeThinkingFor m emptyOptions ^. #displayText @?= Nothing + let budget = Models.anthropic_claude_haiku_4_5 + body <- shapedBody budget emptyContext opts + lookupPath ["thinking"] body @?= Just (Aeson.object ["type" .= ("enabled" :: Text.Text), "budget_tokens" .= thinkingTokenBudget ThinkingLow]) + describeThinkingFor budget opts ^. #displayText @?= Nothing diff --git a/test/SseSpec.hs b/test/SseSpec.hs --- a/test/SseSpec.hs +++ b/test/SseSpec.hs @@ -1,18 +1,40 @@ module SseSpec (tests) where -import Baikai.Error (ErrorCategory (..), category, httpStatus, retryAfterSeconds) -import Baikai.Provider.Claude.Sse (sseFromResponse) +import Baikai +import Baikai.Http qualified as Http +import Baikai.Models.Generated (anthropic_claude_fable_5_1, anthropic_claude_haiku_4_5, anthropic_claude_opus_5) +import Baikai.Provider.Claude.Internal.Stream (Assembler, SseDriver, claudeMessagesStreamWith, emptyAssembler, translate) +import Baikai.Provider.Claude.Sse + ( ResponseMetadata, + buildRequest, + claudeSseStreamValueWithHeaders, + sseFromResponse, + ) +import Baikai.Usage qualified as Usage 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.ByteString.Lazy qualified as LBS 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.Set qualified as Set +import Data.Text qualified as Text +import Data.Time.Clock (UTCTime) +import Data.Vector (Vector) +import Data.Vector qualified as Vector import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) +import Servant.Client qualified as Client +import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) tests :: TestTree tests = @@ -20,8 +42,9 @@ "Baikai.Provider.Claude.Sse" [ testCase "non-2xx response preserves Retry-After and status" $ do eventsRef <- newIORef [] + metaRef <- newIORef [] resp <- mkResponse 429 [("Retry-After", "7")] ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"] - sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev])) + sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev])) events <- readIORef eventsRef case events of [Left e] -> do @@ -29,8 +52,40 @@ 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 [] resp <- mkResponse 200 @@ -40,14 +95,376 @@ "\"usage\":{\"input_tokens\":3,\"output_tokens\":0}}}\r\n\r\n", "data: {\"type\":\"message_stop\"}\n\n" ] - sseFromResponse resp (\ev -> modifyIORef' eventsRef (<> [ev])) + sseFromResponse resp (\md -> modifyIORef' metaRef (<> [md])) (\ev -> modifyIORef' eventsRef (<> [ev])) events <- readIORef eventsRef case events of [Right 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) + other -> assertFailure ("expected message_start then message_stop, got: " <> show other), + observationTests, + requestShapeTests, + redirectTests ] +-- | What the transport and the assembler between them can say about +-- what Anthropic reported, as opposed to what was configured. +-- +-- The fixture's @model@ deliberately differs from the model the +-- assembler was built with. If they matched, a bug that read the +-- caller's configuration instead of the provider's event would pass +-- these assertions, which is exactly the substitution the 'Observed' +-- type exists to prevent. +observationTests :: TestTree +observationTests = + testGroup + "response observation" + [ testCase "a 200 response yields one metadata value carrying request-id" $ do + (metas, _) <- replay 200 [("request-id", "req_abc123"), ("x-api-key", "sk-leak")] successBody + case metas of + [md] -> do + md ^. #httpStatus @?= 200 + -- Allow-list, not denylist: the credential-shaped header the + -- fixture also carries must not be recorded. + md ^. #headers @?= [("request-id", "req_abc123")] + other -> assertFailure ("expected exactly one metadata value, got: " <> show other), + testCase "partial and repeated usage snapshots preserve reported cache categories" $ do + let start = frameOf "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_usage\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-test\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":10,\"output_tokens\":0,\"cache_read_input_tokens\":20}}}" + partial = frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":100}}" + final = frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":100,\"cache_creation_input_tokens\":30}}" + (_, before) <- replayTranslate [start, partial] + (before ^. #usage) ^. #availability @?= Just (Usage.UsageAvailability (Set.singleton Usage.CacheWriteUsage) False Set.empty) + (_, once) <- replayTranslate [start, partial, final] + (_, twice) <- replayTranslate [start, partial, final, final] + once ^. #usage @?= twice ^. #usage + (once ^. #usage) ^. #totalTokens @?= 160 + (once ^. #usage) ^. #availability @?= Just (Usage.UsageAvailability Set.empty False Set.empty) + let (_, failed) = translate (Left (providerUnavailable "reset")) once testTime + failed ^. #usage @?= once ^. #usage, + testCase "the observed model comes from message_start, not the configured model" $ do + (_, ass) <- replay 200 [("request-id", "req_abc123")] successBody + ass ^. #observedModel @?= Observed "claude-haiku-4-5-20990101-server-side" + -- Asserted as a difference rather than against a literal + -- catalog id, which is generated and moves. + assertBool + "the fixture's model must differ from the configured one" + (ass ^. #observedModel /= Observed (anthropic_claude_haiku_4_5 ^. #modelId)) + ass ^. #responseId @?= Just "msg_observed" + ass ^. #usageReported @?= True, + testCase "a failed response still yields metadata, and observes no model" $ do + (metas, ass) <- + replay + 429 + [("request-id", "req_failed")] + ["{\"type\":\"error\",\"error\":{\"type\":\"rate_limit_error\",\"message\":\"slow\"}}"] + case metas of + [md] -> do + md ^. #httpStatus @?= 429 + md ^. #headers @?= [("request-id", "req_failed")] + other -> assertFailure ("expected exactly one metadata value, got: " <> show other) + ass ^. #observedModel @?= Unobserved + ass ^. #usageReported @?= False, + testCase "a gateway header is captured when Anthropic's own is absent" $ do + (metas, _) <- replay 200 [("cf-ray", "ray-9"), ("x-request-id", "gw-1")] successBody + case metas of + -- Recorded in the order the response listed them; the + -- adapter's preference order lives in capturedHeaderNames. + [md] -> md ^. #headers @?= [("cf-ray", "ray-9"), ("x-request-id", "gw-1")] + 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 "fast terminal pricing follows observed speed, including missing observations" $ do + forM_ [(Just "fast", 1 / 50, Set.empty), (Just "standard", 1 / 100, Set.empty), (Nothing, 1 / 100, Set.singleton SpeedNotReported)] $ \(observed, expected, reasons) -> do + let speedJson = maybe "" (\v -> ",\"speed\":\"" <> v <> "\"") observed + body = [frameOf ("{\"type\":\"message_start\",\"message\":{\"id\":\"msg_fast\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-opus-5\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":0,\"output_tokens\":0,\"cache_read_input_tokens\":0,\"cache_creation_input_tokens\":1000,\"service_tier\":\"standard\"" <> speedJson <> "}}}"), frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":0}}", frameOf "{\"type\":\"message_stop\"}"] + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] body)) anthropic_claude_opus_5 emptyContext (testOptions & #cacheRetention .~ Just CacheRetentionLong & #speed .~ Just SpeedFast) + response ^. #message . #usage . #cost . #usd @?= expected + response ^. #message . #usage . #cost . #basis . #estimateReasons @?= reasons, + testCase "Fable cache writes use the shaped duration including compatibility downgrades" $ do + let fable = anthropic_claude_fable_5_1 + downgraded = fable & #compat .~ CompatAnthropicMessages (anthropicMessagesCompatFor fable & #supportsLongCacheRetention .~ False) + body = [frameOf "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_cost\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-fable-5-1\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":0,\"output_tokens\":0,\"cache_read_input_tokens\":0,\"cache_creation_input_tokens\":1000,\"service_tier\":\"standard\",\"speed\":\"standard\"}}}", frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":0}}", frameOf "{\"type\":\"message_stop\"}"] + forM_ [(fable, CacheRetentionLong, 1 / 50), (fable, CacheRetentionShort, 1 / 80), (downgraded, CacheRetentionLong, 1 / 80)] $ \(m, duration, expected) -> do + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] body)) m emptyContext (testOptions & #cacheRetention .~ Just duration) + response ^. #message . #usage . #cost . #usd @?= expected + response ^. #message . #usage . #cost . #basis . #estimateReasons @?= Set.empty + fmap Usage.billingFacts (response ^. #message . #usage . #availability) @?= Just (Set.fromList [Usage.BillingServiceTier "standard", Usage.BillingSpeed "standard"]), + 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)), + refusalDetailTests, + 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] +successBody = + [ "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\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},", + "\"usage\":{\"output_tokens\":5}}\n\n", + "data: {\"type\":\"message_stop\"}\n\n" + ] + +-- | Drive a recorded response through the real transport and fold the +-- events it produces through the real translator. +replay :: + Int -> [(ByteString, ByteString)] -> [ByteString] -> IO ([ResponseMetadata], Assembler) +replay status headers chunks = do + metaRef <- newIORef [] + eventsRef <- newIORef [] + resp <- mkResponse status headers chunks + sseFromResponse + resp + (\md -> modifyIORef' metaRef (<> [md])) + (\ev -> modifyIORef' eventsRef (<> [ev])) + metas <- readIORef metaRef + events <- readIORef eventsRef + let ass = + foldl' + (\acc ev -> snd (translate ev acc testTime)) + (emptyAssembler anthropic_claude_haiku_4_5 testTime) + events + pure (metas, ass) + +testTime :: UTCTime +testTime = read "2026-07-03 12:00:00 UTC" + mkResponse :: Int -> [(ByteString, ByteString)] -> [ByteString] -> IO (HTTP.Response HTTP.BodyReader) mkResponse status headers chunks = do ref <- newIORef chunks @@ -67,3 +484,164 @@ 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" + +refusalDetailTests :: TestTree +refusalDetailTests = + testGroup + "refusal details" + [ testCase "a categorised refusal names its category and explanation" $ + check (Just "cyber") (Just "Provider explanation"), + testCase "unknown categories survive without an enum update" $ + check (Just "future_category") Nothing, + testCase "an explanation survives without a category" $ + check Nothing (Just "Provider explanation"), + testCase "null details preserve the original refusal message" $ do + events <- replayStream 200 [] (refusalWithDetails Aeson.Null) + be <- terminalError events + be ^. #refusalCategory @?= Nothing + be ^. #message @?= base, + testCase "absent detail fields preserve the original refusal message" $ + check Nothing Nothing, + testCase "explicit null category and explanation remain absent" $ do + events <- replayStream 200 [] (refusalWithDetails (Aeson.object ["type" Aeson..= ("refusal" :: Text.Text), "category" Aeson..= Aeson.Null, "explanation" Aeson..= Aeson.Null])) + be <- terminalError events + be ^. #refusalCategory @?= Nothing + be ^. #message @?= base, + testCase "non-refusal completion does not turn stray details into an error" $ do + let body = map (S8.pack . Text.unpack . Text.replace "\"stop_reason\":\"refusal\"" "\"stop_reason\":\"end_turn\"" . Text.pack . S8.unpack) (refusalWithDetails (detail (Just "cyber") Nothing)) + events <- replayStream 200 [] body + case reverse events of + EventDone TerminalPayload {errorInfo = Nothing} : _ -> pure () + other -> assertFailure (show other), + testCase "blocking completion preserves the structured refusal" $ do + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] (refusalWithDetails (detail (Just "bio") Nothing)))) testModel emptyContext testOptions + fmap (\be -> be ^. #refusalCategory) (response ^. #errorInfo) @?= Just (Just "bio") + ] + where + base = "Anthropic refused to generate a response (stop_reason=refusal)" + detail :: Maybe Text.Text -> Maybe Text.Text -> Aeson.Value + detail c e = Aeson.object (["type" Aeson..= ("refusal" :: Text.Text)] <> maybe [] (\v -> ["category" Aeson..= v]) c <> maybe [] (\v -> ["explanation" Aeson..= v]) e) + check c e = do + events <- replayStream 200 [] (refusalWithDetails (detail c e)) + assertErrorContract events + be <- terminalError events + be ^. #category @?= ContentFiltered + isRetryable be @?= False + be ^. #refusalCategory @?= c + be ^. #message @?= base <> maybe "" (\v -> " [category=" <> v <> "]") c <> maybe "" (": " <>) e + +refusalWithDetails :: Aeson.Value -> [ByteString] +refusalWithDetails details = + take 1 refusalBody + <> [ frameOf + ( LBS.toStrict + ( Aeson.encode + ( Aeson.object + [ "type" Aeson..= ("message_delta" :: Text.Text), + "delta" Aeson..= Aeson.object ["stop_reason" Aeson..= ("refusal" :: Text.Text), "stop_details" Aeson..= details], + "usage" Aeson..= Aeson.object ["output_tokens" Aeson..= (1 :: Int)] + ] + ) + ) + ), + frameOf "{\"type\":\"message_stop\"}" + ] diff --git a/test/ThinkingSpec.hs b/test/ThinkingSpec.hs --- a/test/ThinkingSpec.hs +++ b/test/ThinkingSpec.hs @@ -4,17 +4,25 @@ 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 +import Numeric.Natural (Natural) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -22,7 +30,16 @@ tests = testGroup "ThinkingSpec" - [ testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests), + [ testCase "foreign opaque reasoning cannot enter this endpoint" $ do + let thought = emptyThinkingContent & #replayState .~ Just (ThinkingReplay OpenAIResponses "gpt-6-astra" (Vector.singleton (Aeson.object []))) + response = emptyResponse & #message . #content .~ Vector.singleton (AssistantThinking thought) + ctx = addResponse response emptyContext + case mapRequest anthropic_claude_fable_5_1 ctx emptyOptions of + Left _ -> pure () + Right _ -> assertFailure "foreign state was silently accepted", + testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests), + translationTableTests, + conditionalDowngradeTests, adaptiveHigherEffortTests, maxBudgetTest, explicitMaxTokensTest, @@ -30,19 +47,39 @@ tooSmallCapDropsThinkingTest, mergedOutputConfigTest, explicitCompatOverridesDefaultTest, + anthropicModelsCoverCatalogTest, + testGroup "fast-mode catalog facts" [testCase name ((anthropicMessagesCompatFor m ^. #supportsFastMode) @?= fast) | (name, m, _, _, _, fast) <- anthropicModels], + testGroup "forced-tool catalog facts" [testCase name ((anthropicMessagesCompatFor m ^. #supportsForcedToolChoice) @?= forced) | (name, m, _, _, forced, _) <- anthropicModels], + samplingTests, + claude15UsageTests, + zeroCapFloorTests, + replaySanitationTests, + toolIdTests, streamFidelityTests ] -anthropicModels :: [(String, Model, AnthropicThinkingStyle)] +-- | Every Anthropic model in the generated catalog, with the three +-- 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.supportsForcedToolChoice'. +-- +-- @anthropicModelsCoverCatalogTest@ ties the table to @allModels@, so a +-- newly curated model cannot arrive unpinned. +anthropicModels :: [(String, Model, AnthropicThinkingStyle, Bool, Bool, 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, True, False), + ("claude-fable-5-1", anthropic_claude_fable_5_1, AnthropicThinkingAdaptive, False, False, False), + ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive, True, True, False), + ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive, False, True, False), + ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive, False, True, True), + ("claude-opus-5", anthropic_claude_opus_5, AnthropicThinkingAdaptive, False, True, True), + ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingAdaptive, True, True, False), + ("claude-sonnet-5", anthropic_claude_sonnet_5, AnthropicThinkingAdaptive, False, True, False) ] thinkingLevels :: [(String, ThinkingLevel)] @@ -59,9 +96,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 ] @@ -76,16 +113,120 @@ @?= 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) + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) + req ^. #max_tokens @?= model ^. #maxOutputTokens + (req ^. #output_config >>= Messages.effort) @?= adaptiveEffort level - | (name, model, style) <- anthropicModels, + | (name, model, style, _, _, _) <- anthropicModels, (levelName, level) <- thinkingLevels ] +-- | Every canonical level against both Anthropic thinking styles, with +-- the exact effort text, exact budget, and exact adjustment list each +-- one produces. +-- +-- The expected values are written out rather than computed from the +-- functions under test, so a change to either mapping fails a row here +-- instead of quietly agreeing with itself. A failing row is either a +-- transcription error or a real behaviour change, and the two must be +-- told apart before either side is edited. +translationTable :: + [(AnthropicThinkingStyle, ThinkingLevel, Maybe Text.Text, Maybe Natural, [ThinkingAdjustment])] +translationTable = + [ -- A token budget expresses every level exactly: nothing is adjusted. + (AnthropicThinkingBudget, ThinkingMinimal, Nothing, Just 1024, []), + (AnthropicThinkingBudget, ThinkingLow, Nothing, Just 2048, []), + (AnthropicThinkingBudget, ThinkingMedium, Nothing, Just 8192, []), + (AnthropicThinkingBudget, ThinkingHigh, Nothing, Just 16384, []), + (AnthropicThinkingBudget, ThinkingXHigh, Nothing, Just 24576, []), + (AnthropicThinkingBudget, ThinkingMax, Nothing, Just 32768, []), + -- Anthropic's adaptive vocabulary has no "minimal", so the lowest + -- level is clamped up to "low" and says so. + ( AnthropicThinkingAdaptive, + ThinkingMinimal, + Just "low", + Nothing, + [EffortClamped ThinkingMinimal "low"] + ), + (AnthropicThinkingAdaptive, ThinkingLow, Just "low", Nothing, []), + (AnthropicThinkingAdaptive, ThinkingMedium, Just "medium", Nothing, []), + -- "high" sends no effort field at all, which on the wire is + -- indistinguishable from expressing no preference. + ( AnthropicThinkingAdaptive, + ThinkingHigh, + Nothing, + Nothing, + [EffortOmitted ThinkingHigh] + ), + (AnthropicThinkingAdaptive, ThinkingXHigh, Just "xhigh", Nothing, []), + (AnthropicThinkingAdaptive, ThinkingMax, Just "max", Nothing, []) + ] + +translationTableTests :: TestTree +translationTableTests = + testGroup + "thinking translation table" + [ testCase (show style <> " " <> Text.unpack (renderThinkingLevel level)) $ do + t <- translationFor (modelWithStyle style) (emptyOptions & #thinking .~ Just level) + t ^. #requested @?= Just level + t ^. #mode @?= expectedMode + t ^. #effortText @?= expectedEffort + t ^. #budgetTokens @?= expectedBudget + t ^. #wireField @?= Just "thinking" + t ^. #adjustments @?= expectedAdjustments + | (style, level, expectedEffort, expectedBudget, expectedAdjustments) <- translationTable, + let expectedMode = case style of + AnthropicThinkingBudget -> ThinkingModeBudget + AnthropicThinkingAdaptive -> ThinkingModeAdaptive + ] + +-- | A reasoning model whose thinking style is pinned explicitly, so a +-- row of the table above depends on the style it names rather than on +-- which model generation happens to default to it. +modelWithStyle :: AnthropicThinkingStyle -> Model +modelWithStyle style = + anthropic_claude_haiku_4_5 + & #compat .~ CompatAnthropicMessages (defaultAnthropicMessagesCompat {thinkingStyle = style}) + +-- | The two downgrades that depend on the model rather than the level: +-- a model that cannot reason at all, and an output ceiling too small to +-- hold the budget the level asks for. Neither was visible anywhere in +-- baikai's output before this plan. +conditionalDowngradeTests :: TestTree +conditionalDowngradeTests = + testGroup + "conditional thinking downgrades" + [ testCase "a non-reasoning model drops thinking and records why" $ do + let model = anthropic_claude_haiku_4_5 & #reasoning .~ False + req <- requestFor model (emptyOptions & #thinking .~ Just ThinkingMedium) + requestThinking req @?= Nothing + t <- translationFor model (emptyOptions & #thinking .~ Just ThinkingMedium) + t ^. #requested @?= Just ThinkingMedium + t ^. #mode @?= ThinkingModeUnsupported + t ^. #wireField @?= Nothing + t ^. #budgetTokens @?= Nothing + t ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingMedium], + testCase "an output ceiling at or below the budget drops thinking and names both numbers" $ do + -- 1000 is below ThinkingMinimal's 1024-token budget, so the + -- resolved ceiling collapses onto the cap and the budget can no + -- longer fit inside it. + let model = anthropic_claude_haiku_4_5 & #maxOutputTokens .~ 1000 + opts = emptyOptions & #thinking .~ Just ThinkingMinimal + req <- requestFor model opts + requestThinking req @?= Nothing + req ^. #max_tokens @?= 1000 + t <- translationFor model opts + t ^. #requested @?= Just ThinkingMinimal + t ^. #mode @?= ThinkingModeUnsupported + t ^. #wireField @?= Nothing + t ^. #budgetTokens @?= Nothing + t ^. #effortText @?= Nothing + t ^. #adjustments + @?= [ThinkingDroppedBudgetExceeded ThinkingMinimal 1024 1000] + ] + adaptiveHigherEffortTests :: TestTree adaptiveHigherEffortTests = testGroup @@ -95,8 +236,8 @@ requestFor anthropic_claude_opus_4_7 (emptyOptions & #thinking .~ Just level) - requestThinking req @?= Just Messages.ThinkingAdaptive - (Messages.output_config req >>= Messages.effort) @?= Just expected + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) + (req ^. #output_config >>= Messages.effort) @?= Just expected | (name, level, expected) <- [ ("xhigh is preserved", ThinkingXHigh, "xhigh"), ("max is preserved", ThinkingMax, "max") @@ -114,7 +255,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 = @@ -127,7 +268,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 = @@ -145,7 +286,7 @@ & #maxTokens .~ Just 100 expected = 100 + thinkingTokenBudget ThinkingLow req <- requestFor model opts - Messages.max_tokens req @?= expected + req ^. #max_tokens @?= expected tooSmallCapDropsThinkingTest :: TestTree tooSmallCapDropsThinkingTest = @@ -156,7 +297,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 = @@ -166,11 +307,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 + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) + req ^. #output_config @?= Just expected explicitCompatOverridesDefaultTest :: TestTree explicitCompatOverridesDefaultTest = @@ -184,13 +325,20 @@ & #compat .~ CompatAnthropicMessages compat opts = emptyOptions & #thinking .~ Just ThinkingLow req <- requestFor model opts - requestThinking req @?= Just Messages.ThinkingAdaptive - (Messages.output_config req >>= Messages.effort) @?= Just "low" + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) + (req ^. #output_config >>= Messages.effort) @?= Just "low" requestFor :: Model -> Options -> IO Messages.CreateMessage -requestFor model opts = case mapRequest model emptyContext opts of +requestFor model opts = fst <$> mappedFor model emptyContext opts + +translationFor :: Model -> Options -> IO ThinkingTranslation +translationFor model opts = snd <$> mappedFor model emptyContext opts + +mappedFor :: + Model -> Context -> Options -> IO (Messages.CreateMessage, ThinkingTranslation) +mappedFor model ctx opts = case mapRequest model ctx opts of Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e) - Right req -> pure req + Right mapped -> pure mapped requestThinking :: Messages.CreateMessage -> Maybe Messages.Thinking requestThinking Messages.CreateMessage {Messages.thinking = t} = t @@ -204,6 +352,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, replayState = Nothing}], + 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 @@ -214,13 +691,15 @@ ThinkingContent { thinking = "because therefore", signature = Just "sig-final", - redacted = False + redacted = False, + replayState = Nothing } expectedRedacted = ThinkingContent { thinking = "ENCRYPTED==", signature = Nothing, - redacted = True + redacted = True, + replayState = Nothing } thinkingEnds events @?= [expectedSigned, expectedRedacted] @@ -267,7 +746,8 @@ ThinkingContent { thinking = "draft", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "visible") ], @@ -342,9 +822,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 ] @@ -361,18 +842,82 @@ 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 + } + } + runClaudeEvents :: [Messages.MessageStreamEvent] -> ([AssistantMessageEvent], Assembler) runClaudeEvents = foldl' @@ -400,9 +945,7 @@ _ -> error "last event was not terminal" requestForContext :: Model -> Context -> Options -> IO Messages.CreateMessage -requestForContext model ctx opts = case mapRequest model ctx opts of - Left e -> assertFailure ("mapRequest failed: " <> Text.unpack e) - Right req -> pure req +requestForContext model ctx opts = fst <$> mappedFor model ctx opts requestMessages :: Messages.CreateMessage -> Vector.Vector Messages.Message requestMessages Messages.CreateMessage {Messages.messages = msgs} = msgs 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