diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,183 @@ ## [Unreleased] +## [baikai 0.7.0.0] - 2026-09-08 + +### Added + +- `BaikaiError.refusalCategory` preserves an Anthropic refusal's + provider category. JSON adds `refusal_category`; older errors still decode. + Evidence schema 2.5 records the addition without changing digest inputs. + __Breaking__ to construct a `BaikaiError` from its full field list. + +- `Speed`, `Options.speed`, catalog-owned fast rates and + `computeCostAtSpeed`. Anthropic gates fast mode by model capability, adds the + beta header and records unsupported drops. Terminal pricing uses observed + speed, including cache duration; unreported speed is an explicit estimate. + Older `Model` JSON defaults the new fields safely. __Breaking__: public + records and sum types gain fields and constructors. + +- API usage now records observed service tiers, inference speed and server-tool + use in optional billing facts covered by evidence schema 2.2. Missing service + information and uncurated products produce explicit standard-rate estimates. + `computeCostForService` separates requested and observed service, while + `computeCostAtRates` prices a resolved rate set once for future speed policies. + Empty billing facts preserve legacy availability JSON; a CLI-reported zero + cost retains its reported-total source. __Breaking__: the public vocabulary + and records gain members. + +- Failed trace terminals now retain partial response token counts, cost basis, + usage availability and USD totals. Synthetic aborts leave unreported billing + absent; legacy failed trace JSON still decodes. __Breaking__: `TraceEvent`'s + `CallFailed` gains fields. See `baikai-trace-otel 0.4.0.1` for the export. + +- Successful trace terminals and call-log records carry optional cost basis and + usage availability; call logs also carry cache-write counts. Old JSON decodes + with absent metadata and empty additive-zero bases stay omitted from traces. + __Breaking__: `CallFinished` and the call-log record gain fields. + +- Optional `Usage.availability` and shared inclusive/exclusive billing + normalization, in the new `Baikai.Usage.Normalize`. OpenAI Chat/Responses and + Claude preserve missing cache counters as explicit estimation reasons, + distinguish reported zeroes, and merge cumulative usage without + double-counting. Schema 2.2 commits provider availability while preserving + legacy usage digests. __Breaking__: `Usage` gains a field. + +- Optional `Model.pricingPolicy`, exact whole-request context tiers, + and an explicit cache-duration rate resolver. Generated Astra pricing changes + above 272000 input tokens; Fable exposes its one-hour write price. `Cost.basis` + preserves calculation sources and estimation reasons when summed. Evidence + schema 2.2 serializes the local basis without including local pricing metadata + in provider commitments. __Breaking__: `Model` and `Cost` gain fields. + +- Separate `OpenAIResponses` dispatch and compatibility types, and + optional provider/model-scoped `ThinkingContent.replayState` with opaque + diagnostic output and backward-compatible JSON decoding. Evidence schema 2.2 + includes replay state and optional billing facts in commitments while preserving + legacy encodings when those fields are absent. __Breaking__ for a `case` over + `Api` that is exhaustive without a wildcard. + +- `Baikai.Evidence.ThinkingTranslation` gains `displayText` and + `ThinkingAdjustment` gains `ThinkingSummaryUnavailable`, so a transport can + record the thinking display setting it asked for and diagnose a successful + response whose thinking blocks carry no readable summary. `Baikai.Compat` + gains `supportsForcedToolChoice`; legacy JSON defaults it to True. + __Breaking__ for an exhaustive `case` over `ThinkingAdjustment`. + +- GPT-6 Astra and Claude Fable 5.1 catalog bindings, with verified + pricing, token limits, and Anthropic thinking/sampling compatibility. + +- Repository `update-models` skill for verifying provider releases and refreshing + the curated JSON and generated Haskell catalog. + +### Fixed + +- Preserve OpenAI endpoint capability facts through catalog refreshes. + +- Chat and Claude reject provider-scoped reasoning replay they cannot encode. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +## [baikai-claude 0.7.0.0] - 2026-09-08 + +### Changed + +- Refusal messages include the reported category and explanation, + retaining the original message when neither exists. Classification remains + non-retryable `ContentFiltered`. Server-side fallbacks remain deliberately + unsupported, as recorded in ADR 0005. + +- Adaptive reasoning requests explicitly ask for summarized + thinking. Evidence schema 2.4 records the display setting and diagnoses + successful responses whose thinking blocks contain no readable summary. + Budget and absent-thinking request shapes, signed empty blocks, redacted + content and multi-turn replay are preserved. + +- Fast mode is gated by the generated model capability: it adds the Anthropic + beta header for a model that advertises it and records an evidence adjustment + for one that does not. + +### Fixed + +- Price Fable cache writes using the TTL in the shaped request, + including compatibility downgrades. Missing write-duration context is explicit + in the cost basis. + +- Reject forced tool choices locally on Fable 5.1, using the + generated `supportsForcedToolChoice` capability. Automatic tool rounds retain + signed empty/visible thinking, redacted blocks and prior-message order. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-openai 0.7.0.0] - 2026-09-08 + +### Added + +- Explicit `Baikai.Provider.OpenAI.Responses` registration and + stream/complete provider with stateless reasoning replay, function tool turns, + structured output and bounded worker cleanup, across the new + `Baikai.Provider.OpenAI.Responses.{Request,Stream,Assembler}` modules. Astra + now selects this provider through a per-model catalog override; callers must + register it explicitly. Cache writes, billing availability and context pricing + are integrated. + +- `Baikai.Provider.OpenAI.Internal.Usage`, the shared usage mapping both the + Chat Completions and Responses transports read. + +### Fixed + +- Reject tools locally for models whose Chat Completions endpoint + disallows them, including GPT-6 Astra. Respect generated effort policies and + sampling restrictions, with matching translation evidence and strict refusal. + +- Validate Responses terminals and enforce the stream contracts. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-trace-otel 0.4.0.1] - 2026-09-08 + +### Added + +- Successful and failed spans export `baikai.cost.basis` and + `baikai.usage.availability` as canonically encoded JSON. A failed span now + also carries the input/output token counts and USD total that + `baikai 0.7.0.0` retains on `CallFailed`, alongside its error status. + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, and now depends on `aeson ^>=2.2` to encode the + two new attributes. + +## [baikai-effectful 0.4.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-kit 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-agent 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, `baikai-claude ^>=0.7` and + `baikai-openai ^>=0.7`. No API change. + ## [baikai 0.6.0.1] - 2026-08-30 ### Fixed 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.6.0.1 +version: 0.7.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -83,6 +83,7 @@ Baikai.Provider.Transport.Classify Baikai.Response Baikai.ResponseFormat + Baikai.Speed Baikai.StopReason Baikai.Stream Baikai.Stream.Event @@ -93,6 +94,7 @@ Baikai.Trace.Sink Baikai.Url Baikai.Usage + Baikai.Usage.Normalize -- The cabal-generated version module. 'Baikai.Evidence.Build' reads -- it so an evidence record can name the build that produced it, @@ -193,6 +195,7 @@ GenModelsSpec HelpersSpec InteractiveSpec + PricingPolicySpec PublicSurfaceSpec StreamSpec StreamWorkerSpec diff --git a/fetch/FetchModelsCore.hs b/fetch/FetchModelsCore.hs --- a/fetch/FetchModelsCore.hs +++ b/fetch/FetchModelsCore.hs @@ -16,7 +16,8 @@ -- emitted, and only if upstream marks them @tool_call: true@. For -- @openai@ this excludes Responses-API-only ids (@*-pro@, @*-codex@, -- @*-deep-research@) because @baikai/data/models/openai.json@ speaks --- @openai-chat-completions@ and 'Baikai.Api' has no Responses tag. +-- @openai-chat-completions@ by default. Per-model API overrides allow +-- explicitly curated Responses models without changing the older routes. -- -- == Override philosophy -- @@ -64,9 +65,11 @@ ) where -import Baikai.Compat (AnthropicThinkingStyle (..)) +import Baikai.Compat (AnthropicThinkingStyle (..), OpenAICompletionsCompat (..), OpenAIResponsesCompat (..), defaultOpenAIResponsesCompat) import Baikai.Model (InputModality (..)) +import Baikai.Model qualified as Model import Baikai.Prelude +import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) import Data.Aeson (Value (String), eitherDecode, encode, withObject, (.!=), (.:), (.:?)) import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) @@ -77,8 +80,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Maybe (fromMaybe) -import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific) -import Data.Set (Set) +import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific, fromRationalRepetendUnlimited) import Data.Set qualified as Set import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8, encodeUtf8) @@ -200,15 +202,17 @@ -- JSON into the generated 'Baikai.Compat.AnthropicMessagesCompat'. data AnthropicGenerationFacts = AnthropicGenerationFacts { thinkingStyle :: !AnthropicThinkingStyle, - supportsSamplingParameters :: !Bool + supportsSamplingParameters :: !Bool, + supportsForcedToolChoice :: !Bool, + fastModeCost :: !(Maybe CatalogCost) } 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 +-- | Per-model endpoint facts preserved through catalog refreshes. +data CatalogModelCompat + = CatalogAnthropicCompat !AnthropicGenerationFacts + | CatalogOpenAICompat !OpenAICompletionsCompat + | CatalogResponsesCompat !OpenAIResponsesCompat deriving stock (Eq, Show, Generic) -- | One emitted catalog model. @enabled@ is always @true@ for emitted @@ -219,8 +223,11 @@ reasoning :: !Bool, input :: ![InputModality], cost :: !CatalogCost, + fastModeCost :: !(Maybe CatalogCost), + pricingPolicy :: !(Maybe Model.PricingPolicy), contextWindow :: !Integer, maxOutputTokens :: !Integer, + apiOverride :: !(Maybe Text), compat :: !(Maybe CatalogModelCompat) } deriving stock (Eq, Show, Generic) @@ -247,6 +254,7 @@ -- | 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. + apiFor :: !(Text -> Maybe Text), compatFor :: !(Text -> Maybe CatalogModelCompat) } deriving stock (Generic) @@ -254,32 +262,46 @@ -- | Curation include set for OpenAI: the chat-completions-compatible -- current line. Responses-API-only ids (@*-pro@, @*-codex@, -- @*-deep-research@) are deliberately absent. -openaiInclude :: Set Text +openaiInclude :: Map Text (Maybe CatalogModelCompat) openaiInclude = - Set.fromList - [ "gpt-5.6", - "gpt-5.6-luna", - "gpt-5.6-sol", - "gpt-5.6-terra", - "gpt-5.5", - "gpt-5.4", - "gpt-5.4-mini", - "gpt-5.4-nano", - "gpt-5.2", - "gpt-5.1", - "gpt-5", - "gpt-5-mini", - "gpt-5-nano", - "gpt-4.1", - "gpt-4.1-mini", - "gpt-4.1-nano", - "gpt-4o", - "gpt-4o-mini", - "o3", - "o3-mini", - "o4-mini", - "o1" - ] + Map.insert "gpt-6-astra" (Just (CatalogResponsesCompat astraResponsesFacts)) $ + Map.fromList + [ (model, Nothing) + | model <- + [ "gpt-5.6", + "gpt-5.6-luna", + "gpt-5.6-sol", + "gpt-5.6-terra", + "gpt-5.5", + "gpt-5.4", + "gpt-5.4-mini", + "gpt-5.4-nano", + "gpt-5.2", + "gpt-5.1", + "gpt-5", + "gpt-5-mini", + "gpt-5-nano", + "gpt-4.1", + "gpt-4.1-mini", + "gpt-4.1-nano", + "gpt-4o", + "gpt-4o-mini", + "o3", + "o3-mini", + "o4-mini", + "o1" + ] + ] + where + -- 2026-09-07: native tools require Responses; only modern 30m cache TTL. + -- https://developers.openai.com/api/docs/guides/latest-model + astraResponsesFacts = + defaultOpenAIResponsesCompat + { supportsPromptCacheOptions = True, + supportsLongCacheRetention = False, + supportsSamplingParameters = False, + supportedReasoningEfforts = Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] + } -- | Curation include set for Anthropic: the current generations, each -- keyed to the request-shaping facts of its generation. @@ -299,10 +321,10 @@ -- 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), + ("claude-opus-5", fastAdaptive), -- 2026-08-27: adaptive-only, sampling parameters rejected with a -- 400 — same source. - ("claude-opus-4-8", adaptiveNoSampling), + ("claude-opus-4-8", fastAdaptive), -- 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 @@ -325,22 +347,35 @@ -- 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) + ("claude-fable-5", adaptiveNoSampling), + -- 2026-09-07: always-on adaptive thinking; omit sampling parameters. + -- https://platform.claude.com/docs/en/models/fable-5-1/whats-new-fable-5-1 + ("claude-fable-5-1", adaptiveNoSampling & #supportsForcedToolChoice .~ False) ] where - adaptiveNoSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive False - adaptiveWithSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive True - budgetWithSampling = AnthropicGenerationFacts AnthropicThinkingBudget True + -- 2026-09-07: all curated predecessors accept forced choice (subject to + -- their separate manual-thinking constraint); only Fable 5.1 rejects it. + -- https://platform.claude.com/docs/en/api/errors + -- https://platform.claude.com/docs/en/models/fable-5-1/migration-guide + -- 2026-09-07: Opus 5 and 4.8 only; cache multipliers stack on fast rates. + -- https://platform.claude.com/docs/en/build-with-claude/fast-mode + fastAdaptive = adaptiveNoSampling & #fastModeCost ?~ CatalogCost 10 50 1 12.5 + adaptiveNoSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive False True Nothing + adaptiveWithSampling = AnthropicGenerationFacts AnthropicThinkingAdaptive True True Nothing + budgetWithSampling = AnthropicGenerationFacts AnthropicThinkingBudget True True Nothing --- | Provider spec for OpenAI's first-party chat-completions endpoint. +-- | OpenAI curation with a Chat default and explicit Responses overrides. openaiSpec :: ProviderSpec openaiSpec = ProviderSpec { provider = "openai", baseUrl = "https://api.openai.com", api = "openai-chat-completions", - include = (`Set.member` openaiInclude), - compatFor = const Nothing + include = (`Map.member` openaiInclude), + apiFor = \mid -> case Map.lookup mid openaiInclude >>= id of + Just (CatalogResponsesCompat _) -> Just "openai-responses" + _ -> Nothing, + compatFor = \mid -> Map.lookup mid openaiInclude >>= id } -- | Provider spec for Anthropic's first-party messages endpoint. @@ -351,6 +386,7 @@ baseUrl = "https://api.anthropic.com", api = "anthropic-messages", include = (`Map.member` anthropicInclude), + apiFor = const Nothing, compatFor = fmap CatalogAnthropicCompat . (`Map.lookup` anthropicInclude) } @@ -390,8 +426,13 @@ cacheReadCost = fromMaybe 0 (m ^. #cacheReadCost), cacheWriteCost = fromMaybe 0 (m ^. #cacheWriteCost) }, + fastModeCost = case (spec ^. #compatFor) (m ^. #modelId) of + Just (CatalogAnthropicCompat facts) -> facts ^. #fastModeCost + _ -> Nothing, + pricingPolicy = Map.lookup (spec ^. #provider, m ^. #modelId) pricingPolicies, contextWindow = fromMaybe 0 (m ^. #contextWindow), maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens), + apiOverride = (spec ^. #apiFor) (m ^. #modelId), compat = (spec ^. #compatFor) (m ^. #modelId) } @@ -569,6 +610,9 @@ " \"contextWindow\": " <> Text.pack (show (m ^. #contextWindow)) <> ",", " \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> "," ] + ++ maybe [] (\a -> [" \"api\": " <> jsonString a <> ","]) (m ^. #apiOverride) + ++ maybe [] (\r -> [" \"fastModeCost\": " <> renderFastCost r <> ","]) (m ^. #fastModeCost) + ++ maybe [] (\p -> [" \"pricingPolicy\": " <> renderPricingPolicy p <> ","]) (m ^. #pricingPolicy) ++ renderModelCompat (m ^. #compat) ++ [ " \"enabled\": true", " }" @@ -576,6 +620,27 @@ where c = m ^. #cost +-- | Provider documentation verified 2026-09-07. These rules supplement base +-- models.dev rates, which do not describe the full request billing policy. +-- https://developers.openai.com/api/docs/models/gpt-6-astra +-- https://platform.claude.com/docs/en/models/fable-5-1/overview +-- https://platform.claude.com/docs/en/build-with-claude/fast-mode +pricingPolicies :: Map (Text, Text) Model.PricingPolicy +pricingPolicies = + Map.fromList + [ (("anthropic", "claude-opus-5"), Model.PricingPolicy [] (Just 10)), + (("anthropic", "claude-opus-4-8"), Model.PricingPolicy [] (Just 10)), + (("openai", "gpt-6-astra"), Model.PricingPolicy [Model.InputPriceTier 272000 (Model.ModelCost 20 75 2 25)] Nothing), + (("anthropic", "claude-fable-5-1"), Model.PricingPolicy [] (Just 20)) + ] + +renderPricingPolicy :: Model.PricingPolicy -> Text +renderPricingPolicy p = "{\"inputTiers\": [" <> Text.intercalate ", " (map tier (Model.inputTiers p)) <> "]" <> maybe "" (\r -> ", \"longCacheWriteCost\": " <> num r) (Model.longCacheWriteCost p) <> "}" + where + num = renderNum . fst . fromRationalRepetendUnlimited + tier t = "{\"inputAbove\": " <> Text.pack (show (Model.inputAbove t)) <> ", \"rates\": " <> rates (Model.rates t) <> "}" + rates c = "{\"input\": " <> num (Model.inputCost c) <> ", \"output\": " <> num (Model.outputCost c) <> ", \"cacheRead\": " <> num (Model.cacheReadCost c) <> ", \"cacheWrite\": " <> num (Model.cacheWriteCost c) <> "}" + -- | 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 @@ -589,9 +654,29 @@ <> jsonString (renderThinkingStyle (facts ^. #thinkingStyle)) <> ",", " \"supportsSamplingParameters\": " - <> jsonBool (facts ^. #supportsSamplingParameters), + <> jsonBool (facts ^. #supportsSamplingParameters) + <> ",", + " \"supportsFastMode\": " <> jsonBool (maybe False (const True) (facts ^. #fastModeCost)) <> ",", + " \"supportsForcedToolChoice\": " <> jsonBool (facts ^. #supportsForcedToolChoice), " }," ] +renderModelCompat (Just (CatalogOpenAICompat facts)) = + [ " \"compat\": {", + " \"kind\": \"openai-completions\",", + " \"supportsToolCalls\": " <> jsonBool (facts ^. #supportsToolCalls) <> ",", + " \"supportsSamplingParameters\": " <> jsonBool (facts ^. #supportsSamplingParameters) <> ",", + " \"supportedReasoningEfforts\": " <> maybe "null" (\xs -> "[" <> Text.intercalate ", " (map (jsonString . renderThinkingLevel) xs) <> "]") (facts ^. #supportedReasoningEfforts), + " }," + ] +renderModelCompat (Just (CatalogResponsesCompat facts)) = + [ " \"compat\": {", + " \"kind\": \"openai-responses\",", + " \"supportsSamplingParameters\": " <> jsonBool (facts ^. #supportsSamplingParameters) <> ",", + " \"supportsLongCacheRetention\": " <> jsonBool (facts ^. #supportsLongCacheRetention) <> ",", + " \"supportsPromptCacheOptions\": " <> jsonBool (facts ^. #supportsPromptCacheOptions) <> ",", + " \"supportedReasoningEfforts\": " <> maybe "null" (\xs -> "[" <> Text.intercalate ", " (map (jsonString . renderThinkingLevel) xs) <> "]") (facts ^. #supportedReasoningEfforts), + " }," + ] -- | The catalog dialect spells the thinking style as a word, as every -- other catalog enum does. The derived JSON instance on @@ -621,3 +706,6 @@ -- control characters, quotes, and backslashes follow the JSON encoder exactly. jsonString :: Text -> Text jsonString = decodeUtf8 . LBS.toStrict . encode . String + +renderFastCost :: CatalogCost -> Text +renderFastCost c = "{\"input\": " <> renderNum (c ^. #inputCost) <> ", \"output\": " <> renderNum (c ^. #outputCost) <> ", \"cacheRead\": " <> renderNum (c ^. #cacheReadCost) <> ", \"cacheWrite\": " <> renderNum (c ^. #cacheWriteCost) <> "}" diff --git a/gen/GenModelsCore.hs b/gen/GenModelsCore.hs --- a/gen/GenModelsCore.hs +++ b/gen/GenModelsCore.hs @@ -26,6 +26,8 @@ ( AnthropicMessagesCompat ( sendSessionAffinityHeaders, supportsCacheControlOnTools, + supportsFastMode, + supportsForcedToolChoice, supportsLongCacheRetention, supportsSamplingParameters, thinkingStyle @@ -37,19 +39,27 @@ ( cacheControlFormat, maxTokensField, requiresThinkingAsText, + supportedReasoningEfforts, supportsLongCacheRetention, + supportsSamplingParameters, supportsStrictMode, + supportsToolCalls, supportsUsageInStreaming, thinkingFormat ), + OpenAIResponsesCompat (..), ThinkingFormat (..), defaultAnthropicMessagesCompat, defaultOpenAICompletionsCompat, + defaultOpenAIResponsesCompat, ) import Baikai.Model (InputModality (..)) +import Baikai.Model qualified as Model +import Baikai.ThinkingLevel (parseThinkingLevel) import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) import Data.Aeson qualified as Aeson import Data.Aeson.Types (Parser, typeMismatch) +import Data.List (nub, sort) import Data.Map.Strict qualified as Map import Data.Ratio (denominator, numerator) import Data.Scientific (Scientific) @@ -84,6 +94,7 @@ data CatalogCompat = CatalogCompatAuto | CatalogCompatOpenAI !OpenAICompletionsCompat + | CatalogCompatResponses !OpenAIResponsesCompat | CatalogCompatAnthropic !AnthropicMessagesCompat deriving stock (Show) @@ -95,12 +106,26 @@ case kind of "openai-completions" -> CatalogCompatOpenAI <$> parseOpenAICompat o + "openai-responses" -> CatalogCompatResponses <$> parseResponsesCompat o "anthropic-messages" -> CatalogCompatAnthropic <$> parseAnthropicCompat o _ -> fail $ "CatalogCompat: unknown kind " <> show kind v -> typeMismatch "CatalogCompat (expected \"auto\" or {\"kind\": ...})" v +parseResponsesCompat :: Aeson.Object -> Parser OpenAIResponsesCompat +parseResponsesCompat o = do + let d = defaultOpenAIResponsesCompat + raw <- o .:? "supportedReasoningEfforts" + efforts <- traverse (traverse (\t -> maybe (fail "Unknown reasoning effort") pure (parseThinkingLevel t))) raw + case efforts of + Just xs | null xs || xs /= sort (nub xs) -> fail "supportedReasoningEfforts must be nonempty, unique and ordered" + _ -> pure () + sampling <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters + long <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention + modern <- o .:? "supportsPromptCacheOptions" .!= d.supportsPromptCacheOptions + pure d {supportedReasoningEfforts = efforts, supportsSamplingParameters = sampling, supportsLongCacheRetention = long, supportsPromptCacheOptions = modern} + parseOpenAICompat :: Aeson.Object -> Parser OpenAICompletionsCompat parseOpenAICompat o = do let d = defaultOpenAICompletionsCompat @@ -111,9 +136,19 @@ ccf <- optionalMaybeField o "cacheControlFormat" parseCacheControlFormat (cacheControlFormat d) sus <- o .:? "supportsUsageInStreaming" .!= d.supportsUsageInStreaming slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention + stc <- o .:? "supportsToolCalls" .!= d.supportsToolCalls + ssp <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters + rawEfforts <- o .:? "supportedReasoningEfforts" + efforts <- traverse (traverse (\t -> maybe (fail "Unknown reasoning effort") pure (parseThinkingLevel t))) rawEfforts + case efforts of + Just xs | null xs || xs /= sort (nub xs) -> fail "supportedReasoningEfforts must be nonempty, unique and ordered" + _ -> pure () pure d - { maxTokensField = mtf, + { supportsToolCalls = stc, + supportsSamplingParameters = ssp, + supportedReasoningEfforts = efforts, + maxTokensField = mtf, supportsStrictMode = sst, requiresThinkingAsText = rtat, thinkingFormat = tf, @@ -130,13 +165,17 @@ ssah <- o .:? "sendSessionAffinityHeaders" .!= d.sendSessionAffinityHeaders ts <- optionalField o "thinkingStyle" parseAnthropicThinkingStyle d.thinkingStyle ssp <- o .:? "supportsSamplingParameters" .!= d.supportsSamplingParameters + fast <- o .:? "supportsFastMode" .!= False + forced <- o .:? "supportsForcedToolChoice" .!= d.supportsForcedToolChoice pure d { supportsLongCacheRetention = slcr, supportsCacheControlOnTools = scot, sendSessionAffinityHeaders = ssah, thinkingStyle = ts, - supportsSamplingParameters = ssp + supportsSamplingParameters = ssp, + supportsFastMode = fast, + supportsForcedToolChoice = forced } -- | The catalog dialect spells the extended-thinking wire shape as a @@ -204,10 +243,13 @@ entryReasoning :: !Bool, entryInput :: ![InputModality], entryCost :: !CostEntry, + entryFastModeCost :: !(Maybe CostEntry), + entryPricingPolicy :: !(Maybe Model.PricingPolicy), entryContextWindow :: !Natural, entryMaxOutputTokens :: !Natural, entryEnabled :: !Bool, - entryCompatOverride :: !(Maybe CatalogCompat) + entryCompatOverride :: !(Maybe CatalogCompat), + entryApiOverride :: !(Maybe Api) } instance FromJSON ModelEntry where @@ -218,10 +260,13 @@ <*> o .:? "reasoning" .!= False <*> (o .: "input" >>= traverse parseInputModality) <*> o .: "cost" + <*> o .:? "fastModeCost" + <*> (o .:? "pricingPolicy" >>= traverse parsePricingPolicy) <*> o .: "contextWindow" <*> o .: "maxOutputTokens" <*> o .:? "enabled" .!= True <*> o .:? "compat" + <*> (fmap parseApi <$> o .:? "api") parseInputModality :: Text -> Parser InputModality parseInputModality = \case @@ -240,13 +285,33 @@ } instance FromJSON CostEntry where - parseJSON = Aeson.withObject "CostEntry" $ \o -> - CostEntry - <$> o .: "input" - <*> o .: "output" - <*> o .:? "cacheRead" .!= 0 - <*> o .:? "cacheWrite" .!= 0 + parseJSON = Aeson.withObject "CostEntry" $ \o -> do + c <- + CostEntry + <$> o .: "input" + <*> o .: "output" + <*> o .:? "cacheRead" .!= 0 + <*> o .:? "cacheWrite" .!= 0 + if all (>= 0) [costInput c, costOutput c, costCacheRead c, costCacheWrite c] + then pure c + else fail "Cost rates must be nonnegative" +-- | Catalog prices use decimal numbers; runtime policy rates are exact rationals. +parsePricingPolicy :: Aeson.Value -> Parser Model.PricingPolicy +parsePricingPolicy = Aeson.withObject "PricingPolicy" $ \o -> do + tiers <- o .:? "inputTiers" .!= [] >>= traverse parseTier + long <- fmap toRational <$> (o .:? "longCacheWriteCost" :: Parser (Maybe Scientific)) + let policy = Model.PricingPolicy tiers long + either (fail . Text.unpack) (const (pure policy)) (Model.validatePricingPolicy policy) + where + parseTier = Aeson.withObject "InputPriceTier" $ \o -> + Model.InputPriceTier <$> o .: "inputAbove" <*> (o .: "rates" >>= parseCompleteRates) + parseCompleteRates = Aeson.withObject "Complete tier rates" $ \o -> + toModelCost <$> (CostEntry <$> o .: "input" <*> o .: "output" <*> o .: "cacheRead" <*> o .: "cacheWrite") + +toModelCost :: CostEntry -> Model.ModelCost +toModelCost c = Model.ModelCost (toRational (costInput c)) (toRational (costOutput c)) (toRational (costCacheRead c)) (toRational (costCacheWrite c)) + -- * Flattening --------------------------------------------------------- -- | One generated Haskell identifier plus the 'Model'-shaped record @@ -262,6 +327,8 @@ reasoning :: !Bool, input :: ![InputModality], cost :: !CostEntry, + fastModeCost :: !(Maybe CostEntry), + pricingPolicy :: !(Maybe Model.PricingPolicy), contextWindow :: !Natural, maxOutputTokens :: !Natural, compat :: !CatalogCompat @@ -278,12 +345,14 @@ sanitizeIdentifier (c.provider <> "_" <> entryId m), modelId = entryId m, name = entryName m, - api = c.api, + api = maybe c.api id (entryApiOverride m), provider = c.provider, baseUrl = c.baseUrl, reasoning = entryReasoning m, input = entryInput m, cost = entryCost m, + fastModeCost = entryFastModeCost m, + pricingPolicy = entryPricingPolicy m, contextWindow = entryContextWindow m, maxOutputTokens = entryMaxOutputTokens m, compat = @@ -327,9 +396,14 @@ checkAnthropicCompat :: [(Text, GeneratedEntry)] -> Either Text () checkAnthropicCompat entries = case [e | (_, e) <- entries, e.api == AnthropicMessages, not (stated e.compat)] of - [] -> Right () + [] -> case [e | (_, e) <- entries, fastSupported e /= maybe False (const True) e.fastModeCost] of + [] -> Right () + bad -> Left ("fast-mode capability and rates disagree: " <> Text.intercalate ", " (map modelId bad)) missing -> Left (Text.intercalate "; " (map complain missing)) where + fastSupported e = case e.compat of + CatalogCompatAnthropic c -> c.supportsFastMode + _ -> False stated = \case CatalogCompatAnthropic _ -> True _ -> False @@ -388,6 +462,8 @@ " ( AnthropicMessagesCompat", " ( sendSessionAffinityHeaders,", " supportsCacheControlOnTools,", + " supportsFastMode,", + " supportsForcedToolChoice,", " supportsLongCacheRetention,", " supportsSamplingParameters,", " thinkingStyle", @@ -399,34 +475,44 @@ " ( cacheControlFormat,", " maxTokensField,", " requiresThinkingAsText,", + " supportedReasoningEfforts,", " supportsLongCacheRetention,", + " supportsSamplingParameters,", " supportsStrictMode,", + " supportsToolCalls,", " supportsUsageInStreaming,", " thinkingFormat", " ),", + " OpenAIResponsesCompat (..),", " ThinkingFormat (..),", " defaultAnthropicMessagesCompat,", " defaultOpenAICompletionsCompat,", + " defaultOpenAIResponsesCompat,", " )", "import Baikai.Model", " ( Compat (..),", " InputModality (..),", + " InputPriceTier (..),", " Model,", " ModelCost (..),", + " PricingPolicy (..),", " api,", " baseUrl,", " compat,", " contextWindow,", " cost,", " emptyModel,", + " fastModeCost,", " headers,", " input,", " maxOutputTokens,", " modelId,", " name,", + " pricingPolicy,", " provider,", " reasoning,", " )", + "import Baikai.ThinkingLevel (ThinkingLevel (..))", "import Data.Map.Strict qualified as Map", "import Data.Ratio ((%))", "" @@ -465,6 +551,8 @@ " input = " <> renderInputList g.input <> ",", " cost =", renderCost g.cost <> ",", + renderFastCost g.fastModeCost, + " pricingPolicy = " <> renderPolicy g.pricingPolicy <> ",", " contextWindow = " <> Text.pack (show g.contextWindow) <> ",", " maxOutputTokens = " <> Text.pack (show g.maxOutputTokens) <> ",", " headers = Map.empty," @@ -494,6 +582,7 @@ renderApiCtor :: Api -> Text renderApiCtor = \case OpenAIChatCompletions -> "OpenAIChatCompletions" + OpenAIResponses -> "OpenAIResponses" AnthropicMessages -> "AnthropicMessages" OpenAICompletionsCli -> "OpenAICompletionsCli" AnthropicMessagesCli -> "AnthropicMessagesCli" @@ -511,6 +600,13 @@ " }" ] +renderPolicy :: Maybe Model.PricingPolicy -> Text +renderPolicy Nothing = "Nothing" +renderPolicy (Just p) = "Just (PricingPolicy [" <> Text.intercalate ", " (map tier (Model.inputTiers p)) <> "] " <> maybe "Nothing" (\r -> "(Just (" <> renderRational r <> "))") (Model.longCacheWriteCost p) <> ")" + where + tier t = "InputPriceTier " <> Text.pack (show (Model.inputAbove t)) <> " (" <> rates (Model.rates t) <> ")" + rates c = "ModelCost " <> Text.unwords (map (\r -> "(" <> renderRational r <> ")") [Model.inputCost c, Model.outputCost c, Model.cacheReadCost c, Model.cacheWriteCost c]) + renderRational :: Rational -> Text renderRational r = Text.pack (show (numerator r)) <> " % " <> Text.pack (show (denominator r)) @@ -534,10 +630,23 @@ " requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",", " thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",", " cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",", + " supportsToolCalls = " <> renderBool c.supportsToolCalls <> ",", + " supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",", + " supportedReasoningEfforts = " <> maybe "Nothing" (\xs -> "Just [" <> Text.intercalate ", " (map (Text.pack . show) xs) <> "]") c.supportedReasoningEfforts <> ",", " supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",", " supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, " }" ] + CatalogCompatResponses c -> + [ " compat =", + " CompatOpenAIResponses", + " defaultOpenAIResponsesCompat", + " { supportedReasoningEfforts = " <> maybe "Nothing" (\xs -> "Just [" <> Text.intercalate ", " (map (Text.pack . show) xs) <> "]") c.supportedReasoningEfforts <> ",", + " supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",", + " supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",", + " supportsPromptCacheOptions = " <> renderBool c.supportsPromptCacheOptions, + " }" + ] CatalogCompatAnthropic c -> [ " compat =", " CompatAnthropicMessages", @@ -546,7 +655,9 @@ " supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",", " sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",", " thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle <> ",", - " supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters, + " supportsSamplingParameters = " <> renderBool c.supportsSamplingParameters <> ",", + " supportsFastMode = " <> renderBool c.supportsFastMode <> ",", + " supportsForcedToolChoice = " <> renderBool c.supportsForcedToolChoice, " }" ] @@ -574,3 +685,19 @@ renderMaybeCacheControl = \case Nothing -> "Nothing" Just CacheControlFormatAnthropic -> "Just CacheControlFormatAnthropic" + +renderFastCost :: Maybe CostEntry -> Text +renderFastCost Nothing = " fastModeCost = Nothing," +renderFastCost (Just c) = + Text.intercalate + "\n" + [ " fastModeCost =", + " Just", + " ( ModelCost", + " { inputCost = " <> renderRational (toRational (costInput c)) <> ",", + " outputCost = " <> renderRational (toRational (costOutput c)) <> ",", + " cacheReadCost = " <> renderRational (toRational (costCacheRead c)) <> ",", + " cacheWriteCost = " <> renderRational (toRational (costCacheWrite c)), + " }", + " )," + ] diff --git a/src/Baikai.hs b/src/Baikai.hs --- a/src/Baikai.hs +++ b/src/Baikai.hs @@ -37,6 +37,7 @@ -- * Per-API compat shims and call-time options module Baikai.Compat, + module Baikai.Speed, module Baikai.CacheRetention, module Baikai.ResponseFormat, module Baikai.ThinkingLevel, @@ -69,6 +70,7 @@ import Baikai.Provider import Baikai.Response import Baikai.ResponseFormat +import Baikai.Speed import Baikai.StopReason import Baikai.Stream import Baikai.Stream.Event diff --git a/src/Baikai/Api.hs b/src/Baikai/Api.hs --- a/src/Baikai/Api.hs +++ b/src/Baikai/Api.hs @@ -28,6 +28,7 @@ -- | The supported upstream API surfaces, plus an open escape hatch. data Api = OpenAIChatCompletions + | OpenAIResponses | AnthropicMessages | OpenAICompletionsCli | AnthropicMessagesCli @@ -37,6 +38,7 @@ -- | Render an 'Api' tag as its canonical kebab-cased wire string. renderApi :: Api -> Text renderApi = \case + OpenAIResponses -> "openai-responses" OpenAIChatCompletions -> "openai-chat-completions" AnthropicMessages -> "anthropic-messages" OpenAICompletionsCli -> "openai-completions-cli" @@ -47,6 +49,7 @@ -- 'Custom' values so callers can use the same tag space. parseApi :: Text -> Api parseApi = \case + "openai-responses" -> OpenAIResponses "openai-chat-completions" -> OpenAIChatCompletions "anthropic-messages" -> AnthropicMessages "openai-completions-cli" -> OpenAICompletionsCli diff --git a/src/Baikai/Compat.hs b/src/Baikai/Compat.hs --- a/src/Baikai/Compat.hs +++ b/src/Baikai/Compat.hs @@ -33,6 +33,9 @@ requiresThinkingAsText, thinkingFormat, cacheControlFormat, + supportsToolCalls, + supportsSamplingParameters, + supportedReasoningEfforts, supportsUsageInStreaming, supportsLongCacheRetention ), @@ -41,12 +44,18 @@ ThinkingFormat (..), CacheControlFormat (..), + -- * OpenAI Responses compat + OpenAIResponsesCompat (supportedReasoningEfforts, supportsSamplingParameters, supportsLongCacheRetention, supportsPromptCacheOptions), + defaultOpenAIResponsesCompat, + -- * Anthropic Messages compat AnthropicMessagesCompat ( supportsLongCacheRetention, supportsCacheControlOnTools, sendSessionAffinityHeaders, thinkingStyle, + supportsFastMode, + supportsForcedToolChoice, supportsSamplingParameters ), AnthropicThinkingStyle (..), @@ -60,8 +69,9 @@ ) where +import Baikai.ThinkingLevel (ThinkingLevel) import Baikai.Url (hostMatchesSuffix, urlHost) -import Data.Aeson (FromJSON, ToJSON) +import Data.Aeson (FromJSON (parseJSON), ToJSON, withObject, (.!=), (.:), (.:?)) import Data.Text (Text) import GHC.Generics (Generic) @@ -82,7 +92,8 @@ = -- | OpenAI-native: top-level @reasoning_effort: "minimal" | "low" -- | "medium" | "high" | "xhigh" | "max"@. -- - -- This shape sends the canonical baikai level verbatim. Three of + -- This shape sends the canonical level unless the model declares + -- a restricted supportedReasoningEfforts vocabulary. 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@ — @@ -173,6 +184,12 @@ -- @Baikai.Provider.OpenAI.Shape.streamRequestBody@ to include -- or omit @stream_options.include_usage@. supportsUsageInStreaming :: !Bool, + -- | Whether this endpoint accepts function tools for the model. + supportsToolCalls :: !Bool, + -- | Whether this model accepts sampling controls. + supportsSamplingParameters :: !Bool, + -- | Accepted effort levels in increasing order; Nothing is unconstrained. + supportedReasoningEfforts :: !(Maybe [ThinkingLevel]), -- | Whether the host honours long (1h) cache TTLs through the -- Anthropic-style cache_control marker. Consumed by -- @Baikai.Provider.OpenAI.Shape.injectCacheControl@ when @@ -192,9 +209,33 @@ thinkingFormat = ThinkingFormatOpenAI, cacheControlFormat = Nothing, supportsUsageInStreaming = True, + supportsToolCalls = True, + supportsSamplingParameters = True, + supportedReasoningEfforts = Nothing, supportsLongCacheRetention = True } +-- | Model and endpoint facts for native Responses. This is separate +-- from Chat Completions: a host implementing one need not implement both. +data OpenAIResponsesCompat = OpenAIResponsesCompat + { supportedReasoningEfforts :: !(Maybe [ThinkingLevel]), + supportsSamplingParameters :: !Bool, + supportsLongCacheRetention :: !Bool, + -- | Use prompt_cache_options rather than legacy prompt_cache_retention. + supportsPromptCacheOptions :: !Bool + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +defaultOpenAIResponsesCompat :: OpenAIResponsesCompat +defaultOpenAIResponsesCompat = + OpenAIResponsesCompat + { supportedReasoningEfforts = Nothing, + supportsSamplingParameters = True, + supportsLongCacheRetention = True, + supportsPromptCacheOptions = False + } + -- | Feature flags for one Anthropic Messages-compatible host. data AnthropicMessagesCompat = AnthropicMessagesCompat { -- | Whether the host honours Anthropic's @@ -229,10 +270,16 @@ -- 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 + supportsSamplingParameters :: !Bool, + -- | Whether this model accepts fast inference. Defaults to False; + -- curated availability and premium rates must agree. + supportsFastMode :: !Bool, + -- | Whether this generation accepts required or named tool choice. + -- Defaults to True; explicit catalog facts disable unsupported choices. + supportsForcedToolChoice :: !Bool } deriving stock (Eq, Show, Generic) - deriving anyclass (FromJSON, ToJSON) + deriving anyclass (ToJSON) -- | Anthropic's own host: every flag at its default. defaultAnthropicMessagesCompat :: AnthropicMessagesCompat @@ -242,8 +289,22 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingBudget, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } + +-- | Older persisted models predate fast-mode and forced-choice capabilities. +instance FromJSON AnthropicMessagesCompat where + parseJSON = withObject "AnthropicMessagesCompat" $ \o -> + AnthropicMessagesCompat + <$> o .: "supportsLongCacheRetention" + <*> o .: "supportsCacheControlOnTools" + <*> o .: "sendSessionAffinityHeaders" + <*> o .: "thinkingStyle" + <*> o .: "supportsSamplingParameters" + <*> o .:? "supportsFastMode" .!= False + <*> o .:? "supportsForcedToolChoice" .!= True -- | Pick a sensible compat record for an unknown OpenAI-compatible -- host based on its @baseUrl@. Falls back to diff --git a/src/Baikai/Content.hs b/src/Baikai/Content.hs --- a/src/Baikai/Content.hs +++ b/src/Baikai/Content.hs @@ -18,6 +18,7 @@ ( -- * Block primitives TextContent (..), ThinkingContent (..), + ThinkingReplay (..), ToolCall (..), ImageContent (..), @@ -38,6 +39,7 @@ ) where +import Baikai.Api (Api) import Data.Aeson ( FromJSON (parseJSON), Options (..), @@ -51,6 +53,7 @@ object, withObject, (.:), + (.:?), (.=), ) import Data.Aeson qualified as Aeson @@ -60,6 +63,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Vector (Vector) import GHC.Generics (Generic) -- | A plain-text block. The wire form is @{"text": "..."}@. @@ -80,10 +84,32 @@ data ThinkingContent = ThinkingContent { thinking :: !Text, signature :: !(Maybe Text), - redacted :: !Bool + redacted :: !Bool, + -- | Provider-owned continuation, persisted but never rendered as text. + replayState :: !(Maybe ThinkingReplay) } deriving stock (Eq, Show, Generic) +-- | Ordered opaque provider items needed to continue a reasoning turn. +-- The API and model identify where these items may be replayed. Providers +-- validate that scope before sending them. JSON persistence is lossless; +-- Show deliberately omits the opaque item payloads. +data ThinkingReplay = ThinkingReplay + { replayApi :: !Api, + replayModel :: !Text, + replayItems :: !(Vector Value) + } + deriving stock (Eq, Generic) + +instance Show ThinkingReplay where + show _ = "ThinkingReplay " + +instance FromJSON ThinkingReplay where + parseJSON = genericParseJSON snakeOptions + +instance ToJSON ThinkingReplay where + toJSON = genericToJSON snakeOptions + -- | 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@. @@ -166,7 +192,8 @@ ThinkingContent { thinking = Text.empty, signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing } emptyToolCall :: ToolCall @@ -190,10 +217,14 @@ snakeOptions = defaultOptions {fieldLabelModifier = camelTo2 '_'} instance FromJSON ThinkingContent where - parseJSON = genericParseJSON snakeOptions + parseJSON = withObject "ThinkingContent" $ \o -> + ThinkingContent <$> o .: "thinking" <*> o .:? "signature" <*> o .: "redacted" <*> o .:? "replay_state" instance ToJSON ThinkingContent where - toJSON = genericToJSON snakeOptions + toJSON c = + object $ + ["thinking" .= thinking c, "signature" .= signature c, "redacted" .= redacted c] + <> maybe [] (\r -> ["replay_state" .= r]) (replayState c) -- Strip the trailing underscore on @id_@ so the wire form is @id@; the -- other fields keep their natural names. diff --git a/src/Baikai/Cost.hs b/src/Baikai/Cost.hs --- a/src/Baikai/Cost.hs +++ b/src/Baikai/Cost.hs @@ -1,16 +1,91 @@ module Baikai.Cost ( Cost (..), CostBreakdown (..), + CostBasis (..), + CostSource (..), + CostEstimateReason (..), + standardCostBasis, + providerReportedBasis, + estimateCost, + nonEmptyBasis, zeroCost, zeroCostBreakdown, usdAsScientific, ) where -import Data.Aeson (ToJSON (toJSON), object, (.=)) +import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), object, (.=)) +import Data.Aeson qualified as Aeson import Data.Scientific (Scientific, fromRationalRepetendUnlimited) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) import GHC.Generics (Generic) +-- | What the number represents; a standard token calculation is not an invoice. +data CostSource = StandardTokenRates | ResolvedTokenRates | ProviderReportedTotal + deriving stock (Eq, Ord, Show, Generic) + +data CostEstimateReason + = UsageNotReported + | InputUsageNotReported + | OutputUsageNotReported + | CacheReadUsageNotReported + | CacheWriteUsageNotReported + | InconsistentUsage + | ServiceTierNotReported + | UnsupportedServiceTier Text + | SpeedNotReported + | UnsupportedSpeed Text + | ServiceTierMismatch Text Text + | PricingUnavailable + | InvalidPricingPolicy + | CacheDurationNotReported + | AdditionalChargesExcluded + deriving stock (Eq, Ord, Show, Generic) + +-- | Sources and estimation reasons survive aggregation by set union. +-- An empty basis belongs to the additive zero, not to an observed free call. +data CostBasis = CostBasis + { sources :: !(Set CostSource), + estimateReasons :: !(Set CostEstimateReason) + } + deriving stock (Eq, Show, Generic) + +basisOptions :: Aeson.Options +basisOptions = Aeson.defaultOptions {Aeson.fieldLabelModifier = Aeson.camelTo2 '_', Aeson.constructorTagModifier = Aeson.camelTo2 '_'} + +instance ToJSON CostSource where toJSON = Aeson.genericToJSON basisOptions + +instance FromJSON CostSource where parseJSON = Aeson.genericParseJSON basisOptions + +instance ToJSON CostEstimateReason where toJSON = Aeson.genericToJSON basisOptions + +instance FromJSON CostEstimateReason where parseJSON = Aeson.genericParseJSON basisOptions + +instance ToJSON CostBasis where toJSON = Aeson.genericToJSON basisOptions + +instance FromJSON CostBasis where parseJSON = Aeson.genericParseJSON basisOptions + +instance Semigroup CostBasis where + a <> b = CostBasis (sources a <> sources b) (estimateReasons a <> estimateReasons b) + +instance Monoid CostBasis where mempty = CostBasis Set.empty Set.empty + +standardCostBasis :: CostBasis +standardCostBasis = CostBasis (Set.singleton StandardTokenRates) Set.empty + +providerReportedBasis :: CostBasis +providerReportedBasis = CostBasis (Set.singleton ProviderReportedTotal) Set.empty + +estimateCost :: [CostEstimateReason] -> Cost -> Cost +estimateCost reasons c = c {basis = basis c <> CostBasis Set.empty (Set.fromList reasons)} + +-- | The additive zero carries no calculation facts. Omit that empty basis +-- when adding optional metadata to existing trace and log formats. +nonEmptyBasis :: Cost -> Maybe CostBasis +nonEmptyBasis c = if basis c == mempty then Nothing else Just (basis c) + data CostBreakdown = CostBreakdown { inputUsd :: !Rational, outputUsd :: !Rational, @@ -21,7 +96,8 @@ data Cost = Cost { usd :: !Rational, - breakdown :: !CostBreakdown + breakdown :: !CostBreakdown, + basis :: !CostBasis } deriving stock (Eq, Show, Generic) @@ -35,7 +111,7 @@ } zeroCost :: Cost -zeroCost = Cost {usd = 0, breakdown = zeroCostBreakdown} +zeroCost = Cost {usd = 0, breakdown = zeroCostBreakdown, basis = mempty} -- Field-wise combination so callers can total per-call costs with -- '(<>)'/'mconcat'. 'mempty' reuses the existing zero value, so the @@ -54,7 +130,7 @@ mempty = zeroCostBreakdown instance Semigroup Cost where - a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b} + a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b, basis = basis a <> basis b} instance Monoid Cost where mempty = zeroCost @@ -72,7 +148,8 @@ toJSON c = object [ "usd" .= ratToSci (usd c), - "breakdown" .= breakdown c + "breakdown" .= breakdown c, + "basis" .= basis c ] usdAsScientific :: Cost -> Scientific 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 @@ -42,7 +42,8 @@ import Baikai.Content (TextContent (..), UserContent (..)) import Baikai.Context (Context) -import Baikai.Cost (usdAsScientific) +import Baikai.Cost (CostBasis, usdAsScientific) +import Baikai.Cost qualified as Cost import Baikai.Message ( Message (..), UserPayload (..), @@ -106,6 +107,9 @@ inputTokens :: !(Maybe Natural), outputTokens :: !(Maybe Natural), cachedInputTokens :: !(Maybe Natural), + cacheWriteTokens :: !(Maybe Natural), + costBasis :: !(Maybe CostBasis), + usageAvailability :: !(Maybe Usage.UsageAvailability), reasoningTokens :: !(Maybe Natural), usd :: !(Maybe Scientific), latencyMs :: !Int, @@ -215,6 +219,9 @@ inputTokens = positive (Usage.inputTokens u), outputTokens = positive (Usage.outputTokens u), cachedInputTokens = positive (Usage.cacheReadTokens u), + cacheWriteTokens = Just (Usage.cacheWriteTokens u), + costBasis = Cost.nonEmptyBasis (Usage.cost u), + usageAvailability = Usage.availability u, reasoningTokens = Usage.reasoningTokens u, -- A zero cost is reported as zero. The other entry-building -- site ('Baikai.Trace.runRequestWithRegistry') used to diff --git a/src/Baikai/Cost/Pricing.hs b/src/Baikai/Cost/Pricing.hs --- a/src/Baikai/Cost/Pricing.hs +++ b/src/Baikai/Cost/Pricing.hs @@ -1,30 +1,102 @@ -- | Cost computation from a 'Baikai.Model.Model' and a 'Usage'. -- --- The previous map-based lookup (@Map Text PricingRate@) is gone. --- Pricing rates live on 'Baikai.Model.Model.cost' directly, so the --- computation collapses to a record-field access. Models without --- published pricing carry a zero 'Baikai.Model.ModelCost' (the --- default in 'emptyModel'), producing a zero 'Cost'. +-- Base prices and optional context/duration policies live on the model. +-- Arithmetic stays exact, and unavailable pricing carries an estimate reason. module Baikai.Cost.Pricing ( computeCost, + computeCostAtSpeed, attachCost, + resolveRates, + computeCostWith, + computeCostForService, + computeCostAtRates, ) where -import Baikai.Cost (Cost (..), CostBreakdown (..)) +import Baikai.CacheRetention (CacheRetention (..)) +import Baikai.Cost (Cost (..), CostBreakdown (..), CostEstimateReason (..), CostSource (..), estimateCost, standardCostBasis) import Baikai.Message (AssistantPayload (..)) -import Baikai.Model (Model, ModelCost (..)) +import Baikai.Model (InputPriceTier (..), Model, ModelCost (..), PricingPolicy (..), validatePricingPolicy, zeroModelCost) import Baikai.Prelude import Baikai.Response (Response (..)) -import Baikai.Usage (Usage (..)) +import Baikai.Speed (Speed (..)) +import Baikai.Usage (BillingFact (..), Usage (..), UsageAvailability (..), UsageCategory (..)) +import Data.Set qualified as Set -- | Compute a 'Cost' from a model's per-million-token rates and a --- 'Usage'. Returns a zero 'Cost' when the model carries zero rates, --- which is the truthful signal for providers without published --- pricing (CLI providers, custom hosts). +-- 'Usage'. Zero rates retain the old numeric total and now mark pricing +-- unavailable. This entry point assumes the standard cache duration. +-- Use 'computeCostAtSpeed' to select premium speed rates explicitly. computeCost :: Model -> Usage -> Cost -computeCost m u = - let rates = m ^. #cost +computeCost = computeCostWith Nothing + +-- | Duration must be the value selected by request shaping, not merely +-- requested by the caller. Service-tier and usage availability are supplied +-- by adapters as estimation reasons on the resulting cost. +computeCostWith :: Maybe CacheRetention -> Model -> Usage -> Cost +computeCostWith duration m u = priceUsage (resolveRates duration m u) u + +-- | Shared terminal pricing entry point. Observed tiers and speed come from +-- Usage availability, never from the caller's preference. Uncurated products +-- retain a standard-rate estimate with a specific reason. +computeCostForService :: Maybe CacheRetention -> Maybe Text -> Model -> Usage -> Cost +computeCostForService duration requested m u = + let facts = maybe [] (Set.toList . billingFacts) (u ^. #availability) + tiers = [t | BillingServiceTier t <- facts] + speeds = [s | BillingSpeed s <- facts] + reasons = + [ServiceTierNotReported | null tiers] + <> [AdditionalChargesExcluded | BillingServerToolUse `elem` facts] + <> [UnsupportedServiceTier t | t <- tiers, t `notElem` ["default", "standard"]] + <> [UnsupportedSpeed s | s <- speeds, s /= "standard", s /= "fast" || m ^. #fastModeCost == Nothing] + <> [InconsistentUsage | length speeds > 1] + <> [ServiceTierMismatch wanted actual | Just wanted <- [requested], wanted /= "auto", actual <- tiers, not (matches wanted actual)] + in estimateCost reasons (if speeds == ["fast"] then priceAtSpeed duration m SpeedFast u else computeCostWith duration m u) + where + matches wanted actual = wanted == actual || (wanted == "standard_only" && actual == "standard") || (wanted == "fast" && actual == "priority") + +-- | Price an explicitly selected speed with the standard cache duration. +-- Standard agrees exactly with 'computeCost'. Missing fast rates retain a +-- standard-rate estimate with 'UnsupportedSpeed', never a fabricated zero. +-- This helper does not claim the provider observed the selected speed. +computeCostAtSpeed :: Model -> Speed -> Usage -> Cost +computeCostAtSpeed = priceAtSpeed Nothing + +priceAtSpeed :: Maybe CacheRetention -> Model -> Speed -> Usage -> Cost +priceAtSpeed duration m SpeedStandard u = computeCostWith duration m u +priceAtSpeed duration m SpeedFast u = case m ^. #fastModeCost of + Nothing -> estimateCost [UnsupportedSpeed "fast"] (computeCostWith duration m u) + Just fast -> + let resolved = do + validatePricingPolicy (PricingPolicy [InputPriceTier 0 fast] Nothing) + standard <- resolveRates duration m u + let base = m ^. #cost + -- Apply each premium rate's ratio to the resolved policy once. + -- A zero base cannot define a ratio for a nonzero policy rate. + scale b f r + | b > 0 = Right (r * f / b) + | r == 0 = Right f + | otherwise = Left "Cannot apply fast rates to a zero-base pricing policy" + ModelCost + <$> scale (inputCost base) (inputCost fast) (inputCost standard) + <*> scale (outputCost base) (outputCost fast) (outputCost standard) + <*> scale (cacheReadCost base) (cacheReadCost fast) (cacheReadCost standard) + <*> scale (cacheWriteCost base) (cacheWriteCost fast) (cacheWriteCost standard) + computed = priceUsage resolved u + in computed & #basis . #sources .~ Set.singleton ResolvedTokenRates + +-- | Price one resolved rate record exactly once. +computeCostAtRates :: ModelCost -> Usage -> Cost +computeCostAtRates rates u = + let resolved = validatePricingPolicy (PricingPolicy [InputPriceTier 0 rates] Nothing) >> pure rates + computed = priceUsage resolved u + in computed & #basis . #sources .~ Set.singleton ResolvedTokenRates + +priceUsage :: Either Text ModelCost -> Usage -> Cost +priceUsage resolved u = + let selected = either (const zeroModelCost) id resolved + problems = [InvalidPricingPolicy | Left _ <- [resolved]] <> [PricingUnavailable | selected == ModelCost 0 0 0 0] + rates = selected inRate = inputCost rates outRate = outputCost rates crRate = cacheReadCost rates @@ -34,16 +106,50 @@ cachedUsd = toRational (u ^. #cacheReadTokens) * crRate / 1_000_000 cacheWriteUsd = toRational (u ^. #cacheWriteTokens) * cwRate / 1_000_000 total = inUsd + outUsd + cachedUsd + cacheWriteUsd - in Cost - { usd = total, - breakdown = - CostBreakdown - { inputUsd = inUsd, - outputUsd = outUsd, - cachedInputUsd = cachedUsd, - cachedWriteUsd = cacheWriteUsd - } - } + in estimateCost + (problems <> usageProblems u) + Cost + { usd = total, + basis = standardCostBasis, + breakdown = + CostBreakdown + { inputUsd = inUsd, + outputUsd = outUsd, + cachedInputUsd = cachedUsd, + cachedWriteUsd = cacheWriteUsd + } + } + +-- | Legacy, manually constructed usages have no availability annotation. +-- Normalized provider usages always carry one, even for an entirely absent body. +usageProblems :: Usage -> [CostEstimateReason] +usageProblems u = case u ^. #availability of + Nothing -> [] + Just facts -> + [InconsistentUsage | inconsistent facts] + <> if Set.size (missingCategories facts) == 4 + then [UsageNotReported] + else map reason (Set.toList (missingCategories facts)) + where + reason InputUsage = InputUsageNotReported + reason OutputUsage = OutputUsageNotReported + reason CacheReadUsage = CacheReadUsageNotReported + reason CacheWriteUsage = CacheWriteUsageNotReported + +-- | Choose one complete rate record. Thresholds are exclusive and use +-- disjoint normalized input categories, including both cache counters. +resolveRates :: Maybe CacheRetention -> Model -> Usage -> Either Text ModelCost +resolveRates duration m u = do + validatePricingPolicy (PricingPolicy [InputPriceTier 0 (m ^. #cost)] Nothing) + case m ^. #pricingPolicy of + Nothing -> pure (m ^. #cost) + Just policy -> do + validatePricingPolicy policy + let totalInput = (u ^. #inputTokens) + (u ^. #cacheReadTokens) + (u ^. #cacheWriteTokens) + selected = foldl' (\current tier -> if totalInput > inputAbove tier then rates tier else current) (m ^. #cost) (inputTiers policy) + pure $ case (duration, longCacheWriteCost policy) of + (Just CacheRetentionLong, Just price) -> selected {cacheWriteCost = price} + _ -> selected -- | Replace the assistant response payload's embedded 'Cost' with one -- computed from the supplied model. diff --git a/src/Baikai/Error.hs b/src/Baikai/Error.hs --- a/src/Baikai/Error.hs +++ b/src/Baikai/Error.hs @@ -106,7 +106,10 @@ -- header in either its integer or its HTTP-date form. retryAfterSeconds :: !(Maybe Int), -- | The subprocess exit code, for 'ProcessFailure'. - exitCode :: !(Maybe Int) + exitCode :: !(Maybe Int), + -- | Provider-reported refusal category, an open vocabulary. Present only + -- when a content refusal names one; never inferred from message text. + refusalCategory :: !(Maybe Text) } deriving stock (Eq, Show, Generic) @@ -133,7 +136,8 @@ message = m, httpStatus = Nothing, retryAfterSeconds = Nothing, - exitCode = Nothing + exitCode = Nothing, + refusalCategory = Nothing } -- Smart constructors. These keep call sites close to the old API: an diff --git a/src/Baikai/Evidence.hs b/src/Baikai/Evidence.hs --- a/src/Baikai/Evidence.hs +++ b/src/Baikai/Evidence.hs @@ -259,19 +259,20 @@ -- between the canonical 'ThinkingLevel' and the wire. -- -- This is the type that makes an otherwise silent downgrade visible. --- Every constructor corresponds to a real site in this repository --- where a request is weakened, dropped, or made indistinguishable from --- the provider's own default. +-- Request adjustments correspond to sites where a request is weakened, +-- dropped, or made indistinguishable from the provider's own default. +-- 'ThinkingSummaryUnavailable' is instead a response-only diagnostic. -- -- 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 +-- Sampling and speed drops are not about thinking: 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. +-- evidence mode does not refuse a call over one. Fast-mode drops follow +-- the same rule: losing speed does not weaken reasoning. data ThinkingAdjustment = -- | The requested level was replaced by a weaker one the transport -- accepts. Carries the requested level and the wire text sent. @@ -306,6 +307,11 @@ -- @presence_penalty@. Carries the wire names removed, in wire -- order. SamplingDroppedUnsupportedApi ![Text] + | -- | Fast speed was requested but the model does not support it. + FastModeDroppedUnsupportedModel + | -- | Response-only diagnostic: completed thinking blocks carried no + -- readable summary. This says nothing about reasoning depth or billing. + ThinkingSummaryUnavailable deriving stock (Eq, Show, Generic) -- | Whether an adjustment weakens the /thinking/ the caller asked for. @@ -313,7 +319,7 @@ -- 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. +-- constructors weaken thinking; the sampling and speed ones do not. weakensThinking :: ThinkingAdjustment -> Bool weakensThinking = \case EffortClamped {} -> True @@ -324,6 +330,8 @@ ThinkingDroppedBudgetExceeded {} -> True SamplingDroppedUnsupportedModel {} -> False SamplingDroppedUnsupportedApi {} -> False + FastModeDroppedUnsupportedModel -> False + ThinkingSummaryUnavailable -> False -- | Adjustments encode as a tagged object whose @kind@ names the -- constructor in snake_case and whose @requested@ field carries the @@ -349,6 +357,10 @@ untagged "sampling_dropped_unsupported_model" fields SamplingDroppedUnsupportedApi fields -> untagged "sampling_dropped_unsupported_api" fields + ThinkingSummaryUnavailable -> + object ["kind" .= ("thinking_summary_unavailable" :: Text)] + FastModeDroppedUnsupportedModel -> + object ["kind" .= ("fast_mode_dropped_unsupported_model" :: Text)] where tagged kind lvl extra = object @@ -382,6 +394,8 @@ SamplingDroppedUnsupportedModel <$> o .: "fields" "sampling_dropped_unsupported_api" -> SamplingDroppedUnsupportedApi <$> o .: "fields" + "thinking_summary_unavailable" -> pure ThinkingSummaryUnavailable + "fast_mode_dropped_unsupported_model" -> pure FastModeDroppedUnsupportedModel other -> fail ("unknown thinking adjustment: " <> show other) v -> typeMismatch "ThinkingAdjustment" v @@ -421,9 +435,14 @@ -- in, for example @"thinking"@, @"reasoning_effort"@, or -- @"--effort"@. 'Nothing' when nothing was sent. wireField :: !(Maybe Text), + -- | Exact display setting sent, such as Anthropic's @summarized@. + -- Nothing means no display setting was sent, not a provider observation. + displayText :: !(Maybe Text), -- | 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. + -- level and the wire, in the order it was applied, followed by any + -- response diagnostics. Empty means no adjustment or diagnostic was recorded. + -- The provider may append ThinkingSummaryUnavailable after successful + -- assembly; it never changes the request fields or observed effort. -- -- Reasoning /and/ sampling changes travel here: a -- 'SamplingDroppedUnsupportedModel' entry can appear on a call @@ -437,13 +456,15 @@ instance ToJSON ThinkingTranslation where toJSON t = object - [ "requested" .= fmap renderThinkingLevel (requested t), - "mode" .= mode t, - "effort_text" .= effortText t, - "budget_tokens" .= budgetTokens t, - "wire_field" .= wireField t, - "adjustments" .= adjustments t - ] + ( [ "requested" .= fmap renderThinkingLevel (requested t), + "mode" .= mode t, + "effort_text" .= effortText t, + "budget_tokens" .= budgetTokens t, + "wire_field" .= wireField t, + "adjustments" .= adjustments t + ] + <> maybe [] (\d -> ["display_text" .= d]) (displayText t) + ) instance FromJSON ThinkingTranslation where parseJSON = \case @@ -455,6 +476,7 @@ <*> o .:? "effort_text" <*> o .:? "budget_tokens" <*> o .:? "wire_field" + <*> o .:? "display_text" <*> o .: "adjustments" v -> typeMismatch "ThinkingTranslation" v @@ -476,6 +498,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [] } @@ -496,6 +519,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [] } @@ -506,12 +530,12 @@ -- 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 +-- counts and optional availability facts 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 + object $ [ "input_tokens" .= Usage.inputTokens u, "output_tokens" .= Usage.outputTokens u, "cache_read_tokens" .= Usage.cacheReadTokens u, @@ -519,6 +543,7 @@ "reasoning_tokens" .= Usage.reasoningTokens u, "total_tokens" .= Usage.totalTokens u ] + <> maybe [] (\facts -> ["availability" .= facts]) (Usage.availability u) -- ============================================================ -- Endpoint and transport @@ -760,6 +785,7 @@ declaredStrength = \case AnthropicMessages -> EvidenceModelObserved OpenAIChatCompletions -> EvidenceModelObserved + OpenAIResponses -> EvidenceModelObserved AnthropicMessagesCli -> EvidenceModelObserved OpenAICompletionsCli -> EvidenceCorrelated Custom _ -> EvidenceRequestedOnly @@ -876,7 +902,21 @@ -- further compatible addition rides along: @thinking.mode@ may now be -- @"not_translated"@. evidenceSchemaVersion :: Text -evidenceSchemaVersion = "baikai.model-call-evidence/2.0" +-- Version 2.1 adds optional provider-scoped replay_state to thinking +-- content. It participates in content commitments, but is omitted when +-- absent, preserving every pre-existing content encoding and digest. +-- Version 2.2 adds the local cost calculation basis to serialized usage. +-- Like the local numeric cost, this basis is excluded from response commitments. +-- Optional provider availability facts do join usage commitments. Their absence +-- preserves the six-field envelope and every legacy usage digest. +-- Version 2.3 adds fast-mode drops and speed-unreported cost estimates. +-- Newly emitted speed fields join the configuration projection; envelopes +-- without speed retain their existing digests. +-- Version 2.4 adds optional thinking.display_text and a response-only +-- thinking_summary_unavailable diagnostic; existing digest rules are unchanged. +-- Version 2.5 adds error_info.refusal_category, an optional provider fact. +-- Older error objects decode with Nothing; digest inputs are unchanged. +evidenceSchemaVersion = "baikai.model-call-evidence/2.5" -- | Everything Baikai can say about one completed provider call. -- @@ -1251,6 +1291,7 @@ "reasoning", "reasoning_effort", "seed", + "speed", "stop_sequences", "stream", "temperature", 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 @@ -418,6 +418,8 @@ SamplingDroppedUnsupportedModel fields -> Text.intercalate ", " fields <> " would be dropped, because this model generation rejects sampling parameters" + ThinkingSummaryUnavailable -> "the response contained thinking blocks but no readable summary" + FastModeDroppedUnsupportedModel -> "fast mode would be dropped, because this model does not support it" SamplingDroppedUnsupportedApi fields -> Text.intercalate ", " fields <> " would be dropped, because this API has no such field on any generation" diff --git a/src/Baikai/Model.hs b/src/Baikai/Model.hs --- a/src/Baikai/Model.hs +++ b/src/Baikai/Model.hs @@ -21,6 +21,8 @@ reasoning, input, cost, + fastModeCost, + pricingPolicy, contextWindow, maxOutputTokens, headers, @@ -31,6 +33,9 @@ -- * Cost rates ModelCost (..), zeroModelCost, + PricingPolicy (..), + InputPriceTier (..), + validatePricingPolicy, -- * Capabilities InputModality (..), @@ -38,6 +43,7 @@ -- * Compatibility shim Compat (..), openaiCompletionsCompatFor, + openaiResponsesCompatFor, anthropicMessagesCompatFor, ) where @@ -47,17 +53,24 @@ import Baikai.Compat ( AnthropicMessagesCompat, OpenAICompletionsCompat, + OpenAIResponsesCompat, autoDetectAnthropicMessages, autoDetectOpenAICompletions, + defaultOpenAIResponsesCompat, ) import Baikai.Header (HeaderName) +import Control.Monad (unless) import Data.Aeson - ( FromJSON, + ( FromJSON (parseJSON), ToJSON (toEncoding, toJSON), defaultOptions, genericToEncoding, genericToJSON, + withObject, + (.!=), + (.:?), ) +import Data.List (nub, sort) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) @@ -82,6 +95,37 @@ deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +-- | An exclusive input-context threshold. Its complete rate record +-- applies to every token category in the call once total input exceeds it. +data InputPriceTier = InputPriceTier + { inputAbove :: !Natural, + rates :: !ModelCost + } + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + +-- | Optional catalog policy layered over Model.cost. Long cache-write +-- pricing is an absolute per-million rate, selected only for a shaped +-- long-duration request. It overrides the selected tier's write rate. +data PricingPolicy = PricingPolicy + { inputTiers :: ![InputPriceTier], + longCacheWriteCost :: !(Maybe Rational) + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + +instance FromJSON PricingPolicy where + parseJSON = withObject "PricingPolicy" $ \o -> do + p <- PricingPolicy <$> o .:? "inputTiers" .!= [] <*> o .:? "longCacheWriteCost" + either (fail . show) (const (pure p)) (validatePricingPolicy p) + +validatePricingPolicy :: PricingPolicy -> Either Text () +validatePricingPolicy p = do + let thresholds = map inputAbove (inputTiers p) + validRates r = all (>= 0) [inputCost r, outputCost r, cacheReadCost r, cacheWriteCost r] + unless (thresholds == sort (nub thresholds)) (Left "Pricing thresholds must be strictly increasing") + unless (all (validRates . rates) (inputTiers p) && maybe True (>= 0) (longCacheWriteCost p)) (Left "Pricing rates must be nonnegative") + -- | Per-API compatibility shim. 'CompatNone' tells the provider to -- pick a sensible record by inspecting 'baseUrl'; the two real -- constructors carry an explicit per-host record that overrides the @@ -90,6 +134,7 @@ -- dependency. data Compat = CompatNone + | CompatOpenAIResponses !OpenAIResponsesCompat | CompatOpenAICompletions !OpenAICompletionsCompat | CompatAnthropicMessages !AnthropicMessagesCompat deriving stock (Eq, Show, Generic) @@ -103,6 +148,12 @@ CompatOpenAICompletions c -> c _ -> autoDetectOpenAICompletions (baseUrl m) +-- | Explicit Responses facts or the native Responses defaults. +openaiResponsesCompatFor :: Model -> OpenAIResponsesCompat +openaiResponsesCompatFor m = case compat m of + CompatOpenAIResponses c -> c + _ -> defaultOpenAIResponsesCompat + -- | Project the 'AnthropicMessagesCompat' that applies to a 'Model': -- the explicit one if 'compat' is 'CompatAnthropicMessages', -- otherwise the result of inspecting 'baseUrl' via @@ -133,6 +184,9 @@ reasoning :: !Bool, input :: ![InputModality], cost :: !ModelCost, + -- | Optional premium speed rates, in USD per million tokens. + fastModeCost :: !(Maybe ModelCost), + pricingPolicy :: !(Maybe PricingPolicy), contextWindow :: !Natural, -- | The provider's cap on output tokens for this model, or @0@ -- when it is unknown (a hand-rolled model built from @@ -181,6 +235,8 @@ . next "reasoning" (reasoning m) . next "input" (input m) . next "cost" (cost m) + . next "fastModeCost" (fastModeCost m) + . next "pricingPolicy" (pricingPolicy m) . next "contextWindow" (contextWindow m) . next "maxOutputTokens" (maxOutputTokens m) . next "headers" (Auth.redactHeaderValues (headers m)) @@ -230,6 +286,8 @@ reasoning = False, input = [InputText], cost = zeroModelCost, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 0, maxOutputTokens = 0, headers = Map.empty, 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 @@ -11,6 +11,8 @@ ( AnthropicMessagesCompat ( sendSessionAffinityHeaders, supportsCacheControlOnTools, + supportsFastMode, + supportsForcedToolChoice, supportsLongCacheRetention, supportsSamplingParameters, thinkingStyle @@ -22,34 +24,44 @@ ( cacheControlFormat, maxTokensField, requiresThinkingAsText, + supportedReasoningEfforts, supportsLongCacheRetention, + supportsSamplingParameters, supportsStrictMode, + supportsToolCalls, supportsUsageInStreaming, thinkingFormat ), + OpenAIResponsesCompat (..), ThinkingFormat (..), defaultAnthropicMessagesCompat, defaultOpenAICompletionsCompat, + defaultOpenAIResponsesCompat, ) import Baikai.Model ( Compat (..), InputModality (..), + InputPriceTier (..), Model, ModelCost (..), + PricingPolicy (..), api, baseUrl, compat, contextWindow, cost, emptyModel, + fastModeCost, headers, input, maxOutputTokens, modelId, name, + pricingPolicy, provider, reasoning, ) +import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.Map.Strict qualified as Map import Data.Ratio ((%)) @@ -70,6 +82,8 @@ cacheReadCost = 1 % 1, cacheWriteCost = 25 % 2 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -80,10 +94,47 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = False + supportsSamplingParameters = False, + supportsFastMode = False, + supportsForcedToolChoice = True } } +anthropic_claude_fable_5_1 :: Model +anthropic_claude_fable_5_1 = + emptyModel + { modelId = "claude-fable-5-1", + name = "Claude Fable 5.1", + api = AnthropicMessages, + provider = "anthropic", + baseUrl = "https://api.anthropic.com", + reasoning = True, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 10 % 1, + outputCost = 50 % 1, + cacheReadCost = 1 % 4, + cacheWriteCost = 25 % 2 + }, + fastModeCost = Nothing, + pricingPolicy = Just (PricingPolicy [] (Just (20 % 1))), + contextWindow = 1000000, + maxOutputTokens = 128000, + headers = Map.empty, + compat = + CompatAnthropicMessages + defaultAnthropicMessagesCompat + { supportsLongCacheRetention = True, + supportsCacheControlOnTools = True, + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingAdaptive, + supportsSamplingParameters = False, + supportsFastMode = False, + supportsForcedToolChoice = False + } + } + anthropic_claude_haiku_4_5 :: Model anthropic_claude_haiku_4_5 = emptyModel @@ -101,6 +152,8 @@ cacheReadCost = 1 % 10, cacheWriteCost = 5 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 64000, headers = Map.empty, @@ -111,7 +164,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingBudget, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -132,6 +187,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 25 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 64000, headers = Map.empty, @@ -142,7 +199,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingBudget, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -163,6 +222,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 25 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -173,7 +234,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -194,6 +257,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 25 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -204,7 +269,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = False + supportsSamplingParameters = False, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -225,6 +292,16 @@ cacheReadCost = 1 % 2, cacheWriteCost = 25 % 4 }, + fastModeCost = + Just + ( ModelCost + { inputCost = 10 % 1, + outputCost = 50 % 1, + cacheReadCost = 1 % 1, + cacheWriteCost = 25 % 2 + } + ), + pricingPolicy = Just (PricingPolicy [] (Just (10 % 1))), contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -235,7 +312,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = False + supportsSamplingParameters = False, + supportsFastMode = True, + supportsForcedToolChoice = True } } @@ -256,6 +335,16 @@ cacheReadCost = 1 % 2, cacheWriteCost = 25 % 4 }, + fastModeCost = + Just + ( ModelCost + { inputCost = 10 % 1, + outputCost = 50 % 1, + cacheReadCost = 1 % 1, + cacheWriteCost = 25 % 2 + } + ), + pricingPolicy = Just (PricingPolicy [] (Just (10 % 1))), contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -266,7 +355,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = False + supportsSamplingParameters = False, + supportsFastMode = True, + supportsForcedToolChoice = True } } @@ -287,6 +378,8 @@ cacheReadCost = 3 % 10, cacheWriteCost = 15 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 64000, headers = Map.empty, @@ -297,7 +390,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingBudget, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -318,6 +413,8 @@ cacheReadCost = 3 % 10, cacheWriteCost = 15 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -328,7 +425,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -349,6 +448,8 @@ cacheReadCost = 1 % 5, cacheWriteCost = 5 % 2 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1000000, maxOutputTokens = 128000, headers = Map.empty, @@ -359,7 +460,9 @@ supportsCacheControlOnTools = True, sendSessionAffinityHeaders = False, thinkingStyle = AnthropicThinkingAdaptive, - supportsSamplingParameters = False + supportsSamplingParameters = False, + supportsFastMode = False, + supportsForcedToolChoice = True } } @@ -380,6 +483,8 @@ cacheReadCost = 7 % 100, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 64000, maxOutputTokens = 8192, headers = Map.empty, @@ -403,6 +508,8 @@ cacheReadCost = 7 % 50, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 64000, maxOutputTokens = 8192, headers = Map.empty, @@ -426,6 +533,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1047576, maxOutputTokens = 32768, headers = Map.empty, @@ -449,6 +558,8 @@ cacheReadCost = 1 % 10, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1047576, maxOutputTokens = 32768, headers = Map.empty, @@ -472,6 +583,8 @@ cacheReadCost = 1 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1047576, maxOutputTokens = 32768, headers = Map.empty, @@ -495,6 +608,8 @@ cacheReadCost = 5 % 4, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 128000, maxOutputTokens = 16384, headers = Map.empty, @@ -518,6 +633,8 @@ cacheReadCost = 3 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 128000, maxOutputTokens = 16384, headers = Map.empty, @@ -541,6 +658,8 @@ cacheReadCost = 1 % 8, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -564,6 +683,8 @@ cacheReadCost = 1 % 8, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -587,6 +708,8 @@ cacheReadCost = 7 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -610,6 +733,8 @@ cacheReadCost = 1 % 4, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -633,6 +758,8 @@ cacheReadCost = 3 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -656,6 +783,8 @@ cacheReadCost = 1 % 50, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -679,6 +808,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -702,6 +833,8 @@ cacheReadCost = 2 % 5, cacheWriteCost = 5 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -725,6 +858,8 @@ cacheReadCost = 1 % 50, cacheWriteCost = 1 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -748,6 +883,8 @@ cacheReadCost = 2 % 5, cacheWriteCost = 5 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -771,6 +908,8 @@ cacheReadCost = 1 % 5, cacheWriteCost = 5 % 2 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, headers = Map.empty, @@ -794,6 +933,8 @@ cacheReadCost = 1 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, @@ -817,12 +958,46 @@ cacheReadCost = 1 % 200, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, headers = Map.empty, compat = CompatNone } +openai_gpt_6_astra :: Model +openai_gpt_6_astra = + emptyModel + { modelId = "gpt-6-astra", + name = "GPT-6 Astra", + api = OpenAIResponses, + provider = "openai", + baseUrl = "https://api.openai.com", + reasoning = True, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 10 % 1, + outputCost = 50 % 1, + cacheReadCost = 1 % 1, + cacheWriteCost = 25 % 2 + }, + fastModeCost = Nothing, + pricingPolicy = Just (PricingPolicy [InputPriceTier 272000 (ModelCost (20 % 1) (75 % 1) (2 % 1) (25 % 1))] Nothing), + contextWindow = 1050000, + maxOutputTokens = 128000, + headers = Map.empty, + compat = + CompatOpenAIResponses + defaultOpenAIResponsesCompat + { supportedReasoningEfforts = Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax], + supportsSamplingParameters = False, + supportsLongCacheRetention = False, + supportsPromptCacheOptions = True + } + } + openai_o1 :: Model openai_o1 = emptyModel @@ -840,6 +1015,8 @@ cacheReadCost = 15 % 2, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 100000, headers = Map.empty, @@ -863,6 +1040,8 @@ cacheReadCost = 1 % 2, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 100000, headers = Map.empty, @@ -886,6 +1065,8 @@ cacheReadCost = 11 % 20, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 100000, headers = Map.empty, @@ -909,6 +1090,8 @@ cacheReadCost = 11 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 100000, headers = Map.empty, @@ -932,6 +1115,8 @@ cacheReadCost = 3 % 10, cacheWriteCost = 15 % 4 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 8192, headers = Map.empty, @@ -955,6 +1140,8 @@ cacheReadCost = 3 % 40, cacheWriteCost = 0 % 1 }, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 128000, maxOutputTokens = 16384, headers = Map.empty, @@ -965,6 +1152,7 @@ allModels :: [Model] allModels = [ anthropic_claude_fable_5, + anthropic_claude_fable_5_1, anthropic_claude_haiku_4_5, anthropic_claude_opus_4_5, anthropic_claude_opus_4_6, @@ -994,6 +1182,7 @@ openai_gpt_5_6_terra, openai_gpt_5_mini, openai_gpt_5_nano, + openai_gpt_6_astra, openai_o1, openai_o3, openai_o3_mini, diff --git a/src/Baikai/Options.hs b/src/Baikai/Options.hs --- a/src/Baikai/Options.hs +++ b/src/Baikai/Options.hs @@ -56,6 +56,7 @@ toolChoice, cacheRetention, thinking, + speed, responseFormat, evidence, topP, @@ -73,6 +74,7 @@ import Baikai.Evidence (EvidenceRequest) import Baikai.Header (HeaderName) import Baikai.ResponseFormat (ResponseFormat) +import Baikai.Speed (Speed) import Baikai.ThinkingLevel (ThinkingLevel) import Baikai.Tool (ToolChoice) import Data.Aeson @@ -104,6 +106,10 @@ -- both send no cache-control marker. The constructor is kept for a -- caller who wants to say "no caching" explicitly. cacheRetention :: !(Maybe CacheRetention), + -- | Nothing omits the speed field; standard explicitly requests standard + -- speed. Fast is catalog-gated by Anthropic and dropped with evidence on + -- unsupported models. See "Baikai.Speed" for availability and pricing. + speed :: !(Maybe Speed), thinking :: !(Maybe ThinkingLevel), responseFormat :: !(Maybe ResponseFormat), evidence :: !(Maybe EvidenceRequest), @@ -144,6 +150,7 @@ . next "metadata" (metadata o) . next "toolChoice" (toolChoice o) . next "cacheRetention" (cacheRetention o) + . next "speed" (speed o) . next "thinking" (thinking o) . next "responseFormat" (responseFormat o) . next "evidence" (evidence o) @@ -179,6 +186,7 @@ metadata = Map.empty, toolChoice = Nothing, cacheRetention = Nothing, + speed = Nothing, thinking = Nothing, responseFormat = Nothing, evidence = Nothing, 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 @@ -40,7 +40,7 @@ UserContent (..), ) import Baikai.Context (Context) -import Baikai.Cost (Cost (..), zeroCost, zeroCostBreakdown) +import Baikai.Cost (Cost (..), providerReportedBasis, zeroCost, zeroCostBreakdown) import Baikai.Error (BaikaiError, decodeError) import Baikai.Evidence (EvidenceStrength (..), Observed (..), deriveStrength, usageEnvelope) import Baikai.Message @@ -418,6 +418,7 @@ cacheWriteTokens = written, reasoningTokens = natFieldMaybe u "reasoning_output_tokens", totalTokens = nonCached + out + cached + written, + availability = Nothing, cost = zeroCost } @@ -538,12 +539,13 @@ cacheWriteTokens = cw, reasoningTokens = Nothing, totalTokens = i + out + cr + cw, + availability = Nothing, cost = reportedCost } _ -> Nothing where reportedCost = case KeyMap.lookup "total_cost_usd" o of - Just (Number n) | n > 0 -> Cost {usd = toRational n, breakdown = zeroCostBreakdown} + Just (Number n) | n >= 0 -> Cost {usd = toRational n, breakdown = zeroCostBreakdown, basis = providerReportedBasis} _ -> zeroCost claudeUsageKeys :: [Key] diff --git a/src/Baikai/Speed.hs b/src/Baikai/Speed.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Speed.hs @@ -0,0 +1,13 @@ +-- | Provider-independent inference speed preference. Anthropic sends fast mode +-- only for catalog entries advertising it (currently Opus 5 and Opus 4.8). +-- Their published fast rates are twice standard rates. Unsupported fast +-- requests are dropped with an evidence adjustment. Other providers omit it. +-- A request is a preference; only provider usage reports which speed ran. +module Baikai.Speed (Speed (..)) where + +import Data.Aeson (FromJSON, ToJSON) +import GHC.Generics (Generic) + +data Speed = SpeedStandard | SpeedFast + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -370,7 +370,7 @@ thinkingBlock t | Text.null t = Nothing | otherwise = - Just (AssistantThinking ThinkingContent {thinking = t, signature = Nothing, redacted = False}) + Just (AssistantThinking ThinkingContent {thinking = t, signature = Nothing, redacted = False, replayState = Nothing}) toolBlock raw | Text.null raw = Nothing diff --git a/src/Baikai/Trace.hs b/src/Baikai/Trace.hs --- a/src/Baikai/Trace.hs +++ b/src/Baikai/Trace.hs @@ -57,6 +57,7 @@ import Baikai.Context (Context) import Baikai.Cost (usdAsScientific) +import Baikai.Cost qualified as Cost import Baikai.Cost.Log ( CallLogEntry (..), CallLogHandle, @@ -265,6 +266,15 @@ provider = m ^. #provider, model = m ^. #modelId, latencyMs = millisBetween start now, + inputTokens = Nothing, + outputTokens = Nothing, + cachedInputTokens = Nothing, + cacheWriteTokens = Nothing, + reasoningTokens = Nothing, + totalTokens = Nothing, + costBasis = Nothing, + usageAvailability = Nothing, + usd = Nothing, errorMessage = abortText } -- The consumer stopped before the terminal event, so no adapter @@ -500,6 +510,8 @@ -- baikai could not compute — and the subscription-based -- CLI providers always compute zero, so that was the -- common case rather than a corner. + costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost, + usageAvailability = mu >>= Usage.availability, usd = fmap (usdAsScientific . Usage.cost) mu } -- Evidence goes out *before* the terminal, so a sink that keys @@ -517,6 +529,7 @@ EventError TerminalPayload {message = msg, evidence = mev} -> do now <- getCurrentTime let latency = millisBetween start now + mu = assistantUsageFromMsg msg errMsg = case msg of AssistantMessage AssistantPayload {errorMessage = Just t} -> t _ -> "stream terminated with EventError" @@ -527,6 +540,15 @@ provider = m ^. #provider, model = m ^. #modelId, latencyMs = latency, + inputTokens = fmap Usage.inputTokens mu, + outputTokens = fmap Usage.outputTokens mu, + cachedInputTokens = fmap Usage.cacheReadTokens mu, + cacheWriteTokens = fmap Usage.cacheWriteTokens mu, + reasoningTokens = mu >>= Usage.reasoningTokens, + totalTokens = fmap Usage.totalTokens mu, + costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost, + usageAvailability = mu >>= Usage.availability, + usd = fmap (usdAsScientific . Usage.cost) mu, errorMessage = errMsg } commitTerminal state eid now m mev failed @@ -601,6 +623,9 @@ inputTokens = mu >>= positiveNat . Usage.inputTokens, outputTokens = mu >>= positiveNat . Usage.outputTokens, cachedInputTokens = mu >>= positiveNat . Usage.cacheReadTokens, + cacheWriteTokens = fmap Usage.cacheWriteTokens mu, + costBasis = mu >>= Cost.nonEmptyBasis . Usage.cost, + usageAvailability = mu >>= Usage.availability, reasoningTokens = mu >>= Usage.reasoningTokens, -- Report a zero cost as zero. Suppressing it made "this -- call was free" indistinguishable from "baikai could not 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 @@ -15,7 +15,9 @@ ) where +import Baikai.Cost (CostBasis) import Baikai.Evidence (ModelCallEvidence) +import Baikai.Usage (UsageAvailability) import Data.Aeson ( FromJSON (parseJSON), Options (..), @@ -83,6 +85,8 @@ cacheWriteTokens :: !(Maybe Natural), reasoningTokens :: !(Maybe Natural), totalTokens :: !(Maybe Natural), + costBasis :: !(Maybe CostBasis), + usageAvailability :: !(Maybe UsageAvailability), usd :: !(Maybe Scientific) } | CallFailed @@ -91,6 +95,15 @@ provider :: !Text, model :: !Text, latencyMs :: !Int, + inputTokens :: !(Maybe Natural), + outputTokens :: !(Maybe Natural), + cachedInputTokens :: !(Maybe Natural), + cacheWriteTokens :: !(Maybe Natural), + reasoningTokens :: !(Maybe Natural), + totalTokens :: !(Maybe Natural), + costBasis :: !(Maybe CostBasis), + usageAvailability :: !(Maybe UsageAvailability), + usd :: !(Maybe Scientific), errorMessage :: !Text } | -- | The complete evidence record for one terminal provider call. @@ -182,6 +195,8 @@ <*> d .:? "cacheWriteTokens" <*> d .:? "reasoningTokens" <*> d .:? "totalTokens" + <*> d .:? "costBasis" + <*> d .:? "usageAvailability" <*> d .:? "usd" "call_failed" -> CallFailed @@ -190,6 +205,15 @@ <*> d .: "provider" <*> d .: "model" <*> d .: "latencyMs" + <*> d .:? "inputTokens" + <*> d .:? "outputTokens" + <*> d .:? "cachedInputTokens" + <*> d .:? "cacheWriteTokens" + <*> d .:? "reasoningTokens" + <*> d .:? "totalTokens" + <*> d .:? "costBasis" + <*> d .:? "usageAvailability" + <*> d .:? "usd" <*> d .: "errorMessage" "call_evidence" -> fail diff --git a/src/Baikai/Usage.hs b/src/Baikai/Usage.hs --- a/src/Baikai/Usage.hs +++ b/src/Baikai/Usage.hs @@ -22,20 +22,55 @@ -- 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, sumUsage) where +module Baikai.Usage (Usage (..), UsageAvailability (..), UsageCategory (..), BillingFact (..), observeBilling, zeroUsage, sumUsage) where import Baikai.Cost (Cost, zeroCost) -import Data.Aeson - ( Options (fieldLabelModifier), - ToJSON (toJSON), - camelTo2, - defaultOptions, - genericToJSON, - ) +import Data.Aeson (FromJSON (parseJSON), Options (constructorTagModifier, fieldLabelModifier), ToJSON (toJSON), camelTo2, defaultOptions, genericToJSON, (.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.Maybe (fromMaybe) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) import GHC.Generics (Generic) import Numeric.Natural (Natural) +-- | Billed categories whose omission affects the local calculation. +data UsageCategory = InputUsage | OutputUsage | CacheReadUsage | CacheWriteUsage + deriving stock (Eq, Ord, Show, Generic) + +-- | Provider observations, independent of the requested tier and local rates. +data BillingFact = BillingServiceTier Text | BillingSpeed Text | BillingServerToolUse + deriving stock (Eq, Ord, Show, Generic) + +instance FromJSON BillingFact where parseJSON = Aeson.genericParseJSON usageOptions + +instance ToJSON BillingFact where toJSON = genericToJSON usageOptions + +-- | Provider facts, independent of local prices. Missing categories are not +-- observed zeroes; inconsistent counters cannot support an exact calculation. +data UsageAvailability = UsageAvailability + { missingCategories :: !(Set UsageCategory), + inconsistent :: !Bool, + billingFacts :: !(Set BillingFact) + } + deriving stock (Eq, Show, Generic) + +instance FromJSON UsageCategory where parseJSON = Aeson.genericParseJSON usageOptions + +instance ToJSON UsageCategory where toJSON = genericToJSON usageOptions + +instance FromJSON UsageAvailability where + parseJSON = Aeson.withObject "UsageAvailability" $ \o -> UsageAvailability <$> o .: "missing_categories" <*> o .: "inconsistent" <*> o .:? "billing_facts" .!= Set.empty + +instance ToJSON UsageAvailability where + toJSON facts = case genericToJSON usageOptions facts of + Aeson.Object o | Set.null (billingFacts facts) -> Aeson.Object (KeyMap.delete "billing_facts" o) + value -> value + +instance Semigroup UsageAvailability where + a <> b = UsageAvailability (missingCategories a <> missingCategories b) (inconsistent a || inconsistent b) (billingFacts a <> billingFacts b) + -- | Provider-normalized token usage for one model call. -- -- The prompt-side classes are disjoint: 'inputTokens' excludes @@ -62,16 +97,21 @@ -- 'inputTokens' + 'outputTokens' + 'cacheReadTokens' + -- 'cacheWriteTokens'. totalTokens :: !Natural, - -- | Computed cost for this usage. Providers without pricing data - -- use 'zeroCost'. + -- | Availability of provider billing facts. Nothing is the legacy/manual + -- representation; normalized API responses always carry an annotation. + availability :: !(Maybe UsageAvailability), + -- | Computed cost. Incomplete usage or prices carry estimation reasons. cost :: !Cost } deriving stock (Eq, Show, Generic) usageOptions :: Options -usageOptions = defaultOptions {fieldLabelModifier = camelTo2 '_'} +usageOptions = defaultOptions {fieldLabelModifier = camelTo2 '_', constructorTagModifier = camelTo2 '_'} -instance ToJSON Usage where toJSON = genericToJSON usageOptions +instance ToJSON Usage where + toJSON u = case genericToJSON usageOptions u of + Aeson.Object o | Nothing <- availability u -> Aeson.Object (KeyMap.delete "availability" o) + value -> value -- | Empty usage with every count and cost set to zero. zeroUsage :: Usage @@ -83,6 +123,7 @@ cacheWriteTokens = 0, reasoningTokens = Nothing, totalTokens = 0, + availability = Nothing, cost = zeroCost } @@ -103,6 +144,7 @@ cacheWriteTokens = cacheWriteTokens a + cacheWriteTokens b, reasoningTokens = combineReasoning (reasoningTokens a) (reasoningTokens b), totalTokens = totalTokens a + totalTokens b, + availability = availability a <> availability b, cost = cost a <> cost b } @@ -112,3 +154,10 @@ -- | Total a collection of per-call usages into one. sumUsage :: (Foldable f) => f Usage -> Usage sumUsage = foldl' (<>) mempty + +-- | Add actual response observations without overwriting missing-count facts. +observeBilling :: [BillingFact] -> Usage -> Usage +observeBilling [] u = u +observeBilling facts u = + let previous = fromMaybe (UsageAvailability Set.empty False Set.empty) (availability u) + in u {availability = Just previous {billingFacts = billingFacts previous <> Set.fromList facts}} diff --git a/src/Baikai/Usage/Normalize.hs b/src/Baikai/Usage/Normalize.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Usage/Normalize.hs @@ -0,0 +1,44 @@ +-- | Shared billing-category normalization. Adapters extract optional wire +-- counts; this module preserves their availability without inferring writes. +module Baikai.Usage.Normalize (InputAccounting (..), ReportedUsage (..), normalizeUsage) where + +import Baikai.Usage qualified as U +import Data.Maybe (fromMaybe, isNothing) +import Data.Set qualified as Set +import Numeric.Natural (Natural) + +data InputAccounting = InclusiveInput | ExclusiveInput + deriving stock (Eq, Show) + +data ReportedUsage = ReportedUsage + { inputTokens :: !(Maybe Natural), + outputTokens :: !(Maybe Natural), + cacheReadTokens :: !(Maybe Natural), + cacheWriteTokens :: !(Maybe Natural), + reasoningTokens :: !(Maybe Natural) + } + deriving stock (Eq, Show) + +normalizeUsage :: InputAccounting -> ReportedUsage -> U.Usage +normalizeUsage accounting r = + let input = fromMaybe 0 (inputTokens r) + output = fromMaybe 0 (outputTokens r) + cached = fromMaybe 0 (cacheReadTokens r) + writes = fromMaybe 0 (cacheWriteTokens r) + fresh = case accounting of + ExclusiveInput -> input + InclusiveInput -> if cached + writes > input then 0 else input - cached - writes + invalidInput = accounting == InclusiveInput && maybe False (cached + writes >) (inputTokens r) + invalidReasoning = case (reasoningTokens r, outputTokens r) of + (Just reasoning, Just out) -> reasoning > out + _ -> False + missing = Set.fromList [category | (category, count) <- [(U.InputUsage, inputTokens r), (U.OutputUsage, outputTokens r), (U.CacheReadUsage, cacheReadTokens r), (U.CacheWriteUsage, cacheWriteTokens r)], isNothing count] + in U.zeroUsage + { U.inputTokens = fresh, + U.outputTokens = output, + U.cacheReadTokens = cached, + U.cacheWriteTokens = writes, + U.reasoningTokens = reasoningTokens r, + U.totalTokens = fresh + output + cached + writes, + U.availability = Just (U.UsageAvailability missing (invalidInput || invalidReasoning) Set.empty) + } diff --git a/test/CatalogSpec.hs b/test/CatalogSpec.hs --- a/test/CatalogSpec.hs +++ b/test/CatalogSpec.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedRecordDot #-} + -- | Regression test that locks down the contract between the JSON -- catalog files under @baikai\/data\/models\/@ and the auto-generated -- @baikai\/src\/Baikai\/Models\/Generated.hs@ module. @@ -18,21 +20,25 @@ -- JSON file changed without a paired regeneration. module CatalogSpec (tests) where -import Baikai.Api (Api (AnthropicMessages)) +import Baikai.Api (Api (AnthropicMessages, OpenAIResponses)) import Baikai.Compat ( AnthropicMessagesCompat, AnthropicThinkingStyle (..), + OpenAIResponsesCompat (supportedReasoningEfforts, supportsLongCacheRetention, supportsPromptCacheOptions, supportsSamplingParameters), + supportsFastMode, + supportsForcedToolChoice, supportsSamplingParameters, thinkingStyle, ) import Baikai.Model - ( Compat (CompatAnthropicMessages), + ( Compat (CompatAnthropicMessages, CompatOpenAIResponses), Model, api, compat, modelId, ) import Baikai.Models.Generated (allModels) +import Baikai.ThinkingLevel (ThinkingLevel (..)) import Data.ByteString qualified as BS import Data.List (sort) import Data.Text (Text) @@ -45,7 +51,16 @@ tests = testGroup "Baikai.Models.Generated" - [ testCase "regenerating from data/models produces no diff" $ + [ testCase "Astra selects Responses with explicit endpoint facts" $ do + [api m | m <- allModels, modelId m == "gpt-6-astra"] @?= [OpenAIResponses] + case [compat m | m <- allModels, modelId m == "gpt-6-astra"] of + [CompatOpenAIResponses c] -> do + c.supportsPromptCacheOptions @?= True + c.supportsLongCacheRetention @?= False + c.supportsSamplingParameters @?= False + c.supportedReasoningEfforts @?= Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] + _ -> assertFailure "Astra needs explicit OpenAI endpoint facts", + testCase "regenerating from data/models produces no diff" $ withSystemTempDirectory "baikai-catalog-spec" $ \tmpDir -> do let regenPath = tmpDir <> "/Generated.hs" committedPath = "src/Baikai/Models/Generated.hs" @@ -78,18 +93,19 @@ -- | 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 :: [(Text, (AnthropicThinkingStyle, Bool, Bool, 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)) + [ ("claude-fable-5", (AnthropicThinkingAdaptive, False, True, False)), + ("claude-fable-5-1", (AnthropicThinkingAdaptive, False, False, False)), + ("claude-haiku-4-5", (AnthropicThinkingBudget, True, True, False)), + ("claude-opus-4-5", (AnthropicThinkingBudget, True, True, False)), + ("claude-opus-4-6", (AnthropicThinkingAdaptive, True, True, False)), + ("claude-opus-4-7", (AnthropicThinkingAdaptive, False, True, False)), + ("claude-opus-4-8", (AnthropicThinkingAdaptive, False, True, True)), + ("claude-opus-5", (AnthropicThinkingAdaptive, False, True, True)), + ("claude-sonnet-4-5", (AnthropicThinkingBudget, True, True, False)), + ("claude-sonnet-4-6", (AnthropicThinkingAdaptive, True, True, False)), + ("claude-sonnet-5", (AnthropicThinkingAdaptive, False, True, False)) ] assertFacts :: Model -> IO () @@ -107,5 +123,5 @@ <> show other ) where - facts :: AnthropicMessagesCompat -> (AnthropicThinkingStyle, Bool) - facts c = (thinkingStyle c, supportsSamplingParameters c) + facts :: AnthropicMessagesCompat -> (AnthropicThinkingStyle, Bool, Bool, Bool) + facts c = (thinkingStyle c, c.supportsSamplingParameters, c.supportsForcedToolChoice, c.supportsFastMode) diff --git a/test/CliInternalSpec.hs b/test/CliInternalSpec.hs --- a/test/CliInternalSpec.hs +++ b/test/CliInternalSpec.hs @@ -196,7 +196,15 @@ claudeParserTests = testGroup "claude -p --output-format json result" - [ testCase "a recorded run yields its text, session id, model, usage, and cost" $ do + [ testCase "a reported zero total retains its source instead of becoming missing cost" $ do + case decodeClaudeCliResult "{\"result\":\"ok\",\"is_error\":false,\"usage\":{\"input_tokens\":0},\"total_cost_usd\":0}" of + Left err -> assertFailure (show err) + Right report -> case report ^. #usage of + Just u -> do + u ^. #cost . #usd @?= 0 + u ^. #cost . #basis @?= providerReportedBasis + Nothing -> assertFailure "usage disappeared", + testCase "a recorded run yields its text, session id, model, usage, and cost" $ do recorded <- BS.readFile "test/fixtures/claude-cli-result.json" case decodeClaudeCliResult recorded of Left err -> assertFailure ("expected the recording to decode: " <> show err) diff --git a/test/ContextSpec.hs b/test/ContextSpec.hs --- a/test/ContextSpec.hs +++ b/test/ContextSpec.hs @@ -3,16 +3,18 @@ import Baikai import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson +import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector qualified as V import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) tests :: TestTree tests = testGroup "Context helpers" - [ monoidTests, + [ replayStateTests, + monoidTests, constructorTests, timestampTests, flattenTextTests, @@ -129,7 +131,8 @@ ThinkingContent { thinking = "hidden", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantToolCall emptyToolCall {name = "lookup", arguments = Aeson.object []}, AssistantText (TextContent " world") @@ -153,3 +156,35 @@ (|>) :: a -> (a -> b) -> b (|>) x f = f x + +replayStateTests :: TestTree +replayStateTests = + testGroup + "provider-scoped reasoning replay" + [ testCase "legacy JSON remains valid and byte-compatible" $ do + let old = Aeson.object ["thinking" Aeson..= ("" :: Text.Text), "signature" Aeson..= Aeson.Null, "redacted" Aeson..= False] + Aeson.fromJSON old @?= Aeson.Success emptyThinkingContent + Aeson.toJSON emptyThinkingContent @?= old, + testCase "empty summary and ordered encrypted items survive content persistence and context appending" $ do + let saved = Aeson.eitherDecode (Aeson.encode thought) + saved @?= Right thought + let resp = emptyResponse & #message . #content .~ V.singleton (AssistantThinking thought) + context = addResponse resp (contextOf [user "go"]) + context ^. #messages @?= V.fromList [user "go", responseMessage resp] + flattenAssistantText (resp ^. #message . #content) @?= "" + assertBool "Show omits encrypted content" (not ("encrypted-secret" `Text.isInfixOf` Text.pack (show resp))), + testCase "response content commitment binds replay scope, identity, payload and order" $ do + let digest t = commitmentDigest (Aeson.object ["content" Aeson..= V.singleton (AssistantThinking t)]) + changed r = thought & #replayState .~ Just r + mapM_ + (\r -> assertBool "replay mutation must change commitment" (digest thought /= digest (changed r))) + [ state & #replayApi .~ AnthropicMessages, + state & #replayModel .~ "other-model", + state & #replayItems .~ V.reverse items, + state & #replayItems .~ V.singleton (Aeson.object ["id" Aeson..= ("different" :: Text.Text)]) + ] + ] + where + items = V.fromList [Aeson.object ["type" Aeson..= ("reasoning" :: Text.Text), "id" Aeson..= ("rs_1" :: Text.Text), "summary" Aeson..= ([] :: [Aeson.Value]), "encrypted_content" Aeson..= ("encrypted-secret" :: Text.Text)], Aeson.object ["id" Aeson..= ("rs_2" :: Text.Text)]] + state = ThinkingReplay OpenAIResponses "gpt-6-astra" items + thought = emptyThinkingContent & #replayState .~ Just state diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -1,6 +1,7 @@ module CostSpec (tests) where import Baikai.Api (Api (..)) +import Baikai.CacheRetention (CacheRetention (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext) import Baikai.Cost qualified as Cost @@ -13,9 +14,10 @@ runRequestWithLog, withCallLog, ) -import Baikai.Cost.Pricing (attachCost, computeCost) +import Baikai.Cost.Pricing (attachCost, computeCost, computeCostAtSpeed, computeCostForService) import Baikai.Message (AssistantPayload (..), user) -import Baikai.Model (Model (..), ModelCost (..), emptyModel) +import Baikai.Model (InputPriceTier (..), Model (..), ModelCost (..), PricingPolicy (..), emptyModel) +import Baikai.Models.Generated qualified as Models import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider @@ -23,13 +25,16 @@ registerApiProvider, ) import Baikai.Response (Response (..), flattenAssistantBlocks) +import Baikai.Speed (Speed (..)) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) import Baikai.Usage (Usage, zeroUsage) +import Baikai.Usage qualified as Usage import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BSL import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Maybe (fromJust, isJust) +import Data.Set qualified as Set import Data.Time (UTCTime, getCurrentTime) import Data.Vector qualified as V import System.Directory (getTemporaryDirectory, removeFile) @@ -42,7 +47,8 @@ tests = testGroup "Baikai.Cost" - [ computeTests, + [ fastCostTests, + computeTests, attachCostTests, callLogTests ] @@ -230,6 +236,8 @@ entry ^. #latencyMs @?= 7 entry ^. #promptSummary @?= "Hello world" isJust (entry ^. #usd) @?= True + entry ^. #costBasis @?= Just (cannedHaiku ^. #message . #usage . #cost . #basis) + entry ^. #cacheWriteTokens @?= Just (cannedHaiku ^. #message . #usage . #cacheWriteTokens) removeFile path', testCase "closeCallLog returns even when the log path is unwritable" $ do tmp <- getTemporaryDirectory @@ -269,7 +277,54 @@ outputTokens = Nothing, cachedInputTokens = Nothing, reasoningTokens = Nothing, + cacheWriteTokens = Nothing, + costBasis = Nothing, + usageAvailability = Nothing, usd = Nothing, latencyMs = 0, promptSummary = "" } + +fastCostTests :: TestTree +fastCostTests = + testGroup + "fast pricing" + [ testCase "fast premiums compose with context tiers before pricing" $ do + let m = Models.anthropic_claude_opus_5 & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 1000 (ModelCost 10 50 1 12.5)] Nothing) + Cost.usd (computeCostAtSpeed m SpeedFast u) @?= 2 * Cost.usd (computeCost m u), + testCase "invalid premium rates and undefined policy ratios are explicit" $ do + let negative = knownModel & #fastModeCost .~ Just (ModelCost (-1) 10 0.2 2.5) + undefinedRatio = knownModel & #cost .~ ModelCost 0 5 0.1 1.25 & #fastModeCost .~ Just (ModelCost 10 10 0.2 2.5) & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 1 (ModelCost 5 5 0.1 1.25)] Nothing) + mapM_ (\m -> Set.member Cost.InvalidPricingPolicy (Cost.estimateReasons (Cost.basis (computeCostAtSpeed m SpeedFast u))) @?= True) [negative, undefinedRatio], + testCase "contradictory speed observations remain an explicit standard estimate" $ do + let usage = Usage.observeBilling [Usage.BillingSpeed "fast", Usage.BillingSpeed "standard"] u + result = computeCostForService Nothing Nothing Models.anthropic_claude_opus_5 usage + Cost.usd result @?= Cost.usd (computeCost Models.anthropic_claude_opus_5 u) + Set.member Cost.InconsistentUsage (Cost.estimateReasons (Cost.basis result)) @?= True, + testCase "fast Opus costs exactly twice standard across all four token categories" $ do + mapM_ + ( \m -> do + let standard = computeCost m u + fast = computeCostAtSpeed m SpeedFast u + Cost.usd fast @?= 2 * Cost.usd standard + Cost.breakdown fast @?= Cost.breakdown (standard <> standard) + computeCostAtSpeed m SpeedStandard u @?= standard + Cost.sources (Cost.basis fast) @?= Set.singleton Cost.ResolvedTokenRates + ) + [Models.anthropic_claude_opus_5, Models.anthropic_claude_opus_4_8], + testCase "uncurated fast pricing retains the standard amount and marks the estimate" $ do + let m = Models.anthropic_claude_sonnet_5 + fast = computeCostAtSpeed m SpeedFast u + Cost.usd fast @?= Cost.usd (computeCost m u) + Set.member (Cost.UnsupportedSpeed "fast") (Cost.estimateReasons (Cost.basis fast)) @?= True, + testCase "observed fast speed selects premium long-cache rates once" $ do + let usage = Usage.observeBilling [Usage.BillingSpeed "fast", Usage.BillingServiceTier "standard"] (zeroUsage & #cacheWriteTokens .~ 1000000) + price = computeCostForService (Just CacheRetentionLong) Nothing Models.anthropic_claude_opus_5 usage + Cost.usd price @?= 20 + Set.member (Cost.UnsupportedSpeed "fast") (Cost.estimateReasons (Cost.basis price)) @?= False, + testCase "observed standard speed retains standard long-cache rates" $ do + let usage = Usage.observeBilling [Usage.BillingSpeed "standard", Usage.BillingServiceTier "standard"] (zeroUsage & #cacheWriteTokens .~ 1000000) + Cost.usd (computeCostForService (Just CacheRetentionLong) Nothing Models.anthropic_claude_opus_5 usage) @?= 10 + ] + where + u = sampleUsage & #cacheReadTokens .~ 200 & #cacheWriteTokens .~ 300 diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -5,6 +5,7 @@ ErrorCategory (..), classifyHttpStatus, classifyHttpStatusWithBody, + contentFiltered, decodeError, httpError, invalidRequest, @@ -15,6 +16,7 @@ rateLimited, retryAfterSecondsAt, ) +import Data.Aeson qualified as Aeson import Data.Time (UTCTime) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -27,6 +29,7 @@ bodyClassifyTests, httpHelperTests, retryTests, + refusalJsonTests, constructorTests ] @@ -150,4 +153,27 @@ category (invalidRequest "x") @?= InvalidRequest, testCase "decodeError category" $ category (decodeError "x") @?= DecodeFailure + ] + +refusalJsonTests :: TestTree +refusalJsonTests = + testGroup + "refusal error JSON" + [ testCase "provider category round-trips under its snake-case key" $ do + let e = (contentFiltered "declined") {refusalCategory = Just "future_category"} + Aeson.eitherDecode (Aeson.encode e) @?= Right e + Aeson.toJSON e + @?= Aeson.object + [ "category" Aeson..= ("content_filtered" :: String), + "message" Aeson..= ("declined" :: String), + "http_status" Aeson..= Aeson.Null, + "retry_after_seconds" Aeson..= Aeson.Null, + "exit_code" Aeson..= Aeson.Null, + "refusal_category" Aeson..= ("future_category" :: String) + ], + testCase "legacy errors without refusal_category still decode" $ + Aeson.eitherDecode "{\"category\":\"content_filtered\",\"message\":\"declined\",\"http_status\":null,\"retry_after_seconds\":null,\"exit_code\":null}" + @?= Right (contentFiltered "declined"), + testCase "ordinary failures have no refusal category" $ + refusalCategory (httpError 429 Nothing "slow down") @?= Nothing ] diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -6,7 +6,7 @@ -- through. module EvidenceSpec (tests) where -import Baikai.Cost (Cost (..), zeroCost) +import Baikai.Cost (Cost (..), CostEstimateReason (CacheWriteUsageNotReported), estimateCost, zeroCost) import Baikai.Evidence import Baikai.Provider.Cli.Internal qualified as Internal import Baikai.ThinkingLevel (ThinkingLevel (..)) @@ -27,7 +27,8 @@ tests = testGroup "Evidence" - [ canonicalTests, + [ translationDisplayTests, + canonicalTests, digestTests, usageEnvelopeTests, deriveStrengthTests, @@ -60,7 +61,8 @@ ThinkingDroppedUnsupportedHost ThinkingMinimal, ThinkingDroppedBudgetExceeded ThinkingMax 32000 8192, SamplingDroppedUnsupportedModel ["temperature", "top_p"], - SamplingDroppedUnsupportedApi ["seed", "frequency_penalty", "presence_penalty"] + SamplingDroppedUnsupportedApi ["seed", "frequency_penalty", "presence_penalty"], + ThinkingSummaryUnavailable ] ] <> [ testCase "a sampling drop encodes its kind and fields and no requested level" $ @@ -158,7 +160,13 @@ digestTests = testGroup "digests" - [ testCase "a digest is sha256: plus 64 lowercase hex characters" $ do + [ testCase "speed participates in the configuration fingerprint" $ do + let absent = object ["model" .= ("claude-opus-5" :: Text.Text)] + standard = object ["model" .= ("claude-opus-5" :: Text.Text), "speed" .= ("standard" :: Text.Text)] + fast = object ["model" .= ("claude-opus-5" :: Text.Text), "speed" .= ("fast" :: Text.Text)] + assertBool "fast differs from standard" (configurationDigest fast /= configurationDigest standard) + assertBool "explicit standard differs from absent" (configurationDigest standard /= configurationDigest absent), + testCase "a digest is sha256: plus 64 lowercase hex characters" $ do env <- loadFixture let d = commitmentDigest env assertBool ("expected a sha256: prefix, got " <> Text.unpack d) $ @@ -262,7 +270,12 @@ usageEnvelopeTests = testGroup "usage envelope" - [ testCase "two usages differing only in cost produce the same envelope" $ do + [ testCase "cost basis is serialized additively without changing provider commitments" $ do + evidenceSchemaVersion @?= "baikai.model-call-evidence/2.5" + let estimated = zeroUsage {cost = estimateCost [CacheWriteUsageNotReported] zeroCost} + usageEnvelope estimated @?= usageEnvelope zeroUsage + assertBool "usage JSON retains the local calculation basis" (Aeson.toJSON estimated /= Aeson.toJSON zeroUsage), + 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 @@ -270,6 +283,10 @@ let cheap = zeroUsage {inputTokens = 10, outputTokens = 20} dear = cheap {cost = zeroCost {usd = 1234}} usageEnvelope cheap @?= usageEnvelope dear, + testCase "legacy usage envelope has exactly the original six keys" $ + case usageEnvelope zeroUsage of + Object fields -> KeyMap.size fields @?= 6 + _ -> assertFailure "usage envelope is not an object", testCase "the encoded envelope carries no cost key" $ do let encoded = BS8.unpack (canonicalEncode (usageEnvelope zeroUsage)) assertBool @@ -492,3 +509,13 @@ case raw of Left err -> assertFailure ("could not read " <> fixturePath <> ": " <> err) Right v -> pure v + +translationDisplayTests :: TestTree +translationDisplayTests = testCase "display translation is optional in legacy JSON and round-trips when present" $ do + let legacy = Aeson.toJSON noThinkingRequested + summary = noThinkingRequested {displayText = Just "summarized"} + case legacy of + Object o -> KeyMap.lookup "display_text" o @?= Nothing + _ -> assertFailure "translation must be an object" + Aeson.fromJSON legacy @?= Aeson.Success noThinkingRequested + Aeson.fromJSON (Aeson.toJSON summary) @?= Aeson.Success summary diff --git a/test/FetchModelsSpec.hs b/test/FetchModelsSpec.hs --- a/test/FetchModelsSpec.hs +++ b/test/FetchModelsSpec.hs @@ -4,9 +4,11 @@ -- models.dev-shaped fixture. No network is involved. module FetchModelsSpec (tests) where -import Baikai.Compat (AnthropicThinkingStyle (..)) +import Baikai.Compat (AnthropicThinkingStyle (..), defaultOpenAIResponsesCompat) import Baikai.Model (InputModality (..)) +import Baikai.Model qualified as Model import Baikai.Prelude +import Control.Monad (forM_) import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as BSL @@ -19,6 +21,7 @@ import Data.Text.Encoding (decodeUtf8) import Data.Vector qualified as V import FetchModelsCore +import GenModelsCore qualified as Gen import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -57,8 +60,11 @@ reasoning = True, input = [InputText, InputImage], cost = CatalogCost 0.05 0.4 0 0, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 400000, maxOutputTokens = 128000, + apiOverride = Nothing, compat = Nothing }, CatalogModel @@ -67,8 +73,11 @@ reasoning = True, input = [InputText, InputImage], cost = CatalogCost 2.5 15 0.25 0, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1050000, maxOutputTokens = 128000, + apiOverride = Nothing, compat = Nothing } ] @@ -90,14 +99,19 @@ reasoning = True, input = [InputText, InputImage], cost = CatalogCost 5 25 1.5 6.25, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 200000, maxOutputTokens = 64000, + apiOverride = Nothing, compat = Just ( CatalogAnthropicCompat ( AnthropicGenerationFacts { thinkingStyle = AnthropicThinkingBudget, - supportsSamplingParameters = True + supportsSamplingParameters = True, + supportsForcedToolChoice = True, + fastModeCost = Nothing } ) ) @@ -109,8 +123,66 @@ tests = testGroup "Baikai.FetchModels" - [ testCase "OpenAI normalization filters, curates, and maps fields" $ do + [ testCase "per-model API and Responses compat survive normalization and rendering" $ do upstream <- loadUpstream + let spec = + openaiSpec + & #apiFor + .~ (\mid -> if mid == "gpt-5.4" then Just "openai-responses" else Nothing) + & #compatFor + .~ (\mid -> if mid == "gpt-5.4" then Just (CatalogResponsesCompat defaultOpenAIResponsesCompat) else Nothing) + refreshed = catalogFor upstream spec + raw = renderCatalog refreshed + map (^. #apiOverride) (refreshed ^. #models) @?= [Nothing, Just "openai-responses"] + case Aeson.eitherDecode (BSL.fromStrict raw) of + Left err -> assertFailure err + Right catalog -> do + let generated = Gen.renderModule (Gen.flattenEntries catalog) + assertBool "generator reads the rendered override" ("api = OpenAIResponses" `Text.isInfixOf` generated) + assertBool "generator keeps the inherited default" ("api = OpenAIChatCompletions" `Text.isInfixOf` generated) + + case Aeson.eitherDecode (BSL.fromStrict raw) of + Right (Aeson.Object root) -> case KeyMap.lookup "models" root of + Just (Aeson.Array entries) -> case V.toList entries of + [Aeson.Object legacy, Aeson.Object native] -> do + KeyMap.lookup "api" legacy @?= Nothing + KeyMap.lookup "api" native @?= Just (Aeson.String "openai-responses") + case KeyMap.lookup "compat" native of + Just (Aeson.Object facts) -> KeyMap.lookup "kind" facts @?= Just (Aeson.String "openai-responses") + _ -> assertFailure "missing Responses compat" + _ -> assertFailure "wrong entries" + _ -> assertFailure "missing models" + _ -> assertFailure "invalid rendered catalog", + testCase "refresh preserves Astra endpoint restrictions despite upstream tool support" $ do + upstream <- loadUpstream + let sample = (upstream Map.! "openai") Map.! "gpt-5.4" + astra = sample & #modelId .~ "gpt-6-astra" + refreshed = normalizeProvider openaiSpec (Map.singleton "gpt-6-astra" astra) + expected = Map.lookup "gpt-6-astra" openaiInclude >>= id + map (^. #apiOverride) (refreshed ^. #models) @?= [Just "openai-responses"] + map (^. #compat) (refreshed ^. #models) @?= [expected] + assertBool "explicit compat survives rendering" ("openai-responses" `Text.isInfixOf` decodeUtf8 (renderCatalog refreshed)), + testCase "fast rates and capability survive fetch and generator on exactly two curated models" $ do + upstream <- loadUpstream + let sample = (upstream Map.! "openai") Map.! "gpt-5.4" + forM_ (Map.keys anthropicInclude) $ \mid -> do + let refreshed = normalizeProvider anthropicSpec (Map.singleton mid (sample & #modelId .~ mid)) + expected = if mid `elem` ["claude-opus-5", "claude-opus-4-8"] then Just (CatalogCost 10 50 1 12.5) else Nothing + map (^. #fastModeCost) (refreshed ^. #models) @?= [expected] + case Aeson.eitherDecode (BSL.fromStrict (renderCatalog refreshed)) of + Left err -> assertFailure err + Right catalog -> Gen.checkAnthropicCompat (Gen.flattenEntries catalog) @?= Right (), + testCase "curated pricing survives fetch rendering and generator parsing" $ do + upstream <- loadUpstream + let sample = (upstream Map.! "openai") Map.! "gpt-5.4" + forM_ [(openaiSpec, "gpt-6-astra", Model.PricingPolicy [Model.InputPriceTier 272000 (Model.ModelCost 20 75 2 25)] Nothing), (anthropicSpec, "claude-fable-5-1", Model.PricingPolicy [] (Just 20))] $ \(spec, mid, policy) -> do + let refreshed = normalizeProvider spec (Map.singleton mid (sample & #modelId .~ mid)) + map (^. #pricingPolicy) (refreshed ^. #models) @?= [Just policy] + case Aeson.eitherDecode (BSL.fromStrict (renderCatalog refreshed)) of + Left err -> assertFailure err + Right catalog -> map (Gen.pricingPolicy . snd) (Gen.flattenEntries catalog) @?= [Just policy], + testCase "OpenAI normalization filters, curates, and maps fields" $ do + upstream <- loadUpstream catalogFor upstream openaiSpec @?= expectedOpenAI, testCase "tool_call: false model is excluded" $ do upstream <- loadUpstream @@ -157,8 +229,11 @@ reasoning = False, input = [InputText], cost = CatalogCost 0 0 0 0, + fastModeCost = Nothing, + pricingPolicy = Nothing, contextWindow = 1, maxOutputTokens = 1, + apiOverride = Nothing, compat = Nothing } ] @@ -194,7 +269,9 @@ [ " \"compat\": {", " \"kind\": \"anthropic-messages\",", " \"thinkingStyle\": \"budget\",", - " \"supportsSamplingParameters\": true", + " \"supportsSamplingParameters\": true,", + " \"supportsFastMode\": false,", + " \"supportsForcedToolChoice\": true", " }," ] `Text.isInfixOf` rendered diff --git a/test/GenModelsSpec.hs b/test/GenModelsSpec.hs --- a/test/GenModelsSpec.hs +++ b/test/GenModelsSpec.hs @@ -1,13 +1,16 @@ module GenModelsSpec (tests) where -import Baikai.Api (Api (AnthropicMessages, OpenAIChatCompletions)) +import Baikai.Api (Api (AnthropicMessages, OpenAIChatCompletions, OpenAIResponses)) import Baikai.Compat ( AnthropicThinkingStyle (AnthropicThinkingAdaptive), defaultAnthropicMessagesCompat, + supportsFastMode, supportsSamplingParameters, thinkingStyle, ) import Baikai.Model (InputModality (InputText)) +import Control.Monad (forM_) +import Data.Aeson qualified as Aeson import Data.Text (Text) import Data.Text qualified as Text import GenModelsCore @@ -18,7 +21,43 @@ tests = testGroup "Baikai.GenModels" - [ testCase "checkIdentifierCollisions rejects sanitized binding duplicates" $ do + [ testCase "fast capability and rates must agree in both directions" $ do + forM_ [(True, Nothing), (False, Just (CostEntry 10 50 1 12.5))] $ \(supported, rates) -> do + let block = CatalogCompatAnthropic (defaultAnthropicMessagesCompat {supportsFastMode = supported}) + catalog = (anthropicCatalog CatalogCompatAuto (Just block)) {models = [(model "claude-x") {entryCompatOverride = Just block, entryFastModeCost = rates}]} + case checkAnthropicCompat (flattenEntries catalog) of + Left err -> assertBool "names model" ("claude-x" `Text.isInfixOf` err) + Right () -> assertFailure "contradictory fast-mode catalog accepted", + testCase "catalog rejects invalid policy thresholds and negative rates" $ do + let cost n = Aeson.object ["input" Aeson..= (n :: Int), "output" Aeson..= (1 :: Int), "cacheRead" Aeson..= (0 :: Int), "cacheWrite" Aeson..= (0 :: Int)] + tier n rate = Aeson.object ["inputAbove" Aeson..= (n :: Int), "rates" Aeson..= cost rate] + policy tiers = Aeson.object ["inputTiers" Aeson..= tiers] + entry p = Aeson.object ["id" Aeson..= ("test" :: Text), "name" Aeson..= ("Test" :: Text), "input" Aeson..= (["text"] :: [Text]), "cost" Aeson..= cost 1, "contextWindow" Aeson..= (1 :: Int), "maxOutputTokens" Aeson..= (1 :: Int), "pricingPolicy" Aeson..= p] + forM_ [policy [Aeson.object ["inputAbove" Aeson..= (1 :: Int), "rates" Aeson..= Aeson.object ["input" Aeson..= (1 :: Int), "output" Aeson..= (1 :: Int)]]], policy [tier (-1) 1], policy [tier 1 1, tier 1 1], policy [tier 2 1, tier 1 1], policy [tier 1 (-1)], Aeson.object ["longCacheWriteCost" Aeson..= (-1 :: Int)]] $ \p -> + case Aeson.fromJSON (entry p) :: Aeson.Result ModelEntry of + Aeson.Error _ -> pure () + Aeson.Success _ -> assertFailure "invalid policy accepted", + testCase "per-model API override changes only the selected binding" $ do + let catalog = collisionCatalog {models = [model "legacy", (model "native") {entryApiOverride = Just OpenAIResponses}]} + rendered = renderModule (flattenEntries catalog) + assertBool "legacy inherits file API" ("api = OpenAIChatCompletions" `Text.isInfixOf` rendered) + assertBool "native overrides API" ("api = OpenAIResponses" `Text.isInfixOf` rendered), + testCase "Responses catalog compat parses and renders all endpoint facts" $ do + let raw = Aeson.object ["kind" Aeson..= ("openai-responses" :: Text), "supportsSamplingParameters" Aeson..= False, "supportsLongCacheRetention" Aeson..= False, "supportsPromptCacheOptions" Aeson..= True, "supportedReasoningEfforts" Aeson..= (["low", "max"] :: [Text])] + case Aeson.fromJSON raw of + Aeson.Error err -> assertFailure err + Aeson.Success block -> do + let rendered = renderModule (flattenEntries collisionCatalog {models = [(model "native") {entryApiOverride = Just OpenAIResponses, entryCompatOverride = Just block}]}) + mapM_ (\expected -> assertBool (Text.unpack expected) (expected `Text.isInfixOf` rendered)) ["CompatOpenAIResponses", "supportsPromptCacheOptions = True", "supportsLongCacheRetention = False", "supportsSamplingParameters = False", "Just [ThinkingLow, ThinkingMax]"], + testCase "OpenAI effort policy rejects empty, duplicate, unordered and unknown levels" $ + mapM_ + ( \levels -> + case Aeson.fromJSON (Aeson.object ["kind" Aeson..= ("openai-completions" :: Text), "supportedReasoningEfforts" Aeson..= levels]) :: Aeson.Result CatalogCompat of + Aeson.Error _ -> pure () + Aeson.Success _ -> assertFailure "invalid effort policy accepted" + ) + ([[], ["low", "low"], ["high", "low"], ["unknown"]] :: [[Text]]), + testCase "checkIdentifierCollisions rejects sanitized binding duplicates" $ do let entries = flattenEntries collisionCatalog case checkIdentifierCollisions entries of Right () -> assertFailure "expected duplicate generated identifier to be rejected" @@ -95,8 +134,11 @@ costCacheRead = 0, costCacheWrite = 0 }, + entryFastModeCost = Nothing, + entryPricingPolicy = Nothing, entryContextWindow = 1, entryMaxOutputTokens = 1, entryEnabled = True, + entryApiOverride = Nothing, entryCompatOverride = Nothing } diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -31,6 +31,7 @@ import GenModelsSpec qualified import HelpersSpec qualified import InteractiveSpec qualified +import PricingPolicySpec qualified import PublicSurfaceSpec qualified import StreamSpec qualified import StreamWorkerSpec qualified @@ -118,6 +119,7 @@ GenModelsSpec.tests, HelpersSpec.tests, InteractiveSpec.tests, + PricingPolicySpec.tests, PublicSurfaceSpec.tests, StreamSpec.tests, StreamWorkerSpec.tests, diff --git a/test/PricingPolicySpec.hs b/test/PricingPolicySpec.hs new file mode 100644 --- /dev/null +++ b/test/PricingPolicySpec.hs @@ -0,0 +1,110 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module PricingPolicySpec (tests) where + +import Baikai.CacheRetention (CacheRetention (..)) +import Baikai.Cost qualified as C +import Baikai.Cost.Pricing (computeCost, computeCostAtRates, computeCostForService, computeCostWith, resolveRates) +import Baikai.Evidence qualified as Ev +import Baikai.Model qualified as M +import Baikai.Models.Generated qualified as Models +import Baikai.Usage qualified as U +import Baikai.Usage.Normalize qualified as N +import Control.Lens ((&), (.~)) +import Control.Monad (forM_) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Set qualified as Set +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Pricing policy" + [ testCase "requested tiers never substitute for observed service" $ do + let unknown = N.normalizeUsage N.InclusiveInput (N.ReportedUsage (Just 1000) (Just 0) (Just 0) (Just 0) Nothing) + standard = U.observeBilling [U.BillingServiceTier "default"] unknown + priority = U.observeBilling [U.BillingServiceTier "priority"] unknown + (computeCostForService Nothing (Just "default") astra unknown).basis.estimateReasons @?= Set.singleton C.ServiceTierNotReported + (computeCostForService Nothing (Just "default") astra standard).basis.estimateReasons @?= Set.empty + (computeCostForService Nothing (Just "default") astra priority).basis.estimateReasons @?= Set.fromList [C.UnsupportedServiceTier "priority", C.ServiceTierMismatch "default" "priority"] + assertBool "observed tier joins commitment" (Ev.usageEnvelope standard /= Ev.usageEnvelope priority), + testCase "standard-only matches observed standard and fast remains an explicit estimate" $ do + let u = N.normalizeUsage N.ExclusiveInput (N.ReportedUsage (Just 1000) (Just 0) (Just 0) (Just 0) Nothing) + standard = U.observeBilling [U.BillingServiceTier "standard", U.BillingSpeed "standard"] u + fast = U.observeBilling [U.BillingServiceTier "standard", U.BillingSpeed "fast"] u + (computeCostForService Nothing (Just "standard_only") fable standard).basis.estimateReasons @?= Set.empty + (computeCostForService Nothing Nothing fable fast).basis.estimateReasons @?= Set.singleton (C.UnsupportedSpeed "fast") + (computeCostForService Nothing Nothing fable fast).usd @?= (computeCost fable u).usd, + testCase "server-side tool products are explicitly outside token charges" $ do + let u = U.observeBilling [U.BillingServiceTier "standard", U.BillingServerToolUse] (U.zeroUsage & #inputTokens .~ 1000) + (computeCostForService Nothing Nothing fable u).basis.estimateReasons @?= Set.singleton C.AdditionalChargesExcluded, + testCase "resolved rate seam prices a speed policy exactly once" $ do + let u = U.zeroUsage & #inputTokens .~ 1000 & #outputTokens .~ 100 + doubled = M.ModelCost 20 100 2 25 + selected = computeCostAtRates doubled u + selected.usd @?= 2 * (computeCost astra u).usd + selected.basis.sources @?= Set.singleton C.ResolvedTokenRates, + testCase "legacy availability JSON preserves its encoding without billing facts" $ do + let old = Aeson.object ["missing_categories" Aeson..= ([] :: [U.UsageCategory]), "inconsistent" Aeson..= False] + case Aeson.fromJSON old of + Aeson.Success facts -> Aeson.toJSON (facts :: U.UsageAvailability) @?= old + Aeson.Error err -> assertFailure err, + testCase "context thresholds are exclusive and price the whole request" $ + forM_ [(271999, base), (272000, base), (272001, high)] $ \(n, expectedRates) -> do + let u = U.zeroUsage & #inputTokens .~ n & #outputTokens .~ 100 + resolveRates Nothing astra u @?= Right expectedRates + (computeCost astra u).usd @?= (fromIntegral n * expectedRates.inputCost + 100 * expectedRates.outputCost) / 1000000, + testCase "272001 input plus 100 output costs exactly 5.44752" $ + (computeCost astra (U.zeroUsage & #inputTokens .~ 272001 & #outputTokens .~ 100)).usd @?= 544752 / 100000, + testCase "cache reads and writes both contribute to context threshold" $ do + forM_ [U.zeroUsage & #inputTokens .~ 272000 & #cacheReadTokens .~ 1, U.zeroUsage & #inputTokens .~ 272000 & #cacheWriteTokens .~ 1] $ \u -> resolveRates Nothing astra u @?= Right high + resolveRates Nothing astra (U.zeroUsage & #cacheReadTokens .~ 136000 & #cacheWriteTokens .~ 136000) @?= Right base, + testCase "Fable cache reads and shaped write duration use exact rates" $ do + (computeCost fable (U.zeroUsage & #cacheReadTokens .~ 1000)).usd @?= 1 / 4000 + (computeCostWith (Just CacheRetentionShort) fable (U.zeroUsage & #cacheWriteTokens .~ 1000)).usd @?= 1 / 80 + (computeCostWith (Just CacheRetentionLong) fable (U.zeroUsage & #cacheWriteTokens .~ 1000)).usd @?= 1 / 50, + testCase "reasoning is a subset of output, not an extra charge" $ do + let u = U.zeroUsage & #outputTokens .~ 100 + computeCost astra (u & #reasoningTokens .~ Just 75) @?= computeCost astra u, + testCase "flat policies retain base calculations" $ do + let flat = astra & #pricingPolicy .~ Nothing + resolveRates (Just CacheRetentionLong) flat (U.zeroUsage & #inputTokens .~ 900000) @?= Right base, + testCase "duplicate, unordered and negative policy data are rejected" $ do + forM_ [M.PricingPolicy [M.InputPriceTier 2 high, M.InputPriceTier 2 base] Nothing, M.PricingPolicy [M.InputPriceTier 2 high, M.InputPriceTier 1 base] Nothing, M.PricingPolicy [] (Just (-1)), M.PricingPolicy [M.InputPriceTier 1 (base & #inputCost .~ (-1))] Nothing] $ \p -> do + assertBool "pure validation rejects" (case M.validatePricingPolicy p of Left _ -> True; _ -> False) + case Aeson.fromJSON (Aeson.toJSON p) :: Aeson.Result M.PricingPolicy of Aeson.Error _ -> pure (); _ -> assertFailure "invalid policy decoded" + let negative = Aeson.object ["inputTiers" Aeson..= [Aeson.object ["inputAbove" Aeson..= (-1 :: Int), "rates" Aeson..= base]]] + case Aeson.fromJSON negative :: Aeson.Result M.PricingPolicy of Aeson.Error _ -> pure (); _ -> assertFailure "negative threshold decoded", + testCase "old model JSON without a policy decodes and new policy round trips" $ do + let old = case Aeson.toJSON M.emptyModel of Aeson.Object o -> Aeson.Object (KM.delete "pricingPolicy" o); v -> v + case Aeson.fromJSON old of Aeson.Success m -> (m :: M.Model).pricingPolicy @?= Nothing; Aeson.Error err -> assertFailure err + case Aeson.fromJSON (Aeson.toJSON astra) of Aeson.Success m -> (m :: M.Model) @?= astra; Aeson.Error err -> assertFailure err, + testCase "estimated components retain reasons and provenance when summed" $ do + let known = computeCost fable (U.zeroUsage & #cacheReadTokens .~ 1000) + missing = C.estimateCost [C.CacheWriteUsageNotReported] known + unknown = C.estimateCost [C.ServiceTierNotReported, C.CacheWriteUsageNotReported] known + total = known <> missing <> unknown + total.usd @?= 3 * known.usd + total.basis.estimateReasons @?= Set.fromList [C.CacheWriteUsageNotReported, C.ServiceTierNotReported] + total.basis.sources @?= Set.singleton C.StandardTokenRates + mempty <> total @?= total + total <> mempty @?= total + (known <> missing) <> unknown @?= known <> (missing <> unknown) + case Aeson.fromJSON (Aeson.toJSON total.basis) of Aeson.Success decoded -> decoded @?= total.basis; Aeson.Error err -> assertFailure err, + testCase "unavailable prices carry an explicit estimate reason" $ + (computeCost M.emptyModel (U.zeroUsage & #inputTokens .~ 50)).basis.estimateReasons @?= Set.singleton C.PricingUnavailable + ] + +base :: M.ModelCost +base = M.ModelCost 10 50 1 (25 / 2) + +high :: M.ModelCost +high = M.ModelCost 20 75 2 25 + +astra :: M.Model +astra = Models.openai_gpt_6_astra + +fable :: M.Model +fable = Models.anthropic_claude_fable_5_1 diff --git a/test/PublicSurfaceSpec.hs b/test/PublicSurfaceSpec.hs --- a/test/PublicSurfaceSpec.hs +++ b/test/PublicSurfaceSpec.hs @@ -21,6 +21,7 @@ import Baikai.Cost.Log (CallLogConfig (enabled, path), callLogConfig) import Baikai.Embedding qualified as Embedding import Data.Aeson (Value (Null)) +import Data.Aeson qualified as Aeson import Data.Map.Strict qualified as Map import Data.Text (Text) import Data.Vector qualified as V @@ -32,7 +33,17 @@ tests = testGroup "public surface" - [ testCase "every hidden record is buildable with record update alone" $ do + [ testCase "Responses API and compatibility are public and serializable" $ do + parseApi "openai-responses" @?= OpenAIResponses + renderApi OpenAIResponses @?= "openai-responses" + normaliseApi (Custom "openai-responses") @?= OpenAIResponses + let model = + (mkModel OpenAIResponses "probe" "https://api.openai.com") + { compat = CompatOpenAIResponses defaultOpenAIResponsesCompat {supportsPromptCacheOptions = True} + } + (openaiResponsesCompatFor model).supportsPromptCacheOptions @?= True + Aeson.fromJSON (Aeson.toJSON model) @?= Aeson.Success model, + testCase "every hidden record is buildable with record update alone" $ do probeTool.name @?= "probe" probeLog.path @?= "/dev/null" probeLog.enabled @?= True diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs --- a/test/StreamSpec.hs +++ b/test/StreamSpec.hs @@ -76,7 +76,7 @@ signedThinking :: ThinkingContent signedThinking = - ThinkingContent {thinking = "t", signature = Just "sig-abc", redacted = True} + ThinkingContent {thinking = "t", signature = Just "sig-abc", redacted = True, replayState = Nothing} tests :: TestTree tests = @@ -133,7 +133,7 @@ let expected = Vector.fromList [ AssistantText (TextContent "first"), - AssistantThinking ThinkingContent {thinking = "partial-think", signature = Nothing, redacted = False}, + AssistantThinking ThinkingContent {thinking = "partial-think", signature = Nothing, redacted = False, replayState = Nothing}, AssistantText (TextContent "last"), AssistantToolCall ToolCall {id_ = "", name = "", arguments = Aeson.String "{\"a\":1"} ] @@ -339,7 +339,7 @@ resp ^. #message ^. #content @?= Vector.fromList [ AssistantText (TextContent "closed"), - AssistantThinking ThinkingContent {thinking = "half a thought", signature = Nothing, redacted = False} + AssistantThinking ThinkingContent {thinking = "half a thought", signature = Nothing, redacted = False, replayState = Nothing} ] -- | A terminal that carries no content is not authoritative about diff --git a/test/StrictEvidenceSpec.hs b/test/StrictEvidenceSpec.hs --- a/test/StrictEvidenceSpec.hs +++ b/test/StrictEvidenceSpec.hs @@ -299,7 +299,9 @@ ThinkingDroppedUnsupportedHost lvl, ThinkingDroppedBudgetExceeded lvl 32000 8192, SamplingDroppedUnsupportedModel ["temperature"], - SamplingDroppedUnsupportedApi ["seed"] + SamplingDroppedUnsupportedApi ["seed"], + FastModeDroppedUnsupportedModel, + ThinkingSummaryUnavailable ] ] ] @@ -308,6 +310,8 @@ -- group above is separately identifiable when it fails. adjustmentName :: ThinkingAdjustment -> String adjustmentName = \case + ThinkingSummaryUnavailable -> "summary unavailable" + FastModeDroppedUnsupportedModel -> "fast mode dropped" EffortClamped {} -> "clamped" EffortCollapsedToToggle {} -> "collapsed" EffortOmitted {} -> "omitted" diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -3,6 +3,7 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), emptyContext) +import Baikai.Cost qualified as Cost import Baikai.Error (BaikaiError, ErrorCategory (..), providerError) import Baikai.Evidence ( ModelCallEvidence, @@ -487,6 +488,8 @@ .~ Just 4 & #totalTokens .~ 26 + & #cost + .~ Cost.estimateCost [Cost.ServiceTierNotReported] Cost.zeroCost registerWithUsage :: Api -> Usage -> IO () registerWithUsage a u = @@ -503,7 +506,25 @@ fidelityTest = testGroup "CallFinished fidelity" - [ testCase "carries the full disjoint token breakdown" $ do + [ testCase "failed terminal retains the partial response billing" $ do + let a = Custom "baikai-partial-billing" + partial = stubResponse a & #message . #usage .~ richUsage & #message . #stopReason .~ ErrorReason & #message . #errorMessage .~ Just "reset" + handler _ _ _ = pure partial + registerApiProvider (apiProviderWith a (liftCompleteToStream handler) handler) + (ref, sink) <- memorySink + response <- withTrace sink (stubModel a) stubContext stubOptions + events <- reverse <$> readTVarIO ref + case [f | f@CallFailed {} <- events] of + [CallFailed {inputTokens, outputTokens, cachedInputTokens, cacheWriteTokens, totalTokens, usd, costBasis}] -> do + inputTokens @?= Just 11 + outputTokens @?= Just 7 + cachedInputTokens @?= Just 5 + cacheWriteTokens @?= Just 3 + totalTokens @?= Just 26 + usd @?= Just (Cost.usdAsScientific (response ^. #message . #usage . #cost)) + costBasis @?= Cost.nonEmptyBasis (response ^. #message . #usage . #cost) + other -> assertFailure (show other), + testCase "carries the full disjoint token breakdown" $ do let a = Custom "baikai-trace-usage-fidelity" registerWithUsage a richUsage (ref, sink) <- memorySink @@ -520,7 +541,8 @@ cachedInputTokens, cacheWriteTokens, reasoningTokens, - totalTokens + totalTokens, + costBasis } ] -> do inputTokens @?= Just 11 @@ -529,6 +551,7 @@ cacheWriteTokens @?= Just 3 reasoningTokens @?= Just 4 totalTokens @?= Just 26 + costBasis @?= Just (Cost.basis (richUsage ^. #cost)) other -> assertFailure ("expected one CallFinished, got: " <> show other), -- A zero cost used to be suppressed, which made "this call was -- free" indistinguishable from "baikai could not price this @@ -623,6 +646,7 @@ Ev.effortText = Nothing, Ev.budgetTokens = Just 1024, Ev.wireField = Just "thinking", + Ev.displayText = Nothing, Ev.adjustments = [] } in registerApiProvider @@ -1214,6 +1238,8 @@ cacheWriteTokens = Just 3, reasoningTokens = Just 4, totalTokens = Just 26, + costBasis = Nothing, + usageAvailability = Nothing, usd = Just 0 } @@ -1225,5 +1251,14 @@ provider = "stub.trace", model = "stub-1", latencyMs = 12, + inputTokens = Nothing, + outputTokens = Nothing, + cachedInputTokens = Nothing, + cacheWriteTokens = Nothing, + reasoningTokens = Nothing, + totalTokens = Nothing, + costBasis = Nothing, + usageAvailability = Nothing, + usd = Nothing, errorMessage = "boom" } diff --git a/test/UsageSpec.hs b/test/UsageSpec.hs --- a/test/UsageSpec.hs +++ b/test/UsageSpec.hs @@ -1,6 +1,6 @@ module UsageSpec (tests) where -import Baikai.Cost (Cost (..), CostBreakdown (..), zeroCost, zeroCostBreakdown) +import Baikai.Cost (Cost (..), CostBreakdown (..), standardCostBasis, zeroCost, zeroCostBreakdown) import Baikai.Usage (Usage (..), sumUsage, zeroUsage) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -35,7 +35,8 @@ costOf :: Rational -> Rational -> Rational -> Rational -> Cost costOf i o ci cw = Cost - { usd = (i + o + ci + cw) / 100, + { basis = standardCostBasis, + usd = (i + o + ci + cw) / 100, breakdown = CostBreakdown { inputUsd = i / 100,