diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,206 @@ ## [Unreleased] +## [baikai 0.7.0.0] - 2026-09-08 + +### Added + +- `BaikaiError.refusalCategory` preserves an Anthropic refusal's + provider category. JSON adds `refusal_category`; older errors still decode. + Evidence schema 2.5 records the addition without changing digest inputs. + __Breaking__ to construct a `BaikaiError` from its full field list. + +- `Speed`, `Options.speed`, catalog-owned fast rates and + `computeCostAtSpeed`. Anthropic gates fast mode by model capability, adds the + beta header and records unsupported drops. Terminal pricing uses observed + speed, including cache duration; unreported speed is an explicit estimate. + Older `Model` JSON defaults the new fields safely. __Breaking__: public + records and sum types gain fields and constructors. + +- API usage now records observed service tiers, inference speed and server-tool + use in optional billing facts covered by evidence schema 2.2. Missing service + information and uncurated products produce explicit standard-rate estimates. + `computeCostForService` separates requested and observed service, while + `computeCostAtRates` prices a resolved rate set once for future speed policies. + Empty billing facts preserve legacy availability JSON; a CLI-reported zero + cost retains its reported-total source. __Breaking__: the public vocabulary + and records gain members. + +- Failed trace terminals now retain partial response token counts, cost basis, + usage availability and USD totals. Synthetic aborts leave unreported billing + absent; legacy failed trace JSON still decodes. __Breaking__: `TraceEvent`'s + `CallFailed` gains fields. See `baikai-trace-otel 0.4.0.1` for the export. + +- Successful trace terminals and call-log records carry optional cost basis and + usage availability; call logs also carry cache-write counts. Old JSON decodes + with absent metadata and empty additive-zero bases stay omitted from traces. + __Breaking__: `CallFinished` and the call-log record gain fields. + +- Optional `Usage.availability` and shared inclusive/exclusive billing + normalization, in the new `Baikai.Usage.Normalize`. OpenAI Chat/Responses and + Claude preserve missing cache counters as explicit estimation reasons, + distinguish reported zeroes, and merge cumulative usage without + double-counting. Schema 2.2 commits provider availability while preserving + legacy usage digests. __Breaking__: `Usage` gains a field. + +- Optional `Model.pricingPolicy`, exact whole-request context tiers, + and an explicit cache-duration rate resolver. Generated Astra pricing changes + above 272000 input tokens; Fable exposes its one-hour write price. `Cost.basis` + preserves calculation sources and estimation reasons when summed. Evidence + schema 2.2 serializes the local basis without including local pricing metadata + in provider commitments. __Breaking__: `Model` and `Cost` gain fields. + +- Separate `OpenAIResponses` dispatch and compatibility types, and + optional provider/model-scoped `ThinkingContent.replayState` with opaque + diagnostic output and backward-compatible JSON decoding. Evidence schema 2.2 + includes replay state and optional billing facts in commitments while preserving + legacy encodings when those fields are absent. __Breaking__ for a `case` over + `Api` that is exhaustive without a wildcard. + +- `Baikai.Evidence.ThinkingTranslation` gains `displayText` and + `ThinkingAdjustment` gains `ThinkingSummaryUnavailable`, so a transport can + record the thinking display setting it asked for and diagnose a successful + response whose thinking blocks carry no readable summary. `Baikai.Compat` + gains `supportsForcedToolChoice`; legacy JSON defaults it to True. + __Breaking__ for an exhaustive `case` over `ThinkingAdjustment`. + +- GPT-6 Astra and Claude Fable 5.1 catalog bindings, with verified + pricing, token limits, and Anthropic thinking/sampling compatibility. + +- Repository `update-models` skill for verifying provider releases and refreshing + the curated JSON and generated Haskell catalog. + +### Fixed + +- Preserve OpenAI endpoint capability facts through catalog refreshes. + +- Chat and Claude reject provider-scoped reasoning replay they cannot encode. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +## [baikai-claude 0.7.0.0] - 2026-09-08 + +### Changed + +- Refusal messages include the reported category and explanation, + retaining the original message when neither exists. Classification remains + non-retryable `ContentFiltered`. Server-side fallbacks remain deliberately + unsupported, as recorded in ADR 0005. + +- Adaptive reasoning requests explicitly ask for summarized + thinking. Evidence schema 2.4 records the display setting and diagnoses + successful responses whose thinking blocks contain no readable summary. + Budget and absent-thinking request shapes, signed empty blocks, redacted + content and multi-turn replay are preserved. + +- Fast mode is gated by the generated model capability: it adds the Anthropic + beta header for a model that advertises it and records an evidence adjustment + for one that does not. + +### Fixed + +- Price Fable cache writes using the TTL in the shaped request, + including compatibility downgrades. Missing write-duration context is explicit + in the cost basis. + +- Reject forced tool choices locally on Fable 5.1, using the + generated `supportsForcedToolChoice` capability. Automatic tool rounds retain + signed empty/visible thinking, redacted blocks and prior-message order. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-openai 0.7.0.0] - 2026-09-08 + +### Added + +- Explicit `Baikai.Provider.OpenAI.Responses` registration and + stream/complete provider with stateless reasoning replay, function tool turns, + structured output and bounded worker cleanup, across the new + `Baikai.Provider.OpenAI.Responses.{Request,Stream,Assembler}` modules. Astra + now selects this provider through a per-model catalog override; callers must + register it explicitly. Cache writes, billing availability and context pricing + are integrated. + +- `Baikai.Provider.OpenAI.Internal.Usage`, the shared usage mapping both the + Chat Completions and Responses transports read. + +### Fixed + +- Reject tools locally for models whose Chat Completions endpoint + disallows them, including GPT-6 Astra. Respect generated effort policies and + sampling restrictions, with matching translation evidence and strict refusal. + +- Validate Responses terminals and enforce the stream contracts. + +- Widened the `http-client-tls` bound to admit 0.4 (carried forward from the + tagged but never-published 0.6.0.1). + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. + +## [baikai-trace-otel 0.4.0.1] - 2026-09-08 + +### Added + +- Successful and failed spans export `baikai.cost.basis` and + `baikai.usage.availability` as canonically encoded JSON. A failed span now + also carries the input/output token counts and USD total that + `baikai 0.7.0.0` retains on `CallFailed`, alongside its error status. + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, and now depends on `aeson ^>=2.2` to encode the + two new attributes. + +## [baikai-effectful 0.4.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-kit 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`. No API change. + +## [baikai-agent 0.2.0.1] - 2026-09-08 + +### Changed (dependencies) + +- Requires `baikai ^>=0.7.0`, `baikai-claude ^>=0.7` and + `baikai-openai ^>=0.7`. No API change. + +## [baikai 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4. The 0.4 API retains the + manager functions this package uses and belongs to the same TLS 2.x / Crypton + 1.1 dependency cohort as baikai 0.6; the old `^>=0.3` cap made baikai 0.6 + impossible to solve in applications that require Crypton 1.1. + +## [baikai-claude 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4, allowing applications that + require Crypton 1.1 to solve the dependency set. + +## [baikai-openai 0.6.0.1] - 2026-08-30 + +### Fixed + +- widened the `http-client-tls` bound to admit 0.4, allowing applications that + require Crypton 1.1 to solve the dependency set. + ## [baikai 0.6.0.0] - 2026-08-28 ### Added diff --git a/baikai-claude.cabal b/baikai-claude.cabal --- a/baikai-claude.cabal +++ b/baikai-claude.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai-claude -version: 0.6.0.0 +version: 0.7.0.0 synopsis: Anthropic Claude providers for the baikai abstraction description: Anthropic backends for baikai: the Messages API over SSE, the claude -p batch @@ -65,7 +65,7 @@ autogen-modules: Paths_baikai_claude build-depends: , aeson ^>=2.2 - , baikai ^>=0.6.0 + , baikai ^>=0.7.0 , base >=4.20 && <5 , base16-bytestring ^>=1.0 , base64-bytestring ^>=1.2 @@ -78,7 +78,7 @@ , crypton >=1.0 && <1.2 , generic-lens ^>=2.3 , http-client ^>=0.7 - , http-client-tls ^>=0.3 + , http-client-tls >=0.3 && <0.5 , http-types ^>=0.12 , lens ^>=5.3 , servant-client ^>=0.20 @@ -98,6 +98,7 @@ Contract ErrorClassSpec EvidenceSpec + FableContractsSpec LifecycleSpec MidStreamSpec PublicSurfaceSpec @@ -110,7 +111,7 @@ ghc-options: -threaded -with-rtsopts=-N build-depends: , aeson - , baikai ^>=0.6.0 + , baikai ^>=0.7.0 , baikai-claude , base >=4.20 && <5 , bytestring diff --git a/src/Baikai/Provider/Claude/Agent.hs b/src/Baikai/Provider/Claude/Agent.hs --- a/src/Baikai/Provider/Claude/Agent.hs +++ b/src/Baikai/Provider/Claude/Agent.hs @@ -138,6 +138,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just "--effort", + displayText = Nothing, adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl] } diff --git a/src/Baikai/Provider/Claude/Cli.hs b/src/Baikai/Provider/Claude/Cli.hs --- a/src/Baikai/Provider/Claude/Cli.hs +++ b/src/Baikai/Provider/Claude/Cli.hs @@ -166,6 +166,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just "--effort", + displayText = Nothing, adjustments = [Ev.EffortClamped lvl wire | wire /= renderThinkingLevel lvl] } diff --git a/src/Baikai/Provider/Claude/Internal/Request.hs b/src/Baikai/Provider/Claude/Internal/Request.hs --- a/src/Baikai/Provider/Claude/Internal/Request.hs +++ b/src/Baikai/Provider/Claude/Internal/Request.hs @@ -8,6 +8,7 @@ module Baikai.Provider.Claude.Internal.Request ( mapRequest, planRequest, + planSpeed, planThinking, describeThinkingFor, ThinkingPlan (..), @@ -32,6 +33,7 @@ import Baikai.Model (Model, anthropicMessagesCompatFor) import Baikai.Options (Options (..)) import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) +import Baikai.Speed (Speed (..)) import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel, thinkingTokenBudget) import Baikai.Tool qualified as Tool import Claude.V1.Messages qualified as Messages @@ -77,6 +79,24 @@ mapRequest :: Model -> Context -> Options -> Either Text (Messages.CreateMessage, ThinkingTranslation) mapRequest m ctx opts = do + case opts ^. #toolChoice of + Just Tool.ToolChoiceRequired | not (anthropicMessagesCompatFor m).supportsForcedToolChoice -> unsupportedForcedChoice + Just (Tool.ToolChoiceSpecific _) | not (anthropicMessagesCompatFor m).supportsForcedToolChoice -> unsupportedForcedChoice + _ -> pure () + mapM_ + ( \msg -> case msg of + Msg.AssistantMessage payload -> + mapM_ + ( \block -> case block of + Content.AssistantThinking th + | Just _ <- Content.replayState th -> + Left "This endpoint cannot replay provider-scoped reasoning state; use its originating API and model" + _ -> pure () + ) + (payload ^. #content) + _ -> pure () + ) + (ctx ^. #messages) msgs <- catMaybes <$> traverse mapMessage (Vector.toList (ctx ^. #messages)) let compat = anthropicMessagesCompatFor m cap = m ^. #maxOutputTokens @@ -109,12 +129,16 @@ Messages.tools = toolsField, Messages.tool_choice = toolChoiceField, Messages.cache_control = cacheControlField, + Messages.speed = fst (planSpeed compat (opts ^. #speed)), Messages.thinking = field plan, Messages.output_config = outputConfigField }, translation ) +unsupportedForcedChoice :: Either Text () +unsupportedForcedChoice = Left "This model does not support forced tool choice; use ToolChoiceAuto or ToolChoiceNone" + -- | The sampling parameters that will reach the wire, after the compat -- record's gate. 'Nothing' means the field is omitted — the SDK encodes -- 'Messages.CreateMessage' with @omitNothingFields = True@, so a @@ -185,7 +209,7 @@ -- separately: one is a fact about the model, the other about the API. planRequest :: Model -> Options -> (ThinkingPlan, SamplingPlan, ThinkingTranslation) planRequest m opts = - (plan, sampling, translation & #adjustments %~ (<> samplingAdjustments)) + (plan, sampling, translation & #adjustments %~ (<> (samplingAdjustments <> snd (planSpeed compat (opts ^. #speed))))) where compat = anthropicMessagesCompatFor m cap = m ^. #maxOutputTokens @@ -201,7 +225,7 @@ ) _ -> (plan0, translation0) - gated = not (supportsSamplingParameters compat) + gated = not (compat ^. #supportsSamplingParameters) sampling | gated = SamplingPlan {temperature = Nothing, topP = Nothing} | otherwise = @@ -315,6 +339,9 @@ -- provider-neutral description of what the caller's level became. -- -- The two travel together because they are two views of one decision. +-- Adaptive requests explicitly ask for summarized display, using the catalog +-- thinking style. Budget requests retain their existing provider default. +-- Display changes visibility only; it does not establish reasoning depth. -- Returning only the first is what this provider used to do, and it is -- why a caller could never tell an honoured request from a dropped one. computeThinking :: @@ -332,13 +359,14 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [ThinkingDroppedUnsupportedModel lvl] } ) | thinkingStyle compat == AnthropicThinkingAdaptive = let e = adaptiveEffort lvl in ( ThinkingPlan - { field = Just Messages.ThinkingAdaptive, + { field = Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized), effort = e, budget = Nothing }, @@ -348,6 +376,7 @@ effortText = e, budgetTokens = Nothing, wireField = Just "thinking", + displayText = Just "summarized", adjustments = adaptiveAdjustments lvl e } ) @@ -366,6 +395,7 @@ -- A budget expresses the requested level exactly, so -- there is nothing to adjust. wireField = Just "thinking", + displayText = Nothing, adjustments = [] } ) @@ -407,6 +437,7 @@ & #effortText .~ Nothing & #budgetTokens .~ Nothing & #wireField .~ Nothing + & #displayText .~ Nothing & #adjustments %~ (<> [adj]) -- | Map a baikai 'Tool.Tool' into the upstream Anthropic @@ -637,3 +668,12 @@ nonEmpty t | Text.null t = Nothing | otherwise = Just t + +-- | One capability gate shared by wire mapping, headers and the describer. +planSpeed :: AnthropicMessagesCompat -> Maybe Speed -> (Maybe Messages.Speed, [ThinkingAdjustment]) +planSpeed compat = \case + Nothing -> (Nothing, []) + Just SpeedStandard -> (Just Messages.SpeedStandard, []) + Just SpeedFast + | compat ^. #supportsFastMode -> (Just Messages.SpeedFast, []) + | otherwise -> (Nothing, [FastModeDroppedUnsupportedModel]) diff --git a/src/Baikai/Provider/Claude/Internal/Stream.hs b/src/Baikai/Provider/Claude/Internal/Stream.hs --- a/src/Baikai/Provider/Claude/Internal/Stream.hs +++ b/src/Baikai/Provider/Claude/Internal/Stream.hs @@ -29,9 +29,10 @@ ) where +import Baikai.CacheRetention (CacheRetention (..)) import Baikai.Content qualified as Content import Baikai.Context (Context (..)) -import Baikai.Cost (zeroCost) +import Baikai.Cost (CostEstimateReason (CacheDurationNotReported, SpeedNotReported), estimateCost) import Baikai.Cost.Pricing qualified as Pricing import Baikai.Error (BaikaiError, contentFiltered, invalidRequest, providerError) import Baikai.Evidence qualified as Ev @@ -66,11 +67,14 @@ ) import Baikai.Url qualified as Url import Baikai.Usage qualified as Usage +import Baikai.Usage.Normalize qualified as Normalize import Claude.V1.Messages qualified as Messages +import Control.Applicative ((<|>)) import Control.Exception (SomeAsyncException (..), SomeException, fromException, throwIO, try) import Control.Lens ((%~), (&), (.~), (^.)) import Data.Aeson (Value) import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as BSL import Data.CaseInsensitive qualified as CI import Data.Generics.Labels () @@ -79,6 +83,7 @@ import Data.IntMap.Strict qualified as IntMap import Data.IntSet qualified as IntSet import Data.Maybe (fromMaybe) +import Data.Set qualified as Set import Data.Text (Text) import Data.Text qualified as Text import Data.Text.Encoding qualified as Text @@ -136,7 +141,7 @@ -- separately by 'Transport.requestHeaders'. mkEvidence <- Build.prepareEvidenceAt - (call ^. #baseUrl) + (Text.pack (Client.showBaseUrl (Client.baseUrl (call ^. #clientEnv))) <> "/v1/messages") m opts Ev.TransportHttpApi @@ -161,7 +166,10 @@ responseId = Nothing } ], - assembler = emptyAssembler m startTime, + assembler = + emptyAssembler m startTime + & #cacheDuration .~ shapedCacheDuration (call ^. #requestBody) + & #fastRequested .~ shapedFastRequested (call ^. #requestBody), finished = False, terminalRef = tref, metadataRef = mref, @@ -393,8 +401,9 @@ -- unconditionally, because each costs a lookup and each improves the -- 'Baikai.Response.Response' for every caller. -- --- Nothing here consults the request. An observation the provider did not --- make stays 'Ev.Unobserved'. +-- Observed fields never borrow the request. An observation the provider did +-- not make stays 'Ev.Unobserved'. The separate summary diagnostic relates +-- the translated request to completed blocks without claiming observed effort. observeAnthropic :: Ev.CallStatus -> Assembler -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence observeAnthropic st ass ev = @@ -404,6 +413,7 @@ & #providerRequestId .~ (ass ^. #providerRequestId) & #responseId .~ maybe Ev.Unobserved Ev.Observed (ass ^. #responseId) & #usage .~ observedUsage ass + & #thinking . #adjustments %~ (<> summaryDiagnostics st ass (ev ^. #thinking)) & #responseCommitment .~ responseCommitment st ass & #strength .~ Ev.deriveStrength @@ -411,6 +421,23 @@ (ass ^. #providerRequestId) (maybe Ev.Unobserved Ev.Observed (ass ^. #responseId)) +-- | Diagnose visibility after a successful response, without inventing an +-- observation of effort or weakening the original translation. Adaptive calls +-- may legitimately contain no thinking blocks. Failed streams may simply have +-- stopped before text arrived, so neither case claims an unavailable summary. +summaryDiagnostics :: Ev.CallStatus -> Assembler -> Ev.ThinkingTranslation -> [Ev.ThinkingAdjustment] +summaryDiagnostics st ass translation + | st == Ev.CallSucceeded, + Just _ <- translation ^. #requested, + translation ^. #mode `elem` [Ev.ThinkingModeAdaptive, Ev.ThinkingModeBudget], + not (null thinkingBlocks), + all unreadable thinkingBlocks = + [Ev.ThinkingSummaryUnavailable] + | otherwise = [] + where + thinkingBlocks = [t | Content.AssistantThinking t <- Vector.toList (blocksInOrder ass)] + unreadable t = t ^. #redacted || Text.null (t ^. #thinking) + -- | The token accounting, but only if Anthropic actually reported it. -- -- The assembler initialises 'usage' to zeroes, so reporting it @@ -551,7 +578,11 @@ toolArgsBuf :: !(IntMap Text), toolMeta :: !(IntMap (Text, Text)), usage :: !Usage.Usage, + cacheDuration :: !(Maybe CacheRetention), + fastRequested :: !Bool, stopReason :: !Stop.StopReason, + -- | Refusal detail reported in the delta, consumed at message_stop. + stopDetails :: !(Maybe Messages.StopDetails), -- | Anthropic's own correlation identifier for this call, from the -- response headers. providerRequestId :: !(Ev.Observed Text), @@ -585,7 +616,10 @@ toolArgsBuf = IntMap.empty, toolMeta = IntMap.empty, usage = Usage.zeroUsage, + cacheDuration = Nothing, + fastRequested = False, stopReason = Stop.Stop, + stopDetails = Nothing, providerRequestId = Ev.Unobserved, observedModel = Ev.Unobserved, httpStatus = Nothing, @@ -650,27 +684,35 @@ -- 'Messages.StreamUsage' has no 'GHC.Generics.Generic' instance, -- so these are record dots rather than the generic-lens labels -- used for 'Messages.Usage'. - inputFinal = fromMaybe (u ^. #inputTokens) su.stream_input_tokens - outputFinal = su.output_tokens - cacheReadFinal = fromMaybe (u ^. #cacheReadTokens) su.stream_cache_read_input_tokens - cacheWriteFinal = fromMaybe (u ^. #cacheWriteTokens) su.stream_cache_creation_input_tokens - reasoningFinal = case su.stream_output_tokens_details of - Just d -> Just d.thinking_tokens - Nothing -> u ^. #reasoningTokens + known category getter = case u ^. #availability of + Just facts | category `Set.notMember` Usage.missingCategories facts -> Just (getter u) + _ -> Nothing u' = - u - & #inputTokens .~ inputFinal - & #outputTokens .~ outputFinal - & #cacheReadTokens .~ cacheReadFinal - & #cacheWriteTokens .~ cacheWriteFinal - & #reasoningTokens .~ reasoningFinal - & #totalTokens .~ (inputFinal + outputFinal + cacheReadFinal + cacheWriteFinal) - in ([], ass & #stopReason .~ stopR & #usage .~ u' & #usageReported .~ True) + Usage.observeBilling (maybe [] (Set.toList . Usage.billingFacts) (u ^. #availability) <> toolBilling su.stream_server_tool_use) $ + Normalize.normalizeUsage + Normalize.ExclusiveInput + ( Normalize.ReportedUsage + (su.stream_input_tokens <|> known Usage.InputUsage Usage.inputTokens) + (Just su.output_tokens) + (su.stream_cache_read_input_tokens <|> known Usage.CacheReadUsage Usage.cacheReadTokens) + (su.stream_cache_creation_input_tokens <|> known Usage.CacheWriteUsage Usage.cacheWriteTokens) + ((Messages.thinking_tokens <$> su.stream_output_tokens_details) <|> (u ^. #reasoningTokens)) + ) + in ([], ass & #stopReason .~ stopR & #stopDetails .~ (md ^. #stop_details) & #usage .~ u' & #usageReported .~ True) Messages.Message_Stop -> let reason = ass ^. #stopReason -- A refusal is a filter: the content, not the transport, is -- the problem, and a caller can branch on the category. - refusal = contentFiltered "Anthropic refused to generate a response (stop_reason=refusal)" + details = ass ^. #stopDetails + refusalCategory = details >>= (\d -> d.category) + explanation = details >>= (\d -> d.explanation) + refusal = + contentFiltered + ( "Anthropic refused to generate a response (stop_reason=refusal)" + <> maybe "" (\c -> " [category=" <> c <> "]") refusalCategory + <> maybe "" (": " <>) explanation + ) + & #refusalCategory .~ refusalCategory msg = if reason == Stop.ErrorReason then finalMessageOnError ass now (refusal ^. #message) @@ -772,7 +814,8 @@ Content.ThinkingContent { Content.thinking = payload, Content.signature = Nothing, - Content.redacted = True + Content.redacted = True, + Content.replayState = Nothing } block = Content.AssistantThinking thinkingContent in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], @@ -786,7 +829,8 @@ Content.ThinkingContent { Content.thinking = body, Content.signature = if maybe True Text.null sig then Nothing else sig, - Content.redacted = False + Content.redacted = False, + Content.replayState = Nothing } block = Content.AssistantThinking thinkingContent in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], @@ -841,21 +885,31 @@ -- Shared so the terminal message and the evidence record cannot report -- two different figures for one call. -- --- __Known limitation: cache writes are priced at one rate.__ Anthropic --- bills a one-hour ('Baikai.CacheRetention.CacheRetentionLong') cache --- write at roughly twice the five-minute rate, but the catalog carries a --- single @cacheWriteCost@ — the five-minute one — and the SDK's --- 'Messages.Usage' reports a single @cache_creation_input_tokens@ with --- no per-TTL split (see 'anthroUsageToBaikai'). A long-retention write --- is therefore /under-stated/ here. Token counts are unaffected; only --- the dollar figure is low. Fixing it needs a second value carried off --- the worker channel, a second field inside the evidence record, and a --- second rate models.dev does not publish. +-- The duration comes from the shaped request body, so a compatibility +-- downgrade to a short cache cannot accidentally incur the long-write rate. finalUsage :: Assembler -> Usage.Usage finalUsage ass = - let usageBare = ass ^. #usage - in usageBare & #cost .~ Pricing.computeCost (ass ^. #model) usageBare + let usageBare = if ass ^. #usageReported then ass ^. #usage else Normalize.normalizeUsage Normalize.ExclusiveInput (Normalize.ReportedUsage Nothing Nothing Nothing Nothing Nothing) + calculated = Pricing.computeCostForService (ass ^. #cacheDuration) Nothing (ass ^. #model) usageBare + reasons = + [CacheDurationNotReported | usageBare ^. #cacheWriteTokens > 0, Nothing <- [ass ^. #cacheDuration]] + <> [SpeedNotReported | ass ^. #fastRequested, not (any isSpeed (maybe [] (Set.toList . Usage.billingFacts) (usageBare ^. #availability)))] + isSpeed (Usage.BillingSpeed _) = True + isSpeed _ = False + in usageBare & #cost .~ estimateCost reasons calculated +shapedFastRequested :: Aeson.Value -> Bool +shapedFastRequested (Aeson.Object body) = KeyMap.lookup "speed" body == Just (Aeson.String "fast") +shapedFastRequested _ = False + +shapedCacheDuration :: Aeson.Value -> Maybe CacheRetention +shapedCacheDuration (Aeson.Object body) = case KeyMap.lookup "cache_control" body of + Just (Aeson.Object marker) -> Just $ case KeyMap.lookup "ttl" marker of + Just (Aeson.String "1h") -> CacheRetentionLong + _ -> CacheRetentionShort + _ -> Nothing +shapedCacheDuration _ = Nothing + finalMessage :: Assembler -> UTCTime -> Msg.Message finalMessage ass now = Msg.AssistantMessage @@ -947,26 +1001,25 @@ -- output tokens rather than a billed class of its own, so it moves no -- total. -- --- @cache_creation_input_tokens@ is one number covering both cache-write --- TTLs. The SDK's 'Messages.Usage' has no per-TTL breakdown, so baikai --- cannot tell a five-minute write from a one-hour one and prices both at --- the catalog's single @cacheWriteCost@; see 'finalUsage' and --- @docs\/user\/prompt-caching.md@. +-- @cache_creation_input_tokens@ is a total across cache writes. The final +-- calculation uses the duration selected by the actual shaped request body. anthroUsageToBaikai :: Messages.Usage -> Usage.Usage anthroUsageToBaikai u = - let i = u ^. #input_tokens - o = u ^. #output_tokens - cr = fromMaybe 0 (u ^. #cache_read_input_tokens) - cw = fromMaybe 0 (u ^. #cache_creation_input_tokens) - in Usage.Usage - { Usage.inputTokens = i, - Usage.outputTokens = o, - Usage.cacheReadTokens = cr, - Usage.cacheWriteTokens = cw, - Usage.reasoningTokens = fmap (^. #thinking_tokens) (u ^. #output_tokens_details), - Usage.totalTokens = i + o + cr + cw, - Usage.cost = zeroCost - } + Usage.observeBilling ([Usage.BillingServiceTier tier | Just tier <- [u ^. #service_tier]] <> [Usage.BillingSpeed speed | Just value <- [u ^. #speed], Aeson.String speed <- [Aeson.toJSON value]] <> toolBilling (u ^. #server_tool_use)) $ + Normalize.normalizeUsage + Normalize.ExclusiveInput + ( Normalize.ReportedUsage + (Just (u ^. #input_tokens)) + (Just (u ^. #output_tokens)) + (u ^. #cache_read_input_tokens) + (u ^. #cache_creation_input_tokens) + (fmap (^. #thinking_tokens) (u ^. #output_tokens_details)) + ) + +-- Server-side tool products are outside the token-rate calculation. +toolBilling :: Maybe Messages.ServerToolUseUsage -> [Usage.BillingFact] +toolBilling Nothing = [] +toolBilling (Just usage) = [Usage.BillingServerToolUse | fromMaybe 0 (usage ^. #web_search_requests) + fromMaybe 0 (usage ^. #tool_search_requests) > 0] mapStopReason :: Maybe Messages.StopReason -> Stop.StopReason mapStopReason = \case diff --git a/src/Baikai/Provider/Claude/Transport.hs b/src/Baikai/Provider/Claude/Transport.hs --- a/src/Baikai/Provider/Claude/Transport.hs +++ b/src/Baikai/Provider/Claude/Transport.hs @@ -25,6 +25,8 @@ import Baikai.Message qualified as Msg import Baikai.Model (Model (..)) import Baikai.Options (Options (..)) +import Baikai.Provider.Claude.Internal.Request (planSpeed) +import Claude.V1.Messages qualified as Messages import Control.Exception (throwIO) import Control.Lens ((^.)) import Crypto.Hash (Digest, SHA256) @@ -55,12 +57,16 @@ id (\v -> (("anthropic-version", Text.encodeUtf8 v) :)) anthropicVersion - ( sessionHeaders + ( speedHeaders + <> sessionHeaders <> [ ("x-api-key", Text.encodeUtf8 apiKey), ("Accept", "text/event-stream"), ("Content-Type", "application/json") ] ) + speedHeaders = case fst (planSpeed compat (opts ^. #speed)) of + Just Messages.SpeedFast -> [("anthropic-beta", "fast-mode-2026-02-01")] + _ -> [] sessionHeaders = if sendSessionAffinityHeaders compat then [("x-session-affinity", Text.encodeUtf8 (sessionAffinityValue ctx))] @@ -142,7 +148,8 @@ message = "provider stream exceeded timeoutMs=" <> Text.pack (show ms), httpStatus = Nothing, retryAfterSeconds = Nothing, - exitCode = Nothing + exitCode = Nothing, + refusalCategory = Nothing } -- | Apply caller overrides over the provider's own headers. diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -224,7 +224,7 @@ oneEvidence =<< replayWith (testModel & #baseUrl .~ "") 200 successHeaders successBody baseOptions case field "endpoint" ev of - Just (Object e) -> KeyMap.lookup "endpoint" e @?= Just (String "https://api.anthropic.com") + Just (Object e) -> KeyMap.lookup "endpoint" e @?= Just (String "https://api.anthropic.com/v1/messages") other -> assertFailure ("expected an endpoint identity, got: " <> show other) -- | A response that names its model and its message id but carries no @@ -382,7 +382,7 @@ testModel & #compat .~ CompatAnthropicMessages - (defaultAnthropicMessagesCompat {supportsSamplingParameters = False}) + (defaultAnthropicMessagesCompat & #supportsSamplingParameters .~ False) ev <- oneEvidence =<< replayWith diff --git a/test/FableContractsSpec.hs b/test/FableContractsSpec.hs new file mode 100644 --- /dev/null +++ b/test/FableContractsSpec.hs @@ -0,0 +1,243 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module FableContractsSpec (tests) where + +import Baikai hiding (messages, model) +import Baikai.Models.Generated (anthropic_claude_fable_5_1) +import Baikai.Provider.Claude.Internal.Request qualified as R +import Baikai.Provider.Claude.Internal.Stream (SseDriver, claudeMessagesStreamWith) +import Claude.V1.Messages qualified as C +import Contract (assertErrorContract) +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Fable contracts" + [ summaryTests, + testCase "forced choices fail before the driver for complete and stream, including renamed models" $ + forM_ [model, model & #modelId .~ "renamed-generation"] $ \m -> + forM_ [ToolChoiceRequired, ToolChoiceSpecific "lookup"] $ \choice -> do + sent <- newIORef False + let never _ _ _ = writeIORef sent True + opts = options & #toolChoice .~ Just choice + events <- Stream.toList (claudeMessagesStreamWith never m context opts) + assertErrorContract events + response <- streamingComplete (claudeMessagesStreamWith never) m context opts + fmap (.category) (responseError response) @?= Just InvalidRequest + assertBool "useful correction" (maybe False (T.isInfixOf "ToolChoiceAuto" . (.message)) (responseError response)) + readIORef sent >>= (@?= False), + testCase "auto and none keep their exact wire meaning" $ + forM_ [(ToolChoiceAuto, "auto"), (ToolChoiceNone, "none")] $ \(choice, expected) -> do + body <- newIORef Null + let capture call _ emit = writeIORef body (call ^. #requestBody) >> send finalTurn emit + _ <- streamingComplete (claudeMessagesStreamWith capture) model context (options & #toolChoice .~ Just choice) + raw <- readIORef body + (field "tool_choice" raw >>= field "type") @?= Just (String expected), + testCase "supporting compatibility retains required and named choice" $ + forM_ [(ToolChoiceRequired, "any"), (ToolChoiceSpecific "lookup", "tool")] $ \(choice, expected) -> do + let m = model & #modelId .~ "supporting-generation" & #compat .~ CompatAnthropicMessages (anthropicMessagesCompatFor model & #supportsForcedToolChoice .~ True) + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest m context (options & #toolChoice .~ Just choice)) + (field "tool_choice" (Aeson.toJSON req) >>= field "type") @?= Just (String expected), + testCase "unset effort is no preference and small caps never create a manual budget" $ + forM_ [Nothing, Just ThinkingMinimal, Just ThinkingLow, Just ThinkingMedium, Just ThinkingHigh, Just ThinkingXHigh, Just ThinkingMax] $ \level -> do + let opts = options & #thinking .~ level & #maxTokens .~ Just 1 + (req, translation) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model context opts) + let raw = Aeson.toJSON req + field "max_tokens" raw @?= Just (Number 1) + translation @?= R.describeThinkingFor model opts + case level of + Nothing -> do + field "thinking" raw @?= Nothing + translation @?= noThinkingRequested + Just _ -> do + (field "thinking" raw >>= field "type") @?= Just (String "adaptive") + (field "thinking" raw >>= field "budget_tokens") @?= Nothing, + testCase "legacy serialized compat defaults to supporting forced choice" $ do + let raw = case Aeson.toJSON defaultAnthropicMessagesCompat of Object o -> Object (KM.delete "supportsForcedToolChoice" o); v -> v + case Aeson.fromJSON raw of + Aeson.Success c -> (c :: AnthropicMessagesCompat).supportsForcedToolChoice @?= True + Aeson.Error err -> assertFailure err, + testCase "two consecutive tool rounds preserve signed empty, visible and redacted thinking" $ do + requests <- newIORef ([] :: [Value]) + executed <- newIORef ([] :: [Text]) + let scripted call _ emit = do + previous <- readIORef requests + writeIORef requests (previous <> [call ^. #requestBody]) + send (case length previous of 0 -> toolTurn "" "sig-one" "toolu_1" True; 1 -> toolTurn "visible summary" "sig-two" "toolu_2" False; _ -> finalTurn) emit + reg <- newProviderRegistryFrom [apiProvider AnthropicMessages (claudeMessagesStreamWith scripted)] + (history, response) <- runToolLoopWith reg 4 (\tc -> do xs <- readIORef executed; writeIORef executed (xs <> [tc.id_]); pure (toolResultText "found")) model context summaryOptions + response.message.content @?= V.singleton (AssistantText (TextContent "done")) + readIORef executed >>= (@?= ["toolu_1", "toolu_2"]) + bodies <- readIORef requests + length bodies @?= 3 + case bodies of + [first, second, third] -> do + let a = messages first; b = messages second; c = messages third + V.take (V.length a) b @?= a + V.take (V.length b) c @?= b + field "system" first @?= field "system" third + field "tools" first @?= field "tools" third + forM_ bodies $ \body -> (field "thinking" body >>= field "display") @?= Just (String "summarized") + contentAt 1 b @?= V.fromList [signed "" "sig-one", redactedItem, toolItem "toolu_1"] + contentAt 3 c @?= V.fromList [signed "visible summary" "sig-two", toolItem "toolu_2"] + field "tool_use_id" (contentAt 2 b V.! 0) @?= Just (String "toolu_1") + field "tool_use_id" (contentAt 4 c V.! 0) @?= Just (String "toolu_2") + persisted <- V.mapM persistThinking (history ^. #messages) + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model (history & #messages .~ persisted) summaryOptions) + messages (Aeson.toJSON req) @?= c + _ -> assertFailure "expected three requests", + testCase "error cleanup retains completed signed thinking for persistence" $ do + let partial _ _ emit = send (take 4 (toolTurn "" "sig-one" "toolu_1" False)) emit >> emit (Left (providerError "interrupted")) + response <- streamingComplete (claudeMessagesStreamWith partial) model context options + assertBool "failed response" (responseError response /= Nothing) + case V.toList response.message.content of + [AssistantThinking t] -> do + t.thinking @?= "" + t.signature @?= Just "sig-one" + t.replayState @?= Nothing + _ -> assertFailure "signed state was discarded on error" + ] + +model :: Model +model = anthropic_claude_fable_5_1 + +options :: Options +options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-key") + +context :: Context +context = systemUser "unchanged system" "look twice" & #tools .~ V.singleton (mkTool "lookup" "lookup" (object ["type" .= ("object" :: Text)])) + +send :: [Value] -> (Either BaikaiError C.MessageStreamEvent -> IO ()) -> IO () +send frames emit = forM_ frames $ \raw -> case Aeson.fromJSON raw of + Aeson.Error err -> assertFailure err + Aeson.Success ev -> emit (Right ev) + +start :: Value +start = object ["type" .= ("message_start" :: Text), "message" .= object ["id" .= ("msg" :: Text), "type" .= ("message" :: Text), "role" .= ("assistant" :: Text), "model" .= ("claude-fable-5-1" :: Text), "content" .= ([] :: [Value]), "usage" .= object ["input_tokens" .= (5 :: Int), "output_tokens" .= (0 :: Int)]]] + +block :: Int -> Value -> Value +block n b = object ["type" .= ("content_block_start" :: Text), "index" .= n, "content_block" .= b] + +stopBlock :: Int -> Value +stopBlock n = object ["type" .= ("content_block_stop" :: Text), "index" .= n] + +end :: Text -> [Value] +end reason = [object ["type" .= ("message_delta" :: Text), "delta" .= object ["stop_reason" .= reason], "usage" .= object ["output_tokens" .= (5 :: Int)]], object ["type" .= ("message_stop" :: Text)]] + +signed :: Text -> Text -> Value +signed text sig = object ["type" .= ("thinking" :: Text), "thinking" .= text, "signature" .= sig] + +redactedItem :: Value +redactedItem = object ["type" .= ("redacted_thinking" :: Text), "data" .= ("encrypted-redacted" :: Text)] + +toolItem :: Text -> Value +toolItem ident = object ["type" .= ("tool_use" :: Text), "id" .= ident, "name" .= ("lookup" :: Text), "input" .= object []] + +toolTurn :: Text -> Text -> Text -> Bool -> [Value] +toolTurn text sig ident redacted = + [start, block 0 (signed "" "")] + <> (if T.null text then [] else [object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("thinking_delta" :: Text), "thinking" .= text]]]) + <> [object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("signature_delta" :: Text), "signature" .= sig]], stopBlock 0] + <> (if redacted then [block 1 redactedItem, stopBlock 1] else []) + <> [block (if redacted then 2 else 1) (toolItem ident), stopBlock (if redacted then 2 else 1)] + <> end "tool_use" + +finalTurn :: [Value] +finalTurn = [start, block 0 (object ["type" .= ("text" :: Text), "text" .= ("" :: Text)]), object ["type" .= ("content_block_delta" :: Text), "index" .= (0 :: Int), "delta" .= object ["type" .= ("text_delta" :: Text), "text" .= ("done" :: Text)]], stopBlock 0] <> end "end_turn" + +field :: Key -> Value -> Maybe Value +field k (Object o) = KM.lookup k o +field _ _ = Nothing + +messages :: Value -> V.Vector Value +messages raw = case field "messages" raw of Just (Array xs) -> xs; _ -> V.empty + +contentAt :: Int -> V.Vector Value -> V.Vector Value +contentAt n xs = case xs V.!? n >>= field "content" of Just (Array cs) -> cs; _ -> V.empty + +-- Applications own the surrounding history store; ThinkingContent supplies +-- its JSON round trip. Exercise that payload without inventing a Context decoder. +persistThinking :: Message -> IO Message +persistThinking (AssistantMessage payload) = do + blocks <- V.mapM persist (payload ^. #content) + pure (AssistantMessage (payload & #content .~ blocks)) + where + persist (AssistantThinking t) = AssistantThinking <$> either assertFailure pure (Aeson.eitherDecode (Aeson.encode t)) + persist block = pure block +persistThinking other = pure other + +summaryOptions :: Options +summaryOptions = options & #thinking .~ Just ThinkingLow & #evidence .~ Just (evidenceRequest "summary-replay") + +summaryTests :: TestTree +summaryTests = + testGroup + "summary visibility" + [ testCase "summarized reasoning assembles into non-empty thinking content" $ do + response <- completeFrames (toolTurn "visible summary" "signed-summary" "toolu_summary" False) summaryOptions + let blocks = [t | AssistantThinking t <- V.toList (response ^. #message . #content)] + map (^. #thinking) blocks @?= ["visible summary"] + map (^. #signature) blocks @?= [Just "signed-summary"] + ev <- evidenceOf response + ev ^. #thinking . #displayText @?= Just "summarized" + ev ^. #thinking . #adjustments @?= [] + ev ^. #observedThinking @?= Unobserved, + testCase "reasoning requested but returned empty is recorded in the evidence" $ do + forM_ [[signed "" "empty-signature"], [redactedItem], [signed "" "empty-signature", redactedItem]] $ \blocks -> do + response <- completeFrames (blocksTurn blocks) summaryOptions + ev <- evidenceOf response + ev ^. #thinking . #adjustments @?= [ThinkingSummaryUnavailable] + ev ^. #thinking . #displayText @?= Just "summarized" + ev ^. #observedThinking @?= Unobserved + ev ^. #status @?= CallSucceeded + responseError response @?= Nothing + weakensThinking ThinkingSummaryUnavailable @?= False + let actual = [t | AssistantThinking t <- V.toList (response ^. #message . #content)] + length actual @?= length blocks + -- Encrypted payloads and signed empty blocks remain usable history. + (req, _) <- either (\e -> assertFailure (T.unpack e) >> fail "map") pure (R.mapRequest model (emptyContext & #messages .~ V.singleton (AssistantMessage (response ^. #message))) summaryOptions) + contentAt 0 (messages (Aeson.toJSON req)) @?= V.fromList blocks, + testCase "one visible block among empty and redacted blocks is a readable summary" $ do + response <- completeFrames (blocksTurn [signed "" "empty", redactedItem, signed "visible" "visible-signature"]) summaryOptions + ev <- evidenceOf response + ev ^. #thinking . #adjustments @?= [], + testCase "no thinking block and no thinking preference do not invent missing summaries" $ do + noBlocks <- completeFrames finalTurn summaryOptions + ev <- evidenceOf noBlocks + ev ^. #thinking . #adjustments @?= [] + noPreference <- completeFrames (blocksTurn [signed "" "sig"]) (options & #evidence .~ Just (evidenceRequest "no-thinking")) + ev2 <- evidenceOf noPreference + ev2 ^. #thinking @?= noThinkingRequested, + testCase "failed streams do not label partial thinking as a missing completed summary" $ do + let driver _ _ emit = send [start, block 0 (signed "" "sig"), stopBlock 0] emit >> emit (Left (providerError "interrupted")) + response <- streamingComplete (claudeMessagesStreamWith driver) model emptyContext summaryOptions + ev <- evidenceOf response + ev ^. #status @?= CallFailed + ev ^. #thinking . #adjustments @?= [] + assertBool "failure retained" (responseError response /= Nothing) + ] + where + completeFrames frames opts = streamingComplete (claudeMessagesStreamWith (\_ _ emit -> send frames emit)) model emptyContext opts + blocksTurn blocks = [start] <> concat [blockFrames i b | (i, b) <- zip [0 ..] blocks] <> end "end_turn" + blockFrames i b = case (field "type" b, field "thinking" b, field "signature" b) of + (Just (String "thinking"), Just (String text), Just (String sig)) -> + [ block i (signed "" ""), + object ["type" .= ("content_block_delta" :: Text), "index" .= i, "delta" .= object ["type" .= ("thinking_delta" :: Text), "thinking" .= text]], + object ["type" .= ("content_block_delta" :: Text), "index" .= i, "delta" .= object ["type" .= ("signature_delta" :: Text), "signature" .= sig]], + stopBlock i + ] + _ -> [block i b, stopBlock i] + evidenceOf response = maybe (assertFailure "missing evidence" >> fail "evidence") pure (response ^. #evidence) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -30,6 +30,7 @@ import Data.Vector qualified as Vector import ErrorClassSpec qualified import EvidenceSpec qualified +import FableContractsSpec qualified import LifecycleSpec qualified import MidStreamSpec qualified import PublicSurfaceSpec qualified @@ -77,6 +78,7 @@ CliEvidenceSpec.tests, ErrorClassSpec.tests, EvidenceSpec.tests, + FableContractsSpec.tests, LifecycleSpec.tests, MidStreamSpec.tests, PublicSurfaceSpec.tests, @@ -458,6 +460,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just "--effort", + displayText = Nothing, adjustments = expected } | (level, wire, expected) <- diff --git a/test/ShapeSpec.hs b/test/ShapeSpec.hs --- a/test/ShapeSpec.hs +++ b/test/ShapeSpec.hs @@ -2,13 +2,16 @@ import Baikai import Baikai.Models.Generated qualified as Models -import Baikai.Provider.Claude.Internal.Request (mapRequest) +import Baikai.Provider.Claude.Internal.Request (describeThinkingFor, mapRequest) import Baikai.Provider.Claude.Shape (streamRequestBody) -import Control.Lens ((&), (.~)) +import Baikai.Provider.Claude.Transport qualified as Transport +import Control.Lens ((&), (.~), (^.)) +import Control.Monad (forM_) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap qualified as KeyMap +import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Vector qualified as Vector import Test.Tasty (TestTree, testGroup) @@ -18,7 +21,12 @@ tests = testGroup "ShapeSpec" - [ verbatimToolSchemaTest, + [ testCase "server-side fallbacks stay absent from the request" $ do + value <- shapedBody Models.anthropic_claude_opus_5 emptyContext emptyOptions + lookupPath ["fallbacks"] value @?= Nothing, + summaryDisplayTest, + fastSpeedTests, + verbatimToolSchemaTest, toolChoiceNoneTest, toolCacheControlTest, toolCacheControlCompatGateTest @@ -124,3 +132,59 @@ i < Vector.length xs = lookupPath rest (xs Vector.! i) lookupPath _ _ = Nothing + +fastSpeedTests :: TestTree +fastSpeedTests = + testGroup + "speed" + [ testCase "a fast-mode request on claude-opus-5 carries speed and the beta header" $ do + let m = Models.anthropic_claude_opus_5 + opts = emptyOptions & #speed .~ Just SpeedFast + value <- shapedBody m emptyContext opts + lookupPath ["speed"] value @?= Just (String "fast") + lookup "anthropic-beta" (headers m opts) @?= Just "fast-mode-2026-02-01", + testCase "a fast-mode request on claude-sonnet-5 omits speed and records the drop" $ do + let m = Models.anthropic_claude_sonnet_5 + opts = emptyOptions & #speed .~ Just SpeedFast + value <- shapedBody m emptyContext opts + lookupPath ["speed"] value @?= Nothing + lookup "anthropic-beta" (headers m opts) @?= Nothing + case mapRequest m emptyContext opts of + Left err -> assertFailure (show err) + Right (_, translation) -> do + translation @?= describeThinkingFor m opts + translation ^. #adjustments @?= [FastModeDroppedUnsupportedModel] + weakensThinking FastModeDroppedUnsupportedModel @?= False + Aeson.fromJSON (Aeson.toJSON FastModeDroppedUnsupportedModel) @?= Aeson.Success FastModeDroppedUnsupportedModel, + testCase "absent and explicit standard speed remain distinct on unsupported models" $ do + let m = Models.anthropic_claude_sonnet_5 + opts = emptyOptions & #speed .~ Just SpeedStandard + absent <- shapedBody m emptyContext emptyOptions + standard <- shapedBody m emptyContext opts + lookupPath ["speed"] absent @?= Nothing + lookupPath ["speed"] standard @?= Just (String "standard") + lookup "anthropic-beta" (headers m opts) @?= Nothing + describeThinkingFor m opts ^. #adjustments @?= [], + testCase "caller beta headers override model and automatic fast beta headers" $ do + let m = Models.anthropic_claude_opus_5 & #headers .~ Map.singleton "anthropic-beta" "model-beta" + opts = emptyOptions & #speed .~ Just SpeedFast & #headers .~ Map.singleton "Anthropic-Beta" "caller-beta" + lookup "anthropic-beta" (headers m emptyOptions) @?= Just "model-beta" + lookup "anthropic-beta" (headers m opts) @?= Just "caller-beta" + ] + where + headers m opts = Transport.requestHeaders "test-key" Nothing (anthropicMessagesCompatFor m) emptyContext m opts + +summaryDisplayTest :: TestTree +summaryDisplayTest = testCase "adaptive requests ask for summarized display; budget and absent thinking retain their shapes" $ do + let opts = emptyOptions & #thinking .~ Just ThinkingLow + forM_ [Models.anthropic_claude_opus_5, Models.anthropic_claude_opus_4_6, Models.anthropic_claude_fable_5_1, Models.anthropic_claude_opus_5 & #modelId .~ "renamed"] $ \m -> do + body <- shapedBody m emptyContext opts + lookupPath ["thinking"] body @?= Just (Aeson.object ["type" .= ("adaptive" :: Text.Text), "display" .= ("summarized" :: Text.Text)]) + describeThinkingFor m opts ^. #displayText @?= Just "summarized" + absent <- shapedBody m emptyContext emptyOptions + lookupPath ["thinking"] absent @?= Nothing + describeThinkingFor m emptyOptions ^. #displayText @?= Nothing + let budget = Models.anthropic_claude_haiku_4_5 + body <- shapedBody budget emptyContext opts + lookupPath ["thinking"] body @?= Just (Aeson.object ["type" .= ("enabled" :: Text.Text), "budget_tokens" .= thinkingTokenBudget ThinkingLow]) + describeThinkingFor budget opts ^. #displayText @?= Nothing diff --git a/test/SseSpec.hs b/test/SseSpec.hs --- a/test/SseSpec.hs +++ b/test/SseSpec.hs @@ -2,7 +2,7 @@ import Baikai import Baikai.Http qualified as Http -import Baikai.Models.Generated (anthropic_claude_haiku_4_5) +import Baikai.Models.Generated (anthropic_claude_fable_5_1, anthropic_claude_haiku_4_5, anthropic_claude_opus_5) import Baikai.Provider.Claude.Internal.Stream (Assembler, SseDriver, claudeMessagesStreamWith, emptyAssembler, translate) import Baikai.Provider.Claude.Sse ( ResponseMetadata, @@ -10,6 +10,7 @@ claudeSseStreamValueWithHeaders, sseFromResponse, ) +import Baikai.Usage qualified as Usage import Claude.V1.Messages qualified as Messages import Contract (assertErrorContract) import Control.Lens ((&), (.~), (^.)) @@ -18,9 +19,11 @@ import Data.ByteString (ByteString) import Data.ByteString qualified as SBS import Data.ByteString.Char8 qualified as S8 +import Data.ByteString.Lazy qualified as LBS import Data.CaseInsensitive qualified as CI import Data.Generics.Labels () import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector (Vector) @@ -124,6 +127,19 @@ -- fixture also carries must not be recorded. md ^. #headers @?= [("request-id", "req_abc123")] other -> assertFailure ("expected exactly one metadata value, got: " <> show other), + testCase "partial and repeated usage snapshots preserve reported cache categories" $ do + let start = frameOf "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_usage\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-test\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":10,\"output_tokens\":0,\"cache_read_input_tokens\":20}}}" + partial = frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":100}}" + final = frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":100,\"cache_creation_input_tokens\":30}}" + (_, before) <- replayTranslate [start, partial] + (before ^. #usage) ^. #availability @?= Just (Usage.UsageAvailability (Set.singleton Usage.CacheWriteUsage) False Set.empty) + (_, once) <- replayTranslate [start, partial, final] + (_, twice) <- replayTranslate [start, partial, final, final] + once ^. #usage @?= twice ^. #usage + (once ^. #usage) ^. #totalTokens @?= 160 + (once ^. #usage) ^. #availability @?= Just (Usage.UsageAvailability Set.empty False Set.empty) + let (_, failed) = translate (Left (providerUnavailable "reset")) once testTime + failed ^. #usage @?= once ^. #usage, testCase "the observed model comes from message_start, not the configured model" $ do (_, ass) <- replay 200 [("request-id", "req_abc123")] successBody ass ^. #observedModel @?= Observed "claude-haiku-4-5-20990101-server-side" @@ -168,7 +184,23 @@ blockClosingTests = testGroup "block closing under failure" - [ testCase "a tool call cut off by max_tokens closes with its raw argument text" $ do + [ testCase "fast terminal pricing follows observed speed, including missing observations" $ do + forM_ [(Just "fast", 1 / 50, Set.empty), (Just "standard", 1 / 100, Set.empty), (Nothing, 1 / 100, Set.singleton SpeedNotReported)] $ \(observed, expected, reasons) -> do + let speedJson = maybe "" (\v -> ",\"speed\":\"" <> v <> "\"") observed + body = [frameOf ("{\"type\":\"message_start\",\"message\":{\"id\":\"msg_fast\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-opus-5\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":0,\"output_tokens\":0,\"cache_read_input_tokens\":0,\"cache_creation_input_tokens\":1000,\"service_tier\":\"standard\"" <> speedJson <> "}}}"), frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":0}}", frameOf "{\"type\":\"message_stop\"}"] + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] body)) anthropic_claude_opus_5 emptyContext (testOptions & #cacheRetention .~ Just CacheRetentionLong & #speed .~ Just SpeedFast) + response ^. #message . #usage . #cost . #usd @?= expected + response ^. #message . #usage . #cost . #basis . #estimateReasons @?= reasons, + testCase "Fable cache writes use the shaped duration including compatibility downgrades" $ do + let fable = anthropic_claude_fable_5_1 + downgraded = fable & #compat .~ CompatAnthropicMessages (anthropicMessagesCompatFor fable & #supportsLongCacheRetention .~ False) + body = [frameOf "{\"type\":\"message_start\",\"message\":{\"id\":\"msg_cost\",\"type\":\"message\",\"role\":\"assistant\",\"content\":[],\"model\":\"claude-fable-5-1\",\"stop_reason\":null,\"stop_sequence\":null,\"usage\":{\"input_tokens\":0,\"output_tokens\":0,\"cache_read_input_tokens\":0,\"cache_creation_input_tokens\":1000,\"service_tier\":\"standard\",\"speed\":\"standard\"}}}", frameOf "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\",\"stop_sequence\":null},\"usage\":{\"output_tokens\":0}}", frameOf "{\"type\":\"message_stop\"}"] + forM_ [(fable, CacheRetentionLong, 1 / 50), (fable, CacheRetentionShort, 1 / 80), (downgraded, CacheRetentionLong, 1 / 80)] $ \(m, duration, expected) -> do + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] body)) m emptyContext (testOptions & #cacheRetention .~ Just duration) + response ^. #message . #usage . #cost . #usd @?= expected + response ^. #message . #usage . #cost . #basis . #estimateReasons @?= Set.empty + fmap Usage.billingFacts (response ^. #message . #usage . #availability) @?= Just (Set.fromList [Usage.BillingServiceTier "standard", Usage.BillingSpeed "standard"]), + testCase "a tool call cut off by max_tokens closes with its raw argument text" $ do events <- replayStream 200 [] cutOffToolBody let calls = [tc | ToolCallEnd ToolCallEndPayload {toolCall = tc} <- events] case calls of @@ -191,6 +223,7 @@ be ^. #category @?= ContentFiltered isRetryable be @?= False other -> assertFailure ("expected a terminal EventError, got: " <> show (take 1 other)), + refusalDetailTests, testCase "a mid-stream transport error closes open blocks before the terminal" $ do -- The failure is injected through 'translate' rather than the -- transport, because what is under test is the assembler's @@ -550,3 +583,65 @@ redirectResponse = S8.pack "HTTP/1.1 302 Found\r\nLocation: http://evil.test/steal\r\nContent-Length: 0\r\n\r\n" + +refusalDetailTests :: TestTree +refusalDetailTests = + testGroup + "refusal details" + [ testCase "a categorised refusal names its category and explanation" $ + check (Just "cyber") (Just "Provider explanation"), + testCase "unknown categories survive without an enum update" $ + check (Just "future_category") Nothing, + testCase "an explanation survives without a category" $ + check Nothing (Just "Provider explanation"), + testCase "null details preserve the original refusal message" $ do + events <- replayStream 200 [] (refusalWithDetails Aeson.Null) + be <- terminalError events + be ^. #refusalCategory @?= Nothing + be ^. #message @?= base, + testCase "absent detail fields preserve the original refusal message" $ + check Nothing Nothing, + testCase "explicit null category and explanation remain absent" $ do + events <- replayStream 200 [] (refusalWithDetails (Aeson.object ["type" Aeson..= ("refusal" :: Text.Text), "category" Aeson..= Aeson.Null, "explanation" Aeson..= Aeson.Null])) + be <- terminalError events + be ^. #refusalCategory @?= Nothing + be ^. #message @?= base, + testCase "non-refusal completion does not turn stray details into an error" $ do + let body = map (S8.pack . Text.unpack . Text.replace "\"stop_reason\":\"refusal\"" "\"stop_reason\":\"end_turn\"" . Text.pack . S8.unpack) (refusalWithDetails (detail (Just "cyber") Nothing)) + events <- replayStream 200 [] body + case reverse events of + EventDone TerminalPayload {errorInfo = Nothing} : _ -> pure () + other -> assertFailure (show other), + testCase "blocking completion preserves the structured refusal" $ do + response <- streamingComplete (claudeMessagesStreamWith (replayDriver 200 [] (refusalWithDetails (detail (Just "bio") Nothing)))) testModel emptyContext testOptions + fmap (\be -> be ^. #refusalCategory) (response ^. #errorInfo) @?= Just (Just "bio") + ] + where + base = "Anthropic refused to generate a response (stop_reason=refusal)" + detail :: Maybe Text.Text -> Maybe Text.Text -> Aeson.Value + detail c e = Aeson.object (["type" Aeson..= ("refusal" :: Text.Text)] <> maybe [] (\v -> ["category" Aeson..= v]) c <> maybe [] (\v -> ["explanation" Aeson..= v]) e) + check c e = do + events <- replayStream 200 [] (refusalWithDetails (detail c e)) + assertErrorContract events + be <- terminalError events + be ^. #category @?= ContentFiltered + isRetryable be @?= False + be ^. #refusalCategory @?= c + be ^. #message @?= base <> maybe "" (\v -> " [category=" <> v <> "]") c <> maybe "" (": " <>) e + +refusalWithDetails :: Aeson.Value -> [ByteString] +refusalWithDetails details = + take 1 refusalBody + <> [ frameOf + ( LBS.toStrict + ( Aeson.encode + ( Aeson.object + [ "type" Aeson..= ("message_delta" :: Text.Text), + "delta" Aeson..= Aeson.object ["stop_reason" Aeson..= ("refusal" :: Text.Text), "stop_details" Aeson..= details], + "usage" Aeson..= Aeson.object ["output_tokens" Aeson..= (1 :: Int)] + ] + ) + ) + ), + frameOf "{\"type\":\"message_stop\"}" + ] diff --git a/test/ThinkingSpec.hs b/test/ThinkingSpec.hs --- a/test/ThinkingSpec.hs +++ b/test/ThinkingSpec.hs @@ -30,7 +30,14 @@ tests = testGroup "ThinkingSpec" - [ testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests), + [ testCase "foreign opaque reasoning cannot enter this endpoint" $ do + let thought = emptyThinkingContent & #replayState .~ Just (ThinkingReplay OpenAIResponses "gpt-6-astra" (Vector.singleton (Aeson.object []))) + response = emptyResponse & #message . #content .~ Vector.singleton (AssistantThinking thought) + ctx = addResponse response emptyContext + case mapRequest anthropic_claude_fable_5_1 ctx emptyOptions of + Left _ -> pure () + Right _ -> assertFailure "foreign state was silently accepted", + testGroup "mapRequest max_tokens" (neverExceedsCapTests <> styleTests), translationTableTests, conditionalDowngradeTests, adaptiveHigherEffortTests, @@ -41,6 +48,8 @@ mergedOutputConfigTest, explicitCompatOverridesDefaultTest, anthropicModelsCoverCatalogTest, + testGroup "fast-mode catalog facts" [testCase name ((anthropicMessagesCompatFor m ^. #supportsFastMode) @?= fast) | (name, m, _, _, _, fast) <- anthropicModels], + testGroup "forced-tool catalog facts" [testCase name ((anthropicMessagesCompatFor m ^. #supportsForcedToolChoice) @?= forced) | (name, m, _, _, forced, _) <- anthropicModels], samplingTests, claude15UsageTests, zeroCapFloorTests, @@ -49,27 +58,28 @@ streamFidelityTests ] --- | Every Anthropic model in the generated catalog, with the two +-- | Every Anthropic model in the generated catalog, with the three -- request-shaping facts its compat record states. Written out by hand -- rather than read off the record, so a catalog refresh that changes a -- generation's wire shape fails a row here instead of quietly agreeing -- with itself. The last column is --- 'Baikai.Compat.supportsSamplingParameters'. +-- 'Baikai.Compat.supportsForcedToolChoice'. -- -- @anthropicModelsCoverCatalogTest@ ties the table to @allModels@, so a -- newly curated model cannot arrive unpinned. -anthropicModels :: [(String, Model, AnthropicThinkingStyle, Bool)] +anthropicModels :: [(String, Model, AnthropicThinkingStyle, Bool, Bool, Bool)] anthropicModels = - [ ("claude-fable-5", anthropic_claude_fable_5, AnthropicThinkingAdaptive, False), - ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget, True), - ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget, True), - ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive, True), - ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive, False), - ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive, False), - ("claude-opus-5", anthropic_claude_opus_5, AnthropicThinkingAdaptive, False), - ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget, True), - ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingAdaptive, True), - ("claude-sonnet-5", anthropic_claude_sonnet_5, AnthropicThinkingAdaptive, False) + [ ("claude-fable-5", anthropic_claude_fable_5, AnthropicThinkingAdaptive, False, True, False), + ("claude-fable-5-1", anthropic_claude_fable_5_1, AnthropicThinkingAdaptive, False, False, False), + ("claude-haiku-4-5", anthropic_claude_haiku_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-opus-4-5", anthropic_claude_opus_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-opus-4-6", anthropic_claude_opus_4_6, AnthropicThinkingAdaptive, True, True, False), + ("claude-opus-4-7", anthropic_claude_opus_4_7, AnthropicThinkingAdaptive, False, True, False), + ("claude-opus-4-8", anthropic_claude_opus_4_8, AnthropicThinkingAdaptive, False, True, True), + ("claude-opus-5", anthropic_claude_opus_5, AnthropicThinkingAdaptive, False, True, True), + ("claude-sonnet-4-5", anthropic_claude_sonnet_4_5, AnthropicThinkingBudget, True, True, False), + ("claude-sonnet-4-6", anthropic_claude_sonnet_4_6, AnthropicThinkingAdaptive, True, True, False), + ("claude-sonnet-5", anthropic_claude_sonnet_5, AnthropicThinkingAdaptive, False, True, False) ] thinkingLevels :: [(String, ThinkingLevel)] @@ -88,7 +98,7 @@ req <- requestFor model (emptyOptions & #thinking .~ Just level) req ^. #max_tokens <= model ^. #maxOutputTokens @?= True - | (name, model, _, _) <- anthropicModels, + | (name, model, _, _, _, _) <- anthropicModels, (levelName, level) <- thinkingLevels ] @@ -105,11 +115,11 @@ "max_tokens leaves visible-output room beyond budget" (req ^. #max_tokens > expectedBudget) AnthropicThinkingAdaptive -> do - requestThinking req @?= Just Messages.ThinkingAdaptive + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) req ^. #max_tokens @?= model ^. #maxOutputTokens (req ^. #output_config >>= Messages.effort) @?= adaptiveEffort level - | (name, model, style, _) <- anthropicModels, + | (name, model, style, _, _, _) <- anthropicModels, (levelName, level) <- thinkingLevels ] @@ -226,7 +236,7 @@ requestFor anthropic_claude_opus_4_7 (emptyOptions & #thinking .~ Just level) - requestThinking req @?= Just Messages.ThinkingAdaptive + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) (req ^. #output_config >>= Messages.effort) @?= Just expected | (name, level, expected) <- [ ("xhigh is preserved", ThinkingXHigh, "xhigh"), @@ -300,7 +310,7 @@ .~ Just (JsonSchema (jsonSchemaFormat "answer" schema) {strict = True}) expected = (Messages.jsonSchemaConfig schema) {Messages.effort = Just "medium"} req <- requestFor anthropic_claude_opus_4_6 opts - requestThinking req @?= Just Messages.ThinkingAdaptive + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) req ^. #output_config @?= Just expected explicitCompatOverridesDefaultTest :: TestTree @@ -315,7 +325,7 @@ & #compat .~ CompatAnthropicMessages compat opts = emptyOptions & #thinking .~ Just ThinkingLow req <- requestFor model opts - requestThinking req @?= Just Messages.ThinkingAdaptive + requestThinking req @?= Just (Messages.ThinkingAdaptiveWithDisplay Messages.ThinkingSummarized) (req ^. #output_config >>= Messages.effort) @?= Just "low" requestFor :: Model -> Options -> IO Messages.CreateMessage @@ -349,7 +359,7 @@ anthropicModelsCoverCatalogTest :: TestTree anthropicModelsCoverCatalogTest = testCase "anthropicModels covers exactly the catalog's Anthropic ids" $ - List.sort [m ^. #modelId | (_, m, _, _) <- anthropicModels] + List.sort [m ^. #modelId | (_, m, _, _, _, _) <- anthropicModels] @?= List.sort [m ^. #modelId | m <- allModels, m ^. #api == AnthropicMessages] -- | Sampling parameters against the catalog's own record. @@ -376,7 +386,7 @@ Messages.top_p req @?= Nothing filter isSamplingAdjustment (t ^. #adjustments) @?= [SamplingDroppedUnsupportedModel ["temperature", "top_p"]] - | (name, model, _, supported) <- anthropicModels, + | (name, model, _, supported, _, _) <- anthropicModels, let verb = if supported then "forwards temperature and top_p" else "drops temperature and top_p and records it" ] <> [ testCase "sampling is dropped and recorded even when no thinking level is set" $ do @@ -481,7 +491,7 @@ msgs <- mappedMessages [ assistantBlocks - [AssistantThinking ThinkingContent {thinking = "hmm", signature = Nothing, redacted = False}], + [AssistantThinking ThinkingContent {thinking = "hmm", signature = Nothing, redacted = False, replayState = Nothing}], user "next" ] Vector.length msgs @?= 1, @@ -681,13 +691,15 @@ ThinkingContent { thinking = "because therefore", signature = Just "sig-final", - redacted = False + redacted = False, + replayState = Nothing } expectedRedacted = ThinkingContent { thinking = "ENCRYPTED==", signature = Nothing, - redacted = True + redacted = True, + replayState = Nothing } thinkingEnds events @?= [expectedSigned, expectedRedacted] @@ -734,7 +746,8 @@ ThinkingContent { thinking = "draft", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "visible") ],