diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,125 +7,1352 @@ ## [Unreleased] -## [baikai 0.5.0.0] - 2026-08-05 - -### Added - -- `baikai`: new exposed module `Baikai.Agent`, the provider-neutral vocabulary - for an **unattended coding-agent run** — a run with no terminal and no human, - which owns its own tool loop, may change files inside directories the caller - authorized, and returns a process result rather than a `Response`. It defines - `AgentRunRequest` (with a required `workingDir`), `AgentRunResult`, the - `AgentCapability` profile (`read-only`, `edit-workspace`, `full-access`), - `AgentSafety`, the `AgentOutputMode` and `AgentCapturedOutput` output - discipline, the `AgentCommand` renderer/runner boundary with an explicit - prompt transport, and the `AgentRenderError` / `AgentRunFailure` taxonomies. - -- `baikai`: the operator policy ceiling — `AgentCeiling`, - `defaultAgentCeiling`, `CeilingViolation`, and the pure `applyAgentCeiling`. - It returns a request unchanged when it is within the ceiling and reports - every violation when it is not; it never clamps an over-broad request to the - permitted value. The default ceiling permits read-only and edit-workspace - authority and refuses full access and raw provider arguments. - - `Baikai.Agent` itself is vocabulary and pure policy algebra only: it spawns no - process and renders no command-line flags. Those live in the vendor packages - and in `baikai-agent`, below. The module is deliberately not re-exported from - the umbrella `Baikai` module, because its field accessors share names with - `Baikai.Interactive`, so `import Baikai` continues to compile unchanged. - -- `baikai`: new exposed module `Baikai.Evidence`, the vocabulary for - **verifiable model-call evidence** — a record of what actually crossed the - boundary to a provider, as opposed to what the process was configured to ask - for. It defines `ModelCallEvidence` and the `evidenceSchemaVersion` string - consumers pin against, `Observed` (a deliberate non-`Maybe` for a value the - provider either did or did not report, with no function that supplies a - default), `ThinkingTranslation` with its `ThinkingMode` and - `ThinkingAdjustment` enumerations describing what a requested - reasoning-effort level actually became on the wire and every clamp, collapse, - or drop applied on the way, `EndpointIdentity` and `TransportKind`, - `CallStatus`, and the ascending `EvidenceStrength` scale. - - It also provides the canonical hashing core: `canonicalEncode` gives a JSON - value exactly one byte representation (object keys sorted, no insignificant - whitespace, numbers normalised so `1`, `1.0`, `1.00`, and `1e0` all encode as - `1`, and a hand-written string escaper so an aeson upgrade cannot silently - invalidate a recorded digest); `commitmentDigest` hashes a full request - envelope, and `configurationDigest` hashes an allow-list projection - (`configurationProjection`) that keeps configuration and replaces content with - structural summaries, so two calls that ask the same model the same way about - different subjects agree. The two digests are separate on purpose: the first - binds a record to a particular request, the second is safe to compare across - runs that legitimately differ in content. - - Nothing constructs a `ModelCallEvidence` from a real call yet, and no existing - behaviour changed. New dependencies: `cryptohash-sha256` and - `base16-bytestring`, both single-purpose packages chosen over a full - cryptographic framework. - -- `baikai`: `Options` gains an `evidence` field carrying an optional - `EvidenceRequest` — the caller's run identifier, retry provenance, and how - strictly they need evidence. A call whose `evidence` is `Nothing`, which is - every call that does not opt in, behaves exactly as it did before: no digest - is computed and no evidence is emitted. - -- `baikai`: model-call evidence is now **produced and emitted**. A caller who - sets `Options.evidence` gets exactly one `call_evidence` line per call from - their trace sink, under every way a call can end: success, provider failure, a - consumer that abandons the stream (status `aborted`, not `failed` — an abort - is the consumer's doing and reporting it as a provider failure would - misattribute it), and dispatch that found no registered handler. - - New exposed module `Baikai.Evidence.Build` bridges the vocabulary to the - `Model` and `Options` records: `minimalEvidence` and `prepareEvidence` build a - record, `dispatchEnvelope` supplies the request envelope for the paths where - no adapter ran, `sanitizeEndpoint` reduces a base URL to scheme/host/port/path - with the query string and any userinfo dropped wholesale, and `onSinkFailure` - is the hook a future release replaces to make a strict caller's call fail when - the trace sink does. - - Every record this release produces has `strength` `requested_only` and every - provider-observed field set to `"unobserved"`. That is not a placeholder: it - is a truthful record for a transport that has not yet been taught to observe - anything. Later releases teach each transport to observe more. - - **A caller who does not opt in pays nothing.** With `Options.evidence` absent - no digest is computed, no call identifier is generated, no evidence event is - emitted, and the request envelope is never even forced — the gate lives inside - the shared builder rather than at each adapter's call site, and the envelope - parameter is deliberately lazy. Both facts are guarded by tests. - -- `baikai`: `TraceEvent` gains a `CallEvidence` constructor, encoded as - `{"kind":"call_evidence", …}`. A consumer whose pattern match over `TraceEvent` - is exhaustive must add a branch; one with a wildcard is unaffected. Filter for - it with `jq 'select(.kind == "call_evidence") | .evidence'`. Note that a trace - line carries its fields alongside the `kind` discriminator rather than nested - under a `data` key, and that the evidence record inside spells its own fields - in snake_case — the two encodings differ deliberately, because an evidence - record must render an absent field as explicit `null` while a trace line drops - it to stay small. - -- `baikai`: `Baikai.Provider.Cli.Internal` — the module the two subprocess - providers share — gains the vocabulary for reading what a coding-agent CLI - reported about its own run. `CodexRunReport` and the new - `parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport` fold the - `codex exec --json` event stream into its assistant text, its thread - identifier, and its token counts, instead of concatenating agent-message text - and discarding everything else. `ClaudeCliReport` and - `decodeClaudeCliResult` do the same for `claude -p --output-format json`. - Every field but the message text is optional, because both tools' event - schemas have changed across versions and an absent field is a genuine absence - rather than a parse failure. **Breaking** for anyone calling - `parseCodexJsonlStream` directly: its result type is no longer `Text`. This is - an internal module and is documented as outside the PVP guarantee. - -- `baikai`: `Baikai.Provider.Cli.Internal` also gains `ExecutableIdentity` and - `executableIdentity`, which resolve a configured executable name to an - absolute path and read the tool's own `--version` line. The probe is cached - per resolved name for the lifetime of the process, because spawning it per - model call would roughly double the process cost of the cheapest possible - call, and it is bounded by a two-second timeout so a tool that hangs on - `--version` cannot wedge a model call. A probe that fails records the version +## [baikai 0.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 diff --git a/baikai.cabal b/baikai.cabal --- a/baikai.cabal +++ b/baikai.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai -version: 0.5.0.0 +version: 0.6.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -16,6 +16,7 @@ maintainer: nadeem@gmail.com copyright: (c) 2026 Nadeem Bitar build-type: Simple +tested-with: GHC ==9.12.4 extra-doc-files: CHANGELOG.md common common-options @@ -67,6 +68,8 @@ Baikai.Error Baikai.Evidence Baikai.Evidence.Build + Baikai.Header + Baikai.Http Baikai.Interactive Baikai.Message Baikai.Model @@ -75,7 +78,9 @@ Baikai.Prelude Baikai.Provider Baikai.Provider.Cli.Internal + Baikai.Provider.Internal.StreamWorker Baikai.Provider.Registry + Baikai.Provider.Transport.Classify Baikai.Response Baikai.ResponseFormat Baikai.StopReason @@ -86,6 +91,7 @@ Baikai.Trace Baikai.Trace.Event Baikai.Trace.Sink + Baikai.Url Baikai.Usage -- The cabal-generated version module. 'Baikai.Evidence.Build' reads @@ -100,19 +106,26 @@ , base16-bytestring ^>=1.0 , base64-bytestring ^>=1.2 , bytestring ^>=0.12 + , case-insensitive ^>=1.2 , containers ^>=0.7 , cryptohash-sha256 ^>=0.11 , directory ^>=1.3 , filepath ^>=1.5 , generic-lens ^>=2.3 + , http-client ^>=0.7 + , http-client-tls ^>=0.3 + , http-types ^>=0.12 , lens ^>=5.3 , openai ^>=2.5 , process ^>=1.6 , scientific ^>=0.3 + , servant-client ^>=0.20 + , stm ^>=2.5 , streamly >=0.11 && <0.13 , streamly-core >=0.3 && <0.5 , text ^>=2.1 , time ^>=1.14 + , tls >=2.2 && <2.5 , unliftio-core ^>=0.2 , vector ^>=0.13 @@ -180,11 +193,15 @@ GenModelsSpec HelpersSpec InteractiveSpec + PublicSurfaceSpec StreamSpec + StreamWorkerSpec StrictEvidenceSpec SurfaceSpec ThinkingLevelSpec TraceSpec + TransportClassifySpec + UrlSpec UsageSpec build-tool-depends: baikai:baikai-gen-models @@ -193,14 +210,18 @@ , baikai , base , bytestring + , case-insensitive , containers , directory , filepath , generic-lens + , http-client + , http-types , lens , openai , process , scientific + , servant-client , stm , streamly-core >=0.3 && <0.5 , tasty @@ -209,4 +230,5 @@ , temporary , text , time + , tls , vector diff --git a/fetch/FetchModelsCore.hs b/fetch/FetchModelsCore.hs --- a/fetch/FetchModelsCore.hs +++ b/fetch/FetchModelsCore.hs @@ -40,6 +40,8 @@ -- * Output catalog shape CatalogModel (..), CatalogCost (..), + CatalogModelCompat (..), + AnthropicGenerationFacts (..), Catalog (..), -- * Provider specs and normalization @@ -62,6 +64,7 @@ ) where +import Baikai.Compat (AnthropicThinkingStyle (..)) import Baikai.Model (InputModality (..)) import Baikai.Prelude import Data.Aeson (Value (String), eitherDecode, encode, withObject, (.!=), (.:), (.:?)) @@ -188,6 +191,26 @@ } deriving stock (Eq, Show, Generic) +-- | The two request-shaping facts every curated Anthropic model must +-- state before it can enter the catalog. Which extended-thinking wire +-- shape a generation accepts, and whether it accepts the sampling +-- parameters @temperature@, @top_p@ and @top_k@, are facts about the +-- generation that no amount of inspecting the model id or the base URL +-- can recover; they are curated here and travel through the catalog +-- JSON into the generated 'Baikai.Compat.AnthropicMessagesCompat'. +data AnthropicGenerationFacts = AnthropicGenerationFacts + { thinkingStyle :: !AnthropicThinkingStyle, + supportsSamplingParameters :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | A per-model @compat@ block in the catalog JSON. Only +-- @anthropic-messages@ needs one today; the OpenAI-compatible side is +-- fully covered by the file-level @"compat": "auto"@ directive and +-- 'Baikai.Compat.autoDetectOpenAICompletions'. +data CatalogModelCompat = CatalogAnthropicCompat !AnthropicGenerationFacts + deriving stock (Eq, Show, Generic) + -- | One emitted catalog model. @enabled@ is always @true@ for emitted -- models, so it is not stored here; the renderer writes it literally. data CatalogModel = CatalogModel @@ -197,7 +220,8 @@ input :: ![InputModality], cost :: !CatalogCost, contextWindow :: !Integer, - maxOutputTokens :: !Integer + maxOutputTokens :: !Integer, + compat :: !(Maybe CatalogModelCompat) } deriving stock (Eq, Show, Generic) @@ -219,7 +243,11 @@ { provider :: !Text, baseUrl :: !Text, api :: !Text, - include :: !(Text -> Bool) + include :: !(Text -> Bool), + -- | The per-model @compat@ block to render, if this provider needs + -- one. 'const Nothing' for a provider whose file-level + -- @"compat": "auto"@ directive says everything. + compatFor :: !(Text -> Maybe CatalogModelCompat) } deriving stock (Generic) @@ -253,20 +281,56 @@ "o1" ] --- | Curation include set for Anthropic: the current generations. -anthropicInclude :: Set Text +-- | Curation include set for Anthropic: the current generations, each +-- keyed to the request-shaping facts of its generation. +-- +-- This is the one place a human vets an Anthropic id, so it is also the +-- one place the facts are stated: no id can be curated in without them, +-- and a wholesale refresh cannot lose them. Each entry MUST carry a +-- dated comment naming its source, exactly as 'overrides' does. The +-- generator refuses an @anthropic-messages@ entry that reaches it +-- without a @compat@ block, so a hand edit cannot quietly drop one +-- back to host auto-detection. +anthropicInclude :: Map Text AnthropicGenerationFacts anthropicInclude = - Set.fromList - [ "claude-opus-4-8", - "claude-opus-4-7", - "claude-opus-4-6", - "claude-opus-4-5", - "claude-sonnet-5", - "claude-sonnet-4-6", - "claude-sonnet-4-5", - "claude-haiku-4-5", - "claude-fable-5" + Map.fromList + [ -- 2026-08-27: adaptive-only, sampling parameters rejected with a + -- 400 — Anthropic API reference cached 2026-06-24, as consulted + -- by REV-2 C.1 (docs/reviews/correctness-and-api-review-follow-up.md). + -- docs/plans/60-... named this id as the one the include set did not + -- yet carry, and stated the facts it would have to arrive with. + ("claude-opus-5", adaptiveNoSampling), + -- 2026-08-27: adaptive-only, sampling parameters rejected with a + -- 400 — same source. + ("claude-opus-4-8", adaptiveNoSampling), + -- 2026-08-27: adaptive-only, sampling parameters rejected — same source. + ("claude-opus-4-7", adaptiveNoSampling), + -- 2026-08-27: accepts both thinking shapes, but the budget shape is + -- deprecated for this generation, so baikai sends the adaptive one; + -- sampling parameters still accepted — same source. + ("claude-opus-4-6", adaptiveWithSampling), + -- 2026-08-27: budget shape, sampling parameters accepted — same source. + ("claude-opus-4-5", budgetWithSampling), + -- 2026-08-27: adaptive-only, sampling parameters rejected with a 400. + -- This is the finding: the retired prefix table did not know this id + -- and sent it budget_tokens — same source. + ("claude-sonnet-5", adaptiveNoSampling), + -- 2026-08-27: as claude-opus-4-6 — budget deprecated but functional, + -- sampling accepted; baikai prefers the non-deprecated shape — same + -- source. Plan 40 left this membership to a live check that never + -- happened; docs/plans/60-... M4 is where it meets a real key. + ("claude-sonnet-4-6", adaptiveWithSampling), + -- 2026-08-27: budget shape, sampling parameters accepted — same source. + ("claude-sonnet-4-5", budgetWithSampling), + -- 2026-08-27: budget shape, sampling parameters accepted — same source. + ("claude-haiku-4-5", budgetWithSampling), + -- 2026-08-27: adaptive-only, sampling parameters rejected — same source. + ("claude-fable-5", adaptiveNoSampling) ] + where + adaptiveNoSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive False + adaptiveWithSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive True + budgetWithSampling = AnthropicGenerationFacts AnthropicThinkingBudget True -- | Provider spec for OpenAI's first-party chat-completions endpoint. openaiSpec :: ProviderSpec @@ -275,7 +339,8 @@ { provider = "openai", baseUrl = "https://api.openai.com", api = "openai-chat-completions", - include = (`Set.member` openaiInclude) + include = (`Set.member` openaiInclude), + compatFor = const Nothing } -- | Provider spec for Anthropic's first-party messages endpoint. @@ -285,7 +350,8 @@ { provider = "anthropic", baseUrl = "https://api.anthropic.com", api = "anthropic-messages", - include = (`Set.member` anthropicInclude) + include = (`Map.member` anthropicInclude), + compatFor = fmap CatalogAnthropicCompat . (`Map.lookup` anthropicInclude) } -- | Normalize one provider's upstream models into a 'Catalog'. Keeps @@ -325,7 +391,8 @@ cacheWriteCost = fromMaybe 0 (m ^. #cacheWriteCost) }, contextWindow = fromMaybe 0 (m ^. #contextWindow), - maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens) + maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens), + compat = (spec ^. #compatFor) (m ^. #modelId) } -- | Strip a trailing @" (latest)"@ display-name suffix that models.dev @@ -500,12 +567,39 @@ " \"cacheWrite\": " <> renderNum (c ^. #cacheWriteCost), " },", " \"contextWindow\": " <> Text.pack (show (m ^. #contextWindow)) <> ",", - " \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> ",", - " \"enabled\": true", - " }" + " \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> "," ] + ++ renderModelCompat (m ^. #compat) + ++ [ " \"enabled\": true", + " }" + ] where c = m ^. #cost + +-- | Render the per-model @compat@ block, if the provider spec supplied +-- one. The block sits between @maxOutputTokens@ and @enabled@ so a +-- @git diff@ over the catalog shows a generation's wire facts next to +-- its limits. +renderModelCompat :: Maybe CatalogModelCompat -> [Text] +renderModelCompat Nothing = [] +renderModelCompat (Just (CatalogAnthropicCompat facts)) = + [ " \"compat\": {", + " \"kind\": \"anthropic-messages\",", + " \"thinkingStyle\": " + <> jsonString (renderThinkingStyle (facts ^. #thinkingStyle)) + <> ",", + " \"supportsSamplingParameters\": " + <> jsonBool (facts ^. #supportsSamplingParameters), + " }," + ] + +-- | The catalog dialect spells the thinking style as a word, as every +-- other catalog enum does. The derived JSON instance on +-- 'Baikai.Compat.AnthropicThinkingStyle' is part of 'Baikai.Model.Model'\'s +-- pinned round trip and is deliberately not reused here. +renderThinkingStyle :: AnthropicThinkingStyle -> Text +renderThinkingStyle AnthropicThinkingBudget = "budget" +renderThinkingStyle AnthropicThinkingAdaptive = "adaptive" renderInput :: [InputModality] -> Text renderInput ms = "[" <> Text.intercalate ", " (map one ms) <> "]" diff --git a/gen/GenModels.hs b/gen/GenModels.hs --- a/gen/GenModels.hs +++ b/gen/GenModels.hs @@ -34,7 +34,8 @@ import Data.Text qualified as Text import Data.Text.IO qualified as TIO import GenModelsCore - ( checkIdentifierCollisions, + ( checkAnthropicCompat, + checkIdentifierCollisions, flattenEntries, renderModule, ) @@ -56,6 +57,9 @@ Right c -> pure c let allEntries = concatMap flattenEntries catalogs case checkIdentifierCollisions allEntries of + Left err -> die (Text.unpack err) + Right () -> pure () + case checkAnthropicCompat allEntries of Left err -> die (Text.unpack err) Right () -> pure () let sorted = sortOn fst allEntries diff --git a/gen/GenModelsCore.hs b/gen/GenModelsCore.hs --- a/gen/GenModelsCore.hs +++ b/gen/GenModelsCore.hs @@ -14,6 +14,8 @@ GeneratedEntry (..), flattenEntries, checkIdentifierCollisions, + checkAnthropicCompat, + parseAnthropicThinkingStyle, sanitizeIdentifier, renderModule, ) @@ -25,6 +27,7 @@ ( sendSessionAffinityHeaders, supportsCacheControlOnTools, supportsLongCacheRetention, + supportsSamplingParameters, thinkingStyle ), AnthropicThinkingStyle (..), @@ -74,8 +77,9 @@ <*> o .: "compat" <*> o .: "models" --- | A compat directive in the catalog. @"auto"@ defers to EP-5's --- @baseUrl@-driven auto-detection (rendered as 'CompatNone'). The two +-- | A compat directive in the catalog. @"auto"@ defers to the +-- provider's @baseUrl@-driven auto-detection (rendered as +-- 'CompatNone'). The two -- structured constructors carry a full override record. data CatalogCompat = CatalogCompatAuto @@ -124,15 +128,28 @@ slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention scot <- o .:? "supportsCacheControlOnTools" .!= d.supportsCacheControlOnTools ssah <- o .:? "sendSessionAffinityHeaders" .!= d.sendSessionAffinityHeaders - ts <- o .:? "thinkingStyle" .!= d.thinkingStyle + ts <- optionalField o "thinkingStyle" parseAnthropicThinkingStyle d.thinkingStyle + ssp <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters pure d { supportsLongCacheRetention = slcr, supportsCacheControlOnTools = scot, sendSessionAffinityHeaders = ssah, - thinkingStyle = ts + thinkingStyle = ts, + supportsSamplingParameters = ssp } +-- | The catalog dialect spells the extended-thinking wire shape as a +-- word, as every other catalog enum does, rather than through the +-- derived instance on 'AnthropicThinkingStyle' (which is part of +-- 'Baikai.Model.Model'\'s pinned JSON round trip and names the Haskell +-- constructor). +parseAnthropicThinkingStyle :: Text -> Parser AnthropicThinkingStyle +parseAnthropicThinkingStyle = \case + "budget" -> pure AnthropicThinkingBudget + "adaptive" -> pure AnthropicThinkingAdaptive + t -> fail $ "unknown thinkingStyle: " <> Text.unpack t + parseMaxTokensField :: Text -> Parser MaxTokensField parseMaxTokensField = \case "max_tokens" -> pure MaxTokensField @@ -299,6 +316,32 @@ <> Text.intercalate ", " (map origin (reverse es)) origin e = e.provider <> "/" <> e.modelId +-- | Every @anthropic-messages@ entry must state its thinking style and +-- sampling support explicitly. An entry left at the file-level +-- @"compat": "auto"@ directive would fall through to host +-- auto-detection, which knows the host but cannot know the model +-- generation — the drift that sent @claude-sonnet-5@ a @budget_tokens@ +-- request the generation rejects. The generator refuses rather than +-- guessing, so a hand edit to @baikai/data/models/anthropic.json@ that +-- drops a block fails the build instead of shipping. +checkAnthropicCompat :: [(Text, GeneratedEntry)] -> Either Text () +checkAnthropicCompat entries = + case [e | (_, e) <- entries, e.api == AnthropicMessages, not (stated e.compat)] of + [] -> Right () + missing -> Left (Text.intercalate "; " (map complain missing)) + where + stated = \case + CatalogCompatAnthropic _ -> True + _ -> False + complain e = + "anthropic-messages entry " + <> e.provider + <> "/" + <> e.modelId + <> " has no compat block; add {\"kind\":\"anthropic-messages\"" + <> ",\"thinkingStyle\":\"budget\"|\"adaptive\"" + <> ",\"supportsSamplingParameters\":true|false}" + -- | Replace any non-identifier character with @_@. Haskell allows -- letters, digits, underscore, and apostrophe; everything else -- (slash, dash, dot, colon, ...) becomes an underscore. @@ -342,9 +385,25 @@ "", "import Baikai.Api (Api (..))", "import Baikai.Compat", - " ( AnthropicThinkingStyle (..),", + " ( AnthropicMessagesCompat", + " ( sendSessionAffinityHeaders,", + " supportsCacheControlOnTools,", + " supportsLongCacheRetention,", + " supportsSamplingParameters,", + " thinkingStyle", + " ),", + " AnthropicThinkingStyle (..),", " CacheControlFormat (..),", " MaxTokensField (..),", + " OpenAICompletionsCompat", + " ( cacheControlFormat,", + " maxTokensField,", + " requiresThinkingAsText,", + " supportsLongCacheRetention,", + " supportsStrictMode,", + " supportsUsageInStreaming,", + " thinkingFormat", + " ),", " ThinkingFormat (..),", " defaultAnthropicMessagesCompat,", " defaultOpenAICompletionsCompat,", @@ -408,11 +467,12 @@ renderCost g.cost <> ",", " contextWindow = " <> Text.pack (show g.contextWindow) <> ",", " maxOutputTokens = " <> Text.pack (show g.maxOutputTokens) <> ",", - " headers = Map.empty,", - " compat = " <> renderCompat g.compat, - " }", - "" + " headers = Map.empty," ] + ++ renderCompat g.compat + ++ [ " }", + "" + ] renderText :: Text -> Text renderText t = @@ -455,34 +515,40 @@ renderRational r = Text.pack (show (numerator r)) <> " % " <> Text.pack (show (denominator r)) -renderCompat :: CatalogCompat -> Text +-- | The @compat@ field of one rendered entry, as source lines. +-- +-- The layout is the one @ormolu@ produces, because the repository +-- formatter runs over the generated module and @CatalogSpec@ demands +-- the generator's output be byte-identical to the committed file: a +-- layout the formatter would rewrite makes those two checks +-- contradict each other. +renderCompat :: CatalogCompat -> [Text] renderCompat = \case - CatalogCompatAuto -> "CompatNone" + CatalogCompatAuto -> [" compat = CompatNone"] CatalogCompatOpenAI c -> - Text.intercalate - "\n" - [ "CompatOpenAICompletions", - " defaultOpenAICompletionsCompat", - " { maxTokensField = " <> renderMaxTokensField c.maxTokensField <> ",", - " supportsStrictMode = " <> renderBool c.supportsStrictMode <> ",", - " requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",", - " thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",", - " cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",", - " supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",", - " supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, - " }" - ] + [ " compat =", + " CompatOpenAICompletions", + " defaultOpenAICompletionsCompat", + " { maxTokensField = " <> renderMaxTokensField c.maxTokensField <> ",", + " supportsStrictMode = " <> renderBool c.supportsStrictMode <> ",", + " requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",", + " thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",", + " cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",", + " supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",", + " supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, + " }" + ] CatalogCompatAnthropic c -> - Text.intercalate - "\n" - [ "CompatAnthropicMessages", - " defaultAnthropicMessagesCompat", - " { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",", - " supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",", - " sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",", - " thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle, - " }" - ] + [ " compat =", + " CompatAnthropicMessages", + " defaultAnthropicMessagesCompat", + " { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",", + " supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",", + " sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",", + " thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle <> ",", + " supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters, + " }" + ] renderMaxTokensField :: MaxTokensField -> Text renderMaxTokensField = \case diff --git a/src/Baikai.hs b/src/Baikai.hs --- a/src/Baikai.hs +++ b/src/Baikai.hs @@ -19,6 +19,7 @@ module Baikai.AgentAssets, module Baikai.Api, module Baikai.Auth, + module Baikai.Header, module Baikai.Model, module Baikai.Content, module Baikai.StopReason, @@ -60,6 +61,7 @@ import Baikai.Error import Baikai.Evidence import Baikai.Evidence.Build +import Baikai.Header import Baikai.Interactive import Baikai.Message import Baikai.Model diff --git a/src/Baikai/Agent.hs b/src/Baikai/Agent.hs --- a/src/Baikai/Agent.hs +++ b/src/Baikai/Agent.hs @@ -36,6 +36,9 @@ AgentOutputMode (..), renderAgentOutputMode, parseAgentOutputMode, + AgentOutputFormat (..), + renderAgentOutputFormat, + parseAgentOutputFormat, AgentCapturedOutput (..), capturedBytes, @@ -50,24 +53,35 @@ safety, timeout, output, + outputFormat, outputLimit, - envPassthrough + envRequires ), agentRunRequest, -- * The operator policy ceiling - AgentCeiling (maxCapability, allowProviderArgs, allowedProviders), + AgentCeiling + ( maxCapability, + allowProviderArgs, + allowedProviders, + allowedTools, + maxTimeout, + maxOutputLimit + ), defaultAgentCeiling, + defaultMaxOutputLimit, + toolGrantsImpliedBy, CeilingViolation (..), renderCeilingViolation, applyAgentCeiling, + ceilingViolations, -- * The rendered command AgentPromptTransport (..), AgentCommand (..), -- * The run result - AgentRunResult, + AgentRunResult (provider, exitCode, stdout, stderr, duration), agentRunResult, AgentRunOutcome (..), agentRunOutcome, @@ -76,6 +90,7 @@ AgentRenderError (..), renderAgentRenderError, AgentRunFailure (..), + AgentTimedOut (..), renderAgentRunFailure, ) where @@ -142,10 +157,21 @@ data AgentSafety = AgentSafety { -- | How much filesystem authority the run requests. capability :: !AgentCapability, - -- | Optional narrowing of the provider's tool set. An empty list - -- means \"do not restrict tools beyond what the capability - -- implies\"; a non-empty list is rendered where the provider - -- supports a tool allow-list. + -- | Tools this run is __granted__ — pre-approved — beyond what the + -- capability's permission mode approves on its own. This is a + -- widening, not a narrowing: on Claude Code the list renders as + -- @--allowedTools@, whose help reads \"list of tool names to + -- allow\", so @allowedTools = [\"Bash\"]@ under an + -- @edit-workspace@ capability pre-approves shell access that the + -- permission mode would otherwise have raised a request for, and in + -- an unattended run a request nobody answers is denied. An empty + -- list grants nothing beyond the mode, which is the default. Codex + -- has no equivalent flag and its renderer refuses a non-empty list. + -- + -- Because a grant is authority, an operator ceiling bounds it: see + -- 'toolGrantsImpliedBy' and 'AgentCeiling.allowedTools'. The + -- narrowing flags Claude Code also has, @--tools@ and + -- @--disallowedTools@, are not modelled here. allowedTools :: ![Text], -- | Raw provider arguments Baikai does not model, passed through -- verbatim. This is a privileged channel: arbitrary vendor flags @@ -158,8 +184,8 @@ } deriving stock (Eq, Show, Generic) --- | A safety request for the given capability, with no tool narrowing --- and no raw provider arguments. +-- | A safety request for the given capability, with no tool grants +-- beyond what the capability implies and no raw provider arguments. agentSafety :: AgentCapability -> AgentSafety agentSafety cap = AgentSafety @@ -194,6 +220,38 @@ parseAgentOutputMode "tee" = Just TeeOutput parseAgentOutputMode _ = Nothing +-- | What shape the coding agent should print its final answer in. +-- +-- Distinct from 'AgentOutputMode', which says /where/ the bytes go. This +-- says what they are. +-- +-- * 'TextFormat': whatever the tool prints by default, meant for a +-- person. Both tools default to it and Baikai renders no flag. +-- * 'JsonFormat': one machine-readable result. Claude Code renders +-- @--output-format json@ and @codex exec@ renders @--json@; both are +-- the shapes Baikai's own output readers already parse, so this is +-- the setting that lets an evidence record observe the session +-- identifier, the model and the token usage of a run. +-- +-- Asking for it through the raw-argument channel used to be the only +-- way, which meant an operator had to open a privileged channel to get +-- a record — the opposite of what the ceiling is for. +data AgentOutputFormat + = TextFormat + | JsonFormat + deriving stock (Eq, Ord, Show, Generic) + +renderAgentOutputFormat :: AgentOutputFormat -> Text +renderAgentOutputFormat TextFormat = "text" +renderAgentOutputFormat JsonFormat = "json" + +-- | Parse a canonical output-format name. Matching is exact and +-- case-sensitive. +parseAgentOutputFormat :: Text -> Maybe AgentOutputFormat +parseAgentOutputFormat "text" = Just TextFormat +parseAgentOutputFormat "json" = Just JsonFormat +parseAgentOutputFormat _ = Nothing + -- | One captured stream of a finished run. The three states are -- distinct on purpose: under 'InheritOutput' the bytes went to the -- parent's terminal and none exist to report, which an empty @@ -245,6 +303,8 @@ timeout :: !(Maybe NominalDiffTime), -- | What to do with the child's output streams. output :: !AgentOutputMode, + -- | What shape the tool should print its final answer in. + outputFormat :: !AgentOutputFormat, -- | Maximum captured bytes per stream, not in total. 'Nothing' -- means unbounded. outputLimit :: !(Maybe Int), @@ -258,7 +318,7 @@ -- fails before spawning when a declared variable is unset or -- empty, so a misconfigured job produces one clear error instead -- of a coding agent that starts and then flails. - envPassthrough :: ![Text] + envRequires :: ![Text] } deriving stock (Eq, Show, Generic) @@ -266,8 +326,8 @@ -- working directory, with the given prompt. Everything else defaults -- to the least-authority, least-surprising value: no model or effort -- override, no extra directories, read-only capability, no timeout, --- inherited output, no output limit, and no declared environment --- variables. +-- inherited output in the tool's own text format, no output limit, and +-- no declared environment variables. -- -- The capability default is 'AgentReadOnly': a caller who wants to -- change files must say so. That is independent of an operator @@ -284,8 +344,9 @@ safety = agentSafety AgentReadOnly, timeout = Nothing, output = InheritOutput, + outputFormat = TextFormat, outputLimit = Nothing, - envPassthrough = [] + envRequires = [] } -- | The limit an operator places on what any job may request. @@ -304,7 +365,21 @@ allowProviderArgs :: !Bool, -- | The providers jobs may select. An empty list permits __no__ -- provider; it does not mean \"all providers\". - allowedProviders :: ![AgentProvider] + allowedProviders :: ![AgentProvider], + -- | Tool grants the operator permits beyond the ones + -- 'toolGrantsImpliedBy' the maximum capability already allows. + -- Matching is exact on the whole string, so granting @\"Bash\"@ + -- does not permit @\"Bash(git *)\"@ and vice versa: a job asks for + -- exactly the spelling the operator wrote, or it is refused. + allowedTools :: ![Text], + -- | The longest wall-clock limit any job may request. 'Nothing' + -- permits an unlimited run, which is the default. A finite maximum + -- also refuses a job that requests __no__ timeout at all, because a + -- maximum defeated by omitting the setting is not a maximum. + maxTimeout :: !(Maybe NominalDiffTime), + -- | The largest per-stream output capture any job may request. + -- 'Nothing' permits @output-limit \"unlimited\"@. + maxOutputLimit :: !(Maybe Int) } deriving stock (Eq, Show, Generic) @@ -323,9 +398,53 @@ AgentCeiling { maxCapability = AgentEditWorkspace, allowProviderArgs = False, - allowedProviders = [AgentClaude, AgentCodex] + allowedProviders = [AgentClaude, AgentCodex], + allowedTools = [], + maxTimeout = Nothing, + maxOutputLimit = Just defaultMaxOutputLimit } +-- | The largest per-stream output capture the default ceiling permits: +-- sixty-four mebibytes, sixteen times the per-stream default a job gets +-- when it mentions no limit at all. +-- +-- Concrete rather than unbounded because the memory belongs to the host +-- the operator owns, not to the repository that wrote the job: a +-- checkout writing @output-limit \"unlimited\"@ is asking to buffer an +-- entire runaway agent in the operator's address space, and it should +-- have to ask the operator rather than help itself. Sixty-four +-- mebibytes is far more than any real run prints, so a job that hits +-- it has gone wrong. +defaultMaxOutputLimit :: Int +defaultMaxOutputLimit = 67108864 + +-- | The tool grants a capability implies on its own, or 'Nothing' when +-- the capability implies every grant. +-- +-- The names are Claude Code's built-in tools at version 2.1.247. The +-- lists are deliberately short and fail closed: a tool name that is not +-- listed here can only ever be refused unless the maximum capability is +-- 'AgentFullAccess' or the operator names it in +-- 'AgentCeiling.allowedTools', so a coding agent that grows a new tool +-- can never widen an existing ceiling by accident. +-- +-- @Bash@ is absent from every finite list on purpose. It runs arbitrary +-- commands, which is what 'AgentFullAccess' means; a job that wants it +-- under a lesser capability needs the operator to say so. +toolGrantsImpliedBy :: AgentCapability -> Maybe [Text] +toolGrantsImpliedBy AgentReadOnly = Just readTools +toolGrantsImpliedBy AgentEditWorkspace = Just (readTools <> editTools) +toolGrantsImpliedBy AgentFullAccess = Nothing + +-- | Grants that read but change nothing. +readTools :: [Text] +readTools = ["Read", "Glob", "Grep", "NotebookRead", "TodoWrite"] + +-- | Grants that change files, which 'AgentEditWorkspace' adds to +-- 'readTools'. +editTools :: [Text] +editTools = ["Edit", "MultiEdit", "Write", "NotebookEdit"] + -- | One way a request exceeded a ceiling. data CeilingViolation = -- | The requested capability, then the permitted maximum. The @@ -346,6 +465,31 @@ ProviderArgsForbidden ![Text] | -- | The requested provider, then the permitted providers. ProviderForbidden !AgentProvider ![AgentProvider] + | -- | The requested tool grants that are not permitted, then the + -- maximum capability in force. A grant is authority, so the + -- capability is named: it is what decides which grants are implied + -- without the operator writing anything. + ToolGrantForbidden ![Text] !AgentCapability + | -- | The requested wall-clock limit ('Nothing' is \"no limit\"), + -- then the permitted maximum. + TimeoutExceeded !(Maybe NominalDiffTime) !NominalDiffTime + | -- | The requested per-stream capture ('Nothing' is @unlimited@), + -- then the permitted maximum in bytes. + OutputLimitExceeded !(Maybe Int) !Int + | -- | The leaf name of a setting only operator scope may supply, for + -- example @executable@, that a repository file supplied. + -- + -- Unlike every other violation this one is about /where/ a value + -- came from rather than what it was, so 'applyAgentCeiling' cannot + -- produce it: that function sees a request, not the provenance of + -- each field. It is produced by the configuration layer, which + -- reads provenance from the resolution report, and is carried in + -- the same list so an operator sees one refusal. + RepositoryScopeForbidden !Text + | -- | The working directory a repository file asked for, after + -- resolving symbolic links, then the repository root it must lie + -- inside. + WorkingDirOutsideRepository !FilePath !FilePath deriving stock (Eq, Show, Generic) -- | One line of plain English naming what was asked for and what is @@ -368,7 +512,56 @@ where renderPermittedProviders [] = "none" renderPermittedProviders ps = Text.intercalate ", " (map renderAgentProvider ps) +renderCeilingViolation (ToolGrantForbidden grants permitted) = + "tool grants " + <> Text.intercalate ", " grants + <> " are not permitted under the maximum capability " + <> renderAgentCapability permitted + <> "; add them to policy.allowed-tools in the operator file or raise \ + \policy.max-capability" +renderCeilingViolation (TimeoutExceeded Nothing permitted) = + "the job sets no timeout, and the permitted maximum is " + <> renderCeilingDuration permitted +renderCeilingViolation (TimeoutExceeded (Just requested) permitted) = + "the requested timeout " + <> renderCeilingDuration requested + <> " exceeds the permitted maximum " + <> renderCeilingDuration permitted +renderCeilingViolation (OutputLimitExceeded Nothing permitted) = + "output-limit unlimited exceeds the permitted maximum " + <> Text.pack (show permitted) + <> " bytes" +renderCeilingViolation (OutputLimitExceeded (Just requested) permitted) = + "the requested output-limit " + <> Text.pack (show requested) + <> " exceeds the permitted maximum " + <> Text.pack (show permitted) + <> " bytes" +renderCeilingViolation (RepositoryScopeForbidden name) = + "the repository configuration set " + <> name + <> ", which only the operator file or the command line may set" +renderCeilingViolation (WorkingDirOutsideRepository resolved root) = + "the working directory " + <> Text.pack resolved + <> " lies outside the repository " + <> Text.pack root +-- | A duration in one of the spellings the configuration layer's +-- @timeout@ parser accepts, so a refusal names a value an operator can +-- paste straight back into @policy.max-timeout@. @show@ on a +-- 'NominalDiffTime' prints @7200s@, which that parser does accept but +-- which no operator writes. +renderCeilingDuration :: NominalDiffTime -> Text +renderCeilingDuration value + | seconds > 0, seconds `mod` 3600 == 0 = spell (seconds `div` 3600) "h" + | seconds > 0, seconds `mod` 60 == 0 = spell (seconds `div` 60) "m" + | otherwise = spell seconds "s" + where + seconds :: Integer + seconds = truncate value + spell magnitude unit = Text.pack (show magnitude) <> unit + -- | Check a request against a ceiling. Returns the request -- __unchanged__ when it is within the ceiling, and every violation -- when it is not. @@ -384,28 +577,68 @@ -- This function does not inspect the contents of the requested -- 'providerArgs'. See that field's documentation for why a denylist of -- dangerous flags would be false confidence rather than a boundary. +-- +-- Two violations this function never produces are +-- 'RepositoryScopeForbidden' and 'WorkingDirOutsideRepository'. Both +-- depend on which configuration file supplied a value, and a request +-- carries no provenance; the configuration layer produces them and +-- concatenates them with this function's list, so a caller sees one +-- refusal naming everything at once. applyAgentCeiling :: AgentCeiling -> AgentRunRequest -> Either [CeilingViolation] AgentRunRequest applyAgentCeiling limit request | null violations = Right request | otherwise = Left violations where + violations = ceilingViolations limit request + +-- | Every way a request exceeds a ceiling, as a list a caller can +-- concatenate with the provenance-dependent violations the +-- configuration layer produces. 'applyAgentCeiling' is this function +-- plus the decision to return the request unchanged when the list is +-- empty. +ceilingViolations :: AgentCeiling -> AgentRunRequest -> [CeilingViolation] +ceilingViolations limit request = + concat + [ [ ProviderForbidden requestedProvider permittedProviders + | requestedProvider `notElem` permittedProviders + ], + [ CapabilityExceeded requestedCapability permittedCapability + | requestedCapability > permittedCapability + ], + [ ProviderArgsForbidden requestedArgs + | not (null requestedArgs), + not (limit ^. #allowProviderArgs) + ], + [ ToolGrantForbidden forbiddenGrants permittedCapability + | not (null forbiddenGrants) + ], + [ TimeoutExceeded requestedTimeout permittedTimeout + | Just permittedTimeout <- [limit ^. #maxTimeout], + maybe True (> permittedTimeout) requestedTimeout + ], + [ OutputLimitExceeded requestedOutputLimit permittedLimit + | Just permittedLimit <- [limit ^. #maxOutputLimit], + maybe True (> permittedLimit) requestedOutputLimit + ] + ] + where requestedProvider = request ^. #provider permittedProviders = limit ^. #allowedProviders requestedCapability = request ^. #safety . #capability permittedCapability = limit ^. #maxCapability requestedArgs = request ^. #safety . #providerArgs - violations = - concat - [ [ ProviderForbidden requestedProvider permittedProviders - | requestedProvider `notElem` permittedProviders - ], - [ CapabilityExceeded requestedCapability permittedCapability - | requestedCapability > permittedCapability - ], - [ ProviderArgsForbidden requestedArgs - | not (null requestedArgs), - not (limit ^. #allowProviderArgs) - ] + requestedTimeout = request ^. #timeout + requestedOutputLimit = request ^. #outputLimit + -- A capability implying every grant permits the whole list; any + -- other capability permits its implied names plus whatever the + -- operator granted, matched exactly. + forbiddenGrants = case toolGrantsImpliedBy permittedCapability of + Nothing -> [] + Just implied -> + [ grant + | grant <- request ^. #safety . #allowedTools, + grant `notElem` implied, + grant `notElem` (limit ^. #allowedTools) ] -- | How the prompt reaches the child process. @@ -458,6 +691,8 @@ -- A non-zero exit code is a normal result and lives here rather than -- in a failure type: a coding agent that fails its task and exits 1 -- has still run. +-- Construction: the constructor is deliberately not exported. Start +-- from 'agentRunResult' and override fields by record update. data AgentRunResult = AgentRunResult { -- | Which coding-agent tool ran. provider :: !AgentProvider, @@ -563,6 +798,28 @@ "the request exceeds the permitted policy ceiling: " <> Text.intercalate "; " (map renderCeilingViolation violations) +-- | What a run that hit its deadline left behind. +-- +-- The limit is the one that was configured, not the slightly larger +-- elapsed time, because the caller asked for a limit and wants to be +-- told which one was hit. +-- +-- The two streams are whatever was drained before the process group was +-- killed. A timed-out run is precisely the run an operator most wants to +-- read: the tool started, may have consumed tokens, and may already have +-- changed the working tree, and the bytes it printed on the way are the +-- only account of that. Under 'InheritOutput' those bytes went to the +-- parent's terminal and both fields are 'OutputNotCaptured'. +data AgentTimedOut = AgentTimedOut + { -- | The configured limit the run exceeded. + limit :: !NominalDiffTime, + -- | Standard output drained before the group was killed. + stdout :: !AgentCapturedOutput, + -- | Standard error drained before the group was killed. + stderr :: !AgentCapturedOutput + } + deriving stock (Eq, Show, Generic) + -- | A failure raised while spawning the child process or waiting for -- it. -- @@ -575,16 +832,16 @@ -- not installed\" from \"the tool is installed but the working -- directory does not exist\". SpawnFailed !FilePath !Text - | -- | The run exceeded this limit and was terminated. - RunTimedOut !NominalDiffTime - | -- | Every variable named in the request's 'envPassthrough' that is + | -- | The run exceeded its limit. Its whole process group was + -- interrupted, then terminated, then killed; what each stream + -- drained before the kill is carried along. + RunTimedOut !AgentTimedOut + | -- | Every variable named in the request's 'envRequires' that is -- unset or empty, checked as a group so an operator sees all of -- them at once. MissingEnvironment ![Text] | -- | The working directory does not exist or is not a directory. WorkingDirMissing !FilePath - | -- | The run produced output the caller could not interpret. - OutputMalformed !Text | -- | The caller required evidence this configuration cannot produce, -- so nothing was started. Carries one rendered explanation per -- reason, from @@ -601,16 +858,14 @@ renderAgentRunFailure :: AgentRunFailure -> Text renderAgentRunFailure (SpawnFailed path message) = "could not start " <> Text.pack path <> ": " <> message -renderAgentRunFailure (RunTimedOut limit) = - "the run exceeded its timeout of " <> Text.pack (show limit) +renderAgentRunFailure (RunTimedOut timedOut) = + "the run exceeded its timeout of " <> Text.pack (show (timedOut ^. #limit)) renderAgentRunFailure (MissingEnvironment names) = "required environment variables are unset or empty: " <> Text.intercalate ", " names renderAgentRunFailure (WorkingDirMissing path) = "the working directory does not exist or is not a directory: " <> Text.pack path -renderAgentRunFailure (OutputMalformed why) = - "the run produced malformed output: " <> why renderAgentRunFailure (EvidenceRefused reasons) = "refused before starting, because this run cannot produce the evidence it \ \required: " diff --git a/src/Baikai/AgentAssets.hs b/src/Baikai/AgentAssets.hs --- a/src/Baikai/AgentAssets.hs +++ b/src/Baikai/AgentAssets.hs @@ -26,6 +26,7 @@ ) import Baikai.Prelude import Data.Text qualified as Text +import Text.Printf (printf) -- | Asset helpers use the same provider vocabulary as interactive -- launchers: Claude Code and Codex are the local provider families. @@ -129,17 +130,56 @@ where appendSegment acc segment = acc <> "/" <> segment +-- | A TOML /basic/ string: quotation mark, backslash, and every control +-- character escaped, as TOML 1.0 requires. A basic string interprets +-- backslash escapes, so an unescaped control character in one is a +-- parse error rather than a stray byte. tomlString :: Text -> Text -tomlString t = - "\"" <> Text.concatMap escape t <> "\"" - where - escape '"' = "\\\"" - escape '\\' = "\\\\" - escape '\n' = "\\n" - escape '\r' = "\\r" - escape '\t' = "\\t" - escape c = Text.singleton c +tomlString t = "\"" <> Text.concatMap escapeBasic t <> "\"" +-- | One character inside a TOML basic string. +-- +-- The six named escapes are the ones TOML spells; everything else below +-- U+0020, and U+007F, takes the @\\uXXXX@ form. Nothing above that is +-- escaped: TOML basic strings are Unicode, and escaping more would only +-- make the file harder to read. +escapeBasic :: Char -> Text +escapeBasic = \case + '"' -> "\\\"" + '\\' -> "\\\\" + '\b' -> "\\b" + '\t' -> "\\t" + '\n' -> "\\n" + '\f' -> "\\f" + '\r' -> "\\r" + c + | c < ' ' || c == '\DEL' -> Text.pack (printf "\\u%04X" (fromEnum c)) + | otherwise -> Text.singleton c + +-- | The instructions body of a Codex custom agent. +-- +-- Rendered as a TOML /literal/ multi-line string — three apostrophes, +-- interpreting nothing — so the Markdown a human opens in +-- @.codex\/agents\/*.toml@ is the Markdown that was written, backslashes +-- intact. Rendered as a /basic/ string instead, every backslash in the +-- body starts an escape sequence, so a body containing @\\d+@ made Codex +-- refuse to load the file. +-- +-- A literal string cannot contain three apostrophes, a bare carriage +-- return, or any control character other than tab and newline, so such a +-- body falls back to a fully escaped basic string rather than being +-- refused. Escaping every quotation mark there guarantees the closing +-- delimiter cannot appear inside, and escaping every backslash means no +-- line-ending backslash can silently swallow the next line's +-- indentation. tomlMultilineString :: Text -> Text -tomlMultilineString t = - "\"\"\"\n" <> Text.replace "\"\"\"" "\\\"\\\"\\\"" t <> "\n\"\"\"" +tomlMultilineString t + | literalSafe = "\'\'\'\n" <> t <> "\n\'\'\'" + | otherwise = "\"\"\"\n" <> Text.concatMap escapeMultiline t <> "\n\"\"\"" + where + literalSafe = not ("\'\'\'" `Text.isInfixOf` t) && Text.all literalChar t + literalChar c = c == '\t' || c == '\n' || (c >= ' ' && c /= '\DEL') + -- A raw newline is allowed inside a multi-line basic string and + -- keeps the body readable; everything else follows the basic rules. + escapeMultiline '\n' = "\n" + escapeMultiline c = escapeBasic c diff --git a/src/Baikai/Api.hs b/src/Baikai/Api.hs --- a/src/Baikai/Api.hs +++ b/src/Baikai/Api.hs @@ -17,6 +17,7 @@ ( Api (..), renderApi, parseApi, + normaliseApi, ) where @@ -51,6 +52,18 @@ "openai-completions-cli" -> OpenAICompletionsCli "anthropic-messages-cli" -> AnthropicMessagesCli t -> Custom t + +-- | Collapse a 'Custom' tag that spells a built-in API onto that +-- constructor, so @Custom "anthropic-messages"@ and 'AnthropicMessages' +-- are one registry key. Every other value is returned unchanged. +-- +-- The registry normalises both the key it stores and the tag it is asked +-- for, so a handler registered under either spelling answers a model +-- tagged with the other. Derived 'Eq' and 'Ord' are deliberately left +-- alone: changing them would silently rearrange every @Map Api@ a +-- consumer holds. +normaliseApi :: Api -> Api +normaliseApi = parseApi . renderApi instance ToJSON Api where toJSON = toJSON . renderApi diff --git a/src/Baikai/Auth.hs b/src/Baikai/Auth.hs --- a/src/Baikai/Auth.hs +++ b/src/Baikai/Auth.hs @@ -11,21 +11,32 @@ defaultApiKeyEnvForBaseUrl, renderApiKeySourceForDebug, resolveApiKey, + + -- * Redacting credentials that travel in headers + redactedMarker, + isCredentialHeader, + redactHeaderValues, ) where -import Baikai.Compat (hostMatchesSuffix, urlHost) import Baikai.Error (authError) +import Baikai.Header (HeaderName, renderHeaderName) +import Baikai.Url (hostMatchesSuffix, urlHost) import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (ToJSON (toJSON), object, (.=)) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Text qualified as Text import System.Environment qualified as Environment data ApiKeySource = ApiKeyLiteral !Text - | ApiKeyEnv !String + | -- | 'String' rather than 'Text' because + -- 'System.Environment.lookupEnv' takes one; converting here would + -- only move the conversion to every call site. + ApiKeyEnv !String | ApiKeyEnvChain ![String] deriving stock (Eq) @@ -71,35 +82,95 @@ | hostMatchesSuffix host "fireworks.ai" = Just "FIREWORKS_API_KEY" | otherwise = Nothing +-- | What baikai prints where a credential would otherwise appear. +-- +-- One marker everywhere, so a reader who has seen it once in an +-- @ApiKeyLiteral@ recognises it in a header map. +redactedMarker :: Text +redactedMarker = "" + +-- | Whether a header name carries a credential, by convention. +-- +-- Case-insensitive, and deliberately generous: it matches +-- @authorization@, @api-key@, @apikey@, @token@, @secret@, @cookie@ and +-- @password@ anywhere in the name, and any name ending in @-key@. That +-- over-matches — a header called @x-idempotency-key@ prints as the +-- marker — and over-matching is the safe direction, because this only +-- decides what is /printed/. The header itself is untouched and is still +-- sent exactly as the caller wrote it. +isCredentialHeader :: Text -> Bool +isCredentialHeader name = + any (`Text.isInfixOf` lowered) needles || "-key" `Text.isSuffixOf` lowered + where + lowered = Text.toLower (Text.strip name) + needles = + [ "authorization", + "api-key", + "apikey", + "token", + "secret", + "cookie", + "password" + ] + +-- | Replace the value of every credential-carrying header with +-- 'redactedMarker', leaving the names and every other value alone. +redactHeaderValues :: Map HeaderName Text -> Map HeaderName Text +redactHeaderValues = + Map.mapWithKey + ( \name value -> + if isCredentialHeader (renderHeaderName name) then redactedMarker else value + ) + -- | Render a credential source for logs, test failures, and debugging without -- exposing literal secret material. renderApiKeySourceForDebug :: ApiKeySource -> Text -renderApiKeySourceForDebug (ApiKeyLiteral _) = "ApiKeyLiteral " +renderApiKeySourceForDebug (ApiKeyLiteral _) = "ApiKeyLiteral " <> redactedMarker renderApiKeySourceForDebug (ApiKeyEnv name) = "ApiKeyEnv " <> Text.pack (show name) renderApiKeySourceForDebug (ApiKeyEnvChain names) = "ApiKeyEnvChain " <> Text.pack (show names) -- | Resolve a key source to a plain 'Text'. Throws a 'BaikaiError' in the --- 'Baikai.Error.AuthError' category if 'ApiKeyEnv' is used and the named variable --- is unset. +-- 'Baikai.Error.AuthError' category when no variable yields a key. +-- +-- A variable whose value is empty, or is only whitespace, counts as +-- __unset__. An empty key can never authenticate, so reporting it here +-- as an error that names the variable is strictly better than sending +-- @Authorization: Bearer @ and reading a provider's 401 back. A +-- non-empty value is passed through exactly as it was set, whitespace +-- and all: trimming a real key would be a different behaviour change, +-- and one that could silently break a key with a meaningful edge +-- character. resolveApiKey :: (MonadIO m) => ApiKeySource -> m Text resolveApiKey (ApiKeyLiteral t) = pure t resolveApiKey (ApiKeyEnv name) = liftIO $ - Environment.lookupEnv name >>= \case - Just v -> pure (Text.pack v) - Nothing -> throwIO (authError ("env var " <> Text.pack name <> " is not set")) + lookupNonEmptyEnv name >>= \case + Just v -> pure v + Nothing -> + throwIO + (authError ("env var " <> Text.pack name <> " is not set or is empty")) resolveApiKey (ApiKeyEnvChain names) = liftIO (go names) where go [] = throwIO - (authError ("none of the env vars " <> renderedNames <> " are set")) - go (name : rest) = - Environment.lookupEnv name >>= \case - Just v -> pure (Text.pack v) - Nothing -> go rest + ( authError + ( "none of the env vars " + <> renderedNames + <> " are set (an empty value counts as unset)" + ) + ) + go (name : rest) = lookupNonEmptyEnv name >>= maybe (go rest) pure renderedNames = case names of [] -> "" _ -> Text.intercalate ", " (Text.pack <$> names) + +-- | 'Environment.lookupEnv' that treats a blank value as absent. +lookupNonEmptyEnv :: String -> IO (Maybe Text) +lookupNonEmptyEnv name = do + found <- Environment.lookupEnv name + pure $ case found of + Just raw | not (Text.null (Text.strip (Text.pack raw))) -> Just (Text.pack raw) + _ -> Nothing diff --git a/src/Baikai/CacheRetention.hs b/src/Baikai/CacheRetention.hs --- a/src/Baikai/CacheRetention.hs +++ b/src/Baikai/CacheRetention.hs @@ -1,10 +1,12 @@ -- | Provider-agnostic prompt-cache retention preference. -- --- Each provider maps the value to its own primitive: Anthropic's --- 'long' becomes @cache_control.ttl: "1h"@, 'short' becomes the --- ephemeral marker with no TTL; OpenAI Responses API's 'long' would --- become 24h. Hosts that do not advertise prompt caching ignore the --- preference. +-- Each provider maps the value to its own primitive: on Anthropic, +-- 'CacheRetentionLong' becomes @cache_control.ttl: "1h"@ and +-- 'CacheRetentionShort' the ephemeral marker with no TTL. The +-- OpenAI-compatible provider emits Anthropic-style markers only where +-- the host's compat record sets +-- 'Baikai.Compat.cacheControlFormat'; hosts that do not advertise +-- prompt caching under a marker ignore the preference. module Baikai.CacheRetention ( CacheRetention (..), ) @@ -19,9 +21,9 @@ CacheRetentionNone | -- | Provider-default ephemeral retention (Anthropic: 5 minutes). CacheRetentionShort - | -- | Long-retention bucket (Anthropic: @ttl: "1h"@; OpenAI - -- Responses: 24h). Downgrades to short on hosts that report - -- 'supportsLongCacheRetention' as 'False'. + | -- | Long-retention bucket (Anthropic: @ttl: "1h"@). Downgrades to + -- short on hosts that report 'supportsLongCacheRetention' as + -- 'False'. CacheRetentionLong deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) diff --git a/src/Baikai/Compat.hs b/src/Baikai/Compat.hs --- a/src/Baikai/Compat.hs +++ b/src/Baikai/Compat.hs @@ -21,7 +21,10 @@ -- -- Auto-detection from a 'Baikai.Model.Model' @baseUrl@ provides -- reasonable defaults so callers rarely need to spell out a full --- compat record. +-- compat record. The host it detects on comes from "Baikai.Url", the +-- only place in baikai that turns a URL into a host name; 'urlHost' and +-- 'hostMatchesSuffix' are re-exported from here so a caller reasoning +-- about auto-detection has them to hand. module Baikai.Compat ( -- * OpenAI Chat Completions compat OpenAICompletionsCompat @@ -43,11 +46,11 @@ ( supportsLongCacheRetention, supportsCacheControlOnTools, sendSessionAffinityHeaders, - thinkingStyle + thinkingStyle, + supportsSamplingParameters ), AnthropicThinkingStyle (..), defaultAnthropicMessagesCompat, - defaultAnthropicThinkingStyle, -- * Auto-detection from baseUrl urlHost, @@ -57,9 +60,9 @@ ) where +import Baikai.Url (hostMatchesSuffix, urlHost) import Data.Aeson (FromJSON, ToJSON) import Data.Text (Text) -import Data.Text qualified as Text import GHC.Generics (Generic) -- | Where the OpenAI-compatible host expects the max-output-tokens @@ -79,12 +82,15 @@ = -- | OpenAI-native: top-level @reasoning_effort: "minimal" | "low" -- | "medium" | "high" | "xhigh" | "max"@. -- - -- This shape sends the canonical baikai level verbatim. The other - -- six route through @Baikai.Provider.OpenAI.Shape.compatibleEffort@, - -- which clamps @minimal@ to @low@ and both @xhigh@ and @max@ to - -- @high@ — a lowest-common-denominator vocabulary for hosts that - -- do not accept the full one. The exclusion is deliberate and - -- guarded by @nativeHigherEffortTests@ in + -- This shape sends the canonical baikai level verbatim. Three of + -- the other six — OpenRouter, DeepSeek and Together — route + -- through @Baikai.Provider.OpenAI.Shape.compatibleEffort@, which + -- clamps @minimal@ to @low@ and both @xhigh@ and @max@ to @high@ — + -- a lowest-common-denominator vocabulary for hosts that do not + -- accept the full one. Z.ai and Qwen send a bare toggle with no + -- depth, and 'ThinkingFormatNone' drops the control. Excluding + -- this shape from the clamp is deliberate and is guarded by + -- @nativeHigherEffortTests@ in -- @baikai-openai/test/ShapeSpec.hs@: clamping here would silently -- weaken every high-effort request against a current OpenAI model. ThinkingFormatOpenAI @@ -138,7 +144,7 @@ maxTokensField :: !MaxTokensField, -- | Whether the host accepts @strict: true@ on function tool -- definitions. Consumed by - -- @Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat@ and + -- @Baikai.Provider.OpenAI.Internal.Request.mkOpenAIResponseFormat@ and -- @Baikai.Provider.OpenAI.Shape.dropUnsupportedStrict@ to -- omit JSON-schema @strict@ on hosts that reject it. supportsStrictMode :: !Bool, @@ -147,12 +153,12 @@ -- @\...\@ markers. Field-based reasoning -- extraction (for @reasoning_content@ / @reasoning@ deltas) is -- unconditional; this flag enables the incremental tag scanner - -- in @Baikai.Provider.OpenAI.Api.translateTextLikeDelta@ for + -- in @Baikai.Provider.OpenAI.Internal.Stream.scanThinkTags@ for -- hosts that do not split reasoning into a separate field. requiresThinkingAsText :: !Bool, -- | The wire shape the host accepts for reasoning-effort -- preferences. Consumed by - -- @Baikai.Provider.OpenAI.Api.applyThinkingFormat@ for the + -- @Baikai.Provider.OpenAI.Internal.Request.applyThinkingFormat@ for the -- OpenAI-native field and by -- @Baikai.Provider.OpenAI.Shape.injectThinkingShape@ for -- OpenAI-compatible host-specific JSON keys. @@ -194,7 +200,7 @@ { -- | Whether the host honours Anthropic's -- @cache_control.ttl: "1h"@ long-retention marker. When 'False', -- long-retention preferences silently downgrade to ephemeral. - -- Consumed by @Baikai.Provider.Claude.Api.computeCacheControl@ + -- Consumed by @Baikai.Provider.Claude.Internal.Request.computeCacheControl@ -- for top-level cache markers and by -- @Baikai.Provider.Claude.Shape.injectToolCacheControl@ for -- tool cache markers. @@ -209,9 +215,21 @@ -- @Baikai.Provider.Claude.Transport.requestHeaders@. sendSessionAffinityHeaders :: !Bool, -- | Which extended-thinking request shape to send for the - -- selected model generation. Consumed by - -- @Baikai.Provider.Claude.Api.computeThinking@. - thinkingStyle :: !AnthropicThinkingStyle + -- selected model generation. Which shape a generation accepts + -- is a fact of the generated catalog record + -- ("Baikai.Models.Generated"), not something to be guessed from + -- the model id. Consumed by + -- @Baikai.Provider.Claude.Internal.Request.computeThinking@. + thinkingStyle :: !AnthropicThinkingStyle, + -- | Whether the model generation accepts the sampling parameters + -- @temperature@, @top_p@ and @top_k@. Adaptive-era generations + -- from Opus 4.7 and Sonnet 5 onward reject them with a 400, so + -- the Anthropic adapter drops them and records + -- 'Baikai.Evidence.SamplingDroppedUnsupportedModel'. Which + -- generations accept them is a fact of the generated catalog + -- record, not of this type. Consumed by + -- @Baikai.Provider.Claude.Internal.Request.planRequest@. + supportsSamplingParameters :: !Bool } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -223,22 +241,10 @@ { supportsLongCacheRetention = True, supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, - thinkingStyle = AnthropicThinkingBudget + thinkingStyle = AnthropicThinkingBudget, + supportsSamplingParameters = True } --- | The thinking style a first-party Anthropic model id defaults to --- when the model carries no explicit compat record. Unknown ids --- default to the budget style used by earlier model generations. -defaultAnthropicThinkingStyle :: Text -> AnthropicThinkingStyle -defaultAnthropicThinkingStyle modelId - | adaptive "claude-opus-4-6" = AnthropicThinkingAdaptive - | adaptive "claude-opus-4-7" = AnthropicThinkingAdaptive - | adaptive "claude-opus-4-8" = AnthropicThinkingAdaptive - | adaptive "claude-fable-5" = AnthropicThinkingAdaptive - | otherwise = AnthropicThinkingBudget - where - adaptive prefix = prefix `Text.isPrefixOf` modelId - -- | Pick a sensible compat record for an unknown OpenAI-compatible -- host based on its @baseUrl@. Falls back to -- 'defaultOpenAICompletionsCompat' for hosts the table does not @@ -298,27 +304,3 @@ where host = urlHost url matches suffix = maybe False (`hostMatchesSuffix` suffix) host - --- | Extract a hostname from a URL-ish value. This is intentionally --- small and total rather than a validating URI parser: it drops an --- optional scheme, optional userinfo, then stops at '/', ':', '?', or --- '#'. Empty results return 'Nothing'. -urlHost :: Text -> Maybe Text -urlHost raw = - let noScheme = case Text.breakOn "://" raw of - (_, rest) | not (Text.null rest) -> Text.drop 3 rest - _ -> raw - noUser = last (Text.splitOn "@" noScheme) - host = Text.toLower (Text.strip (Text.takeWhile hostChar noUser)) - in if Text.null host then Nothing else Just host - where - hostChar c = c /= '/' && c /= ':' && c /= '?' && c /= '#' - --- | Match a hostname against a suffix at a label boundary. -hostMatchesSuffix :: Text -> Text -> Bool -hostMatchesSuffix host suffix = - let h = Text.toLower (Text.strip host) - s = Text.toLower (Text.strip suffix) - in not (Text.null h) - && not (Text.null s) - && (h == s || ("." <> s) `Text.isSuffixOf` h) diff --git a/src/Baikai/Content.hs b/src/Baikai/Content.hs --- a/src/Baikai/Content.hs +++ b/src/Baikai/Content.hs @@ -9,8 +9,7 @@ -- invocation. For tool-result messages (a caller-supplied reply to a -- model-issued tool call) blocks can be text or image. -- --- EP-1 introduces the types; EP-3 streams them, and EP-4 wires tool --- round-tripping through the providers. Image content is restricted to +-- Image content is restricted to -- inline base64 with an explicit @mimeType@: the caller is responsible -- for the (small, reversible) work of base64-encoding bytes once, and -- every provider can consume the same shape without a URL-fetch path @@ -27,15 +26,15 @@ AssistantContent (..), ToolResultContent (..), + -- * Tool-call arguments + toolArgumentsFromText, + isCutOffToolCall, + -- * Smart defaults emptyTextContent, emptyThinkingContent, emptyToolCall, emptyImageContent, - _TextContent, - _ThinkingContent, - _ToolCall, - _ImageContent, ) where @@ -54,6 +53,7 @@ (.:), (.=), ) +import Data.Aeson qualified as Aeson import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Base64 qualified as Base64 @@ -87,6 +87,16 @@ -- | A model-issued tool invocation. @id_@ has a trailing underscore in -- Haskell to dodge a clash with @Prelude.id@; the JSON encoding strips -- it back to @id@. +-- +-- @arguments@ is the decoded JSON value the model sent — normally an +-- object. A bare 'Data.Aeson.String' is the __cut-off marker__: the +-- model's argument stream was truncated (by the output cap, or by a +-- transport failure mid-call) and the raw text is kept verbatim rather +-- than replaced by something well-formed that the model never asked +-- for. 'isCutOffToolCall' is the predicate; 'toolArgumentsFromText' is +-- the one rule that produces it. A cut-off call must not be dispatched: +-- 'Baikai.Provider.Registry.runToolLoop' stops on one and +-- 'Baikai.Context.appendToolResult' reports it as a tool-result error. data ToolCall = ToolCall { id_ :: !Text, name :: !Text, @@ -94,6 +104,32 @@ } deriving stock (Eq, Show, Generic) +-- | Turn a tool call's accumulated argument text into its @arguments@ +-- value. +-- +-- Empty text is an empty object: Anthropic opens a @tool_use@ block with +-- no input and streams no delta, and an empty object is exactly what the +-- model asked for. Non-empty text that does not decode is kept verbatim +-- as a 'Data.Aeson.String' — the call was cut off, and no byte of what +-- the model did send is dropped. +-- +-- Both provider assemblers and core's stream-recovery path use this one +-- rule, so 'isCutOffToolCall' means the same thing at every layer. +-- Before it, the assemblers replaced malformed arguments with @{}@ and a +-- tool loop happily executed the call with no arguments at all. +toolArgumentsFromText :: Text -> Value +toolArgumentsFromText raw + | Text.null (Text.strip raw) = Aeson.Object mempty + | otherwise = case Aeson.eitherDecodeStrict (Text.encodeUtf8 raw) of + Right v -> v + Left _ -> Aeson.String raw + +-- | 'True' when the call's argument stream was cut off: @arguments@ is +-- the raw text rather than a decoded value. See 'ToolCall'. +isCutOffToolCall :: ToolCall -> Bool +isCutOffToolCall ToolCall {arguments = Aeson.String _} = True +isCutOffToolCall _ = False + -- | An inline image block. Bytes are stored decoded; the JSON encoding -- emits base64 under @data@ and the @mimeType@ camel-snakes to -- @mime_type@. @@ -216,19 +252,3 @@ instance ToJSON ToolResultContent where toJSON = genericToJSON contentSumOptions - -{-# DEPRECATED _TextContent "Use emptyTextContent instead." #-} -_TextContent :: TextContent -_TextContent = emptyTextContent - -{-# DEPRECATED _ThinkingContent "Use emptyThinkingContent instead." #-} -_ThinkingContent :: ThinkingContent -_ThinkingContent = emptyThinkingContent - -{-# DEPRECATED _ToolCall "Use emptyToolCall instead." #-} -_ToolCall :: ToolCall -_ToolCall = emptyToolCall - -{-# DEPRECATED _ImageContent "Use emptyImageContent instead." #-} -_ImageContent :: ImageContent -_ImageContent = emptyImageContent diff --git a/src/Baikai/Context.hs b/src/Baikai/Context.hs --- a/src/Baikai/Context.hs +++ b/src/Baikai/Context.hs @@ -2,14 +2,14 @@ -- conversation: the optional system prompt, the message vector, and -- the declared tools the model may invoke. -- --- 'Context' replaces the prior 'Baikai.Request.Request' record's --- conversation-related fields. The per-call knobs that previously --- lived alongside the messages (max tokens, temperature, API key) --- now live on 'Baikai.Options.Options' instead. +-- The per-call knobs — max tokens, temperature, API key — live on +-- 'Baikai.Options.Options' instead, so a conversation and the settings +-- it is dispatched with are separate values. -- --- EP-4 adds the @tools@ field and the 'appendToolResult' helper --- that builds the follow-up request after the model invoked one or --- more tools. The helper lives here rather than in 'Baikai.Tool' so +-- The @tools@ field is on the context because the same tool set applies +-- to every turn, and so is 'appendToolResult', which builds the +-- follow-up request after the model invoked one or more tools. The +-- helper lives here rather than in 'Baikai.Tool' so -- that 'Baikai.Tool' can stay imports-light (the 'Tool' type is -- referenced by the @tools@ field, so 'Baikai.Tool' cannot itself -- depend on 'Context'). @@ -19,7 +19,6 @@ messages, tools, emptyContext, - _Context, contextOf, systemUser, addUser, @@ -30,9 +29,9 @@ ) where -import Baikai.Content (AssistantContent (..), ToolCall (..)) -import Baikai.Message (Message (..), ToolResult, toolResultFromCallNow, toolResultText, user) -import Baikai.Response (Response (..), responseMessage) +import Baikai.Content (AssistantContent (..), ToolCall (..), isCutOffToolCall) +import Baikai.Message (Message (..), ToolResult, toolResultErrorText, toolResultFromCallNow, toolResultText, user) +import Baikai.Response (Response (..), responseError, responseMessage) import Baikai.Tool (Tool) import Control.Applicative ((<|>)) import Control.Lens ((&), (.~), (^.)) @@ -102,15 +101,36 @@ -- returned 'Context' is ready to drive the follow-up request that -- gives the model the tool results. -- --- The dispatcher receives one 'ToolCall' at a time and returns a rich --- 'ToolResult' carrying text blocks, image blocks, and an error flag. --- Any error handling (timeouts, sandboxing, multi-call concurrency) --- lives in the dispatcher. +-- Calls are dispatched one at a time, in the order they appear, and the +-- dispatcher returns a rich 'ToolResult' carrying text blocks, image +-- blocks, and an error flag. Any timeout or sandboxing lives in the +-- dispatcher. +-- +-- An __error-shaped response__ (one whose 'Baikai.Response.responseError' +-- is 'Just') appends nothing and dispatches nothing: the context comes +-- back unchanged. A failed call has no assistant turn worth replaying +-- and no tool calls to answer, and appending its empty message would put +-- a turn into the transcript that the model never took. +-- 'Baikai.Provider.Registry.runToolLoop' has always stopped on such a +-- response; the documented direct round trip in @docs\/user\/tools.md@ +-- reaches here instead, and now behaves the same way. +-- +-- A tool call cut off by the output cap +-- ('Baikai.Content.isCutOffToolCall') is __never dispatched__: its +-- arguments are the raw text the model got as far as sending, not a +-- request it finished making. It still gets a +-- 'Baikai.Message.ToolResultMessage', with @isError = True@ explaining +-- why, because a caller driving the exchange by hand expects one result +-- per call and must not silently lose the turn. +-- 'Baikai.Provider.Registry.runToolLoop' stops on such a response +-- instead of reaching here. appendToolResult :: Context -> Response -> (ToolCall -> IO ToolResult) -> IO Context +appendToolResult ctx resp _dispatcher + | Just _ <- responseError resp = pure ctx appendToolResult ctx resp dispatcher = do let respPayload = resp ^. #message respMsg = responseMessage resp @@ -118,7 +138,10 @@ results <- traverse ( \tc -> do - result <- dispatcher tc + result <- + if isCutOffToolCall tc + then pure cutOffToolResult + else dispatcher tc toolResultFromCallNow tc result ) toolCalls @@ -130,6 +153,13 @@ <> V.fromList results ) +-- | What 'appendToolResult' reports instead of dispatching a call the +-- model never finished asking for. +cutOffToolResult :: ToolResult +cutOffToolResult = + toolResultErrorText + "tool call arguments were cut off by the output limit; the call was not dispatched — raise maxTokens and retry" + -- | Text-only convenience wrapper for the common case where every -- tool call returns one successful text block. appendToolResultText :: @@ -139,7 +169,3 @@ IO Context appendToolResultText ctx resp dispatcher = appendToolResult ctx resp (fmap toolResultText . dispatcher) - -{-# DEPRECATED _Context "Use emptyContext instead." #-} -_Context :: Context -_Context = emptyContext diff --git a/src/Baikai/Cost.hs b/src/Baikai/Cost.hs --- a/src/Baikai/Cost.hs +++ b/src/Baikai/Cost.hs @@ -3,8 +3,6 @@ CostBreakdown (..), zeroCost, zeroCostBreakdown, - _Cost, - _CostBreakdown, usdAsScientific, ) where @@ -82,11 +80,3 @@ ratToSci :: Rational -> Scientific ratToSci = fst . fromRationalRepetendUnlimited - -{-# DEPRECATED _CostBreakdown "Use zeroCostBreakdown instead." #-} -_CostBreakdown :: CostBreakdown -_CostBreakdown = zeroCostBreakdown - -{-# DEPRECATED _Cost "Use zeroCost instead." #-} -_Cost :: Cost -_Cost = zeroCost diff --git a/src/Baikai/Cost/Log.hs b/src/Baikai/Cost/Log.hs --- a/src/Baikai/Cost/Log.hs +++ b/src/Baikai/Cost/Log.hs @@ -8,15 +8,26 @@ -- The usual pattern is 'withCallLog', which opens a handle, runs -- the body, and flushes pending entries on the way out: -- --- > withCallLog (CallLogConfig "/tmp/baikai.jsonl" True) $ \h -> do +-- > withCallLog (callLogConfig "/tmp/baikai.jsonl") $ \h -> do -- > _ <- runRequestWithLog h model context options -- > pure () -- -- If the worker cannot open or write the log file, the close path -- reports one warning on stderr and returns. Logging failures do not -- mask the request body or hang release actions. +-- +-- 'closeCallLog' is idempotent: the first caller claims the handle, +-- writes the sentinel and waits for the worker; a second caller returns +-- at once rather than blocking forever on a worker that has already +-- finished. An 'appendEntry' after the close is a no-op, because the +-- worker that would have drained it is gone. The close wait itself is +-- unbounded, unlike the trace bridge's: the call log's purpose is +-- durability, its close runs once per process rather than once per +-- call, and its writer is a local file the operator chose rather than a +-- third-party fold. module Baikai.Cost.Log - ( CallLogConfig (..), + ( CallLogConfig (path, enabled), + callLogConfig, CallLogEntry (..), CallLogHandle, openCallLog, @@ -48,10 +59,10 @@ import Baikai.Usage qualified as Usage import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) import Control.Exception (SomeException, bracket, displayException, try) import Control.Lens ((^.)) -import Control.Monad (forM_) +import Control.Monad (forM_, unless) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON, ToJSON) @@ -60,7 +71,7 @@ import Data.Foldable (find) import Data.Function ((&)) import Data.Generics.Labels () -import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Text qualified as Text @@ -73,15 +84,21 @@ import System.IO (BufferMode (LineBuffering), IOMode (AppendMode), hPutStrLn, hSetBuffering, stderr, withFile) -- | Where (and whether) to write the call log. +-- +-- Construction: the constructor is deliberately not exported. Start +-- from 'callLogConfig' and override fields by record update. data CallLogConfig = CallLogConfig { path :: !FilePath, enabled :: !Bool } deriving stock (Eq, Show, Generic) --- | One line of the JSONL call log. Wire shape preserved from EP-0: --- @cachedInputTokens@ keeps its name so existing log readers keep --- parsing. +-- | A call log at the given path, enabled. +callLogConfig :: FilePath -> CallLogConfig +callLogConfig logPath = CallLogConfig {path = logPath, enabled = True} + +-- | One line of the JSONL call log. @cachedInputTokens@ keeps the name +-- it has always had on the wire, so existing log readers keep parsing. data CallLogEntry = CallLogEntry { timestamp :: !UTCTime, provider :: !Text, @@ -102,7 +119,10 @@ { chan :: !(Chan (Maybe CallLogEntry)), done :: !(MVar ()), cfg :: !CallLogConfig, - workerError :: !(IORef (Maybe SomeException)) + workerError :: !(IORef (Maybe SomeException)), + -- | Claimed by the first 'closeCallLog'. A second close returns + -- immediately and an 'appendEntry' after it enqueues nothing. + closed :: !(IORef Bool) } -- | Open a handle. When @enabled = True@, fork the worker thread @@ -112,26 +132,36 @@ ch <- newChan d <- newEmptyMVar e <- newIORef Nothing + cl <- newIORef False case enabled c of False -> putMVar d () True -> do _ <- forkIO (worker (path c) ch d e) pure () - pure CallLogHandle {chan = ch, done = d, cfg = c, workerError = e} + pure CallLogHandle {chan = ch, done = d, cfg = c, workerError = e, closed = cl} -- | Signal shutdown and block until the worker has drained every -- pending entry to disk. +-- +-- Idempotent. The first caller claims the handle and does the work; a +-- second returns at once. Before the claim existed, a second close +-- blocked forever on an 'MVar' the worker had already emptied — which +-- 'withCallLog' made easy to hit, since its bracket closes a handle a +-- body may also have closed. 'readMVar' rather than 'takeMVar' for the +-- same reason: the slot stays filled. closeCallLog :: (MonadIO m) => CallLogHandle -> m () closeCallLog h = liftIO $ do - case enabled (cfg h) of - True -> writeChan (chan h) Nothing - False -> pure () - takeMVar (done h) - merr <- readIORef (workerError h) - forM_ merr $ \e -> - hPutStrLn - stderr - ("baikai: call log worker failed; pending entries were dropped: " <> displayException e) + alreadyClosed <- atomicModifyIORef' (closed h) (\b -> (True, b)) + unless alreadyClosed $ do + case enabled (cfg h) of + True -> writeChan (chan h) Nothing + False -> pure () + readMVar (done h) + merr <- readIORef (workerError h) + forM_ merr $ \e -> + hPutStrLn + stderr + ("baikai: call log worker failed; pending entries were dropped: " <> displayException e) -- | Bracketed lifetime: open the handle, run the body, close -- exactly once on every path (including exceptions). @@ -140,12 +170,16 @@ withRunInIO $ \run -> bracket (openCallLog c) closeCallLog (run . body) --- | Non-blocking enqueue. When the handle is disabled, returns --- immediately without touching the channel. +-- | Non-blocking enqueue. When the handle is disabled, or has already +-- been closed, returns immediately without touching the channel — the +-- worker that would have drained the entry is gone, so enqueuing it +-- would only grow a channel nobody reads. appendEntry :: (MonadIO m) => CallLogHandle -> CallLogEntry -> m () appendEntry h entry | not (enabled (cfg h)) = pure () - | otherwise = liftIO (writeChan (chan h) (Just entry)) + | otherwise = liftIO $ do + isClosed <- readIORef (closed h) + unless isClosed (writeChan (chan h) (Just entry)) -- | Dispatch through the registry, then (if logging is enabled) -- enqueue a single JSONL record summarizing the call. diff --git a/src/Baikai/Embedding.hs b/src/Baikai/Embedding.hs --- a/src/Baikai/Embedding.hs +++ b/src/Baikai/Embedding.hs @@ -1,12 +1,16 @@ -- | A small, provider-neutral embeddings client over an OpenAI-compatible --- @\/v1\/embeddings@ endpoint (EP-15). +-- @\/v1\/embeddings@ endpoint. -- --- baikai shipped no embeddings client; this is the first. It reuses the same --- @openai@ SDK path the OpenAI /chat/ provider already uses --- ('OpenAI.V1.getClientEnv' + 'OpenAI.V1.makeMethods') and the sibling --- 'OpenAI.V1.createEmbeddings' method, plus baikai's own 'Baikai.Auth' for key --- resolution. It is policy-free (a plain @IO@ client, no effect binding) — the --- effect interpreter lives one layer up in shikumi, exactly as @baikai-effectful@ +-- baikai shipped no embeddings client; this is the first. It reuses the +-- @openai@ SDK's 'OpenAI.V1.makeMethods' and the sibling +-- 'OpenAI.V1.createEmbeddings' method, baikai's own 'Baikai.Auth' for key +-- resolution — the same per-host table the chat providers use — and +-- baikai's own 'Baikai.Http' connection cache, which the chat providers +-- share, so two calls to one host reuse one TLS manager rather than +-- allocating one per call as the SDK's own @getClientEnv@ does. +-- +-- It is policy-free (a plain @IO@ client, no effect binding) — the effect +-- interpreter lives one layer up in shikumi, exactly as @baikai-effectful@ -- relates to the transport. -- -- An embedding model is named by a bare provider model-id string (e.g. @@ -15,29 +19,39 @@ -- fields (context window, output tokens, chat pricing, modalities) are meaningful -- for embeddings. module Baikai.Embedding - ( EmbeddingModel (..), + ( EmbeddingModel (modelId, baseUrl, dimensions, apiKey), emptyEmbeddingModel, - _EmbeddingModel, openAIEmbeddingModel, mkEmbeddingRequest, firstEmbedding, + resolveEmbeddingKey, + embeddingClientEnv, embed, embedOne, ) where import Baikai.Auth (ApiKeySource (..), resolveApiKey) -import Baikai.Error (BaikaiError, decodeError) +import Baikai.Auth qualified as Auth +import Baikai.Error (BaikaiError, authError, decodeError, invalidRequest) +import Baikai.Http qualified as Http +import Baikai.Url qualified as Url import Control.Exception (throwIO) import Data.Text (Text) import Data.Vector (Vector) import Data.Vector qualified as V +import GHC.Generics (Generic) import Numeric.Natural (Natural) import OpenAI.V1 qualified as OpenAI import OpenAI.V1.Embeddings qualified as Emb import OpenAI.V1.Models qualified as OpenAIModels +import Servant.Client qualified as Client -- | How to reach an embeddings endpoint and which model to ask for. +-- +-- Construction: the constructor is deliberately not exported. Start +-- from 'emptyEmbeddingModel' (or 'openAIEmbeddingModel') and override +-- fields by record update. data EmbeddingModel = EmbeddingModel { -- | e.g. @\"text-embedding-3-small\"@ modelId :: !Text, @@ -45,31 +59,38 @@ baseUrl :: !Text, -- | request a reduced dimensionality, or 'Nothing' for the model default dimensions :: !(Maybe Natural), - -- | how to resolve the API key (from "Baikai.Auth") - apiKey :: !ApiKeySource + -- | How to resolve the API key (from "Baikai.Auth"). 'Nothing' means + -- the conventional variable for this host, from + -- 'Auth.defaultApiKeyEnvForBaseUrl' — the same table the chat + -- providers consult — and a host that table does not know refuses + -- with an 'Baikai.Error.AuthError' rather than falling back to + -- another provider's credential. This mirrors + -- 'Baikai.Options.apiKey', which has meant exactly that all along. + apiKey :: !(Maybe ApiKeySource) } - deriving stock (Show) + deriving stock (Eq, Show, Generic) -- | A blank embedding model; a record-update target for hand-built models. Keyed --- on @OPENAI_API_KEY@ by default. +-- per host by default, so @api.openai.com@ resolves @OPENAI_API_KEY@ and +-- @api.deepseek.com@ resolves @DEEPSEEK_API_KEY@. emptyEmbeddingModel :: EmbeddingModel emptyEmbeddingModel = EmbeddingModel { modelId = "", baseUrl = "", dimensions = Nothing, - apiKey = ApiKeyEnv "OPENAI_API_KEY" + apiKey = Nothing } --- | The OpenAI default: @api.openai.com@, key from @OPENAI_API_KEY@, model-default --- dimensionality. +-- | The OpenAI default: @api.openai.com@, whose conventional key variable is +-- @OPENAI_API_KEY@, and model-default dimensionality. openAIEmbeddingModel :: Text -> EmbeddingModel openAIEmbeddingModel mid = emptyEmbeddingModel { modelId = mid, baseUrl = "https://api.openai.com", dimensions = Nothing, - apiKey = ApiKeyEnv "OPENAI_API_KEY" + apiKey = Nothing } -- | Build the OpenAI @\/v1\/embeddings@ request for a single input text. Pure and @@ -94,6 +115,40 @@ Just (obj, _) -> Right (Emb.embedding obj) +-- | The key 'embed' will send: the explicit source when the model names +-- one, otherwise the conventional variable for the model's host. +-- +-- A host with no conventional variable is an 'Baikai.Error.AuthError' +-- naming the host and telling the caller to set the field, rather than a +-- silent fallback to @OPENAI_API_KEY@ — which is what this did before, +-- and which sent an OpenAI key to whatever host the base URL named. +-- +-- Exported so a caller can see which key a model resolves without +-- making a request. +resolveEmbeddingKey :: EmbeddingModel -> IO Text +resolveEmbeddingKey m = case apiKey m of + Just source -> resolveApiKey source + Nothing -> case Auth.defaultApiKeyEnvForBaseUrl url of + Just name -> resolveApiKey (ApiKeyEnv name) + Nothing -> + throwIO + ( authError + ( "no default API key env is known for " + <> url + <> "; set EmbeddingModel.apiKey explicitly" + ) + ) + where + url = urlOf m + +-- | The cached connection 'embed' will use, from "Baikai.Http" — the +-- same process-global cache the chat providers use, so an embeddings +-- call and a chat call to one host share a TLS manager. +-- +-- Exported so the sharing is observable without a network call. +embeddingClientEnv :: EmbeddingModel -> IO Client.ClientEnv +embeddingClientEnv = Http.getClientEnvCached . urlOf + -- | Embed a batch of texts: one vector per input text, in input order. The SDK's -- @CreateEmbeddings.input@ is a single 'Text', so this loops one call per text. The -- transport exception (a Servant client error) is let propagate — error remapping @@ -101,8 +156,17 @@ embed :: EmbeddingModel -> [Text] -> IO (Vector (Vector Double)) embed _ [] = pure V.empty embed m texts = do - key <- resolveApiKey (apiKey m) - env <- OpenAI.getClientEnv (urlOf m) + -- Checked before the key is resolved, so a base URL baikai will not + -- send to never causes a credential to be read out of the + -- environment. The base URL is the API root — baikai appends + -- @\/v1\/embeddings@ itself, and a trailing @\/v1@ is removed rather + -- than doubled. + case Url.baseUrlProblem (urlOf m) of + Just problem -> + throwIO (invalidRequest ("EmbeddingModel.baseUrl is not usable: " <> problem)) + Nothing -> pure () + key <- resolveEmbeddingKey m + env <- embeddingClientEnv m let create = OpenAI.createEmbeddings (OpenAI.makeMethods env key Nothing Nothing) V.fromList <$> traverse (embedText create) texts where @@ -123,7 +187,3 @@ urlOf m = case baseUrl m of "" -> "https://api.openai.com" u -> u - -{-# DEPRECATED _EmbeddingModel "Use emptyEmbeddingModel instead." #-} -_EmbeddingModel :: EmbeddingModel -_EmbeddingModel = emptyEmbeddingModel diff --git a/src/Baikai/Error.hs b/src/Baikai/Error.hs --- a/src/Baikai/Error.hs +++ b/src/Baikai/Error.hs @@ -5,6 +5,7 @@ -- * Smart constructors providerError, invalidRequest, + contentFiltered, decodeError, processError, rateLimited, @@ -17,12 +18,15 @@ -- * Pure classification helpers for provider packages httpError, parseRetryAfterSeconds, + parseHttpDate, + retryAfterSecondsAt, classifyHttpStatus, classifyHttpStatusWithBody, bodyIndicatesOverflow, ) where +import Control.Applicative ((<|>)) import Control.Exception (Exception (displayException)) import Data.Aeson ( FromJSON (parseJSON), @@ -33,8 +37,10 @@ genericParseJSON, genericToJSON, ) +import Data.Maybe (listToMaybe, mapMaybe) import Data.Text (Text) import Data.Text qualified as Text +import Data.Time (UTCTime, defaultTimeLocale, diffUTCTime, parseTimeM) import GHC.Generics (Generic) import Text.Read (readMaybe) @@ -50,11 +56,17 @@ -- retryable after a delay; see 'retryAfterSeconds'. RateLimited | -- | The request exceeded the model's context window or a related - -- size limit. Not retryable as-is; the caller must shrink input. + -- size limit: HTTP 413, or a 400\/422 whose body names the context + -- window. Not retryable as-is; the caller must shrink input. ContextOverflow | -- | The request was malformed or otherwise rejected as invalid -- (HTTP 400/404/422). Not retryable without changes. InvalidRequest + | -- | The provider refused or filtered the content — OpenAI's + -- @finish_reason: "content_filter"@, Anthropic's @refusal@ stop. + -- The content, not the transport, is the problem, so it is not + -- retryable as-is: the caller must change what it sent. + ContentFiltered | -- | A transient server-side or network failure (HTTP 408/5xx, or a -- connection error). Safe to retry, ideally with backoff. TransientError @@ -91,7 +103,7 @@ -- | The HTTP status code, when the failure came from an HTTP call. httpStatus :: !(Maybe Int), -- | Seconds to wait before retrying, parsed from a @Retry-After@ - -- header when present and integer-valued. + -- header in either its integer or its HTTP-date form. retryAfterSeconds :: !(Maybe Int), -- | The subprocess exit code, for 'ProcessFailure'. exitCode :: !(Maybe Int) @@ -135,6 +147,10 @@ invalidRequest :: Text -> BaikaiError invalidRequest = baseError InvalidRequest +-- | Content the provider refused or filtered. +contentFiltered :: Text -> BaikaiError +contentFiltered = baseError ContentFiltered + -- | A response that failed to decode. decodeError :: Text -> BaikaiError decodeError = baseError DecodeFailure @@ -166,13 +182,43 @@ TransientError -> True _ -> False --- | Parse an integer-valued @Retry-After@ header as seconds. HTTP-date --- values and malformed values yield 'Nothing'. +-- | Parse an integer-valued @Retry-After@ header as seconds. The +-- integer form only: an HTTP-date yields 'Nothing' here, deliberately, +-- because converting one needs a reference instant. See +-- 'retryAfterSecondsAt' for the form that accepts either. parseRetryAfterSeconds :: Text -> Maybe Int parseRetryAfterSeconds raw = do n <- readMaybe (Text.unpack (Text.strip raw)) if n >= 0 then Just n else Nothing +-- | Parse an HTTP-date (RFC 7231 section 7.1.1.1). Accepts the +-- IMF-fixdate form servers must send, plus the obsolete RFC 850 and +-- asctime forms a recipient must still accept. +parseHttpDate :: Text -> Maybe UTCTime +parseHttpDate raw = listToMaybe (mapMaybe attempt formats) + where + s = Text.unpack (Text.strip raw) + attempt fmt = parseTimeM True defaultTimeLocale fmt s + formats = + [ "%a, %d %b %Y %H:%M:%S GMT", -- Sun, 06 Nov 1994 08:49:37 GMT + "%A, %d-%b-%y %H:%M:%S GMT", -- Sunday, 06-Nov-94 08:49:37 GMT + "%a %b %e %H:%M:%S %Y" -- Sun Nov 6 08:49:37 1994 + ] + +-- | Seconds to wait, from a @Retry-After@ value in either of its two +-- forms, relative to a reference instant. +-- +-- The reference should be the response's own @Date@ header when it +-- parses, which takes the caller's clock skew out of the computation; +-- the local time is the fallback. A date already in the past yields +-- @Just 0@ — the server is saying "now" — and text in neither form +-- yields 'Nothing'. +retryAfterSecondsAt :: UTCTime -> Text -> Maybe Int +retryAfterSecondsAt reference raw = + parseRetryAfterSeconds raw <|> (secondsUntil <$> parseHttpDate raw) + where + secondsUntil t = max 0 (ceiling (diffUTCTime t reference)) + -- | Build a classified error from an HTTP failure's status, optional -- parsed @Retry-After@ seconds, and response body text. httpError :: Int -> Maybe Int -> Text -> BaikaiError @@ -195,12 +241,15 @@ -- -- The body of a 400 may indicate a context-window overflow, but this -- helper only sees the status code; callers that can inspect the body --- should special-case overflow before falling back here. +-- should special-case overflow before falling back here. 413 needs no +-- such help: it /is/ the size-limit status, and the caller's remedy — +-- shrink the input — is the same whatever the body says. classifyHttpStatus :: Int -> Maybe Int -> ErrorCategory classifyHttpStatus status _retryAfter | status == 401 || status == 403 = AuthError | status == 429 = RateLimited | status == 408 = TransientError + | status == 413 = ContextOverflow | status == 400 || status == 404 || status == 422 = InvalidRequest | status >= 500 = TransientError | otherwise = OtherError diff --git a/src/Baikai/Evidence.hs b/src/Baikai/Evidence.hs --- a/src/Baikai/Evidence.hs +++ b/src/Baikai/Evidence.hs @@ -29,7 +29,31 @@ evidenceSchemaVersion, -- * The evidence record - ModelCallEvidence (..), + ModelCallEvidence + ( schemaVersion, + runId, + callId, + attempt, + supersedes, + endpoint, + requestedModel, + thinking, + observedModel, + observedThinking, + responseId, + providerRequestId, + clientRequestId, + startedAt, + endedAt, + latencyMs, + status, + errorInfo, + usage, + strength, + requestCommitment, + requestConfiguration, + responseCommitment + ), baseEvidence, -- * Observation @@ -40,7 +64,9 @@ ThinkingTranslation (..), ThinkingMode (..), ThinkingAdjustment (..), + weakensThinking, noThinkingRequested, + untranslatedThinking, -- * Endpoint and transport EndpointIdentity (..), @@ -50,14 +76,17 @@ CallStatus (..), EvidenceStrength (..), renderEvidenceStrength, + parseEvidenceStrength, declaredStrength, + deriveStrength, -- * The caller's request - EvidenceRequest (..), + EvidenceRequest (runId, strictness, attempt, supersedes), EvidenceStrictness (..), evidenceRequest, -- * Canonical encoding and digests + usageEnvelope, canonicalEncode, commitmentDigest, configurationDigest, @@ -70,8 +99,9 @@ import Baikai.Api (Api (..)) import Baikai.Error (BaikaiError) -import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Baikai.ThinkingLevel (ThinkingLevel (..), parseThinkingLevel, renderThinkingLevel) import Baikai.Usage (Usage) +import Baikai.Usage qualified as Usage import Control.Exception (SomeException, try) import Crypto.Hash.SHA256 qualified as SHA256 import Data.Aeson @@ -91,7 +121,7 @@ ) import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap -import Data.Aeson.Types (typeMismatch) +import Data.Aeson.Types (Parser, typeMismatch) import Data.Bits (Bits, shiftL, shiftR, (.&.), (.|.)) import Data.ByteString (ByteString) import Data.ByteString qualified as ByteString @@ -172,7 +202,7 @@ -- | Which shape a provider's thinking configuration took on the wire. -- -- Encodes as a lowercase string: @budget@, @adaptive@, @flag@, --- @toggle@, @unsupported@, @absent@. +-- @toggle@, @unsupported@, @not_translated@, @absent@. data ThinkingMode = -- | The provider took an explicit token budget. ThinkingModeBudget @@ -185,6 +215,13 @@ | -- | The caller requested a level and this transport cannot express -- any part of it. ThinkingModeUnsupported + | -- | The caller requested a level and no provider adapter ran to + -- translate it: the call was refused, never dispatched, or + -- abandoned before the adapter could describe what it did. The + -- request is recorded; the translation is unknown. Distinct from + -- 'ThinkingModeAbsent' (nothing requested) and from + -- 'ThinkingModeUnsupported' (an adapter looked and could not). + ThinkingModeNotTranslated | -- | The caller requested no level at all. ThinkingModeAbsent deriving stock (Eq, Show, Generic) @@ -196,6 +233,7 @@ ThinkingModeFlag -> "flag" ThinkingModeToggle -> "toggle" ThinkingModeUnsupported -> "unsupported" + ThinkingModeNotTranslated -> "not_translated" ThinkingModeAbsent -> "absent" parseThinkingMode :: Text -> Maybe ThinkingMode @@ -205,6 +243,7 @@ "flag" -> Just ThinkingModeFlag "toggle" -> Just ThinkingModeToggle "unsupported" -> Just ThinkingModeUnsupported + "not_translated" -> Just ThinkingModeNotTranslated "absent" -> Just ThinkingModeAbsent _ -> Nothing @@ -227,6 +266,12 @@ -- Levels are carried as 'ThinkingLevel' rather than text so that -- strict evidence mode can compare them; they render through -- 'Baikai.ThinkingLevel.renderThinkingLevel' in JSON. +-- +-- Two constructors are not about thinking: the sampling drops record +-- that @temperature@, @top_p@, @seed@ and their kind were removed +-- because the model generation or the API rejects them. They carry no +-- requested level and 'weakensThinking' is 'False' for them, so strict +-- evidence mode does not refuse a call over one. data ThinkingAdjustment = -- | The requested level was replaced by a weaker one the transport -- accepts. Carries the requested level and the wire text sent. @@ -248,8 +293,38 @@ -- fit inside the resolved output-token ceiling. Carries the -- requested level, the budget that was computed, and the ceiling. ThinkingDroppedBudgetExceeded !ThinkingLevel !Natural !Natural + | -- | Sampling parameters the caller set were removed because the + -- chosen model generation rejects them. Carries the wire names + -- removed, in wire order, for example + -- @["temperature","top_p"]@. Carries no requested level: it is + -- not about thinking, and it happens on calls that asked for no + -- thinking at all. + SamplingDroppedUnsupportedModel ![Text] + | -- | Sampling parameters the caller set were removed because this + -- API has no field for them on any generation — the Anthropic + -- Messages API has no @seed@, @frequency_penalty@ or + -- @presence_penalty@. Carries the wire names removed, in wire + -- order. + SamplingDroppedUnsupportedApi ![Text] deriving stock (Eq, Show, Generic) +-- | Whether an adjustment weakens the /thinking/ the caller asked for. +-- +-- Strict evidence mode refuses a call whose translation would weaken +-- the requested thinking level; it must not refuse one merely because +-- a sampling parameter had nowhere to go. The six level-carrying +-- constructors weaken thinking; the two sampling ones do not. +weakensThinking :: ThinkingAdjustment -> Bool +weakensThinking = \case + EffortClamped {} -> True + EffortCollapsedToToggle {} -> True + EffortOmitted {} -> True + ThinkingDroppedUnsupportedModel {} -> True + ThinkingDroppedUnsupportedHost {} -> True + ThinkingDroppedBudgetExceeded {} -> True + SamplingDroppedUnsupportedModel {} -> False + SamplingDroppedUnsupportedApi {} -> False + -- | Adjustments encode as a tagged object whose @kind@ names the -- constructor in snake_case and whose @requested@ field carries the -- canonical level name. @@ -270,28 +345,43 @@ "thinking_dropped_budget_exceeded" lvl ["budget_tokens" .= budget, "max_tokens" .= maxOut] + SamplingDroppedUnsupportedModel fields -> + untagged "sampling_dropped_unsupported_model" fields + SamplingDroppedUnsupportedApi fields -> + untagged "sampling_dropped_unsupported_api" fields where tagged kind lvl extra = object ( ["kind" .= (kind :: Text), "requested" .= renderThinkingLevel lvl] <> extra ) + untagged kind fields = + object ["kind" .= (kind :: Text), "fields" .= (fields :: [Text])] +-- | @kind@ is read first, because only the six level-carrying kinds +-- have a @requested@ field to read: the two sampling kinds carry a +-- @fields@ array instead. instance FromJSON ThinkingAdjustment where parseJSON = \case Object o -> do kind <- o .: "kind" - lvl <- o .: "requested" >>= parseThinkingLevelText + let withLevel :: (ThinkingLevel -> Parser ThinkingAdjustment) -> Parser ThinkingAdjustment + withLevel k = o .: "requested" >>= parseThinkingLevelText >>= k case kind :: Text of - "effort_clamped" -> EffortClamped lvl <$> o .: "wire" - "effort_collapsed_to_toggle" -> pure (EffortCollapsedToToggle lvl) - "effort_omitted" -> pure (EffortOmitted lvl) + "effort_clamped" -> withLevel $ \lvl -> EffortClamped lvl <$> o .: "wire" + "effort_collapsed_to_toggle" -> withLevel (pure . EffortCollapsedToToggle) + "effort_omitted" -> withLevel (pure . EffortOmitted) "thinking_dropped_unsupported_model" -> - pure (ThinkingDroppedUnsupportedModel lvl) + withLevel (pure . ThinkingDroppedUnsupportedModel) "thinking_dropped_unsupported_host" -> - pure (ThinkingDroppedUnsupportedHost lvl) + withLevel (pure . ThinkingDroppedUnsupportedHost) "thinking_dropped_budget_exceeded" -> - ThinkingDroppedBudgetExceeded lvl <$> o .: "budget_tokens" <*> o .: "max_tokens" + withLevel $ \lvl -> + ThinkingDroppedBudgetExceeded lvl <$> o .: "budget_tokens" <*> o .: "max_tokens" + "sampling_dropped_unsupported_model" -> + SamplingDroppedUnsupportedModel <$> o .: "fields" + "sampling_dropped_unsupported_api" -> + SamplingDroppedUnsupportedApi <$> o .: "fields" other -> fail ("unknown thinking adjustment: " <> show other) v -> typeMismatch "ThinkingAdjustment" v @@ -301,15 +391,13 @@ -- names that 'ThinkingLevel'\'s own derived instance uses, because a -- reader of an evidence record should see the same vocabulary the -- provider documentation uses. +-- +-- The table itself lives beside its renderer, in +-- 'Baikai.ThinkingLevel.parseThinkingLevel'; this is the parser-monad +-- wrapper that turns a miss into a decode failure naming the input. parseThinkingLevelText :: (MonadFail m) => Text -> m ThinkingLevel -parseThinkingLevelText = \case - "minimal" -> pure ThinkingMinimal - "low" -> pure ThinkingLow - "medium" -> pure ThinkingMedium - "high" -> pure ThinkingHigh - "xhigh" -> pure ThinkingXHigh - "max" -> pure ThinkingMax - other -> fail ("unknown thinking level: " <> show other) +parseThinkingLevelText t = + maybe (fail ("unknown thinking level: " <> show t)) pure (parseThinkingLevel t) -- | What a canonical 'ThinkingLevel' actually became on the wire for -- one specific provider. @@ -336,6 +424,12 @@ -- | Everything that happened to the request between the canonical -- level and the wire, in the order it was applied. Empty means the -- request was expressed exactly. + -- + -- Reasoning /and/ sampling changes travel here: a + -- 'SamplingDroppedUnsupportedModel' entry can appear on a call + -- whose 'mode' is 'ThinkingModeAbsent', because nothing about + -- thinking was asked and something about sampling was dropped. + -- 'mode' describes the thinking configuration only. adjustments :: ![ThinkingAdjustment] } deriving stock (Eq, Show, Generic) @@ -368,6 +462,12 @@ -- Distinct from a call that asked for a level the transport could not -- express, which is 'ThinkingModeUnsupported' with a non-empty -- 'adjustments' list. +-- +-- This value's 'adjustments' list is empty, but a real call that asked +-- for no thinking may still carry adjustments: a dropped sampling +-- parameter is recorded whatever the thinking mode. Build such a +-- translation by adding to this one rather than by assuming +-- @mode = absent@ implies nothing happened. noThinkingRequested :: ThinkingTranslation noThinkingRequested = ThinkingTranslation @@ -379,6 +479,47 @@ adjustments = [] } +-- | The translation for a path where no adapter ran: the caller's +-- level exactly, and no claim about the wire. 'noThinkingRequested' +-- when no level was set, so the two statements stay distinct. +-- +-- The 'adjustments' list is empty on purpose: an untranslated request +-- has not been downgraded, it has not been looked at, and strict +-- evidence mode refuses a call over a non-empty list. +untranslatedThinking :: Maybe ThinkingLevel -> ThinkingTranslation +untranslatedThinking = \case + Nothing -> noThinkingRequested + Just lvl -> + ThinkingTranslation + { requested = Just lvl, + mode = ThinkingModeNotTranslated, + effortText = Nothing, + budgetTokens = Nothing, + wireField = Nothing, + adjustments = [] + } + +-- | The usage a response digest commits to: the token counts the +-- provider reported, and never the cost. +-- +-- 'Usage.cost' is computed here from the caller's own catalog rates, +-- not reported by the provider, so including it made +-- @response_commitment@ change whenever pricing was edited and left a +-- verifier holding only the response unable to recompute it. The six +-- counts are listed through record selectors rather than encoded +-- wholesale, so a field added to 'Usage' later does not silently join +-- the digest. +usageEnvelope :: Usage -> Value +usageEnvelope u = + object + [ "input_tokens" .= Usage.inputTokens u, + "output_tokens" .= Usage.outputTokens u, + "cache_read_tokens" .= Usage.cacheReadTokens u, + "cache_write_tokens" .= Usage.cacheWriteTokens u, + "reasoning_tokens" .= Usage.reasoningTokens u, + "total_tokens" .= Usage.totalTokens u + ] + -- ============================================================ -- Endpoint and transport -- ============================================================ @@ -522,16 +663,23 @@ EvidenceModelObserved -> "model_observed" EvidenceFullyObserved -> "fully_observed" +-- | The inverse of 'renderEvidenceStrength'. Beside its renderer, so +-- the two cannot drift when a level is added; the 'FromJSON' instance +-- and @baikai-agent@'s @--require-evidence@ parser both go through it. +parseEvidenceStrength :: Text -> Maybe EvidenceStrength +parseEvidenceStrength = \case + "requested_only" -> Just EvidenceRequestedOnly + "correlated" -> Just EvidenceCorrelated + "model_observed" -> Just EvidenceModelObserved + "fully_observed" -> Just EvidenceFullyObserved + _ -> Nothing + instance ToJSON EvidenceStrength where toJSON = String . renderEvidenceStrength instance FromJSON EvidenceStrength where - parseJSON = withText "EvidenceStrength" $ \case - "requested_only" -> pure EvidenceRequestedOnly - "correlated" -> pure EvidenceCorrelated - "model_observed" -> pure EvidenceModelObserved - "fully_observed" -> pure EvidenceFullyObserved - other -> fail ("unknown evidence strength: " <> show other) + parseJSON = withText "EvidenceStrength" $ \t -> + maybe (fail ("unknown evidence strength: " <> show t)) pure (parseEvidenceStrength t) -- | The highest strength a transport can reach when everything goes -- well. @@ -569,6 +717,45 @@ -- -- * 'Custom' declares 'EvidenceRequestedOnly'. Baikai knows nothing -- about a caller-supplied transport and must not assume on its behalf. +-- | The one rule that turns observations into a strength. +-- +-- A __correlation identifier__ is the provider's request id (typically a +-- response header) or its response id; either locates the call in the +-- provider's own records, which is what 'EvidenceCorrelated' means. +-- +-- A model is 'EvidenceModelObserved' only /in addition to/ one, because +-- the scale is cumulative by its own documentation. An unlocatable model +-- claim does not climb it — it stays recorded in @observed_model@, where +-- a reader can see it — and no shipped transport produces that +-- combination. Nothing reaches 'EvidenceFullyObserved'. +-- +-- A successful status is deliberately not an argument. A 200 means the +-- request was accepted, not that any particular model ran. +-- +-- Three copies of this rule had drifted apart: the subprocess one +-- counted a session or thread id as correlation while the two API ones +-- looked only at a captured header, so a host reporting @model@ and @id@ +-- on every chunk but no header landed at 'EvidenceRequestedOnly', +-- /below/ a host that sent only a header. +deriveStrength :: + -- | The model the provider reported serving. + Observed Text -> + -- | The provider's request id, typically from a response header. + Observed Text -> + -- | The provider's response id. + Observed Text -> + EvidenceStrength +deriveStrength observedModel providerRequestId responseId = + case (observedModel, correlated) of + (Observed _, True) -> EvidenceModelObserved + (_, True) -> EvidenceCorrelated + _ -> EvidenceRequestedOnly + where + correlated = case (providerRequestId, responseId) of + (Observed _, _) -> True + (_, Observed _) -> True + _ -> False + declaredStrength :: Api -> EvidenceStrength declaredStrength = \case AnthropicMessages -> EvidenceModelObserved @@ -619,6 +806,9 @@ -- behaves exactly as it did before this vocabulary existed: no digest -- is computed, no call identifier is generated for evidence purposes, -- and no evidence is emitted. +-- +-- Construction: the constructor is deliberately not exported. Start +-- from 'evidenceRequest' and override fields by record update. data EvidenceRequest = EvidenceRequest { -- | The caller's identifier for the logical unit of work this call -- belongs to. Baikai treats it as opaque text and never parses it. @@ -662,14 +852,41 @@ -- existing readers working; bump the major component when a field is -- removed, changes meaning, or when 'canonicalEncode' changes, since -- that invalidates every previously recorded digest. +-- The @1.1@ minor bump added the @sampling_dropped_unsupported_model@ +-- and @sampling_dropped_unsupported_api@ adjustment kinds. They are a +-- compatible addition: a reader that switches on @kind@ and ignores +-- what it does not know keeps working, and no existing digest changes. +-- +-- The @2.0@ major bump changed what two digests cover, so a verifier +-- must select its rules by @schema_version@ rather than assume: +-- +-- * @response_commitment@ covers @{"content", "stop_reason", "usage"}@ +-- where @usage@ is the provider-reported token counts only +-- ('usageEnvelope'). Under @1.x@ it also covered baikai's computed +-- @cost@, which comes from the caller's catalog rates rather than +-- from the response, so the digest changed whenever pricing was +-- edited and a verifier holding only the response could not +-- recompute it. +-- * @request_configuration@ additionally summarises @output_config@ and +-- @response_format@ ('configurationProjection'), because a +-- structured-output JSON schema is author-written content wherever it +-- appears. Under @1.x@ both survived verbatim. +-- +-- A @1.x@ record's digests are recomputed under @1.x@ rules. One +-- further compatible addition rides along: @thinking.mode@ may now be +-- @"not_translated"@. evidenceSchemaVersion :: Text -evidenceSchemaVersion = "baikai.model-call-evidence/1.0" +evidenceSchemaVersion = "baikai.model-call-evidence/2.0" -- | Everything Baikai can say about one completed provider call. -- -- The field order is the story the record tells: who ran it, where it -- went, what was asked, what came back, how it went, and what it costs -- to believe. +-- +-- Construction: the constructor is deliberately not exported. Start +-- from 'baseEvidence' and override fields by record update, so that a +-- field added in a later release cannot break a construction site. data ModelCallEvidence = ModelCallEvidence { -- Identity ------------------------------------------------------- @@ -981,13 +1198,25 @@ -- the digest until someone adds it here, which loses fidelity rather -- than leaking. -- --- Keys outside the list are dropped entirely. Three keys are kept but +-- Keys outside the list are dropped entirely. Five keys are kept but -- replaced with structural summaries: @messages@ becomes one object -- per message carrying its role, its block count, and the total -- character length of every string inside it; @system@ becomes just -- that character count; @tools@ becomes each tool's name and nothing --- else, so descriptions and JSON schemas do not survive. +-- else; @output_config@ keeps its effort and reduces its @format@ to a +-- type and a character count; and @response_format@ keeps its type and +-- reduces its @json_schema@ to a name, a strictness flag and a +-- character count. -- +-- The rule the last three share: __a JSON schema is content wherever it +-- appears.__ A schema carries author-written @description@ strings that +-- describe the caller's domain as freely as a prompt does. +-- @tools[].input_schema@ was already stripped on that ground while the +-- same kind of schema, reached through @output_config.format.schema@ or +-- @response_format.json_schema@, survived verbatim into a digest +-- callers were told is content-free. The names, types and flags around +-- it are configuration in the sense a tool's name is. +-- -- A top-level value that is not an object has no named fields for the -- allow-list to admit, so it projects to 'Null' rather than passing -- through. @@ -1000,6 +1229,8 @@ "messages" -> [(k, summariseMessages v)] "system" -> [(k, charSummary v)] "tools" -> [(k, summariseTools v)] + "output_config" -> [(k, summariseOutputConfig v)] + "response_format" -> [(k, summariseResponseFormat v)] name | name `Set.member` configurationKeys -> [(k, v)] | otherwise -> [] @@ -1016,11 +1247,9 @@ "max_completion_tokens", "max_tokens", "model", - "output_config", "presence_penalty", "reasoning", "reasoning_effort", - "response_format", "seed", "stop_sequences", "stream", @@ -1074,6 +1303,56 @@ -- schema are author-written content. Both wire shapes are handled: the -- Anthropic form with @name@ at the top level, and the OpenAI form -- that nests it under @function@. +-- | Anthropic's @output_config@: @{"effort": , "format": +-- {"type": ..., "schema": ...}}@ at claude 0.6 (@Claude.V1.Messages@, +-- @OutputConfig@ and @OutputFormat@). Every key is kept as it is except +-- @format@, whose schema is content. +summariseOutputConfig :: Value -> Value +summariseOutputConfig = \case + Object o -> Object (KeyMap.mapWithKey summarise o) + _ -> Null + where + summarise k v + | Key.toText k == "format" = + object + [ "type" .= formatType v, + "chars" .= totalStringChars v + ] + | otherwise = v + formatType = \case + Object f -> case KeyMap.lookup "type" f of + Just t@(String _) -> t + _ -> Null + _ -> Null + +-- | The OpenAI-compatible @response_format@: @{"type": "json_schema", +-- "json_schema": {"name": ..., "strict": ..., "schema": ...}}@. The +-- type, the schema's name and its strictness are configuration; the +-- schema itself is content. +summariseResponseFormat :: Value -> Value +summariseResponseFormat = \case + Object o -> + object + [ "type" .= lookupString "type" o, + "json_schema" .= schemaSummary (KeyMap.lookup "json_schema" o) + ] + _ -> Null + where + lookupString k o = case KeyMap.lookup (Key.fromText k) o of + Just t@(String _) -> t + _ -> Null + schemaSummary = \case + Just v@(Object js) -> + object + [ "name" .= lookupString "name" js, + "strict" .= strictOf js, + "chars" .= totalStringChars v + ] + _ -> Null + strictOf js = case KeyMap.lookup "strict" js of + Just b@(Bool _) -> b + _ -> Null + summariseTools :: Value -> Value summariseTools = \case Array xs -> Array (fmap summariseTool xs) diff --git a/src/Baikai/Evidence/Build.hs b/src/Baikai/Evidence/Build.hs --- a/src/Baikai/Evidence/Build.hs +++ b/src/Baikai/Evidence/Build.hs @@ -16,10 +16,14 @@ -- cannot forget it. module Baikai.Evidence.Build ( minimalEvidence, + minimalEvidenceAt, prepareEvidence, + prepareEvidenceAt, endpointIdentity, + endpointIdentityAt, sanitizeEndpoint, dispatchEnvelope, + requestedTranslation, transportForModel, baikaiPackageVersion, @@ -28,6 +32,10 @@ sinkFailureIsFatal, sinkFailureError, + -- * Strict mode + strictnessOf, + missingEvidenceError, + -- * The pre-dispatch strictness gate EvidenceRefusal (..), renderEvidenceRefusal, @@ -50,14 +58,16 @@ baseEvidence, commitmentDigest, configurationDigest, - declaredStrength, newCallId, renderEvidenceStrength, + untranslatedThinking, + weakensThinking, ) import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Prelude import Baikai.ThinkingLevel (renderThinkingLevel) +import Baikai.Url qualified as Url import Control.Exception (SomeException, displayException) import Data.Aeson qualified as Aeson import Data.Maybe (fromMaybe) @@ -125,8 +135,36 @@ -- documentation rather than enforced by the type. Maybe BaikaiError -> IO (Maybe ModelCallEvidence) -minimalEvidence m opts transport translation envelope started ended st err = do - mk <- prepareEvidence m opts transport translation envelope started +minimalEvidence m opts = + minimalEvidenceAt (m ^. #baseUrl) m opts + +-- | 'minimalEvidence' against the base URL the adapter actually +-- resolved, rather than the possibly-empty one on the 'Model'. +-- +-- Both API adapters substitute a vendor default for an empty +-- @baseUrl@ inside their own @prepareCall@, so the call goes to a +-- definite host while the model still says @""@ — and +-- 'sanitizeEndpoint' then recorded @null@ for a call whose destination +-- was perfectly well known. The core cannot know a vendor default, so +-- where no adapter ran @null@ remains the truthful answer and the +-- unsuffixed functions keep passing @m ^. #baseUrl@. +minimalEvidenceAt :: + -- | The resolved base URL. + Text -> + Model -> + Options -> + TransportKind -> + ThinkingTranslation -> + -- | The request envelope. Lazy, for the reason 'minimalEvidence' + -- documents at length. + Aeson.Value -> + UTCTime -> + UTCTime -> + CallStatus -> + Maybe BaikaiError -> + IO (Maybe ModelCallEvidence) +minimalEvidenceAt baseUrl m opts transport translation envelope started ended st err = do + mk <- prepareEvidenceAt baseUrl m opts transport translation envelope started pure (fmap (\finish -> finish ended st err) mk) -- | 'minimalEvidence' for a transport that learns its terminal @@ -154,12 +192,30 @@ -- | Started at. UTCTime -> IO (Maybe (UTCTime -> CallStatus -> Maybe BaikaiError -> ModelCallEvidence)) -prepareEvidence m opts transport translation envelope started = +prepareEvidence m opts = + prepareEvidenceAt (m ^. #baseUrl) m opts + +-- | 'prepareEvidence' against the base URL the adapter actually +-- resolved. See 'minimalEvidenceAt'. +prepareEvidenceAt :: + -- | The resolved base URL. + Text -> + Model -> + Options -> + TransportKind -> + ThinkingTranslation -> + -- | The request envelope. Lazy, for the reason 'minimalEvidence' + -- documents at length. + Aeson.Value -> + -- | Started at. + UTCTime -> + IO (Maybe (UTCTime -> CallStatus -> Maybe BaikaiError -> ModelCallEvidence)) +prepareEvidenceAt baseUrl m opts transport translation envelope started = case opts ^. #evidence of Nothing -> pure Nothing Just req -> do cid <- newCallId - let ep = endpointIdentity m transport + let ep = endpointIdentityAt baseUrl m transport commitment = commitmentDigest envelope configuration = configurationDigest envelope pure $ @@ -179,6 +235,40 @@ { errorInfo = err } +-- | The strictness a call was dispatched under. A call with no +-- evidence request is best-effort. +strictnessOf :: Options -> EvidenceStrictness +strictnessOf opts = + maybe EvidenceBestEffort (^. #strictness) (opts ^. #evidence) + +-- | The error a strict call fails with when its provider produced a +-- successful terminal and attached no evidence record to it. +-- +-- Built with 'providerError' for the reason 'sinkFailureError' is: +-- nothing about the request was invalid and the provider did its job, +-- and 'Baikai.Error.ErrorCategory' is closed. The message prefix is the +-- contract until the surface freeze decides on a category. +missingEvidenceError :: BaikaiError +missingEvidenceError = + providerError + "this call required evidence, but the provider attached no evidence record to its \ + \terminal event; the response is reported failed rather than left unaccounted for" + +-- | The translation to record where no provider adapter ran: an +-- unregistered provider, and a @complete@ handler that threw before +-- returning. +-- +-- It carries the caller's level and says @not_translated@, so the +-- record states the request without claiming a wire shape that was +-- never built. Where an adapter /did/ run — the consumer-abort path in +-- "Baikai.Trace", and each adapter's own @immediateError@ — call that +-- adapter's @describeThinking@ instead; re-deriving a description in +-- the core is what +-- @docs\/adr\/0003-the-adapter-owns-the-translation-description.md@ +-- forbids. +requestedTranslation :: Options -> ThinkingTranslation +requestedTranslation opts = untranslatedThinking (opts ^. #thinking) + -- | Where a call went, without recording a credential. -- -- 'implementationVersion' is left 'Nothing' here. An API provider knows @@ -186,53 +276,43 @@ -- executable, but neither fact is available to the core, and inventing -- one would be worse than admitting the gap. endpointIdentity :: Model -> TransportKind -> EndpointIdentity -endpointIdentity m transport = +endpointIdentity m = endpointIdentityAt (m ^. #baseUrl) m + +-- | 'endpointIdentity' against the base URL the adapter actually +-- resolved. See 'minimalEvidenceAt'. +endpointIdentityAt :: Text -> Model -> TransportKind -> EndpointIdentity +endpointIdentityAt baseUrl m transport = EndpointIdentity { provider = m ^. #provider, api = renderApi (m ^. #api), transport = transport, - endpoint = sanitizeEndpoint (m ^. #baseUrl), + endpoint = sanitizeEndpoint baseUrl, baikaiVersion = baikaiPackageVersion, implementationVersion = Nothing } -- | Reduce a base URL to scheme, host, port, and path. -- --- The query string is dropped __wholesale__ rather than filtered field --- by field, because some gateways carry an API key in a query --- parameter and an allow-list of safe parameter names would be wrong --- the first time a host invented one. Any @userinfo@ component --- (@https:\/\/user:secret\@host\/@) is dropped for the same reason. A --- fragment cannot carry a credential to a server but is dropped too, --- since it is never part of what was requested. +-- This is "Baikai.Url" applied to the recording problem: 'Url.parseUrl' +-- never holds the userinfo, the query string or the fragment in the +-- first place, and 'Url.renderEndpoint' can only put back what it has. +-- The query string is therefore dropped __wholesale__ rather than +-- filtered field by field, which is the right behaviour rather than a +-- convenient one: some gateways carry an API key in a query parameter, +-- and an allow-list of safe parameter names would be wrong the first +-- time a host invented one. Userinfo +-- (@https:\/\/user:secret\@host\/@) goes for the same reason; a +-- fragment cannot carry a credential to a server but is never part of +-- what was requested either. -- +-- The scheme and host come back lower-cased, because that is what +-- "Baikai.Url" says a host is; the path is kept verbatim. +-- -- An empty base URL yields 'Nothing' rather than an empty string, so a -- reader can tell "baikai recorded no endpoint" from "the endpoint was -- the empty string". sanitizeEndpoint :: Text -> Maybe Text -sanitizeEndpoint raw - | Text.null trimmed = Nothing - | Text.null cleaned = Nothing - | otherwise = Just cleaned - where - trimmed = Text.strip raw - withoutFragment = Text.takeWhile (/= '#') trimmed - withoutQuery = Text.takeWhile (/= '?') withoutFragment - cleaned = dropUserInfo withoutQuery - --- | Drop a @user:password\@@ prefix from the authority component, --- keeping the scheme. Splits on the last @\@@ before the first @\/@ of --- the path so that an @\@@ later in the path is not mistaken for --- userinfo. -dropUserInfo :: Text -> Text -dropUserInfo url = - let (scheme, rest) = case Text.breakOn "://" url of - (s, r) | not (Text.null r) -> (s <> "://", Text.drop 3 r) - _ -> ("", url) - (authority, path) = Text.break (== '/') rest - in case Text.breakOnEnd "@" authority of - (before, after) | not (Text.null before) -> scheme <> after <> path - _ -> scheme <> authority <> path +sanitizeEndpoint = fmap Url.renderEndpoint . Url.parseUrl -- | The request envelope for the paths where __no provider adapter ran -- to completion__, and therefore no wire request body exists for this @@ -305,10 +385,13 @@ "the reasoning-effort request would not reach the provider as asked: " <> Text.intercalate "; " (map describeAdjustment adjustments) --- | One downgrade, in words. These are the six places baikai weakens a +-- | One adjustment, in words. Six of these are places baikai weakens a -- thinking request, and the whole point of strict mode is that a caller -- can refuse each of them by name rather than discovering it in a trace --- afterwards. +-- afterwards. The two sampling entries are rendered here as well, so a +-- record printed for a human reads completely, even though +-- 'Baikai.Evidence.weakensThinking' keeps them out of the refusal +-- list. describeAdjustment :: ThinkingAdjustment -> Text describeAdjustment = \case EffortClamped lvl wire -> @@ -332,6 +415,12 @@ <> Text.pack (show budget) <> "-token budget does not fit inside the resolved output ceiling of " <> Text.pack (show maxOut) + SamplingDroppedUnsupportedModel fields -> + Text.intercalate ", " fields + <> " would be dropped, because this model generation rejects sampling parameters" + SamplingDroppedUnsupportedApi fields -> + Text.intercalate ", " fields + <> " would be dropped, because this API has no such field on any generation" -- | The pre-dispatch gate: every reason this call must not proceed, or -- an empty list when it may. @@ -355,22 +444,37 @@ -- The downgrade rule needs one judgement stated, because it is not -- obvious. A caller who requested no level at all is never downgraded — -- there is nothing to weaken, and 'Baikai.Evidence.noThinkingRequested' --- carries no adjustments, so this falls out. But /every/ non-empty --- adjustment list refuses, including +-- carries no adjustments, so this falls out. But every adjustment that +-- weakens the thinking request refuses, including -- 'Baikai.Evidence.EffortOmitted', which is the subtlest: that request -- is not weaker in effect, it is merely indistinguishable on the wire -- from the provider's default. A caller who demanded strict evidence and -- receives a request they cannot later prove asked for @high@ has not -- got what they demanded. +-- +-- The adjustment list is filtered through +-- 'Baikai.Evidence.weakensThinking' rather than tested for emptiness, +-- because it also carries the sampling drops. The documented contract is +-- refusing a call that would /weaken the requested thinking level/; a +-- caller who set @seed@ on a Claude model, where the API has no such +-- field on any generation, must not have every strict call refused over +-- it. The drop is still in the record, where they can see it. checkEvidenceRequirements :: - EvidenceStrictness -> Api -> ThinkingTranslation -> [EvidenceRefusal] + EvidenceStrictness -> + -- | The provider's own ceiling + -- ('Baikai.Provider.Registry.strengthCeiling'), not a value looked up + -- by 'Baikai.Api.Api': only the provider knows what its evidence can + -- reach, and a tag-keyed table capped every caller-supplied transport + -- at 'EvidenceRequestedOnly'. + EvidenceStrength -> + ThinkingTranslation -> + [EvidenceRefusal] checkEvidenceRequirements EvidenceBestEffort _ _ = [] -checkEvidenceRequirements (EvidenceRequired needed) api translation = +checkEvidenceRequirements (EvidenceRequired needed) declared translation = [StrengthUnreachable needed declared | declared < needed] <> [ThinkingWouldDowngrade downgrades | not (null downgrades)] where - declared = declaredStrength api - downgrades = adjustments translation + downgrades = filter weakensThinking (adjustments translation) -- | Turn a non-empty refusal list into the error the call fails with. -- @@ -425,10 +529,18 @@ -- did its job. It is baikai's own machinery that failed the caller, so -- it is a plain provider-side error naming the sink and carrying the -- sink's own message. +-- +-- "Not confirmed written" rather than "not written": this covers a +-- sink that threw, whose record certainly was not written, and a sink +-- that stalled past "Baikai.Trace"'s drain bound, whose worker was +-- abandoned with the events still queued and may yet deliver them. What +-- the strict caller is told in both cases is the same and is the honest +-- claim — the call returned without the record's delivery being +-- confirmed. sinkFailureError :: SomeException -> BaikaiError sinkFailureError e = providerError ( "the trace sink failed and this call required evidence, so its record was \ - \not written: " + \not confirmed written: " <> Text.pack (displayException e) ) diff --git a/src/Baikai/Header.hs b/src/Baikai/Header.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Header.hs @@ -0,0 +1,77 @@ +-- | HTTP header names as a type that carries the case-insensitivity +-- rule. +-- +-- A header name is case-insensitive on the wire, so @Authorization@ and +-- @authorization@ are one header. A @Map Text Text@ of header overrides +-- does not know that: it holds both, and which one reaches the provider +-- is decided by the fold order of whatever code assembles the request. +-- 'HeaderName' puts the rule in the key type, so a @Map HeaderName Text@ +-- holds at most one value per header and the last write wins, as a +-- caller writing two spellings would expect. +-- +-- The original spelling is preserved and is what goes out on the wire +-- and into JSON, so a host that (wrongly) cares about case still sees +-- what the caller wrote. +-- +-- The type is baikai's own rather than a bare +-- 'Data.CaseInsensitive.CI' 'Data.Text.Text' because the aeson +-- instances would then be orphans, which two packages can define +-- incompatibly. +module Baikai.Header + ( HeaderName, + headerName, + renderHeaderName, + ) +where + +import Data.Aeson + ( FromJSON (parseJSON), + FromJSONKey (fromJSONKey), + FromJSONKeyFunction (FromJSONKeyText), + ToJSON (toJSON), + ToJSONKey (toJSONKey), + withText, + ) +import Data.Aeson.Types (toJSONKeyText) +import Data.CaseInsensitive (CI) +import Data.CaseInsensitive qualified as CI +import Data.String (IsString (fromString)) +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics (Generic) + +-- | A case-insensitive HTTP header name that remembers its original +-- spelling. +newtype HeaderName = HeaderName (CI Text) + deriving stock (Eq, Ord, Generic) + +-- | Shows the original spelling, so a header map prints as it was +-- written. +instance Show HeaderName where + showsPrec d = showsPrec d . renderHeaderName + +-- | So that @Map.singleton "x-test" "1" :: Map HeaderName Text@ keeps +-- compiling and reading naturally. +instance IsString HeaderName where + fromString = headerName . Text.pack + +instance ToJSON HeaderName where + toJSON = toJSON . renderHeaderName + +instance FromJSON HeaderName where + parseJSON = withText "HeaderName" (pure . headerName) + +instance ToJSONKey HeaderName where + toJSONKey = toJSONKeyText renderHeaderName + +instance FromJSONKey HeaderName where + fromJSONKey = FromJSONKeyText headerName + +-- | A header name from its text. Comparison ignores case from here on; +-- the spelling given is what 'renderHeaderName' returns. +headerName :: Text -> HeaderName +headerName = HeaderName . CI.mk + +-- | The name as it was originally written. +renderHeaderName :: HeaderName -> Text +renderHeaderName (HeaderName n) = CI.original n diff --git a/src/Baikai/Http.hs b/src/Baikai/Http.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Http.hs @@ -0,0 +1,135 @@ +-- | The one HTTP client cache, and the one place a base URL becomes +-- something baikai will actually connect to. +-- +-- Building a @ClientEnv@ — @servant-client@'s pairing of a parsed base +-- URL with an @http-client@ 'HTTP.Manager', which owns the connection +-- pool and the TLS state — costs a TLS manager setup, so baikai keeps +-- one per base URL for the life of the process. That cache used to be +-- duplicated in each provider package and keyed on the raw base-URL +-- text, which meant @https:\/\/h@ and @https:\/\/h\/@ were two managers +-- and two connection pools to one host, and that the three copies could +-- disagree about what "the same host" means. There is one cache here +-- now, and its key is the canonical rendering of "Baikai.Url"'s parse. +-- +-- The cache is unbounded on purpose. The set of distinct base URLs a +-- process talks to is configuration-sized rather than request-sized; +-- normalisation removes the one unbounded source (textual variants of a +-- single host); and how long a connection lives is already the +-- 'HTTP.Manager''s idle timeout. A fleet of per-tenant base URLs is not +-- a supported use of @Model.baseUrl@. +module Baikai.Http + ( canonicalBaseUrl, + getClientEnvCached, + cachedClientEnvCount, + ) +where + +import Baikai.Error (invalidRequest) +import Baikai.Url qualified as Url +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar) +import Control.Exception (throwIO) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Client.TLS qualified as TLS +import Servant.Client qualified as Client +import System.IO.Unsafe (unsafePerformIO) + +-- | Parse a base URL into the @servant-client@ 'Client.BaseUrl' baikai +-- will send to, normalised so that every spelling of one target is one +-- value: the host lower-cased by 'Url.parseUrl', the port made explicit +-- from the scheme's default when none was given, trailing slashes +-- removed from the path, and one trailing @\/v1@ segment removed. +-- +-- That last rule is the base-URL convention: @Model.baseUrl@ is the API +-- __root__ — the host, or the prefix a host mounts the API under — +-- without the version segment, because baikai appends +-- @\/v1\/chat\/completions@, @\/v1\/messages@ or @\/v1\/embeddings@ +-- itself. A @\/v1@ suffix is nevertheless accepted and removed rather +-- than refused, because @https:\/\/api.deepseek.com\/v1@ is what every +-- OpenAI SDK teaches and refusing it would break a working configuration +-- for no security gain. Without the rule that base URL composed to +-- @\/v1\/v1\/chat\/completions@. +-- +-- Built from 'Url.parseUrl' directly rather than by handing the raw text +-- to @servant-client@'s own @parseBaseUrl@, so that the host baikai +-- resolves a key for and the host it opens a connection to are decided +-- by the same function. (@parseBaseUrl@ also silently prepends +-- @http:\/\/@ to a scheme-less URL, which would send a bearer token in +-- plaintext, and rejects userinfo and query strings with an exception +-- that says nothing useful.) +-- +-- 'Left' carries a reason fit to show a caller. +canonicalBaseUrl :: Text -> Either Text Client.BaseUrl +canonicalBaseUrl raw = case Url.parseUrl raw of + Nothing -> Left "no host could be found in it" + Just parts -> case Url.scheme parts of + Nothing -> + Left + ( Url.renderEndpoint parts + <> " has no scheme; start it with https:// or http://" + ) + Just s + | s /= "http", + s /= "https" -> + Left + ( Url.renderEndpoint parts + <> " uses the scheme " + <> s + <> "; only http and https are sent" + ) + | otherwise -> + let secure = s == "https" + in Right + Client.BaseUrl + { Client.baseUrlScheme = if secure then Client.Https else Client.Http, + Client.baseUrlHost = Text.unpack (Url.host parts), + Client.baseUrlPort = + maybe (if secure then 443 else 80) id (Url.port parts), + Client.baseUrlPath = + Text.unpack (Url.stripApiVersion (Url.path parts)) + } + +-- | The cached 'Client.ClientEnv' for a base URL, building one on first +-- use. Two spellings of one target share an entry, because the key is +-- 'canonicalBaseUrl''s rendering rather than the caller's text. +-- +-- Throws a 'Baikai.Error.BaikaiError' in the +-- 'Baikai.Error.InvalidRequest' category when the base URL is not one +-- baikai can send to. +getClientEnvCached :: Text -> IO Client.ClientEnv +getClientEnvCached raw = case canonicalBaseUrl raw of + Left problem -> + throwIO (invalidRequest ("Model.baseUrl is not usable: " <> problem)) + Right base -> do + let key = Text.pack (Client.showBaseUrl base) + modifyMVar clientEnvCache $ \cache -> + case Map.lookup key cache of + Just env -> pure (cache, env) + Nothing -> do + env <- newClientEnv base + pure (Map.insert key env cache, env) + +-- | How many distinct targets the cache holds. Exposed so a test can +-- observe that two spellings of one host are one entry. +cachedClientEnvCount :: IO Int +cachedClientEnvCount = + modifyMVar clientEnvCache $ \cache -> pure (cache, Map.size cache) + +-- | A fresh manager with no per-response timeout: a streaming response +-- is open for as long as the model is thinking, and @Options.timeoutMs@ +-- bounds the whole call from outside. +newClientEnv :: Client.BaseUrl -> IO Client.ClientEnv +newClientEnv base = do + manager <- + TLS.newTlsManagerWith + TLS.tlsManagerSettings + { HTTP.managerResponseTimeout = HTTP.responseTimeoutNone + } + pure (Client.mkClientEnv manager base) + +{-# NOINLINE clientEnvCache #-} +clientEnvCache :: MVar (Map Text Client.ClientEnv) +clientEnvCache = unsafePerformIO (newMVar Map.empty) diff --git a/src/Baikai/Interactive.hs b/src/Baikai/Interactive.hs --- a/src/Baikai/Interactive.hs +++ b/src/Baikai/Interactive.hs @@ -22,8 +22,6 @@ InteractiveLaunchResult (..), interactiveLaunchRequest, interactiveLaunchResult, - _InteractiveLaunchRequest, - _InteractiveLaunchResult, renderInteractiveProvider, renderInteractiveScope, renderCodexSandboxMode, @@ -78,11 +76,26 @@ | CodexDangerFullAccess deriving stock (Eq, Ord, Show, Generic) +-- | When Codex asks a human before running a command. +-- +-- The first two are spellings older Codex generations accepted and +-- current ones reject. They are kept so the type stays stable for a +-- caller that matches on it, and the Codex launcher in @baikai-openai@ +-- refuses a request carrying one with 'Baikai.Agent.SafetyNotExpressible' +-- before starting anything, rather than letting the CLI fail with a +-- usage error after a process was created. data CodexApprovalPolicy - = CodexApprovalUntrusted - | CodexApprovalOnFailure - | CodexApprovalOnRequest - | CodexApprovalNever + = -- | Spelled @untrusted@. Rejected by current Codex releases; the + -- Codex launcher refuses a request carrying it. + CodexApprovalUntrusted + | -- | Spelled @on-failure@. Rejected by current Codex releases; the + -- Codex launcher refuses a request carrying it. + CodexApprovalOnFailure + | -- | Spelled @on-request@: the model decides when to ask. + CodexApprovalOnRequest + | -- | Spelled @never@: execution failures go straight back to the + -- model. + CodexApprovalNever deriving stock (Eq, Ord, Show, Generic) -- | Process-level outcome after the interactive CLI exits. @@ -111,14 +124,6 @@ { provider = p, exitCode = code } - -{-# DEPRECATED _InteractiveLaunchRequest "Use interactiveLaunchRequest instead." #-} -_InteractiveLaunchRequest :: Text -> InteractiveLaunchRequest -_InteractiveLaunchRequest = interactiveLaunchRequest - -{-# DEPRECATED _InteractiveLaunchResult "Use interactiveLaunchResult instead." #-} -_InteractiveLaunchResult :: InteractiveProvider -> ExitCode -> InteractiveLaunchResult -_InteractiveLaunchResult = interactiveLaunchResult renderInteractiveProvider :: InteractiveProvider -> Text renderInteractiveProvider InteractiveClaude = "claude" diff --git a/src/Baikai/Message.hs b/src/Baikai/Message.hs --- a/src/Baikai/Message.hs +++ b/src/Baikai/Message.hs @@ -15,9 +15,10 @@ -- answers, the tool's name, the result 'content' (text or image), an -- 'isError' flag, and an optional timestamp). -- --- The 'system' constructor from prior versions is removed: system --- prompts live on 'Baikai.Request.Request.systemPrompt'. The 'Role' --- enum is also removed — pattern-match on the constructor instead. +-- There is no 'system' constructor: a system prompt lives on +-- 'Baikai.Context.Context.systemPrompt', not in the message vector. +-- There is no 'Role' enum either — pattern-match on the constructor +-- instead. -- -- Each constructor wraps a dedicated single-constructor payload record -- ('UserPayload', 'AssistantPayload', 'ToolResultPayload') rather than diff --git a/src/Baikai/Model.hs b/src/Baikai/Model.hs --- a/src/Baikai/Model.hs +++ b/src/Baikai/Model.hs @@ -3,12 +3,13 @@ -- front to talk to a provider: the 'Api' tag (used to look up the -- registered handler), the provider name, the base URL, the -- per-million-token pricing rates, the context window and max output --- cap, default per-call headers, and a per-API 'Compat' record (a --- placeholder until EP-5 populates the real shims). +-- cap, default per-call headers, and a per-API 'Compat' record +-- ('CompatNone' lets the provider auto-detect the record from the base +-- URL; see "Baikai.Compat"). -- --- The previous newtype @Model = Model Text@ — a thin tag for the --- model id — is retired. Use 'modelId' to read the selected upstream --- model identifier, or 'mkModel' to build a dispatchable record. +-- Use 'modelId' to read the selected upstream model identifier, or +-- 'mkModel' to build a dispatchable record from the three +-- discriminators. module Baikai.Model ( -- * Model Model, @@ -25,13 +26,11 @@ headers, compat, emptyModel, - _Model, mkModel, -- * Cost rates ModelCost (..), zeroModelCost, - _ModelCost, -- * Capabilities InputModality (..), @@ -44,23 +43,29 @@ where import Baikai.Api (Api (..), renderApi) +import Baikai.Auth qualified as Auth import Baikai.Compat - ( AnthropicMessagesCompat (..), + ( AnthropicMessagesCompat, OpenAICompletionsCompat, autoDetectAnthropicMessages, autoDetectOpenAICompletions, - defaultAnthropicThinkingStyle, ) -import Data.Aeson (FromJSON, ToJSON) +import Baikai.Header (HeaderName) +import Data.Aeson + ( FromJSON, + ToJSON (toEncoding, toJSON), + defaultOptions, + genericToEncoding, + genericToJSON, + ) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) --- | What kinds of input a model accepts. EP-1 introduced the typed --- content blocks; this field documents which of them the chosen --- 'Model' is allowed to consume. +-- | What kinds of input a model accepts: which typed content blocks +-- ("Baikai.Content") the chosen 'Model' may be given. data InputModality = InputText | InputImage @@ -102,13 +107,21 @@ -- the explicit one if 'compat' is 'CompatAnthropicMessages', -- otherwise the result of inspecting 'baseUrl' via -- 'autoDetectAnthropicMessages'. +-- +-- An explicit record always wins. 'CompatNone' means host +-- auto-detection alone: the budget thinking style and sampling +-- parameters supported, which is what every generation before Opus 4.7 +-- and every known compatible host accepts. The model id is never +-- consulted, because a generation's wire quirks are a fact of the +-- catalog record, not of its id — every Anthropic model in +-- "Baikai.Models.Generated" carries an explicit +-- 'CompatAnthropicMessages'. A hand-rolled model naming an +-- adaptive-era id must set its own record or start from the catalog +-- value. anthropicMessagesCompatFor :: Model -> AnthropicMessagesCompat anthropicMessagesCompatFor m = case compat m of CompatAnthropicMessages c -> c - _ -> - (autoDetectAnthropicMessages (baseUrl m)) - { thinkingStyle = defaultAnthropicThinkingStyle (modelId m) - } + _ -> autoDetectAnthropicMessages (baseUrl m) -- | The data record baikai dispatches on. data Model = Model @@ -121,13 +134,73 @@ input :: ![InputModality], cost :: !ModelCost, contextWindow :: !Natural, + -- | The provider's cap on output tokens for this model, or @0@ + -- when it is unknown (a hand-rolled model built from + -- 'emptyModel', or a catalog entry upstream published no limit + -- for). @0@ is not a request for zero output: the OpenAI adapter + -- omits the cap entirely, and the Anthropic adapter — whose API + -- requires the field and rejects @0@ — sends + -- @Baikai.Provider.Claude.Internal.Request.uncappedMaxTokensFloor@ + -- instead. An explicit 'Baikai.Options.maxTokens' always wins, + -- including an explicit @Just 0@. maxOutputTokens :: !Natural, - headers :: !(Map Text Text), + headers :: !(Map HeaderName Text), compat :: !Compat } - deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving stock (Eq, Generic) + deriving anyclass (FromJSON) +-- | Rendered field by field rather than derived, so that the value of a +-- credential-carrying header prints as 'Auth.redactedMarker'. A 'Model' +-- is the record most likely to reach a log: it is embedded in every +-- 'Baikai.Response.Response', and the guides tell people to @print@ +-- one. +-- +-- The format is exactly what @deriving stock Show@ produces — the same +-- record syntax, field order and precedence — because the point is to +-- redact one value, not to invent a rendering. A test in +-- @baikai\/test\/Main.hs@ walks the 'Generic' representation and asserts +-- that every field name appears here, so a field added later cannot +-- silently vanish from 'show'. +-- +-- 'Eq' is untouched, and so is 'FromJSON': the field itself still holds +-- what the caller put there and the header is still sent. The one lossy +-- path is a JSON round trip — 'toJSON' writes the marker, so decoding +-- the result gives a 'Model' whose credential header /is/ the marker. +-- That is deliberate; a serialised 'Model' is exactly the thing that +-- should not carry a key. +instance Show Model where + showsPrec d m = + showParen (d >= 11) $ + showString "Model {" + . field "modelId" (modelId m) + . next "name" (name m) + . next "api" (api m) + . next "provider" (provider m) + . next "baseUrl" (baseUrl m) + . next "reasoning" (reasoning m) + . next "input" (input m) + . next "cost" (cost m) + . next "contextWindow" (contextWindow m) + . next "maxOutputTokens" (maxOutputTokens m) + . next "headers" (Auth.redactHeaderValues (headers m)) + . next "compat" (compat m) + . showChar '}' + where + field label v = showString label . showString " = " . showsPrec 0 v + next label v = showString ", " . field label v + +-- | Encoded through the 'Generic' representation of a copy whose +-- credential headers have been replaced, so the output is byte-identical +-- to the derived instance's for every model that carries none, and there +-- is no recursion back into this instance. +instance ToJSON Model where + toJSON = genericToJSON defaultOptions . redactModel + toEncoding = genericToEncoding defaultOptions . redactModel + +redactModel :: Model -> Model +redactModel m = m {headers = Auth.redactHeaderValues (headers m)} + -- | A zero 'ModelCost' across all rates. Useful as a default for -- models without published pricing (CLI providers, custom hosts). zeroModelCost :: ModelCost @@ -141,6 +214,11 @@ -- | A blank 'Model'. Useful as a record-update base for hand-rolled -- 'Model' values in tests and one-shot scripts. +-- +-- Its @api@ is @Custom ""@, which no handler can be registered under +-- meaningfully: dispatching a model that still carries it fails with +-- @No provider registered for API: \@. Set @api@ +-- (and @modelId@) before calling anything. emptyModel :: Model emptyModel = Model @@ -171,11 +249,3 @@ provider = renderApi apiTag, baseUrl = baseUrl_ } - -{-# DEPRECATED _ModelCost "Use zeroModelCost instead." #-} -_ModelCost :: ModelCost -_ModelCost = zeroModelCost - -{-# DEPRECATED _Model "Use emptyModel instead." #-} -_Model :: Model -_Model = emptyModel diff --git a/src/Baikai/Models/Generated.hs b/src/Baikai/Models/Generated.hs --- a/src/Baikai/Models/Generated.hs +++ b/src/Baikai/Models/Generated.hs @@ -8,9 +8,25 @@ import Baikai.Api (Api (..)) import Baikai.Compat - ( AnthropicThinkingStyle (..), + ( AnthropicMessagesCompat + ( sendSessionAffinityHeaders, + supportsCacheControlOnTools, + supportsLongCacheRetention, + supportsSamplingParameters, + thinkingStyle + ), + AnthropicThinkingStyle (..), CacheControlFormat (..), MaxTokensField (..), + OpenAICompletionsCompat + ( cacheControlFormat, + maxTokensField, + requiresThinkingAsText, + supportsLongCacheRetention, + supportsStrictMode, + supportsUsageInStreaming, + thinkingFormat + ), ThinkingFormat (..), defaultAnthropicMessagesCompat, defaultOpenAICompletionsCompat, @@ -57,7 +73,15 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } } anthropic_claude_haiku_4_5 :: Model @@ -80,7 +104,15 @@ contextWindow = 200000, maxOutputTokens = 64000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingBudget, + supportsSamplingParameters = True + } } anthropic_claude_opus_4_5 :: Model @@ -103,7 +135,15 @@ contextWindow = 200000, maxOutputTokens = 64000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingBudget, + supportsSamplingParameters = True + } } anthropic_claude_opus_4_6 :: Model @@ -126,7 +166,15 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = True + } } anthropic_claude_opus_4_7 :: Model @@ -149,7 +197,15 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } } anthropic_claude_opus_4_8 :: Model @@ -172,9 +228,48 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } } +anthropic_claude_opus_5 :: Model +anthropic_claude_opus_5 = + emptyModel + { modelId = "claude-opus-5", + name = "Claude Opus 5", + api = AnthropicMessages, + provider = "anthropic", + baseUrl = "https://api.anthropic.com", + reasoning = True, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 5 % 1, + outputCost = 25 % 1, + cacheReadCost = 1 % 2, + cacheWriteCost = 25 % 4 + }, + contextWindow = 1000000, + maxOutputTokens = 128000, + headers = Map.empty, + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } + } + anthropic_claude_sonnet_4_5 :: Model anthropic_claude_sonnet_4_5 = emptyModel @@ -195,7 +290,15 @@ contextWindow = 1000000, maxOutputTokens = 64000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingBudget, + supportsSamplingParameters = True + } } anthropic_claude_sonnet_4_6 :: Model @@ -218,7 +321,15 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = True + } } anthropic_claude_sonnet_5 :: Model @@ -241,7 +352,15 @@ contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, - compat = CompatNone + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } } deepseek_deepseek_chat :: Model @@ -578,10 +697,10 @@ input = [InputText, InputImage], cost = ModelCost - { inputCost = 5 % 1, - outputCost = 30 % 1, - cacheReadCost = 1 % 2, - cacheWriteCost = 25 % 4 + { inputCost = 4 % 1, + outputCost = 20 % 1, + cacheReadCost = 2 % 5, + cacheWriteCost = 5 % 1 }, contextWindow = 1050000, maxOutputTokens = 128000, @@ -601,10 +720,10 @@ input = [InputText, InputImage], cost = ModelCost - { inputCost = 1 % 1, - outputCost = 6 % 1, - cacheReadCost = 1 % 10, - cacheWriteCost = 5 % 4 + { inputCost = 1 % 5, + outputCost = 6 % 5, + cacheReadCost = 1 % 50, + cacheWriteCost = 1 % 4 }, contextWindow = 1050000, maxOutputTokens = 128000, @@ -624,10 +743,10 @@ input = [InputText, InputImage], cost = ModelCost - { inputCost = 5 % 1, - outputCost = 30 % 1, - cacheReadCost = 1 % 2, - cacheWriteCost = 25 % 4 + { inputCost = 4 % 1, + outputCost = 20 % 1, + cacheReadCost = 2 % 5, + cacheWriteCost = 5 % 1 }, contextWindow = 1050000, maxOutputTokens = 128000, @@ -647,10 +766,10 @@ input = [InputText, InputImage], cost = ModelCost - { inputCost = 5 % 2, - outputCost = 15 % 1, - cacheReadCost = 1 % 4, - cacheWriteCost = 25 % 8 + { inputCost = 2 % 1, + outputCost = 12 % 1, + cacheReadCost = 1 % 5, + cacheWriteCost = 5 % 2 }, contextWindow = 1050000, maxOutputTokens = 128000, @@ -851,6 +970,7 @@ anthropic_claude_opus_4_6, anthropic_claude_opus_4_7, anthropic_claude_opus_4_8, + anthropic_claude_opus_5, anthropic_claude_sonnet_4_5, anthropic_claude_sonnet_4_6, anthropic_claude_sonnet_5, diff --git a/src/Baikai/Options.hs b/src/Baikai/Options.hs --- a/src/Baikai/Options.hs +++ b/src/Baikai/Options.hs @@ -19,19 +19,24 @@ -- in the OpenAI and Claude providers: connection setup, response -- headers, and full stream drain. On expiry the stream terminates -- in-band with a retryable transient 'Baikai.Error.BaikaiError'. +-- @Just n@ with @n <= 0@ is refused as +-- 'Baikai.Error.InvalidRequest' before any connection is opened; +-- 'Nothing' is the only spelling of \"no bound\". -- -- 'headers' are per-call HTTP header overrides for API providers. -- Provider defaults are built first, then 'Baikai.Model.headers', -- then this field; later values replace earlier ones by -- case-insensitive header name, including auth headers for callers --- intentionally fronting a gateway. +-- intentionally fronting a gateway. Because that is an invitation to +-- put a credential here, the 'Show' and 'ToJSON' instances below print +-- 'Baikai.Auth.redactedMarker' in place of the value of any header +-- whose name looks credential-carrying. The field itself is untouched +-- and the header is still sent exactly as written. -- --- EP-4 added @toolChoice@. EP-5 adds @cacheRetention@ and @thinking@ --- (provider-agnostic preferences that each provider maps to its own --- primitive — see 'Baikai.CacheRetention' and 'Baikai.ThinkingLevel' --- for the mappings). EP-2 (shikumi) adds @responseFormat@, the --- provider-agnostic structured-output preference — see --- 'Baikai.ResponseFormat'. +-- @cacheRetention@, @thinking@ and @responseFormat@ are +-- provider-agnostic preferences that each provider maps onto its own +-- primitive — see 'Baikai.CacheRetention', 'Baikai.ThinkingLevel' and +-- 'Baikai.ResponseFormat' for the mappings. -- -- 'evidence' is the per-call request for verifiable model-call -- evidence — see 'Baikai.Evidence.EvidenceRequest'. It carries the @@ -59,21 +64,27 @@ frequencyPenalty, presencePenalty, emptyOptions, - _Options, ) where import Baikai.Auth (ApiKeySource) +import Baikai.Auth qualified as Auth import Baikai.CacheRetention (CacheRetention) import Baikai.Evidence (EvidenceRequest) +import Baikai.Header (HeaderName) import Baikai.ResponseFormat (ResponseFormat) import Baikai.ThinkingLevel (ThinkingLevel) import Baikai.Tool (ToolChoice) -import Data.Aeson (ToJSON, Value) +import Data.Aeson + ( ToJSON (toEncoding, toJSON), + Value, + defaultOptions, + genericToEncoding, + genericToJSON, + ) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) -import Data.Vector (Vector) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -82,22 +93,81 @@ temperature :: !(Maybe Double), apiKey :: !(Maybe ApiKeySource), timeoutMs :: !(Maybe Int), - headers :: !(Map Text Text), + headers :: !(Map HeaderName Text), metadata :: !(Map Text Value), + -- | 'Nothing' and @Just 'ToolChoiceAuto'@ are the same request: both + -- send no @tool_choice@ and let the provider apply its own default, + -- which is @auto@ at Anthropic and OpenAI. The constructor is kept + -- for a caller who wants to say "auto" explicitly. toolChoice :: !(Maybe ToolChoice), + -- | 'Nothing' and @Just 'CacheRetentionNone'@ are the same request: + -- both send no cache-control marker. The constructor is kept for a + -- caller who wants to say "no caching" explicitly. cacheRetention :: !(Maybe CacheRetention), thinking :: !(Maybe ThinkingLevel), responseFormat :: !(Maybe ResponseFormat), evidence :: !(Maybe EvidenceRequest), topP :: !(Maybe Double), - stopSequences :: !(Maybe (Vector Text)), - seed :: !(Maybe Integer), + -- | Sequences that stop generation. Empty means "send nothing" — + -- one representation, where @Nothing@ and @Just []@ used to be two + -- indistinguishable ones. + stopSequences :: ![Text], + -- | A machine integer, like 'timeoutMs': every provider that accepts + -- a seed accepts one. + seed :: !(Maybe Int), frequencyPenalty :: !(Maybe Double), presencePenalty :: !(Maybe Double) } - deriving stock (Eq, Show, Generic) - deriving anyclass (ToJSON) + deriving stock (Eq, Generic) +-- | Rendered field by field rather than derived, so that the value of a +-- credential-carrying header prints as 'Auth.redactedMarker'. +-- +-- The format is exactly what @deriving stock Show@ produces — the same +-- record syntax, the same field order, the same @showsPrec@ precedence +-- — because the point is to redact one value, not to invent a new +-- rendering. A test in @baikai\/test\/Main.hs@ walks the 'Generic' +-- representation and asserts that every field name appears here, so a +-- field added later cannot silently vanish from 'show'. +-- +-- 'Eq' is untouched: two 'Options' whose credential headers differ are +-- still unequal. +instance Show Options where + showsPrec d o = + showParen (d >= 11) $ + showString "Options {" + . field "maxTokens" (maxTokens o) + . next "temperature" (temperature o) + . next "apiKey" (apiKey o) + . next "timeoutMs" (timeoutMs o) + . next "headers" (Auth.redactHeaderValues (headers o)) + . next "metadata" (metadata o) + . next "toolChoice" (toolChoice o) + . next "cacheRetention" (cacheRetention o) + . next "thinking" (thinking o) + . next "responseFormat" (responseFormat o) + . next "evidence" (evidence o) + . next "topP" (topP o) + . next "stopSequences" (stopSequences o) + . next "seed" (seed o) + . next "frequencyPenalty" (frequencyPenalty o) + . next "presencePenalty" (presencePenalty o) + . showChar '}' + where + field name v = showString name . showString " = " . showsPrec 0 v + next name v = showString ", " . field name v + +-- | Encoded through the 'Generic' representation of a copy whose +-- credential headers have been replaced, so the output is byte-identical +-- to the derived instance's for every record that carries none, and +-- there is no recursion back into this instance. +instance ToJSON Options where + toJSON = genericToJSON defaultOptions . redactOptions + toEncoding = genericToEncoding defaultOptions . redactOptions + +redactOptions :: Options -> Options +redactOptions o = o {headers = Auth.redactHeaderValues (headers o)} + emptyOptions :: Options emptyOptions = Options @@ -113,12 +183,8 @@ responseFormat = Nothing, evidence = Nothing, topP = Nothing, - stopSequences = Nothing, + stopSequences = [], seed = Nothing, frequencyPenalty = Nothing, presencePenalty = Nothing } - -{-# DEPRECATED _Options "Use emptyOptions instead." #-} -_Options :: Options -_Options = emptyOptions diff --git a/src/Baikai/Provider.hs b/src/Baikai/Provider.hs --- a/src/Baikai/Provider.hs +++ b/src/Baikai/Provider.hs @@ -10,7 +10,9 @@ -- @import Baikai.Provider@ habit still resolves the symbols a -- caller cares about. module Baikai.Provider - ( ApiProvider (..), + ( ApiProvider (apiTag, stream, complete, describeThinking, strengthCeiling), + apiProvider, + apiProviderWith, ProviderRegistry, newProviderRegistry, newProviderRegistryFrom, @@ -28,9 +30,14 @@ ) where +import Baikai.Api (Api) +import Baikai.Context (Context) +import Baikai.Model (Model) +import Baikai.Options (Options) import Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, + apiProviderWith, assertRegistered, completeRequest, completeRequestWith, @@ -45,3 +52,23 @@ runToolLoop, runToolLoopWith, ) +import Baikai.Stream (streamingComplete) +import Baikai.Stream.Event (AssistantMessageEvent) +import Streamly.Data.Stream (Stream) + +-- | Build an 'ApiProvider' from an 'Baikai.Api.Api' tag and a streaming +-- producer, deriving the synchronous @complete@ by draining that stream +-- with 'Baikai.Stream.streamingComplete'. +-- +-- This is the documented construction path. The 'ApiProvider' +-- constructor is not exported, so a field added in a later release +-- cannot break a registration site: start here and override what you +-- need by record update. +-- +-- > apiProvider (Custom "my-api") myStream +-- > & #describeThinking .~ myDescribeThinking +apiProvider :: + Api -> + (Model -> Context -> Options -> Stream IO AssistantMessageEvent) -> + ApiProvider +apiProvider tag producer = apiProviderWith tag producer (streamingComplete producer) diff --git a/src/Baikai/Provider/Cli/Internal.hs b/src/Baikai/Provider/Cli/Internal.hs --- a/src/Baikai/Provider/Cli/Internal.hs +++ b/src/Baikai/Provider/Cli/Internal.hs @@ -42,7 +42,7 @@ import Baikai.Context (Context) import Baikai.Cost (Cost (..), zeroCost, zeroCostBreakdown) import Baikai.Error (BaikaiError, decodeError) -import Baikai.Evidence (EvidenceStrength (..), Observed (..)) +import Baikai.Evidence (EvidenceStrength (..), Observed (..), deriveStrength, usageEnvelope) import Baikai.Message ( AssistantPayload (..), Message (..), @@ -87,7 +87,6 @@ import Streamly.Data.Fold qualified as Fold import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream -import Streamly.Data.Unfold qualified as Unfold import System.Directory qualified as Directory import System.Exit (ExitCode (..)) import System.FilePath (isPathSeparator) @@ -242,16 +241,26 @@ -- A line that is not valid JSON is skipped rather than failing the run: -- codex writes progress chatter to stderr, but a future version writing -- a non-JSON line to stdout must not turn a completed model call into a --- decode error. +-- decode error. A last line with no trailing newline is still parsed. +-- +-- Lines are cut out of each chunk with 'BS.elemIndex' and 'BS.splitAt', +-- which are a scan and a constant-time slice, and the pieces of a line +-- that spans a chunk boundary are carried as a reversed list and joined +-- once, when its newline arrives. Every byte is therefore copied a +-- bounded number of times however long the line is. The obvious +-- alternative — unpacking each chunk into a stream of bytes and +-- appending them one at a time with 'BS.snoc' — copies the whole +-- accumulator per byte, which is quadratic in line length: a codex event +-- carrying a two-million-character message cost on the order of a +-- trillion byte moves and in practice never finished. parseCodexJsonlStream :: Stream IO ByteString -> IO CodexRunReport parseCodexJsonlStream chunks = do - let bytes :: Stream IO Word8 - bytes = Stream.unfoldEach Unfold.fromList (fmap BS.unpack chunks) - lineFold = Fold.takeEndBy_ (== newlineByte) (Fold.foldl' BS.snoc BS.empty) - acc <- - Stream.foldMany lineFold bytes - & Stream.mapMaybe Aeson.decodeStrict - & Stream.fold (Fold.foldl' absorbCodexEvent emptyCodexAccumulator) + (folded, pending) <- + Stream.fold (Fold.foldl' absorbChunk (emptyCodexAccumulator, [])) chunks + -- Whatever follows the last newline. An empty remainder — the ordinary + -- case, because codex terminates every line — decodes to Nothing and + -- is skipped, exactly as a non-JSON line is. + let acc = absorbLine folded (joinPieces pending) pure CodexRunReport { message = Text.concat (reverse (acc ^. #messages)), @@ -259,6 +268,15 @@ reportedModel = acc ^. #reportedModel, usage = acc ^. #usage } + where + absorbChunk (acc, pending) chunk = case BS.elemIndex newlineByte chunk of + Nothing -> (acc, chunk : pending) + Just at -> + let (piece, rest) = BS.splitAt at chunk + acc' = absorbLine acc (joinPieces (piece : pending)) + in absorbChunk (acc', []) (BS.drop 1 rest) + absorbLine acc line = maybe acc (absorbCodexEvent acc) (Aeson.decodeStrict line) + joinPieces = BS.concat . reverse -- | Fold one decoded codex event into the accumulator. -- @@ -711,7 +729,8 @@ Aeson.object [ "content" .= Vector.singleton (AssistantText (TextContent body)), "stop_reason" .= Stop, - "usage" .= used + -- Token counts only; see 'Evidence.usageEnvelope'. + "usage" .= usageEnvelope used ] -- | How much a subprocess call's evidence proves. @@ -722,6 +741,12 @@ -- provider at all — so a successful exit never raises the strength, and -- the exit status is deliberately not an argument to this function. -- Only a value the tool itself reported can raise it. +-- +-- The rule itself is 'Evidence.deriveStrength', shared with the HTTP +-- transports. A subprocess has no response header to capture, so the +-- tool's session or thread identifier is the correlation identifier it +-- passes; this keeps its argument order for the three call sites that +-- already have one. subprocessStrength :: -- | The session or thread identifier the tool reported. Observed Text -> @@ -729,7 +754,4 @@ Observed Text -> EvidenceStrength subprocessStrength sessionIdentifier reported = - case (reported, sessionIdentifier) of - (Observed _, Observed _) -> EvidenceModelObserved - (_, Observed _) -> EvidenceCorrelated - _ -> EvidenceRequestedOnly + deriveStrength reported Unobserved sessionIdentifier diff --git a/src/Baikai/Provider/Internal/StreamWorker.hs b/src/Baikai/Provider/Internal/StreamWorker.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Internal/StreamWorker.hs @@ -0,0 +1,136 @@ +-- | The hand-off between a provider's SSE worker thread and the +-- consumer draining its 'Stream'. +-- +-- __This module is internal.__ Like "Baikai.Provider.Cli.Internal" it is +-- exposed so the provider packages can share one implementation, and it +-- is outside baikai's PVP promise: its contents may change in a minor +-- release. +-- +-- A provider forks one worker per call to read frames off the socket and +-- push them here; the consumer pulls them out on the other side. Three +-- things about that hand-off are deliberate, and a reader of either +-- provider's @Api.hs@ will find the reasoning only here. +-- +-- __The queue is bounded.__ 'frameQueueCapacity' slots, and 'pushFrame' +-- blocks when they are full. A consumer that simply stops pulling — it +-- took the first three events and moved on — therefore stops the socket +-- read after at most 'frameQueueCapacity' further frames, with the +-- worker parked in an interruptible STM wait. No garbage collection and +-- no timer is involved: the bound alone stops the read, and the provider +-- stops being billed for a generation nobody is reading. An unbounded +-- channel gives the opposite behaviour, draining the whole response into +-- memory for a consumer that will never look at it. +-- +-- __Cleanup has three strengths, and they are not the same.__ +-- +-- * /Immediate/ when the consumer stops by exception. 'withFrameWorker' +-- wraps the consumer in 'Stream.bracketIO', so an exception thrown +-- into the draining thread — @Ctrl-C@, 'System.Timeout.timeout', +-- @cancel@ — lands while that thread sits inside the stream's own +-- step, inside the bracket. streamly runs the release synchronously: +-- the worker is killed, the transport's own @bracket@ around the HTTP +-- response runs, and the connection is back in the pool before the +-- exception reaches the caller. +-- +-- * /Immediate/ when the stream ends normally, for the same reason. +-- +-- * /Eventual/ when the consumer abandons the stream without an +-- exception (@Stream.take 3@ and carry on). Nothing runs at that +-- moment, because nothing knows it happened; the bound above has +-- already stopped the read, and streamly's GC finaliser runs the same +-- 'killThread' at the next major collection, which is when the +-- connection is released. Callers who need the connection back at a +-- known moment cancel the draining thread or wrap the drain in +-- 'System.Timeout.timeout'. +-- +-- A "consumer still alive" flag was considered and rejected: nothing +-- sets it to false on abandonment, so only the collector can answer +-- "will anyone pull again". So was a stall deadline on a full queue — +-- a slow but live consumer, a callback that takes minutes per event, +-- would be cut off, and correctness must not depend on consumer speed. +-- +-- __The worker never writes a sentinel.__ End-of-frames is a 'TVar' +-- flag set by 'forkFrameWorker''s 'finally', not a @Nothing@ pushed onto +-- the queue. A sentinel write can block on a full queue and so defeat +-- the very cleanup it is part of; a 'TVar' write never blocks. This is +-- also why an asynchronous exception delivered to the worker can no +-- longer strand the consumer: the flag is set however the body ends. +module Baikai.Provider.Internal.StreamWorker + ( FrameQueue, + frameQueueCapacity, + newFrameQueue, + pushFrame, + closeFrames, + pullFrame, + forkFrameWorker, + withFrameWorker, + ) +where + +import Control.Concurrent (ThreadId, forkIOWithUnmask, killThread) +import Control.Concurrent.STM + ( TVar, + atomically, + check, + newTVarIO, + orElse, + readTVar, + writeTVar, + ) +import Control.Concurrent.STM.TBQueue (TBQueue, newTBQueueIO, readTBQueue, writeTBQueue) +import Control.Exception (finally, mask_) +import GHC.Generics (Generic) +import Numeric.Natural (Natural) +import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream qualified as Stream + +-- | The bounded hand-off between one worker and one consumer. +data FrameQueue a = FrameQueue + { frames :: !(TBQueue a), + closed :: !(TVar Bool) + } + deriving stock (Generic) + +-- | How many frames a worker may run ahead of its consumer. +-- +-- Large enough that a consumer doing ordinary per-event work is never +-- the bottleneck, small enough that an abandoned stream stops reading +-- the socket almost at once. +frameQueueCapacity :: Natural +frameQueueCapacity = 64 + +newFrameQueue :: IO (FrameQueue a) +newFrameQueue = FrameQueue <$> newTBQueueIO frameQueueCapacity <*> newTVarIO False + +-- | Push one frame. Blocks while the queue is full, interruptibly, so a +-- worker parked here dies as soon as it is killed. +pushFrame :: FrameQueue a -> a -> IO () +pushFrame q a = atomically (writeTBQueue (frames q) a) + +-- | Mark the queue closed. Never blocks, so it is safe inside a +-- 'finally' on a full queue. +closeFrames :: FrameQueue a -> IO () +closeFrames q = atomically (writeTVar (closed q) True) + +-- | The next frame, or 'Nothing' once the queue is empty /and/ closed. +-- Frames pushed before the close are always delivered first. +pullFrame :: FrameQueue a -> IO (Maybe a) +pullFrame q = + atomically $ + (Just <$> readTBQueue (frames q)) + `orElse` (readTVar (closed q) >>= check >> pure Nothing) + +-- | Fork a worker body so that its 'ThreadId' cannot be lost to an +-- asynchronous exception arriving between the fork and the caller +-- recording it, and so that the queue is closed however the body ends — +-- normal return, synchronous exception, or 'killThread'. +forkFrameWorker :: FrameQueue a -> IO () -> IO ThreadId +forkFrameWorker q body = + mask_ (forkIOWithUnmask (\unmask -> unmask body `finally` closeFrames q)) + +-- | Run a consumer stream with the worker alive, killing the worker when +-- the stream stops, throws, or is collected. See the module +-- documentation for which of those is immediate and which is eventual. +withFrameWorker :: FrameQueue a -> IO () -> Stream IO b -> Stream IO b +withFrameWorker q body consumer = + Stream.bracketIO (forkFrameWorker q body) killThread (const consumer) diff --git a/src/Baikai/Provider/Registry.hs b/src/Baikai/Provider/Registry.hs --- a/src/Baikai/Provider/Registry.hs +++ b/src/Baikai/Provider/Registry.hs @@ -1,10 +1,12 @@ +{-# LANGUAGE LambdaCase #-} + -- | The provider registry — the dispatch surface that replaces the -- prior 'Baikai.Provider' typeclass and 'SomeProvider' existential. -- --- An 'ApiProvider' is the per-API handler. EP-3 promotes 'stream' to --- the primary method: every handler exposes a streaming producer --- that emits 'AssistantMessageEvent' values, and 'complete' is the --- synchronous draining wrapper (typically @streamingComplete . stream@). +-- An 'ApiProvider' is the per-API handler, and 'stream' is its primary +-- method: every handler exposes a streaming producer that emits +-- 'AssistantMessageEvent' values, and 'complete' is the synchronous +-- draining wrapper (typically @streamingComplete . stream@). -- Callers can use an explicit 'ProviderRegistry' handle to isolate handler -- sets, or use the global convenience registry for simple scripts. -- @@ -13,7 +15,9 @@ -- error-shaped 'Response' in the 'Baikai.Error.ProviderUnavailable' -- category. module Baikai.Provider.Registry - ( ApiProvider (..), + ( ApiProvider (apiTag, stream, complete, describeThinking, strengthCeiling), + apiProviderWith, + describeApi, ProviderRegistry, newProviderRegistry, newProviderRegistryFrom, @@ -26,17 +30,19 @@ lookupApiProvider, completeRequestWith, completeRequest, + requireEvidenceOnResponse, runToolLoopWith, runToolLoop, completeText, ) where -import Baikai.Api (Api, renderApi) -import Baikai.Content (AssistantContent (..), ToolCall) +import Baikai.Api (Api (..), normaliseApi, renderApi) +import Baikai.Content (AssistantContent (..), ToolCall, isCutOffToolCall) import Baikai.Context (Context, appendToolResult, contextOf) import Baikai.Error (providerUnavailable) -import Baikai.Evidence (ThinkingTranslation, noThinkingRequested) +import Baikai.Error qualified as Error +import Baikai.Evidence (ThinkingTranslation) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), ToolResult, toolResultErrorText, user) @@ -57,12 +63,18 @@ import Data.Text qualified as Text import Data.Time (getCurrentTime) import Data.Vector qualified as Vector +import GHC.Generics (Generic) import Streamly.Data.Stream (Stream) import System.IO.Unsafe (unsafePerformIO) -- | A per-API handler. 'stream' is the primary streaming -- entry point; 'complete' is the synchronous draining wrapper, -- typically @streamingComplete . stream@ from "Baikai.Stream". +-- +-- Construction: the constructor is deliberately not exported. Start +-- from 'Baikai.Provider.apiProvider' and override fields by record +-- update, so that a field added in a later release cannot break a +-- registration site — as adding 'describeThinking' in 0.5.0.0 did. data ApiProvider = ApiProvider { apiTag :: !Api, stream :: !(Model -> Context -> Options -> Stream IO AssistantMessageEvent), @@ -80,9 +92,68 @@ -- -- Never called for a caller who set no @evidence@ request or who -- asked for best-effort evidence, which is every existing caller. - describeThinking :: !(Model -> Options -> ThinkingTranslation) + describeThinking :: !(Model -> Options -> ThinkingTranslation), + -- | The highest strength this provider's evidence can reach when + -- everything goes well: a static declaration the pre-dispatch gate + -- compares against a strict caller's requirement. + -- + -- Only the provider knows this, which is why it is declared here + -- rather than looked up by tag. 'Evidence.declaredStrength' is where + -- the built-in providers get their value; a caller-supplied + -- transport that observes a model was previously capped at + -- 'Evidence.EvidenceRequestedOnly' by that table and so could never + -- satisfy a strict 'Evidence.EvidenceCorrelated' caller. + -- + -- Declaring more than the provider delivers is the one remaining way + -- to make strict mode lie, so a declaration above + -- 'Evidence.EvidenceRequestedOnly' needs a test that drives the + -- provider to it. A provider that attaches no record at all must + -- declare 'Evidence.EvidenceRequestedOnly', and will still fail a + -- strict caller at the terminal — see + -- @docs\/adr\/0014-strict-evidence-means-a-record-exists.md@. + strengthCeiling :: !Evidence.EvidenceStrength } + deriving stock (Generic) +-- | Build an 'ApiProvider' from its three functions, leaving every +-- later-added field at a safe default. +-- +-- This is the explicit builder: it takes the streaming producer /and/ +-- the synchronous completer, because "Baikai.Provider.Registry" cannot +-- import 'Baikai.Stream.streamingComplete' without a module cycle. +-- Most callers want 'Baikai.Provider.apiProvider', which supplies the +-- completer by draining the stream. +-- +-- 'describeThinking' defaults to reporting that nothing was requested +-- and nothing translated, which is honest for a transport with no +-- reasoning controls; 'strengthCeiling' defaults to +-- 'Evidence.EvidenceRequestedOnly', matching @declaredStrength (Custom _)@. +-- Override either by record update. +apiProviderWith :: + Api -> + (Model -> Context -> Options -> Stream IO AssistantMessageEvent) -> + (Model -> Context -> Options -> IO Response) -> + ApiProvider +apiProviderWith tag producer completer = + ApiProvider + { apiTag = tag, + stream = producer, + complete = completer, + describeThinking = \_ _ -> Evidence.noThinkingRequested, + strengthCeiling = Evidence.EvidenceRequestedOnly + } + +-- | How an 'Api' tag reads in a dispatch failure. +-- +-- 'renderApi' everywhere except @Custom ""@, which renders as the empty +-- string and made "No provider registered for API: " the whole message. +-- A blank tag has one cause — 'Baikai.Model.emptyModel' whose @api@ was +-- never set — so the message says that instead of nothing. +describeApi :: Api -> Text +describeApi = \case + Custom "" -> "" + other -> renderApi other + -- | A mutable provider registry handle. Each handle owns its own handler map, -- so tests and applications can maintain isolated provider sets in one process. newtype ProviderRegistry = ProviderRegistry @@ -112,9 +183,16 @@ -- | Install (or replace) a handler. Idempotent for the same 'Api' -- tag — calling 'registerApiProviderWith' twice for the same tag keeps only -- the second handler. +-- +-- The key is 'normaliseApi' of the provider's own tag, so registering +-- under @Custom \"anthropic-messages\"@ and under +-- 'Baikai.Api.AnthropicMessages' collide as one entry rather than +-- sitting side by side and dispatching by which spelling the model +-- happened to use. registerApiProviderWith :: ProviderRegistry -> ApiProvider -> IO () registerApiProviderWith reg p = - atomicModifyIORef' (registryRef reg) $ \m -> (Map.insert (apiTag p) p m, ()) + atomicModifyIORef' (registryRef reg) $ \m -> + (Map.insert (normaliseApi (apiTag p)) p m, ()) -- | Install (or replace) a handler in the process-global registry. registerApiProvider :: ApiProvider -> IO () @@ -140,8 +218,13 @@ ) -- | Look up the handler registered for an 'Api' tag. +-- +-- Both the stored key and the query go through 'normaliseApi', so a +-- handler registered under @Custom \"anthropic-messages\"@ answers a +-- model tagged 'Baikai.Api.AnthropicMessages', and the reverse. lookupApiProviderWith :: ProviderRegistry -> Api -> IO (Maybe ApiProvider) -lookupApiProviderWith reg tag = Map.lookup tag <$> readIORef (registryRef reg) +lookupApiProviderWith reg tag = + Map.lookup (normaliseApi tag) <$> readIORef (registryRef reg) -- | Look up the handler registered for an 'Api' tag in the process-global -- registry. @@ -156,21 +239,21 @@ mProvider <- lookupApiProviderWith reg (Model.api m) case mProvider of Just p -> case evidenceRefusals p m opts of - [] -> complete p m ctx opts + [] -> requireEvidenceOnResponse opts <$> complete p m ctx opts refusals -> refusedResponse m opts (describeThinking p m opts) refusals Nothing -> do now <- getCurrentTime -- "No provider was registered" is a fact about the call, so a -- caller who asked for evidence gets a record of it. Nothing was -- sent, so the digests are over 'Build.dispatchEnvelope'. - let detail = "No provider registered for API: " <> renderApi (Model.api m) + let detail = "No provider registered for API: " <> describeApi (Model.api m) err = providerUnavailable detail ev <- Build.minimalEvidence m opts (Build.transportForModel m) - noThinkingRequested + (Build.requestedTranslation opts) (Build.dispatchEnvelope m opts) now now @@ -179,6 +262,39 @@ let resp = errorResponse m now 0 err pure resp {evidence = ev} +-- | The 'Response' twin of 'Baikai.Stream.requireEvidenceOnTerminal': +-- fail a strict call whose successful response carries no evidence +-- record. +-- +-- Both dispatch points need the rule because the built-in providers' +-- @complete@ is @streamingComplete . stream@, which reassembles the +-- provider's own stream and never passes through +-- 'Baikai.Stream.streamRequestWith'. A caller using 'completeRequest' +-- with no sink at all therefore gets the same guarantee as a streaming +-- one: under 'Evidence.EvidenceRequired', a record exists or the call +-- failed. +-- +-- A response that already failed keeps its own error, which is more +-- useful than this one and already satisfies the contract. +requireEvidenceOnResponse :: Options -> Response -> Response +requireEvidenceOnResponse opts resp = case Build.strictnessOf opts of + Evidence.EvidenceRequired _ | recordMissing -> failResponse resp + _ -> resp + where + recordMissing = case (responseError resp, resp) of + (Nothing, Response {evidence = Nothing}) -> True + _ -> False + + failResponse r@Response {message = msg} = + r + { errorInfo = Just Build.missingEvidenceError, + message = + msg + { stopReason = ErrorReason, + errorMessage = Just (Error.message Build.missingEvidenceError) + } + } + -- | Every reason strict evidence mode must refuse this call before it -- is dispatched, or an empty list. -- @@ -194,7 +310,7 @@ Just req -> Build.checkEvidenceRequirements (Evidence.strictness req) - (Model.api m) + (strengthCeiling p) (describeThinking p m opts) -- | The error-shaped response a refused call returns. @@ -250,6 +366,12 @@ -- exceptions become error tool results so the model can recover; asynchronous -- exceptions are rethrown. Dispatchers should return 'toolResultErrorText' for -- unknown tool names rather than throwing. +-- +-- The loop also stops, with the response and its tool calls intact, when +-- any tool call was cut off by the output cap +-- ('Baikai.Content.isCutOffToolCall'). The model asked for something it +-- could not finish, and the only useful next step -- raise @maxTokens@ +-- and retry -- is the caller's to take. runToolLoopWith :: ProviderRegistry -> Int -> @@ -269,10 +391,17 @@ ctx' <- appendToolResult ctx resp (safeDispatcher dispatcher) go (remaining - 1) ctx' + -- A cut-off call is normally a 'Length' stop, which the second + -- clause already catches, but a compatible host that reports + -- @finish_reason: tool_calls@ for truncated arguments would slip + -- through it. Dispatching a call the model never finished asking + -- for is the one outcome this loop must not have, so the check is + -- on the calls themselves. shouldStop remaining resp = responseError resp /= Nothing || responseStopReason resp /= ToolUse || Vector.null (responseToolCalls resp) + || Vector.any isCutOffToolCall (responseToolCalls resp) || remaining <= 1 -- | One-shot text completion through the global registry. Throws the diff --git a/src/Baikai/Provider/Transport/Classify.hs b/src/Baikai/Provider/Transport/Classify.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/Transport/Classify.hs @@ -0,0 +1,202 @@ +-- | Transport-failure classification, shared by every HTTP provider. +-- +-- The rule is /where/ the failure happened, not what type it is. A +-- failure after the request went out that breaks or ends the connection +-- is 'TransientError': the same call may well succeed on the next +-- attempt. A failure that says the caller's request or the process's +-- configuration is wrong — a bad URL, an unsendable header, a proxy or +-- TLS setup that cannot work, a server that does not speak HTTP — is +-- not retryable. A programming error is neither, and stays +-- 'OtherError' so it is not silently retried forever. +-- +-- Three exception types reach a provider's worker, because +-- @http-client@ delivers the same underlying failure differently +-- depending on the phase it happened in. At connect time the manager's +-- exception wrapper turns a socket or TLS failure into +-- @HttpExceptionRequest _ (InternalException _)@ or +-- @ConnectionFailure@. While the response body is streaming, only +-- @http-client@'s own thin wrapper is in play, so an 'IOException' from +-- the socket or a 'TLS.TLSException' from the session reaches the +-- caller /raw/ — which is why a classifier that understood +-- 'HTTP.HttpException' alone called a mid-stream reset 'OtherError' +-- while calling the identical reset at connect time transient. +-- +-- Providers call 'classifyTransportException' and keep their own +-- fallback for a 'Nothing'; see +-- @Baikai.Provider.Claude.Internal.ErrorClass.classifyException@. +module Baikai.Provider.Transport.Classify + ( classifyTransportException, + classifyHttpException, + classifyHttpExceptionContent, + classifyIOException, + classifyTlsException, + ) +where + +import Baikai.Error + ( BaikaiError (..), + ErrorCategory (..), + httpError, + invalidRequest, + parseHttpDate, + parseRetryAfterSeconds, + providerError, + retryAfterSecondsAt, + ) +import Control.Exception (SomeException, displayException, fromException) +import Data.ByteString (ByteString) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Text.Encoding.Error qualified as Text +import Foreign.C.Error + ( Errno (..), + eCONNABORTED, + eCONNRESET, + eHOSTDOWN, + eHOSTUNREACH, + eNETDOWN, + eNETRESET, + eNETUNREACH, + ePIPE, + eTIMEDOUT, + ) +-- Qualified: its 'IOErrorType' has a constructor named @OtherError@, +-- which collides with the 'ErrorCategory' constructor of that name. +import GHC.IO.Exception qualified as IOE +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Types.Header (hDate, hRetryAfter) +import Network.HTTP.Types.Status (statusCode) +import Network.TLS qualified as TLS + +-- | Classify any exception a transport can raise. 'Nothing' means "not +-- a transport failure at all" — the caller keeps its own fallback, +-- which is what makes a @userError@ from a buggy callback stay +-- 'OtherError' instead of being reported as a network blip. +classifyTransportException :: SomeException -> Maybe BaikaiError +classifyTransportException ex + | Just httpEx <- fromException ex = Just (classifyHttpException httpEx) + | Just tlsEx <- fromException ex = Just (classifyTlsException tlsEx) + | Just ioEx <- fromException ex = classifyIOException ioEx + | otherwise = Nothing + +-- | Classify an @http-client@ 'HTTP.HttpException'. +classifyHttpException :: HTTP.HttpException -> BaikaiError +classifyHttpException = \case + HTTP.InvalidUrlException url reason -> + invalidRequest (Text.pack (url <> ": " <> reason)) + HTTP.HttpExceptionRequest _ content -> classifyHttpExceptionContent content + +-- | Classify the payload of an 'HTTP.HttpExceptionRequest'. +classifyHttpExceptionContent :: HTTP.HttpExceptionContent -> BaikaiError +classifyHttpExceptionContent = \case + -- A response arrived and carried a failing status. Unreachable from + -- baikai's own transports, which never install + -- 'throwErrorStatusCodes'; mapped for third-party providers built on + -- http-client. + HTTP.StatusCodeException resp body -> + let hdrs = HTTP.responseHeaders resp + headerText name = decodeLenient <$> lookup name hdrs + -- The server's own Date is the reference instant, so an + -- HTTP-date Retry-After does not inherit this machine's clock + -- skew. Falling back to epoch would be worse than falling back + -- to the integer form alone, so a missing Date leaves the date + -- form unconverted here; the transports, which are in IO, use + -- the local clock instead. + retryAfter = case parseHttpDate =<< headerText hDate of + Just reference -> retryAfterSecondsAt reference =<< headerText hRetryAfter + Nothing -> parseRetryAfterSeconds =<< headerText hRetryAfter + in httpError (statusCode (HTTP.responseStatus resp)) retryAfter (decodeLenient body) + -- The connection could not be made, or went quiet, or went away. + HTTP.ConnectionFailure e -> transient ("connection failure: " <> Text.pack (displayException e)) + HTTP.ConnectionTimeout -> transient "connection timeout" + HTTP.ResponseTimeout -> transient "response timeout" + HTTP.ConnectionClosed -> transient "connection closed" + HTTP.NoResponseDataReceived -> transient "no response data received" + HTTP.IncompleteHeaders -> transient "incomplete response headers" + -- The body broke after the status line: framing, declared length, or + -- inflation. A server that closes the socket mid-chunk surfaces here. + HTTP.InvalidChunkHeaders -> transient "chunked response body ended or broke mid-chunk" + HTTP.ResponseBodyTooShort expected actual -> + transient + ( "response body too short: expected " + <> tshow expected + <> " bytes, got " + <> tshow actual + ) + HTTP.HttpZlibException e -> + transient ("compressed response body could not be inflated: " <> tshow e) + -- http-client-tls's wrapper for a socket or TLS failure at connect + -- time. The constructor is documented as carrying exactly those, so + -- an unrecognised inner exception is still a connection failure. + HTTP.InternalException inner + | Just tlsEx <- fromException inner -> classifyTlsException tlsEx + | Just ioEx <- fromException inner -> + transient (Text.pack (displayException (ioEx :: IOE.IOException))) + | otherwise -> transient (Text.pack (displayException inner)) + -- The caller's request cannot be sent as written. + HTTP.InvalidRequestHeader h -> invalidRequest ("invalid request header: " <> decodeLenient h) + HTTP.InvalidDestinationHost h -> invalidRequest ("invalid destination host: " <> decodeLenient h) + HTTP.WrongRequestBodyStreamSize expected actual -> + invalidRequest + ( "request body size mismatch: declared " + <> tshow expected + <> ", sent " + <> tshow actual + ) + -- Everything else is a server that does not speak HTTP, or a proxy or + -- redirect configuration that cannot work. Retrying changes nothing. + other -> providerError (Text.take 300 (tshow other)) + where + tshow :: (Show a) => a -> Text + tshow = Text.pack . show + +-- | Classify a raw 'IOE.IOException', which is what a socket failure +-- during the body read looks like. +-- +-- Both the error /type/ and the errno are consulted, because @base@ +-- maps @ECONNABORTED@ to the 'IOE.OtherError' error type: a type-only +-- rule would call an aborted connection a programming error. +classifyIOException :: IOE.IOException -> Maybe BaikaiError +classifyIOException ioe + | IOE.ioe_type ioe `elem` [IOE.ResourceVanished, IOE.EOF, IOE.TimeExpired] = + Just (transient detail) + | Just n <- IOE.ioe_errno ioe, Errno n `elem` socketErrnos = Just (transient detail) + | otherwise = Nothing + where + detail = Text.pack (displayException ioe) + socketErrnos = + [ eCONNABORTED, + eCONNRESET, + eNETRESET, + eNETDOWN, + eNETUNREACH, + eHOSTDOWN, + eHOSTUNREACH, + eTIMEDOUT, + ePIPE + ] + +-- | Classify a 'TLS.TLSException'. The constructor names encode /when/ +-- the failure happened, which is exactly the fact the rule needs: a +-- session that existed and broke is transient, a session that never +-- existed is a trust-store, protocol or library-misuse problem that a +-- retry will reproduce. +classifyTlsException :: TLS.TLSException -> BaikaiError +classifyTlsException = \case + TLS.Terminated _ why err -> + transient ("TLS session terminated: " <> Text.pack why <> " (" <> tshow err <> ")") + TLS.PostHandshake err -> transient ("TLS failure after handshake: " <> tshow err) + TLS.Uncontextualized err -> transient ("TLS failure: " <> tshow err) + TLS.HandshakeFailed err -> providerError ("TLS handshake failed: " <> tshow err) + TLS.ConnectionNotEstablished -> providerError "TLS connection not established" + TLS.MissingHandshake -> providerError "TLS handshake missing" + where + tshow :: (Show a) => a -> Text + tshow = Text.pack . show + +transient :: Text -> BaikaiError +transient t = (providerError ("connection error: " <> t)) {category = TransientError} + +decodeLenient :: ByteString -> Text +decodeLenient = Text.decodeUtf8With Text.lenientDecode diff --git a/src/Baikai/Response.hs b/src/Baikai/Response.hs --- a/src/Baikai/Response.hs +++ b/src/Baikai/Response.hs @@ -13,7 +13,6 @@ module Baikai.Response ( Response (..), emptyResponse, - _Response, responseMessage, flattenAssistantBlocks, flattenAssistantText, @@ -68,7 +67,7 @@ } deriving stock (Eq, Show, Generic) --- | A blank assistant turn at epoch start. Useful as a fixture base +-- | A blank assistant turn with no timestamp. Useful as a fixture base -- for tests and as the default in error paths where no message was -- received. emptyResponse :: Response @@ -140,7 +139,3 @@ errorInfo = Just err, evidence = Nothing } - -{-# DEPRECATED _Response "Use emptyResponse instead." #-} -_Response :: Response -_Response = emptyResponse diff --git a/src/Baikai/ResponseFormat.hs b/src/Baikai/ResponseFormat.hs --- a/src/Baikai/ResponseFormat.hs +++ b/src/Baikai/ResponseFormat.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -Wno-partial-fields #-} +{-# LANGUAGE OverloadedRecordDot #-} -- | Provider-agnostic structured-output preference. -- @@ -8,26 +8,57 @@ -- structured-output constraint (today's behaviour). module Baikai.ResponseFormat ( ResponseFormat (..), + JsonSchemaFormat (name, schema, strict), + jsonSchemaFormat, ) where -import Data.Aeson (FromJSON, ToJSON, Value) +import Data.Aeson + ( FromJSON (parseJSON), + ToJSON (toJSON), + Value, + object, + withObject, + (.:), + (.:?), + (.=), + ) +import Data.Maybe (fromMaybe) import Data.Text (Text) import GHC.Generics (Generic) +-- | A named JSON Schema to enforce. +-- +-- The 'schema' is a raw JSON Schema document (an aeson 'Value'), passed +-- through verbatim; baikai never inspects or validates it. 'strict' +-- requests the provider's strict schema-enforcement mode where available +-- (OpenAI honours it; Anthropic structured outputs are always +-- schema-enforcing and ignore it). +-- +-- Construction: the constructor is deliberately not exported. Start from +-- 'jsonSchemaFormat' and override 'strict' by record update. +data JsonSchemaFormat = JsonSchemaFormat + { name :: !Text, + schema :: !Value, + strict :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | A schema request from its name and its schema document, with +-- @strict = False@. +jsonSchemaFormat :: Text -> Value -> JsonSchemaFormat +jsonSchemaFormat schemaName schemaDoc = + JsonSchemaFormat {name = schemaName, schema = schemaDoc, strict = False} + -- | How to constrain the model's output. +-- +-- The schema fields live on 'JsonSchemaFormat' rather than directly on +-- the 'JsonSchema' constructor: as fields of a sum they were partial +-- selectors, and @name f@ on a 'JsonObject' was a crash rather than a +-- type error. data ResponseFormat - = -- | Enforce a named JSON Schema. The 'schema' is a raw JSON - -- Schema document (an aeson 'Value'), passed through verbatim; - -- baikai never inspects or validates it. 'strict' requests the - -- provider's strict schema-enforcement mode where available - -- (OpenAI honours it; Anthropic structured outputs are always - -- schema-enforcing and ignore it). - JsonSchema - { name :: !Text, - schema :: !Value, - strict :: !Bool - } + = -- | Enforce a named JSON Schema. + JsonSchema !JsonSchemaFormat | -- | Plain-JSON mode: the model must emit syntactically valid JSON -- but is not constrained to a specific shape. Maps to OpenAI's -- @{"type":"json_object"}@; on Anthropic (whose structured @@ -35,4 +66,33 @@ -- @{"type":"object"}@ schema. JsonObject deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) + +-- | Hand-written to keep the flat encoding the derived instances +-- produced before 'JsonSchemaFormat' existed: +-- @{"tag":"JsonSchema","name":…,"schema":…,"strict":…}@ and +-- @{"tag":"JsonObject"}@. 'Baikai.Options.Options' derives 'ToJSON' +-- through this, and at least one consumer keys a cache on the result. +instance ToJSON ResponseFormat where + toJSON (JsonSchema f) = + object + [ "tag" .= ("JsonSchema" :: Text), + "name" .= f.name, + "schema" .= f.schema, + "strict" .= f.strict + ] + toJSON JsonObject = object ["tag" .= ("JsonObject" :: Text)] + +instance FromJSON ResponseFormat where + parseJSON = withObject "ResponseFormat" $ \o -> do + tag <- o .: "tag" + case tag :: Text of + "JsonObject" -> pure JsonObject + "JsonSchema" -> do + schemaName <- o .: "name" + schemaDoc <- o .: "schema" + isStrict <- o .:? "strict" + pure + ( JsonSchema + (jsonSchemaFormat schemaName schemaDoc) {strict = fromMaybe False isStrict} + ) + other -> fail ("unknown ResponseFormat tag: " <> show other) diff --git a/src/Baikai/StopReason.hs b/src/Baikai/StopReason.hs --- a/src/Baikai/StopReason.hs +++ b/src/Baikai/StopReason.hs @@ -8,7 +8,7 @@ -- subprocess reports an error. -- -- Constructor encoding on the wire is snake-case: @"stop"@, @"length"@, --- @"tool_use"@, @"error"@, @"aborted"@. @ErrorReason@ is renamed to +-- @"tool_use"@, @"error"@. @ErrorReason@ is renamed to -- @"error"@ so the Haskell name does not clash with @Prelude.Either.Left@ -- callers and the wire shape stays terse. module Baikai.StopReason (StopReason (..)) where @@ -29,7 +29,6 @@ | Length | ToolUse | ErrorReason - | Aborted deriving stock (Eq, Show, Generic) stopReasonOptions :: Options diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -24,10 +24,10 @@ streamingComplete, reassembleResponse, liftCompleteToStream, + requireEvidenceOnTerminal, ) where -import Baikai.Api (renderApi) import Baikai.Content ( AssistantContent (..), TextContent (..), @@ -36,7 +36,7 @@ import Baikai.Content qualified as Content import Baikai.Context (Context) import Baikai.Error (BaikaiError, providerError, providerUnavailable) -import Baikai.Evidence (ModelCallEvidence, noThinkingRequested) +import Baikai.Evidence (ModelCallEvidence) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build import Baikai.Message (AssistantPayload (..), Message (AssistantMessage)) @@ -46,6 +46,7 @@ import Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, + describeApi, evidenceRefusals, globalProviderRegistry, lookupApiProviderWith, @@ -94,7 +95,8 @@ streamRequest = streamRequestWith globalProviderRegistry -- | Dispatch a streaming call through the selected provider registry. --- Returns a one-event error stream when no handler is registered for that tag. +-- Returns an 'EventStart' then 'EventError' stream when no handler is +-- registered for that tag. streamRequestWith :: ProviderRegistry -> Model -> @@ -107,9 +109,15 @@ case mProvider of Nothing -> Stream.fromList <$> noProviderEvents m opts Just p -> case evidenceRefusals p m opts of - [] -> pure (stream p m ctx opts) + [] -> pure (applyStrict (stream p m ctx opts)) refusals -> Stream.fromList <$> refusedEvents m opts (describeThinking p m opts) refusals + where + -- A best-effort or opted-out call pays one 'Maybe' test here and no + -- per-event map; only a strict call is rewritten event by event. + applyStrict = case Build.strictnessOf opts of + Evidence.EvidenceRequired _ -> fmap (requireEvidenceOnTerminal opts) + Evidence.EvidenceBestEffort -> id -- | Stream a request through the process-global registry, invoking the -- callback once per event, then return the same reassembled 'Response' @@ -182,7 +190,11 @@ { model :: !Model, -- | 'Just' once 'EventStart' has been observed. skeleton :: !(Maybe Message), - -- | Captured by the reassembler when the fold starts driving the stream. + -- | Captured by the reassembler when the fold starts driving the + -- stream, and used to measure 'latencyMs' when the provider stamped + -- no timestamps on its skeleton or its terminal. Provider + -- timestamps stay primary: a lifted or replaying provider stamps + -- the true provider window, which this clock cannot see. wallStart :: !UTCTime, -- | Provider message id, preferring the terminal payload over the start payload. responseId :: !(Maybe Text), @@ -223,61 +235,76 @@ terminal = Nothing } +-- | Fold one event into the assembly. +-- +-- Two totality rules hold over the whole fold and are stated here +-- because they are invisible at the individual branches. __The first +-- terminal wins__: once 'terminal' is 'Just', every further event is +-- ignored, so a producer that keeps talking after its terminal cannot +-- rewrite the answer. __The first start wins__: a duplicated +-- 'EventStart' keeps the first skeleton, and @responseId@ merges with +-- '<|>' on every event that carries one, so a later 'Nothing' never +-- erases an id an earlier event supplied. Both match the OpenAI +-- assembler's @firstObserved@ discipline. step :: ReassemblyState -> AssistantMessageEvent -> ReassemblyState -step s = \case - EventStart StartPayload {partial = sk, responseId = rid} -> - s & #skeleton .~ Just sk & #responseId .~ rid - TextStart IndexPayload {contentIndex = i} -> - s & #textBuf %~ IntMap.insert i Text.empty - TextDelta DeltaPayload {contentIndex = i, delta = d} -> - s & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i d - TextEnd BlockEndPayload {contentIndex = i, content = body} -> - s - & #blocks %~ IntMap.insert i (AssistantText (TextContent body)) - & #textBuf %~ IntMap.delete i - ThinkingStart IndexPayload {contentIndex = i} -> - s & #thinkBuf %~ IntMap.insert i Text.empty - ThinkingDelta DeltaPayload {contentIndex = i, delta = d} -> - s & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i d - ThinkingEnd ThinkingEndPayload {contentIndex = i, content = tc} -> - s - & #blocks - %~ IntMap.insert - i - (AssistantThinking tc) - & #thinkBuf %~ IntMap.delete i - ToolCallStart IndexPayload {contentIndex = i} -> - s & #toolArgsBuf %~ IntMap.insert i Text.empty - ToolCallDelta DeltaPayload {contentIndex = i, delta = d} -> - s & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i d - ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} -> - s - & #blocks %~ IntMap.insert i (AssistantToolCall tc) - & #toolArgsBuf %~ IntMap.delete i - EventDone TerminalPayload {reason = r, message = msg, responseId = rid, evidence = ev} -> - s - & #terminal - .~ Just - TerminalSeen - { reason = r, - message = msg, - errorInfo = Nothing, - evidence = ev, - failed = False - } - & #responseId %~ (\old -> rid <|> old) - EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei, evidence = ev} -> - s - & #terminal - .~ Just - TerminalSeen - { reason = r, - message = msg, - errorInfo = ei, - evidence = ev, - failed = True - } - & #responseId %~ (\old -> rid <|> old) +step s event + | Just _ <- s ^. #terminal = s + | otherwise = case event of + EventStart StartPayload {partial = sk, responseId = rid} -> + s + & #skeleton %~ (\old -> old <|> Just sk) + & #responseId %~ (\old -> rid <|> old) + TextStart IndexPayload {contentIndex = i} -> + s & #textBuf %~ IntMap.insert i Text.empty + TextDelta DeltaPayload {contentIndex = i, delta = d} -> + s & #textBuf %~ IntMap.insertWith (\new old -> old <> new) i d + TextEnd BlockEndPayload {contentIndex = i, content = body} -> + s + & #blocks %~ IntMap.insert i (AssistantText (TextContent body)) + & #textBuf %~ IntMap.delete i + ThinkingStart IndexPayload {contentIndex = i} -> + s & #thinkBuf %~ IntMap.insert i Text.empty + ThinkingDelta DeltaPayload {contentIndex = i, delta = d} -> + s & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i d + ThinkingEnd ThinkingEndPayload {contentIndex = i, content = tc} -> + s + & #blocks + %~ IntMap.insert + i + (AssistantThinking tc) + & #thinkBuf %~ IntMap.delete i + ToolCallStart IndexPayload {contentIndex = i} -> + s & #toolArgsBuf %~ IntMap.insert i Text.empty + ToolCallDelta DeltaPayload {contentIndex = i, delta = d} -> + s & #toolArgsBuf %~ IntMap.insertWith (\new old -> old <> new) i d + ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} -> + s + & #blocks %~ IntMap.insert i (AssistantToolCall tc) + & #toolArgsBuf %~ IntMap.delete i + EventDone TerminalPayload {reason = r, message = msg, responseId = rid, evidence = ev} -> + s + & #terminal + .~ Just + TerminalSeen + { reason = r, + message = msg, + errorInfo = Nothing, + evidence = ev, + failed = False + } + & #responseId %~ (\old -> rid <|> old) + EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei, evidence = ev} -> + s + & #terminal + .~ Just + TerminalSeen + { reason = r, + message = msg, + errorInfo = ei, + evidence = ev, + failed = True + } + & #responseId %~ (\old -> rid <|> old) finalizeState :: ReassemblyState -> IO Response finalizeState s = do @@ -303,7 +330,9 @@ message' = overrideBlocksAndReason terminalReason terminalMsg finalContent now latency = case (s ^. #skeleton >>= messageTimestamp, assistantPayloadTimestamp message') of (Just startTs, Just endTs) -> millisBetween startTs endTs - _ -> 0 + -- No provider timestamps: measure the window this fold actually + -- saw rather than reporting zero, which reads as "instant". + _ -> millisBetween (s ^. #wallStart) now pure Response { message = message', @@ -346,9 +375,7 @@ toolBlock raw | Text.null raw = Nothing | otherwise = - let decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 raw) of - Right v -> v - Left _ -> Aeson.String raw + let decoded = Content.toolArgumentsFromText raw in Just ( AssistantToolCall Content.ToolCall @@ -467,9 +494,12 @@ Right a -> pure (Right a) -- | Build the synthetic event list for a fully resolved 'Response'. --- The 'EventStart' carries the supplied @startTs@ on its message --- skeleton so 'reassembleResponse' can recover 'latencyMs' from the --- start/end timestamps. +-- +-- The 'EventStart' carries the response's message skeleton — empty +-- content, but the final usage, stop reason and error text already +-- filled in, because the lifted response is complete before the stream +-- begins — and the supplied @startTs@, so 'reassembleResponse' can +-- recover 'latencyMs' from the start/end timestamps. eventsFor :: UTCTime -> Response -> [AssistantMessageEvent] eventsFor startTs resp = let payload = resp ^. #message @@ -556,7 +586,7 @@ m opts (Build.transportForModel m) - noThinkingRequested + (Build.requestedTranslation opts) (Build.dispatchEnvelope m opts) startTs now @@ -567,6 +597,47 @@ EventError (errorTerminal ev Nothing ErrorReason msg err) ] +-- | Fail a strict call whose successful terminal carries no evidence +-- record. +-- +-- Strict mode already guaranteed that a record which was built and then +-- lost fails the call; it did not guarantee that one was built. A +-- provider that attaches nothing returned a successful response and +-- wrote no @call_evidence@ line, with no error anywhere — evidence that +-- can vanish without the caller noticing is not evidence. Under +-- 'Evidence.EvidenceRequired' such a terminal becomes an 'EventError' +-- carrying 'Build.missingEvidenceError'. +-- +-- Everything else is returned unchanged: an error terminal (whose own +-- error is more useful than this one and which already satisfies the +-- contract — the call failed), any terminal carrying a record, every +-- non-terminal event, and every best-effort or opted-out call. +requireEvidenceOnTerminal :: Options -> AssistantMessageEvent -> AssistantMessageEvent +requireEvidenceOnTerminal opts ev = case (Build.strictnessOf opts, ev) of + (Evidence.EvidenceRequired _, EventDone p) + | Nothing <- p ^. #evidence -> + EventError + ( p + & #reason + .~ ErrorReason + & #errorInfo + .~ Just Build.missingEvidenceError + & #message + %~ markFailed + ) + _ -> ev + where + markFailed = \case + AssistantMessage p -> + AssistantMessage + ( p + & #stopReason + .~ ErrorReason + & #errorMessage + .~ Just (Build.missingEvidenceError ^. #message) + ) + other -> other + -- | The synthetic error stream used when no provider is registered for -- the model's API tag. -- @@ -575,8 +646,8 @@ -- omits it is worse than one that records the failure. There is no wire -- request body to digest here because nothing was ever sent, so the -- digests are over 'Build.dispatchEnvelope'. --- | The one-event error stream a strict call refused before dispatch --- returns. +-- | The 'EventStart' then 'EventError' stream a strict call refused +-- before dispatch returns. -- -- Shaped exactly like 'noProviderEvents', because from a consumer's -- point of view both are the same thing: a call that produced a terminal @@ -623,7 +694,7 @@ noProviderEvents :: Model -> Options -> IO [AssistantMessageEvent] noProviderEvents m opts = do now <- getCurrentTime - let detail = "No provider registered for API: " <> renderApi (m ^. #api) + let detail = "No provider registered for API: " <> describeApi (m ^. #api) be = providerUnavailable detail msg = AssistantMessage @@ -639,7 +710,7 @@ m opts (Build.transportForModel m) - noThinkingRequested + (Build.requestedTranslation opts) (Build.dispatchEnvelope m opts) now now diff --git a/src/Baikai/Stream/Event.hs b/src/Baikai/Stream/Event.hs --- a/src/Baikai/Stream/Event.hs +++ b/src/Baikai/Stream/Event.hs @@ -4,17 +4,19 @@ -- -- A provider call exposes its progress as a 'Streamly.Data.Stream.Stream -- IO AssistantMessageEvent'. The stream begins with a single --- 'EventStart' carrying an empty 'AssistantMessage' skeleton (api, --- provider, model id), interleaves per-content-block lifecycle events +-- 'EventStart' carrying an 'AssistantMessage' skeleton — empty content, +-- zero usage, no stop reason yet — interleaves per-content-block +-- lifecycle events -- (@_Start@ / @_Delta@ / @_End@) keyed by 'contentIndex', and -- terminates with exactly one 'EventDone' (success) or 'EventError' -- (any failure that bubbled out of the producer). This EventStart-first -- invariant includes error-only streams produced by core dispatch and -- request-preparation failures; they emit a synthetic skeleton before --- the terminal error. One temporary provider-side gap remains: a Claude --- mid-call failure before @message_start@ can still terminate without a --- start event until the EP-7 Claude streaming rewrite pre-seeds its --- skeleton. The terminal event carries the fully assembled +-- the terminal error. It holds without exception: both HTTP providers +-- pre-seed their skeleton before the first wire read, so a failure that +-- arrives before the provider has said anything about the response +-- still begins its stream with 'EventStart'. +-- The terminal event carries the fully assembled -- 'AssistantMessage' so a consumer that only pattern-matches on the -- terminal event still gets a correct response without folding deltas. -- @@ -70,9 +72,9 @@ -- constructors. data AssistantMessageEvent = -- | The first event in every stream. The payload's 'partial' is an - -- 'AssistantMessage' with empty content; downstream consumers that - -- care only about the message skeleton (api, provider, model id) - -- can read it here. + -- 'AssistantMessage' skeleton: empty content, zero usage, and no + -- stop reason yet. The api, provider and model id live on the + -- 'Baikai.Response.Response', not on the message. EventStart StartPayload | -- | A text content block is about to receive deltas. TextStart IndexPayload @@ -110,15 +112,23 @@ | -- | The stream's terminal failure event. The payload's 'message' -- is an 'AssistantMessage' carrying whatever content blocks were -- already closed before the failure, plus a populated - -- 'errorMessage' and @stopReason = ErrorReason@ or - -- @stopReason = Aborted@. + -- 'errorMessage' and @stopReason = ErrorReason@. EventError TerminalPayload deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) -- | Payload of 'EventStart': the message skeleton observed up front, --- plus the provider's message id when the provider learns it this --- early (Anthropic's @message_start.id@). 'Nothing' otherwise. +-- plus the provider's message id when the provider knows it before its +-- first event. +-- +-- Neither HTTP provider does: both pre-seed this event before the first +-- wire read, so that a failure arriving before the provider has said +-- anything still begins the stream the way the protocol says every +-- stream begins. The id, when it arrives, rides +-- 'TerminalPayload.responseId', which +-- 'Baikai.Stream.reassembleResponse' prefers over this one anyway. A +-- lifted or replaying provider that knows the id up front may still set +-- it here. data StartPayload = StartPayload { partial :: !Message, responseId :: !(Maybe Text) diff --git a/src/Baikai/ThinkingLevel.hs b/src/Baikai/ThinkingLevel.hs --- a/src/Baikai/ThinkingLevel.hs +++ b/src/Baikai/ThinkingLevel.hs @@ -10,6 +10,7 @@ module Baikai.ThinkingLevel ( ThinkingLevel (..), renderThinkingLevel, + parseThinkingLevel, thinkingTokenBudget, ) where @@ -42,6 +43,21 @@ ThinkingHigh -> "high" ThinkingXHigh -> "xhigh" ThinkingMax -> "max" + +-- | The inverse of 'renderThinkingLevel': parse a canonical level name. +-- +-- Beside its renderer so the two cannot drift, which three hand-copied +-- tables — in 'Baikai.Evidence', @Baikai.Agent.Config@ and +-- @Baikai.Agent.Cli@ — did the first time a level was added. +parseThinkingLevel :: Text -> Maybe ThinkingLevel +parseThinkingLevel = \case + "minimal" -> Just ThinkingMinimal + "low" -> Just ThinkingLow + "medium" -> Just ThinkingMedium + "high" -> Just ThinkingHigh + "xhigh" -> Just ThinkingXHigh + "max" -> Just ThinkingMax + _ -> Nothing -- | Recommended token budget for providers that take an explicit -- count (Anthropic's @thinking.budget_tokens@). diff --git a/src/Baikai/Tool.hs b/src/Baikai/Tool.hs --- a/src/Baikai/Tool.hs +++ b/src/Baikai/Tool.hs @@ -18,10 +18,10 @@ -- between this module (which 'Baikai.Context' imports for the @tools@ -- field type) and 'Baikai.Context' itself. module Baikai.Tool - ( Tool (..), + ( Tool (name, description, parameters), + mkTool, ToolChoice (..), emptyTool, - _Tool, ) where @@ -42,6 +42,12 @@ -- | A caller-declared tool. @parameters@ holds a JSON Schema; the -- provider-side encoders pass it through unchanged. +-- +-- Construction: the constructor is deliberately not exported. Use +-- 'mkTool', which takes the three fields every provider needs, and +-- override anything else by record update. 'emptyTool' remains for +-- fixtures, but a tool declared from it and sent unchanged reaches the +-- wire with @input_schema: null@. data Tool = Tool { name :: !Text, description :: !Text, @@ -50,6 +56,18 @@ deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +-- | A tool from its name, its description and its JSON Schema — the +-- three things every provider requires. +-- +-- > mkTool "get_weather" "Look up the weather" schema +mkTool :: Text -> Text -> Value -> Tool +mkTool toolName toolDescription toolParameters = + Tool + { name = toolName, + description = toolDescription, + parameters = toolParameters + } + -- | How the model should pick between the registered tools. -- -- * 'ToolChoiceAuto' — model decides (the default at most providers). @@ -84,7 +102,3 @@ description = Text.empty, parameters = Null } - -{-# DEPRECATED _Tool "Use emptyTool instead." #-} -_Tool :: Tool -_Tool = emptyTool diff --git a/src/Baikai/Trace.hs b/src/Baikai/Trace.hs --- a/src/Baikai/Trace.hs +++ b/src/Baikai/Trace.hs @@ -2,7 +2,7 @@ -- | The 'withTrace' wrapper and supporting helpers. -- --- After EP-3, the trace bridge is stream-shaped at the core: +-- The trace bridge is stream-shaped at the core: -- 'withTraceStream' returns a 'Stream IO AssistantMessageEvent' -- that side-effects 'CallStarted' / 'CallFinished' / 'CallFailed' -- events to a user-supplied 'TraceSink' as the stream's lifecycle @@ -16,12 +16,27 @@ -- 'AssistantMessageEvent' is emitted), then watch for the stream's -- terminal event ('EventDone' or 'EventError') and push the -- matching 'CallFinished' / 'CallFailed' before yielding the --- terminal event to the consumer. Cleanup ('Nothing' sentinel on --- the channel + 'takeMVar' on the worker) is idempotent and runs --- through 'Stream.finallyIO' so an early-aborting consumer eventually --- records a synthetic 'CallFailed' and never leaks the worker. Sink --- exceptions are captured by the worker and reported once on stderr --- during cleanup; they do not propagate into the provider call. +-- terminal event to the consumer. +-- +-- Cleanup — the 'Nothing' sentinel on the channel, then a wait for +-- the worker — runs exactly once per call. On a normal terminal it +-- runs on the calling thread, so when 'withTrace' returns the sink +-- has processed this call's events. When the consumer abandons the +-- stream instead, it runs from streamly's garbage-collection hook: +-- the synthetic 'CallFailed' and its @aborted@ evidence record are +-- delivered at the next major collection after the stream becomes +-- unreachable, and are __not guaranteed before process exit__. A +-- caller who needs the record before exiting drains the stream to +-- its terminal ('withTrace', or a fold that keeps consuming) rather +-- than stopping early. +-- +-- The wait for the worker is bounded by 'sinkDrainBoundMicros'. A +-- sink that blocks forever costs the call one second, after which +-- the worker is abandoned and the stall is reported. Sink +-- exceptions — and stalls — are recorded by the worker and reported +-- once on stderr during cleanup; they fail the call only under +-- 'Baikai.Evidence.EvidenceRequired', where a record whose delivery +-- was never confirmed is not one the caller can account for. module Baikai.Trace ( -- * Re-exports TraceEvent (..), @@ -36,7 +51,6 @@ runRequestWithRegistry, -- * Helpers - newEventId, summarizeContext, ) where @@ -55,10 +69,8 @@ -- both belong in this module, so the status constructors stay behind -- the @Evidence.@ qualifier. import Baikai.Evidence - ( EvidenceStrictness (..), - ModelCallEvidence, + ( ModelCallEvidence, newCallId, - noThinkingRequested, ) import Baikai.Evidence qualified as Evidence import Baikai.Evidence.Build qualified as Build @@ -67,6 +79,7 @@ import Baikai.Options (Options) import Baikai.Prelude import Baikai.Provider.Registry (ProviderRegistry, globalProviderRegistry) +import Baikai.Provider.Registry qualified as Registry import Baikai.Response (Response) import Baikai.StopReason (StopReason (ErrorReason)) import Baikai.Stream (reassembleResponse, streamRequestWith) @@ -77,16 +90,18 @@ import Baikai.Usage qualified as Usage import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) -import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Exception (SomeException, try) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.Exception (Exception (..), SomeException, mask, onException, try, uninterruptibleMask_) import Control.Monad (forM_, unless, void) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isJust) import Data.Time (UTCTime, diffUTCTime, getCurrentTime) import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream +import System.IO (hPutStrLn, stderr) +import System.Timeout (timeout) -- ============================================================ -- Stream-shaped trace bridge @@ -157,20 +172,17 @@ -- is already over — so a fatal sink failure discovered here has -- nowhere to go but the stderr line 'reportSinkError' already -- wrote. The terminal event below is where it can still matter. - (void (finalizeTrace state eid start m opts)) - (Stream.mapM (traceEvent state eid start m opts) (streamRequestWith reg m ctx opts)) + (void (finalizeTrace reg state eid start m opts)) + (Stream.mapM (traceEvent reg state eid start m opts) (streamRequestWith reg m ctx opts)) -- | Synchronous trace wrapper. Drains 'withTraceStream' into a -- 'Response' through 'reassembleResponse'. -- --- Unlike the EP-2 'withTrace' (which re-threw the producer's --- exception), this implementation never throws for producer-side --- failures: errors flow through the stream as a terminal --- 'EventError' and the drained 'Response' carries --- @stopReason = ErrorReason@ plus 'errorMessage'. The masterplan's --- Vision & Scope section commits to "partial output is always --- recoverable" and the plan's Decision Log records that producer --- failures must surface as response data, not exceptions. +-- This never throws for producer-side failures: errors flow through +-- the stream as a terminal 'EventError' and the drained 'Response' +-- carries @stopReason = ErrorReason@ plus 'errorMessage'. Partial +-- output must always be recoverable, so a producer failure surfaces as +-- response data rather than as an exception. -- Downstream-of-the-fold exceptions (e.g. an 'appendEntry' that -- fails) still propagate unchanged. withTrace :: @@ -235,8 +247,8 @@ -- answer can still change the call's outcome; by cleanup time the -- stream is over. finalizeTrace :: - TraceState -> Text -> UTCTime -> Model -> Options -> IO (Maybe BaikaiError) -finalizeTrace s eid start m opts = do + ProviderRegistry -> TraceState -> Text -> UTCTime -> Model -> Options -> IO (Maybe BaikaiError) +finalizeTrace reg s eid start m opts = mask $ \restore -> do alreadyClosed <- atomicModifyIORef' (s ^. #closed) (\b -> (True, b)) if alreadyClosed @@ -262,12 +274,26 @@ -- would misattribute it. The digests are over -- 'Build.dispatchEnvelope' — see its documentation for what that -- does and does not commit to. + -- + -- The translation comes from the registered adapter's own + -- 'Registry.describeThinking': the adapter /did/ run on this + -- path, so its description is the truthful one and the only one + -- @docs\/adr\/0003-the-adapter-owns-the-translation-description.md@ + -- permits. Where no provider is registered there is nothing to + -- ask, and 'Build.requestedTranslation' says the caller\'s level + -- was never translated. Either way the caller\'s own level is + -- recorded, which passing 'Evidence.noThinkingRequested' here + -- silently denied. + mProvider <- Registry.lookupApiProviderWith reg (m ^. #api) + let translation = case mProvider of + Just p -> Registry.describeThinking p m opts + Nothing -> Build.requestedTranslation opts mev <- Build.minimalEvidence m opts (Build.transportForModel m) - noThinkingRequested + translation (Build.dispatchEnvelope m opts) start now @@ -278,14 +304,71 @@ -- because nothing about the provider went wrong: the consumer -- stopped reading. The message says exactly that. (Just (providerError abortText)) - pushEvidence s eid now m mev - writeChan (s ^. #chan) (Just aborted) + commitTerminal s eid now m mev aborted writeChan (s ^. #chan) Nothing - takeMVar (s ^. #done) + -- The claim-through-sentinel region above cannot be interrupted; + -- the wait below can, which is the whole point of the 'mask' / + -- 'restore' pair. The GC-hook path enters here already under + -- 'Control.Exception.mask_', and 'restore' puts back /that/ state, + -- in which a blocking 'readMVar' is still interruptible — so + -- 'timeout' can deliver its exception on either path. The + -- 'onException' releases the root if the wait is interrupted: the + -- sentinel is already queued, so the worker cannot block on the + -- channel again and no longer needs rooting. + drained <- restore (awaitWorker s) `onException` releaseStableRoot s + unless drained $ + atomicModifyIORef' (s ^. #sinkError) $ \old -> + (Just (fromMaybe (toException (TraceSinkStalled sinkDrainBoundMicros)) old), ()) fatal <- reportSinkError s opts releaseStableRoot s pure fatal +-- | How long 'finalizeTrace' waits for the trace worker after writing +-- the shutdown sentinel. +-- +-- On expiry the worker is abandoned, not killed, and the call proceeds. +-- One second is chosen because a call produces at most four events, the +-- wait covers only their delivery and the sink's end-of-stream action, +-- and a sink whose per-call latency approaches a second is +-- mis-configured for per-call tracing — an OpenTelemetry exporter +-- belongs behind the non-blocking batch processor. Not a public option: +-- if the bound ever proves tight the answer is an 'Options' field. +sinkDrainBoundMicros :: Int +sinkDrainBoundMicros = 1_000_000 + +-- | The trace sink did not confirm delivery within +-- 'sinkDrainBoundMicros', carried here as the microsecond bound. +-- +-- Stored in the trace state's @sinkError@ as a plain exception, so the +-- strict-mode decision in "Baikai.Evidence.Build" applies to it exactly +-- as it does to a sink that threw: best-effort callers get the stderr +-- line and their answer, a caller who required evidence gets a failed +-- call. Not exported — it renders as text through both paths, and an +-- exported type is a name the surface freeze would have to keep. +newtype TraceSinkStalled = TraceSinkStalled Int + deriving stock (Show) + +instance Exception TraceSinkStalled where + displayException (TraceSinkStalled us) = + "the trace sink did not confirm delivery within " + <> show (us `div` 1000) + <> " ms; its worker was abandoned, and events already queued may still be \ + \delivered later" + +-- | Wait for the worker to signal completion, for at most +-- 'sinkDrainBoundMicros'. 'True' when it did. +-- +-- On 'False' the worker is left running: killing it would abort the +-- sink's fold mid-step and lose its end-of-stream action. An abandoned +-- worker finishes when the sink unblocks, or is reaped with +-- 'Control.Exception.BlockedIndefinitelyOnMVar' — which its 'try' +-- catches — when whatever it blocks on becomes unreachable. +-- +-- 'readMVar', not 'takeMVar', so the worker's eventual 'putMVar' can +-- never block on a slot this thread emptied. +awaitWorker :: TraceState -> IO Bool +awaitWorker s = isJust <$> timeout sinkDrainBoundMicros (readMVar (s ^. #done)) + -- | Push the 'CallEvidence' event for a call, when there is one. -- -- An absent evidence value means one of two things and this layer must @@ -315,6 +398,35 @@ evidence = ev } +-- | Commit a call's terminal to the sink: mark the terminal as sent, +-- push the evidence record (when there is one), then push the terminal +-- event. +-- +-- One unit with respect to asynchronous exceptions. An exception +-- delivered between the terminal push and the flag write made +-- 'finalizeTrace' read the flag as unset and push a second evidence +-- record and an @aborted@ 'CallFailed' after the real terminal, so a +-- sink saw two records and two contradictory terminals for one call. +-- Plain 'Control.Exception.mask_' closes the window everywhere except +-- inside 'writeChan', whose internal 'takeMVar' on the channel's write +-- lock is interruptible; it never blocks in practice, because the +-- worker only reads, but "never in practice" is what this exists to +-- remove. Every write here is a non-blocking push to an unbounded +-- 'Chan' or one 'IORef' write, so the uninterruptible block holds for +-- microseconds and cannot become an un-cancellable hang. +-- +-- The flag goes /first/ so a synchronous failure inside the block +-- yields a missing terminal — which the abort machinery tolerates — +-- rather than a duplicated one. The wait for the worker is outside the +-- block, in 'finalizeTrace'. +commitTerminal :: + TraceState -> Text -> UTCTime -> Model -> Maybe ModelCallEvidence -> TraceEvent -> IO () +commitTerminal s eid now m mev terminal = + uninterruptibleMask_ $ do + writeIORef (s ^. #terminalSent) True + pushEvidence s eid now m mev + writeChan (s ^. #chan) (Just terminal) + releaseStableRoot :: TraceState -> IO () releaseStableRoot s = do msp <- atomicModifyIORef' (s ^. #stableRoot) (\sp -> (Nothing, sp)) @@ -333,22 +445,24 @@ case merr of Nothing -> pure Nothing Just e -> do - Build.onSinkFailure strictness e + -- A stall is not a throw, and 'Build.onSinkFailure's line says + -- the events "were dropped", which is the one thing an abandoned + -- worker's events were not: they are still queued and may yet be + -- delivered. The fatality decision below is identical for both. + case fromException e of + Just stalled@TraceSinkStalled {} -> + hPutStrLn stderr ("baikai: " <> displayException stalled) + Nothing -> Build.onSinkFailure strictness e pure ( if Build.sinkFailureIsFatal strictness then Just (Build.sinkFailureError e) else Nothing ) where - strictness = strictnessOf opts - --- | The strictness a call was dispatched under. A call with no evidence --- request is best-effort. -strictnessOf :: Options -> EvidenceStrictness -strictnessOf opts = - maybe EvidenceBestEffort (^. #strictness) (opts ^. #evidence) + strictness = Build.strictnessOf opts traceEvent :: + ProviderRegistry -> TraceState -> Text -> UTCTime -> @@ -356,7 +470,7 @@ Options -> AssistantMessageEvent -> IO AssistantMessageEvent -traceEvent state eid start m opts ev = do +traceEvent reg state eid start m opts ev = do case ev of EventDone TerminalPayload {message = msg, evidence = mev} -> do now <- getCurrentTime @@ -393,10 +507,8 @@ -- call's state open when it arrives. The OpenTelemetry sink ends -- and removes its span on the terminal, so the other order left -- its evidence branch unreachable from a live stream. - pushEvidence state eid now m mev - writeChan (state ^. #chan) (Just finished) - writeIORef (state ^. #terminalSent) True - fatal <- finalizeTrace state eid start m opts + commitTerminal state eid now m mev finished + fatal <- finalizeTrace reg state eid start m opts -- A strict caller whose record did not survive gets a failed call -- rather than an answer they cannot account for. This is the only -- place in baikai where a call that reached the provider and came @@ -417,13 +529,11 @@ latencyMs = latency, errorMessage = errMsg } - pushEvidence state eid now m mev - writeChan (state ^. #chan) (Just failed) - writeIORef (state ^. #terminalSent) True + commitTerminal state eid now m mev failed -- Already an error: a sink failure on top changes nothing the -- caller can act on, and overwriting the provider's own error with -- baikai's would lose the more useful of the two. - _ <- finalizeTrace state eid start m opts + _ <- finalizeTrace reg state eid start m opts pure ev _ -> pure ev @@ -525,19 +635,3 @@ millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double)) - --- ============================================================ --- Event id --- ============================================================ - --- | Generate an identifier for one traced call. --- --- Delegates to 'newCallId'. The previous implementation combined the --- process-start POSIX /second/ with a process-local counter and --- produced 16 hexadecimal characters, which meant two processes --- started within the same second emitted identical identifier --- sequences. 'newCallId' produces 32 characters and is unique across --- processes. -newEventId :: IO Text -newEventId = newCallId -{-# DEPRECATED newEventId "Use Baikai.Evidence.newCallId; newEventId's ids were only unique within one process." #-} diff --git a/src/Baikai/Trace/Event.hs b/src/Baikai/Trace/Event.hs --- a/src/Baikai/Trace/Event.hs +++ b/src/Baikai/Trace/Event.hs @@ -39,9 +39,10 @@ -- -- Every event carries an 'eventId' that correlates the @started@ event -- with its matching @finished@, @failed@, or @evidence@ event within a --- single process run. Token counts are 'Maybe' because subscription-based --- providers (the CLIs) do not report them; 'omitNothingFields' keeps the --- absent fields out of the rendered JSON. +-- single process run. Token counts are 'Maybe' because a non-assistant +-- terminal has no usage and a subprocess tool may report nothing; since +-- 0.5.0.0 both CLI providers carry the counts the tool reported. +-- 'omitNothingFields' keeps the absent fields out of the rendered JSON. -- -- 'usd' is deliberately /not/ 'Maybe'-shaped as an "unknown" marker: it -- was until this release, and a computed cost of zero was suppressed, so @@ -49,6 +50,14 @@ -- looked identical in a trace. The field is still 'Maybe' because a -- non-assistant terminal has no usage at all, but a zero cost now -- renders as @0@. +-- +-- The @model@ field carries the __requested__ 'Baikai.Model.modelId' on +-- every constructor, including 'CallEvidence'. The model the provider +-- actually served — which can differ, and which is an observation +-- rather than a request — is available only inside 'CallEvidence'\'s +-- record, as +-- 'Baikai.Evidence.ModelCallEvidence'\'s @observedModel@. A sink must +-- not present @model@ under a response-model key. data TraceEvent = CallStarted { eventId :: !Text, @@ -86,8 +95,10 @@ } | -- | The complete evidence record for one terminal provider call. -- - -- Emitted exactly once per call, immediately after the matching - -- 'CallFinished' or 'CallFailed', and only when the caller set + -- Emitted exactly once per call, immediately __before__ the + -- matching 'CallFinished' or 'CallFailed', so a sink that keys + -- per-call state off the started/terminal pair still has the call + -- open when the record arrives. Only when the caller set -- 'Baikai.Options.evidence' and the provider built a record. A -- consumer that wants only evidence can filter on this kind alone, -- and a consumer written before this constructor existed is diff --git a/src/Baikai/Trace/Sink.hs b/src/Baikai/Trace/Sink.hs --- a/src/Baikai/Trace/Sink.hs +++ b/src/Baikai/Trace/Sink.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} -- | The 'TraceSink' newtype and four built-in sinks. -- @@ -7,6 +8,12 @@ -- combinators like 'Fold.tee' (fan to two folds), 'Fold.filter' (drop inputs -- failing a predicate), and 'Fold.lmap' (project each input), so future -- sinks (OpenTelemetry, redaction, projection) plug in without an adapter. +-- +-- 'multiSink' is the one place that does /not/ compose with 'Fold.tee': +-- 'Fold.tee' runs one member then the other and lets either's exception +-- escape, so a single throwing member stopped delivery to its siblings +-- and skipped their end-of-stream actions. Each member now runs on its +-- own drain thread; see 'multiSink'. module Baikai.Trace.Sink ( TraceSink (..), silent, @@ -19,14 +26,21 @@ import Baikai.Evidence qualified as Evidence import Baikai.Trace.Event (TraceEvent (..)) +import Control.Concurrent (forkIO) +import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar) +import Control.Exception (Exception (..), SomeException, throwIO, try) +import Control.Monad (forM_, unless) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy qualified as BSL +import Data.List (intercalate) import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as Text.IO import Data.Time (defaultTimeLocale, formatTime) import Streamly.Data.Fold (Fold) import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream import System.IO (IOMode (AppendMode), withFile) -- | A trace sink is a streamly fold over 'TraceEvent' values. Folds @@ -54,15 +68,82 @@ withFile path AppendMode $ \h -> BSL.hPut h (Aeson.encode e <> "\n") --- | Fan every event out to every sink in the list. Implemented by folding --- 'Fold.tee' across the input list; 'Fold.tee' runs both folds on each --- input and returns the pair of their accumulators, which we discard. +-- | Fan every event out to every sink in the list. +-- +-- Each member runs on its own drain thread behind its own unbounded +-- channel, so a member that throws or blocks cannot stop delivery to +-- the others or skip their end-of-stream action. This fold's step never +-- blocks. Its final action sends every member the sentinel, waits for +-- every member, and throws one 'TraceSinkFailure' naming each failed +-- member by zero-based index when any failed — which the trace worker +-- records like any other sink failure. +-- +-- The wait for a member is unbounded here; "Baikai.Trace" bounds the +-- whole drain, so a member that blocks forever costs the call the drain +-- bound and no more. One consequence is accepted: while such a member +-- is blocked the aggregate is never thrown, so a /throwing/ sibling's +-- message does not reach stderr in that combination. The stall line +-- names the actionable fact, and the sibling's events were delivered +-- regardless. multiSink :: [TraceSink] -> TraceSink multiSink sinks = - TraceSink (foldr step Fold.drain sinks) + TraceSink (Fold.rmapM finish (Fold.foldlM' deliver start)) where - step (TraceSink f) acc = fmap (const ()) (Fold.tee f acc) + start :: IO [Member] + start = mapM startMember sinks + deliver :: [Member] -> TraceEvent -> IO [Member] + deliver members e = do + forM_ members $ \member -> writeChan (chan member) (Just e) + pure members + + finish :: [Member] -> IO () + finish members = do + forM_ members $ \member -> writeChan (chan member) Nothing + outcomes <- mapM (readMVar . outcome) members + let failures = [(i, e) | (i, Just e) <- zip [0 :: Int ..] outcomes] + unless (null failures) $ + throwIO (TraceSinkFailure (length members) failures) + +-- | One member of a 'multiSink': the channel it is fed through and the +-- slot its drain thread fills with the outcome of its fold. +data Member = Member + { chan :: !(Chan (Maybe TraceEvent)), + outcome :: !(MVar (Maybe SomeException)) + } + +-- | Fork one member's drain thread. The 'try' is @SomeException@ for +-- the same reason the trace worker's is: nothing throws /to/ this +-- thread, so the catch cannot swallow a cancellation aimed at anyone, +-- and a member abandoned by a stalled drain is reaped with +-- 'Control.Exception.BlockedIndefinitelyOnMVar', which is worth +-- recording rather than printing through the runtime. +startMember :: TraceSink -> IO Member +startMember (TraceSink f) = do + c <- newChan + o <- newEmptyMVar + _ <- forkIO $ do + let step () = fmap (fmap (\e -> (e, ()))) (readChan c) + r <- try (Stream.fold f (Stream.unfoldrM step ())) :: IO (Either SomeException ()) + putMVar o (either Just (const Nothing) r) + pure Member {chan = c, outcome = o} + +-- | One or more members of a 'multiSink' failed. Not exported: the +-- strict-mode error and the stderr line both render its text, and an +-- exported type is a name the surface freeze would have to keep. +data TraceSinkFailure = TraceSinkFailure Int [(Int, SomeException)] + deriving stock (Show) + +instance Exception TraceSinkFailure where + displayException (TraceSinkFailure total failures) = + show (length failures) + <> " of " + <> show total + <> " member sinks failed: " + <> intercalate + "; " + ["member " <> show i <> ": " <> displayException e | (i, e) <- failures] + -- | Format an event as a single human-readable line. renderHuman :: TraceEvent -> Text renderHuman = \case @@ -114,15 +195,15 @@ tshow x = Text.pack (show x) fmtTime t = Text.pack (formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%SZ" t) --- | Read through a record pattern rather than bare selectors: +-- | Read through 'OverloadedRecordDot' rather than bare selectors: -- 'Evidence.ModelCallEvidence' and 'Evidence.EvidenceRequest' both -- carry @runId@, so under @DuplicateRecordFields@ a bare --- @Evidence.runId ev@ is an ambiguous occurrence. +-- @Evidence.runId ev@ is an ambiguous occurrence. A record pattern +-- would also work, but the constructor is no longer exported. evidenceSummary :: Evidence.ModelCallEvidence -> Text -evidenceSummary - Evidence.ModelCallEvidence {Evidence.runId, Evidence.callId, Evidence.strength} = - Text.unwords - [ "run=" <> runId, - "call=" <> callId, - "strength=" <> Text.pack (show strength) - ] +evidenceSummary ev = + Text.unwords + [ "run=" <> ev.runId, + "call=" <> ev.callId, + "strength=" <> Text.pack (show ev.strength) + ] diff --git a/src/Baikai/Url.hs b/src/Baikai/Url.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Url.hs @@ -0,0 +1,254 @@ +-- | The one place baikai reads a host out of a URL. +-- +-- baikai decides which API key to send and which per-host compatibility +-- record to apply by looking at the host name inside a model's +-- @baseUrl@. That decision routes a credential, so it has to be made the +-- same way everywhere: two parsers that disagree about what host a URL +-- names are two different answers to "where does this key go". +-- +-- This module is deliberately __not__ a validating URI parser. It knows +-- just enough to name a host, key a cache, render an endpoint for an +-- evidence record, and say why a base URL is unusable. It has no +-- dependencies beyond @text@ and @base@, and every function is total. +-- +-- The rule, in full: +-- +-- * Leading and trailing whitespace is stripped. +-- +-- * If the text before the first @\"://\"@ is a syntactically valid +-- scheme — a letter followed by letters, digits, @+@, @-@ or @.@ — +-- that is the scheme, lower-cased, and it is removed. Otherwise there +-- is no scheme and nothing is removed. +-- +-- * The __authority__ is everything up to the first @\/@, @?@ or @#@. +-- This is what RFC 3986 means by the term, and bounding it at all +-- three characters is the point of this module: a URL such as +-- @https:\/\/proxy.example.com\/v1?u=\@api.openai.com@ names the host +-- @proxy.example.com@, and anything that reads the text after the last +-- @\@@ anywhere in the URL will send that proxy another host's key. +-- +-- * Userinfo is everything up to the last @\@@ __inside the authority__, +-- and is dropped. Its presence is recorded; its text never is. +-- +-- * What remains is the host and an optional port. A bracketed IPv6 +-- literal keeps its brackets and its port follows the closing +-- bracket; otherwise the host is the text before the first @:@. A +-- non-numeric port is ignored and the host is still the text before +-- the colon. The host is lower-cased, because DNS names are +-- case-insensitive. +-- +-- * The path is everything from the first @\/@ up to the first @?@ or +-- @#@, kept verbatim — case and trailing slash included. +-- +-- * An empty host means there is no result at all. +module Baikai.Url + ( -- * Parsing + UrlParts (scheme, host, port, path, hasUserInfo, hasQuery, hasFragment), + parseUrl, + urlHost, + hostMatchesSuffix, + + -- * Rendering + renderEndpoint, + stripApiVersion, + + -- * Fitness as a base URL + baseUrlProblem, + ) +where + +import Data.Char (isAlpha, isAlphaNum, isDigit) +import Data.Text (Text) +import Data.Text qualified as Text +import GHC.Generics (Generic) + +-- | The pieces of a URL that baikai needs. +-- +-- Credential-free by construction: userinfo, the query string and the +-- fragment are recorded as /present or absent/ and never as text, so a +-- value of this type cannot carry a secret into a log line. That is why +-- the constructor is not exported — 'parseUrl' is the only producer. +data UrlParts = UrlParts + { -- | Lower-cased scheme without the @\"://\"@, when one was present. + scheme :: !(Maybe Text), + -- | Lower-cased host. An IPv6 literal keeps its brackets: @\"[::1]\"@. + host :: !Text, + -- | The port, when one was given as digits. + port :: !(Maybe Int), + -- | From the first @\/@ up to (not including) @?@ or @#@; @\"\"@ when + -- there was no path. Kept verbatim. + path :: !Text, + -- | Whether a @user:password\@@ prefix was present and dropped. + hasUserInfo :: !Bool, + -- | Whether a @?query@ was present and dropped. + hasQuery :: !Bool, + -- | Whether a @#fragment@ was present and dropped. + hasFragment :: !Bool + } + deriving stock (Eq, Show, Generic) + +-- | Parse a URL far enough to name its host. 'Nothing' when no host can +-- be found, which includes the empty string and a bare scheme. +parseUrl :: Text -> Maybe UrlParts +parseUrl raw + | Text.null hostText = Nothing + | otherwise = + Just + UrlParts + { scheme = parsedScheme, + host = hostText, + port = parsedPort, + path = pathText, + hasUserInfo = userInfoPresent, + hasQuery = queryPresent, + hasFragment = fragmentPresent + } + where + trimmed = Text.strip raw + + -- The scheme is only a scheme when it looks like one. "note://x" has + -- one; ":://x" does not, and neither does a bare "api.openai.com". + (parsedScheme, afterScheme) = case Text.breakOn "://" trimmed of + (candidate, rest) + | not (Text.null rest), + validScheme candidate -> + (Just (Text.toLower candidate), Text.drop 3 rest) + _ -> (Nothing, trimmed) + validScheme s = case Text.uncons s of + Just (c, cs) -> isAlpha c && Text.all schemeChar cs + Nothing -> False + schemeChar c = isAlphaNum c || c == '+' || c == '-' || c == '.' + + -- The authority ends at the first '/', '?' or '#'. Everything this + -- module exists for depends on that boundary. + (authority, afterAuthority) = + Text.break (\c -> c == '/' || c == '?' || c == '#') afterScheme + + -- Userinfo is the last '@' inside the authority, never one later in + -- the path or query. + (userInfoPresent, hostAndPort) = case Text.breakOnEnd "@" authority of + (before, after) | not (Text.null before) -> (True, after) + _ -> (False, authority) + + (hostText, parsedPort) = splitHostPort hostAndPort + + (pathText, afterPath) = + Text.break (\c -> c == '?' || c == '#') afterAuthority + queryPresent = "?" `Text.isPrefixOf` afterPath + fragmentPresent = "#" `Text.isInfixOf` afterPath + +-- | Split @host:port@, keeping an IPv6 literal's brackets together. +splitHostPort :: Text -> (Text, Maybe Int) +splitHostPort raw + | "[" `Text.isPrefixOf` raw = + case Text.breakOn "]" raw of + (literal, rest) + | not (Text.null rest) -> + (Text.toLower (literal <> "]"), portOf (Text.drop 1 rest)) + _ -> (Text.toLower raw, Nothing) + | otherwise = + let (h, rest) = Text.breakOn ":" raw + in (Text.toLower h, portOf rest) + where + -- ":8080" is a port; ":" alone, ":abc" and "" are not, and in every + -- one of those cases the host is still what came before the colon. + portOf rest = case Text.stripPrefix ":" rest of + Just digits + | not (Text.null digits), + Text.all isDigit digits -> + Just (read (Text.unpack digits)) + _ -> Nothing + +-- | The host a URL names, or 'Nothing' when it names none. +urlHost :: Text -> Maybe Text +urlHost = fmap host . parseUrl + +-- | Match a hostname against a suffix at a label boundary, so that +-- @evil-api.openai.com.attacker.test@ does not match @api.openai.com@. +hostMatchesSuffix :: Text -> Text -> Bool +hostMatchesSuffix h suffix = + let lowerHost = Text.toLower (Text.strip h) + lowerSuffix = Text.toLower (Text.strip suffix) + in not (Text.null lowerHost) + && not (Text.null lowerSuffix) + && (lowerHost == lowerSuffix || ("." <> lowerSuffix) `Text.isSuffixOf` lowerHost) + +-- | Render the parts back as an endpoint: scheme, host, port and path, +-- and nothing else. Userinfo, the query and the fragment are gone +-- because 'UrlParts' never held them. +renderEndpoint :: UrlParts -> Text +renderEndpoint parts = + maybe "" (<> "://") (scheme parts) + <> host parts + <> maybe "" (\p -> ":" <> Text.pack (show p)) (port parts) + <> path parts + +-- | Remove one trailing @\/v1@ segment from a path, along with any +-- trailing slashes. +-- +-- Segment-wise, so @\/v10@ and @\/v1beta@ are left alone. The result is +-- either @\"\"@ or a path beginning with @\/@. This is what makes +-- @https:\/\/api.deepseek.com\/v1@ — the base URL every OpenAI SDK +-- teaches — compose to one @\/v1\/chat\/completions@ rather than two. +stripApiVersion :: Text -> Text +stripApiVersion raw + | Text.null trimmed = "" + | otherwise = case Text.stripSuffix "/v1" withLeadingSlash of + Just kept -> kept + Nothing -> withLeadingSlash + where + trimmed = Text.dropWhileEnd (== '/') raw + withLeadingSlash + | "/" `Text.isPrefixOf` trimmed = trimmed + | otherwise = "/" <> trimmed + +-- | Why this text cannot be used as a model's @baseUrl@, or 'Nothing' +-- when it can. +-- +-- Every message names the offending URL with its userinfo and query +-- removed — rendered through 'renderEndpoint', never echoed raw — so an +-- error that reaches a log cannot carry a key someone put in a query +-- parameter. +baseUrlProblem :: Text -> Maybe Text +baseUrlProblem raw = case parseUrl raw of + Nothing -> Just "no host could be found in it" + Just parts + | Nothing <- scheme parts -> + Just (safe parts <> " has no scheme; start it with https:// or http://") + | Just s <- scheme parts, + s /= "http", + s /= "https" -> + Just (safe parts <> " uses the scheme " <> s <> "; only http and https are sent") + | hasUserInfo parts -> + Just + ( safe parts + <> " carries credentials before the host, which are never sent; \ + \use Options.apiKey for the API key or Options.headers for a \ + \gateway header" + ) + | hasQuery parts -> + Just + ( safe parts + <> " has a query string; baikai composes the request path itself \ + \and does not support per-host query parameters such as \ + \?api-version=. Remove it, or front the host with a gateway \ + \that adds it" + ) + | hasFragment parts -> + Just (safe parts <> " has a fragment, which is not part of a request") + | Just ending <- endpointSuffix (path parts) -> + Just + ( safe parts + <> " already ends in the endpoint path " + <> ending + <> "; Model.baseUrl is the API root, and baikai appends the \ + \endpoint path itself" + ) + | otherwise -> Nothing + where + safe = renderEndpoint + endpointSuffix p = + case filter (`Text.isSuffixOf` Text.dropWhileEnd (== '/') p) endpointPaths of + (found : _) -> Just found + [] -> Nothing + endpointPaths = ["/chat/completions", "/messages", "/embeddings"] diff --git a/src/Baikai/Usage.hs b/src/Baikai/Usage.hs --- a/src/Baikai/Usage.hs +++ b/src/Baikai/Usage.hs @@ -22,7 +22,7 @@ -- every cost-reading caller would have to handle. 'Baikai.Cost.Pricing.computeCost' -- depends on the token classes being disjoint so each class is billed -- exactly once. -module Baikai.Usage (Usage (..), zeroUsage, _Usage, sumUsage) where +module Baikai.Usage (Usage (..), zeroUsage, sumUsage) where import Baikai.Cost (Cost, zeroCost) import Data.Aeson @@ -112,7 +112,3 @@ -- | Total a collection of per-call usages into one. sumUsage :: (Foldable f) => f Usage -> Usage sumUsage = foldl' (<>) mempty - -{-# DEPRECATED _Usage "Use zeroUsage instead." #-} -_Usage :: Usage -_Usage = zeroUsage diff --git a/test/AgentAssetsSpec.hs b/test/AgentAssetsSpec.hs --- a/test/AgentAssetsSpec.hs +++ b/test/AgentAssetsSpec.hs @@ -12,7 +12,8 @@ "Baikai.AgentAssets" [ pathTests, layoutTests, - codexTomlTest + codexTomlTest, + codexTomlLiteralBodyTests ] pathTests :: TestTree @@ -64,7 +65,7 @@ codexTomlTest :: TestTree codexTomlTest = - testCase "Codex custom-agent TOML escapes strings and preserves instructions" $ do + testCase "Codex custom-agent TOML uses a literal body and escapes basic strings" $ do codexCustomAgentToml CodexCustomAgent { name = "repo\"reviewer", @@ -74,5 +75,75 @@ @?= Text.unlines [ "name = \"repo\\\"reviewer\"", "description = \"Reviews\\tchanges\"", - "developer_instructions = \"\"\"\nRead first.\nAvoid triple quotes: \\\"\\\"\\\"\n\"\"\"" + -- A literal string interprets nothing, so the three quotation + -- marks in the body need no escape at all; only three + -- apostrophes would, and there are none. + "developer_instructions = \'\'\'\nRead first.\nAvoid triple quotes: \"\"\"\n\'\'\'" ] + +-- | The body of a Codex custom agent is Markdown a human reads in +-- @.codex\/agents\/*.toml@, so it is rendered as a TOML /literal/ +-- multi-line string — delimited by three apostrophes, interpreting +-- nothing — and comes back byte for byte. +-- +-- This is the defect these cases exist for: rendered as a /basic/ +-- string, every backslash in the body is the start of an escape +-- sequence, so a body containing @\\d+@ made Codex refuse to load the +-- file with an unknown-escape error. +-- +-- A literal string cannot contain three apostrophes, a bare carriage +-- return, or any control character other than tab and newline, so such a +-- body falls back to a fully escaped basic string rather than being +-- refused. +codexTomlLiteralBodyTests :: TestTree +codexTomlLiteralBodyTests = + testGroup + "Codex custom-agent bodies" + [ testCase "backslashes render verbatim in a literal string" $ + bodyBlock "Match \\d+ then \\ and stop." + @?= "developer_instructions = \'\'\'\nMatch \\d+ then \\ and stop.\n\'\'\'", + testCase "a body containing three apostrophes falls back to a basic string" $ + bodyBlock "say \'\'\'hi\'\'\'" + @?= "developer_instructions = \"\"\"\nsay \'\'\'hi\'\'\'\n\"\"\"", + testCase "the fallback escapes backslashes and quotation marks" $ + bodyBlock "a\\b \"c\" \'\'\'" + @?= "developer_instructions = \"\"\"\na\\\\b \\\"c\\\" \'\'\'\n\"\"\"", + testCase "a control character in the body forces the fallback and is escaped" $ + bodyBlock "before\SOHafter" + @?= "developer_instructions = \"\"\"\nbefore\\u0001after\n\"\"\"", + testCase "newlines survive the fallback as newlines" $ + bodyBlock "first\nsecond\SOH" + @?= "developer_instructions = \"\"\"\nfirst\nsecond\\u0001\n\"\"\"", + testCase "control characters in name and description are escaped" $ do + let rendered = + Text.lines + ( codexCustomAgentToml + CodexCustomAgent + { name = "x\SOHy", + description = "\DEL", + developerInstructions = "body" + } + ) + take 2 rendered + @?= [ "name = \"x\\u0001y\"", + "description = \"\\u007F\"" + ] + ] + where + -- Everything from the third line on: the body's own delimiters and + -- the lines between them. + bodyBlock body = + Text.intercalate + "\n" + ( drop + 2 + ( Text.lines + ( codexCustomAgentToml + CodexCustomAgent + { name = "n", + description = "d", + developerInstructions = body + } + ) + ) + ) diff --git a/test/AgentSpec.hs b/test/AgentSpec.hs --- a/test/AgentSpec.hs +++ b/test/AgentSpec.hs @@ -18,6 +18,10 @@ multipleViolationTest, emptyAllowedProvidersTest, providerArgsCeilingTest, + toolGrantCeilingTest, + impliedGrantsTest, + timeoutCeilingTest, + outputLimitCeilingTest, violationRenderingTest, capturedOutputTest, failureRenderingTest, @@ -43,8 +47,9 @@ req ^. #safety . #providerArgs @?= [] req ^. #timeout @?= Nothing req ^. #output @?= InheritOutput + req ^. #outputFormat @?= TextFormat req ^. #outputLimit @?= Nothing - req ^. #envPassthrough @?= [] + req ^. #envRequires @?= [] canonicalRenderingTest :: TestTree canonicalRenderingTest = @@ -73,21 +78,50 @@ parseAgentOutputMode "tee" @?= Just TeeOutput parseAgentOutputMode "Tee" @?= Nothing + renderAgentOutputFormat TextFormat @?= "text" + renderAgentOutputFormat JsonFormat @?= "json" + parseAgentOutputFormat "text" @?= Just TextFormat + parseAgentOutputFormat "json" @?= Just JsonFormat + parseAgentOutputFormat "JSON" @?= Nothing + parseAgentOutputFormat "stream-json" @?= Nothing + +-- | A request carrying a per-stream output limit. +-- +-- 'agentRunRequest' defaults 'outputLimit' to 'Nothing', which means +-- \"capture without bound\", and the default ceiling's +-- 'defaultMaxOutputLimit' refuses exactly that. Every case below that is +-- not itself about the output limit starts from this helper, so the +-- violation it asserts is the only one in the list. Jobs resolved +-- through @baikai-agent@ never hit this, because that layer's own +-- default supplies a finite limit. +bounded :: AgentRunRequest -> AgentRunRequest +bounded request = request & #outputLimit .~ Just 4096 + -- | Accepting a request must return it byte-identical. The equality -- assertion against the original value is what proves no clamping -- happened. ceilingAcceptanceTest :: TestTree ceilingAcceptanceTest = testCase "the default ceiling accepts read-only and edit-workspace unchanged" $ do - let readOnly = agentRunRequest AgentClaude "/tmp/work" "look around" - editing = readOnly & #safety .~ agentSafety AgentEditWorkspace + let readOnly = bounded (agentRunRequest AgentClaude "/tmp/work" "look around") + editing = + readOnly + & #safety + .~ (agentSafety AgentEditWorkspace & #allowedTools .~ ["Read", "Edit"]) + & #timeout + .~ Just 600 + & #outputLimit + .~ Just 1024 applyAgentCeiling defaultAgentCeiling readOnly @?= Right readOnly + -- Grants the capability already implies, a timeout under an + -- unlimited maximum, and a limit under the default maximum all pass + -- through untouched. applyAgentCeiling defaultAgentCeiling editing @?= Right editing ceilingRefusalTest :: TestTree ceilingRefusalTest = testCase "the ceiling refuses with the exact violation for each closed channel" $ do - let base = agentRunRequest AgentClaude "/tmp/work" "rewrite everything" + let base = bounded (agentRunRequest AgentClaude "/tmp/work" "rewrite everything") greedy = base & #safety .~ agentSafety AgentFullAccess rawArgs = base @@ -95,7 +129,7 @@ . #providerArgs .~ ["--dangerously-skip-permissions", "--verbose"] claudeOnly = defaultAgentCeiling & #allowedProviders .~ [AgentClaude] - codexRequest = agentRunRequest AgentCodex "/tmp/work" "rewrite everything" + codexRequest = bounded (agentRunRequest AgentCodex "/tmp/work" "rewrite everything") applyAgentCeiling defaultAgentCeiling greedy @?= Left [CapabilityExceeded AgentFullAccess AgentEditWorkspace] applyAgentCeiling defaultAgentCeiling rawArgs @@ -118,7 +152,7 @@ & #allowedProviders .~ [AgentClaude] req = - agentRunRequest AgentCodex "/tmp/work" "rewrite everything" + bounded (agentRunRequest AgentCodex "/tmp/work" "rewrite everything") & #safety .~ ( agentSafety AgentFullAccess & #providerArgs @@ -137,8 +171,8 @@ emptyAllowedProvidersTest = testCase "an empty allowedProviders list permits no provider" $ do let closed = defaultAgentCeiling & #allowedProviders .~ [] - claudeRequest = agentRunRequest AgentClaude "/tmp/work" "hello" - codexRequest = agentRunRequest AgentCodex "/tmp/work" "hello" + claudeRequest = bounded (agentRunRequest AgentClaude "/tmp/work" "hello") + codexRequest = bounded (agentRunRequest AgentCodex "/tmp/work" "hello") applyAgentCeiling closed claudeRequest @?= Left [ProviderForbidden AgentClaude []] applyAgentCeiling closed codexRequest @@ -148,7 +182,7 @@ providerArgsCeilingTest = testCase "raw provider arguments pass only when the operator opens the channel" $ do let req = - agentRunRequest AgentClaude "/tmp/work" "hello" + bounded (agentRunRequest AgentClaude "/tmp/work" "hello") & #safety . #providerArgs .~ ["--some-vendor-flag"] @@ -157,6 +191,92 @@ @?= Left [ProviderArgsForbidden ["--some-vendor-flag"]] applyAgentCeiling permissive req @?= Right req +-- | A tool grant is authority, so the capability decides which grants +-- need no operator involvement and the operator's allow-list supplies +-- the rest. @Bash@ is in neither implied set, which is the whole point +-- of the finding this pins: a repository file granting itself shell +-- access under @edit-workspace@ must be refused. +toolGrantCeilingTest :: TestTree +toolGrantCeilingTest = + testCase "a tool grant needs the capability to imply it or the operator to grant it" $ do + let granting names = + bounded (agentRunRequest AgentClaude "/tmp/work" "look around") + & #safety + .~ (agentSafety AgentEditWorkspace & #allowedTools .~ names) + bash = granting ["Bash"] + applyAgentCeiling defaultAgentCeiling bash + @?= Left [ToolGrantForbidden ["Bash"] AgentEditWorkspace] + applyAgentCeiling (defaultAgentCeiling & #allowedTools .~ ["Bash"]) bash @?= Right bash + applyAgentCeiling (defaultAgentCeiling & #maxCapability .~ AgentFullAccess) bash + @?= Right bash + -- Matching is exact on the whole string. A pattern-scoped grant is a + -- different grant, so granting the bare name does not permit it and + -- an operator who wants it writes it out. + let scoped = granting ["Bash(git *)"] + applyAgentCeiling (defaultAgentCeiling & #allowedTools .~ ["Bash"]) scoped + @?= Left [ToolGrantForbidden ["Bash(git *)"] AgentEditWorkspace] + -- Grants the capability already implies need no operator at all, + -- and only the forbidden ones are named in the refusal. + applyAgentCeiling defaultAgentCeiling (granting ["Read", "Write", "Bash", "WebFetch"]) + @?= Left [ToolGrantForbidden ["Bash", "WebFetch"] AgentEditWorkspace] + +-- | The implied grant lists are a security boundary, so they are pinned +-- name by name rather than by a property. A name added here widens every +-- ceiling in existence, which should require editing this test. +impliedGrantsTest :: TestTree +impliedGrantsTest = + testCase "each capability implies exactly the documented grants" $ do + toolGrantsImpliedBy AgentReadOnly + @?= Just ["Read", "Glob", "Grep", "NotebookRead", "TodoWrite"] + toolGrantsImpliedBy AgentEditWorkspace + @?= Just + [ "Read", + "Glob", + "Grep", + "NotebookRead", + "TodoWrite", + "Edit", + "MultiEdit", + "Write", + "NotebookEdit" + ] + toolGrantsImpliedBy AgentFullAccess @?= Nothing + +-- | A finite maximum bounds a requested timeout and also refuses a job +-- that requests none, because a maximum an operator can defeat by +-- omitting the setting is not a maximum. +timeoutCeilingTest :: TestTree +timeoutCeilingTest = + testCase "a finite max-timeout refuses a longer run and an untimed one" $ do + let twoHours = defaultAgentCeiling & #maxTimeout .~ Just 7200 + asking limit = bounded (agentRunRequest AgentClaude "/tmp/work" "work") & #timeout .~ limit + applyAgentCeiling twoHours (asking (Just 3600)) @?= Right (asking (Just 3600)) + applyAgentCeiling twoHours (asking (Just 7200)) @?= Right (asking (Just 7200)) + applyAgentCeiling twoHours (asking (Just 10800)) + @?= Left [TimeoutExceeded (Just 10800) 7200] + applyAgentCeiling twoHours (asking Nothing) @?= Left [TimeoutExceeded Nothing 7200] + -- The default maximum is unlimited, so an untimed run passes. + applyAgentCeiling defaultAgentCeiling (asking Nothing) @?= Right (asking Nothing) + +-- | The default maximum is finite, so @unlimited@ is refused until the +-- operator opens it. The memory belongs to the operator's host. +outputLimitCeilingTest :: TestTree +outputLimitCeilingTest = + testCase "a finite max-output-limit refuses a larger capture and an unlimited one" $ do + let asking limit = + bounded (agentRunRequest AgentClaude "/tmp/work" "work") & #outputLimit .~ limit + unbounded = defaultAgentCeiling & #maxOutputLimit .~ Nothing + defaultMaxOutputLimit @?= 67108864 + applyAgentCeiling defaultAgentCeiling (asking (Just 1024)) + @?= Right (asking (Just 1024)) + applyAgentCeiling defaultAgentCeiling (asking (Just defaultMaxOutputLimit)) + @?= Right (asking (Just defaultMaxOutputLimit)) + applyAgentCeiling defaultAgentCeiling (asking (Just (defaultMaxOutputLimit + 1))) + @?= Left [OutputLimitExceeded (Just (defaultMaxOutputLimit + 1)) defaultMaxOutputLimit] + applyAgentCeiling defaultAgentCeiling (asking Nothing) + @?= Left [OutputLimitExceeded Nothing defaultMaxOutputLimit] + applyAgentCeiling unbounded (asking Nothing) @?= Right (asking Nothing) + -- | Pin that both the requested and the permitted value appear, not -- the exact sentence, so wording can improve without breaking tests. violationRenderingTest :: TestTree @@ -187,6 +307,48 @@ ("expected both providers in: " <> Text.unpack providerMessage) ("codex" `Text.isInfixOf` providerMessage && "claude" `Text.isInfixOf` providerMessage) + -- A grant refusal must name what to do about it, because the fix is + -- in a file the person reading the message may not know exists. + let grantMessage = + renderCeilingViolation (ToolGrantForbidden ["Bash", "Skill"] AgentEditWorkspace) + mapM_ + ( \fragment -> + assertBool + ("expected " <> Text.unpack fragment <> " in: " <> Text.unpack grantMessage) + (fragment `Text.isInfixOf` grantMessage) + ) + ["Bash", "Skill", "edit-workspace", "policy.allowed-tools"] + + -- Durations are rendered in the spellings the configuration parser + -- accepts, so an operator can paste the maximum back into their file. + let overTime = renderCeilingViolation (TimeoutExceeded (Just 10800) 7200) + untimed = renderCeilingViolation (TimeoutExceeded Nothing 7200) + assertBool + ("expected both durations in: " <> Text.unpack overTime) + ("3h" `Text.isInfixOf` overTime && "2h" `Text.isInfixOf` overTime) + assertBool + ("expected the permitted maximum in: " <> Text.unpack untimed) + ("2h" `Text.isInfixOf` untimed && "no timeout" `Text.isInfixOf` untimed) + + let overBytes = renderCeilingViolation (OutputLimitExceeded (Just 99999999) 67108864) + unlimitedBytes = renderCeilingViolation (OutputLimitExceeded Nothing 67108864) + assertBool + ("expected both byte counts in: " <> Text.unpack overBytes) + ("99999999" `Text.isInfixOf` overBytes && "67108864" `Text.isInfixOf` overBytes) + assertBool + ("expected the word unlimited in: " <> Text.unpack unlimitedBytes) + ("unlimited" `Text.isInfixOf` unlimitedBytes && "67108864" `Text.isInfixOf` unlimitedBytes) + + let scopeMessage = renderCeilingViolation (RepositoryScopeForbidden "executable") + assertBool + ("expected the setting name in: " <> Text.unpack scopeMessage) + ("executable" `Text.isInfixOf` scopeMessage) + let outsideMessage = + renderCeilingViolation (WorkingDirOutsideRepository "/etc" "/tmp/checkout") + assertBool + ("expected both paths in: " <> Text.unpack outsideMessage) + ("/etc" `Text.isInfixOf` outsideMessage && "/tmp/checkout" `Text.isInfixOf` outsideMessage) + capturedOutputTest :: TestTree capturedOutputTest = testCase "capturedBytes distinguishes uncaptured output from empty output" $ do @@ -207,10 +369,9 @@ ] runFailures = [ SpawnFailed "/usr/local/bin/claude" "no such file or directory", - RunTimedOut 90, + RunTimedOut (AgentTimedOut 90 OutputNotCaptured OutputNotCaptured), MissingEnvironment ["KEIRO_PATH", "ANTHROPIC_API_KEY"], - WorkingDirMissing "/tmp/gone", - OutputMalformed "expected JSON, got a banner" + WorkingDirMissing "/tmp/gone" ] mapM_ ( \e -> diff --git a/test/CatalogSpec.hs b/test/CatalogSpec.hs --- a/test/CatalogSpec.hs +++ b/test/CatalogSpec.hs @@ -18,11 +18,28 @@ -- JSON file changed without a paired regeneration. module CatalogSpec (tests) where +import Baikai.Api (Api (AnthropicMessages)) +import Baikai.Compat + ( AnthropicMessagesCompat, + AnthropicThinkingStyle (..), + supportsSamplingParameters, + thinkingStyle, + ) +import Baikai.Model + ( Compat (CompatAnthropicMessages), + Model, + api, + compat, + modelId, + ) +import Baikai.Models.Generated (allModels) import Data.ByteString qualified as BS +import Data.List (sort) +import Data.Text (Text) import System.IO.Temp (withSystemTempDirectory) import System.Process (callProcess) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertEqual, testCase) +import Test.Tasty.HUnit (assertEqual, assertFailure, testCase, (@?=)) tests :: TestTree tests = @@ -39,5 +56,56 @@ "Generated.hs is out of sync with data/models/*.json.\n\ \Run `cabal run baikai-gen-models` and commit the result." committed - regenerated + regenerated, + -- Which extended-thinking wire shape a generation accepts, and + -- whether it accepts sampling parameters, cannot be recovered + -- from the model id or the base URL. Every Anthropic catalog + -- entry must therefore carry an explicit compat record stating + -- both, and this table is where the shipped values are pinned: + -- a catalog refresh that changes one has to change this row too. + testCase "every Anthropic catalog entry carries an explicit thinking style and sampling flag" $ do + assertEqual + "the pinned table must cover exactly the catalog's Anthropic ids" + (sort (map fst expectedAnthropicFacts)) + (sort (map modelId anthropicCatalogModels)) + mapM_ assertFacts anthropicCatalogModels ] + +-- | Every Anthropic model in the generated catalog. +anthropicCatalogModels :: [Model] +anthropicCatalogModels = [m | m <- allModels, api m == AnthropicMessages] + +-- | The shipped thinking style and sampling support of each Anthropic +-- catalog id, written out by hand from +-- @baikai\/data\/models\/anthropic.json@. +expectedAnthropicFacts :: [(Text, (AnthropicThinkingStyle, Bool))] +expectedAnthropicFacts = + [ ("claude-fable-5", (AnthropicThinkingAdaptive, False)), + ("claude-haiku-4-5", (AnthropicThinkingBudget, True)), + ("claude-opus-4-5", (AnthropicThinkingBudget, True)), + ("claude-opus-4-6", (AnthropicThinkingAdaptive, True)), + ("claude-opus-4-7", (AnthropicThinkingAdaptive, False)), + ("claude-opus-4-8", (AnthropicThinkingAdaptive, False)), + ("claude-opus-5", (AnthropicThinkingAdaptive, False)), + ("claude-sonnet-4-5", (AnthropicThinkingBudget, True)), + ("claude-sonnet-4-6", (AnthropicThinkingAdaptive, True)), + ("claude-sonnet-5", (AnthropicThinkingAdaptive, False)) + ] + +assertFacts :: Model -> IO () +assertFacts m = case compat m of + CompatAnthropicMessages c -> case lookup (modelId m) expectedAnthropicFacts of + Just expected -> facts c @?= expected + Nothing -> + assertFailure + ("no pinned facts for Anthropic catalog model " <> show (modelId m)) + other -> + assertFailure + ( "Anthropic catalog model " + <> show (modelId m) + <> " must carry an explicit CompatAnthropicMessages record, not " + <> show other + ) + where + facts :: AnthropicMessagesCompat -> (AnthropicThinkingStyle, Bool) + facts c = (thinkingStyle c, supportsSamplingParameters c) diff --git a/test/CliInternalSpec.hs b/test/CliInternalSpec.hs --- a/test/CliInternalSpec.hs +++ b/test/CliInternalSpec.hs @@ -18,11 +18,13 @@ import Data.Generics.Labels () import Data.List (isInfixOf) import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text import Data.Vector qualified as Vector import Streamly.Data.Stream qualified as Stream import System.Directory (doesFileExist, getPermissions, setOwnerExecutable, setPermissions) import System.FilePath (()) import System.IO.Temp (withSystemTempDirectory) +import System.Timeout qualified as Timeout import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -149,7 +151,41 @@ [ "{\"type\":\"turn.completed\",\ \\"usage\":{\"input_tokens\":5,\"cached_input_tokens\":9,\"output_tokens\":1}}\n" ] - fmap (^. #inputTokens) (report ^. #usage) @?= Just 0 + fmap (^. #inputTokens) (report ^. #usage) @?= Just 0, + -- Chunk boundaries are the operating system's business, not the + -- codex event schema's: a pipe read returns whatever bytes had + -- arrived, which for a long event is the middle of a line. + testCase "a line spanning several chunks is one event" $ do + report <- + parseCodex + [ "{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_mess", + "age\",\"text\":\"split\"}}\n" + ] + report ^. #message @?= "split", + testCase "a final line without a newline is still parsed" $ do + report <- + parseCodex + ["{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"last\"}}"] + report ^. #message @?= "last", + -- The previous implementation appended one byte at a time with + -- BS.snoc, copying the whole accumulator per byte: quadratic in + -- line length, so a two-million-character message cost on the + -- order of a trillion byte moves and never finished. The bound is + -- what makes this a test rather than a benchmark. + testCase "a multi-megabyte event is assembled in linear time" $ do + let body = Text.replicate 2000000 "a" + event = + Text.encodeUtf8 + ( "{\"type\":\"item.completed\",\"item\":{\"type\":\"agent_message\",\"text\":\"" + <> body + <> "\"}}\n" + ) + finished <- Timeout.timeout 10000000 (parseCodex [event]) + case finished of + Nothing -> + assertFailure + "assembling one two-megabyte event did not finish within ten seconds" + Just report -> Text.length (report ^. #message) @?= 2000000 ] -- ============================================================ diff --git a/test/ContextSpec.hs b/test/ContextSpec.hs --- a/test/ContextSpec.hs +++ b/test/ContextSpec.hs @@ -15,7 +15,29 @@ [ monoidTests, constructorTests, timestampTests, - flattenTextTests + flattenTextTests, + toolResultTests + ] + +-- | A failed call has no assistant turn worth replaying and no tool +-- calls to answer, so 'appendToolResult' appends nothing and runs +-- nothing. 'runToolLoop' has always stopped on such a response; the +-- documented direct round trip reaches here instead. +toolResultTests :: TestTree +toolResultTests = + testGroup + "appendToolResult" + [ testCase "an error-shaped response leaves the context unchanged and never dispatches" $ do + let ctx = contextOf [user "go"] + failed = + errorResponse + emptyModel + (read "2026-06-05 01:02:03 UTC" :: UTCTime) + 12 + (providerError "upstream died") + explode _ = error "the dispatcher must not run for an error-shaped response" + after <- appendToolResult ctx failed explode + after @?= ctx ] monoidTests :: TestTree diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -5,20 +5,21 @@ import Baikai.Context (Context (..), emptyContext) import Baikai.Cost qualified as Cost import Baikai.Cost.Log - ( CallLogConfig (..), - CallLogEntry (..), + ( CallLogEntry (..), appendEntry, + callLogConfig, + closeCallLog, + openCallLog, runRequestWithLog, withCallLog, ) import Baikai.Cost.Pricing (attachCost, computeCost) -import Baikai.Evidence (noThinkingRequested) import Baikai.Message (AssistantPayload (..), user) import Baikai.Model (Model (..), ModelCost (..), emptyModel) import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider - ( ApiProvider (..), + ( apiProviderWith, registerApiProvider, ) import Baikai.Response (Response (..), flattenAssistantBlocks) @@ -29,7 +30,7 @@ import Data.ByteString.Lazy.Char8 qualified as BSL import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Maybe (fromJust, isJust) -import Data.Time (getCurrentTime) +import Data.Time (UTCTime, getCurrentTime) import Data.Vector qualified as V import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath (()) @@ -177,12 +178,11 @@ registerCanned resp = let handler _m _ctx _opts = pure resp in registerApiProvider - ApiProvider - { apiTag = cannedApi, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + cannedApi + (liftCompleteToStream handler) + (handler) + ) cannedModel :: Model cannedModel = knownModel & #api .~ cannedApi @@ -199,7 +199,7 @@ "CallLog" [ testCase "disabled handle skips disk I/O" $ do registerCanned cannedHaiku - let cfg = CallLogConfig {path = "/dev/null", enabled = False} + let cfg = callLogConfig "/dev/null" & #enabled .~ False withCallLog cfg $ \h -> do resp <- runRequestWithLog h cannedModel ctxHello optsZero flattenAssistantBlocks resp @@ -209,7 +209,7 @@ tmp <- getTemporaryDirectory let path' = tmp "baikai-cost-test.jsonl" writeFile path' "" - let cfg = CallLogConfig {path = path', enabled = True} + let cfg = callLogConfig path' withCallLog cfg $ \h -> do _ <- runRequestWithLog h cannedModel ctxHello optsZero pure () @@ -234,21 +234,42 @@ testCase "closeCallLog returns even when the log path is unwritable" $ do tmp <- getTemporaryDirectory let missing = tmp "baikai-costspec-no-such-dir" "entries.jsonl" - cfg = CallLogConfig {path = missing, enabled = True} + cfg = callLogConfig missing now <- getCurrentTime - let entry = - CallLogEntry - { timestamp = now, - provider = "test", - model = "m", - inputTokens = Nothing, - outputTokens = Nothing, - cachedInputTokens = Nothing, - reasoningTokens = Nothing, - usd = Nothing, - latencyMs = 0, - promptSummary = "" - } - result <- timeout 5000000 (withCallLog cfg (\h -> appendEntry h entry)) + result <- timeout 5000000 (withCallLog cfg (\h -> appendEntry h (sampleEntry now))) + result @?= Just (), + -- 'withCallLog' brackets a close around a body that may also close + -- the handle, so the second close is a shape a caller reaches by + -- accident. Before the claim it blocked forever on an 'MVar' the + -- worker had already emptied. + testCase "closeCallLog twice returns and appendEntry after close is a no-op" $ do + tmp <- getTemporaryDirectory + let path' = tmp "baikai-costspec-double-close.jsonl" + writeFile path' "" + let cfg = callLogConfig path' + h <- openCallLog cfg + result <- timeout 5000000 (closeCallLog h >> closeCallLog h) result @?= Just () + now <- getCurrentTime + appendEntry h (sampleEntry now) + raw <- BSL.readFile path' + BSL.length raw @?= 0 + removeFile path' ] + +-- | A minimal entry, shared by the call-log cases that need one to +-- enqueue rather than one to inspect. +sampleEntry :: UTCTime -> CallLogEntry +sampleEntry now = + CallLogEntry + { timestamp = now, + provider = "test", + model = "m", + inputTokens = Nothing, + outputTokens = Nothing, + cachedInputTokens = Nothing, + reasoningTokens = Nothing, + usd = Nothing, + latencyMs = 0, + promptSummary = "" + } diff --git a/test/EmbeddingSpec.hs b/test/EmbeddingSpec.hs --- a/test/EmbeddingSpec.hs +++ b/test/EmbeddingSpec.hs @@ -1,4 +1,4 @@ --- | Tests for the embeddings client (EP-15, M1). +-- | Tests for the embeddings client. -- -- The request-mapping test is hermetic: it asserts on the pure -- 'mkEmbeddingRequest' (no network), proving the input text, model id, and @@ -7,14 +7,32 @@ -- default run stays offline. module EmbeddingSpec (tests) where -import Baikai.Embedding (embedOne, firstEmbedding, mkEmbeddingRequest, openAIEmbeddingModel) -import Baikai.Error (decodeError) +import Baikai.Auth (ApiKeySource (..)) +import Baikai.Embedding + ( EmbeddingModel (..), + embedOne, + embeddingClientEnv, + emptyEmbeddingModel, + firstEmbedding, + mkEmbeddingRequest, + openAIEmbeddingModel, + resolveEmbeddingKey, + ) +import Baikai.Error (BaikaiError, ErrorCategory (..), decodeError) +import Baikai.Http qualified as Http +import Control.Exception qualified as Exception +import Control.Lens ((&), (.~), (^.)) +import Data.Generics.Labels () +import Data.Text (Text) +import Data.Text qualified as Text import Data.Vector qualified as V import OpenAI.V1.Embeddings qualified as Emb import OpenAI.V1.Models qualified as OpenAIModels +import Servant.Client qualified as Client import System.Environment (lookupEnv) +import System.Environment qualified as Environment import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) tests :: TestTree tests = @@ -36,6 +54,54 @@ Emb.object = "embedding" } firstEmbedding (V.singleton obj) @?= Right vec, + testCase "an embedding host resolves its own key, not OpenAI's" $ do + -- The defect: whatever the base URL said, the default key was + -- OPENAI_API_KEY. Pointing an EmbeddingModel at DeepSeek sent an + -- OpenAI key to DeepSeek. + withEnv "OPENAI_API_KEY" (Just "openai-secret") $ + withEnv "DEEPSEEK_API_KEY" Nothing $ do + err <- + expectAuthError + (emptyEmbeddingModel & #baseUrl .~ "https://api.deepseek.com") + assertBool + ("names the host's own variable: " <> Text.unpack (err ^. #message)) + ("DEEPSEEK_API_KEY" `Text.isInfixOf` (err ^. #message)), + testCase "an unknown embedding host refuses rather than sending OpenAI's key" $ + withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do + err <- + expectAuthError + (emptyEmbeddingModel & #baseUrl .~ "https://vectors.example") + assertBool + ("says what to set: " <> Text.unpack (err ^. #message)) + ("EmbeddingModel.apiKey" `Text.isInfixOf` (err ^. #message)), + testCase "the OpenAI default still resolves OPENAI_API_KEY" $ + withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do + resolved <- resolveEmbeddingKey (openAIEmbeddingModel "text-embedding-3-small") + resolved @?= "openai-secret", + testCase "an explicit key source wins over the per-host table" $ + withEnv "OPENAI_API_KEY" (Just "openai-secret") $ do + resolved <- + resolveEmbeddingKey + ( openAIEmbeddingModel "m" + & #apiKey + .~ Just (ApiKeyLiteral "explicit-key") + ) + resolved @?= "explicit-key", + testCase "embeddings share the connection cache with the chat providers" $ do + -- One TLS manager per host, not one per call: the SDK's own + -- getClientEnv allocated a fresh manager every time embed ran. + before <- Http.cachedClientEnvCount + _ <- embeddingClientEnv (emptyEmbeddingModel & #baseUrl .~ "https://embed-cache.test") + env <- embeddingClientEnv (emptyEmbeddingModel & #baseUrl .~ "https://Embed-Cache.test/") + afterBoth <- Http.cachedClientEnvCount + afterBoth @?= before + 1 + Client.baseUrlHost (Client.baseUrl env) @?= "embed-cache.test" + Client.baseUrlPath (Client.baseUrl env) @?= "", + testCase "the #field idiom compiles on EmbeddingModel" $ do + -- It could not before: the record derived neither Generic nor Eq. + let m = openAIEmbeddingModel "m" & #dimensions .~ Just 256 + m ^. #dimensions @?= Just 256 + m @?= (openAIEmbeddingModel "m" & #dimensions .~ Just 256), testCase "live embedding returns a 1536-length vector" $ do live <- lookupEnv "BAIKAI_EMBEDDING_LIVE" case live of @@ -44,3 +110,29 @@ V.length v @?= 1536 _ -> putStrLn "BAIKAI_EMBEDDING_LIVE not set; skipping live test" ] + +-- | Resolve a model's key, expecting it to refuse. +expectAuthError :: EmbeddingModel -> IO BaikaiError +expectAuthError m = do + thrown <- Exception.try (resolveEmbeddingKey m) :: IO (Either BaikaiError Text) + case thrown of + Right key -> assertFailure ("expected an AuthError, got a key: " <> Text.unpack key) + Left err -> do + err ^. #category @?= AuthError + pure err + +-- | Run an action with one environment variable set to a value, or +-- removed, restoring whatever was there before. +withEnv :: String -> Maybe String -> IO a -> IO a +withEnv name value action = + Exception.bracket + ( do + old <- Environment.lookupEnv name + apply value + pure old + ) + apply + (const action) + where + apply Nothing = Environment.unsetEnv name + apply (Just v) = Environment.setEnv name v diff --git a/test/ErrorInfoSpec.hs b/test/ErrorInfoSpec.hs --- a/test/ErrorInfoSpec.hs +++ b/test/ErrorInfoSpec.hs @@ -51,12 +51,11 @@ registerErr :: IO () registerErr = registerApiProvider - ApiProvider - { apiTag = errApi, - stream = errStream, - complete = streamingComplete errStream, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + errApi + (errStream) + (streamingComplete errStream) + ) tests :: TestTree tests = diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -9,10 +9,13 @@ httpError, invalidRequest, isRetryable, + parseHttpDate, parseRetryAfterSeconds, processError, rateLimited, + retryAfterSecondsAt, ) +import Data.Time (UTCTime) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -36,15 +39,45 @@ category e @?= RateLimited httpStatus e @?= Just 429 retryAfterSeconds e @?= Just 12, + -- Re-homed from the provider suites' servant fixtures: the + -- assertion is about 'httpError', which is where it belongs. + testCase "429 without Retry-After -> RateLimited, no hint" $ do + let e = httpError 429 Nothing "slow down" + category e @?= RateLimited + retryAfterSeconds e @?= Nothing, testCase "400 + overflow body -> ContextOverflow" $ category (httpError 400 Nothing "maximum context length exceeded") @?= ContextOverflow, testCase "integer Retry-After parses as seconds" $ parseRetryAfterSeconds "12" @?= Just 12, - testCase "HTTP-date Retry-After is ignored" $ - parseRetryAfterSeconds "Wed, 21 Oct 2026 07:28:00 GMT" @?= Nothing + -- The integer-only contract is now deliberate rather than a + -- limitation: converting a date needs a reference instant, which + -- 'retryAfterSecondsAt' takes and this function cannot. + testCase "parseRetryAfterSeconds is integer-only" $ + parseRetryAfterSeconds "Wed, 21 Oct 2026 07:28:00 GMT" @?= Nothing, + testCase "HTTP-date Retry-After yields seconds from the reference instant" $ + retryAfterSecondsAt referenceInstant "Wed, 21 Oct 2026 07:28:00 GMT" @?= Just 30, + -- The server is saying "now", not "some time last week". + testCase "HTTP-date Retry-After in the past yields zero" $ + retryAfterSecondsAt referenceInstant "Wed, 21 Oct 2026 07:00:00 GMT" @?= Just 0, + testCase "integer Retry-After ignores the reference instant" $ + retryAfterSecondsAt referenceInstant "12" @?= Just 12, + testCase "malformed Retry-After yields Nothing" $ + retryAfterSecondsAt referenceInstant "soonish" @?= Nothing, + testCase "parseHttpDate accepts IMF-fixdate, RFC 850 and asctime" $ do + let expected = Just (read "1994-11-06 08:49:37 UTC" :: UTCTime) + parseHttpDate "Sun, 06 Nov 1994 08:49:37 GMT" @?= expected + parseHttpDate "Sunday, 06-Nov-94 08:49:37 GMT" @?= expected + parseHttpDate "Sun Nov 6 08:49:37 1994" @?= expected, + testCase "parseHttpDate rejects text that is not a date" $ + parseHttpDate "tomorrow" @?= Nothing ] +-- | Thirty seconds before the @Retry-After@ date the cases above use, so +-- the expected answer is a number a reader can check by eye. +referenceInstant :: UTCTime +referenceInstant = read "2026-10-21 07:27:30 UTC" + bodyClassifyTests :: TestTree bodyClassifyTests = testGroup @@ -62,7 +95,13 @@ classifyHttpStatusWithBody 429 Nothing "context length whatever" @?= RateLimited, testCase "500 defers to status -> TransientError" $ - classifyHttpStatusWithBody 500 Nothing "context length" @?= TransientError + classifyHttpStatusWithBody 500 Nothing "context length" @?= TransientError, + -- 413 is the size-limit status, so the body's wording changes + -- nothing: the caller's remedy is to shrink the input either way. + testCase "413 + ordinary body -> ContextOverflow" $ + classifyHttpStatusWithBody 413 Nothing "payload too large" @?= ContextOverflow, + testCase "413 + request_too_large body -> ContextOverflow" $ + classifyHttpStatusWithBody 413 Nothing "request_too_large" @?= ContextOverflow ] classifyTests :: TestTree @@ -79,6 +118,7 @@ testCase "500 -> TransientError" $ classifyHttpStatus 500 Nothing @?= TransientError, testCase "502 -> TransientError" $ classifyHttpStatus 502 Nothing @?= TransientError, testCase "503 -> TransientError" $ classifyHttpStatus 503 Nothing @?= TransientError, + testCase "413 -> ContextOverflow" $ classifyHttpStatus 413 Nothing @?= ContextOverflow, testCase "418 -> OtherError" $ classifyHttpStatus 418 Nothing @?= OtherError ] diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -1,11 +1,16 @@ +{-# LANGUAGE OverloadedRecordDot #-} + -- | Tests for "Baikai.Evidence": that the canonical encoding really is -- canonical, that the two digests differ in exactly the way they are -- documented to, and that the configuration projection lets no content -- through. module EvidenceSpec (tests) where +import Baikai.Cost (Cost (..), zeroCost) import Baikai.Evidence import Baikai.Provider.Cli.Internal qualified as Internal +import Baikai.ThinkingLevel (ThinkingLevel (..)) +import Baikai.Usage (Usage (..), zeroUsage) import Control.Concurrent (threadDelay) import Control.Monad (replicateM) import Data.Aeson (Value (Number, Object, String), object, (.=)) @@ -24,12 +29,61 @@ "Evidence" [ canonicalTests, digestTests, + usageEnvelopeTests, + deriveStrengthTests, redactionTests, observedTests, + adjustmentJsonTests, callIdTests ] -- ============================================================ +-- Adjustment JSON +-- ============================================================ + +-- | Every adjustment kind, through JSON and back. +-- +-- The two sampling kinds carry a @fields@ array and no @requested@ +-- level, so a decoder that reads @requested@ before it reads @kind@ +-- fails on them. Round-tripping every constructor is what keeps that +-- ordering honest as constructors are added. +adjustmentJsonTests :: TestTree +adjustmentJsonTests = + testGroup + "ThinkingAdjustment JSON" + ( [ testCase (show adjustment) (roundTripAdjustment adjustment) + | adjustment <- + [ EffortClamped ThinkingMax "high", + EffortCollapsedToToggle ThinkingHigh, + EffortOmitted ThinkingHigh, + ThinkingDroppedUnsupportedModel ThinkingLow, + ThinkingDroppedUnsupportedHost ThinkingMinimal, + ThinkingDroppedBudgetExceeded ThinkingMax 32000 8192, + SamplingDroppedUnsupportedModel ["temperature", "top_p"], + SamplingDroppedUnsupportedApi ["seed", "frequency_penalty", "presence_penalty"] + ] + ] + <> [ testCase "a sampling drop encodes its kind and fields and no requested level" $ + Aeson.toJSON (SamplingDroppedUnsupportedModel ["temperature", "top_p"]) + @?= Aeson.object + [ "kind" Aeson..= ("sampling_dropped_unsupported_model" :: Text.Text), + "fields" Aeson..= (["temperature", "top_p"] :: [Text.Text]) + ], + testCase "an API-level sampling drop names its own kind" $ + Aeson.toJSON (SamplingDroppedUnsupportedApi ["seed"]) + @?= Aeson.object + [ "kind" Aeson..= ("sampling_dropped_unsupported_api" :: Text.Text), + "fields" Aeson..= (["seed"] :: [Text.Text]) + ] + ] + ) + where + roundTripAdjustment :: ThinkingAdjustment -> IO () + roundTripAdjustment v = case Aeson.fromJSON (Aeson.toJSON v) of + Aeson.Success v' -> v' @?= v + Aeson.Error e -> assertFailure ("round trip failed: " <> e) + +-- ============================================================ -- Canonical encoding -- ============================================================ @@ -118,14 +172,20 @@ -- changed, and every digest recorded by an earlier build has -- become unverifiable. That is a major bump of -- evidenceSchemaVersion, not a value to paste over. + -- + -- Both values changed at schema version 2.0, because the fixture + -- gained an `output_config` and a `response_format` and the + -- projection now summarises both. They were recomputed only after + -- the redaction group above was green: a golden value pasted while + -- a marker still leaked would pin the leak. testCase "the request commitment matches the golden value" $ do env <- loadFixture commitmentDigest env - @?= "sha256:ee1baf81dad750bb61bbcd6a737b8266c206a4288403510be5e10cace20b5798", + @?= "sha256:7328ef9e177fbf71793c2167c25749b98845ecc5ea1cf9cd5a38ef3aa52d3b0b", testCase "the configuration digest matches the golden value" $ do env <- loadFixture configurationDigest env - @?= "sha256:858f0d5ec35ba6f8bac39140c6523785abcbf4e8007c770c1ba2e13f0e72d6b5", + @?= "sha256:5ed62ecd1a00798c06de88363e9f6a591610449f1e06fa8bd8260ee7934ea366", testCase "the configuration digest ignores content, the commitment does not" $ do let ask subject = object @@ -156,6 +216,84 @@ ] -- ============================================================ +-- The one strength rule +-- ============================================================ + +-- | All eight combinations, one named case per row. +-- +-- Three copies of this rule had drifted: the subprocess one counted a +-- session or thread id as correlation while the two API ones looked only +-- at a captured header, so a host reporting @model@ and @id@ on every +-- chunk but no header landed below a host that sent only a header. +deriveStrengthTests :: TestTree +deriveStrengthTests = + testGroup + "deriveStrength" + [ row "nothing observed" Unobserved Unobserved Unobserved EvidenceRequestedOnly, + row "a model alone does not climb the scale" (Observed "m") Unobserved Unobserved EvidenceRequestedOnly, + row "a request id alone is correlation" Unobserved (Observed "req") Unobserved EvidenceCorrelated, + row "A RESPONSE ID ALONE IS ALSO CORRELATION" Unobserved Unobserved (Observed "resp") EvidenceCorrelated, + row "both identifiers are still correlation" Unobserved (Observed "req") (Observed "resp") EvidenceCorrelated, + row "a model with a request id is model_observed" (Observed "m") (Observed "req") Unobserved EvidenceModelObserved, + row "A MODEL WITH A RESPONSE ID IS ALSO model_observed" (Observed "m") Unobserved (Observed "resp") EvidenceModelObserved, + row "a model with both identifiers is model_observed" (Observed "m") (Observed "req") (Observed "resp") EvidenceModelObserved, + testCase "nothing reaches fully_observed" $ + assertBool + "no combination of these three observations may reach the top of the scale" + ( all + (< EvidenceFullyObserved) + [ deriveStrength o r i + | o <- both, + r <- both, + i <- both + ] + ) + ] + where + row name observedModel requestId responseId expected = + testCase name (deriveStrength observedModel requestId responseId @?= expected) + both = [Unobserved, Observed "x"] + +-- ============================================================ +-- The usage a response digest commits to +-- ============================================================ + +usageEnvelopeTests :: TestTree +usageEnvelopeTests = + testGroup + "usage envelope" + [ testCase "two usages differing only in cost produce the same envelope" $ do + -- The cost is computed here from the caller's catalog rates, not + -- read off the response, so a verifier holding only the response + -- could not recompute a digest that covered it — and the digest + -- changed whenever a price was edited. + let cheap = zeroUsage {inputTokens = 10, outputTokens = 20} + dear = cheap {cost = zeroCost {usd = 1234}} + usageEnvelope cheap @?= usageEnvelope dear, + testCase "the encoded envelope carries no cost key" $ do + let encoded = BS8.unpack (canonicalEncode (usageEnvelope zeroUsage)) + assertBool + ("cost survived into the usage envelope: " <> encoded) + (not ("cost" `isInfix` encoded)) + mapM_ + ( \k -> + assertBool + (k <> " missing from the usage envelope: " <> encoded) + (k `isInfix` encoded) + ) + [ "input_tokens", + "output_tokens", + "cache_read_tokens", + "cache_write_tokens", + "reasoning_tokens", + "total_tokens" + ] + ] + where + isInfix needle haystack = + Text.isInfixOf (Text.pack needle) (Text.pack haystack) + +-- ============================================================ -- Redaction -- ============================================================ @@ -182,7 +320,18 @@ "SYSTEM-PROMPT-BODY-MARKER", "REASONING-TEXT-MARKER", "TOOL-PAYLOAD-MARKER", - "Fetch a quarterly report by identifier." + "Fetch a quarterly report by identifier.", + -- A JSON schema is content wherever it appears. These two + -- markers sit in the `description` of a structured-output + -- schema reached two different ways: Anthropic's + -- `output_config.format.schema` and the OpenAI-compatible + -- `response_format.json_schema.schema`. The fixture is one + -- recorded envelope serving both the digest and the + -- redaction tests, and it already carries a non-wire + -- `extra_headers` key, so mixing an OpenAI-shaped key into + -- an Anthropic-shaped body is in keeping. + "OUTPUT-SCHEMA-MARKER", + "RESPONSE-SCHEMA-MARKER" ], testCase "the projection keeps the configuration it is supposed to" $ do env <- loadFixture @@ -198,7 +347,13 @@ "max_tokens", "temperature", -- A tool's name is configuration; its description is not. - "fetch_report" + "fetch_report", + -- The same rule around a structured-output schema: the + -- effort, the schema's name and its strictness are how the + -- call is configured. + "effort", + "quarterly_report", + "strict" ], testCase "the commitment digest does see the content" $ do env <- loadFixture @@ -271,20 +426,15 @@ -- 'attempt', and 'supersedes' name a field on both -- 'EvidenceRequest' and 'ModelCallEvidence', and under -- DuplicateRecordFields a bare selector is ambiguous. Library - -- code reaches these through the generic-lens labels - -- (@r ^. #runId@) that the rest of this codebase uses. - testCase "evidenceRequest defaults to best effort, attempt one" $ - case evidenceRequest "run-42" of - EvidenceRequest - { runId = rid, - strictness = strict, - attempt = att, - supersedes = prev - } -> do - rid @?= "run-42" - strict @?= EvidenceBestEffort - att @?= 1 - prev @?= Nothing + -- code reaches these through 'OverloadedRecordDot' or the + -- generic-lens labels (@r ^. #runId@) the rest of this codebase + -- uses; the constructor is no longer exported. + testCase "evidenceRequest defaults to best effort, attempt one" $ do + let req = evidenceRequest "run-42" + req.runId @?= "run-42" + req.strictness @?= EvidenceBestEffort + req.attempt @?= 1 + req.supersedes @?= Nothing ] where roundTrip :: Observed Text.Text -> IO () diff --git a/test/FetchModelsSpec.hs b/test/FetchModelsSpec.hs --- a/test/FetchModelsSpec.hs +++ b/test/FetchModelsSpec.hs @@ -4,6 +4,7 @@ -- models.dev-shaped fixture. No network is involved. module FetchModelsSpec (tests) where +import Baikai.Compat (AnthropicThinkingStyle (..)) import Baikai.Model (InputModality (..)) import Baikai.Prelude import Data.Aeson qualified as Aeson @@ -57,7 +58,8 @@ input = [InputText, InputImage], cost = CatalogCost 0.05 0.4 0 0, contextWindow = 400000, - maxOutputTokens = 128000 + maxOutputTokens = 128000, + compat = Nothing }, CatalogModel { modelId = "gpt-5.4", @@ -66,11 +68,43 @@ input = [InputText, InputImage], cost = CatalogCost 2.5 15 0.25 0, contextWindow = 1050000, - maxOutputTokens = 128000 + maxOutputTokens = 128000, + compat = Nothing } ] } +-- | Expected Anthropic catalog after normalization. The one fixture +-- model carries the generation facts curated in 'anthropicInclude': +-- the budget thinking shape, sampling parameters accepted. +expectedAnthropic :: Catalog +expectedAnthropic = + Catalog + { provider = "anthropic", + baseUrl = "https://api.anthropic.com", + api = "anthropic-messages", + models = + [ CatalogModel + { modelId = "claude-opus-4-5", + name = "Claude Opus 4.5", + reasoning = True, + input = [InputText, InputImage], + cost = CatalogCost 5 25 1.5 6.25, + contextWindow = 200000, + maxOutputTokens = 64000, + compat = + Just + ( CatalogAnthropicCompat + ( AnthropicGenerationFacts + { thinkingStyle = AnthropicThinkingBudget, + supportsSamplingParameters = True + } + ) + ) + } + ] + } + tests :: TestTree tests = testGroup @@ -124,7 +158,8 @@ input = [InputText], cost = CatalogCost 0 0 0 0, contextWindow = 1, - maxOutputTokens = 1 + maxOutputTokens = 1, + compat = Nothing } ] } @@ -147,6 +182,29 @@ upstream <- loadUpstream let ids = map (^. #modelId) (catalogFor upstream anthropicSpec ^. #models) ids @?= ["claude-opus-4-5"], + testCase "Anthropic normalization carries the curated generation facts" $ do + upstream <- loadUpstream + catalogFor upstream anthropicSpec @?= expectedAnthropic, + testCase "the generation facts render as a per-model compat block" $ do + upstream <- loadUpstream + let rendered = renderText (catalogFor upstream anthropicSpec) + assertBool + "compat block rendered" + ( Text.unlines + [ " \"compat\": {", + " \"kind\": \"anthropic-messages\",", + " \"thinkingStyle\": \"budget\",", + " \"supportsSamplingParameters\": true", + " }," + ] + `Text.isInfixOf` rendered + ), + testCase "an OpenAI model renders no compat block" $ do + upstream <- loadUpstream + let rendered = renderText (catalogFor upstream openaiSpec) + assertBool + "no per-model compat block (the file-level \"compat\": \"auto\" stays)" + (not ("\"compat\": {" `Text.isInfixOf` rendered)), testCase "\" (latest)\" suffix is stripped from display names" $ do upstream <- loadUpstream let cat = catalogFor upstream anthropicSpec diff --git a/test/GenModelsSpec.hs b/test/GenModelsSpec.hs --- a/test/GenModelsSpec.hs +++ b/test/GenModelsSpec.hs @@ -1,6 +1,12 @@ module GenModelsSpec (tests) where -import Baikai.Api (Api (OpenAIChatCompletions)) +import Baikai.Api (Api (AnthropicMessages, OpenAIChatCompletions)) +import Baikai.Compat + ( AnthropicThinkingStyle (AnthropicThinkingAdaptive), + defaultAnthropicMessagesCompat, + supportsSamplingParameters, + thinkingStyle, + ) import Baikai.Model (InputModality (InputText)) import Data.Text (Text) import Data.Text qualified as Text @@ -19,8 +25,48 @@ Left err -> do assertBool "mentions duplicate identifier" ("openai_a_b" `Text.isInfixOf` err) assertBool "mentions first origin" ("openai/a-b" `Text.isInfixOf` err) - assertBool "mentions second origin" ("openai/a_b" `Text.isInfixOf` err) + assertBool "mentions second origin" ("openai/a_b" `Text.isInfixOf` err), + testCase "checkAnthropicCompat rejects an entry left at compat auto" $ do + let entries = flattenEntries (anthropicCatalog CatalogCompatAuto Nothing) + case checkAnthropicCompat entries of + Right () -> + assertFailure + "expected an anthropic-messages entry with no compat block to be rejected" + Left err -> do + assertBool "names the entry" ("anthropic/claude-x" `Text.isInfixOf` err) + assertBool "names the fix" ("thinkingStyle" `Text.isInfixOf` err) + assertBool + "names the sampling field" + ("supportsSamplingParameters" `Text.isInfixOf` err), + testCase "checkAnthropicCompat accepts an entry that states its facts" $ do + let block = + CatalogCompatAnthropic + defaultAnthropicMessagesCompat + { thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False + } + entries = flattenEntries (anthropicCatalog CatalogCompatAuto (Just block)) + case checkAnthropicCompat entries of + Right () -> pure () + Left err -> assertFailure ("unexpected rejection: " <> Text.unpack err), + testCase "checkAnthropicCompat ignores an OpenAI catalog" $ do + case checkAnthropicCompat (flattenEntries collisionCatalog) of + Right () -> pure () + Left err -> assertFailure ("unexpected rejection: " <> Text.unpack err) ] + +-- | A one-model @anthropic-messages@ catalog, with the file-level +-- compat directive and the per-model override both under the caller's +-- control. +anthropicCatalog :: CatalogCompat -> Maybe CatalogCompat -> CatalogFile +anthropicCatalog fileCompat override = + CatalogFile + { provider = "anthropic", + baseUrl = "https://api.anthropic.com", + api = AnthropicMessages, + compat = fileCompat, + models = [(model "claude-x") {entryCompatOverride = override}] + } collisionCatalog :: CatalogFile collisionCatalog = diff --git a/test/HelpersSpec.hs b/test/HelpersSpec.hs --- a/test/HelpersSpec.hs +++ b/test/HelpersSpec.hs @@ -5,6 +5,8 @@ import Control.Exception qualified as Exception import Data.Aeson qualified as Aeson import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Map.Strict qualified as Map +import Data.Maybe (isJust) import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as Vector @@ -33,7 +35,36 @@ tests = testGroup "Baikai helpers" - [ testCase "runToolLoop resolves repeated tool turns and leaves final response separate" $ do + [ -- The registry keys on 'normaliseApi' of the tag, at registration + -- and at lookup, so the two spellings of a built-in API are one + -- entry rather than two that dispatch by whichever the model used. + testCase "a handler registered under a Custom spelling answers the built-in tag" $ do + reg <- newProviderRegistryFrom [oneShotProvider (Custom "anthropic-messages") "spelled custom"] + found <- lookupApiProviderWith reg AnthropicMessages + assertBool "AnthropicMessages finds the Custom-spelled handler" (isJust found), + testCase "a handler registered under the built-in tag answers a Custom spelling" $ do + reg <- newProviderRegistryFrom [oneShotProvider AnthropicMessages "spelled built-in"] + found <- lookupApiProviderWith reg (Custom "anthropic-messages") + assertBool "Custom \"anthropic-messages\" finds the built-in handler" (isJust found), + -- A header name is case-insensitive on the wire, so a map keyed + -- on 'HeaderName' must hold one entry for two spellings rather + -- than two entries whose winner depends on Map order. + testCase "two spellings of one header name are one map entry" $ do + let hs = Map.fromList [("Authorization", "a"), ("authorization", "b")] :: Map.Map HeaderName Text + Map.size hs @?= 1 + Map.lookup "AUTHORIZATION" hs @?= Just "b", + -- 'emptyModel' carries @Custom ""@, which used to render as nothing + -- at all: "No provider registered for API: " with an empty tail. + testCase "dispatching emptyModel names emptyModel rather than nothing" $ do + reg <- newProviderRegistry + resp <- completeRequestWith reg emptyModel emptyContext emptyOptions + case responseError resp of + Nothing -> assertFailure "expected a ProviderUnavailable response" + Just err -> + assertBool + ("expected the blank-tag hint, got: " <> Text.unpack (err ^. #message)) + ("blank Custom tag" `Text.isInfixOf` (err ^. #message)), + testCase "runToolLoop resolves repeated tool turns and leaves final response separate" $ do scripted <- newScripted [toolUseResponse "call_1" "get_time", toolUseResponse "call_2" "get_time", textResponse "done"] [] let ctx0 = addUser "start" emptyContext dispatcher _ = pure (toolResultText "2026-06-05T00:00:00Z") @@ -139,6 +170,71 @@ assertBool "message should include first name" (Text.pack first `Text.isInfixOf` (err ^. #message)) assertBool "message should include second name" (Text.pack second `Text.isInfixOf` (err ^. #message)) Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key), + testCase "ApiKeyEnv rejects a variable set to the empty string" $ do + -- An empty key can never authenticate. Reporting it here, by + -- name, beats sending "Authorization: Bearer " and reading a + -- provider's 401 back. + let name = "BAIKAI_HELPERS_EMPTY_KEY" + withUnsetEnv name $ do + Environment.setEnv name "" + thrown <- Exception.try (resolveApiKey (ApiKeyEnv name)) :: IO (Either BaikaiError Text) + case thrown of + Left err -> do + err ^. #category @?= AuthError + assertBool + ("message should name the variable: " <> Text.unpack (err ^. #message)) + (Text.pack name `Text.isInfixOf` (err ^. #message)) + assertBool + ("message should say it is empty: " <> Text.unpack (err ^. #message)) + ("empty" `Text.isInfixOf` (err ^. #message)) + Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key), + testCase "ApiKeyEnv rejects a whitespace-only variable" $ do + let name = "BAIKAI_HELPERS_BLANK_KEY" + withUnsetEnv name $ do + Environment.setEnv name " " + thrown <- Exception.try (resolveApiKey (ApiKeyEnv name)) :: IO (Either BaikaiError Text) + case thrown of + Left err -> err ^. #category @?= AuthError + Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key), + testCase "ApiKeyEnv passes a real value through untrimmed" $ do + -- Only a blank value counts as unset. Trimming a real key would + -- be a second, unrelated behaviour change, and one that could + -- break a key whose edge character matters. + let name = "BAIKAI_HELPERS_PADDED_KEY" + withUnsetEnv name $ do + Environment.setEnv name " sk-padded " + resolved <- resolveApiKey (ApiKeyEnv name) + resolved @?= " sk-padded ", + testCase "ApiKeyEnvChain skips a variable set to the empty string" $ do + let first = "BAIKAI_HELPERS_CHAIN_EMPTY_A" + second = "BAIKAI_HELPERS_CHAIN_EMPTY_B" + withUnsetEnv first $ + withUnsetEnv second $ do + Environment.setEnv first "" + Environment.setEnv second "second-key" + resolved <- resolveApiKey (ApiKeyEnvChain [first, second]) + resolved @?= "second-key", + testCase "ApiKeyEnvChain reports every name when all are empty" $ do + let first = "BAIKAI_HELPERS_CHAIN_ALL_EMPTY_A" + second = "BAIKAI_HELPERS_CHAIN_ALL_EMPTY_B" + withUnsetEnv first $ + withUnsetEnv second $ do + Environment.setEnv first "" + Environment.setEnv second "" + thrown <- Exception.try (resolveApiKey (ApiKeyEnvChain [first, second])) :: IO (Either BaikaiError Text) + case thrown of + Left err -> do + err ^. #category @?= AuthError + assertBool + "message should include first name" + (Text.pack first `Text.isInfixOf` (err ^. #message)) + assertBool + "message should include second name" + (Text.pack second `Text.isInfixOf` (err ^. #message)) + assertBool + ("message should explain that empty counts as unset: " <> Text.unpack (err ^. #message)) + ("empty" `Text.isInfixOf` (err ^. #message)) + Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key), testCase "mkModel fills dispatch discriminators and defaults" $ do let model = mkModel OpenAIChatCompletions "gpt-test" "https://example.test" model ^. #api @?= OpenAIChatCompletions @@ -177,12 +273,10 @@ responsesRef <- newIORef responses callsRef <- newIORef 0 registerApiProviderWith reg $ - ApiProvider - { apiTag = helpersApi, - complete = scriptedComplete responsesRef callsRef, - stream = \_ _ _ -> Stream.fromList events, - describeThinking = \_ _ -> noThinkingRequested - } + apiProviderWith + helpersApi + (\_ _ _ -> Stream.fromList events) + (scriptedComplete responsesRef callsRef) pure Scripted {scriptRegistry = reg, scriptCallRef = callsRef} scriptedComplete :: IORef [Response] -> IORef Int -> Model -> Context -> Options -> IO Response @@ -204,30 +298,25 @@ registerOneShot :: Api -> Response -> IO () registerOneShot apiTag resp = registerApiProvider - ApiProvider - { apiTag, - complete = \model _ctx _opts -> pure (stampModel model resp), - stream = \_ _ _ -> Stream.fromList [], - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + apiTag + (\_ _ _ -> Stream.fromList []) + (\model _ctx _opts -> pure (stampModel model resp)) + ) oneShotProvider :: Api -> Text -> ApiProvider oneShotProvider apiTag body = - ApiProvider - { apiTag, - complete = \model _ctx _opts -> pure (stampModel model (textResponse body)), - stream = \_ _ _ -> Stream.fromList [], - describeThinking = \_ _ -> noThinkingRequested - } + apiProviderWith + apiTag + (\_ _ _ -> Stream.fromList []) + (\model _ctx _opts -> pure (stampModel model (textResponse body))) errorProvider :: Api -> BaikaiError -> ApiProvider errorProvider apiTag err = - ApiProvider - { apiTag, - complete = \model _ctx _opts -> pure (errorResponse model epoch 0 err), - stream = \_ _ _ -> Stream.fromList [], - describeThinking = \_ _ -> noThinkingRequested - } + apiProviderWith + apiTag + (\_ _ _ -> Stream.fromList []) + (\model _ctx _opts -> pure (errorResponse model epoch 0 err)) stampModel :: Model -> Response -> Response stampModel model resp = diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE UndecidableInstances #-} + module Main (main) where import AgentAssetsSpec qualified @@ -8,10 +11,15 @@ import CatalogSpec qualified import CliInternalSpec qualified import ContextSpec qualified +import Control.Monad (forM_) import CostSpec qualified import Data.Aeson qualified as Aeson import Data.ByteString.Char8 qualified as BS8 import Data.ByteString.Lazy.Char8 qualified as LBS8 +import Data.Kind (Type) +import Data.List (isInfixOf) +import Data.Map.Strict qualified as Map +import Data.Proxy (Proxy (..)) import Data.Text qualified as Text import Data.Vector qualified as V import EmbeddingSpec qualified @@ -19,19 +27,24 @@ import ErrorSpec qualified import EvidenceSpec qualified import FetchModelsSpec qualified +import GHC.Generics (C1, D1, Rep, S1, Selector (selName), (:*:)) import GenModelsSpec qualified import HelpersSpec qualified import InteractiveSpec qualified +import PublicSurfaceSpec qualified import StreamSpec qualified +import StreamWorkerSpec qualified import Streamly.Data.Stream qualified as Stream import StrictEvidenceSpec qualified import SurfaceSpec qualified import Test.Tasty (TestTree, defaultMain, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) import Test.Tasty.QuickCheck (Gen) import Test.Tasty.QuickCheck qualified as QC import ThinkingLevelSpec qualified import TraceSpec qualified +import TransportClassifySpec qualified +import UrlSpec qualified import UsageSpec qualified -- | Ground the test provider on a 'Custom' API tag so it does not @@ -78,12 +91,11 @@ .~ testApi & #provider .~ providerName - in ApiProvider - { apiTag = testApi, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + in ( apiProviderWith + testApi + (liftCompleteToStream handler) + (handler) + ) main :: IO () main = do @@ -106,18 +118,22 @@ GenModelsSpec.tests, HelpersSpec.tests, InteractiveSpec.tests, + PublicSurfaceSpec.tests, StreamSpec.tests, + StreamWorkerSpec.tests, StrictEvidenceSpec.tests, SurfaceSpec.tests, ThinkingLevelSpec.tests, TraceSpec.tests, + TransportClassifySpec.tests, + UrlSpec.urlTests, UsageSpec.tests ] tests :: TestTree tests = testGroup - "baikai EP-2" + "baikai core" [ testCase "emptyContext defaults are zero-y" $ do emptyContext ^. #systemPrompt @?= Nothing V.length (emptyContext ^. #messages) @?= 0, @@ -133,9 +149,25 @@ Aeson.object [ "type" Aeson..= ("object" :: Text) ] - schemaFmt = JsonSchema {name = "person", schema = person, strict = True} + schemaFmt = JsonSchema (jsonSchemaFormat "person" person) {strict = True} responseFormat (emptyOptions & #responseFormat .~ Just schemaFmt) @?= Just schemaFmt, + -- The wire shape is pinned, not merely round-tripped: 'Options' + -- derives 'ToJSON' through it and at least one consumer keys a + -- cache on the result, so moving the three fields onto + -- 'JsonSchemaFormat' must not move them in JSON. + testCase "ResponseFormat keeps its flat JSON encoding" $ do + Aeson.toJSON (JsonSchema (jsonSchemaFormat "o" Aeson.Null)) + @?= Aeson.object + [ "tag" Aeson..= ("JsonSchema" :: Text), + "name" Aeson..= ("o" :: Text), + "schema" Aeson..= Aeson.Null, + "strict" Aeson..= False + ] + Aeson.toJSON JsonObject @?= Aeson.object ["tag" Aeson..= ("JsonObject" :: Text)] + let strictFmt = JsonSchema (jsonSchemaFormat "o" Aeson.Null) {strict = True} + Aeson.decode (Aeson.encode strictFmt) @?= Just strictFmt + Aeson.decode (Aeson.encode JsonObject) @?= Just JsonObject, testCase "Options Show redacts literal API keys" $ do let secret = "sk-baikai-secret-never-print" opts = emptyOptions & #apiKey .~ Just (ApiKeyLiteral secret) @@ -148,6 +180,63 @@ assertBool "Aeson.encode opts must not contain the raw API key" (not (secret `Text.isInfixOf` Text.pack (LBS8.unpack (Aeson.encode opts)))), + testCase "Options Show and JSON redact credential headers" $ do + -- Options.headers is documented as the place to put a gateway's + -- own Authorization header, and the guides tell people to print + -- a response. Both of those are fine; printing the credential + -- is not. + let opts = emptyOptions & #headers .~ credentialHeaders + shown = Text.pack (show opts) + encoded = Text.pack (LBS8.unpack (Aeson.encode opts)) + forM_ [shown, encoded] $ \rendered -> do + assertBool + ("the bearer token must not appear: " <> Text.unpack rendered) + (not ("sk-live-secret" `Text.isInfixOf` rendered)) + assertBool + ("the subscription key must not appear: " <> Text.unpack rendered) + (not ("azure-secret" `Text.isInfixOf` rendered)) + assertBool + ("an ordinary header still appears: " <> Text.unpack rendered) + ("my app" `Text.isInfixOf` rendered) + Text.count redactedMarker rendered @?= 2 + -- Redaction is about rendering, never about the value. + Map.lookup "Authorization" (opts ^. #headers) + @?= Just "Bearer sk-live-secret", + testCase "Model and Response Show redact credential headers" $ do + -- A Model is embedded in every Response, so `print resp` is the + -- likeliest way a credential reaches a log. + let m = emptyModel & #headers .~ credentialHeaders + resp = emptyResponse & #model .~ m + forM_ [Text.pack (show m), Text.pack (show resp)] $ \rendered -> do + assertBool + ("the bearer token must not appear: " <> Text.unpack rendered) + (not ("sk-live-secret" `Text.isInfixOf` rendered)) + assertBool + ("the redaction marker appears: " <> Text.unpack rendered) + (redactedMarker `Text.isInfixOf` rendered), + testCase "a Model round-tripped through JSON carries the marker, not the key" $ do + -- Deliberately lossy: a serialised Model is exactly the thing + -- that should not carry a key. + let m = emptyModel & #headers .~ credentialHeaders + case Aeson.decode (Aeson.encode m) :: Maybe Model of + Nothing -> assertFailure "a redacted Model must still parse" + Just decoded -> do + Map.lookup "Authorization" (decoded ^. #headers) @?= Just redactedMarker + Map.lookup "X-Title" (decoded ^. #headers) @?= Just "my app", + testCase "Options and Model Show list every field" $ do + -- The drift guard for the two hand-written Show instances: a + -- field added later must fail here rather than quietly vanish + -- from `show`. + let shownOptions = show emptyOptions + shownModel = show emptyModel + forM_ (fieldNames @Options) $ \name -> + assertBool + ("Options Show omits the field " <> name) + ((name <> " = ") `isInfixOf` shownOptions) + forM_ (fieldNames @Model) $ \name -> + assertBool + ("Model Show omits the field " <> name) + ((name <> " = ") `isInfixOf` shownModel), testCase "completeRequest dispatches through the registered handler" $ do let ctx = emptyContext & #messages .~ V.fromList [user "ping"] resp <- completeRequest testModel ctx emptyOptions @@ -204,12 +293,24 @@ ^. #thinkingFormat @?= ThinkingFormatOpenRouter autoDetectOpenAICompletions "" - @?= defaultOpenAICompletionsCompat, + @?= defaultOpenAICompletionsCompat + -- An "@" after the authority names nothing. A parser that took + -- the text after the last "@" anywhere would hand a proxy the + -- vendor's own compatibility record, and then its key. + autoDetectOpenAICompletions "https://proxy.example.com/v1?u=@api.deepseek.com" + @?= defaultOpenAICompletionsCompat + urlHost "https://proxy.example.com/v1?u=@api.deepseek.com" + @?= Just "proxy.example.com", QC.testProperty "unknown OpenAI host suffixes use defaults" $ QC.forAll unknownHostGen $ \host -> QC.property $ autoDetectOpenAICompletions ("https://" <> Text.pack host) == defaultOpenAICompletionsCompat, + QC.testProperty "no trailing @-suffix can rename a host" $ + QC.forAll ((,) <$> unknownHostGen <*> QC.elements atSuffixes) $ \(host, suffix) -> + QC.property $ + urlHost ("https://" <> Text.pack host <> suffix) + == Just (Text.pack host), testCase "default API-key env table matches known hosts" $ do defaultApiKeyEnvForBaseUrl "https://api.deepseek.com/v1" @?= Just "DEEPSEEK_API_KEY" @@ -220,7 +321,20 @@ defaultApiKeyEnvForBaseUrl "https://api.xyz.ai" @?= Nothing defaultApiKeyEnvForBaseUrl "" - @?= Nothing, + @?= Nothing + -- The credential-misdirection case. Every one of these named a + -- known vendor host before the authority was bounded properly, + -- so each resolved that vendor's key and sent it to the proxy. + defaultApiKeyEnvForBaseUrl "https://proxy.example.com/v1?u=@api.openai.com" + @?= Nothing + defaultApiKeyEnvForBaseUrl "https://proxy.example.com?u=@api.anthropic.com" + @?= Nothing + defaultApiKeyEnvForBaseUrl "https://proxy.example.com#@api.deepseek.com" + @?= Nothing + -- And the benign case the same defect broke in the other + -- direction: an "@" in the path is part of the path. + defaultApiKeyEnvForBaseUrl "https://api.openai.com/v1/@x" + @?= Just "OPENAI_API_KEY", testCase "explicit OpenAI compat overrides baseUrl auto-detection" $ do let explicit = defaultOpenAICompletionsCompat @@ -249,32 +363,29 @@ compat ^. #supportsCacheControlOnTools @?= False compat ^. #sendSessionAffinityHeaders @?= True compat ^. #supportsLongCacheRetention @?= False - compat ^. #thinkingStyle @?= AnthropicThinkingBudget, - testCase "Anthropic compat defaults thinking style by model generation" $ do - anthropicMessagesCompatFor anthropic_claude_opus_4_6 - ^. #thinkingStyle - @?= AnthropicThinkingAdaptive - anthropicMessagesCompatFor anthropic_claude_opus_4_7 - ^. #thinkingStyle - @?= AnthropicThinkingAdaptive - anthropicMessagesCompatFor anthropic_claude_opus_4_8 - ^. #thinkingStyle - @?= AnthropicThinkingAdaptive - anthropicMessagesCompatFor anthropic_claude_fable_5 - ^. #thinkingStyle - @?= AnthropicThinkingAdaptive - anthropicMessagesCompatFor anthropic_claude_haiku_4_5 - ^. #thinkingStyle - @?= AnthropicThinkingBudget - anthropicMessagesCompatFor anthropic_claude_opus_4_5 - ^. #thinkingStyle - @?= AnthropicThinkingBudget - anthropicMessagesCompatFor anthropic_claude_sonnet_4_5 - ^. #thinkingStyle - @?= AnthropicThinkingBudget - anthropicMessagesCompatFor anthropic_claude_sonnet_4_6 - ^. #thinkingStyle - @?= AnthropicThinkingBudget, + compat ^. #thinkingStyle @?= AnthropicThinkingBudget + compat ^. #supportsSamplingParameters @?= True, + testCase "Anthropic catalog compat records carry thinking style and sampling support" $ do + let facts m = + let c = anthropicMessagesCompatFor m + in (c ^. #thinkingStyle, c ^. #supportsSamplingParameters) + facts anthropic_claude_fable_5 @?= (AnthropicThinkingAdaptive, False) + facts anthropic_claude_haiku_4_5 @?= (AnthropicThinkingBudget, True) + facts anthropic_claude_opus_4_5 @?= (AnthropicThinkingBudget, True) + facts anthropic_claude_opus_4_6 @?= (AnthropicThinkingAdaptive, True) + facts anthropic_claude_opus_4_7 @?= (AnthropicThinkingAdaptive, False) + facts anthropic_claude_opus_4_8 @?= (AnthropicThinkingAdaptive, False) + facts anthropic_claude_sonnet_4_5 @?= (AnthropicThinkingBudget, True) + facts anthropic_claude_sonnet_4_6 @?= (AnthropicThinkingAdaptive, True) + facts anthropic_claude_sonnet_5 @?= (AnthropicThinkingAdaptive, False), + testCase "a hand-rolled Anthropic model with CompatNone gets budget style and sampling supported" $ do + -- The model id names an adaptive-era generation, but nothing + -- reads it: a generation's wire facts are a field of the + -- catalog record, and a hand-rolled model carries none. + let handRolled = mkModel AnthropicMessages "claude-sonnet-5" "" + compat = anthropicMessagesCompatFor handRolled + compat ^. #thinkingStyle @?= AnthropicThinkingBudget + compat ^. #supportsSamplingParameters @?= True, testCase "user smart constructor produces a UserMessage" $ do let ts = read "2026-06-05 01:02:03 UTC" case userAt ts "hello" of @@ -366,3 +477,50 @@ unknownHostGen = do label <- QC.listOf1 (QC.elements (['a' .. 'z'] <> ['0' .. '9'])) pure (label <> ".example.invalid") + +-- | A header map with two credential-carrying names, spelled the way a +-- gateway would, and one ordinary header that must survive redaction. +credentialHeaders :: Map.Map HeaderName Text +credentialHeaders = + Map.fromList + [ ("Authorization", "Bearer sk-live-secret"), + ("X-Title", "my app"), + ("Ocp-Apim-Subscription-Key", "azure-secret") + ] + +-- | The record field names of a type, read off its 'Generic' +-- representation. +-- +-- This exists to guard the two hand-written 'Show' instances on +-- 'Options' and 'Model': they list their fields by hand, so a field +-- added later would silently stop being printed. Asking the compiler +-- what the fields actually are turns that into a test failure that names +-- the missing one. +class GFieldNames (f :: Type -> Type) where + gFieldNames :: Proxy f -> [String] + +instance (GFieldNames f) => GFieldNames (D1 m f) where + gFieldNames _ = gFieldNames (Proxy @f) + +instance (GFieldNames f) => GFieldNames (C1 m f) where + gFieldNames _ = gFieldNames (Proxy @f) + +instance (GFieldNames f, GFieldNames g) => GFieldNames (f :*: g) where + gFieldNames _ = gFieldNames (Proxy @f) <> gFieldNames (Proxy @g) + +instance (Selector m) => GFieldNames (S1 m f) where + gFieldNames _ = [selName (undefined :: S1 m f ())] + +fieldNames :: forall a. (GFieldNames (Rep a)) => [String] +fieldNames = gFieldNames (Proxy @(Rep a)) + +-- | Ways of writing another provider's host after the authority ends. +-- None of them may change which host a URL names, because which host a +-- URL names is which key baikai sends. +atSuffixes :: [Text] +atSuffixes = + [ "/v1?u=@api.openai.com", + "/@api.anthropic.com", + "?x=@api.deepseek.com", + "#@openrouter.ai" + ] diff --git a/test/PublicSurfaceSpec.hs b/test/PublicSurfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/PublicSurfaceSpec.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +-- | A downstream consumer's view of baikai, compiled. +-- +-- This module imports __only__ modules a published consumer can import: +-- no @Baikai.Prelude@, no @Control.Lens@, no generic-lens, no +-- @.Internal@ module. Everything it does, it does with record update, +-- plain selectors and the exported base values. +-- +-- Its value is that it compiles. Plan 43 chose compile-time probes over +-- a golden @:browse@ dump, because a dump goes stale silently while a +-- module that sees what a downstream sees fails the build the moment a +-- name a consumer needs stops being exported — or the moment a record +-- can no longer be built without the constructor this release hid. +-- +-- It exports one 'TestTree' so the suite runs the few facts that are +-- cheap to assert here; the compilation is the real test. +module PublicSurfaceSpec (tests) where + +import Baikai +import Baikai.Cost.Log (CallLogConfig (enabled, path), callLogConfig) +import Baikai.Embedding qualified as Embedding +import Data.Aeson (Value (Null)) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Vector qualified as V +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "public surface" + [ testCase "every hidden record is buildable with record update alone" $ do + probeTool.name @?= "probe" + probeLog.path @?= "/dev/null" + probeLog.enabled @?= True + Embedding.modelId probeEmbedding @?= "text-embedding-probe" + headerCount @?= 1, + testCase "a provider registered from apiProvider dispatches" $ do + reg <- newProviderRegistryFrom [probeProvider] + resp <- completeRequestWith reg probeModel probeContext probeOptions + -- The stream is empty, so reassembly produces a response with no + -- content and no error. What matters is that dispatch found the + -- handler and that a consumer could build it. + assertBool "the call produced no error" (responseError resp == Nothing) + ] + +-- | Built from 'apiProvider' — re-exported by the umbrella — not from a +-- constructor. +probeProvider :: ApiProvider +probeProvider = apiProvider (Custom "public-surface-probe") (\_ _ _ -> Stream.fromList []) + +probeModel :: Model +probeModel = + emptyModel + { modelId = "probe-model", + api = Custom "public-surface-probe", + provider = "probe" + } + +probeContext :: Context +probeContext = emptyContext {messages = V.singleton (user "hello")} + +probeOptions :: Options +probeOptions = emptyOptions {maxTokens = Just 16} + +probeTool :: Tool +probeTool = mkTool "probe" "a probe" Null + +probeLog :: CallLogConfig +probeLog = callLogConfig "/dev/null" + +-- Qualified because @modelId@ alone does not name a type: 'Model', +-- 'EmbeddingModel' and 'InteractiveLaunchRequest' all have it, and under +-- @DuplicateRecordFields@ a record update whose fields do not determine +-- the datatype is ambiguous. Hiding constructors did not cause that and +-- does not change it; a consumer either qualifies, as here, or reaches +-- for generic-lens. +probeEmbedding :: Embedding.EmbeddingModel +probeEmbedding = + Embedding.emptyEmbeddingModel {Embedding.modelId = "text-embedding-probe"} + +-- | Two spellings of one header name, through the public 'HeaderName'. +headerCount :: Int +headerCount = + Map.size (Map.fromList [("X-Probe", "a"), ("x-probe", "b")] :: Map.Map HeaderName Text) diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs --- a/test/StreamSpec.hs +++ b/test/StreamSpec.hs @@ -5,6 +5,7 @@ import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay, throwTo) import Control.Exception qualified as Exception import Data.Aeson qualified as Aeson +import Data.IORef (modifyIORef', newIORef, readIORef) import Data.Time (UTCTime) import Data.Vector qualified as Vector import Streamly.Data.Stream qualified as Stream @@ -138,7 +139,15 @@ ] resp ^. #message ^. #content @?= expected resp ^. #message ^. #stopReason @?= Stop - resp ^. #message ^. #errorMessage @?= Just "stream ended without terminal event", + resp ^. #message ^. #errorMessage @?= Just "stream ended without terminal event" + -- The recovered call is the same shape the two provider + -- assemblers now produce for a cut-off call, and it says so. + [tc | AssistantToolCall tc <- Vector.toList (resp ^. #message ^. #content)] + @?= [ToolCall {id_ = "", name = "", arguments = Aeson.String "{\"a\":1"}] + assertBool + "a flushed dangling tool call is marked cut off" + (all isCutOffToolCall [tc | AssistantToolCall tc <- Vector.toList (resp ^. #message ^. #content)]), + cutOffToolCallIsNeverDispatchedTest, testCase "latencyMs is clamped at zero" $ do let oldResponse = responseWith Nothing [AssistantText (TextContent "old")] @@ -147,6 +156,11 @@ handler _ _ _ = pure oldResponse resp <- streamingComplete (liftCompleteToStream handler) streamModel streamContext streamOptions assertBool "latencyMs should be non-negative" (resp ^. #latencyMs >= 0), + duplicateStartTest, + eventsAfterTerminalTest, + failedTerminalAppendsDanglingTest, + emptySuccessfulTerminalFallsBackTest, + wallClockLatencyTest, testCase "async exceptions pass through liftCompleteToStream" $ do done <- newEmptyMVar let blocked _ _ _ = threadDelay (10 * 1000 * 1000) *> pure (responseWith Nothing []) @@ -184,3 +198,193 @@ be ^. #retryAfterSeconds @?= Just 5 Nothing -> assertFailure "expected lifted BaikaiError to survive reassembly" ] + +-- | A tool call the model never finished asking for is not executed. +-- +-- Both halves: 'runToolLoopWith' stops with the response intact rather +-- than dispatching, and 'appendToolResult' -- the documented direct +-- round-trip, which a caller drives by hand -- appends an error result +-- without calling the dispatcher either. +cutOffToolCallIsNeverDispatchedTest :: TestTree +cutOffToolCallIsNeverDispatchedTest = + testCase "a cut-off tool call is never dispatched" $ do + let cutOffCall = ToolCall {id_ = "call_1", name = "search", arguments = Aeson.String "{\"a\":1"} + -- 'Length' is what a real cut-off carries; the guard does not + -- rely on it, because a compatible host can report + -- @finish_reason: tool_calls@ for truncated arguments. + cutOffResponse = + emptyResponse + & #message + .~ assistantPayload (Vector.singleton (AssistantToolCall cutOffCall)) Length Nothing epoch + & #model + .~ cutOffModel + & #api + .~ cutOffApi + & #provider + .~ "stream-spec" + reg <- newProviderRegistry + registerApiProviderWith + reg + ( apiProviderWith + cutOffApi + (liftCompleteToStream (\_ _ _ -> pure cutOffResponse)) + (\_ _ _ -> pure cutOffResponse) + ) + dispatched <- newIORef ([] :: [ToolCall]) + let dispatcher tc = modifyIORef' dispatched (<> [tc]) >> pure (toolResultText "never") + + (_, looped) <- runToolLoopWith reg 4 dispatcher cutOffModel streamContext streamOptions + looped ^. #message ^. #content @?= Vector.singleton (AssistantToolCall cutOffCall) + looped ^. #message ^. #stopReason @?= Length + readIORef dispatched >>= \calls -> calls @?= [] + + ctx' <- appendToolResult streamContext cutOffResponse dispatcher + readIORef dispatched >>= \calls -> calls @?= [] + case Vector.toList (ctx' ^. #messages) of + [_assistant, ToolResultMessage p] -> do + p ^. #isError @?= True + p ^. #toolCallId @?= "call_1" + other -> assertFailure ("expected the assistant message then one tool result, got: " <> show (length other)) + +-- | Its own tag, so this case cannot collide with the module's other +-- registrations when the suite runs in one process. +cutOffApi :: Api +cutOffApi = Custom "baikai-stream-spec-cutoff" + +cutOffModel :: Model +cutOffModel = + emptyModel + & #modelId + .~ "stream-spec-cutoff-model" + & #api + .~ cutOffApi + & #provider + .~ "stream-spec" + +-- | A duplicated start does not rewrite the assembly. +-- +-- First skeleton wins, so the latency window is measured from the first +-- event the provider actually sent; @responseId@ merges, so a later +-- 'Nothing' cannot erase an id an earlier event supplied. +duplicateStartTest :: TestTree +duplicateStartTest = + testCase "a duplicate EventStart keeps the first skeleton and merges responseId" $ do + let firstSkeleton = AssistantMessage (assistantPayload Vector.empty Stop Nothing later) + staleSkeleton = AssistantMessage (assistantPayload Vector.empty Stop Nothing epoch) + resp <- + runEvents + [ EventStart StartPayload {partial = firstSkeleton, responseId = Just "msg_1"}, + EventStart StartPayload {partial = staleSkeleton, responseId = Nothing}, + EventDone + ( doneTerminal + Nothing + Nothing + Stop + (AssistantMessage (assistantPayload (Vector.singleton (AssistantText (TextContent "hi"))) Stop Nothing muchLater)) + ) + ] + resp ^. #responseId @?= Just "msg_1" + -- Measured from the first skeleton's timestamp, not the stale one: + -- the stale skeleton is at the epoch, which would give a latency of + -- decades. + resp ^. #latencyMs @?= 2000 + +-- | The first terminal wins. A producer that keeps talking afterwards +-- cannot rewrite the answer a consumer has already been handed. +eventsAfterTerminalTest :: TestTree +eventsAfterTerminalTest = + testCase "events after the terminal are ignored" $ do + resp <- + runEvents + [ startEvent Nothing, + doneEvent Nothing [AssistantText (TextContent "final")], + TextStart IndexPayload {contentIndex = 5}, + TextDelta DeltaPayload {contentIndex = 5, delta = "late"}, + EventError + ( errorTerminal + Nothing + Nothing + ErrorReason + (AssistantMessage (assistantPayload Vector.empty ErrorReason (Just "too late") epoch)) + (providerError "too late") + ) + ] + resp ^. #message ^. #content @?= Vector.singleton (AssistantText (TextContent "final")) + resp ^. #message ^. #stopReason @?= Stop + resp ^. #errorInfo @?= Nothing + +-- | A failed terminal's own content comes first and the blocks that were +-- still open are appended after it. Safe because an open index is always +-- greater than every closed one. +failedTerminalAppendsDanglingTest :: TestTree +failedTerminalAppendsDanglingTest = + testCase "a failed terminal appends dangling blocks after its content" $ do + resp <- + runEvents + [ startEvent Nothing, + TextStart IndexPayload {contentIndex = 0}, + TextDelta DeltaPayload {contentIndex = 0, delta = "closed"}, + TextEnd BlockEndPayload {contentIndex = 0, content = "closed"}, + ThinkingStart IndexPayload {contentIndex = 1}, + ThinkingDelta DeltaPayload {contentIndex = 1, delta = "half a thought"}, + EventError + ( errorTerminal + Nothing + Nothing + ErrorReason + (AssistantMessage (assistantPayload (Vector.singleton (AssistantText (TextContent "closed"))) ErrorReason (Just "boom") epoch)) + (providerError "boom") + ) + ] + resp ^. #message ^. #content + @?= Vector.fromList + [ AssistantText (TextContent "closed"), + AssistantThinking ThinkingContent {thinking = "half a thought", signature = Nothing, redacted = False} + ] + +-- | A terminal that carries no content is not authoritative about +-- content: the blocks the stream assembled are. +emptySuccessfulTerminalFallsBackTest :: TestTree +emptySuccessfulTerminalFallsBackTest = + testCase "a successful terminal with empty content falls back to the assembled blocks" $ do + resp <- + runEvents + [ startEvent Nothing, + TextStart IndexPayload {contentIndex = 0}, + TextDelta DeltaPayload {contentIndex = 0, delta = "assembled"}, + TextEnd BlockEndPayload {contentIndex = 0, content = "assembled"}, + doneEvent Nothing [] + ] + resp ^. #message ^. #content @?= Vector.singleton (AssistantText (TextContent "assembled")) + +-- | With no provider timestamps, latency is the window this fold saw +-- rather than a zero that reads as "instant". +wallClockLatencyTest :: TestTree +wallClockLatencyTest = + testCase "latencyMs falls back to the wall clock when timestamps are absent" $ do + let untimed sr err blocks = + AssistantMessage + AssistantPayload + { content = Vector.fromList blocks, + usage = zeroUsage, + stopReason = sr, + errorMessage = err, + timestamp = Nothing + } + events = + [ EventStart StartPayload {partial = untimed Stop Nothing [], responseId = Nothing}, + EventDone (doneTerminal Nothing Nothing Stop (untimed Stop Nothing [AssistantText (TextContent "slow")])) + ] + resp <- + Stream.fold + (reassembleResponse streamModel) + (Stream.mapM (\e -> threadDelay 20000 >> pure e) (Stream.fromList events)) + assertBool + ("expected a wall-clock latency of at least 20ms, got: " <> show (resp ^. #latencyMs)) + (resp ^. #latencyMs >= 20) + +later :: UTCTime +later = read "2000-01-01 00:00:01 UTC" + +muchLater :: UTCTime +muchLater = read "2000-01-01 00:00:03 UTC" diff --git a/test/StreamWorkerSpec.hs b/test/StreamWorkerSpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamWorkerSpec.hs @@ -0,0 +1,86 @@ +-- | The bounded worker/consumer hand-off in +-- "Baikai.Provider.Internal.StreamWorker". +-- +-- Both HTTP providers depend on the three properties pinned here: every +-- frame pushed before the close is delivered, a worker blocked on a full +-- queue is interruptible, and the queue closes however the body ends. +module StreamWorkerSpec (tests) where + +import Baikai.Provider.Internal.StreamWorker + ( FrameQueue, + closeFrames, + forkFrameWorker, + frameQueueCapacity, + newFrameQueue, + pullFrame, + pushFrame, + ) +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar, tryTakeMVar) +import Control.Exception (finally) +import Control.Monad (forM_) +import Data.IORef (newIORef, readIORef, writeIORef) +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Provider.Internal.StreamWorker" + [ deliversEveryFrameTest, + blockedPushIsInterruptibleTest, + killedBodyClosesQueueTest + ] + +-- | Ordering and completeness: the close flag never overtakes frames +-- already in the queue. +deliversEveryFrameTest :: TestTree +deliversEveryFrameTest = + testCase "pullFrame delivers every frame pushed before close" $ do + q <- newFrameQueue + forM_ [1 :: Int .. 10] (pushFrame q) + closeFrames q + let drain acc = + pullFrame q >>= \case + Nothing -> pure (reverse acc) + Just a -> drain (a : acc) + got <- drain [] + got @?= [1 .. 10] + +-- | A worker whose consumer has stopped parks on a full queue rather +-- than reading on, and the park is an interruptible STM wait, so +-- 'killThread' reaches it. +blockedPushIsInterruptibleTest :: TestTree +blockedPushIsInterruptibleTest = + testCase "pushFrame blocks when the queue is full and is interruptible" $ do + q <- newFrameQueue + pushed <- newEmptyMVar + diedRef <- newIORef False + tid <- forkIO $ do + ( do + forM_ [1 .. fromIntegral frameQueueCapacity] (pushFrame q :: Int -> IO ()) + pushFrame q 0 + putMVar pushed () + ) + `finally` writeIORef diedRef True + threadDelay 100000 + stillBlocked <- tryTakeMVar pushed + stillBlocked @?= Nothing + killThread tid + threadDelay 50000 + died <- readIORef diedRef + assertBool "the blocked pusher was interrupted" died + +-- | The close flag is set by the fork's own @finally@, so a worker that +-- dies by asynchronous exception cannot leave the consumer waiting. +killedBodyClosesQueueTest :: TestTree +killedBodyClosesQueueTest = + testCase "forkFrameWorker closes the queue when the body is killed" $ do + q <- newFrameQueue :: IO (FrameQueue Int) + blocked <- newEmptyMVar + tid <- forkFrameWorker q (takeMVar blocked) + threadDelay 20000 + killThread tid + got <- timeout 1000000 (pullFrame q) + got @?= Just Nothing diff --git a/test/StrictEvidenceSpec.hs b/test/StrictEvidenceSpec.hs --- a/test/StrictEvidenceSpec.hs +++ b/test/StrictEvidenceSpec.hs @@ -13,9 +13,11 @@ import Control.Exception (evaluate, try) import Control.Exception qualified as Exception import Control.Lens ((&), (.~), (^.)) +import Data.Aeson qualified as Aeson import Data.Generics.Labels () import Data.Text (Text) import Data.Text qualified as Text +import Data.Time (getCurrentTime) import Data.Vector qualified as Vector import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) @@ -88,7 +90,7 @@ [ testCase "a custom transport cannot supply model_observed" $ case checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - (Custom "someone-elses-gateway") + (declaredStrength (Custom "someone-elses-gateway")) noThinkingRequested of [StrengthUnreachable needed declared] -> do needed @?= EvidenceModelObserved @@ -97,14 +99,14 @@ testCase "the codex CLI cannot supply model_observed, because it names no model" $ case checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - OpenAICompletionsCli + (declaredStrength OpenAICompletionsCli) noThinkingRequested of [StrengthUnreachable _ declared] -> declared @?= EvidenceCorrelated other -> assertFailure ("expected one StrengthUnreachable, got: " <> show other), testCase "the codex CLI can supply correlated" $ checkEvidenceRequirements (EvidenceRequired EvidenceCorrelated) - OpenAICompletionsCli + (declaredStrength OpenAICompletionsCli) noThinkingRequested @?= [], testCase "an exactly-met requirement is not a refusal" $ @@ -112,7 +114,7 @@ -- what was asked for satisfies it. checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - AnthropicMessages + (declaredStrength AnthropicMessages) noThinkingRequested @?= [], testCase "both halves of the gate report together, not one per attempt" $ @@ -122,7 +124,7 @@ length ( checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - (Custom "gateway") + (declaredStrength (Custom "gateway")) (downgradedBy (EffortClamped ThinkingMax "high")) ) @?= 2 @@ -149,7 +151,7 @@ testCase name $ case checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) - AnthropicMessages + (declaredStrength AnthropicMessages) (downgradedBy adjustment) of [ThinkingWouldDowngrade [reported]] -> do reported @?= adjustment @@ -196,7 +198,7 @@ testCase "several downgrades on one call are reported together" $ case checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) - AnthropicMessages + (declaredStrength AnthropicMessages) ( noThinkingRequested & #requested .~ Just ThinkingMax & #adjustments @@ -210,16 +212,44 @@ -- no thinking level must still run. checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - AnthropicMessages + (declaredStrength AnthropicMessages) noThinkingRequested @?= [], + testCase "A DROPPED SAMPLING PARAMETER IS NOT A THINKING DOWNGRADE" $ + -- The documented contract is refusing a call that would weaken + -- the requested thinking level. A sampling parameter the model + -- generation or the API has nowhere to put is recorded in the + -- evidence — that is what the adjustment is for — but it is not + -- a thinking downgrade, and a caller who set `temperature` on a + -- Claude model must not have every strict call refused over it. + checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + (declaredStrength AnthropicMessages) + ( noThinkingRequested + & #adjustments .~ [SamplingDroppedUnsupportedModel ["temperature"]] + ) + @?= [], + testCase "a sampling drop alongside a real downgrade reports only the downgrade" $ + case checkEvidenceRequirements + (EvidenceRequired EvidenceRequestedOnly) + (declaredStrength AnthropicMessages) + ( noThinkingRequested + & #requested .~ Just ThinkingMax + & #adjustments + .~ [ EffortOmitted ThinkingMax, + SamplingDroppedUnsupportedModel ["temperature", "top_p"] + ] + ) of + [ThinkingWouldDowngrade reported] -> + reported @?= [EffortOmitted ThinkingMax] + other -> assertFailure ("expected one ThinkingWouldDowngrade, got: " <> show other), testCase "a level expressed exactly is not a downgrade" $ -- The native OpenAI shape sends every canonical level verbatim -- and codex accepts all six. Refusing those would reject the -- configurations that honour the caller in full. checkEvidenceRequirements (EvidenceRequired EvidenceModelObserved) - OpenAIChatCompletions + (declaredStrength OpenAIChatCompletions) ( noThinkingRequested & #requested .~ Just ThinkingXHigh & #mode .~ ThinkingModeAdaptive @@ -240,7 +270,7 @@ -- a sample is a promise about the sample. "a best-effort caller is never refused, on any transport at any level" [ testCase (Text.unpack (renderApi api) <> " / " <> label) $ - checkEvidenceRequirements EvidenceBestEffort api translation @?= [] + checkEvidenceRequirements EvidenceBestEffort (declaredStrength api) translation @?= [] | api <- [ AnthropicMessages, OpenAIChatCompletions, @@ -267,7 +297,9 @@ EffortOmitted lvl, ThinkingDroppedUnsupportedModel lvl, ThinkingDroppedUnsupportedHost lvl, - ThinkingDroppedBudgetExceeded lvl 32000 8192 + ThinkingDroppedBudgetExceeded lvl 32000 8192, + SamplingDroppedUnsupportedModel ["temperature"], + SamplingDroppedUnsupportedApi ["seed"] ] ] ] @@ -282,6 +314,8 @@ ThinkingDroppedUnsupportedModel {} -> "dropped-model" ThinkingDroppedUnsupportedHost {} -> "dropped-host" ThinkingDroppedBudgetExceeded {} -> "dropped-budget" + SamplingDroppedUnsupportedModel {} -> "sampling-dropped-model" + SamplingDroppedUnsupportedApi {} -> "sampling-dropped-api" -- ============================================================ -- The gate does no work on the default path @@ -297,7 +331,16 @@ "the gate never computes a translation it does not need" [ testCase "A BEST-EFFORT CALL NEVER FORCES THE TRANSLATION" $ do outcome <- - try (evaluate (length (checkEvidenceRequirements EvidenceBestEffort AnthropicMessages explodes))) + try + ( evaluate + ( length + ( checkEvidenceRequirements + EvidenceBestEffort + (declaredStrength AnthropicMessages) + explodes + ) + ) + ) case outcome :: Either Exception.SomeException Int of Right n -> n @?= 0 Left e -> assertFailure ("the translation was forced: " <> show e), @@ -308,7 +351,7 @@ ( length ( checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) - AnthropicMessages + (declaredStrength AnthropicMessages) explodes ) ) @@ -378,7 +421,49 @@ registerApiProviderWith reg countingProvider resp <- completeRequestWith reg customModel testContext emptyOptions responseError resp @?= Nothing - flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran" + flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran", + testCase "a strict completeRequest with a record-less provider fails after the call" $ do + -- The gate lets this through: a custom provider declaring + -- requested_only can satisfy a requested_only requirement, and + -- one that builds a minimal record does. This one does not, and + -- the failure is caught at the terminal instead — with no sink + -- anywhere, which is the point of enforcing at dispatch. + reg <- newProviderRegistry + registerApiProviderWith reg countingProvider + resp <- completeRequestWith reg customModel testContext (strictly EvidenceRequestedOnly) + case responseError resp of + Nothing -> assertFailure "expected the missing record to fail the call" + Just err -> + assertBool + ("the message names the missing record: " <> Text.unpack (err ^. #message)) + ("attached no evidence record" `Text.isInfixOf` (err ^. #message)) + -- The provider was reached and its content is kept, so a caller + -- reading the failure can still see what came back. + flattenAssistantText (flattenAssistantBlocks resp) @?= "the provider ran", + testCase "A CUSTOM PROVIDER DECLARING correlated SATISFIES A STRICT correlated CALL" $ do + -- Under the tag-keyed table this was impossible: every Custom + -- transport was capped at requested_only whatever its evidence + -- actually reached, so a gateway that observes a response id + -- could never serve a strict correlated caller. + reg <- newProviderRegistry + registerApiProviderWith reg correlatingProvider + resp <- completeRequestWith reg customModel testContext (strictly EvidenceCorrelated) + responseError resp @?= Nothing + case resp ^. #evidence of + Nothing -> assertFailure "a strict caller opted into evidence and must get a record" + Just ev -> ev ^. #strength @?= EvidenceCorrelated, + testCase "a declaration is still a ceiling, not a blank cheque" $ do + reg <- newProviderRegistry + registerApiProviderWith reg correlatingProvider + resp <- completeRequestWith reg customModel testContext (strictly EvidenceModelObserved) + case responseError resp of + Nothing -> assertFailure "expected a refusal" + Just err -> + assertBool + ("the message names both strengths: " <> Text.unpack (err ^. #message)) + ( "model_observed" `Text.isInfixOf` (err ^. #message) + && "correlated" `Text.isInfixOf` (err ^. #message) + ) ] -- ============================================================ @@ -406,26 +491,59 @@ bestEffortOptions :: Options bestEffortOptions = emptyOptions & #evidence .~ Just (evidenceRequest "run-57") +-- | A custom transport that declares, and delivers, 'EvidenceCorrelated' +-- — a response id it observed. Its ceiling is its own declaration, which +-- the tag-keyed table could never express. +correlatingProvider :: ApiProvider +correlatingProvider = + apiProviderWith + customApi + (liftCompleteToStream handler) + (handler) + & #strengthCeiling .~ (EvidenceCorrelated) + where + handler m _ opts = do + now <- getCurrentTime + ev <- + minimalEvidence + m + opts + TransportHttpApi + noThinkingRequested + (Aeson.object ["model" Aeson..= (m ^. #modelId :: Text)]) + now + now + CallSucceeded + Nothing + let seen = Observed "gateway-response-1" :: Observed Text + observed e = + e + & #responseId .~ seen + & #strength .~ deriveStrength Unobserved Unobserved seen + pure + ( emptyResponse + & #model .~ m + & #evidence .~ fmap observed ev + & #message . #content + .~ Vector.singleton (AssistantText (TextContent "the provider ran")) + ) + -- | A provider that fails loudly if it is reached. Used to prove the -- gate refuses /before/ dispatch rather than annotating afterwards. explodingProvider :: ApiProvider explodingProvider = - ApiProvider - { apiTag = customApi, - stream = \_ _ _ -> error "the provider was dispatched despite a strict refusal", - complete = \_ _ _ -> error "the provider was dispatched despite a strict refusal", - describeThinking = \_ _ -> noThinkingRequested - } + apiProviderWith + customApi + (\_ _ _ -> error "the provider was dispatched despite a strict refusal") + (\_ _ _ -> error "the provider was dispatched despite a strict refusal") -- | The same shape, but it answers. countingProvider :: ApiProvider countingProvider = - ApiProvider - { apiTag = customApi, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + apiProviderWith + customApi + (liftCompleteToStream handler) + (handler) where handler m _ _ = pure diff --git a/test/SurfaceSpec.hs b/test/SurfaceSpec.hs --- a/test/SurfaceSpec.hs +++ b/test/SurfaceSpec.hs @@ -1,11 +1,13 @@ module SurfaceSpec (tests) where import Baikai +import Baikai.Cost.Log (callLogConfig) import Baikai.Embedding qualified as Embedding import Baikai.Prelude import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map import Data.Vector qualified as V +import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -49,5 +51,24 @@ zeroModelCost ^. #inputCost @?= 0 emptyTool ^. #parameters @?= Aeson.Null emptyToolCall ^. #arguments @?= Aeson.Null - Embedding.modelId Embedding.emptyEmbeddingModel @?= "" + Embedding.modelId Embedding.emptyEmbeddingModel @?= "", + -- Every record whose constructor this release hid must still be + -- reachable: build each from its exported base and read one field + -- back. A base value that disappears, or a field that stops being + -- exported, fails to compile here rather than at a consumer. + testCase "hidden records build from their bases" $ do + let provider = apiProvider (Custom "probe") (\_ _ _ -> Stream.nil) + req = evidenceRequest "r" & #attempt .~ 2 + tool = mkTool "t" "d" Aeson.Null + embedding = Embedding.emptyEmbeddingModel & #modelId .~ "e" + logCfg = callLogConfig "/dev/null" + provider ^. #apiTag @?= Custom "probe" + provider ^. #strengthCeiling @?= EvidenceRequestedOnly + req ^. #attempt @?= 2 + req ^. #runId @?= "r" + tool ^. #name @?= "t" + tool ^. #parameters @?= Aeson.Null + embedding ^. #modelId @?= "e" + logCfg ^. #path @?= "/dev/null" + logCfg ^. #enabled @?= True ] diff --git a/test/ThinkingLevelSpec.hs b/test/ThinkingLevelSpec.hs --- a/test/ThinkingLevelSpec.hs +++ b/test/ThinkingLevelSpec.hs @@ -10,6 +10,7 @@ testGroup "ThinkingLevel" [ testGroup "canonical rendering" renderTests, + testGroup "canonical parsing" parseTests, testGroup "token budgets" budgetTests ] @@ -28,6 +29,18 @@ [ testCase name $ renderThinkingLevel level @?= expected | (name, level, expected, _) <- levels ] + +-- | 'parseThinkingLevel' is the inverse of 'renderThinkingLevel' on +-- every level, which is what lets @baikai-agent@'s KDL decoder and the +-- evidence schema read the table instead of copying it. +parseTests :: [TestTree] +parseTests = + [ testCase name $ do + parseThinkingLevel expected @?= Just level + parseThinkingLevel (renderThinkingLevel level) @?= Just level + | (name, level, expected, _) <- levels + ] + <> [testCase "an unknown name is Nothing" $ parseThinkingLevel "enormous" @?= Nothing] budgetTests :: [TestTree] budgetTests = diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -1,15 +1,9 @@ --- This module deliberately exercises 'newEventId', which is deprecated --- in favour of 'Baikai.Evidence.newCallId'. The alias is still part of --- the public surface, so it keeps a test; suppressing the warning here --- is narrower than dropping the coverage. -{-# OPTIONS_GHC -Wno-deprecations #-} - module TraceSpec (tests) where import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext) -import Baikai.Error (BaikaiError, providerError) +import Baikai.Error (BaikaiError, ErrorCategory (..), providerError) import Baikai.Evidence ( ModelCallEvidence, TransportKind (..), @@ -22,24 +16,28 @@ import Baikai.Model (Model (..), emptyModel) import Baikai.Options (Options, emptyOptions) import Baikai.Prelude -import Baikai.Provider (ApiProvider (..), registerApiProvider) +import Baikai.Provider (apiProviderWith, registerApiProvider) import Baikai.Response (Response (..), responseError) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) import Baikai.Stream.Event (AssistantMessageEvent (..)) -import Baikai.Trace (newEventId, withTrace, withTraceStream) +import Baikai.ThinkingLevel (ThinkingLevel (..)) +import Baikai.Trace (withTrace, withTraceStream) import Baikai.Trace.Event (TraceEvent (..)) -import Baikai.Trace.Sink (TraceSink (..), silent) +import Baikai.Trace.Sink (TraceSink (..), multiSink, silent) import Baikai.Usage (Usage, zeroUsage) -import Control.Concurrent (threadDelay) +import Control.Concurrent (forkIO, threadDelay, throwTo) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, readMVar, takeMVar) import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) -import Control.Exception (throwIO) -import Control.Monad (replicateM) +import Control.Exception (AsyncException (ThreadKilled), SomeException, throwIO, try) +import Control.Monad (forM_, replicateM) import Data.Aeson (Value (..)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as Key import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy.Char8 qualified as BL8 +import Data.Either (isLeft) +import Data.List (findIndex) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding qualified as TextEncoding @@ -61,10 +59,18 @@ memoryFinishTest, memoryFailTest, throwingSinkTest, + blockingSinkTest, + blockingSinkStrictTest, + multiSinkThrowingMemberTest, + multiSinkBlockingMemberTest, + multiSinkStrictNamesMemberTest, + terminalPathAtomicityTest, + throwToAroundTerminalTest, eventIdUniquenessTest, earlyAbortTest, fidelityTest, evidenceTests, + requestedLevelTests, encodingTests ] @@ -113,23 +119,21 @@ registerOk a = let handler _m _ctx _opts = pure (stubResponse a) in registerApiProvider - ApiProvider - { apiTag = a, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + ) registerFail :: Api -> BaikaiError -> IO () registerFail a e = let handler _m _ctx _opts = throwIO e in registerApiProvider - ApiProvider - { apiTag = a, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + ) memorySink :: IO (TVar [TraceEvent], TraceSink) memorySink = do @@ -215,17 +219,217 @@ let AssistantPayload {stopReason = sr} = resp ^. #message sr @?= Stop +-- | A sink that never returns from its first step until released. +blockingSink :: IO (MVar (), TraceSink) +blockingSink = do + release <- newEmptyMVar + pure (release, TraceSink (Fold.drainMapM (\_ -> readMVar release))) + +-- | Unfixed, 'finalizeTrace' blocked on the worker forever and the +-- guard below reported the hang. The bound turns a pathological sink +-- into about one second and a stderr line. +blockingSinkTest :: TestTree +blockingSinkTest = + testCase "a sink that blocks forever cannot hold withTrace past the drain bound" $ do + let a = Custom "baikai-trace-blocking-sink" + registerOk a + (release, sink) <- blockingSink + result <- timeout 2000000 (withTrace sink (stubModel a) stubContext stubOptions) + case result of + Nothing -> assertFailure "withTrace hung on a blocking sink" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + putMVar release () + +-- | A record whose delivery was never confirmed is not one a strict +-- caller can account for, so the stall fails the call through the same +-- path a throwing sink does. +blockingSinkStrictTest :: TestTree +blockingSinkStrictTest = + testCase "a strict call whose sink never confirms delivery fails" $ do + let a = Custom "baikai-trace-blocking-sink-strict" + -- The evidence-building fixture, so the sink is the only reason + -- this call can fail. + registerOkWithEvidence a + (release, sink) <- blockingSink + result <- timeout 2000000 (withTrace sink (stubModel a) stubContext strictOptions) + case result of + Nothing -> assertFailure "withTrace hung on a blocking sink" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= ErrorReason + case responseError resp of + Nothing -> assertFailure "expected the stall to reach the response" + Just be -> + assertBool + ("the error names the stall: " <> Text.unpack (be ^. #message)) + ("did not confirm delivery" `Text.isInfixOf` (be ^. #message)) + putMVar release () + +-- | Under 'Fold.tee' the throwing member's exception stopped delivery +-- to the sibling for the rest of the call and skipped its end-of-stream +-- action, so this sibling was empty. +multiSinkThrowingMemberTest :: TestTree +multiSinkThrowingMemberTest = + testCase "a throwing multiSink member does not starve its sibling" $ do + let a = Custom "baikai-trace-multisink-throwing" + registerOk a + (ref, memory) <- memorySink + result <- + timeout + 5000000 + (withTrace (multiSink [throwingSink, memory]) (stubModel a) stubContext stubOptions) + case result of + Nothing -> assertFailure "withTrace hung on a throwing multiSink member" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + events <- reverse <$> readTVarIO ref + case events of + [CallStarted {}, CallFinished {}] -> pure () + other -> assertFailure ("the sibling missed events: " <> show other) + +multiSinkBlockingMemberTest :: TestTree +multiSinkBlockingMemberTest = + testCase "a blocking multiSink member does not starve its sibling" $ do + let a = Custom "baikai-trace-multisink-blocking" + registerOk a + (release, blocking) <- blockingSink + (ref, memory) <- memorySink + result <- + timeout + 2000000 + (withTrace (multiSink [blocking, memory]) (stubModel a) stubContext stubOptions) + case result of + Nothing -> assertFailure "withTrace hung on a blocking multiSink member" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + events <- reverse <$> readTVarIO ref + case events of + [CallStarted {}, CallFinished {}] -> pure () + other -> assertFailure ("the sibling missed events: " <> show other) + putMVar release () + +-- | The aggregate failure has to say /which/ member failed, or an +-- operator with three sinks learns only that tracing broke. +multiSinkStrictNamesMemberTest :: TestTree +multiSinkStrictNamesMemberTest = + testCase "a strict call names the multiSink member that failed" $ do + let a = Custom "baikai-trace-multisink-strict" + registerOkWithEvidence a + (_ref, memory) <- memorySink + result <- + timeout + 5000000 + (withTrace (multiSink [throwingSink, memory]) (stubModel a) stubContext strictOptions) + case result of + Nothing -> assertFailure "withTrace hung on a throwing multiSink member" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= ErrorReason + case responseError resp of + Nothing -> assertFailure "expected the member failure to reach the response" + Just be -> do + let msg = be ^. #message + assertBool + ("the error names the member index: " <> Text.unpack msg) + ("member 0" `Text.isInfixOf` msg) + assertBool + ("the error carries the member's own message: " <> Text.unpack msg) + ("sink exploded" `Text.isInfixOf` msg) + +-- | A memory sink that parks on the terminal event until released. +-- +-- The park is what makes the atomicity test deterministic: when +-- @parked@ is filled the consumer has already run 'commitTerminal' to +-- completion and is waiting for the worker, which is exactly the moment +-- an asynchronous exception used to leave a half-committed terminal +-- behind. +gatedSink :: IO (TVar [TraceEvent], MVar (), MVar (), TraceSink) +gatedSink = do + ref <- newTVarIO [] + parked <- newEmptyMVar + release <- newEmptyMVar + let step () e = do + atomically (modifyTVar' ref (e :)) + case e of + CallFinished {} -> putMVar parked () >> readMVar release + _ -> pure () + sink = TraceSink (Fold.foldlM' step (pure ())) + pure (ref, parked, release, sink) + +-- | Kill the consumer while it waits for a sink that has already taken +-- the terminal. The stream's exception path runs the trace finaliser a +-- second time, and it must find nothing left to do: one evidence +-- record, one terminal, and no synthetic @aborted@ 'CallFailed' on top +-- of the real 'CallFinished'. +terminalPathAtomicityTest :: TestTree +terminalPathAtomicityTest = + testCase "an async exception on the terminal path leaves one terminal and one evidence" $ do + let a = Custom "baikai-trace-terminal-atomicity" + registerOkWithEvidence a + (ref, parked, release, sink) <- gatedSink + outcome <- newEmptyMVar + consumer <- forkIO $ do + r <- try (withTrace sink (stubModel a) stubContext evidenceOptions) + putMVar outcome (r :: Either SomeException Response) + takeMVar parked + throwTo consumer ThreadKilled + r <- takeMVar outcome + assertBool "the consumer was killed" (isLeft r) + putMVar release () + events <- awaitEvents ref 3 + length [e | e@CallEvidence {} <- events] @?= 1 + length [e | e@CallFinished {} <- events] @?= 1 + length [e | e@CallFailed {} <- events] @?= 0 + +-- | Aim an asynchronous exception at the consumer the instant the +-- evidence event reaches the sink — while the consumer is pushing the +-- terminal and setting the flag. Fifty times, because the window is a +-- few instructions wide and no scheduling hook can hit it +-- deterministically; the plan's widened-window demonstration shows the +-- test detects the defect. +throwToAroundTerminalTest :: TestTree +throwToAroundTerminalTest = + testCase "fifty exceptions aimed at the terminal push never duplicate terminal or evidence" $ + forM_ [1 .. 50 :: Int] $ \i -> do + let a = Custom ("baikai-trace-throwto-" <> Text.pack (show i)) + registerOkWithEvidence a + ref <- newTVarIO [] + consumerVar <- newEmptyMVar + let step () e = do + atomically (modifyTVar' ref (e :)) + case e of + CallEvidence {} -> readMVar consumerVar >>= \tid -> throwTo tid ThreadKilled + _ -> pure () + sink = TraceSink (Fold.foldlM' step (pure ())) + outcome <- newEmptyMVar + tid <- forkIO $ do + r <- try (withTrace sink (stubModel a) stubContext evidenceOptions) + putMVar outcome (r :: Either SomeException Response) + putMVar consumerVar tid + _ <- takeMVar outcome + _ <- awaitEvents ref 3 + -- Let anything the finaliser might still push arrive before counting. + threadDelay 200000 + performMajorGC + settled <- reverse <$> readTVarIO ref + length [e | e@CallEvidence {} <- settled] @?= 1 + length [e | e@CallFinished {} <- settled] + length [e | e@CallFailed {} <- settled] @?= 1 + -- | The length assertion here used to read -- @assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids)@. --- It now reads 32, because 'newEventId' delegates to --- 'Baikai.Evidence.newCallId', which carries 128 bits rather than 64. --- The widening is the point of the replacement: the old generator --- packed a process-start /second/ into its high half and so repeated --- itself across processes started in the same second. +-- It reads 32 because 'Baikai.Evidence.newCallId', which replaced the +-- removed @newEventId@, carries 128 bits rather than 64. The widening +-- is the point of the replacement: the old generator packed a +-- process-start /second/ into its high half and so repeated itself +-- across processes started in the same second. eventIdUniquenessTest :: TestTree eventIdUniquenessTest = - testCase "newEventId yields 70000 distinct 32-char ids" $ do - ids <- replicateM 70000 newEventId + testCase "newCallId yields 70000 distinct 32-char ids" $ do + ids <- replicateM 70000 Ev.newCallId Set.size (Set.fromList ids) @?= 70000 assertBool "every id is 32 chars" (all ((== 32) . Text.length) ids) @@ -289,12 +493,11 @@ let resp = stubResponse a & #message . #usage .~ u handler _m _ctx _opts = pure resp in registerApiProvider - ApiProvider - { apiTag = a, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + ) fidelityTest :: TestTree fidelityTest = @@ -383,13 +586,129 @@ Nothing pure (stubResponse a & #evidence .~ ev) in registerApiProvider - ApiProvider - { apiTag = a, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + ) + +-- | 'registerOk' with an honest describer. +-- +-- The other fixtures answer 'noThinkingRequested' whatever the caller +-- set, which is exactly what hid the defect these tests pin: a stub +-- that always says "nothing was asked" cannot tell a path that lost the +-- caller's level from one that kept it. +registerOkHonest :: Api -> IO () +registerOkHonest a = + let handler _m _ctx _opts = pure (stubResponse a) + in registerApiProvider + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + & #describeThinking + .~ (\_ o -> Build.requestedTranslation o) + ) + +-- | A describer that answers with a wire shape of its own, so a test +-- can tell "the core asked the adapter" from "the core spelled +-- not_translated itself". +registerOkBudgetDescriber :: Api -> IO () +registerOkBudgetDescriber a = + let handler _m _ctx _opts = pure (stubResponse a) + budgetTranslation o = + Ev.ThinkingTranslation + { Ev.requested = o ^. #thinking, + Ev.mode = Ev.ThinkingModeBudget, + Ev.effortText = Nothing, + Ev.budgetTokens = Just 1024, + Ev.wireField = Just "thinking", + Ev.adjustments = [] } + in registerApiProvider + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + & #describeThinking + .~ (\_ o -> budgetTranslation o) + ) +thinkingOptions :: Options +thinkingOptions = evidenceOptions & #thinking .~ Just ThinkingMax + +-- | Read one key out of the encoded @thinking@ object. +thinkingField :: Text -> ModelCallEvidence -> Maybe Value +thinkingField k ev = + KeyMap.lookup (Key.fromText k) (asObject (maybe Null id (evidenceField "thinking" ev))) + +requestedLevelTests :: TestTree +requestedLevelTests = + testGroup + "the caller's thinking level on every evidence path" + [ abortRecordsRequestedLevelTest, + abortUsesTheAdapterDescriberTest, + noProviderRecordsRequestedLevelTest, + throwingHandlerRecordsRequestedLevelTest + ] + +abortRecordsRequestedLevelTest :: TestTree +abortRecordsRequestedLevelTest = + testCase "an abandoned stream records the level the caller asked for" $ do + let a = Custom "baikai-trace-abort-thinking" + registerOkHonest a + (ref, sink) <- memorySink + emitted <- + Stream.toList + (Stream.take 1 (withTraceStream sink (stubModel a) stubContext thinkingOptions)) + length emitted @?= 1 + events <- awaitEvents ref 3 + ev <- exactlyOneEvidence events + thinkingField "requested" ev @?= Just (String "max") + thinkingField "mode" ev @?= Just (String "not_translated") + +abortUsesTheAdapterDescriberTest :: TestTree +abortUsesTheAdapterDescriberTest = + testCase "an abandoned stream asks the registered adapter to describe the translation" $ do + let a = Custom "baikai-trace-abort-describer" + registerOkBudgetDescriber a + (ref, sink) <- memorySink + emitted <- + Stream.toList + (Stream.take 1 (withTraceStream sink (stubModel a) stubContext thinkingOptions)) + length emitted @?= 1 + events <- awaitEvents ref 3 + ev <- exactlyOneEvidence events + thinkingField "requested" ev @?= Just (String "max") + -- The proof that the core consulted the adapter rather than + -- spelling not_translated unconditionally. + thinkingField "mode" ev @?= Just (String "budget") + thinkingField "budget_tokens" ev @?= Just (Number 1024) + +noProviderRecordsRequestedLevelTest :: TestTree +noProviderRecordsRequestedLevelTest = + testCase "an unregistered provider records the level the caller asked for" $ do + let a = Custom "baikai-trace-unregistered-thinking" + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext thinkingOptions + events <- awaitEvents ref 3 + ev <- exactlyOneEvidence events + thinkingField "requested" ev @?= Just (String "max") + thinkingField "mode" ev @?= Just (String "not_translated") + +throwingHandlerRecordsRequestedLevelTest :: TestTree +throwingHandlerRecordsRequestedLevelTest = + testCase "a handler that threw records the level the caller asked for" $ do + let a = Custom "baikai-trace-throwing-thinking" + registerFail a (providerError "stub-failure") + (ref, sink) <- memorySink + _ <- withTrace sink (stubModel a) stubContext thinkingOptions + events <- awaitEvents ref 3 + ev <- exactlyOneEvidence events + thinkingField "requested" ev @?= Just (String "max") + thinkingField "mode" ev @?= Just (String "not_translated") + evidenceField "status" ev @?= Just (String "failed") + evidencesIn :: [TraceEvent] -> [ModelCallEvidence] evidencesIn events = [ev | CallEvidence {evidence = ev} <- events] @@ -420,7 +739,12 @@ strictSinkFailureIsStillOneTerminalTest, optOutSilentTest, optOutGoldenTest, - envelopeNotForcedTest + envelopeNotForcedTest, + strictNoRecordFailsTest, + strictNoRecordIsOneTerminalTest, + strictWithRecordSucceedsTest, + strictNoRecordErrorPathKeepsProviderErrorTest, + bestEffortNoRecordStillSucceedsTest ] -- | Assert the shape every record this plan produces must have: the @@ -446,12 +770,37 @@ -- | Exactly one evidence record per call, joined to the rest of the -- call's lines by the trace @eventId@. +-- | The record must reach the sink while the call is still open there. +-- +-- "Baikai.Trace" pushes 'CallEvidence' before the terminal since commit +-- @1717694@, because the OpenTelemetry sink ends and removes its span on +-- the terminal and so could never attach evidence that arrived after it. +-- 'docs\/capabilities\/model-call-evidence.md' claimed an ordering +-- assertion existed; this is it, and every evidence case runs it on its +-- own path — success, failure, abort, unregistered provider. +assertEvidencePrecedesTerminal :: [TraceEvent] -> IO () +assertEvidencePrecedesTerminal events = + case (findIndex isEvidence events, findIndex isTerminal events) of + (Just i, Just j) -> + assertBool + ("CallEvidence at " <> show i <> " must precede the terminal at " <> show j) + (i < j) + (Just _, Nothing) -> assertFailure "an evidence event without a terminal" + _ -> assertFailure "no evidence event to order" + where + isEvidence = \case CallEvidence {} -> True; _ -> False + isTerminal = \case + CallFinished {} -> True + CallFailed {} -> True + _ -> False + exactlyOneEvidence :: [TraceEvent] -> IO ModelCallEvidence exactlyOneEvidence events = case evidencesIn events of [ev] -> do let ids = Set.fromList [e ^. #eventId :: Text | e <- events] Set.size ids @?= 1 assertMinimalShape ev + assertEvidencePrecedesTerminal events pure ev other -> assertFailure @@ -549,7 +898,11 @@ -- something they cannot account for, with no way to notice: evidence -- that can vanish without the caller noticing is not evidence. let a = Custom "baikai-evidence-strict-throwing-sink" - registerOk a + -- The evidence-building fixture, so the sink is the only reason this + -- call can fail. With a provider that attaches no record, a strict + -- call now fails on that account before the sink is ever reached, + -- and this case would assert the sink rule against the record rule. + registerOkWithEvidence a result <- timeout 5000000 (withTrace throwingSink (stubModel a) stubContext strictOptions) case result of @@ -564,6 +917,86 @@ ("the error names the sink: " <> Text.unpack (be ^. #message)) ("trace sink failed" `Text.isInfixOf` (be ^. #message)) +-- | Strict mode guaranteed that a record which was built and then lost +-- fails the call. It did not guarantee that one was built: a provider +-- that attached nothing returned a successful response and wrote no +-- @call_evidence@ line, with no error anywhere. +strictNoRecordFailsTest :: TestTree +strictNoRecordFailsTest = + testCase "A STRICT CALL WHOSE PROVIDER ATTACHED NO RECORD FAILS, AND EMITS NO RECORD" $ do + let a = Custom "baikai-evidence-strict-no-record" + registerOk a + (ref, sink) <- memorySink + resp <- withTrace sink (stubModel a) stubContext strictOptions + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= ErrorReason + case responseError resp of + Nothing -> assertFailure "expected the missing record to fail the call" + Just be -> do + be ^. #category @?= OtherError + assertBool + ("the error names the missing record: " <> Text.unpack (be ^. #message)) + ("attached no evidence record" `Text.isInfixOf` (be ^. #message)) + events <- awaitEvents ref 2 + length [e | e@CallStarted {} <- events] @?= 1 + length [e | e@CallFailed {} <- events] @?= 1 + length (evidencesIn events) @?= 0 + +-- | The rewrite produces one terminal, not two. +strictNoRecordIsOneTerminalTest :: TestTree +strictNoRecordIsOneTerminalTest = + testCase "a record-less strict stream yields one EventError and no EventDone" $ do + let a = Custom "baikai-evidence-strict-no-record-stream" + registerOk a + events <- + Stream.toList (withTraceStream silent (stubModel a) stubContext strictOptions) + length [e | e@(EventDone _) <- events] @?= 0 + length [e | e@(EventError _) <- events] @?= 1 + +-- | The rewrite fires on the absence of a record, not on strictness +-- alone. +strictWithRecordSucceedsTest :: TestTree +strictWithRecordSucceedsTest = + testCase "a strict call whose provider attached a record still succeeds" $ do + let a = Custom "baikai-evidence-strict-with-record" + registerOkWithEvidence a + (ref, sink) <- memorySink + resp <- withTrace sink (stubModel a) stubContext strictOptions + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + responseError resp @?= Nothing + events <- awaitEvents ref 3 + length (evidencesIn events) @?= 1 + +-- | On the error path the provider's own error is the more useful of +-- the two, and the strict contract already holds: the call failed. +strictNoRecordErrorPathKeepsProviderErrorTest :: TestTree +strictNoRecordErrorPathKeepsProviderErrorTest = + testCase "a failed strict call keeps the provider's own error" $ do + let a = Custom "baikai-evidence-strict-provider-error" + registerFail a (providerError "stub-failure") + resp <- withTrace silent (stubModel a) stubContext strictOptions + case responseError resp of + Nothing -> assertFailure "expected the provider's failure to reach the response" + Just be -> do + assertBool + ("the provider's error survives: " <> Text.unpack (be ^. #message)) + ("stub-failure" `Text.isInfixOf` (be ^. #message)) + assertBool + "the missing-record error must not overwrite it" + (not ("attached no evidence record" `Text.isInfixOf` (be ^. #message))) + +-- | Best effort never refuses, here as everywhere. +bestEffortNoRecordStillSucceedsTest :: TestTree +bestEffortNoRecordStillSucceedsTest = + testCase "a best-effort call whose provider attached no record still succeeds" $ do + let a = Custom "baikai-evidence-best-effort-no-record" + registerOk a + resp <- withTrace silent (stubModel a) stubContext evidenceOptions + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + responseError resp @?= Nothing + -- | The exactly-once guarantee still holds when the terminal is -- rewritten. strictSinkFailureIsStillOneTerminalTest :: TestTree @@ -696,12 +1129,11 @@ Nothing pure (stubResponse a & #evidence .~ ev) registerApiProvider - ApiProvider - { apiTag = a, - stream = liftCompleteToStream handler, - complete = handler, - describeThinking = \_ _ -> noThinkingRequested - } + ( apiProviderWith + a + (liftCompleteToStream handler) + (handler) + ) (ref, sink) <- memorySink _ <- withTrace sink (stubModel a) stubContext stubOptions events <- reverse <$> readTVarIO ref diff --git a/test/TransportClassifySpec.hs b/test/TransportClassifySpec.hs new file mode 100644 --- /dev/null +++ b/test/TransportClassifySpec.hs @@ -0,0 +1,265 @@ +-- | The one transport classifier, pinned against the exception shapes +-- @http-client@, @tls@ and the socket layer actually raise. +-- +-- The rule under test is /where/ the failure happened, not what type it +-- is: a connection that existed and broke is retryable, a connection +-- that could never work is not, and a programming error is neither. The +-- cases below therefore pair each constructor with the phase it belongs +-- to, and the negative cases matter as much as the positive ones — a +-- classifier that calls a @userError@ a network blip feeds a retry loop +-- a bug it can never retry away. +module TransportClassifySpec (tests) where + +import Baikai.Error (BaikaiError (..), ErrorCategory (..), isRetryable) +import Baikai.Provider.Transport.Classify + ( classifyHttpException, + classifyHttpExceptionContent, + classifyIOException, + classifyTlsException, + classifyTransportException, + ) +import Control.Exception (toException) +import Data.ByteString (ByteString) +import Data.CaseInsensitive qualified as CI +import Data.Text qualified as Text +import Foreign.C.Error (Errno (..), eCONNABORTED, eCONNRESET) +import GHC.IO.Exception qualified as IOE +import Network.HTTP.Client qualified as HTTP +import Network.HTTP.Client.Internal qualified as HTTPI +import Network.HTTP.Types.Status (mkStatus) +import Network.HTTP.Types.Version (http11) +import Network.TLS qualified as TLS +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Provider.Transport.Classify" + [ testGroup "socket failures during the body read" ioTests, + testGroup "http-client exception content" httpContentTests, + testGroup "TLS failures" tlsTests, + testGroup "the top-level dispatcher" dispatchTests + ] + +-- ============================================================ +-- Fixtures +-- ============================================================ + +-- | An 'IOError' shaped the way the socket layer raises one during a +-- body read: a location naming the recv call, a description from the +-- kernel, an error type and an errno. +socketError :: IOE.IOErrorType -> Errno -> String -> IOE.IOException +socketError ty (Errno n) description = + IOE.IOError + { IOE.ioe_handle = Nothing, + IOE.ioe_type = ty, + IOE.ioe_location = "Network.Socket.recvBuf", + IOE.ioe_description = description, + IOE.ioe_errno = Just n, + IOE.ioe_filename = Nothing + } + +-- | The canonical mid-stream reset: the peer sent RST while the +-- response body was still arriving. +connectionReset :: IOE.IOException +connectionReset = socketError IOE.ResourceVanished eCONNRESET "Connection reset by peer" + +assertTransient :: BaikaiError -> Assertion +assertTransient be = do + category be @?= TransientError + isRetryable be @?= True + +assertNotRetryable :: ErrorCategory -> BaikaiError -> Assertion +assertNotRetryable expected be = do + category be @?= expected + isRetryable be @?= False + +assertJustTransient :: Maybe BaikaiError -> Assertion +assertJustTransient = \case + Just be -> assertTransient be + Nothing -> assertFailure "expected a classified transport failure, got Nothing" + +-- ============================================================ +-- Raw IOExceptions +-- ============================================================ + +ioTests :: [TestTree] +ioTests = + [ testCase "a connection reset during the body read is transient" $ + assertJustTransient (classifyIOException connectionReset), + -- base maps ECONNABORTED to the IOErrorType constructor named + -- OtherError, so a rule that looked only at the type would call an + -- aborted connection a programming error. + testCase "ECONNABORTED is recognised by errno when the error type is OtherError" $ + assertJustTransient + ( classifyIOException + (socketError IOE.OtherError eCONNABORTED "Software caused connection abort") + ), + testCase "an end-of-file on the socket is transient" $ + assertJustTransient + ( classifyIOException + (IOE.IOError Nothing IOE.EOF "brRead" "end of input" Nothing Nothing) + ), + testCase "a timed-out read is transient" $ + assertJustTransient + ( classifyIOException + (IOE.IOError Nothing IOE.TimeExpired "recv" "operation timed out" Nothing Nothing) + ), + testCase "a userError is not a transport failure" $ do + classifyIOException (userError "bug") @?= Nothing + classifyTransportException (toException (userError "bug")) @?= Nothing, + testCase "a missing file is not a transport failure" $ + classifyIOException + (IOE.IOError Nothing IOE.NoSuchThing "openFile" "does not exist" Nothing (Just "/nope")) + @?= Nothing, + testCase "the classified message keeps the socket detail" $ + case classifyIOException connectionReset of + Just be -> assertBool "message names the reset" ("reset by peer" `Text.isInfixOf` message be) + Nothing -> assertFailure "expected a classified transport failure" + ] + +-- ============================================================ +-- HttpExceptionContent +-- ============================================================ + +httpContentTests :: [TestTree] +httpContentTests = + [ testCase "InvalidChunkHeaders is transient" $ + assertTransient (classifyHttpExceptionContent HTTP.InvalidChunkHeaders), + testCase "ResponseBodyTooShort is transient" $ + assertTransient (classifyHttpExceptionContent (HTTP.ResponseBodyTooShort 100 40)), + testCase "ConnectionClosed is transient" $ + assertTransient (classifyHttpExceptionContent HTTP.ConnectionClosed), + testCase "IncompleteHeaders is transient" $ + assertTransient (classifyHttpExceptionContent HTTP.IncompleteHeaders), + testCase "NoResponseDataReceived is transient" $ + assertTransient (classifyHttpExceptionContent HTTP.NoResponseDataReceived), + testCase "ConnectionTimeout and ResponseTimeout are transient" $ do + assertTransient (classifyHttpExceptionContent HTTP.ConnectionTimeout) + assertTransient (classifyHttpExceptionContent HTTP.ResponseTimeout), + testCase "ConnectionFailure is transient" $ + assertTransient + (classifyHttpExceptionContent (HTTP.ConnectionFailure (toException connectionReset))), + testCase "InternalException unwraps to the inner socket rule" $ + assertTransient + (classifyHttpExceptionContent (HTTP.InternalException (toException connectionReset))), + testCase "InternalException unwraps to the inner TLS rule" $ + assertNotRetryable + OtherError + ( classifyHttpExceptionContent + ( HTTP.InternalException + (toException (TLS.HandshakeFailed (TLS.Error_Misc "certificate rejected"))) + ) + ), + testCase "InvalidUrlException is InvalidRequest" $ + assertNotRetryable + InvalidRequest + (classifyHttpException (HTTP.InvalidUrlException "http://%%%" "invalid escape")), + testCase "InvalidRequestHeader is InvalidRequest" $ + assertNotRetryable + InvalidRequest + (classifyHttpExceptionContent (HTTP.InvalidRequestHeader "X-Bad: \n")), + testCase "InvalidDestinationHost is InvalidRequest" $ + assertNotRetryable + InvalidRequest + (classifyHttpExceptionContent (HTTP.InvalidDestinationHost "bad host")), + testCase "WrongRequestBodyStreamSize is InvalidRequest" $ + assertNotRetryable + InvalidRequest + (classifyHttpExceptionContent (HTTP.WrongRequestBodyStreamSize 10 4)), + -- Unreachable from baikai's own transports, which never install + -- throwErrorStatusCodes; pinned for third-party providers built on + -- http-client, and because it is the one arm that reads headers. + testCase "StatusCodeException classifies by status and converts an HTTP-date Retry-After" $ do + let be = + classifyHttpExceptionContent + ( HTTP.StatusCodeException + ( statusResponse + 429 + [ ("Retry-After", "Wed, 21 Oct 2026 07:28:00 GMT"), + ("Date", "Wed, 21 Oct 2026 07:27:15 GMT") + ] + ) + "slow down" + ) + category be @?= RateLimited + httpStatus be @?= Just 429 + retryAfterSeconds be @?= Just 45, + testCase "StatusCodeException falls back to the integer form when there is no Date" $ do + let be = + classifyHttpExceptionContent + (HTTP.StatusCodeException (statusResponse 429 [("Retry-After", "9")]) "") + retryAfterSeconds be @?= Just 9, + -- A server that does not speak HTTP, or a proxy or TLS setup that + -- cannot work, will answer the retry exactly the same way. + testCase "InvalidStatusLine, TooManyHeaderFields and TlsNotSupported are not retryable" $ do + assertNotRetryable OtherError (classifyHttpExceptionContent (HTTP.InvalidStatusLine "gibberish")) + assertNotRetryable OtherError (classifyHttpExceptionContent HTTP.TooManyHeaderFields) + assertNotRetryable OtherError (classifyHttpExceptionContent HTTP.TlsNotSupported) + assertNotRetryable OtherError (classifyHttpExceptionContent (HTTP.TooManyRedirects [])) + ] + +-- | The header-carrying half of a 'HTTP.StatusCodeException': the body +-- travels separately, so the response's own body is @()@. +statusResponse :: Int -> [(ByteString, ByteString)] -> HTTP.Response () +statusResponse status hdrs = + HTTPI.Response + { HTTPI.responseStatus = mkStatus status "", + HTTPI.responseVersion = http11, + HTTPI.responseHeaders = [(CI.mk n, v) | (n, v) <- hdrs], + HTTPI.responseBody = (), + HTTPI.responseCookieJar = HTTP.createCookieJar [], + HTTPI.responseClose' = HTTPI.ResponseClose (pure ()), + HTTPI.responseOriginalRequest = HTTP.defaultRequest, + HTTPI.responseEarlyHints = [] + } + +-- ============================================================ +-- TLS +-- ============================================================ + +tlsTests :: [TestTree] +tlsTests = + [ -- Upstream's own manager agrees: http-client-tls treats a + -- post-handshake EOF as retryable. + testCase "a TLS end-of-file after the handshake is transient" $ + assertTransient (classifyTlsException (TLS.PostHandshake TLS.Error_EOF)), + testCase "a terminated TLS session is transient" $ + assertTransient (classifyTlsException (TLS.Terminated True "peer closed" TLS.Error_EOF)), + testCase "an uncontextualized TLS failure is transient" $ + assertTransient (classifyTlsException (TLS.Uncontextualized TLS.Error_EOF)), + -- Against a well-known API host a handshake failure is a trust-store + -- or protocol mismatch, which the retry reproduces. A socket reset + -- during connect arrives as ConnectionFailure instead, and is + -- transient. + testCase "a failed TLS handshake is not retryable" $ + assertNotRetryable + OtherError + (classifyTlsException (TLS.HandshakeFailed (TLS.Error_Misc "certificate rejected"))), + testCase "a session that never existed is not retryable" $ do + assertNotRetryable OtherError (classifyTlsException TLS.ConnectionNotEstablished) + assertNotRetryable OtherError (classifyTlsException TLS.MissingHandshake) + ] + +-- ============================================================ +-- Dispatch +-- ============================================================ + +dispatchTests :: [TestTree] +dispatchTests = + [ testCase "a raw IOException reaches the socket rule" $ + assertJustTransient (classifyTransportException (toException connectionReset)), + -- This is the shape that reaches a worker raw: http-client wraps the + -- body reader with nothing that would convert it. + testCase "a raw TLSException reaches the TLS rule" $ + assertJustTransient + (classifyTransportException (toException (TLS.PostHandshake TLS.Error_EOF))), + testCase "an HttpException reaches the http-client rule" $ + assertJustTransient + ( classifyTransportException + (toException (HTTP.HttpExceptionRequest HTTP.defaultRequest HTTP.InvalidChunkHeaders)) + ), + testCase "anything else is not a transport failure" $ + classifyTransportException (toException (userError "callback bug")) @?= Nothing + ] diff --git a/test/UrlSpec.hs b/test/UrlSpec.hs new file mode 100644 --- /dev/null +++ b/test/UrlSpec.hs @@ -0,0 +1,275 @@ +-- | The one URL parser, and the three decisions that hang off it: which +-- API key a base URL resolves, which compatibility record it selects, +-- and what an evidence record calls the endpoint. +-- +-- The cases that matter most are the negative ones. baikai routes a +-- credential by host name, so a parser that can be talked into naming +-- the wrong host is a parser that can be talked into sending one +-- provider's key to another. +module UrlSpec (urlTests) where + +import Baikai + ( autoDetectAnthropicMessages, + autoDetectOpenAICompletions, + defaultAnthropicMessagesCompat, + defaultApiKeyEnvForBaseUrl, + defaultOpenAICompletionsCompat, + ) +import Baikai.Evidence.Build (sanitizeEndpoint) +import Baikai.Http qualified as Http +import Baikai.Url + ( UrlParts (..), + baseUrlProblem, + parseUrl, + renderEndpoint, + stripApiVersion, + urlHost, + ) +import Control.Monad (forM_) +import Data.Text (Text) +import Data.Text qualified as Text +import Servant.Client qualified as Client +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +urlTests :: TestTree +urlTests = + testGroup + "Baikai.Url" + [ authorityBoundaryTests, + hostAndPortTests, + renderingTests, + stripApiVersionTests, + baseUrlProblemTests, + canonicalBaseUrlTests + ] + +-- -------------------------------------------------------------------- +-- Where the authority ends +-- -------------------------------------------------------------------- + +-- | The defect this module exists for. Reading the text after the last +-- @\@@ anywhere in a URL lets anyone who can set @baseUrl@ choose which +-- provider's key baikai sends — and send it to their own host. +authorityBoundaryTests :: TestTree +authorityBoundaryTests = + testGroup + "the authority ends at the first /, ? or #" + [ testCase "an @ in the query does not rename the host" $ do + let url = "https://proxy.example.com/v1?u=@api.openai.com" + urlHost url @?= Just "proxy.example.com" + -- The consequences, asserted rather than assumed: no key is + -- resolved for an unknown host, and no vendor compat record is + -- selected for it either. + defaultApiKeyEnvForBaseUrl url @?= Nothing + assertBool + "no OpenAI compat record for a proxy host" + (autoDetectOpenAICompletions url == defaultOpenAICompletionsCompat) + assertBool + "no vendor Anthropic compat record for a proxy host" + (autoDetectAnthropicMessages url == defaultAnthropicMessagesCompat), + testCase "an @ in a query with no path does not rename the host" $ + -- The case the evidence module's own parser got wrong: it + -- bounded the authority at the first "/" only. + urlHost "https://proxy.example.com?u=@api.openai.com" + @?= Just "proxy.example.com", + testCase "an @ in a fragment does not rename the host" $ + urlHost "https://proxy.example.com#@api.openai.com" + @?= Just "proxy.example.com", + testCase "an @ in the path does not rename the host" $ do + urlHost "https://api.openai.com/v1/@x" @?= Just "api.openai.com" + defaultApiKeyEnvForBaseUrl "https://api.openai.com/v1/@x" + @?= Just "OPENAI_API_KEY", + testCase "real userinfo is still dropped" $ do + let url = "https://user:pw@api.openai.com/" + urlHost url @?= Just "api.openai.com" + fmap hasUserInfo (parseUrl url) @?= Just True + defaultApiKeyEnvForBaseUrl url @?= Just "OPENAI_API_KEY" + ] + +-- -------------------------------------------------------------------- +-- Hosts, ports and paths +-- -------------------------------------------------------------------- + +hostAndPortTests :: TestTree +hostAndPortTests = + testGroup + "hosts, ports and paths" + [ testCase "an IPv6 literal keeps its brackets and its port" $ do + parts <- expectParse "http://[::1]:8080/v1" + host parts @?= "[::1]" + port parts @?= Just 8080 + path parts @?= "/v1", + testCase "an IPv6 literal with no port has no port" $ do + parts <- expectParse "https://[::1]" + host parts @?= "[::1]" + port parts @?= Nothing, + testCase "the host is lower-cased and the path is not" $ do + parts <- expectParse "https://Api.OpenAI.com:443/V1/" + host parts @?= "api.openai.com" + port parts @?= Just 443 + path parts @?= "/V1/", + testCase "a non-numeric port is ignored and the host survives" $ do + parts <- expectParse "https://api.openai.com:notaport/v1" + host parts @?= "api.openai.com" + port parts @?= Nothing, + testCase "a scheme-less URL parses with no scheme" $ do + parts <- expectParse "api.openai.com" + scheme parts @?= Nothing + host parts @?= "api.openai.com", + testCase "a scheme is recognised only when it looks like one" $ do + parts <- expectParse "HTTPS://Api.OpenAI.com" + scheme parts @?= Just "https", + testCase "no host means no result" $ do + parseUrl "" @?= Nothing + parseUrl "https://" @?= Nothing + parseUrl " " @?= Nothing + ] + +-- -------------------------------------------------------------------- +-- Rendering an endpoint +-- -------------------------------------------------------------------- + +renderingTests :: TestTree +renderingTests = + testGroup + "rendering an endpoint" + [ testCase "userinfo, query and fragment are gone; scheme and host are lower-cased" $ do + let url = "https://user:pw@Host.example:8443/a/b?k=v#f" + parts <- expectParse url + renderEndpoint parts @?= "https://host.example:8443/a/b" + -- The evidence record's endpoint is the same function, so the + -- two cannot drift. + sanitizeEndpoint url @?= Just "https://host.example:8443/a/b", + testCase "an empty endpoint is absent rather than empty" $ + sanitizeEndpoint "" @?= Nothing + ] + +-- -------------------------------------------------------------------- +-- Stripping a version segment +-- -------------------------------------------------------------------- + +stripApiVersionTests :: TestTree +stripApiVersionTests = + testGroup + "stripApiVersion removes one trailing /v1 segment" + [ testCase "a bare version path becomes empty" $ do + stripApiVersion "/v1" @?= "" + stripApiVersion "/v1/" @?= "" + stripApiVersion "/" @?= "" + stripApiVersion "" @?= "" + stripApiVersion "v1" @?= "", + testCase "a mounted API keeps its prefix" $ do + stripApiVersion "/api/v1" @?= "/api" + stripApiVersion "/compatible-mode/v1/" @?= "/compatible-mode" + stripApiVersion "api" @?= "/api", + testCase "a segment that merely starts with v1 is untouched" $ do + stripApiVersion "/v10" @?= "/v10" + stripApiVersion "/v1beta" @?= "/v1beta" + ] + +-- -------------------------------------------------------------------- +-- Fitness as a base URL +-- -------------------------------------------------------------------- + +baseUrlProblemTests :: TestTree +baseUrlProblemTests = + testGroup + "baseUrlProblem" + [ testCase "the shapes baikai supports are accepted" $ do + baseUrlProblem "https://api.openai.com" @?= Nothing + baseUrlProblem "https://api.deepseek.com/v1" @?= Nothing + baseUrlProblem "https://openrouter.ai/api" @?= Nothing + baseUrlProblem "http://localhost:11434" @?= Nothing, + testCase "a query string is refused without echoing it" $ do + problem <- expectProblem "https://h.example/v1?api-version=1" + assertBool + ("names the problem: " <> Text.unpack problem) + ("query string" `Text.isInfixOf` problem) + assertBool + ("does not echo the query: " <> Text.unpack problem) + (not ("api-version=1" `Text.isInfixOf` problem)), + testCase "userinfo is refused without echoing the password" $ do + problem <- expectProblem "https://u:secret@h.example" + assertBool + ("names the problem: " <> Text.unpack problem) + ("credentials" `Text.isInfixOf` problem) + assertBool + ("does not echo the password: " <> Text.unpack problem) + (not ("secret" `Text.isInfixOf` problem)), + testCase "a missing scheme is refused, saying which to use" $ do + problem <- expectProblem "h.example" + assertBool + ("names the fix: " <> Text.unpack problem) + ("https://" `Text.isInfixOf` problem), + testCase "a scheme baikai does not send is refused" $ do + problem <- expectProblem "ftp://h.example" + assertBool + ("names the scheme: " <> Text.unpack problem) + ("ftp" `Text.isInfixOf` problem), + testCase "a fragment is refused" $ do + problem <- expectProblem "https://h.example/v1#frag" + assertBool + ("names the problem: " <> Text.unpack problem) + ("fragment" `Text.isInfixOf` problem), + testCase "a full endpoint URL is refused as a base URL" $ do + forM_ ["https://h.example/v1/chat/completions", "https://h.example/v1/messages", "https://h.example/v1/embeddings"] $ \url -> do + problem <- expectProblem url + assertBool + ("names the problem for " <> Text.unpack url <> ": " <> Text.unpack problem) + ("endpoint path" `Text.isInfixOf` problem), + testCase "text that names no host is refused" $ do + problem <- expectProblem "" + assertBool + ("names the problem: " <> Text.unpack problem) + ("no host" `Text.isInfixOf` problem) + ] + +-- -------------------------------------------------------------------- +-- Helpers +-- -------------------------------------------------------------------- + +expectParse :: Text -> IO UrlParts +expectParse url = case parseUrl url of + Nothing -> assertFailure ("expected " <> Text.unpack url <> " to parse") + Just parts -> pure parts + +expectProblem :: Text -> IO Text +expectProblem url = case baseUrlProblem url of + Nothing -> assertFailure ("expected " <> Text.unpack url <> " to be refused") + Just problem -> pure problem + +-- -------------------------------------------------------------------- +-- What the transports actually connect to +-- -------------------------------------------------------------------- + +-- | The normalisation the connection cache keys on, and the composition +-- rule the transports rely on. +canonicalBaseUrlTests :: TestTree +canonicalBaseUrlTests = + testGroup + "canonicalBaseUrl" + [ testCase "a trailing /v1 and its absence are the same target" $ do + withVersion <- expectCanonical "https://api.deepseek.com/v1" + without <- expectCanonical "https://api.deepseek.com" + Client.showBaseUrl withVersion @?= Client.showBaseUrl without, + testCase "the host is lower-cased and a default port is implied" $ do + base <- expectCanonical "https://Api.OpenAI.com:443/" + Client.showBaseUrl base @?= "https://api.openai.com", + testCase "a mounted API keeps its prefix without its version" $ do + base <- expectCanonical "https://openrouter.ai/api/v1/" + Client.baseUrlPath base @?= "/api", + testCase "an unusable base URL is a reason, not an exception" $ + case Http.canonicalBaseUrl "h.test" of + Right base -> + assertFailure ("expected a refusal, got " <> Client.showBaseUrl base) + Left problem -> + assertBool + ("names the fix: " <> Text.unpack problem) + ("https://" `Text.isInfixOf` problem) + ] + +expectCanonical :: Text -> IO Client.BaseUrl +expectCanonical url = case Http.canonicalBaseUrl url of + Left problem -> assertFailure (Text.unpack (url <> " was refused: " <> problem)) + Right base -> pure base