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-openai.cabal b/baikai-openai.cabal --- a/baikai-openai.cabal +++ b/baikai-openai.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai-openai -version: 0.6.0.0 +version: 0.7.0.0 synopsis: OpenAI providers for the baikai abstraction description: OpenAI-compatible backends for baikai: Chat Completions over SSE against OpenAI and @@ -57,6 +57,11 @@ Baikai.Provider.OpenAI.Internal.ErrorClass Baikai.Provider.OpenAI.Internal.Request Baikai.Provider.OpenAI.Internal.Stream + Baikai.Provider.OpenAI.Internal.Usage + Baikai.Provider.OpenAI.Responses + Baikai.Provider.OpenAI.Responses.Assembler + Baikai.Provider.OpenAI.Responses.Request + Baikai.Provider.OpenAI.Responses.Stream Baikai.Provider.OpenAI.Shape Baikai.Provider.OpenAI.Sse Baikai.Provider.OpenAI.Transport @@ -65,7 +70,7 @@ autogen-modules: Paths_baikai_openai build-depends: , aeson ^>=2.2 - , baikai ^>=0.6.0 + , baikai ^>=0.7.0 , base >=4.20 && <5 , base64-bytestring ^>=1.2 , bytestring ^>=0.12 @@ -73,7 +78,7 @@ , containers ^>=0.7 , 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 , openai ^>=2.5 @@ -92,21 +97,28 @@ hs-source-dirs: test main-is: Main.hs other-modules: + BillingSpec CliEvidenceSpec Contract + EndpointModels ErrorClassSpec EvidenceSpec LifecycleSpec MidStreamSpec PublicSurfaceSpec ReasoningSpec + ResponsesAssemblerSpec + ResponsesEvidenceSpec + ResponsesSpec + ResponsesStreamSpec + ResponsesTransportSpec ShapeSpec SseSpec TransportSpec build-depends: , aeson - , baikai ^>=0.6.0 + , baikai ^>=0.7.0 , baikai-openai , base >=4.20 && <5 , bytestring diff --git a/src/Baikai/Provider/OpenAI/Agent.hs b/src/Baikai/Provider/OpenAI/Agent.hs --- a/src/Baikai/Provider/OpenAI/Agent.hs +++ b/src/Baikai/Provider/OpenAI/Agent.hs @@ -138,6 +138,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just "model_reasoning_effort", + displayText = Nothing, adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl] } diff --git a/src/Baikai/Provider/OpenAI/Cli.hs b/src/Baikai/Provider/OpenAI/Cli.hs --- a/src/Baikai/Provider/OpenAI/Cli.hs +++ b/src/Baikai/Provider/OpenAI/Cli.hs @@ -188,6 +188,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just "model_reasoning_effort", + displayText = Nothing, adjustments = [Ev.EffortClamped lvl wire | wire /= renderThinkingLevel lvl] } diff --git a/src/Baikai/Provider/OpenAI/Internal/Request.hs b/src/Baikai/Provider/OpenAI/Internal/Request.hs --- a/src/Baikai/Provider/OpenAI/Internal/Request.hs +++ b/src/Baikai/Provider/OpenAI/Internal/Request.hs @@ -19,14 +19,17 @@ import Baikai.Message qualified as Msg import Baikai.Model (Model, openaiCompletionsCompatFor) import Baikai.Options (Options (..)) +import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort) import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) import Baikai.ThinkingLevel (ThinkingLevel (..)) import Baikai.Tool qualified as Tool import Control.Lens ((^.)) +import Control.Monad (unless) import Data.Aeson qualified as Aeson import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Lazy qualified as BSL import Data.Generics.Labels () +import Data.List (nub, sort) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as Text @@ -46,6 +49,32 @@ mapRequest :: Model -> Context -> Options -> Either Text Chat.CreateChatCompletion mapRequest m ctx opts = do + let capability = openaiCompletionsCompatFor m + forced = case opts ^. #toolChoice of + Just Tool.ToolChoiceRequired -> True + Just (Tool.ToolChoiceSpecific _) -> True + _ -> False + unless (capability.supportsToolCalls || (Vector.null (ctx ^. #tools) && not forced)) $ + Left "This model does not support tools on OpenAI Chat Completions; use OpenAI Responses for tool calling" + case capability.supportedReasoningEfforts of + Just levels + | null levels || levels /= sort (nub levels) -> + Left "supportedReasoningEfforts must be nonempty, unique and ordered" + _ -> 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) body <- traverse mapMessage (Vector.toList (ctx ^. #messages)) let compat = openaiCompletionsCompatFor m prefix = case ctx ^. #systemPrompt of @@ -79,8 +108,8 @@ { Chat.messages = Vector.fromList (prefix <> body), Chat.model = OpenAIModels.Model (m ^. #modelId), Chat.max_completion_tokens = maxTokensField, - Chat.temperature = opts ^. #temperature, - Chat.top_p = opts ^. #topP, + Chat.temperature = if compat.supportsSamplingParameters then opts ^. #temperature else Nothing, + Chat.top_p = if compat.supportsSamplingParameters then opts ^. #topP else Nothing, Chat.stop = nonEmptyStops (opts ^. #stopSequences), Chat.seed = fmap fromIntegral (opts ^. #seed), Chat.frequency_penalty = opts ^. #frequencyPenalty, @@ -139,7 +168,7 @@ Maybe Chat.ReasoningEffort applyThinkingFormat _ Nothing = Nothing applyThinkingFormat compat (Just lvl) = case thinkingFormat compat of - ThinkingFormatOpenAI -> Just (toReasoningEffort lvl) + ThinkingFormatOpenAI -> Just (toReasoningEffort (resolveSupportedEffort compat.supportedReasoningEfforts lvl)) _ -> Nothing toReasoningEffort :: ThinkingLevel -> Chat.ReasoningEffort diff --git a/src/Baikai/Provider/OpenAI/Internal/Stream.hs b/src/Baikai/Provider/OpenAI/Internal/Stream.hs --- a/src/Baikai/Provider/OpenAI/Internal/Stream.hs +++ b/src/Baikai/Provider/OpenAI/Internal/Stream.hs @@ -45,7 +45,6 @@ import Baikai.Compat (OpenAICompletionsCompat (requiresThinkingAsText)) import Baikai.Content qualified as Content import Baikai.Context (Context (..)) -import Baikai.Cost (zeroCost) import Baikai.Cost.Pricing qualified as Pricing import Baikai.Error (BaikaiError, contentFiltered, invalidRequest, providerError) import Baikai.Evidence qualified as Ev @@ -62,6 +61,7 @@ ) import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyErrorFrame, classifyException) import Baikai.Provider.OpenAI.Internal.Request (mapRequest) +import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing import Baikai.Provider.OpenAI.Shape (describeThinkingShape, streamRequestBody) import Baikai.Provider.OpenAI.Sse (ResponseMetadata, capturedHeaderNames, openaiSseStreamValueWithHeaders) import Baikai.Provider.OpenAI.Transport qualified as Transport @@ -95,6 +95,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map 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 @@ -104,7 +105,6 @@ import Data.Version (showVersion) import GHC.Generics (Generic) import Network.HTTP.Types.Header (RequestHeaders) -import Numeric.Natural (Natural) import Paths_baikai_openai qualified as Paths import Servant.Client qualified as Client import Streamly.Data.Stream (Stream) @@ -262,6 +262,7 @@ model :: !(Maybe Text), -- | The host's identifier for this response, from the chunk's -- top-level @id@ field. + serviceTier :: !(Maybe Text), responseId :: !(Maybe Text) } deriving stock (Show, Generic) @@ -274,12 +275,7 @@ } deriving stock (Show, Generic) -data RawUsage = RawUsage - { inputTokens :: !Natural, - outputTokens :: !Natural, - cacheReadTokens :: !Natural, - reasoningTokens :: !(Maybe Natural) - } +newtype RawUsage = RawUsage Aeson.Object deriving stock (Show, Generic) -- | Worker body: drive the transport, forwarding decoded chunks onto the @@ -378,6 +374,7 @@ -- compatible hosts vary, and a host that omits either of these -- has reported nothing, which is not a decode failure. model = lookupText "model" o, + serviceTier = lookupText "service_tier" o, responseId = lookupText "id" o } @@ -421,33 +418,7 @@ _ -> Nothing parseUsage :: Aeson.Object -> Maybe RawUsage -parseUsage o = - case Aeson.parseEither pUsage o of - Right u -> Just u - Left _ -> Nothing - where - pUsage obj = do - i <- obj .:? "prompt_tokens" - out <- obj .:? "completion_tokens" - ptd <- obj .:? "prompt_tokens_details" - ctd <- obj .:? "completion_tokens_details" - let cached = case ptd of - Just (Aeson.Object p) -> case lookupField "cached_tokens" p of - Just (Aeson.Number n) -> truncate n - _ -> 0 :: Natural - _ -> 0 - reasoning = case ctd of - Just (Aeson.Object c) -> case lookupField "reasoning_tokens" c of - Just (Aeson.Number n) -> Just (truncate n) - _ -> Nothing - _ -> Nothing - pure - RawUsage - { inputTokens = fromMaybe 0 i, - outputTokens = fromMaybe 0 out, - cacheReadTokens = cached, - reasoningTokens = reasoning - } +parseUsage o = RawUsage o <$ Billing.readUsage Billing.ChatUsage (Aeson.Object o) lookupField :: Text -> Aeson.Object -> Maybe Value lookupField k = KeyMap.lookup (AesonKey.fromText k) @@ -860,6 +831,8 @@ -- 'usage' still holding the zeroes it was initialised with. Without -- this a failed call would claim the host reported consuming -- nothing. + serviceTiers :: !(Set.Set Text), + usageSnapshot :: !(Maybe Value), usageReported :: !Bool } deriving stock (Generic) @@ -891,6 +864,8 @@ observedModel = Ev.Unobserved, responseId = Nothing, httpStatus = Nothing, + serviceTiers = Set.empty, + usageSnapshot = Nothing, usageReported = False } @@ -940,6 +915,7 @@ observeChunk :: RawChunk -> Assembler -> Assembler observeChunk raw ass = ass + & #serviceTiers %~ maybe id Set.insert (raw ^. #serviceTier) & #observedModel .~ firstObserved (ass ^. #observedModel) (raw ^. #model) & #responseId .~ ((ass ^. #responseId) <|> (raw ^. #responseId)) @@ -1084,41 +1060,20 @@ else events0 <> [ToolCallDelta DeltaPayload {contentIndex = baikaiIdx, delta = argsDelta}] in (events1, ass3) --- | Normalize OpenAI's inclusive usage counters into baikai's --- disjoint 'Usage.Usage' convention. OpenAI's @prompt_tokens@ --- includes @prompt_tokens_details.cached_tokens@, so the cached count --- is subtracted out of 'Usage.inputTokens'. The subtraction is clamped --- at zero because 'Natural' subtraction throws on underflow and because --- OpenAI-compatible hosts can report inconsistent counters. --- 'Usage.totalTokens' is recomputed from the normalized parts; --- 'Usage.reasoningTokens' is a subset of 'Usage.outputTokens' and is --- not added to the total. OpenAI does not bill cache writes, so --- 'Usage.cacheWriteTokens' is always zero. +-- | Shared Chat/Responses normalization preserves reported writes and marks +-- missing or inconsistent billing categories explicitly. rawUsageToUsage :: RawUsage -> Usage.Usage -rawUsageToUsage u = - let prompt = u ^. #inputTokens - cached = u ^. #cacheReadTokens - out = u ^. #outputTokens - nonCached = if cached >= prompt then 0 else prompt - cached - in Usage.Usage - { Usage.inputTokens = nonCached, - Usage.outputTokens = out, - Usage.cacheReadTokens = cached, - Usage.cacheWriteTokens = 0, - Usage.reasoningTokens = u ^. #reasoningTokens, - Usage.totalTokens = nonCached + out + cached, - Usage.cost = zeroCost - } +rawUsageToUsage (RawUsage o) = fromMaybe Billing.unreportedUsage (Billing.readUsage Billing.ChatUsage (Aeson.Object o)) applyUsage :: Maybe RawUsage -> Assembler -> Assembler applyUsage Nothing ass = ass -applyUsage (Just u) ass = - ass - & #usage .~ rawUsageToUsage u - -- A host that sent a usage block reported its counts, even if every - -- one of them is zero. That is what distinguishes a reported zero - -- from silence in the evidence record. - & #usageReported .~ True +applyUsage (Just (RawUsage raw)) ass = + let snapshot = Billing.mergeUsage (ass ^. #usageSnapshot) (Just (Aeson.Object raw)) + normalized = fromMaybe Billing.unreportedUsage (snapshot >>= Billing.readUsage Billing.ChatUsage) + in ass + & #usage .~ normalized + & #usageSnapshot .~ snapshot + & #usageReported .~ True -- | Close all open content blocks and stash the resolved stop -- reason; defer 'EventDone' to channel close. @@ -1168,7 +1123,8 @@ Content.ThinkingContent { Content.thinking = body, Content.signature = Nothing, - Content.redacted = False + Content.redacted = False, + Content.replayState = Nothing } block = Content.AssistantThinking thinkingContent in ( [ThinkingEnd ThinkingEndPayload {contentIndex = i, content = thinkingContent}], @@ -1270,8 +1226,8 @@ -- cannot report different numbers for the same call. finalUsage :: Assembler -> Usage.Usage finalUsage ass = - let usageBare = ass ^. #usage - in usageBare & #cost .~ Pricing.computeCost (ass ^. #model) usageBare + let usageBare = Usage.observeBilling (map Usage.BillingServiceTier (Set.toList (ass ^. #serviceTiers))) (if ass ^. #usageReported then ass ^. #usage else Billing.unreportedUsage) + in usageBare & #cost .~ Pricing.computeCostForService Nothing Nothing (ass ^. #model) usageBare finalMessage :: Assembler -> UTCTime -> Maybe Text -> Stop.StopReason -> Msg.Message diff --git a/src/Baikai/Provider/OpenAI/Internal/Usage.hs b/src/Baikai/Provider/OpenAI/Internal/Usage.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Internal/Usage.hs @@ -0,0 +1,55 @@ +-- | Shared Chat/Responses usage extraction. Input totals are inclusive of +-- cache reads and writes; missing categories stay explicit after normalization. +-- Wire semantics: https://developers.openai.com/api/docs/guides/prompt-caching +-- Chat's prompt_tokens_details.cache_write_tokens is documented at +-- https://developers.openai.com/api/reference/resources/chat/subresources/completions/methods/create +-- (verified 2026-09-07). +module Baikai.Provider.OpenAI.Internal.Usage (UsageEndpoint (..), readUsage, unreportedUsage, mergeUsage) where + +import Baikai.Usage qualified as U +import Baikai.Usage.Normalize qualified as N +import Data.Aeson (Value (..)) +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.Maybe (isJust, isNothing) +import Numeric.Natural (Natural) + +data UsageEndpoint = ChatUsage | ResponsesUsage + +unreportedUsage :: U.Usage +unreportedUsage = N.normalizeUsage N.InclusiveInput (N.ReportedUsage Nothing Nothing Nothing Nothing Nothing) + +readUsage :: UsageEndpoint -> Value -> Maybe U.Usage +readUsage endpoint value = + let (inputKey, outputKey, inputDetails, outputDetails) = case endpoint of + ChatUsage -> ("prompt_tokens", "completion_tokens", "prompt_tokens_details", "completion_tokens_details") + ResponsesUsage -> ("input_tokens", "output_tokens", "input_tokens_details", "output_tokens_details") + input = field inputKey value + output = field outputKey value + cached = field inputDetails value >>= field "cached_tokens" + writes = field inputDetails value >>= field "cache_write_tokens" + reasoning = field outputDetails value >>= field "reasoning_tokens" + raw = [input, output, cached, writes, reasoning] + count v = v >>= natural + normalized = N.normalizeUsage N.InclusiveInput (N.ReportedUsage (count input) (count output) (count cached) (count writes) (count reasoning)) + malformed = any (\v -> isJust v && isNothing (count v)) raw + mark facts = facts {U.inconsistent = U.inconsistent facts || malformed} + in if any isJust raw then Just normalized {U.availability = mark <$> U.availability normalized} else Nothing + where + field :: Key -> Value -> Maybe Value + field key (Object o) = case KM.lookup key o of Just Null -> Nothing; found -> found + field _ _ = Nothing + natural :: Value -> Maybe Natural + natural (Number n) | n >= 0, fromInteger (floor n) == n = Just (fromInteger (floor n)) + natural _ = Nothing + +-- | Usage events are cumulative snapshots, never increments. Omitted fields +-- preserve earlier observations; explicit zero replaces the previous value. +mergeUsage :: Maybe Value -> Maybe Value -> Maybe Value +mergeUsage old Nothing = old +mergeUsage Nothing new = new +mergeUsage (Just old) (Just new) = Just (merge new old) + where + merge Null previous = previous + merge (Object newer) (Object previous) = Object (KM.unionWith merge newer previous) + merge newer _ = newer diff --git a/src/Baikai/Provider/OpenAI/Responses.hs b/src/Baikai/Provider/OpenAI/Responses.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses.hs @@ -0,0 +1,35 @@ +-- | Native OpenAI Responses provider. Register explicitly alongside the +-- Chat Completions provider for a registry supporting both protocols. +module Baikai.Provider.OpenAI.Responses + ( register, + openaiResponsesProvider, + openaiResponsesStream, + ) +where + +import Baikai.Api (Api (OpenAIResponses)) +import Baikai.Context (Context) +import Baikai.Evidence qualified as Ev +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Provider (ApiProvider, apiProvider) +import Baikai.Provider.OpenAI.Responses.Request (describeThinking) +import Baikai.Provider.OpenAI.Responses.Stream (liveResponsesDriver, openaiResponsesStreamWith) +import Baikai.Provider.Registry (registerApiProvider) +import Baikai.Stream.Event (AssistantMessageEvent) +import Control.Lens ((&), (.~)) +import Data.Generics.Labels () +import Streamly.Data.Stream (Stream) + +register :: IO () +register = registerApiProvider openaiResponsesProvider + +-- | Completion folds the same event stream, as for other API providers. +openaiResponsesProvider :: ApiProvider +openaiResponsesProvider = + apiProvider OpenAIResponses openaiResponsesStream + & #describeThinking .~ describeThinking + & #strengthCeiling .~ Ev.declaredStrength OpenAIResponses + +openaiResponsesStream :: Model -> Context -> Options -> Stream IO AssistantMessageEvent +openaiResponsesStream = openaiResponsesStreamWith liveResponsesDriver diff --git a/src/Baikai/Provider/OpenAI/Responses/Assembler.hs b/src/Baikai/Provider/OpenAI/Responses/Assembler.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Assembler.hs @@ -0,0 +1,314 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | Internal Responses item assembly; no stability guarantee. The wire +-- schema is wider than the released SDK's streaming sum (see +-- mori://MercuryTechnologies/openai/packages/openai), so inspect JSON at +-- this boundary and preserve reasoning snapshots without re-encoding. +module Baikai.Provider.OpenAI.Responses.Assembler + ( Assembler, + emptyAssembler, + advance, + closePartial, + assembledContent, + observedResponse, + terminalReason, + ) +where + +import Baikai.Api (Api (OpenAIResponses)) +import Baikai.Content qualified as C +import Baikai.Provider.OpenAI.Responses.Request (validateReplayItems) +import Baikai.StopReason (StopReason (..)) +import Baikai.Stream.Event qualified as E +import Control.Monad (foldM, unless) +import Data.Aeson (Value (..)) +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.IntMap.Strict qualified as IM +import Data.IntSet qualified as IS +import Data.Text (Text) +import Data.Text qualified as T +import Data.Vector qualified as V + +-- No Show: items can contain opaque encrypted continuation. +data Item = Item + { kind :: !Text, + identity :: !Text, + callId :: !Text, + functionName :: !Text, + parts :: !(IM.IntMap Text), + endedParts :: !IS.IntSet, + complete :: !Bool, + snapshot :: !(Maybe Value) + } + +data Assembler = Assembler + { scopeModel :: !Text, + items :: !(IM.IntMap Item), + cursor :: !Int, + opened :: !Bool, + emitted :: !Text, + assembledContent :: !(V.Vector C.AssistantContent), + -- | Actual provider response object, including raw usage availability. + observedResponse :: !(Maybe Value), + terminalReason :: !(Maybe StopReason) + } + +emptyAssembler :: Text -> Assembler +emptyAssembler m = Assembler m IM.empty 0 False "" V.empty Nothing Nothing + +-- | Consume one JSON event. Errors contain only schema diagnostics, never +-- raw response bodies. The caller closes partial blocks and emits the +-- terminal error on Left. Lifecycle terminal events are emitted by the +-- owning stream after attaching usage and evidence. +advance :: Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +advance frame a + | Just _ <- a.terminalReason = Right (a, []) + | otherwise = do + typ <- str "type" frame + case typ of + "response.created" -> observe frame a + "response.in_progress" -> observe frame a + "response.queued" -> observe frame a + "response.output_item.added" -> do + n <- index "output_index" frame + raw <- field "item" frame + item <- fromSnapshot False raw + unless (IM.notMember n a.items && n >= a.cursor) (Left "Responses repeated output item") + unless (freshIdentity item (IM.elems a.items)) (Left "Responses duplicate item or function call ID") + pump a {items = IM.insert n item a.items} + "response.output_item.done" -> do + n <- index "output_index" frame + raw <- field "item" frame + updated <- mergeSnapshot n True raw a + pump updated + "response.output_text.delta" -> delta "message" "content_index" frame a + "response.refusal.delta" -> delta "message" "content_index" frame a + "response.reasoning_summary_text.delta" -> delta "reasoning" "summary_index" frame a + "response.function_call_arguments.delta" -> delta "function_call" "" frame a + "response.output_text.done" -> donePart "message" "content_index" "text" frame a + "response.refusal.done" -> donePart "message" "content_index" "refusal" frame a + "response.reasoning_summary_text.done" -> donePart "reasoning" "summary_index" "text" frame a + "response.function_call_arguments.done" -> donePart "function_call" "" "arguments" frame a + "response.content_part.added" -> partEvent False "message" "content_index" frame a + "response.content_part.done" -> partEvent True "message" "content_index" frame a + "response.reasoning_summary_part.added" -> partEvent False "reasoning" "summary_index" frame a + "response.reasoning_summary_part.done" -> partEvent True "reasoning" "summary_index" frame a + "response.completed" -> terminal Stop frame a + "response.incomplete" -> do + response <- field "response" frame + details <- field "incomplete_details" response + reason <- str "reason" details + unless (reason == "max_output_tokens") (Left "Responses terminated incomplete for a reason other than max_output_tokens") + terminal Length frame a + "response.failed" -> Left "Responses response.failed" + "error" -> Left "Responses error event" + -- Annotations and reasoning details do not change the public text + -- or continuation. New output kinds are rejected at item creation. + _ -> Right (a, []) + +observe :: Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +observe f a = do + r <- field "response" f + pure (a {observedResponse = Just r}, []) + +terminal :: StopReason -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +terminal reason f a = do + r <- field "response" f + output <- array "output" r + mapM_ + ( \raw -> case raw of + Object o | reason == Stop && KM.lookup "type" o == Just (String "reasoning") -> validateReplayItems (V.singleton raw) + _ -> pure () + ) + output + updated <- foldM (\s (n, raw) -> mergeSnapshot n True raw s) a (zip [0 ..] (V.toList output)) + unless (IM.size updated.items == V.length output) (Left "Responses terminal output omitted an existing item") + (drained, events) <- pump updated {observedResponse = Just r} + unless (drained.cursor == IM.size drained.items) (Left "Responses terminal output has a gap") + let hasTool = any (\case C.AssistantToolCall _ -> True; _ -> False) drained.assembledContent + stop = if reason == Stop && hasTool then ToolUse else reason + pure (drained {terminalReason = Just stop}, events) + +fromSnapshot :: Bool -> Value -> Either Text Item +fromSnapshot final raw = do + k <- str "type" raw + ident <- nonempty "id" raw + (call, name, ps) <- case k of + "message" -> do + cs <- array "content" raw + texts <- traverse partText (V.toList cs) + pure ("", "", IM.fromList (zip [0 ..] texts)) + "reasoning" -> do + cs <- array "summary" raw + texts <- traverse partText (V.toList cs) + pure ("", "", IM.fromList (zip [0 ..] texts)) + "function_call" -> do + call <- nonempty "call_id" raw + name <- nonempty "name" raw + args <- str "arguments" raw + pure (call, name, IM.singleton 0 args) + _ -> Left "Responses unsupported output item type" + pure (Item k ident call name ps (if final then IS.fromList (IM.keys ps) else IS.empty) final (if final then Just raw else Nothing)) + +freshIdentity :: Item -> [Item] -> Bool +freshIdentity new = all (\old -> old.identity /= new.identity && (new.kind /= "function_call" || old.kind /= "function_call" || old.callId /= new.callId)) + +mergeSnapshot :: Int -> Bool -> Value -> Assembler -> Either Text Assembler +mergeSnapshot n final raw a = do + new <- fromSnapshot final raw + case IM.lookup n a.items of + Nothing -> do + unless (n >= a.cursor && freshIdentity new (IM.elems a.items)) (Left "Responses duplicate item or function call ID") + pure a {items = IM.insert n new a.items} + Just old -> do + unless (old.kind == new.kind && old.identity == new.identity && old.callId == new.callId && old.functionName == new.functionName) (Left "Responses item identity changed") + unless (not old.complete || old.snapshot == Just raw) (Left "Responses completed item changed") + mapM_ (\(p, t) -> unless (maybe False (T.isPrefixOf t) (IM.lookup p new.parts)) (Left "Responses final snapshot contradicts streamed content")) (IM.toList old.parts) + pure a {items = IM.insert n new a.items} + +partText :: Value -> Either Text Text +partText p = do + k <- str "type" p + case k of + "output_text" -> str "text" p + "summary_text" -> str "text" p + "refusal" -> str "refusal" p + _ -> Left "Responses unsupported output content part" + +itemAt :: Text -> Value -> Assembler -> Either Text (Int, Item) +itemAt expected f a = do + n <- index "output_index" f + ident <- str "item_id" f + item <- maybe (Left "Responses delta before output item") Right (IM.lookup n a.items) + unless (item.kind == expected && item.identity == ident) (Left "Responses delta item identity mismatch") + pure (n, item) + +partIndex :: Key -> Value -> Either Text Int +partIndex "" _ = Right 0 +partIndex key f = index key f + +delta :: Text -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +delta k key f a = do + (n, item) <- itemAt k f a + p <- partIndex key f + txt <- str "delta" f + unless (not item.complete && not (IS.member p item.endedParts)) (Left "Responses delta after content done") + let ps = IM.insert p (IM.findWithDefault "" p item.parts <> txt) item.parts + pump a {items = IM.insert n item {parts = ps} a.items} + +donePart :: Text -> Key -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +donePart k key txtKey f a = do + txt <- str txtKey f + setPart True k key txt f a + +partEvent :: Bool -> Text -> Key -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +partEvent final k key f a = do + p <- field "part" f + txt <- partText p + setPart final k key txt f a + +setPart :: Bool -> Text -> Key -> Text -> Value -> Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +setPart final k key txt f a = do + (n, item) <- itemAt k f a + p <- partIndex key f + let old = IM.findWithDefault "" p item.parts + unless (old `T.isPrefixOf` txt && (not (item.complete || IS.member p item.endedParts) || old == txt)) (Left "Responses part snapshot contradicts streamed content") + let updated = item {parts = IM.insert p txt item.parts, endedParts = if final then IS.insert p item.endedParts else item.endedParts} + pump a {items = IM.insert n updated a.items} + +-- Only the contiguous prefix is visible: a later parallel item or content +-- part cannot overtake the one still streaming. One Baikai block per item. +visible :: Item -> Text +visible item = go 0 + where + go n = case IM.lookup n item.parts of + Nothing -> "" + Just txt -> txt <> if item.complete || IS.member n item.endedParts then go (n + 1) else "" + +pump :: Assembler -> Either Text (Assembler, [E.AssistantMessageEvent]) +pump a = case IM.lookup a.cursor a.items of + Nothing -> Right (a, []) + Just item -> do + let txt = visible item + n = V.length a.assembledContent + unless (a.emitted `T.isPrefixOf` txt) (Left "Responses snapshot changed emitted content") + let suffix = T.drop (T.length a.emitted) txt + start = if a.opened then [] else [startEvent item.kind n] + deltas = if T.null suffix then [] else [deltaEvent item.kind n suffix] + openedState = a {opened = True, emitted = txt} + if item.complete + then do + let content = itemContent a.scopeModel True item + closed = openedState {cursor = a.cursor + 1, opened = False, emitted = "", assembledContent = V.snoc a.assembledContent content} + (next, events) <- pump closed + pure (next, start <> deltas <> [endEvent n content] <> events) + else pure (openedState, start <> deltas) + +-- | Close an interrupted stream, retaining every observed item. An item +-- without output_item.done keeps String arguments even when that prefix +-- happens to be parseable JSON; callers must never execute that prefix. +closePartial :: Assembler -> (Assembler, [E.AssistantMessageEvent]) +closePartial a = foldl close (a, []) [(n, i) | (n, i) <- IM.toAscList a.items, n >= a.cursor] + where + close (s, events) (outputIndex, item) = + let n = V.length s.assembledContent + txt = T.concat (IM.elems item.parts) + suffix = if s.emitted `T.isPrefixOf` txt then T.drop (T.length s.emitted) txt else "" + content = itemContent s.scopeModel item.complete item + starts = if s.opened then [] else [startEvent item.kind n] + deltas = if T.null suffix then [] else [deltaEvent item.kind n suffix] + in (s {cursor = outputIndex + 1, opened = False, emitted = "", assembledContent = V.snoc s.assembledContent content}, events <> starts <> deltas <> [endEvent n content]) + +itemContent :: Text -> Bool -> Item -> C.AssistantContent +itemContent m final item = + let txt = T.concat (IM.elems item.parts) + in case item.kind of + "reasoning" -> C.AssistantThinking (C.ThinkingContent txt Nothing False (fmap (C.ThinkingReplay OpenAIResponses m . V.singleton) item.snapshot)) + "function_call" -> C.AssistantToolCall (C.ToolCall item.callId item.functionName (if final && completedStatus item.snapshot then C.toolArgumentsFromText txt else String txt)) + _ -> C.AssistantText (C.TextContent txt) + +completedStatus :: Maybe Value -> Bool +completedStatus (Just (Object o)) = case KM.lookup "status" o of + Nothing -> True -- output_item.done itself supplies completion. + Just (String "completed") -> True + _ -> False +completedStatus _ = False + +startEvent :: Text -> Int -> E.AssistantMessageEvent +startEvent "reasoning" n = E.ThinkingStart (E.IndexPayload n) +startEvent "function_call" n = E.ToolCallStart (E.IndexPayload n) +startEvent _ n = E.TextStart (E.IndexPayload n) + +deltaEvent :: Text -> Int -> Text -> E.AssistantMessageEvent +deltaEvent "reasoning" n txt = E.ThinkingDelta (E.DeltaPayload n txt) +deltaEvent "function_call" n txt = E.ToolCallDelta (E.DeltaPayload n txt) +deltaEvent _ n txt = E.TextDelta (E.DeltaPayload n txt) + +endEvent :: Int -> C.AssistantContent -> E.AssistantMessageEvent +endEvent n (C.AssistantThinking c) = E.ThinkingEnd (E.ThinkingEndPayload n c) +endEvent n (C.AssistantToolCall c) = E.ToolCallEnd (E.ToolCallEndPayload n c) +endEvent n (C.AssistantText c) = E.TextEnd (E.BlockEndPayload n c.text) + +field :: Key -> Value -> Either Text Value +field k (Object o) = maybe (Left "Responses missing required event field") Right (KM.lookup k o) +field _ _ = Left "Responses event field must be an object" + +str :: Key -> Value -> Either Text Text +str k v = field k v >>= \case String t -> Right t; _ -> Left "Responses event field must be text" + +nonempty :: Key -> Value -> Either Text Text +nonempty k v = do + t <- str k v + unless (not (T.null t)) (Left "Responses item identity must be nonempty") + pure t + +array :: Key -> Value -> Either Text (V.Vector Value) +array k v = field k v >>= \case Array xs -> Right xs; _ -> Left "Responses event field must be an array" + +index :: Key -> Value -> Either Text Int +index k v = + field k v >>= \case + Number n | n >= 0, n <= fromIntegral (maxBound :: Int), fromInteger (floor n) == n -> Right (floor n) + _ -> Left "Responses event index must be a nonnegative integer" diff --git a/src/Baikai/Provider/OpenAI/Responses/Request.hs b/src/Baikai/Provider/OpenAI/Responses/Request.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Request.hs @@ -0,0 +1,228 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | Internal Responses request mapping; no stability guarantee. +-- The released SDK (mori://MercuryTechnologies/openai/packages/openai, +-- 2.5.4) supplies the ordinary request/tool types. Local JSON below covers +-- its missing assistant input role, json_object format, current +-- effort vocabulary, cache options, and lossless opaque replay items. +module Baikai.Provider.OpenAI.Responses.Request + ( PreparedRequest (..), + mapRequest, + describeThinking, + validateReplay, + validateReplayItems, + ) +where + +import Baikai.Api (Api (..), normaliseApi) +import Baikai.CacheRetention (CacheRetention (..)) +import Baikai.Compat (OpenAIResponsesCompat (..)) +import Baikai.Content qualified as C +import Baikai.Context (Context (..)) +import Baikai.Evidence qualified as E +import Baikai.Message qualified as M +import Baikai.Model (Model, api, maxOutputTokens, modelId, openaiResponsesCompatFor, reasoning) +import Baikai.Options (Options (..)) +import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort) +import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) +import Baikai.ThinkingLevel (renderThinkingLevel) +import Baikai.Tool qualified as T +import Control.Monad (unless) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Lazy qualified as LBS +import Data.List (nub, sort) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding qualified as Text +import Data.Vector qualified as V +import GHC.Generics (Generic) +import OpenAI.V1.Models qualified as SDK +import OpenAI.V1.Responses qualified as R + +-- | The exact wire body and the description derived while shaping it. +-- No Show instance: a prepared body can contain opaque continuation. +data PreparedRequest = PreparedRequest + { requestBody :: !Value, + translation :: !E.ThinkingTranslation + } + deriving stock (Eq, Generic) + +mapRequest :: Model -> Context -> Options -> Either Text PreparedRequest +mapRequest m ctx opts = do + unless (normaliseApi m.api == OpenAIResponses) (Left "Responses requires Model.api = OpenAIResponses") + let compat = openaiResponsesCompatFor m + unsupported = [name | (name, present) <- [("stopSequences", not (null opts.stopSequences)), ("seed", isJust opts.seed), ("frequencyPenalty", isJust opts.frequencyPenalty), ("presencePenalty", isJust opts.presencePenalty)], present] + unless (null unsupported) (Left ("Responses cannot encode Options fields: " <> Text.intercalate ", " unsupported)) + case compat.supportedReasoningEfforts of + Just xs | null xs || xs /= sort (nub xs) -> Left "supportedReasoningEfforts must be nonempty, unique and ordered" + _ -> pure () + metadata <- traverse metadataText opts.metadata + unless (Map.size metadata <= 16 && all ((<= 64) . Text.length) (Map.keys metadata)) (Left "Responses metadata allows at most 16 keys of at most 64 characters") + items <- concat <$> traverse (messageItems m) (V.toList ctx.messages) + let ids = [i | Object item <- items, Just (String i) <- [KM.lookup "id" item]] + unless (length ids == length (nub ids)) (Left "Responses history contains duplicate item IDs") + choice <- toolChoiceFields ctx opts + cache <- cacheFields m opts + let (reasoning, translation) = thinkingFields m opts + cap = fromMaybe m.maxOutputTokens opts.maxTokens + base = + Aeson.toJSON + R._CreateResponse + { R.model = SDK.Model m.modelId, + R.instructions = ctx.systemPrompt, + R.store = Just False, + R.stream = Just True, + R.include = Just (V.singleton "reasoning.encrypted_content"), + R.max_output_tokens = if cap == 0 then Nothing else Just cap, + R.temperature = if compat.supportsSamplingParameters then opts.temperature else Nothing, + R.top_p = if compat.supportsSamplingParameters then opts.topP else Nothing, + R.metadata = if Map.null metadata then Nothing else Just metadata, + R.tools = if V.null ctx.tools then Nothing else Just (V.map sdkTool ctx.tools) + } + extras = [("input", Aeson.toJSON items)] <> reasoning <> choice <> cache <> formatFields opts + case base of + Object obj -> pure (PreparedRequest (Object (KM.union (KM.fromList extras) obj)) translation) + _ -> Left "Responses SDK request did not encode as an object" + where + metadataText (String t) | Text.length t <= 512 = Right t + metadataText _ = Left "Responses metadata values must be strings of at most 512 characters" + +-- | Both preflight and serialization use this same mapping. +describeThinking :: Model -> Options -> E.ThinkingTranslation +describeThinking m = snd . thinkingFields m + +thinkingFields :: Model -> Options -> ([(Aeson.Key, Value)], E.ThinkingTranslation) +thinkingFields m opts = (fields, thought {E.adjustments = thought.adjustments <> sampling}) + where + compat = openaiResponsesCompatFor m + (fields, thought) = case opts.thinking of + Nothing -> ([], E.noThinkingRequested) + Just lvl | not m.reasoning -> ([], E.ThinkingTranslation (Just lvl) E.ThinkingModeUnsupported Nothing Nothing Nothing Nothing [E.ThinkingDroppedUnsupportedModel lvl]) + Just lvl -> + let effort = renderThinkingLevel (resolveSupportedEffort compat.supportedReasoningEfforts lvl) + in ([("reasoning", object ["effort" .= effort])], E.ThinkingTranslation (Just lvl) E.ThinkingModeAdaptive (Just effort) Nothing (Just "reasoning.effort") Nothing [E.EffortClamped lvl effort | effort /= renderThinkingLevel lvl]) + dropped = [name | (name, set) <- [("temperature", isJust opts.temperature), ("top_p", isJust opts.topP)], set] + sampling = [E.SamplingDroppedUnsupportedModel dropped | not compat.supportsSamplingParameters, not (null dropped)] + +sdkTool :: T.Tool -> R.Tool +sdkTool t = + R.Tool_Function + { R.name = t.name, + R.description = Just t.description, + R.parameters = Just t.parameters, + R.strict = Just False + } + +toolChoiceFields :: Context -> Options -> Either Text [(Aeson.Key, Value)] +toolChoiceFields ctx opts = case opts.toolChoice of + Nothing -> pure [] + Just T.ToolChoiceAuto -> pure [] + Just T.ToolChoiceNone -> pure [("tool_choice", String "none")] + Just T.ToolChoiceRequired + | V.null ctx.tools -> Left "Responses required tool choice needs at least one declared tool" + | otherwise -> pure [("tool_choice", String "required")] + Just (T.ToolChoiceSpecific name) + | V.any ((== name) . T.name) ctx.tools -> pure [("tool_choice", object ["type" .= ("function" :: Text), "name" .= name])] + | otherwise -> Left "Responses named tool choice must name a declared tool" + +formatFields :: Options -> [(Aeson.Key, Value)] +formatFields opts = case opts.responseFormat of + Nothing -> [] + Just JsonObject -> [("text", object ["format" .= object ["type" .= ("json_object" :: Text)]])] + Just (JsonSchema schema) -> + [ ( "text", + object + [ "format" + .= Aeson.toJSON + R.TextFormat_JSON_Schema + { R.name = schema.name, + R.description = Nothing, + R.schema = Just schema.schema, + R.strict = Just schema.strict + } + ] + ) + ] + +cacheFields :: Model -> Options -> Either Text [(Aeson.Key, Value)] +cacheFields m opts = case opts.cacheRetention of + Nothing -> pure [] + Just CacheRetentionNone -> pure [] + Just CacheRetentionShort + | compat.supportsPromptCacheOptions -> pure [("prompt_cache_options", object ["ttl" .= ("30m" :: Text)])] + | otherwise -> pure [("prompt_cache_retention", String "in_memory")] + Just CacheRetentionLong + | compat.supportsPromptCacheOptions || not compat.supportsLongCacheRetention -> Left "This Responses model cannot honor long cache retention" + | otherwise -> pure [("prompt_cache_retention", String "24h")] + where + compat = openaiResponsesCompatFor m + +messageItems :: Model -> M.Message -> Either Text [Value] +messageItems m = \case + M.UserMessage p -> pure [object ["role" .= ("user" :: Text), "content" .= V.map userPart p.content]] + M.AssistantMessage p -> concat <$> traverse assistantItem (V.toList p.content) + M.ToolResultMessage p -> do + parts <- traverse toolResultText p.content + unless (not (Text.null p.toolCallId)) (Left "Responses tool results need a nonempty call_id") + let output = (if p.isError then "[error] " else "") <> Text.concat (V.toList parts) + pure [Aeson.toJSON R.Item_Input_Function_Call_Output {R.id = Nothing, R.call_id = p.toolCallId, R.output = output, R.status = Nothing}] + where + assistantItem = \case + C.AssistantText t -> pure [object ["role" .= ("assistant" :: Text), "content" .= t.text]] + C.AssistantToolCall tc -> do + unless (not (Text.null tc.id_) && not (Text.null tc.name)) (Left "Responses tool calls need a nonempty call_id and name") + unless (not (C.isCutOffToolCall tc)) (Left "Responses cannot replay an incomplete function call") + pure [Aeson.toJSON R.Item_Input_Function_Call {R.id = Nothing, R.call_id = tc.id_, R.name = tc.name, R.arguments = Text.decodeUtf8 (LBS.toStrict (Aeson.encode tc.arguments)), R.status = Nothing}] + C.AssistantThinking th -> do + unless (not th.redacted && th.signature == Nothing) (Left "Responses cannot replay Anthropic thinking signatures or redacted blocks") + case th.replayState of + Nothing -> Left "Responses thinking requires its original opaque replay state" + Just state -> validateReplay m state >> pure (V.toList state.replayItems) + +userPart :: C.UserContent -> Value +userPart = \case + C.UserText t -> Aeson.toJSON (R.Input_Text t.text) + C.UserImage img -> + Aeson.toJSON + R.Input_Image + { R.image_url = Just ("data:" <> img.mimeType <> ";base64," <> Text.decodeUtf8 (Base64.encode img.imageData)), + R.file_id = Nothing, + R.detail = Nothing + } + +toolResultText :: C.ToolResultContent -> Either Text Text +toolResultText = \case + C.ToolResultText t -> Right t.text + C.ToolResultImage _ -> Left "Responses adapter cannot encode ToolResultImage yet" + +-- | Validate scope and minimum reasoning-item contract without rebuilding +-- the items: preserving original fields and array order is intentional. +validateReplay :: Model -> C.ThinkingReplay -> Either Text () +validateReplay m state = do + unless (normaliseApi state.replayApi == OpenAIResponses && state.replayModel == m.modelId) (Left "Reasoning replay belongs to another API or model") + validateReplayItems state.replayItems + +-- | The same wire invariant applies to completed output and next input. +validateReplayItems :: V.Vector Value -> Either Text () +validateReplayItems items = do + unless (not (V.null items)) (Left "Reasoning replay must contain at least one item") + mapM_ item items + where + item (Object o) + | KM.lookup "type" o == Just (String "reasoning"), + Just (String ident) <- KM.lookup "id" o, + not (Text.null ident), + Just (String encrypted) <- KM.lookup "encrypted_content" o, + not (Text.null encrypted), + Just (Array summary) <- KM.lookup "summary" o, + all summaryPart summary = + pure () + item _ = Left "Malformed Responses reasoning replay: expected reasoning type, id, encrypted_content and summary" + summaryPart (Object o) = KM.lookup "type" o == Just (String "summary_text") && case KM.lookup "text" o of Just (String _) -> True; _ -> False + summaryPart _ = False diff --git a/src/Baikai/Provider/OpenAI/Responses/Stream.hs b/src/Baikai/Provider/OpenAI/Responses/Stream.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/OpenAI/Responses/Stream.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} + +-- | Internal Responses transport integration; no stability guarantee. +module Baikai.Provider.OpenAI.Responses.Stream + ( openaiResponsesStreamWith, + liveResponsesDriver, + ) +where + +import Baikai.Content qualified as C +import Baikai.Context (Context) +import Baikai.Cost.Pricing qualified as Pricing +import Baikai.Error (BaikaiError, invalidRequest, providerError) +import Baikai.Evidence qualified as Ev +import Baikai.Evidence.Build qualified as Build +import Baikai.Message qualified as M +import Baikai.Model (Model) +import Baikai.Options (Options) +import Baikai.Provider.Internal.StreamWorker +import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyErrorFrame, classifyException) +import Baikai.Provider.OpenAI.Internal.Stream (SseDriver) +import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing +import Baikai.Provider.OpenAI.Responses.Assembler qualified as A +import Baikai.Provider.OpenAI.Responses.Request qualified as R +import Baikai.Provider.OpenAI.Sse (ResponseMetadata, capturedHeaderNames, responsesSseStreamValueWithHeaders) +import Baikai.Provider.OpenAI.Transport qualified as Transport +import Baikai.StopReason (StopReason (..)) +import Baikai.Stream.Event qualified as E +import Baikai.Url qualified as Url +import Baikai.Usage qualified as U +import Control.Applicative ((<|>)) +import Control.Exception (SomeAsyncException, SomeException, fromException, throwIO, try) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Key (Key) +import Data.Aeson.KeyMap qualified as KM +import Data.CaseInsensitive qualified as CI +import Data.Generics.Labels () +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import Data.Text qualified as T +import Data.Text.Encoding qualified as T +import Data.Time.Clock (UTCTime, getCurrentTime) +import Data.Vector qualified as V +import Data.Version (showVersion) +import Paths_baikai_openai qualified as Paths +import Servant.Client qualified as Client +import Streamly.Data.Stream (Stream) +import Streamly.Data.Stream qualified as Stream + +liveResponsesDriver :: SseDriver +liveResponsesDriver = responsesSseStreamValueWithHeaders + +openaiResponsesStreamWith :: SseDriver -> Model -> Context -> Options -> Stream IO E.AssistantMessageEvent +openaiResponsesStreamWith driver m ctx opts = Stream.concatEffect $ do + setup <- trySync $ do + req <- either (throwIO . invalidRequest) pure (R.mapRequest m ctx opts) + let url = resolvedUrl m + case Url.baseUrlProblem url of + Just problem -> throwIO (invalidRequest ("Model.baseUrl is not usable: " <> problem)) + Nothing -> pure () + key <- Transport.resolveKey url opts + env <- Transport.getClientEnvCached url + pure (req, env, Transport.requestHeaders key m opts) + case setup of + Left ex -> Stream.fromList <$> immediateError m opts (exceptionToError ex) + Right (req, env, headers) -> do + q <- newFrameQueue + meta <- newIORef Nothing + start <- getCurrentTime + let endpoint = T.pack (Client.showBaseUrl (Client.baseUrl env)) <> "/v1/responses" + evidence <- Build.prepareEvidenceAt endpoint m opts Ev.TransportHttpApi req.translation req.requestBody start + let worker = do + result <- + trySync $ + Transport.runWithTimeout (opts ^. #timeoutMs) $ + driver env headers req.requestBody (writeIORef meta . Just) (pushFrame q) + case result of + Left ex -> pushFrame q (Left (exceptionToError ex)) + Right (Just err) -> pushFrame q (Left err) + Right Nothing -> pure () + initial = State q meta m (A.emptyAssembler (m ^. #modelId)) Nothing [E.EventStart (E.StartPayload (message V.empty U.zeroUsage Stop Nothing start) Nothing)] False evidence + pure (withFrameWorker q worker (Stream.unfoldrM step initial)) + +data State = State + { queue :: !(FrameQueue (Either BaikaiError Value)), + metadata :: !(IORef (Maybe ResponseMetadata)), + model :: !Model, + assembler :: !A.Assembler, + observed :: !(Maybe Value), + pending :: ![E.AssistantMessageEvent], + finished :: !Bool, + evidence :: !(Maybe (UTCTime -> Ev.CallStatus -> Maybe BaikaiError -> Ev.ModelCallEvidence)) + } + +step :: State -> IO (Maybe (E.AssistantMessageEvent, State)) +step s + | e : rest <- s.pending = pure (Just (e, s {pending = rest})) + | s.finished = pure Nothing + | otherwise = do + next <- pullFrame s.queue + case next of + Nothing -> terminate (Just (providerError "Responses stream ended without a terminal response")) s + Just (Left err) -> terminate (Just err) s + Just (Right raw) -> do + let obs = mergeObservation s.observed (lookupField "response" raw) + current = s {observed = obs} + case responseError raw of + Just err -> terminate (Just err) current + Nothing -> case A.advance raw s.assembler of + Left err -> terminate (Just (providerError err)) current + Right (assembled, events) -> do + let updated = current {assembler = assembled, pending = events} + case A.terminalReason assembled of + Nothing -> step updated + Just _ -> terminate Nothing updated + +-- The terminal is conclusive for Responses: releasing the stream also +-- cancels a driver that keeps waiting after response.completed. +terminate :: Maybe BaikaiError -> State -> IO (Maybe (E.AssistantMessageEvent, State)) +terminate err s = do + now <- getCurrentTime + md <- readIORef s.metadata + let (assembled, closes) = case err of + Nothing -> (s.assembler, []) + Just _ -> A.closePartial s.assembler + reason = maybe (fromMaybe Stop (A.terminalReason assembled)) (const ErrorReason) err + usage = responseUsage s.model s.observed + payload = M.AssistantPayload (A.assembledContent assembled) usage reason (fmap (^. #message) err) (Just now) + msg = M.AssistantMessage payload + rid = s.observed >>= textField "id" + status = maybe Ev.CallSucceeded (const Ev.CallFailed) err + proof = fmap (\finish -> observe status md s.observed payload (finish now status err)) s.evidence + terminal = case err of + Nothing -> E.EventDone (E.doneTerminal proof rid reason msg) + Just be -> E.EventError (E.errorTerminal proof rid reason msg be) + step s {assembler = assembled, pending = s.pending <> closes <> [terminal], finished = True} + +message :: V.Vector C.AssistantContent -> U.Usage -> StopReason -> Maybe Text -> UTCTime -> M.Message +message content usage reason note now = M.AssistantMessage (M.AssistantPayload content usage reason note (Just now)) + +resolvedUrl :: Model -> Text +resolvedUrl m = case m ^. #baseUrl of "" -> "https://api.openai.com"; u -> u + +immediateError :: Model -> Options -> BaikaiError -> IO [E.AssistantMessageEvent] +immediateError m opts err = do + now <- getCurrentTime + let msg = message V.empty U.zeroUsage ErrorReason (Just (err ^. #message)) now + proof <- Build.minimalEvidenceAt (resolvedUrl m) m opts Ev.TransportHttpApi (R.describeThinking m opts) (Build.dispatchEnvelope m opts) now now Ev.CallFailed (Just err) + pure [E.EventStart (E.StartPayload msg Nothing), E.EventError (E.errorTerminal proof Nothing ErrorReason msg err)] + +responseError :: Value -> Maybe BaikaiError +responseError raw = case textField "type" raw of + Just "error" -> classifyErrorFrame (object ["error" .= raw]) <|> Just (providerError "Responses error event") + Just "response.failed" -> (lookupField "response" raw >>= classifyErrorFrame) <|> Just (providerError "Responses response.failed") + _ -> classifyErrorFrame raw + +mergeObservation :: Maybe Value -> Maybe Value -> Maybe Value +mergeObservation old Nothing = old +mergeObservation (Just (Object old)) (Just (Object new)) = + let merged = KM.union new old + usage = Billing.mergeUsage (KM.lookup "usage" old) (KM.lookup "usage" new) + in Just (Object (maybe merged (\u -> KM.insert "usage" u merged) usage)) +mergeObservation _ new = new + +-- Known counts and their availability travel together into payload and evidence. +responseUsage :: Model -> Maybe Value -> U.Usage +responseUsage m raw = + let normalized = U.observeBilling [U.BillingServiceTier tier | Just tier <- [raw >>= textField "service_tier"]] (fromMaybe Billing.unreportedUsage (raw >>= lookupField "usage" >>= Billing.readUsage Billing.ResponsesUsage)) + in normalized & #cost .~ Pricing.computeCostForService Nothing Nothing m normalized + +observe :: Ev.CallStatus -> Maybe ResponseMetadata -> Maybe Value -> M.AssistantPayload -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence +observe status md raw payload ev = + let seenModel = maybe Ev.Unobserved Ev.Observed (raw >>= textField "model") + rid = maybe Ev.Unobserved Ev.Observed (raw >>= textField "id") + requestId = case md of + Nothing -> Ev.Unobserved + Just meta -> case [v | n <- capturedHeaderNames, Just v <- [lookup (T.decodeUtf8 (CI.foldedCase n)) (meta ^. #headers)]] of + v : _ -> Ev.Observed v + [] -> Ev.Unobserved + allCounts = do + _ <- raw >>= lookupField "usage" >>= Billing.readUsage Billing.ResponsesUsage + pure (payload ^. #usage) + commitment = + if status == Ev.CallSucceeded + then Ev.Observed (Ev.commitmentDigest (object ["content" .= (payload ^. #content), "stop_reason" .= (payload ^. #stopReason), "usage" .= Ev.usageEnvelope (payload ^. #usage)])) + else Ev.Unobserved + in ev + & #endpoint . #implementationVersion .~ Just (T.pack (showVersion Paths.version)) + & #observedModel .~ seenModel + & #responseId .~ rid + & #providerRequestId .~ requestId + & #usage .~ maybe Ev.Unobserved Ev.Observed allCounts + & #responseCommitment .~ commitment + & #strength .~ Ev.deriveStrength seenModel requestId rid + +lookupField :: Key -> Value -> Maybe Value +lookupField k (Object o) = KM.lookup k o +lookupField _ _ = Nothing + +textField :: Key -> Value -> Maybe Text +textField k v = lookupField k v >>= \case String t | not (T.null t) -> Just t; _ -> Nothing + +trySync :: IO a -> IO (Either SomeException a) +trySync action = do + result <- try action + case result of + Left ex | Just _ <- (fromException ex :: Maybe SomeAsyncException) -> throwIO ex + _ -> pure result + +exceptionToError :: SomeException -> BaikaiError +exceptionToError ex = fromMaybe (classifyException ex) (fromException ex) diff --git a/src/Baikai/Provider/OpenAI/Shape.hs b/src/Baikai/Provider/OpenAI/Shape.hs --- a/src/Baikai/Provider/OpenAI/Shape.hs +++ b/src/Baikai/Provider/OpenAI/Shape.hs @@ -13,6 +13,7 @@ dropUnsupportedStrict, injectThinkingShape, describeThinkingShape, + resolveSupportedEffort, injectCacheControl, ) where @@ -24,6 +25,7 @@ OpenAICompletionsCompat ( cacheControlFormat, maxTokensField, + supportedReasoningEfforts, supportsLongCacheRetention, supportsStrictMode, supportsUsageInStreaming, @@ -37,13 +39,16 @@ ThinkingTranslation (..), noThinkingRequested, ) -import Baikai.Options (Options, cacheRetention, thinking) +import Baikai.Options (Options, cacheRetention, temperature, thinking, topP) import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) +import Control.Lens ((%~), (&), (^.)) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey import Data.Aeson.KeyMap (KeyMap) import Data.Aeson.KeyMap qualified as KeyMap +import Data.Generics.Labels () +import Data.Maybe (isJust) import Data.Text (Text) import Data.Vector (Vector) import Data.Vector qualified as Vector @@ -125,12 +130,10 @@ -- through 'compatibleEffort', the two toggle shapes carry no depth at -- all, and 'ThinkingFormatNone' drops the request entirely. -- --- The native shape is the one that records __no__ adjustment, because --- it forwards the canonical level verbatim and therefore expresses all --- six exactly. That is deliberate and guarded by @nativeHigherEffortTests@ --- in @baikai-openai/test/ShapeSpec.hs@; 'compatibleEffort' is scoped by --- its own documentation to the non-native shapes and must not be --- applied here. +-- The native shape preserves each level unless the model explicitly +-- restricts its accepted vocabulary. Any replacement is described by +-- the same mapping that writes the wire field. Host-specific clamping +-- remains separate from this per-model policy. -- -- The 'Bool' is whether the chosen model advertises reasoning support -- ('Baikai.Model.reasoning'). It is consulted /before/ the host's @@ -150,6 +153,28 @@ Aeson.Value -> (Aeson.Value, ThinkingTranslation) injectThinkingShape compat modelReasons opts body = + let (shaped, translation) = injectEffort compat modelReasons opts body + dropped = [name | (name, present) <- [("temperature", isJust (temperature opts)), ("top_p", isJust (topP opts))], present] + in if compat ^. #supportsSamplingParameters + then (shaped, translation) + else + ( mapObject (KeyMap.delete "temperature" . KeyMap.delete "top_p") shaped, + translation & #adjustments %~ (<> [SamplingDroppedUnsupportedModel dropped | not (null dropped)]) + ) + +-- | Resolve to the nearest accepted level at or above the request, or +-- the greatest accepted level when the request exceeds the policy. +-- Invalid empty policies are rejected by request validation. +resolveSupportedEffort :: Maybe [ThinkingLevel] -> ThinkingLevel -> ThinkingLevel +resolveSupportedEffort Nothing lvl = lvl +resolveSupportedEffort (Just []) lvl = lvl +resolveSupportedEffort (Just levels) lvl = + case filter (>= lvl) levels of + first : _ -> first + [] -> last levels + +injectEffort :: OpenAICompletionsCompat -> Bool -> Options -> Aeson.Value -> (Aeson.Value, ThinkingTranslation) +injectEffort compat modelReasons opts body = case thinking opts of Nothing -> (body, noThinkingRequested) Just lvl @@ -161,12 +186,13 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [ThinkingDroppedUnsupportedModel lvl] } ) Just lvl -> case thinkingFormat compat of ThinkingFormatOpenAI -> - let e = renderThinkingLevel lvl + let e = renderThinkingLevel (resolveSupportedEffort (supportedReasoningEfforts compat) lvl) in ( insertTop "reasoning_effort" (String e) body, effortTranslation lvl e "reasoning_effort" ) @@ -178,6 +204,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [ThinkingDroppedUnsupportedHost lvl] } ) @@ -238,6 +265,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just field, + displayText = Nothing, adjustments = [EffortClamped lvl wire | wire /= renderThinkingLevel lvl] } @@ -256,6 +284,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Just "enable_thinking", + displayText = Nothing, adjustments = [EffortCollapsedToToggle lvl] } diff --git a/src/Baikai/Provider/OpenAI/Sse.hs b/src/Baikai/Provider/OpenAI/Sse.hs --- a/src/Baikai/Provider/OpenAI/Sse.hs +++ b/src/Baikai/Provider/OpenAI/Sse.hs @@ -10,8 +10,10 @@ ( openaiSseStream, openaiSseStreamValue, openaiSseStreamValueWithHeaders, + responsesSseStreamValueWithHeaders, sseFromResponse, buildRequest, + buildResponsesRequest, ResponseMetadata (..), capturedHeaderNames, ) @@ -128,8 +130,30 @@ (ResponseMetadata -> IO ()) -> (Either BaikaiError Aeson.Value -> IO ()) -> IO () -openaiSseStreamValueWithHeaders env requestHeaders requestBody onMetadata onEvent = do - HTTP.withResponse (buildRequest (Client.baseUrl env) requestHeaders requestBody) (Client.manager env) $ \response -> +openaiSseStreamValueWithHeaders = sseStreamWith buildRequest + +-- | Native Responses uses the same HTTP ownership and SSE framing, but +-- has a distinct URL and event protocol. The Responses assembler owns +-- interpretation of the JSON frames. +responsesSseStreamValueWithHeaders :: + Client.ClientEnv -> + RequestHeaders -> + Aeson.Value -> + (ResponseMetadata -> IO ()) -> + (Either BaikaiError Aeson.Value -> IO ()) -> + IO () +responsesSseStreamValueWithHeaders = sseStreamWith buildResponsesRequest + +sseStreamWith :: + (Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request) -> + Client.ClientEnv -> + RequestHeaders -> + Aeson.Value -> + (ResponseMetadata -> IO ()) -> + (Either BaikaiError Aeson.Value -> IO ()) -> + IO () +sseStreamWith makeRequest env requestHeaders requestBody onMetadata onEvent = + HTTP.withResponse (makeRequest (Client.baseUrl env) requestHeaders requestBody) (Client.manager env) $ \response -> sseFromResponse response onMetadata onEvent -- | The exact request this transport sends. @@ -145,7 +169,13 @@ -- teaches it — @https:\/\/api.deepseek.com\/v1@ — gets one @\/v1@ here -- rather than two. buildRequest :: Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request -buildRequest base requestHeaders requestBody = +buildRequest = buildRequestAt "/v1/chat/completions" + +buildResponsesRequest :: Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request +buildResponsesRequest = buildRequestAt "/v1/responses" + +buildRequestAt :: String -> Client.BaseUrl -> RequestHeaders -> Aeson.Value -> HTTP.Request +buildRequestAt endpoint base requestHeaders requestBody = HTTP.defaultRequest { HTTP.secure = case Client.baseUrlScheme base of Client.Http -> False @@ -153,7 +183,7 @@ HTTP.host = S8.pack (Client.baseUrlHost base), HTTP.port = Client.baseUrlPort base, HTTP.method = "POST", - HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> "/v1/chat/completions"), + HTTP.path = S8.pack (normalizePath (Client.baseUrlPath base) <> endpoint), HTTP.requestHeaders = requestHeaders, HTTP.requestBody = HTTP.RequestBodyLBS (Aeson.encode requestBody), -- This POST has no legitimate redirect, and http-client's default diff --git a/src/Baikai/Provider/OpenAI/Transport.hs b/src/Baikai/Provider/OpenAI/Transport.hs --- a/src/Baikai/Provider/OpenAI/Transport.hs +++ b/src/Baikai/Provider/OpenAI/Transport.hs @@ -82,7 +82,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/BillingSpec.hs b/test/BillingSpec.hs new file mode 100644 --- /dev/null +++ b/test/BillingSpec.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module BillingSpec (tests) where + +import Baikai qualified as B +import Baikai.Cost qualified as C +import Baikai.Cost.Pricing (computeCost) +import Baikai.Evidence (commitmentDigest, usageEnvelope) +import Baikai.Models.Generated qualified as Models +import Baikai.Provider.OpenAI.Internal.Stream qualified as Chat +import Baikai.Provider.OpenAI.Internal.Usage +import Baikai.Usage qualified as U +import Baikai.Usage.Normalize qualified as N +import Control.Lens ((&), (.~)) +import Control.Monad (forM_) +import Data.Aeson (Value, object, (.=)) +import Data.Aeson.Key (Key) +import Data.Aeson.Types qualified +import Data.Set qualified as Set +import Data.Text (Text) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Billing normalization" + [ testCase "Chat observes the reported tier and discloses unsupported pricing" $ + forM_ [("default", Set.empty), ("priority", Set.singleton (C.UnsupportedServiceTier "priority"))] $ \(tier, reasons) -> do + let frame = object ["service_tier" .= (tier :: Text), "usage" .= wire ChatUsage 1000 ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (0 :: Int)], "choices" .= [object ["finish_reason" .= ("stop" :: Text), "delta" .= object []]]] + driver _ _ _ _ emit = emit (Right frame) + model = Models.openai_gpt_6_astra & #api .~ B.OpenAIChatCompletions & #compat .~ B.CompatNone + response <- B.streamingComplete (Chat.openaiChatStreamWith driver) model B.emptyContext (B.emptyOptions & #apiKey .~ Just (B.ApiKeyLiteral "offline")) + response.message.usage.cost.basis.estimateReasons @?= reasons + U.billingFacts <$> response.message.usage.availability @?= Just (Set.singleton (U.BillingServiceTier tier)), + testCase "both endpoints subtract reported reads and writes exactly once" $ + forM_ [ChatUsage, ResponsesUsage] $ \endpoint -> do + u <- parsed endpoint (wire endpoint 15000 ["cached_tokens" .= (12000 :: Int), "cache_write_tokens" .= (3000 :: Int)]) + (u.inputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.outputTokens, u.totalTokens) @?= (0, 12000, 3000, 100, 15100) + u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty) + (computeCost Models.openai_gpt_6_astra u).usd @?= 109 / 2000, + testCase "missing writes retain counts but make cost an explicit estimate" $ do + missing <- parsed ResponsesUsage (wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int)]) + zero <- parsed ResponsesUsage (wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int), "cache_write_tokens" .= (0 :: Int)]) + missing.inputTokens @?= 3000 + missing.totalTokens @?= zero.totalTokens + (computeCost Models.openai_gpt_6_astra missing).basis.estimateReasons @?= Set.singleton C.CacheWriteUsageNotReported + (computeCost Models.openai_gpt_6_astra zero).basis.estimateReasons @?= Set.empty + assertBool "provider commitments distinguish omitted and zero counters" (commitmentDigest (usageEnvelope missing) /= commitmentDigest (usageEnvelope zero)), + testCase "empty usage is unreported but explicit zero is reported" $ do + readUsage ResponsesUsage (object []) @?= Nothing + (computeCost Models.openai_gpt_6_astra unreportedUsage).basis.estimateReasons @?= Set.singleton C.UsageNotReported + zero <- parsed ResponsesUsage (object ["input_tokens" .= (0 :: Int), "output_tokens" .= (0 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (0 :: Int)]]) + zero.totalTokens @?= 0 + (computeCost Models.openai_gpt_6_astra zero).basis.estimateReasons @?= Set.empty, + testCase "partial usage retains its reported categories" $ do + u <- parsed ChatUsage (object ["completion_tokens" .= (50 :: Int)]) + u.outputTokens @?= 50 + u.availability @?= Just (U.UsageAvailability (Set.fromList [U.InputUsage, U.CacheReadUsage, U.CacheWriteUsage]) False Set.empty), + testCase "invalid and inconsistent counters are never exact" $ + forM_ [wire ResponsesUsage 100 ["cached_tokens" .= (120 :: Int)], wire ResponsesUsage 100 ["cache_write_tokens" .= (-1 :: Int)], wire ResponsesUsage 100 ["cached_tokens" .= (1.5 :: Double)]] $ \raw -> do + u <- parsed ResponsesUsage raw + assertBool "inconsistency survives into calculation basis" (C.InconsistentUsage `Set.member` (computeCost Models.openai_gpt_6_astra u).basis.estimateReasons), + testCase "exclusive input sums cache categories and reasoning stays a subset" $ do + let u = N.normalizeUsage N.ExclusiveInput (N.ReportedUsage (Just 10) (Just 100) (Just 20) (Just 30) (Just 80)) + (u.inputTokens, u.totalTokens) @?= (10, 160) + u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty), + testCase "cumulative snapshots retain missing fields and never double counts" $ do + let initial = wire ResponsesUsage 15000 ["cached_tokens" .= (12000 :: Int)] + final = object ["output_tokens" .= (200 :: Int), "input_tokens_details" .= object ["cache_write_tokens" .= (3000 :: Int)]] + snapshot = mergeUsage (Just initial) (Just final) + mergeUsage snapshot (Just final) @?= snapshot + u <- maybe (assertFailure "missing merged usage") (parsed ResponsesUsage) snapshot + (u.inputTokens, u.outputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.totalTokens) @?= (0, 200, 12000, 3000, 15200) + u.availability @?= Just (U.UsageAvailability Set.empty False Set.empty), + testCase "availability aggregation retains unknown categories and monoid identity" $ do + a <- parsed ResponsesUsage (wire ResponsesUsage 100 []) + b <- parsed ResponsesUsage (wire ResponsesUsage 100 ["cached_tokens" .= (120 :: Int)]) + mempty <> a @?= a + a <> mempty @?= a + (a <> b) <> a @?= a <> (b <> a) + U.inconsistent <$> (a <> b).availability @?= Just True + ] + +wire :: UsageEndpoint -> Int -> [Data.Aeson.Types.Pair] -> Value +wire endpoint input details = + let (i, o, d) = case endpoint of ChatUsage -> ("prompt_tokens", "completion_tokens", "prompt_tokens_details"); ResponsesUsage -> ("input_tokens", "output_tokens", "input_tokens_details") + in object [(i :: Key) .= input, o .= (100 :: Int), d .= object details] + +parsed :: UsageEndpoint -> Value -> IO U.Usage +parsed endpoint raw = maybe (assertFailure "expected usage") pure (readUsage endpoint raw) diff --git a/test/EndpointModels.hs b/test/EndpointModels.hs new file mode 100644 --- /dev/null +++ b/test/EndpointModels.hs @@ -0,0 +1,20 @@ +-- | Explicit Chat capability fixture, independent of catalog routing. +module EndpointModels (chatRestrictedModel) where + +import Baikai +import Control.Lens ((&), (.~)) + +chatRestrictedModel :: Model +chatRestrictedModel = + emptyModel + & #api .~ OpenAIChatCompletions + & #provider .~ "openai" + & #modelId .~ "restricted-chat-model" + & #reasoning .~ True + & #compat + .~ CompatOpenAICompletions + ( defaultOpenAICompletionsCompat + & #supportsToolCalls .~ False + & #supportsSamplingParameters .~ False + & #supportedReasoningEfforts .~ Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] + ) diff --git a/test/EvidenceSpec.hs b/test/EvidenceSpec.hs --- a/test/EvidenceSpec.hs +++ b/test/EvidenceSpec.hs @@ -36,6 +36,7 @@ import Data.Text (Text) import Data.Text qualified as Text import Data.Vector qualified as Vector +import EndpointModels (chatRestrictedModel) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) @@ -51,7 +52,8 @@ -- @--test-options='--pattern Evidence'@ actually selects it. A -- pattern that matches nothing reports "All 0 tests passed". "EvidenceSpec: OpenAI-compatible model-call evidence" - [ successEvidenceTest, + [ endpointEvidenceTest, + successEvidenceTest, rateLimitEvidenceTest, toggleHostIndistinguishabilityTest, nonReasoningModelEvidenceTest, @@ -495,3 +497,30 @@ assertBool (Text.unpack k <> " must be a sha256 digest, got: " <> show d) ("sha256:" `Text.isPrefixOf` d && Text.length d == 71) + +endpointEvidenceTest :: TestTree +endpointEvidenceTest = testCase "Astra text shaping and strict refusal agree with evidence" $ do + bodyRef <- newIORef Null + let model = chatRestrictedModel & #modelId .~ "renamed-astra" + opts = + baseOptions + & #thinking .~ Just ThinkingMinimal + & #temperature .~ Just 0.5 + & #topP .~ Just 0.9 + & #toolChoice .~ Just ToolChoiceAuto + ev <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody opts + body <- readIORef bodyRef + lookupIn "reasoning_effort" body @?= Just (String "low") + lookupIn "temperature" body @?= Nothing + lookupIn "top_p" body @?= Nothing + thinkingOf ev "effort_text" @?= Just (String "low") + let described = describeThinkingShape (openaiCompletionsCompatFor model) True opts + field "thinking" ev @?= Just (Aeson.toJSON described) + described ^. #adjustments @?= [EffortClamped ThinkingMinimal "low", SamplingDroppedUnsupportedModel ["temperature", "top_p"]] + samplingOnly <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody (opts & #thinking .~ Nothing) + thinkingOf samplingOnly "adjustments" @?= Just (Aeson.toJSON [SamplingDroppedUnsupportedModel ["temperature", "top_p"]]) + writeIORef bodyRef Null + let strict = opts & #evidence .~ Just (evidenceRequest "strict-astra" & #strictness .~ EvidenceRequired EvidenceRequestedOnly) + refused <- oneEvidence =<< replayWith bodyRef model 200 successHeaders successBody strict + readIORef bodyRef >>= (@?= Null) + field "status" refused @?= Just (String "failed") diff --git a/test/LifecycleSpec.hs b/test/LifecycleSpec.hs --- a/test/LifecycleSpec.hs +++ b/test/LifecycleSpec.hs @@ -13,9 +13,10 @@ module LifecycleSpec (tests) where import Baikai -import Baikai.Models.Generated (openai_gpt_4o_mini) +import Baikai.Models.Generated (openai_gpt_4o_mini, openai_gpt_6_astra) import Baikai.Provider.Internal.StreamWorker (frameQueueCapacity) import Baikai.Provider.OpenAI.Internal.Stream (SseDriver, openaiChatStreamWith) +import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith) import Baikai.Provider.OpenAI.Sse (sseFromResponse) import Control.Concurrent (forkIO, threadDelay, throwTo) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) @@ -25,9 +26,11 @@ import Data.CaseInsensitive qualified as CI import Data.Generics.Labels () import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Text (Text) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) +import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream import System.Mem (performMajorGC) import System.Timeout (timeout) @@ -37,19 +40,35 @@ tests :: TestTree tests = testGroup - "Baikai.Provider.OpenAI lifecycle" - [ boundedReadTest, - abandonedReleasesAfterGcTest, - cancellationReleasesWithoutGcTest, - workerDeathCannotStrandTest + "OpenAI worker lifecycle" + [ backendTests "Chat lifecycle" chatBackend, + backendTests "Responses lifecycle" responsesBackend ] +backendTests :: String -> Backend -> TestTree +backendTests title backend = + testGroup + title + [ boundedReadTest backend, + abandonedReleasesAfterGcTest backend, + cancellationReleasesWithoutGcTest backend, + workerDeathCannotStrandTest backend + ] + +data Backend = Backend + { streamWith :: SseDriver -> Model -> Context -> Options -> Stream IO AssistantMessageEvent, + modelFor :: Model, + initialFrame :: ByteString, + nextFrame :: ByteString, + eofMessage :: Text + } + -- | The bound alone stops the socket read: no garbage collection and no -- timer is involved. Before the frame queue the counter grew without -- limit, because the worker drained an endless body into an unbounded -- channel. -boundedReadTest :: TestTree -boundedReadTest = +boundedReadTest :: Backend -> TestTree +boundedReadTest backend = testCase "a consumer that stops after three events stops the body reader within the queue bound" $ do reads' <- newIORef (0 :: Int) closedRef <- newIORef False @@ -57,7 +76,7 @@ Stream.toList ( Stream.take 3 - (openaiChatStreamWith (countingDriver reads' closedRef Nothing) testModel emptyContext testOptions) + (streamWith backend (countingDriver backend reads' closedRef Nothing) (modelFor backend) emptyContext testOptions) ) length events @?= 3 settled <- awaitSettled reads' @@ -68,8 +87,8 @@ -- | The eventual guarantee. Nothing runs at the moment a consumer walks -- away; streamly's finaliser kills the worker at the next major -- collection, and that is when the connection goes back. -abandonedReleasesAfterGcTest :: TestTree -abandonedReleasesAfterGcTest = +abandonedReleasesAfterGcTest :: Backend -> TestTree +abandonedReleasesAfterGcTest backend = testCase "an abandoned stream releases its connection after a major GC" $ do reads' <- newIORef (0 :: Int) closedRef <- newIORef False @@ -77,7 +96,7 @@ Stream.toList ( Stream.take 3 - (openaiChatStreamWith (countingDriver reads' closedRef Nothing) testModel emptyContext testOptions) + (streamWith backend (countingDriver backend reads' closedRef Nothing) (modelFor backend) emptyContext testOptions) ) released <- pollFor 100 50000 (performMajorGC >> readIORef closedRef) assertBool "an abandoned stream's connection is released at a major GC" released @@ -85,8 +104,8 @@ -- | The immediate guarantee. The exception lands while the consumer is -- inside the stream's step, which is inside the bracket, so streamly -- runs the release synchronously. -cancellationReleasesWithoutGcTest :: TestTree -cancellationReleasesWithoutGcTest = +cancellationReleasesWithoutGcTest :: Backend -> TestTree +cancellationReleasesWithoutGcTest backend = testCase "cancelling the consumer releases the connection without a GC" $ do reads' <- newIORef (0 :: Int) closedRef <- newIORef False @@ -97,7 +116,7 @@ r <- try ( Stream.toList - (openaiChatStreamWith (countingDriver reads' closedRef (Just gate)) testModel emptyContext testOptions) + (streamWith backend (countingDriver backend reads' closedRef (Just gate)) (modelFor backend) emptyContext testOptions) ) putMVar outcome (r :: Either SomeException [AssistantMessageEvent]) threadDelay 100000 @@ -113,22 +132,22 @@ -- worker that dies by asynchronous exception still ends the stream. -- Before the frame queue the consumer blocked until the runtime's -- deadlock detector fired. -workerDeathCannotStrandTest :: TestTree -workerDeathCannotStrandTest = +workerDeathCannotStrandTest :: Backend -> TestTree +workerDeathCannotStrandTest backend = testCase "an asynchronous exception in the worker still closes the channel" $ do let dyingDriver :: SseDriver dyingDriver _env _headers _body _onMetadata _onEvent = throwIO ThreadKilled got <- timeout 2000000 - (Stream.toList (openaiChatStreamWith dyingDriver testModel emptyContext testOptions)) + (Stream.toList (streamWith backend dyingDriver (modelFor backend) emptyContext testOptions)) case got of Nothing -> assertFailure "a worker killed asynchronously left the consumer blocked" Just events -> case reverse events of -- 'errorInfo' is a 'Maybe': whether a stream error carries a -- typed error at all is itself worth asserting. (EventError p : _) -> - fmap (^. #message) (p ^. #errorInfo) @?= Just "openai stream ended without finish_reason" + fmap (^. #message) (p ^. #errorInfo) @?= Just (eofMessage backend) other -> assertFailure ("expected a terminal EventError, got: " <> show (take 1 other)) -- -------------------------------------------------------------------- @@ -142,8 +161,8 @@ -- With a gate, the reader blocks forever from the fourth read on, which -- is the state a cancelled consumer must be able to interrupt. Without -- one, the body never ends, which is what makes the queue bound visible. -countingDriver :: IORef Int -> IORef Bool -> Maybe (MVar ()) -> SseDriver -countingDriver reads' closedRef gate _env _headers _body onMetadata onEvent = +countingDriver :: Backend -> IORef Int -> IORef Bool -> Maybe (MVar ()) -> SseDriver +countingDriver backend reads' closedRef gate _env _headers _body onMetadata onEvent = bracket mkFakeResponse HTTP.responseClose $ \resp -> sseFromResponse resp onMetadata onEvent where @@ -163,7 +182,7 @@ n <- atomicModifyIORef' reads' (\k -> (k + 1, k)) case gate of Just g | n >= 3 -> takeMVar g >> pure "" - _ -> pure contentFrame + _ -> pure (if n == 0 then initialFrame backend else nextFrame backend) -- | An endless stream of visible-text deltas. contentFrame :: ByteString @@ -202,3 +221,15 @@ testOptions :: Options testOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "test-key") + +chatBackend :: Backend +chatBackend = Backend openaiChatStreamWith testModel contentFrame contentFrame "openai stream ended without finish_reason" + +responsesBackend :: Backend +responsesBackend = + Backend + openaiResponsesStreamWith + openai_gpt_6_astra + "data: {\"type\":\"response.output_item.added\",\"output_index\":0,\"item\":{\"type\":\"message\",\"id\":\"msg\",\"content\":[]}}\n\n" + "data: {\"type\":\"response.output_text.delta\",\"output_index\":0,\"content_index\":0,\"item_id\":\"msg\",\"delta\":\"x\"}\n\n" + "Responses stream ended without a terminal response" diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -29,6 +29,7 @@ translate, ) import Baikai.Provider.OpenAI.Shape (describeThinkingShape) +import BillingSpec qualified import CliEvidenceSpec qualified import Contract (assertErrorContract, assertOneErrorTerminal) import Control.Exception (bracket) @@ -47,6 +48,11 @@ import OpenAI.V1.ResponseFormat qualified as RF import PublicSurfaceSpec qualified import ReasoningSpec qualified +import ResponsesAssemblerSpec qualified +import ResponsesEvidenceSpec qualified +import ResponsesSpec qualified +import ResponsesStreamSpec qualified +import ResponsesTransportSpec qualified import ShapeSpec qualified import SseSpec qualified import Streamly.Data.Stream qualified as Stream @@ -92,6 +98,7 @@ finishReasonTests, responseFormatMappingTest, optionsMappingTest, + BillingSpec.tests, CliEvidenceSpec.tests, ErrorClassSpec.tests, EvidenceSpec.tests, @@ -99,6 +106,11 @@ MidStreamSpec.tests, PublicSurfaceSpec.tests, ReasoningSpec.tests, + ResponsesAssemblerSpec.tests, + ResponsesEvidenceSpec.tests, + ResponsesSpec.tests, + ResponsesStreamSpec.tests, + ResponsesTransportSpec.tests, ShapeSpec.tests, SseSpec.tests, TransportSpec.tests @@ -509,6 +521,7 @@ effortText = Just (renderThinkingLevel level), budgetTokens = Nothing, wireField = Just "model_reasoning_effort", + displayText = Nothing, adjustments = [] } | level <- @@ -969,12 +982,12 @@ [ testCase "content_filter terminates as EventError" $ do let (_events1, ass1) = translate - (Right RawChunk {contentDelta = Just "partial", reasoningDelta = Nothing, finishReason = Nothing, toolDeltas = [], usage = Nothing, model = Nothing, responseId = Nothing}) + (Right RawChunk {contentDelta = Just "partial", reasoningDelta = Nothing, finishReason = Nothing, toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing}) (emptyAssembler openaiTestModel (read "2026-06-05 00:00:00 UTC")) (read "2026-06-05 00:00:01 UTC") (events2, ass2) = translate - (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "content_filter", toolDeltas = [], usage = Nothing, model = Nothing, responseId = Nothing}) + (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "content_filter", toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing}) ass1 (read "2026-06-05 00:00:02 UTC") (events3, _) = closeOpenStream (read "2026-06-05 00:00:03 UTC") Nothing ass2 @@ -991,7 +1004,7 @@ testCase "unknown finish_reason is a successful diagnostic" $ do let (_events, ass1) = translate - (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "mystery", toolDeltas = [], usage = Nothing, model = Nothing, responseId = Nothing}) + (Right RawChunk {contentDelta = Nothing, reasoningDelta = Nothing, finishReason = Just "mystery", toolDeltas = [], usage = Nothing, model = Nothing, serviceTier = Nothing, responseId = Nothing}) (emptyAssembler openaiTestModel (read "2026-06-05 00:00:00 UTC")) (read "2026-06-05 00:00:01 UTC") (terminalEvents, _) = closeOpenStream (read "2026-06-05 00:00:02 UTC") Nothing ass1 diff --git a/test/ReasoningSpec.hs b/test/ReasoningSpec.hs --- a/test/ReasoningSpec.hs +++ b/test/ReasoningSpec.hs @@ -15,8 +15,9 @@ scanThinkTags, translate, ) +import Baikai.Provider.OpenAI.Shape (describeThinkingShape) import Baikai.Provider.OpenAI.Sse (sseFromResponse) -import Control.Lens ((&), (.~)) +import Control.Lens ((&), (.~), (^.)) import Data.Aeson qualified as Aeson import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as LBS @@ -25,6 +26,7 @@ import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector +import EndpointModels (chatRestrictedModel) import Network.HTTP.Client.Internal qualified as HTTP import Network.HTTP.Types.Status (mkStatus) import Network.HTTP.Types.Version (http11) @@ -36,7 +38,20 @@ tests = testGroup "ReasoningSpec" - [ parseReasoningTests, + [ 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 openai_gpt_4o_mini ctx emptyOptions of + Left _ -> pure () + Right _ -> assertFailure "foreign state was silently accepted", + testCase "minimal maps upward by catalog policy with adjustment evidence" $ do + let model = chatRestrictedModel & #modelId .~ "renamed-policy-test" + opts = emptyOptions & #thinking .~ Just ThinkingMinimal + described = describeThinkingShape (openaiCompletionsCompatFor model) True opts + described ^. #effortText @?= Just "low" + described ^. #adjustments @?= [EffortClamped ThinkingMinimal "low"], + parseReasoningTests, assemblyTests, tagScannerTests, taggedTextCompatTest, @@ -87,7 +102,8 @@ ThinkingContent { thinking = "because therefore", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "answer done") ], @@ -130,7 +146,8 @@ ThinkingContent { thinking = "because", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "answer") ], @@ -236,7 +253,8 @@ ThinkingContent { thinking = "reasoning", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "answer") ] @@ -255,7 +273,8 @@ ThinkingContent { thinking = "internal", signature = Nothing, - redacted = False + redacted = False, + replayState = Nothing }, AssistantText (TextContent "visible") ], @@ -300,6 +319,7 @@ toolDeltas = [], usage = Nothing, model = Nothing, + serviceTier = Nothing, responseId = Nothing } diff --git a/test/ResponsesAssemblerSpec.hs b/test/ResponsesAssemblerSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesAssemblerSpec.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module ResponsesAssemblerSpec (tests) where + +import Baikai.Content qualified as C +import Baikai.Provider.OpenAI.Responses.Assembler qualified as A +import Baikai.StopReason (StopReason (..)) +import Baikai.Stream.Event qualified as E +import Control.Monad (foldM) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.Key (Key) +import Data.Text (Text) +import Data.Vector qualified as V +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Responses assembler" + [ testCase "streams text immediately and reconciles snapshots without duplication" $ do + (s, events) <- run [added 0 (message ""), textDelta 0 0 "hello"] + events @?= [E.TextStart (E.IndexPayload 0), E.TextDelta (E.DeltaPayload 0 "hello")] + (done, rest) <- step (completed [message "hello world"]) s + rest @?= [E.TextDelta (E.DeltaPayload 0 " world"), E.TextEnd (E.BlockEndPayload 0 "hello world")] + A.assembledContent done @?= V.singleton (C.AssistantText (C.TextContent "hello world")) + A.terminalReason done @?= Just Stop + (_, again) <- step (completed [message "hello world"]) done + again @?= [], + testCase "parallel function calls retain call IDs and serialize blocks" $ do + (s, events) <- + run + [ added 0 (call "item_a" "call_a" "" "in_progress"), + added 1 (call "item_b" "call_b" "" "in_progress"), + argDelta 1 "item_b" "{\"b\":2}", + argDelta 0 "item_a" "{\"a\":1}", + itemDone 1 (call "item_b" "call_b" "{\"b\":2}" "completed"), + itemDone 0 (call "item_a" "call_a" "{\"a\":1}" "completed"), + completed [call "item_a" "call_a" "{\"a\":1}" "completed", call "item_b" "call_b" "{\"b\":2}" "completed"] + ] + A.terminalReason s @?= Just ToolUse + A.assembledContent s + @?= V.fromList + [C.AssistantToolCall (C.ToolCall "call_a" "lookup" (object ["a" .= (1 :: Int)])), C.AssistantToolCall (C.ToolCall "call_b" "lookup" (object ["b" .= (2 :: Int)]))] + [n | E.ToolCallStart (E.IndexPayload n) <- events] @?= [0, 1] + [n | E.ToolCallEnd (E.ToolCallEndPayload n _) <- events] @?= [0, 1] + assertBool "second block waits for first end" (case drop 2 events of E.ToolCallEnd _ : E.ToolCallStart _ : _ -> True; _ -> False), + testCase "empty summary retains the entire encrypted reasoning item" $ do + (s, _) <- run [added 0 reasoningAdded, itemDone 0 reasoning, completed [reasoning]] + case V.toList (A.assembledContent s) of + [C.AssistantThinking t] -> do + t.thinking @?= "" + fmap (.replayItems) t.replayState @?= Just (V.singleton reasoning) + fmap (.replayModel) t.replayState @?= Just "configured-model" + _ -> assertFailure "missing thinking block", + testCase "later content parts wait for earlier parts and final snapshots fill gaps" $ do + (s, _) <- run [added 0 (message ""), textDelta 0 1 "second", textDelta 0 0 "first"] + let final = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [part "first", part "second"]] + (done, events) <- step (completed [final]) s + events @?= [E.TextDelta (E.DeltaPayload 0 "second"), E.TextEnd (E.BlockEndPayload 0 "firstsecond")] + A.assembledContent done @?= V.singleton (C.AssistantText (C.TextContent "firstsecond")), + testCase "interrupted parseable function prefix stays cut off" $ do + (s, _) <- run [added 0 (call "item_a" "call_a" "" "in_progress"), argDelta 0 "item_a" "{}"] + let (closed, _) = A.closePartial s + A.assembledContent closed @?= V.singleton (C.AssistantToolCall (C.ToolCall "call_a" "lookup" (String "{}"))), + testCase "incomplete response does not turn a truncated call into executable JSON" $ do + let item = call "item_a" "call_a" "{}" "incomplete" + (s, _) <- run [frame "response.incomplete" ["response" .= object ["output" .= [item], "incomplete_details" .= object ["reason" .= ("max_output_tokens" :: Text)]]]] + A.terminalReason s @?= Just Length + A.assembledContent s @?= V.singleton (C.AssistantToolCall (C.ToolCall "call_a" "lookup" (String "{}"))), + testCase "contradictory snapshots and wrong item identities fail" $ do + (s, _) <- run [added 0 (message ""), textDelta 0 0 "prefix"] + rejects (completed [message "replacement"]) s + rejects (argDelta 0 "wrong" "secret") s + rejects (added 1 (message "")) s, + testCase "part done snapshots and item done snapshots never repeat text" $ do + let textDone = frame "response.output_text.done" ["output_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "content_index" .= (0 :: Int), "text" .= ("hello" :: Text)] + (s, events) <- run [added 0 (message ""), textDelta 0 0 "hel", textDone, textDone, itemDone 0 (message "hello"), completed [message "hello"]] + [t | E.TextDelta (E.DeltaPayload _ t) <- events] @?= ["hel", "lo"] + A.terminalReason s @?= Just Stop, + testCase "reasoning summaries stream while encrypted state stays out of deltas" $ do + let summary = object ["type" .= ("summary_text" :: Text), "text" .= ("consider" :: Text)] + raw = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= [summary], "encrypted_content" .= ("opaque" :: Text)] + d = frame "response.reasoning_summary_text.delta" ["output_index" .= (0 :: Int), "item_id" .= ("rs" :: Text), "summary_index" .= (0 :: Int), "delta" .= ("consider" :: Text)] + (s, events) <- run [added 0 reasoningAdded, d, completed [raw]] + [t | E.ThinkingDelta (E.DeltaPayload _ t) <- events] @?= ["consider"] + case V.toList (A.assembledContent s) of + [C.AssistantThinking t] -> fmap (.replayItems) t.replayState @?= Just (V.singleton raw) + _ -> assertFailure "missing summary", + testCase "partial text closes with its observed prefix" $ do + (s, _) <- run [added 0 (message ""), textDelta 0 0 "partial"] + let (closed, events) = A.closePartial s + events @?= [E.TextEnd (E.BlockEndPayload 0 "partial")] + A.assembledContent closed @?= V.singleton (C.AssistantText (C.TextContent "partial")) + let (_, repeated) = A.closePartial closed + repeated @?= [], + testCase "terminal retains exact observed usage including absent cache-write field" $ do + let raw = object ["id" .= ("r" :: Text), "model" .= ("observed" :: Text), "output" .= [message "ok"], "usage" .= object ["input_tokens" .= (20 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (10 :: Int)]]] + (s, _) <- run [frame "response.completed" ["response" .= raw]] + A.observedResponse s @?= Just raw, + testCase "duplicate call IDs cannot masquerade as separate tool calls" $ do + (s, _) <- run [added 0 (call "item_a" "same_call" "" "in_progress")] + rejects (added 1 (call "item_b" "same_call" "" "in_progress")) s + rejects (completed [call "item_a" "same_call" "{}" "completed", call "item_b" "same_call" "{}" "completed"]) s, + testCase "successful reasoning must carry replayable continuation" $ do + rejects (completed [reasoningAdded]) (A.emptyAssembler "m"), + testCase "failure and malformed frames remain failures" $ do + mapM_ + (\f -> rejects f (A.emptyAssembler "m")) + [frame "response.failed" [], frame "error" [], object [], added (-1) (message ""), completed [object ["type" .= ("web_search_call" :: Text), "id" .= ("w" :: Text)]]] + ] + +run :: [Value] -> IO (A.Assembler, [E.AssistantMessageEvent]) +run = foldM (\(s, es) f -> do (next, events) <- step f s; pure (next, es <> events)) (A.emptyAssembler "configured-model", []) + +step :: Value -> A.Assembler -> IO (A.Assembler, [E.AssistantMessageEvent]) +step f s = either (\e -> assertFailure (show e) >> fail "assembly failed") pure (A.advance f s) + +rejects :: Value -> A.Assembler -> IO () +rejects f s = case A.advance f s of Left _ -> pure (); Right _ -> assertFailure "expected schema rejection" + +frame :: Text -> [(Key, Value)] -> Value +frame t fields = object (("type" .= t) : fields) + +added :: Int -> Value -> Value +added n item = frame "response.output_item.added" ["output_index" .= n, "item" .= item] + +itemDone :: Int -> Value -> Value +itemDone n item = frame "response.output_item.done" ["output_index" .= n, "item" .= item] + +completed :: [Value] -> Value +completed items = frame "response.completed" ["response" .= object ["id" .= ("resp" :: Text), "model" .= ("observed-model" :: Text), "output" .= items]] + +part :: Text -> Value +part t = object ["type" .= ("output_text" :: Text), "text" .= t] + +message :: Text -> Value +message t = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [part t]] + +textDelta :: Int -> Int -> Text -> Value +textDelta n p t = frame "response.output_text.delta" ["output_index" .= n, "item_id" .= ("msg" :: Text), "content_index" .= p, "delta" .= t] + +call :: Text -> Text -> Text -> Text -> Value +call ident callId args status = object ["type" .= ("function_call" :: Text), "id" .= ident, "call_id" .= callId, "name" .= ("lookup" :: Text), "arguments" .= args, "status" .= status] + +argDelta :: Int -> Text -> Text -> Value +argDelta n ident t = frame "response.function_call_arguments.delta" ["output_index" .= n, "item_id" .= ident, "delta" .= t] + +reasoningAdded :: Value +reasoningAdded = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value])] + +reasoning :: Value +reasoning = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("opaque" :: Text), "future_field" .= object ["keep" .= True]] diff --git a/test/ResponsesEvidenceSpec.hs b/test/ResponsesEvidenceSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesEvidenceSpec.hs @@ -0,0 +1,187 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module ResponsesEvidenceSpec (tests) where + +import Baikai hiding (describeThinking, model) +import Baikai.Models.Generated (openai_gpt_6_astra) +import Baikai.Provider.OpenAI.Internal.Stream (SseDriver) +import Baikai.Provider.OpenAI.Responses.Request (describeThinking) +import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith) +import Baikai.Provider.OpenAI.Sse (sseFromResponse) +import Baikai.Trace (withTraceStreamWith) +import Baikai.Trace.Event qualified as Trace +import Baikai.Trace.Sink (TraceSink (..)) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (bracket, finally) +import Control.Lens ((&), (.~)) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as LBS +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) +import Data.Text (Text) +import Data.Vector qualified as V +import Network.HTTP.Client.Internal qualified as HTTP +import Network.HTTP.Types.Status (mkStatus) +import Network.HTTP.Types.Version (http11) +import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Responses strict evidence over SSE bytes" + [ testCase "strict success observes host facts and commits exact request and replay" $ do + (response, body) <- replay 200 [wire success] strictOptions + responseError response @?= Nothing + ev <- proof response + ev.observedModel @?= Observed "server-version" + ev.providerRequestId @?= Observed "req-wire" + ev.responseId @?= Observed "response-wire" + ev.requestCommitment @?= commitmentDigest body + ev.strength @?= EvidenceModelObserved + ev.usage @?= Unobserved + case V.toList response.message.content of + [AssistantThinking t, AssistantText (TextContent "hello")] -> fmap (.replayItems) t.replayState @?= Just (V.singleton reasoningItem) + _ -> assertFailure "lost reasoning continuation", + testCase "arbitrary byte fragmentation keeps the same response commitment" $ do + (whole, _) <- replay 200 [wire success] strictOptions + (split, _) <- replay 200 (map BS.singleton (BS.unpack (wire success))) strictOptions + a <- proof whole + b <- proof split + a.responseCommitment @?= b.responseCommitment + split.message.content @?= whole.message.content, + testCase "minimal effort is refused before transport with strict evidence" $ do + (response, body) <- replay 200 [wire success] (strictOptions & #thinking .~ Just ThinkingMinimal) + assertBool "strict adjustment refused" (responseError response /= Nothing) + body @?= Null + ev <- proof response + ev.status @?= CallFailed + ev.observedModel @?= Unobserved, + testCase "local request validation still produces a strict evidence record" $ do + (response, body) <- replay 200 [wire success] (strictOptions & #seed .~ Just 7) + assertBool "unsupported option refused" (responseError response /= Nothing) + body @?= Null + ev <- proof response + ev.status @?= CallFailed, + testCase "non-2xx failure uses HTTP classification and captured request ID" $ do + (response, _) <- replay 429 ["{\"error\":{\"message\":\"slow down\"}}"] strictOptions + fmap (.category) (responseError response) @?= Just RateLimited + ev <- proof response + ev.status @?= CallFailed + ev.providerRequestId @?= Observed "req-wire" + ev.observedModel @?= Unobserved + ev.responseCommitment @?= Unobserved, + testCase "nested in-band error has one failed evidence record" $ do + let failure = object ["type" .= ("response.failed" :: Text), "response" .= object ["id" .= ("failed-response" :: Text), "error" .= object ["code" .= ("rate_limit_exceeded" :: Text), "message" .= ("busy" :: Text)]]] + (response, _) <- replay 200 [wire failure] strictOptions + fmap (.category) (responseError response) @?= Just RateLimited + ev <- proof response + ev.responseId @?= Observed "failed-response" + ev.status @?= CallFailed, + testCase "malformed SSE JSON retains the streamed prefix and fails" $ do + (response, _) <- replay 200 [wire added, wire deltaFrame, "data: {broken}\n\n"] strictOptions + assertBool "decode failure" (responseError response /= Nothing) + response.message.content @?= V.singleton (AssistantText (TextContent "partial")) + ev <- proof response + ev.status @?= CallFailed, + testCase "EOF retains prefix without manufacturing a successful response" $ do + (response, _) <- replay 200 [wire added, wire deltaFrame] strictOptions + assertBool "EOF failure" (responseError response /= Nothing) + response.message.content @?= V.singleton (AssistantText (TextContent "partial")) + ev <- proof response + ev.responseCommitment @?= Unobserved, + testCase "observations absent from response remain absent under best effort" $ do + let silent = object ["type" .= ("response.completed" :: Text), "response" .= object ["output" .= ([] :: [Value])]] + (response, _) <- replay 200 [wire silent] (strictOptions & #evidence .~ Just (evidenceRequest "silent")) + ev <- proof response + ev.observedModel @?= Unobserved + ev.responseId @?= Unobserved + ev.usage @?= Unobserved, + testCase "strict trace cancellation records one abort and releases the worker" $ do + closed <- newEmptyMVar + forever <- newEmptyMVar + captured <- newIORef ([] :: [Trace.TraceEvent]) + recorded <- newEmptyMVar + let blocked _ _ _ _ emit = (emit (Right added) >> emit (Right deltaFrame) >> takeMVar forever) `finally` putMVar closed () + save () e = do + atomicModifyIORef' captured (\xs -> (e : xs, ())) + case e of Trace.CallEvidence {} -> putMVar recorded (); _ -> pure () + sink = TraceSink (Fold.foldlM' save (pure ())) + reg <- registryFor blocked + result <- timeout 100000 (Stream.toList (withTraceStreamWith reg sink openai_gpt_6_astra emptyContext strictOptions)) + assertBool "consumer was cancelled" (case result of Nothing -> True; _ -> False) + timeout 1000000 (takeMVar closed) >>= (@?= Just ()) + timeout 1000000 (takeMVar recorded) >>= (@?= Just ()) + events <- readIORef captured + case [ev | Trace.CallEvidence {Trace.evidence = ev} <- events] of + [ev] -> ev.status @?= CallAborted + _ -> assertFailure "expected one abort evidence record", + testCase "opting out does not attach evidence" $ do + (response, _) <- replay 200 [wire success] (strictOptions & #evidence .~ Nothing) + response.evidence @?= Nothing + ] + +proof :: Response -> IO ModelCallEvidence +proof response = case response.evidence of Just ev -> pure ev; Nothing -> assertFailure "missing evidence" >> fail "missing evidence" + +strictOptions :: Options +strictOptions = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-key") & #evidence .~ Just (evidenceRequest "responses-strict" & #strictness .~ EvidenceRequired EvidenceRequestedOnly) + +replay :: Int -> [ByteString] -> Options -> IO (Response, Value) +replay status chunks opts = do + sent <- newIORef Null + reg <- registryFor (byteDriver sent status chunks) + response <- completeRequestWith reg openai_gpt_6_astra emptyContext opts + body <- readIORef sent + pure (response, body) + +registryFor :: SseDriver -> IO ProviderRegistry +registryFor driver = + newProviderRegistryFrom + [ apiProvider OpenAIResponses (openaiResponsesStreamWith driver) + & #describeThinking .~ describeThinking + & #strengthCeiling .~ declaredStrength OpenAIResponses + ] + +byteDriver :: IORef Value -> Int -> [ByteString] -> SseDriver +byteDriver sent status chunks _ _ body onMetadata emit = do + writeIORef sent body + remaining <- newIORef chunks + let reader = do + xs <- readIORef remaining + case xs of [] -> pure ""; x : rest -> writeIORef remaining rest >> pure x + response = + HTTP.Response + { HTTP.responseStatus = mkStatus status "", + HTTP.responseVersion = http11, + HTTP.responseHeaders = [("x-request-id", "req-wire")], + HTTP.responseBody = reader, + HTTP.responseCookieJar = HTTP.createCookieJar [], + HTTP.responseClose' = HTTP.ResponseClose (pure ()), + HTTP.responseOriginalRequest = HTTP.defaultRequest, + HTTP.responseEarlyHints = [] + } + bracket (pure response) HTTP.responseClose (\r -> sseFromResponse r onMetadata emit) + +wire :: Value -> ByteString +wire v = "event: response.event\ndata: " <> LBS.toStrict (Aeson.encode v) <> "\n\n" + +reasoningItem :: Value +reasoningItem = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("opaque" :: Text), "future" .= True] + +item :: Text -> Value +item text = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [object ["type" .= ("output_text" :: Text), "text" .= text]]] + +success :: Value +success = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("response-wire" :: Text), "model" .= ("server-version" :: Text), "output" .= [reasoningItem, item "hello"]]] + +added :: Value +added = object ["type" .= ("response.output_item.added" :: Text), "output_index" .= (0 :: Int), "item" .= item ""] + +deltaFrame :: Value +deltaFrame = object ["type" .= ("response.output_text.delta" :: Text), "output_index" .= (0 :: Int), "content_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "delta" .= ("partial" :: Text)] diff --git a/test/ResponsesSpec.hs b/test/ResponsesSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesSpec.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module ResponsesSpec (tests) where + +import Baikai hiding (model, schema) +import Baikai.Models.Generated (openai_gpt_6_astra) +import Baikai.Provider.OpenAI.Responses.Request qualified as R +import Control.Lens ((&), (.~)) +import Control.Monad (forM_) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KM +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Vector qualified as V +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Responses request mapping" + [ testCase "stateless request carries text, image, system, cap and metadata" $ do + let ctx = + (systemUser "system instruction" "hello") + & #messages .~ V.singleton (UserMessage UserPayload {content = V.fromList [UserText (TextContent "hello"), UserImage (ImageContent "abc" "image/png")], timestamp = Nothing}) + opts = emptyOptions & #maxTokens .~ Just 321 & #metadata .~ Map.singleton "test" (String "value") + req <- mapped model ctx opts + field "model" req.requestBody @?= Just (String "renamed-responses-model") + field "instructions" req.requestBody @?= Just (String "system instruction") + field "store" req.requestBody @?= Just (Bool False) + field "stream" req.requestBody @?= Just (Bool True) + field "max_output_tokens" req.requestBody @?= Just (Number 321) + field "include" req.requestBody @?= Just (Aeson.toJSON (["reasoning.encrypted_content"] :: [Text])) + let rendered = Text.pack (show (field "input" req.requestBody)) + assertBool "image encoded inline" ("data:image/png;base64,YWJj" `Text.isInfixOf` rendered) + assertBool "text is present" ("hello" `Text.isInfixOf` rendered) + field "metadata" req.requestBody @?= Just (object ["test" .= ("value" :: Text)]), + testCase "assistant plain text has a valid easy-message input shape" $ do + req <- mapped model (contextOf [assistant "previous answer"]) emptyOptions + inputItems req @?= [object ["role" .= ("assistant" :: Text), "content" .= ("previous answer" :: Text)]], + testCase "empty summary and encrypted items persist into the next tool request" $ do + let decoded = Aeson.eitherDecode (Aeson.encode thought) + persisted <- either assertFailure pure decoded + let response = + emptyResponse + & #message . #content .~ V.fromList [AssistantThinking persisted, AssistantToolCall (ToolCall "call_7" "lookup" (object ["x" .= (1 :: Int)]))] + & #message . #stopReason .~ ToolUse + ctx = contextOf [user "go"] & #tools .~ V.singleton tool + next <- appendToolResult ctx response (\_ -> pure (toolResultText "found")) + req <- mapped model next emptyOptions + let items = inputItems req + take 1 (drop 1 items) @?= [reasoningItem] + field "call_id" (items !! 2) @?= Just (String "call_7") + field "type" (items !! 2) @?= Just (String "function_call") + field "call_id" (items !! 3) @?= Just (String "call_7") + field "output" (items !! 3) @?= Just (String "found") + field "previous_response_id" req.requestBody @?= Nothing + req.translation @?= R.describeThinking model emptyOptions, + testCase "every accepted effort survives; minimal adjusts with evidence" $ do + forM_ [ThinkingMinimal, ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] $ \level -> do + let opts = emptyOptions & #thinking .~ Just level + expected = if level == ThinkingMinimal then "low" else renderThinkingLevel level + req <- mapped model emptyContext opts + field "reasoning" req.requestBody @?= Just (object ["effort" .= expected]) + req.translation @?= R.describeThinking model opts + req.translation.adjustments @?= [EffortClamped ThinkingMinimal "low" | level == ThinkingMinimal], + testCase "sampling restriction is visible even without thinking" $ do + let opts = emptyOptions & #temperature .~ Just 0.5 & #topP .~ Just 0.8 + req <- mapped model emptyContext opts + field "temperature" req.requestBody @?= Nothing + field "top_p" req.requestBody @?= Nothing + req.translation.adjustments @?= [SamplingDroppedUnsupportedModel ["temperature", "top_p"]] + supported <- mapped (model & #compat .~ CompatOpenAIResponses defaultOpenAIResponsesCompat) emptyContext opts + field "temperature" supported.requestBody @?= Just (Number 0.5), + testCase "function tools keep permissive schemas and supported choices" $ do + let ctx = emptyContext & #tools .~ V.singleton tool + forM_ [ToolChoiceAuto, ToolChoiceNone, ToolChoiceRequired, ToolChoiceSpecific "lookup"] $ \choice -> do + req <- mapped model ctx (emptyOptions & #toolChoice .~ Just choice) + field "tool_choice" req.requestBody @?= case choice of + ToolChoiceAuto -> Nothing + ToolChoiceNone -> Just (String "none") + ToolChoiceRequired -> Just (String "required") + ToolChoiceSpecific name -> Just (object ["type" .= ("function" :: Text), "name" .= name]) + case field "tools" req.requestBody of + Just (Array tools) -> do + field "type" (V.head tools) @?= Just (String "function") + field "strict" (V.head tools) @?= Just (Bool False) + field "parameters" (V.head tools) @?= Just schema + _ -> assertFailure "missing tools" + rejected emptyContext (emptyOptions & #toolChoice .~ Just ToolChoiceRequired) + rejected ctx (emptyOptions & #toolChoice .~ Just (ToolChoiceSpecific "missing")), + testCase "JSON schema and JSON object use Responses text.format" $ do + strict <- mapped model emptyContext (emptyOptions & #responseFormat .~ Just (JsonSchema (jsonSchemaFormat "answer" schema & #strict .~ True))) + field "text" strict.requestBody @?= Just (object ["format" .= object ["type" .= ("json_schema" :: Text), "name" .= ("answer" :: Text), "schema" .= schema, "strict" .= True]]) + plain <- mapped model emptyContext (emptyOptions & #responseFormat .~ Just JsonObject) + field "text" plain.requestBody @?= Just (object ["format" .= object ["type" .= ("json_object" :: Text)]]), + testCase "cache requests follow endpoint TTL contract" $ do + req <- mapped model emptyContext (emptyOptions & #cacheRetention .~ Just CacheRetentionShort) + field "prompt_cache_options" req.requestBody @?= Just (object ["ttl" .= ("30m" :: Text)]) + rejected emptyContext (emptyOptions & #cacheRetention .~ Just CacheRetentionLong), + testCase "unsupported options fail instead of disappearing" $ + forM_ [emptyOptions & #seed .~ Just 1, emptyOptions & #stopSequences .~ ["stop"], emptyOptions & #frequencyPenalty .~ Just 1, emptyOptions & #presencePenalty .~ Just 1, emptyOptions & #metadata .~ Map.singleton "bad" (Number 1)] (rejected emptyContext), + testCase "foreign, malformed and duplicate replay fails without exposing payload" $ do + forM_ [replay & #replayApi .~ AnthropicMessages, replay & #replayModel .~ "other", replay & #replayItems .~ V.empty, replay & #replayItems .~ V.singleton (object []), replay & #replayItems .~ V.fromList [reasoningItem, reasoningItem]] $ \bad -> do + let ctx = addResponse (emptyResponse & #message . #content .~ V.singleton (AssistantThinking (thought & #replayState .~ Just bad))) emptyContext + case R.mapRequest model ctx emptyOptions of + Left err -> assertBool "error contains no opaque data" (not ("SECRET" `Text.isInfixOf` err)) + Right _ -> assertFailure "invalid replay accepted", + testCase "Anthropic state and incomplete calls cannot be replayed" $ do + forM_ [AssistantThinking (emptyThinkingContent & #signature .~ Just "sig"), AssistantThinking emptyThinkingContent, AssistantToolCall (ToolCall "call_1" "lookup" (String "{"))] $ \block -> + rejected (addResponse (emptyResponse & #message . #content .~ V.singleton block) emptyContext) emptyOptions + ] + where + rejected ctx opts = case R.mapRequest model ctx opts of + Left _ -> pure () + Right _ -> assertFailure "expected local rejection" + +model :: Model +model = + openai_gpt_6_astra + & #api .~ OpenAIResponses + & #modelId .~ "renamed-responses-model" + & #compat + .~ CompatOpenAIResponses + ( defaultOpenAIResponsesCompat + & #supportedReasoningEfforts .~ Just [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] + & #supportsSamplingParameters .~ False + & #supportsPromptCacheOptions .~ True + ) + +schema :: Value +schema = object ["type" .= ("object" :: Text), "properties" .= object ["x" .= object ["type" .= ("integer" :: Text)]]] + +tool :: Tool +tool = mkTool "lookup" "Look up x" schema + +reasoningItem :: Value +reasoningItem = object ["type" .= ("reasoning" :: Text), "id" .= ("rs_7" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("SECRET" :: Text), "status" .= ("completed" :: Text)] + +replay :: ThinkingReplay +replay = ThinkingReplay OpenAIResponses "renamed-responses-model" (V.singleton reasoningItem) + +thought :: ThinkingContent +thought = emptyThinkingContent & #replayState .~ Just replay + +mapped :: Model -> Context -> Options -> IO R.PreparedRequest +mapped m ctx opts = either (assertFailure . Text.unpack) pure (R.mapRequest m ctx opts) + +field :: Aeson.Key -> Value -> Maybe Value +field k (Object o) = KM.lookup k o +field _ _ = Nothing + +inputItems :: R.PreparedRequest -> [Value] +inputItems req = case field "input" req.requestBody of + Just (Array xs) -> V.toList xs + _ -> [] diff --git a/test/ResponsesStreamSpec.hs b/test/ResponsesStreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesStreamSpec.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE OverloadedRecordDot #-} + +module ResponsesStreamSpec (tests) where + +import Baikai hiding (delta, model) +import Baikai.Models.Generated (openai_gpt_6_astra) +import Baikai.Provider.OpenAI.Internal.Stream (SseDriver) +import Baikai.Provider.OpenAI.Responses.Stream (openaiResponsesStreamWith) +import Baikai.Provider.OpenAI.Sse (ResponseMetadata (..)) +import Contract (assertErrorContract) +import Control.Concurrent (threadDelay) +import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) +import Control.Exception (finally) +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson (Value (..), object, (.=)) +import Data.Aeson.KeyMap qualified as KM +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Vector qualified as V +import Streamly.Data.Stream qualified as Stream +import System.Timeout (timeout) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Responses stream" + [ testCase "terminal usage merges earlier categories and evidence matches its cost" $ do + let finished = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("resp_usage" :: Text), "service_tier" .= ("default" :: Text), "output" .= [item "hello"], "usage" .= object ["output_tokens" .= (100 :: Int), "input_tokens_details" .= object ["cache_write_tokens" .= (3000 :: Int)]]]] + events <- Stream.toList (openaiResponsesStreamWith (driver [usageStarted, finished, finished]) model emptyContext (options & #evidence .~ Just (evidenceRequest "billing"))) + case last events of + EventDone p -> case p.message of + AssistantMessage msg -> do + let u = msg.usage + (u.inputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.totalTokens) @?= (0, 12000, 3000, 15100) + u.cost.usd @?= 109 / 2000 + u.cost.basis.estimateReasons @?= Set.empty + case p.evidence of + Just ev -> ev.usage @?= Observed u + Nothing -> assertFailure "missing evidence" + _ -> assertFailure "expected assistant" + _ -> assertFailure "expected completion", + testCase "partial usage survives a failed stream with missing categories explicit" $ do + events <- run [usageStarted, added, delta] + assertErrorContract events + case last events of + EventError p -> case p.message of + AssistantMessage msg -> do + msg.usage.cacheReadTokens @?= 12000 + msg.usage.inputTokens @?= 3000 + msg.usage.cost.basis.estimateReasons @?= Set.fromList [OutputUsageNotReported, CacheWriteUsageNotReported, ServiceTierNotReported] + _ -> assertFailure "expected assistant" + _ -> assertFailure "expected failure", + testCase "complete folds the same stream, including final-only content" $ do + response <- streamingComplete (openaiResponsesStreamWith (driver [completed])) model emptyContext options + response.message.content @?= V.singleton (AssistantText (TextContent "hello")) + response.message.stopReason @?= Stop + response.responseId @?= Just "resp_actual", + testCase "EOF after a text delta closes partial content and fails" $ do + events <- run [added, delta] + assertErrorContract events + case last events of + EventError p -> case p.message of + AssistantMessage msg -> msg.content @?= V.singleton (AssistantText (TextContent "hel")) + _ -> assertFailure "wrong message role" + _ -> assertFailure "expected error", + testCase "in-band rate limit preserves classification" $ do + events <- run [object ["type" .= ("error" :: Text), "code" .= ("rate_limit_exceeded" :: Text), "message" .= ("slow down" :: Text)]] + assertErrorContract events + case last events of + EventError p -> fmap (^. #category) p.errorInfo @?= Just RateLimited + _ -> assertFailure "expected error", + testCase "failed response preserves its nested error" $ do + events <- run [object ["type" .= ("response.failed" :: Text), "response" .= object ["id" .= ("failed_id" :: Text), "error" .= object ["code" .= ("rate_limit_exceeded" :: Text), "message" .= ("busy" :: Text)]]]] + assertErrorContract events + case last events of + EventError p -> do + p.responseId @?= Just "failed_id" + fmap (^. #category) p.errorInfo @?= Just RateLimited + _ -> assertFailure "expected error", + testCase "malformed event becomes a terminal error with partial text" $ do + events <- run [added, delta, object []] + assertErrorContract events, + testCase "completed terminal cancels a driver waiting for more bytes" $ do + closed <- newEmptyMVar + let waiting _ _ _ _ emit = (emit (Right completed) >> threadDelay 10000000) `finally` putMVar closed () + result <- timeout 2000000 (Stream.toList (openaiResponsesStreamWith waiting model emptyContext options)) + assertBool "stream completed promptly" (maybe False (not . null) result) + timeout 1000000 (takeMVar closed) >>= (@?= Just ()), + testCase "consumer timeout releases a driver blocked mid-response" $ do + closed <- newEmptyMVar + let waiting _ _ _ _ emit = (emit (Right added) >> emit (Right delta) >> threadDelay 10000000) `finally` putMVar closed () + result <- timeout 100000 (Stream.toList (openaiResponsesStreamWith waiting model emptyContext options)) + assertBool "consumer was cancelled" (case result of Nothing -> True; _ -> False) + timeout 1000000 (takeMVar closed) >>= (@?= Just ()), + testCase "slow active consumer can drain the complete response" $ do + result <- timeout 2000000 $ Stream.toList $ Stream.mapM (\e -> threadDelay 20000 >> pure e) (openaiResponsesStreamWith (driver [added, delta, completed]) model emptyContext options) + case result of + Just events -> length [() | EventDone _ <- events] @?= 1 + Nothing -> assertFailure "slow consumer did not finish", + testCase "validation fails before the driver starts" $ do + called <- newIORef False + let forbidden _ _ _ _ _ = writeIORef called True + events <- Stream.toList (openaiResponsesStreamWith forbidden model emptyContext (options & #seed .~ Just 1)) + assertErrorContract events + readIORef called >>= (@?= False), + testCase "public two-turn tool loop preserves encrypted reasoning and call identity" $ do + requests <- newIORef ([] :: [Value]) + let reasoning = object ["type" .= ("reasoning" :: Text), "id" .= ("rs_1" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("encrypted" :: Text), "unknown" .= True] + call = object ["type" .= ("function_call" :: Text), "id" .= ("item_1" :: Text), "call_id" .= ("call_1" :: Text), "name" .= ("lookup" :: Text), "arguments" .= ("{}" :: Text), "status" .= ("completed" :: Text)] + first = object ["type" .= ("response.completed" :: Text), "response" .= object ["output" .= [reasoning, call]]] + scripted _ _ body _ emit = do + previous <- readIORef requests + writeIORef requests (previous <> [body]) + emit (Right (if null previous then first else completed)) + provider = apiProvider OpenAIResponses (openaiResponsesStreamWith scripted) + ctx = systemUser "system" "find it" & #tools .~ V.singleton (mkTool "lookup" "lookup" (object ["type" .= ("object" :: Text)])) + reg <- newProviderRegistryFrom [provider] + executed <- newIORef ([] :: [Text]) + (_, result) <- runToolLoopWith reg 3 (\tc -> writeIORef executed [tc.id_] >> pure (toolResultText "found")) model ctx options + result.message.content @?= V.singleton (AssistantText (TextContent "hello")) + readIORef executed >>= (@?= ["call_1"]) + bodies <- readIORef requests + length bodies @?= 2 + case bodies of + [_, Object second] -> case KM.lookup "input" second of + Just (Array items) -> do + items V.! 1 @?= reasoning + case items V.! 3 of + Object reply -> do + KM.lookup "call_id" reply @?= Just (String "call_1") + KM.lookup "output" reply @?= Just (String "found") + _ -> assertFailure "missing function output" + _ -> assertFailure "missing input" + _ -> assertFailure "expected two requests", + testCase "evidence commits to the exact outgoing request and observed header" $ do + sent <- newIORef Null + let capturing _ _ body meta emit = do + writeIORef sent body + meta (ResponseMetadata 200 [("x-request-id", "req_observed")]) + emit (Right completed) + events <- Stream.toList (openaiResponsesStreamWith capturing model emptyContext (options & #evidence .~ Just (evidenceRequest "wire-test"))) + body <- readIORef sent + case last events of + EventDone p -> case p.evidence of + Just ev -> do + ev.requestCommitment @?= commitmentDigest body + (ev ^. #endpoint ^. #endpoint) @?= Just "https://api.openai.com/v1/responses" + ev.providerRequestId @?= Observed "req_observed" + ev.strength @?= declaredStrength OpenAIResponses + Nothing -> assertFailure "missing evidence" + _ -> assertFailure "missing success", + testCase "evidence uses observed model and exact response content" $ do + events <- Stream.toList (openaiResponsesStreamWith (driver [completed]) model emptyContext (options & #evidence .~ Just (evidenceRequest "responses-test"))) + case last events of + EventDone p -> case p.evidence of + Just ev -> do + ev.observedModel @?= Observed "server-model" + ev.responseId @?= Observed "resp_actual" + ev.usage @?= Unobserved + assertBool "response commitment exists" (case ev.responseCommitment of Observed _ -> True; _ -> False) + Nothing -> assertFailure "missing evidence" + _ -> assertFailure "missing success" + ] + +run :: [Value] -> IO [AssistantMessageEvent] +run frames = Stream.toList (openaiResponsesStreamWith (driver frames) model emptyContext options) + +driver :: [Value] -> SseDriver +driver frames _ _ _ _ emit = mapM_ (emit . Right) frames + +model :: Model +model = openai_gpt_6_astra & #modelId .~ "configured-model" + +options :: Options +options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "offline-test-key") + +item :: Text -> Value +item t = object ["type" .= ("message" :: Text), "id" .= ("msg" :: Text), "content" .= [object ["type" .= ("output_text" :: Text), "text" .= t]]] + +added :: Value +added = object ["type" .= ("response.output_item.added" :: Text), "output_index" .= (0 :: Int), "item" .= item ""] + +delta :: Value +delta = object ["type" .= ("response.output_text.delta" :: Text), "output_index" .= (0 :: Int), "content_index" .= (0 :: Int), "item_id" .= ("msg" :: Text), "delta" .= ("hel" :: Text)] + +completed :: Value +completed = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("resp_actual" :: Text), "model" .= ("server-model" :: Text), "output" .= [item "hello"]]] + +usageStarted :: Value +usageStarted = object ["type" .= ("response.created" :: Text), "response" .= object ["id" .= ("resp_usage" :: Text), "usage" .= object ["input_tokens" .= (15000 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (12000 :: Int)]]]] diff --git a/test/ResponsesTransportSpec.hs b/test/ResponsesTransportSpec.hs new file mode 100644 --- /dev/null +++ b/test/ResponsesTransportSpec.hs @@ -0,0 +1,30 @@ +module ResponsesTransportSpec (tests) where + +import Baikai.Provider.OpenAI.Sse (buildResponsesRequest) +import Baikai.Provider.OpenAI.Transport (getClientEnvCached) +import Data.Aeson qualified as Aeson +import Network.HTTP.Client qualified as HTTP +import Servant.Client qualified as Client +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Responses HTTP request" + [ testCase "POST path normalizes one version segment and never redirects" $ do + mapM_ + ( \url -> do + env <- getClientEnvCached url + let body = Aeson.object ["store" Aeson..= False] + req = buildResponsesRequest (Client.baseUrl env) [("Authorization", "Bearer fixture")] body + HTTP.path req @?= "/v1/responses" + HTTP.method req @?= "POST" + case HTTP.requestBody req of + HTTP.RequestBodyLBS encoded -> encoded @?= Aeson.encode body + _ -> assertFailure "expected the prepared JSON body" + HTTP.redirectCount req @?= 0 + HTTP.requestHeaders req @?= [("Authorization", "Bearer fixture")] + ) + ["https://api.openai.com", "https://api.openai.com/v1", "https://api.openai.com/v1/"] + ] diff --git a/test/ShapeSpec.hs b/test/ShapeSpec.hs --- a/test/ShapeSpec.hs +++ b/test/ShapeSpec.hs @@ -23,6 +23,7 @@ import Data.Text qualified as Text import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector +import EndpointModels (chatRestrictedModel) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -30,7 +31,8 @@ tests = testGroup "ShapeSpec" - [ deepseekShapeTest, + [ endpointPolicyTests, + deepseekShapeTest, nativeHigherEffortTests, compatibleHigherEffortClampTest, translationTableTests, @@ -248,6 +250,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Nothing, + displayText = Nothing, adjustments = [ThinkingDroppedUnsupportedHost lvl] }, [], @@ -263,6 +266,7 @@ effortText = Nothing, budgetTokens = Nothing, wireField = Just "enable_thinking", + displayText = Nothing, adjustments = [EffortCollapsedToToggle lvl] }, [("enable_thinking", Bool True)], @@ -278,6 +282,7 @@ effortText = Just wire, budgetTokens = Nothing, wireField = Just field, + displayText = Nothing, adjustments = adjs } @@ -489,6 +494,7 @@ toolDeltas = [], usage = Nothing, model = Nothing, + serviceTier = Nothing, responseId = Nothing } @@ -507,3 +513,16 @@ testTime :: UTCTime testTime = read "2026-07-03 12:00:00 UTC" + +endpointPolicyTests :: TestTree +endpointPolicyTests = + testGroup + "endpoint policy" + [ testCase ("accepted effort " <> show level) $ do + (body, translation) <- shapedCall fake (emptyOptions & #thinking .~ Just level) emptyContext + lookupTop "reasoning_effort" body @?= Just (String (renderThinkingLevel level)) + translation ^. #adjustments @?= [] + | level <- [ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] + ] + where + fake = chatRestrictedModel & #modelId .~ "arbitrary-generation" diff --git a/test/SseSpec.hs b/test/SseSpec.hs --- a/test/SseSpec.hs +++ b/test/SseSpec.hs @@ -239,6 +239,7 @@ toolDeltas = [], usage = Nothing, model = Nothing, + serviceTier = Nothing, responseId = Nothing } diff --git a/test/TransportSpec.hs b/test/TransportSpec.hs --- a/test/TransportSpec.hs +++ b/test/TransportSpec.hs @@ -2,16 +2,22 @@ import Baikai import Baikai.Provider.OpenAI.Api (openaiChatStream) +import Baikai.Provider.OpenAI.Internal.Stream (openaiChatStreamWith) +import Baikai.Provider.OpenAI.Shape (describeThinkingShape) import Baikai.Provider.OpenAI.Transport qualified as Transport +import Contract (assertErrorContract) import Control.Concurrent (threadDelay) import Control.Exception (bracket, try) import Control.Lens ((&), (.~), (^.)) import Control.Monad (forM_) +import Data.Aeson qualified as Aeson import Data.CaseInsensitive qualified as CI -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Map.Strict qualified as Map import Data.Text qualified as Text import Data.Text.Encoding qualified as Text +import Data.Vector qualified as Vector +import EndpointModels (chatRestrictedModel) import Network.HTTP.Types.Header (RequestHeaders) import Servant.Client qualified as Client import Streamly.Data.Stream qualified as Stream @@ -23,7 +29,8 @@ tests = testGroup "Baikai.Provider.OpenAI.Transport" - [ clientEnvCacheTest, + [ endpointRejectionTest, + clientEnvCacheTest, requestHeadersTest, timeoutTest, nonPositiveTimeoutTest, @@ -168,3 +175,45 @@ (lookupEnv name <* unsetEnv name) (maybe (unsetEnv name) (setEnv name)) . const + +endpointRejectionTest :: TestTree +endpointRejectionTest = testCase "endpoint capability rejection precedes network on complete and stream" $ do + calls <- newIORef (0 :: Int) + let driver _ _ _ _ _ = modifyIORef' calls (+ 1) + stream = openaiChatStreamWith driver + model = chatRestrictedModel & #modelId .~ "renamed-text-only" + tool = mkTool "lookup" "lookup" (Aeson.object []) + provider = + apiProviderWith OpenAIChatCompletions stream (streamingComplete stream) + & #describeThinking .~ (\m opts -> describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning) opts) + options = emptyOptions & #apiKey .~ Just (ApiKeyLiteral "unused") + reg <- newProviderRegistry + registerApiProviderWith reg provider + forM_ + [ (emptyContext & #tools .~ Vector.singleton tool, options), + (emptyContext, options & #toolChoice .~ Just ToolChoiceRequired), + (emptyContext, options & #toolChoice .~ Just (ToolChoiceSpecific "lookup")) + ] + $ \(ctx, opts) -> do + events <- Stream.toList (streamRequestWith reg model ctx opts) + assertErrorContract events + case last events of + EventError payload -> case payload ^. #errorInfo of + Just err -> do + err ^. #category @?= InvalidRequest + assertBool "actionable Responses explanation" ("Responses" `Text.isInfixOf` (err ^. #message)) + _ -> assertFailure "missing error" + _ -> assertFailure "expected error terminal" + response <- completeRequestWith reg model ctx opts + response ^. (#message . #stopReason) @?= ErrorReason + let strict = + options + & #thinking .~ Just ThinkingMinimal + & #evidence .~ Just (evidenceRequest "strict-endpoint" & #strictness .~ EvidenceRequired EvidenceRequestedOnly) + strictEvents <- Stream.toList (streamRequestWith reg model emptyContext strict) + assertErrorContract strictEvents + strictResponse <- completeRequestWith reg model emptyContext strict + case responseError strictResponse of + Just err -> err ^. #category @?= InvalidRequest + _ -> assertFailure "strict complete must refuse adjusted reasoning" + readIORef calls >>= (@?= 0)