baikai-openai 0.7.2.0 → 0.7.3.0
raw patch · 16 files changed
+644/−89 lines, 16 filesdep ~baikaiPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependency ranges changed: baikai
API changes (from Hackage documentation)
+ Baikai.Provider.OpenAI.Internal.Cache: CachePlan :: ![(Key, Value)] -> !Bool -> !Maybe CacheRetention -> CachePlan
+ Baikai.Provider.OpenAI.Internal.Cache: [cacheFields] :: CachePlan -> ![(Key, Value)]
+ Baikai.Provider.OpenAI.Internal.Cache: [effectiveRetention] :: CachePlan -> !Maybe CacheRetention
+ Baikai.Provider.OpenAI.Internal.Cache: [markPrefix] :: CachePlan -> !Bool
+ Baikai.Provider.OpenAI.Internal.Cache: cacheCost :: Maybe CacheRetention -> Model -> Usage -> Cost
+ Baikai.Provider.OpenAI.Internal.Cache: chatCachePlan :: Model -> Options -> Either Text CachePlan
+ Baikai.Provider.OpenAI.Internal.Cache: data CachePlan
+ Baikai.Provider.OpenAI.Internal.Cache: instance GHC.Classes.Eq Baikai.Provider.OpenAI.Internal.Cache.CachePlan
+ Baikai.Provider.OpenAI.Internal.Cache: instance GHC.Internal.Show.Show Baikai.Provider.OpenAI.Internal.Cache.CachePlan
+ Baikai.Provider.OpenAI.Internal.Cache: responsesCachePlan :: Model -> Options -> Either Text CachePlan
+ Baikai.Provider.OpenAI.Internal.Stream: [effectiveRetention] :: Assembler -> !Maybe CacheRetention
+ Baikai.Provider.OpenAI.Internal.Usage: checkCacheDuration :: UsageEndpoint -> Maybe CacheRetention -> Maybe Value -> Usage -> Usage
+ Baikai.Provider.OpenAI.Responses.Request: [effectiveRetention] :: PreparedRequest -> !Maybe CacheRetention
+ Baikai.Provider.OpenAI.Shape: applyNativeCache :: CachePlan -> Value -> Value
- Baikai.Provider.OpenAI.Internal.Stream: Assembler :: !Model -> !UTCTime -> !Maybe Int -> !Text -> !Bool -> !Maybe Int -> !Text -> !TagScanState -> !IntMap Int -> !Map Text Int -> !Maybe Int -> !IntMap (Text, Text) -> !IntMap Text -> !IntMap AssistantContent -> !Int -> !Usage -> !StopReason -> !Bool -> !Maybe BaikaiError -> !Maybe Text -> !Observed Text -> !Observed Text -> !Maybe Text -> !Maybe Int -> !Set Text -> !Maybe Value -> !Bool -> Assembler
+ Baikai.Provider.OpenAI.Internal.Stream: Assembler :: !Model -> !UTCTime -> !Maybe Int -> !Text -> !Bool -> !Maybe Int -> !Text -> !TagScanState -> !IntMap Int -> !Map Text Int -> !Maybe Int -> !IntMap (Text, Text) -> !IntMap Text -> !IntMap AssistantContent -> !Int -> !Maybe CacheRetention -> !Usage -> !StopReason -> !Bool -> !Maybe BaikaiError -> !Maybe Text -> !Observed Text -> !Observed Text -> !Maybe Text -> !Maybe Int -> !Set Text -> !Maybe Value -> !Bool -> Assembler
- Baikai.Provider.OpenAI.Responses.Request: PreparedRequest :: !Value -> !ThinkingTranslation -> PreparedRequest
+ Baikai.Provider.OpenAI.Responses.Request: PreparedRequest :: !Value -> !ThinkingTranslation -> !Maybe CacheRetention -> PreparedRequest
Files
- CHANGELOG.md +107/−0
- baikai-openai.cabal +5/−3
- src/Baikai/Provider/OpenAI/Agent.hs +3/−3
- src/Baikai/Provider/OpenAI/Cli.hs +2/−2
- src/Baikai/Provider/OpenAI/Internal/Cache.hs +101/−0
- src/Baikai/Provider/OpenAI/Internal/Request.hs +3/−0
- src/Baikai/Provider/OpenAI/Internal/Stream.hs +42/−33
- src/Baikai/Provider/OpenAI/Internal/Usage.hs +28/−1
- src/Baikai/Provider/OpenAI/Responses/Request.hs +9/−18
- src/Baikai/Provider/OpenAI/Responses/Stream.hs +9/−7
- src/Baikai/Provider/OpenAI/Shape.hs +34/−6
- test/BillingSpec.hs +12/−1
- test/Main.hs +7/−3
- test/NativeCacheSpec.hs +216/−0
- test/ResponsesSpec.hs +11/−5
- test/ShapeSpec.hs +55/−7
CHANGELOG.md view
@@ -7,6 +7,113 @@ ## [Unreleased] +## [baikai 0.10.0.0] - 2026-10-25++### Added++- `ThinkingNone` (`none`) explicitly requests reasoning off; `Nothing` still+ leaves provider defaults untouched. Anthropic compatibility records declare+ `supportsThinkingDisabled`; legacy records conservatively default to False.+- Endpoint-specific `NativeCachePolicy` records distinguish modern, legacy and+ unsupported native OpenAI cache controls. Policies survive legacy JSON and+ catalog refresh; Luna Responses Long has verified 12h base and tier rates.+- Evidence schema 2.8 includes the `none` preference and content-free native+ cache controls and input structure. Digest rules and the separation of+ requested, translated and observed reasoning are unchanged.++### Changed (breaking)++- `ThinkingLevel` gains `ThinkingNone` as its least constructor. Update exhaustive+ matches. Anthropic and OpenAI compatibility records gain fields; use the+ default records or update explicit record construction.+- All seven dependent packages now require `baikai ^>=0.10.0` and release+ independently below. The unchanged adapters take dependency-only patch bumps.++## [baikai-claude 0.7.3.0] - 2026-10-25++### Added++- Export `injectSystemCacheControl` for shared system-prefix cache markers.+- `ThinkingNone` sends catalog-gated `thinking: {"type": "disabled"}` without+ effort, display or a budget. Unsupported off requests remain visible+ adjustments and fail strict evidence before dispatch. A host with no thinking+ controls is not assumed to be a non-reasoning model.++### Fixed++- Short and long `cacheRetention` mark non-empty system prompts so fresh+ conversations with different first questions can reuse the tools-and-system+ prefix. System, last-tool and automatic markers share the effective TTL,+ including host downgrades, and use at most three breakpoints. Empty or absent+ system prompts and disabled caching keep their existing shape. Regression+ coverage includes tool compatibility and an isolated live shared-prefix case.+ Implements issue #2 and the approach in PR #3.++### Changed++- Require `baikai ^>=0.10.0`.++## [baikai-openai 0.7.3.0] - 2026-10-25++### Added++- Export `applyNativeCache` for validated native cache plans.+- OpenAI-compatible Chat (including Ollama) and Responses carry `none` where+ supported. Z.ai and Qwen emit `enable_thinking: false`; unsupported off+ requests remain visible adjustments and fail strict evidence before dispatch.++### Fixed++- Native OpenAI Short caching marks shared non-empty system prefixes on+ catalog-supported Responses and Chat bindings. Unsupported native requests+ fail locally. Effective duration reaches terminal pricing, partial usage+ and evidence.+- Funded live prefix checks pass for Luna Responses Short/Long and GPT-5.6 Chat+ Short. Luna Long uses verified 12h base and tier rates; unsupported Chat Long+ and unverified modern bindings remain locally refused.++### Changed++- Require `baikai ^>=0.10.0`. Catalog effort policies distinguish GPT-5/o-series+ models that cannot disable reasoning, Sol/Luna that accept none, and+ Astra/GPT-6.1 Sol that do not.++## [baikai-typesafe 0.1.0.1] - 2026-10-25++### Changed++- Require `baikai ^>=0.10.0`. Dependency-only update; no package API change.++## [baikai-trace-otel 0.4.1.1] - 2026-10-25++### Changed++- Require `baikai ^>=0.10.0`. Dependency-only update; no package API change.++## [baikai-effectful 0.4.0.5] - 2026-10-25++### Changed++- Require `baikai ^>=0.10.0`. Dependency-only update; no package API change.++## [baikai-kit 0.4.0.3] - 2026-10-25++### Changed++- Require `baikai ^>=0.10.0`. Dependency-only update; no package API change.++## [baikai-agent 0.2.0.4] - 2026-10-25++### Fixed++- Layered job configuration accepts `thinking "none"` through the shared+ canonical parser, keeping explicit off distinct from an absent preference.++### Changed++- Require `baikai ^>=0.10.0`, `baikai-claude ^>=0.7.3` and+ `baikai-openai ^>=0.7.3` for explicit-off handling in both vendor renderers.+ ## [baikai 0.9.0.0] - 2026-10-25 ### Added
baikai-openai.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai-openai-version: 0.7.2.0+version: 0.7.3.0 synopsis: OpenAI providers for the baikai abstraction description: OpenAI-compatible backends for baikai: Chat Completions over SSE against OpenAI and@@ -61,6 +61,7 @@ Baikai.Provider.OpenAI.Api Baikai.Provider.OpenAI.Cli Baikai.Provider.OpenAI.Interactive+ Baikai.Provider.OpenAI.Internal.Cache Baikai.Provider.OpenAI.Internal.ErrorClass Baikai.Provider.OpenAI.Internal.Request Baikai.Provider.OpenAI.Internal.Stream@@ -77,7 +78,7 @@ autogen-modules: Paths_baikai_openai build-depends: aeson ^>=2.2,- baikai ^>=0.9.0,+ baikai ^>=0.10.0, base >=4.20 && <5, base64-bytestring ^>=1.2, bytestring ^>=0.12,@@ -117,6 +118,7 @@ EvidenceSpec LifecycleSpec MidStreamSpec+ NativeCacheSpec PublicSurfaceSpec ReasoningSpec ResponsesAssemblerSpec@@ -131,7 +133,7 @@ build-depends: aeson,- baikai ^>=0.9.0,+ baikai ^>=0.10.0, baikai-openai, base >=4.20 && <5, bytestring,
src/Baikai/Provider/OpenAI/Agent.hs view
@@ -121,7 +121,7 @@ -- The adjustment list is derived by comparing what 'effortArgs' actually -- sends — through the same 'codexEffortValue' — with the canonical level -- name, rather than being hardcoded empty. It is empty at every level,--- because codex is the one tool baikai drives that accepts all six+-- because codex is the one tool baikai drives that accepts all seven -- verbatim; writing @[]@ by hand would keep claiming that after someone -- changed the mapping. --@@ -195,7 +195,7 @@ Just mid -> ["--model", Text.unpack mid] -- | Codex receives reasoning effort through a config override and--- accepts all six canonical Baikai levels, so there is no clamp here —+-- accepts all seven canonical Baikai levels, so there is no clamp here — -- unlike Claude, whose @--effort@ has no @minimal@ value. The -- provider-only @none@ and @ultra@ values remain available through raw -- provider arguments.@@ -206,7 +206,7 @@ ["-c", "model_reasoning_effort=" <> Text.unpack (codexEffortValue lvl)] -- | The word codex's @model_reasoning_effort@ override receives. Codex--- accepts all six baikai levels verbatim, which makes this the identity.+-- accepts all seven baikai levels verbatim, which makes this the identity. codexEffortValue :: ThinkingLevel -> Text codexEffortValue = renderThinkingLevel
src/Baikai/Provider/OpenAI/Cli.hs view
@@ -188,7 +188,7 @@ ) -- | Render Codex's reasoning-effort config override from--- 'Options.thinking'. Codex accepts all six Baikai levels verbatim;+-- 'Options.thinking'. Codex accepts all seven Baikai levels verbatim; -- when 'thinking' is unset, no override is emitted. effortArgs :: Options -> [String] effortArgs opts = case opts ^. #thinking of@@ -196,7 +196,7 @@ Just lvl -> ["-c", "model_reasoning_effort=" <> Text.unpack (codexEffortValue lvl)] -- | The word codex's @model_reasoning_effort@ override receives. Codex--- accepts all six baikai levels verbatim, which makes this the identity+-- accepts all seven baikai levels verbatim, which makes this the identity -- — and makes it the one transport in baikai that expresses every level -- exactly. codexEffortValue :: ThinkingLevel -> Text
+ src/Baikai/Provider/OpenAI/Internal/Cache.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedRecordDot #-}++-- | Internal native cache planning and terminal pricing. One prepared policy+-- supplies the wire controls, prefix placement and effective billing duration.+module Baikai.Provider.OpenAI.Internal.Cache+ ( CachePlan (..),+ responsesCachePlan,+ chatCachePlan,+ cacheCost,+ )+where++import Baikai.CacheRetention (CacheRetention (..))+import Baikai.Compat+import Baikai.Cost qualified as C+import Baikai.Cost.Pricing qualified as Pricing+import Baikai.Model qualified as M+import Baikai.Options (Options (..))+import Baikai.Usage qualified as U+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson.Key (Key)+import Data.Text (Text)++data CachePlan = CachePlan+ { cacheFields :: ![(Key, Value)],+ markPrefix :: !Bool,+ effectiveRetention :: !(Maybe CacheRetention)+ }+ deriving stock (Eq, Show)++responsesCachePlan :: M.Model -> Options -> Either Text CachePlan+responsesCachePlan m opts = do+ let c = M.openaiResponsesCompatFor m+ -- Absent metadata preserves the prior Responses mappings, but never+ -- invents explicit breakpoint support.+ policy = case c.nativeCachePolicy of+ Just p -> p+ Nothing+ | c.supportsPromptCacheOptions -> NativeCacheModern False False+ | otherwise -> NativeCacheLegacy True c.supportsLongCacheRetention+ plan m Nothing (Just policy) opts++chatCachePlan :: M.Model -> Options -> Either Text CachePlan+chatCachePlan m opts =+ let c = M.openaiCompletionsCompatFor m+ in do+ native <- plan m c.cacheControlFormat c.nativeCachePolicy opts+ -- The existing compatible-host downgrade is an independent wire contract.+ pure $ case (c.cacheControlFormat, opts.cacheRetention) of+ (Just CacheControlFormatAnthropic, Just CacheRetentionShort) -> native {effectiveRetention = Just CacheRetentionShort}+ (Just CacheControlFormatAnthropic, Just CacheRetentionLong) -> native {effectiveRetention = Just (if c.supportsLongCacheRetention then CacheRetentionLong else CacheRetentionShort)}+ _ -> native++plan :: M.Model -> Maybe CacheControlFormat -> Maybe NativeCachePolicy -> Options -> Either Text CachePlan+plan m format policy opts = named $ do+ validateNativeCachePolicy format policy+ case M.pricingPolicy m of+ Just p -> M.validatePricingPolicy p+ Nothing -> Right ()+ case policy of+ Just (NativeCacheModern True _) -> requireLongRates+ _ -> Right ()+ case opts.cacheRetention of+ Nothing -> pure absent+ Just CacheRetentionNone -> pure absent+ Just requested -> case policy of+ Nothing -> pure absent -- native Chat is opt-in through endpoint facts+ Just NativeCacheUnsupported -> refuse+ Just (NativeCacheLegacy short long) -> case requested of+ CacheRetentionShort | short -> legacy "in_memory"+ CacheRetentionLong | long -> legacy "24h"+ _ -> refuse+ Just (NativeCacheModern long prefix) -> case requested of+ CacheRetentionShort -> modern "30m" prefix CacheRetentionShort+ CacheRetentionLong | long -> modern "12h" prefix CacheRetentionLong+ _ -> refuse+ where+ named = either (Left . ((M.modelId m <> ": ") <>)) Right+ absent = CachePlan [] False $ case policy of+ Just (NativeCacheModern _ _) -> Just CacheRetentionShort+ _ -> Nothing+ refuse = Left "native cache policy cannot honor requested retention"+ -- Legacy 24h has no duration premium. Always resolve base write prices.+ legacy ttl = pure (CachePlan [("prompt_cache_retention", String ttl)] False (Just CacheRetentionShort))+ modern ttl prefix duration = pure (CachePlan [("prompt_cache_options", object ["ttl" .= (ttl :: Text)])] prefix (Just duration))+ requireLongRates = case M.pricingPolicy m of+ Just p+ | Just _ <- p.longCacheWriteCost,+ all (\t -> t.longCacheWriteCost /= Nothing) p.inputTiers ->+ Right ()+ _ -> Left "modern Long requires base and every tier long cache-write rates"++-- | Unknown duration remains an explicit estimate only when it matters to+-- reported writes. Do not infer duration from a read counter.+cacheCost :: Maybe CacheRetention -> M.Model -> U.Usage -> C.Cost+cacheCost duration m usage = C.estimateCost reasons (Pricing.computeCostForService duration Nothing m usage)+ where+ reasons = [C.CacheDurationNotReported | duration == Nothing, usage.cacheWriteTokens > 0, durationSensitive]+ durationSensitive = case m.pricingPolicy of+ Nothing -> False+ Just p -> p.longCacheWriteCost /= Nothing || any (\t -> t.longCacheWriteCost /= Nothing) p.inputTiers
src/Baikai/Provider/OpenAI/Internal/Request.hs view
@@ -21,6 +21,7 @@ import Baikai.Message qualified as Msg import Baikai.Model (Model, openaiCompletionsCompatFor) import Baikai.Options (Options (..))+import Baikai.Provider.OpenAI.Internal.Cache qualified as Cache import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort) import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) import Baikai.ThinkingLevel (ThinkingLevel (..))@@ -51,6 +52,7 @@ mapRequest :: Model -> Context -> Options -> Either Text Chat.CreateChatCompletion mapRequest m ctx opts = do+ _ <- Cache.chatCachePlan m opts either (Left . Error.message) pure (Context.refuseAssistantDataHistory ctx) let capability = openaiCompletionsCompatFor m forced = case opts ^. #toolChoice of@@ -176,6 +178,7 @@ toReasoningEffort :: ThinkingLevel -> Chat.ReasoningEffort toReasoningEffort = \case+ ThinkingNone -> Chat.ReasoningEffort_None ThinkingMinimal -> Chat.ReasoningEffort_Minimal ThinkingLow -> Chat.ReasoningEffort_Low ThinkingMedium -> Chat.ReasoningEffort_Medium
src/Baikai/Provider/OpenAI/Internal/Stream.hs view
@@ -42,11 +42,11 @@ ) where +import Baikai.CacheRetention (CacheRetention) import Baikai.Compat (OpenAICompletionsCompat (requiresThinkingAsText)) import Baikai.Content qualified as Content import Baikai.Context (Context (..)) import Baikai.Context qualified as Context-import Baikai.Cost.Pricing qualified as Pricing import Baikai.Error (BaikaiError, contentFiltered, invalidRequest, providerError) import Baikai.Evidence qualified as Ev import Baikai.Evidence.Build qualified as Build@@ -60,10 +60,11 @@ pushFrame, withFrameWorker, )+import Baikai.Provider.OpenAI.Internal.Cache qualified as Cache 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.Shape (applyNativeCache, describeThinkingShape, streamRequestBody) import Baikai.Provider.OpenAI.Sse (ResponseMetadata, capturedHeaderNames, openaiSseStreamValueWithHeaders) import Baikai.Provider.OpenAI.Transport qualified as Transport import Baikai.StopReason qualified as Stop@@ -170,7 +171,7 @@ ProducerState { chan = q, pending = [EventStart StartPayload {partial = skeletonStart m startTime, responseId = Nothing}],- assembler = emptyAssembler m startTime,+ assembler = emptyAssembler m startTime & #effectiveRetention .~ (call ^. #effectiveRetention), finished = False, terminalRef = tref, metadataRef = mref,@@ -205,7 +206,8 @@ -- request, as 'streamRequestBody' described it. Carried from here -- rather than recomputed at the terminal: only the shaping step -- knows which of the seven host wire shapes was used.- thinking :: !Ev.ThinkingTranslation+ thinking :: !Ev.ThinkingTranslation,+ effectiveRetention :: !(Maybe CacheRetention) } deriving stock (Generic) @@ -221,33 +223,38 @@ | Left e <- Context.refuseAssistantDataHistory ctx = pure (Left e) | otherwise = case mapRequest m ctx opts of Left e -> pure (Left (invalidRequest e))- Right req -> do- let url = resolvedBaseUrl m- -- Checked before the key is resolved, so a base URL baikai will not- -- send to never causes a credential to be read out of the- -- environment. The message names the problem and what to write- -- instead; it renders the URL without its userinfo or query, so an- -- error reaching a log cannot carry a key someone put in either.- case Url.baseUrlProblem url of- Just problem ->- pure (Left (invalidRequest ("Model.baseUrl is not usable: " <> problem)))- Nothing -> do- key <- Transport.resolveKey url opts- env <- Transport.getClientEnvCached url- let compat = openaiCompletionsCompatFor m- (body, translation) = streamRequestBody compat (m ^. #reasoning) opts req- headers = Transport.requestHeaders key m opts- pure- ( Right- OpenAICall- { clientEnv = env,- requestHeaders = headers,- timeoutMs = opts ^. #timeoutMs,- requestBody = body,- baseUrl = url,- thinking = translation- }- )+ Right req -> case Cache.chatCachePlan m opts of+ Left err -> pure (Left (invalidRequest err))+ Right cache -> prepare req cache+ where+ prepare req cache = do+ let url = resolvedBaseUrl m+ -- Checked before the key is resolved, so a base URL baikai will not+ -- send to never causes a credential to be read out of the+ -- environment. The message names the problem and what to write+ -- instead; it renders the URL without its userinfo or query, so an+ -- error reaching a log cannot carry a key someone put in either.+ case Url.baseUrlProblem url of+ Just problem ->+ pure (Left (invalidRequest ("Model.baseUrl is not usable: " <> problem)))+ Nothing -> do+ key <- Transport.resolveKey url opts+ env <- Transport.getClientEnvCached url+ let compat = openaiCompletionsCompatFor m+ (body, translation) = streamRequestBody compat (m ^. #reasoning) opts req+ headers = Transport.requestHeaders key m opts+ pure+ ( Right+ OpenAICall+ { clientEnv = env,+ requestHeaders = headers,+ timeoutMs = opts ^. #timeoutMs,+ requestBody = applyNativeCache cache body,+ baseUrl = url,+ thinking = translation,+ effectiveRetention = Cache.effectiveRetention cache+ }+ ) -- | A loose summary of one streamed chunk. The raw 'Aeson.Value' is -- pre-parsed into the fields we care about; unknown fields are@@ -800,6 +807,7 @@ -- between them produces 0, 1, 2, … in the order the host sent them, -- which is the order reassembly rebuilds the message in. nextContentIndex :: !Int,+ effectiveRetention :: !(Maybe CacheRetention), usage :: !Usage.Usage, stopReason :: !Stop.StopReason, -- | 'True' once a chunk carrying @finish_reason@ has been@@ -858,6 +866,7 @@ toolArgs = IntMap.empty, closed = IntMap.empty, nextContentIndex = 0,+ effectiveRetention = Nothing, usage = Usage.zeroUsage, stopReason = Stop.Stop, finishSeen = False,@@ -1229,8 +1238,8 @@ -- cannot report different numbers for the same call. finalUsage :: Assembler -> Usage.Usage finalUsage ass =- 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+ let usageBare = Billing.checkCacheDuration Billing.ChatUsage (ass ^. #effectiveRetention) (ass ^. #usageSnapshot) $ Usage.observeBilling (map Usage.BillingServiceTier (Set.toList (ass ^. #serviceTiers))) (if ass ^. #usageReported then ass ^. #usage else Billing.unreportedUsage)+ in usageBare & #cost .~ Cache.cacheCost (ass ^. #effectiveRetention) (ass ^. #model) usageBare finalMessage :: Assembler -> UTCTime -> Maybe Text -> Stop.StopReason -> Msg.Message
src/Baikai/Provider/OpenAI/Internal/Usage.hs view
@@ -4,8 +4,9 @@ -- 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+module Baikai.Provider.OpenAI.Internal.Usage (UsageEndpoint (..), readUsage, unreportedUsage, mergeUsage, checkCacheDuration) where +import Baikai.CacheRetention (CacheRetention (..)) import Baikai.Usage qualified as U import Baikai.Usage.Normalize qualified as N import Data.Aeson (Value (..))@@ -53,3 +54,29 @@ merge Null previous = previous merge (Object newer) (Object previous) = Object (KM.unionWith merge newer previous) merge newer _ = newer++-- | Duration counters are a consistency check, never extra aggregate writes.+-- Missing subcategories stay missing across partial cumulative snapshots.+checkCacheDuration :: UsageEndpoint -> Maybe CacheRetention -> Maybe Value -> U.Usage -> U.Usage+checkCacheDuration endpoint duration raw usage =+ usage {U.availability = (\a -> a {U.inconsistent = U.inconsistent a || bad}) <$> U.availability usage}+ where+ inputKey = case endpoint of ChatUsage -> "prompt_tokens_details"; ResponsesUsage -> "input_tokens_details"+ details = raw >>= field inputKey >>= field "cache_write_tokens_details"+ shortRaw = details >>= field "ttl_30m_tokens"+ longRaw = details >>= field "ttl_12h_tokens"+ totalRaw = raw >>= field inputKey >>= field "cache_write_tokens"+ short = shortRaw >>= count+ long = longRaw >>= count+ total = totalRaw >>= count+ bad =+ (case details of Just (Object _) -> False; Just _ -> True; Nothing -> False)+ || any (\v -> isJust v && isNothing (v >>= count)) [shortRaw, longRaw]+ || (case total of Just t -> maybe 0 id short + maybe 0 id long > t; Nothing -> False)+ || (maybe False (> 0) short && maybe False (> 0) long)+ || (case (short, long, total) of (Just s, Just l, Just t) -> s + l /= t; _ -> False)+ || (case duration of Just CacheRetentionShort -> maybe False (> 0) long; Just CacheRetentionLong -> maybe False (> 0) short; _ -> False)+ field k (Object o) = case KM.lookup k o of Just Null -> Nothing; v -> v+ field _ _ = Nothing+ count (Number n) | n >= 0, fromInteger (floor n) == n = Just (fromInteger (floor n) :: Natural)+ count _ = Nothing
src/Baikai/Provider/OpenAI/Responses/Request.hs view
@@ -26,6 +26,7 @@ import Baikai.Message qualified as M import Baikai.Model (Model, api, maxOutputTokens, modelId, openaiResponsesCompatFor, reasoning) import Baikai.Options (Options (..))+import Baikai.Provider.OpenAI.Internal.Cache qualified as Cache import Baikai.Provider.OpenAI.Shape (resolveSupportedEffort) import Baikai.ResponseFormat (JsonSchemaFormat (..), ResponseFormat (..)) import Baikai.ThinkingLevel (renderThinkingLevel)@@ -51,7 +52,8 @@ -- No Show instance: a prepared body can contain opaque continuation. data PreparedRequest = PreparedRequest { requestBody :: !Value,- translation :: !E.ThinkingTranslation+ translation :: !E.ThinkingTranslation,+ effectiveRetention :: !(Maybe CacheRetention) } deriving stock (Eq, Generic) @@ -71,14 +73,16 @@ 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+ cache <- Cache.responsesCachePlan m opts+ let marked = cache.markPrefix && maybe False (not . Text.null) ctx.systemPrompt+ prefix = [object ["role" .= ("developer" :: Text), "content" .= [object ["type" .= ("input_text" :: Text), "text" .= text, "prompt_cache_breakpoint" .= object ["mode" .= ("explicit" :: Text)]]]] | marked, Just text <- [ctx.systemPrompt]] 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.instructions = if marked then Nothing else ctx.systemPrompt, R.store = Just False, R.stream = Just True, R.include = Just (V.singleton "reasoning.encrypted_content"),@@ -88,9 +92,9 @@ 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+ extras = [("input", Aeson.toJSON (prefix <> items))] <> reasoning <> choice <> cache.cacheFields <> formatFields opts case base of- Object obj -> pure (PreparedRequest (Object (KM.union (KM.fromList extras) obj)) translation)+ Object obj -> pure (PreparedRequest (Object (KM.union (KM.fromList extras) obj)) translation cache.effectiveRetention) _ -> Left "Responses SDK request did not encode as an object" where metadataText (String t) | Text.length t <= 512 = Right t@@ -152,19 +156,6 @@ ] ) ]--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
src/Baikai/Provider/OpenAI/Responses/Stream.hs view
@@ -8,10 +8,10 @@ ) where +import Baikai.CacheRetention (CacheRetention) import Baikai.Content qualified as C import Baikai.Context (Context) import Baikai.Context qualified as 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@@ -19,6 +19,7 @@ import Baikai.Model (Model) import Baikai.Options (Options) import Baikai.Provider.Internal.StreamWorker+import Baikai.Provider.OpenAI.Internal.Cache qualified as Cache import Baikai.Provider.OpenAI.Internal.ErrorClass (classifyErrorFrame, classifyException) import Baikai.Provider.OpenAI.Internal.Stream (SseDriver) import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing@@ -84,13 +85,14 @@ 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+ initial = State q meta m req.effectiveRetention (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,+ effectiveRetention :: !(Maybe CacheRetention), assembler :: !A.Assembler, observed :: !(Maybe Value), pending :: ![E.AssistantMessageEvent],@@ -130,7 +132,7 @@ Nothing -> (s.assembler, []) Just _ -> A.closePartial s.assembler reason = maybe (fromMaybe Stop (A.terminalReason assembled)) (const ErrorReason) err- usage = responseUsage s.model s.observed+ usage = responseUsage s.model s.effectiveRetention s.observed payload = M.AssistantPayload (A.assembledContent assembled) usage reason (fmap (^. #message) err) (Just now) msg = M.AssistantMessage payload rid = s.observed >>= textField "id"@@ -169,10 +171,10 @@ 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+responseUsage :: Model -> Maybe CacheRetention -> Maybe Value -> U.Usage+responseUsage m duration raw =+ let normalized = Billing.checkCacheDuration Billing.ResponsesUsage duration (raw >>= lookupField "usage") $ U.observeBilling [U.BillingServiceTier tier | Just tier <- [raw >>= textField "service_tier"]] (fromMaybe Billing.unreportedUsage (raw >>= lookupField "usage" >>= Billing.readUsage Billing.ResponsesUsage))+ in normalized & #cost .~ Cache.cacheCost duration m normalized observe :: Ev.CallStatus -> Maybe ResponseMetadata -> Maybe Value -> M.AssistantPayload -> Ev.ModelCallEvidence -> Ev.ModelCallEvidence observe status md raw payload ev =
src/Baikai/Provider/OpenAI/Shape.hs view
@@ -15,6 +15,7 @@ describeThinkingShape, resolveSupportedEffort, injectCacheControl,+ applyNativeCache, ) where @@ -40,6 +41,7 @@ noThinkingRequested, ) import Baikai.Options (Options, cacheRetention, temperature, thinking, topP)+import Baikai.Provider.OpenAI.Internal.Cache (CachePlan (..)) import Baikai.ThinkingLevel (ThinkingLevel (..), renderThinkingLevel) import Control.Lens ((%~), (&), (^.)) import Data.Aeson (Value (..), (.=))@@ -50,6 +52,7 @@ import Data.Generics.Labels () import Data.Maybe (isJust) import Data.Text (Text)+import Data.Text qualified as Text import Data.Vector (Vector) import Data.Vector qualified as Vector import OpenAI.V1.Chat.Completions qualified as Chat@@ -164,7 +167,8 @@ -- | 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.+-- Invalid empty policies are rejected by request validation. A policy+-- that does not list @none@ resolves it to its lowest level. resolveSupportedEffort :: Maybe [ThinkingLevel] -> ThinkingLevel -> ThinkingLevel resolveSupportedEffort Nothing lvl = lvl resolveSupportedEffort (Just []) lvl = lvl@@ -226,11 +230,11 @@ effortTranslation lvl e "reasoning_effort" ) ThinkingFormatZai ->- ( insertTop "enable_thinking" (Bool True) body,+ ( insertTop "enable_thinking" (Bool (lvl /= ThinkingNone)) body, toggleTranslation lvl ) ThinkingFormatQwen ->- ( insertTop "enable_thinking" (Bool True) body,+ ( insertTop "enable_thinking" (Bool (lvl /= ThinkingNone)) body, toggleTranslation lvl ) @@ -275,7 +279,8 @@ -- Every level collapses, including the ones whose canonical name a -- richer host would have accepted, because the wire carries no depth: -- a caller asking for @max@ and a caller asking for @low@ produce--- byte-identical requests here.+-- byte-identical requests here. @none@ is the one level such a host+-- expresses exactly: it sends @enable_thinking: false@. toggleTranslation :: ThinkingLevel -> ThinkingTranslation toggleTranslation lvl = ThinkingTranslation@@ -285,7 +290,7 @@ budgetTokens = Nothing, wireField = Just "enable_thinking", displayText = Nothing,- adjustments = [EffortCollapsedToToggle lvl]+ adjustments = [EffortCollapsedToToggle lvl | lvl /= ThinkingNone] } injectCacheControl :: OpenAICompletionsCompat -> Options -> Aeson.Value -> Aeson.Value@@ -390,12 +395,35 @@ key = AesonKey.fromText -- | Common effort vocabulary supported by the non-native--- OpenAI-compatible request shapes above.+-- OpenAI-compatible request shapes above. It has no word for no+-- reasoning, so @none@ clamps to @low@ and the clamp is recorded. compatibleEffort :: ThinkingLevel -> Text compatibleEffort = \case+ ThinkingNone -> "low" ThinkingMinimal -> "low" ThinkingLow -> "low" ThinkingMedium -> "medium" ThinkingHigh -> "high" ThinkingXHigh -> "high" ThinkingMax -> "high"++-- | Apply the already validated native plan. Only the initial instruction+-- message can carry the prefix marker; all later history stays byte-for-byte.+applyNativeCache :: CachePlan -> Value -> Value+applyNativeCache plan = mapObject $ \o ->+ let fields = KeyMap.union (KeyMap.fromList (cacheFields plan)) o+ in if markPrefix plan then adjustKey "messages" markInitial fields else fields+ where+ markInitial (Array xs) = case Vector.uncons xs of+ Just (Object first, rest)+ | KeyMap.lookup "role" first `elem` [Just (String "system"), Just (String "developer")],+ Just text <- instructionText =<< KeyMap.lookup "content" first,+ not (Text.null text) ->+ Array (Vector.cons (Object (KeyMap.insert "content" (Aeson.toJSON [Aeson.object ["type" .= ("text" :: Text), "text" .= text, "prompt_cache_breakpoint" .= Aeson.object ["mode" .= ("explicit" :: Text)]]]) first)) rest)+ _ -> Array xs+ markInitial v = v+ instructionText (String text) = Just text+ instructionText (Array xs) = case Vector.toList xs of+ [Object part] | KeyMap.lookup "type" part == Just (String "text"), Just (String text) <- KeyMap.lookup "text" part -> Just text+ _ -> Nothing+ instructionText _ = Nothing
test/BillingSpec.hs view
@@ -3,6 +3,7 @@ module BillingSpec (tests) where import Baikai qualified as B+import Baikai.CacheRetention (CacheRetention (..)) import Baikai.Cost qualified as C import Baikai.Cost.Pricing (computeCost) import Baikai.Evidence (commitmentDigest, usageEnvelope)@@ -25,7 +26,17 @@ tests = testGroup "Billing normalization"- [ testCase "Chat observes the reported tier and discloses unsupported pricing" $+ [ testCase "duration details remain consistency checks across cumulative snapshots" $ do+ let base = wire ResponsesUsage 1000 ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (200 :: Int)]+ details short long = object ["input_tokens_details" .= object ["cache_write_tokens_details" .= object ["ttl_30m_tokens" .= (short :: Int), "ttl_12h_tokens" .= (long :: Int)]]]+ forM_ [(200, 0, False), (200, 1, True), (199, 0, True), (-1, 0, True)] $ \(s, l, bad) -> do+ let merged = mergeUsage (Just base) (Just (details s l))+ mergeUsage merged (Just (details s l)) @?= merged+ u <- maybe (assertFailure "missing usage") (parsed ResponsesUsage) merged+ let checked = checkCacheDuration ResponsesUsage (Just CacheRetentionShort) merged u+ checked.cacheWriteTokens @?= 200+ U.inconsistent <$> checked.availability @?= Just bad,+ 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)
test/Main.hs view
@@ -46,6 +46,7 @@ import EvidenceSpec qualified import LifecycleSpec qualified import MidStreamSpec qualified+import NativeCacheSpec qualified import OpenAI.V1.Chat.Completions qualified as Chat import OpenAI.V1.ResponseFormat qualified as RF import PublicSurfaceSpec qualified@@ -72,7 +73,8 @@ defaultMain $ testGroup "Baikai.Provider.OpenAI"- [ DataInputSpec.tests,+ [ NativeCacheSpec.tests,+ DataInputSpec.tests, commandRenderingTest, effortRenderingTests, safetyRefusalTest,@@ -405,7 +407,8 @@ "--ephemeral" ] | (name, level, expected) <-- [ ("minimal", ThinkingMinimal, "minimal"),+ [ ("none", ThinkingNone, "none"),+ ("minimal", ThinkingMinimal, "minimal"), ("low", ThinkingLow, "low"), ("medium", ThinkingMedium, "medium"), ("high", ThinkingHigh, "high"),@@ -796,7 +799,8 @@ ["-c", "model_reasoning_effort=" <> expected, "--", "prompt"] ) | (name, level, expected) <-- [ ("minimal", ThinkingMinimal, "minimal"),+ [ ("none", ThinkingNone, "none"),+ ("minimal", ThinkingMinimal, "minimal"), ("low", ThinkingLow, "low"), ("medium", ThinkingMedium, "medium"), ("high", ThinkingHigh, "high"),
+ test/NativeCacheSpec.hs view
@@ -0,0 +1,216 @@+{-# LANGUAGE OverloadedRecordDot #-}++module NativeCacheSpec (tests) where++import Baikai hiding (model)+import Baikai.Compat (NativeCachePolicy (..), nativeCachePolicy)+import Baikai.Models.Generated qualified as Models+import Baikai.Provider.OpenAI.Internal.Cache qualified as Cache+import Baikai.Provider.OpenAI.Internal.Stream qualified as Chat+import Baikai.Provider.OpenAI.Internal.Usage qualified as Billing+import Baikai.Provider.OpenAI.Responses.Request qualified as Responses+import Baikai.Provider.OpenAI.Responses.Stream qualified as Responses+import Baikai.Provider.OpenAI.Shape qualified as Shape+import Control.Lens ((&), (.~))+import Control.Monad (forM_)+import Data.Aeson (Value (..), object, (.=))+import Data.Aeson qualified as A+import Data.Aeson.KeyMap qualified as KM+import Data.IORef+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import Streamly.Data.Stream qualified as Stream+import Test.Tasty+import Test.Tasty.HUnit++tests :: TestTree+tests =+ testGroup+ "native cache contract"+ [ testCase "verified Luna Long plan emits 12h with published duration rates" $ do+ let m = Models.openai_gpt_6_luna+ plan <- right (Cache.responsesCachePlan m (short & #cacheRetention .~ Just CacheRetentionLong))+ Cache.cacheFields plan @?= [("prompt_cache_options", object ["ttl" .= ("12h" :: Text)])]+ Cache.effectiveRetention plan @?= Just CacheRetentionLong+ Cache.markPrefix plan @?= True+ forM_ [(272000, 17 / 250), (272001, 272001 / 2000000)] $ \(count, expected) -> do+ let u = observeBilling [BillingServiceTier "default"] (zeroUsage & #cacheWriteTokens .~ count & #totalTokens .~ count)+ (Cache.cacheCost (Just CacheRetentionLong) m u).usd @?= expected,+ testCase "Responses preserves exactly one identical prefix across fresh questions" $ do+ a <- mapped (systemUser "private prefix" "first") short+ b <- mapped (systemUser "private prefix" "second") short+ field "instructions" a.requestBody @?= Nothing+ field "store" a.requestBody @?= Just (Bool False)+ take 1 (items a.requestBody) @?= take 1 (items b.requestBody)+ assertBool "questions differ" (drop 1 (items a.requestBody) /= drop 1 (items b.requestBody))+ head (items a.requestBody) @?= developer "private prefix"+ a.effectiveRetention @?= Just CacheRetentionShort,+ testCase "absent/None controls preserve wire; default duration is known only for modern policy" $ do+ forM_ [Nothing, Just CacheRetentionNone] $ \preference -> do+ r <- mapped (systemUser "prefix" "question") (emptyOptions & #cacheRetention .~ preference)+ field "instructions" r.requestBody @?= Just (String "prefix")+ field "prompt_cache_options" r.requestBody @?= Nothing+ length (items r.requestBody) @?= 1+ r.effectiveRetention @?= Just CacheRetentionShort,+ testCase "missing/empty system never becomes an empty cacheable block" $+ forM_ [Nothing, Just ""] $ \prompt -> do+ r <- mapped (contextOf [user "question"] & #systemPrompt .~ prompt) short+ length (items r.requestBody) @?= 1,+ testCase "marker survives tool continuation with opaque reasoning unchanged" $ do+ let opaque = object ["type" .= ("reasoning" :: Text), "id" .= ("rs" :: Text), "summary" .= ([] :: [Value]), "encrypted_content" .= ("SECRET_REPLAY" :: Text)]+ thought = emptyThinkingContent & #replayState .~ Just (ThinkingReplay OpenAIResponses model.modelId (V.singleton opaque))+ response = emptyResponse & #message . #content .~ V.fromList [AssistantThinking thought, AssistantToolCall (ToolCall "call" "lookup" (object []))] & #message . #stopReason .~ ToolUse+ next <- appendToolResult (systemUser "prefix" "question") response (\_ -> pure (toolResultText "result"))+ req <- mapped next short+ take 1 (items req.requestBody) @?= [developer "prefix"]+ items req.requestBody !! 2 @?= opaque+ field "call_id" (items req.requestBody !! 4) @?= Just (String "call"),+ testCase "native Chat marks only initial instructions and retains their role" $ do+ plan <- right (Cache.chatCachePlan chatModel short)+ forM_ ["system", "developer"] $ \role -> do+ let first = object ["role" .= (role :: Text), "content" .= ("prefix" :: Text)]+ rest = [object ["role" .= ("user" :: Text), "content" .= ("question" :: Text)], first]+ body = Shape.applyNativeCache plan (object ["messages" .= (first : rest), "tools" .= ([] :: [Value])])+ field "messages" body @?= Just (A.toJSON (object ["role" .= role, "content" .= [object ["type" .= ("text" :: Text), "text" .= ("prefix" :: Text), "prompt_cache_breakpoint" .= marker]]] : rest))+ field "prompt_cache_options" body @?= Just (object ["ttl" .= ("30m" :: Text)]),+ testCase "legacy native controls accept exactly the declared values and have no premium" $ do+ let legacy policy = chatModel & #compat .~ CompatOpenAICompletions (defaultOpenAICompletionsCompat & #nativeCachePolicy .~ Just policy)+ forM_ [(NativeCacheLegacy True True, CacheRetentionShort, "in_memory"), (NativeCacheLegacy True True, CacheRetentionLong, "24h"), (NativeCacheLegacy False True, CacheRetentionLong, "24h")] $ \(policy, pref, ttl) -> do+ plan <- right (Cache.chatCachePlan (legacy policy) (emptyOptions & #cacheRetention .~ Just pref))+ Cache.cacheFields plan @?= [("prompt_cache_retention", String ttl)]+ Cache.markPrefix plan @?= False+ Cache.effectiveRetention plan @?= Just CacheRetentionShort+ assertLeft (Cache.chatCachePlan (legacy (NativeCacheLegacy False True)) short),+ testCase "absent Responses policy preserves legacy mappings; explicit unsupported wins" $ do+ let base = model & #compat .~ CompatOpenAIResponses defaultOpenAIResponsesCompat+ unsupported = model & #compat .~ CompatOpenAIResponses (defaultOpenAIResponsesCompat & #supportsPromptCacheOptions .~ True & #nativeCachePolicy .~ Just NativeCacheUnsupported)+ p <- right (Cache.responsesCachePlan base short)+ Cache.cacheFields p @?= [("prompt_cache_retention", String "in_memory")]+ Cache.markPrefix p @?= False+ assertLeft (Cache.responsesCachePlan unsupported short),+ testCase "public complete/stream dispatch both endpoints through the same prepared prefix" $+ forM_ [model, chatModel] $ \m -> do+ sent <- newIORef []+ let driver _ _ body _ emit = do+ modifyIORef' sent (<> [body])+ emit (Right (terminal m))+ handler = if m.api == OpenAIResponses then Responses.openaiResponsesStreamWith driver else Chat.openaiChatStreamWith driver+ reg <- newProviderRegistryFrom [apiProvider m.api handler]+ let opts = short & #apiKey .~ Just (ApiKeyLiteral "offline")+ a <- completeRequestWith reg m (systemUser "prefix" "first") opts+ responseError a @?= Nothing+ es <- Stream.toList (streamRequestWith reg m (systemUser "prefix" "second") opts)+ assertBool "stream completes" (case last es of EventDone _ -> True; _ -> False)+ bodies <- readIORef sent+ length bodies @?= 2+ let key = if m.api == OpenAIResponses then "input" else "messages"+ initial body = case field key body of Just (Array xs) -> V.head xs; _ -> Null+ map initial bodies @?= replicate 2 (initial (head bodies))+ assertBool "wire contains explicit marker" ("prompt_cache_breakpoint" `T.isInfixOf` T.pack (show (initial (head bodies)))),+ testCase "public refusals precede invalid credentials and driver for both endpoints" $+ forM_ [model, chatModel] $ \m -> do+ let driver _ _ _ _ _ = assertFailure "driver must not run"+ handler = if m.api == OpenAIResponses then Responses.openaiResponsesStreamWith driver else Chat.openaiChatStreamWith driver+ opts = short & #cacheRetention .~ Just CacheRetentionLong & #apiKey .~ Just (ApiKeyEnv "BAIKAI_CACHE_TEST_MISSING_KEY")+ reg <- newProviderRegistryFrom [apiProvider m.api handler]+ r <- completeRequestWith reg m emptyContext opts+ assertBool "model-named local refusal" (maybe False (\e -> T.isInfixOf m.modelId e.message) (responseError r))+ events <- Stream.toList (streamRequestWith reg m emptyContext opts)+ assertBool "stream refuses" (case last events of EventError _ -> True; _ -> False),+ testCase "contradictory controls and missing long prices fail locally" $ do+ let bad = chatModel & #compat .~ CompatOpenAICompletions (defaultOpenAICompletionsCompat & #cacheControlFormat .~ Just CacheControlFormatAnthropic & #nativeCachePolicy .~ Just (NativeCacheModern False True))+ longModel = model & #compat .~ CompatOpenAIResponses (defaultOpenAIResponsesCompat & #nativeCachePolicy .~ Just (NativeCacheModern True True))+ assertLeft (Cache.chatCachePlan bad short)+ forM_ [Nothing, Just (PricingPolicy [] Nothing), Just (PricingPolicy [InputPriceTier 100 (ModelCost 2 3 1 2) Nothing] (Just 4))] $ \policy ->+ assertLeft (Cache.responsesCachePlan (longModel & #pricingPolicy .~ policy) (short & #cacheRetention .~ Just CacheRetentionLong)),+ testCase "synthetic long/short pricing reaches both successful and partial-error terminals" $+ forM_ [model, chatModel] $ \base -> forM_ [CacheRetentionShort, CacheRetentionLong] $ \duration -> forM_ [False, True] $ \failed -> do+ let m =+ base+ & #cost .~ ModelCost 1 2 (1 / 10) (5 / 4)+ & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 100 (ModelCost 2 4 (1 / 5) (5 / 2)) (Just 5)] (Just (5 / 2)))+ & #compat+ .~ ( if base.api == OpenAIResponses+ then CompatOpenAIResponses (defaultOpenAIResponsesCompat & #nativeCachePolicy .~ Just (NativeCacheModern True True))+ else CompatOpenAICompletions (defaultOpenAICompletionsCompat & #nativeCachePolicy .~ Just (NativeCacheModern True True))+ )+ isResponses = m.api == OpenAIResponses+ (ik, ok, dk) = if isResponses then ("input_tokens", "output_tokens", "input_tokens_details") else ("prompt_tokens", "completion_tokens", "prompt_tokens_details")+ input = object [ik .= (1000 :: Int), dk .= object ["cached_tokens" .= (100 :: Int), "cache_write_tokens" .= (200 :: Int)]]+ output = object [ok .= (10 :: Int)]+ frame usage = if isResponses then object ["type" .= ("response.in_progress" :: Text), "response" .= object ["service_tier" .= ("default" :: Text), "usage" .= usage]] else object ["service_tier" .= ("default" :: Text), "usage" .= usage, "choices" .= ([] :: [Value])]+ driver _ _ _ _ emit = do+ mapM_ (emit . Right . frame) [input, output, output]+ if failed then emit (Left (providerError "synthetic interruption")) else emit (Right (terminal m))+ handler = if isResponses then Responses.openaiResponsesStreamWith driver else Chat.openaiChatStreamWith driver+ opts = short & #cacheRetention .~ Just duration & #apiKey .~ Just (ApiKeyLiteral "offline") & #evidence .~ Just (evidenceRequest "synthetic-cache-billing")+ r <- streamingComplete handler m emptyContext opts+ let u = r.message.usage+ (u.inputTokens, u.cacheReadTokens, u.cacheWriteTokens, u.outputTokens, u.totalTokens) @?= (700, 100, 200, 10, 1010)+ u.cost.usd @?= if duration == CacheRetentionShort then 49 / 25000 else 123 / 50000+ u.cost.basis.estimateReasons @?= Set.empty+ case r.evidence of Just e -> e.usage @?= Observed u; Nothing -> assertFailure "missing terminal evidence",+ testCase "synthetic duration prices cross input tiers and unknown duration stays estimated" $ do+ let m = model & #cost .~ ModelCost 1 2 (1 / 10) (5 / 4) & #pricingPolicy .~ Just (PricingPolicy [InputPriceTier 100 (ModelCost 2 4 (1 / 5) (5 / 2)) (Just 5)] (Just (5 / 2)))+ u = observeBilling [BillingServiceTier "default"] (zeroUsage & #cacheWriteTokens .~ 200 & #totalTokens .~ 200)+ (Cache.cacheCost (Just CacheRetentionShort) m u).usd @?= 1 / 2000+ (Cache.cacheCost (Just CacheRetentionLong) m u).usd @?= 1 / 1000+ assertBool "duration estimate" (CacheDurationNotReported `Set.member` (Cache.cacheCost Nothing m u).basis.estimateReasons),+ testCase "duration details check totals and selected TTL without adding writes" $ do+ let usage = object ["input_tokens" .= (100 :: Int), "output_tokens" .= (1 :: Int), "input_tokens_details" .= object ["cached_tokens" .= (0 :: Int), "cache_write_tokens" .= (100 :: Int), "cache_write_tokens_details" .= object ["ttl_30m_tokens" .= (40 :: Int), "ttl_12h_tokens" .= (60 :: Int)]]]+ u <- maybe (assertFailure "usage absent") pure (Billing.readUsage Billing.ResponsesUsage usage)+ let checked = Billing.checkCacheDuration Billing.ResponsesUsage (Just CacheRetentionShort) (Just usage) u+ checked.cacheWriteTokens @?= 100+ inconsistent <$> checked.availability @?= Just True,+ testCase "configuration evidence keeps TTL and placement but excludes private payloads" $ do+ a <- mapped (systemUser "PRIVATE_PROMPT" "SECRET_QUERY") short+ let body = a.requestBody+ changed = case body of Object o -> Object (KM.insert "prompt_cache_options" (object ["ttl" .= ("12h" :: Text), "private" .= ("PRIVATE_NESTED" :: Text)]) o); _ -> body+ projected = T.pack (show (configurationProjection changed))+ forM_ ["PRIVATE_PROMPT", "SECRET_QUERY", "PRIVATE_NESTED"] $ \secret -> assertBool "no content leaked" (not (secret `T.isInfixOf` projected))+ assertBool "ttl changes configuration" (configurationDigest body /= configurationDigest changed)+ sameLength <- mapped (systemUser "REDACTED_VALUE" "HIDDEN_QUERY") short+ configurationDigest body @?= configurationDigest sameLength.requestBody+ ]++model :: Model+model =+ Models.openai_gpt_6_luna+ & #modelId .~ "renamed-responses"+ & #compat .~ CompatOpenAIResponses (openaiResponsesCompatFor Models.openai_gpt_6_luna & #nativeCachePolicy .~ Just (NativeCacheModern False True))++chatModel :: Model+chatModel = Models.openai_gpt_5_6 & #modelId .~ "renamed-chat"++short :: Options+short = emptyOptions & #cacheRetention .~ Just CacheRetentionShort++marker :: Value+marker = object ["mode" .= ("explicit" :: Text)]++developer :: Text -> Value+developer text = object ["role" .= ("developer" :: Text), "content" .= [object ["type" .= ("input_text" :: Text), "text" .= text, "prompt_cache_breakpoint" .= marker]]]++field :: A.Key -> Value -> Maybe Value+field k (Object o) = KM.lookup k o+field _ _ = Nothing++items :: Value -> [Value]+items body = case field "input" body of Just (Array xs) -> V.toList xs; _ -> []++mapped :: Context -> Options -> IO Responses.PreparedRequest+mapped ctx opts = right (Responses.mapRequest model ctx opts)++right :: Either Text a -> IO a+right = either (assertFailure . T.unpack) pure++assertLeft :: Either Text a -> IO ()+assertLeft (Left err) = assertBool "model named" ("renamed" `T.isInfixOf` err)+assertLeft (Right _) = assertFailure "expected refusal"++terminal :: Model -> Value+terminal m+ | m.api == OpenAIResponses = object ["type" .= ("response.completed" :: Text), "response" .= object ["id" .= ("resp" :: Text), "output" .= ([] :: [Value])]]+ | otherwise = object ["choices" .= [object ["delta" .= object [], "finish_reason" .= ("stop" :: Text)]]]
test/ResponsesSpec.hs view
@@ -21,7 +21,12 @@ tests = testGroup "Responses request mapping"- [ testCase "Sol, GPT-6.1 Sol, and Luna catalog bindings retain Responses shaping and replay identity" $+ [ testCase "none is preserved only for catalog models that accept it" $+ forM_ [(openai_gpt_6_sol, "none", []), (openai_gpt_6_luna, "none", []), (openai_gpt_6_astra, "low", [EffortClamped ThinkingNone "low"]), (openai_gpt_6_1_sol, "low", [EffortClamped ThinkingNone "low"])] $ \(m, wire, changes) -> do+ req <- mapped m emptyContext (emptyOptions & #thinking .~ Just ThinkingNone)+ field "reasoning" req.requestBody @?= Just (object ["effort" .= (wire :: Text)])+ req.translation.adjustments @?= changes,+ testCase "Sol, GPT-6.1 Sol, and Luna catalog bindings retain Responses shaping and replay identity" $ forM_ [openai_gpt_6_sol, openai_gpt_6_1_sol, openai_gpt_6_luna] $ \m -> do m.api @?= OpenAIResponses let opts = emptyOptions & #thinking .~ Just ThinkingLow & #temperature .~ Just 0.5 & #topP .~ Just 0.8@@ -76,14 +81,15 @@ 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+ testCase "every accepted effort survives; none and minimal adjust with evidence" $ do+ forM_ [ThinkingNone, ThinkingMinimal, ThinkingLow, ThinkingMedium, ThinkingHigh, ThinkingXHigh, ThinkingMax] $ \level -> do let opts = emptyOptions & #thinking .~ Just level- expected = if level == ThinkingMinimal then "low" else renderThinkingLevel level+ clamped = level < ThinkingLow+ expected = if clamped 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],+ req.translation.adjustments @?= [EffortClamped level "low" | clamped], 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
test/ShapeSpec.hs view
@@ -13,8 +13,9 @@ emptyAssembler, translate, )-import Baikai.Provider.OpenAI.Shape (streamRequestBody)+import Baikai.Provider.OpenAI.Shape (describeThinkingShape, streamRequestBody) import Control.Lens ((&), (.~), (^.))+import Control.Monad (forM_) import Data.Aeson (Value (..), (.=)) import Data.Aeson qualified as Aeson import Data.Aeson.Key qualified as AesonKey@@ -24,6 +25,7 @@ import Data.Time.Clock (UTCTime) import Data.Vector qualified as Vector import EndpointModels (chatRestrictedModel)+import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) @@ -31,7 +33,8 @@ tests = testGroup "ShapeSpec"- [ endpointPolicyTests,+ [ thinkingNoneTests,+ endpointPolicyTests, deepseekShapeTest, nativeHigherEffortTests, compatibleHigherEffortClampTest,@@ -148,7 +151,7 @@ lookupTop "reasoning_effort" value @?= Just (String "high") -- ============================================================--- The forty-two-row translation table+-- The forty-nine-row translation table -- ============================================================ -- | Every canonical level against every wire shape: what goes on the@@ -196,7 +199,8 @@ -- empty adjustment list means. effortRows :: [(ThinkingLevel, Text.Text, Text.Text, [ThinkingAdjustment])] effortRows =- [ (ThinkingMinimal, "minimal", "low", [EffortClamped ThinkingMinimal "low"]),+ [ (ThinkingNone, "none", "low", [EffortClamped ThinkingNone "low"]),+ (ThinkingMinimal, "minimal", "low", [EffortClamped ThinkingMinimal "low"]), (ThinkingLow, "low", "low", []), (ThinkingMedium, "medium", "medium", []), (ThinkingHigh, "high", "high", []),@@ -258,7 +262,8 @@ ) where -- Z.ai and Qwen carry no depth at all, so every level collapses --- -- including the ones a richer host would have accepted verbatim.+ -- including the ones a richer host would have accepted verbatim --+ -- except none, which a toggle expresses exactly by switching off. collapsed = ( ThinkingTranslation { requested = Just lvl,@@ -267,9 +272,9 @@ budgetTokens = Nothing, wireField = Just "enable_thinking", displayText = Nothing,- adjustments = [EffortCollapsedToToggle lvl]+ adjustments = [EffortCollapsedToToggle lvl | lvl /= ThinkingNone] },- [("enable_thinking", Bool True)],+ [("enable_thinking", Bool (lvl /= ThinkingNone))], ["reasoning_effort", "reasoning", "thinking"] ) @@ -526,3 +531,46 @@ ] where fake = chatRestrictedModel & #modelId .~ "arbitrary-generation"++-- Exercise serialization and the actual registry gate, not a duplicated mapper.+thinkingNoneTests :: TestTree+thinkingNoneTests =+ testGroup+ "explicit thinking off"+ [ testCase "Ollama-compatible localhost emits none; default omits the field" $ do+ let model = emptyModel & #api .~ OpenAIChatCompletions & #modelId .~ "qwen3:0.6b" & #baseUrl .~ "http://localhost:11434/v1" & #reasoning .~ True+ (body, translated) <- shapedCall model off emptyContext+ lookupTop "reasoning_effort" body @?= Just (String "none")+ translated ^. #requested @?= Just ThinkingNone+ translated ^. #effortText @?= Just "none"+ translated ^. #adjustments @?= []+ defaultBody <- shapedBody model emptyOptions emptyContext+ lookupTop "reasoning_effort" defaultBody @?= Nothing,+ testCase "catalog reasoning models never send an unsupported none" $+ forM_ [(Models.openai_gpt_5, "minimal"), (Models.openai_gpt_5_mini, "minimal"), (Models.openai_gpt_5_nano, "minimal"), (Models.openai_o1, "low"), (Models.openai_o3, "low"), (Models.openai_o3_mini, "low"), (Models.openai_o4_mini, "low")] $ \(model, wire) -> do+ (body, translated) <- shapedCall model off emptyContext+ lookupTop "reasoning_effort" body @?= Just (String wire)+ translated ^. #adjustments @?= [EffortClamped ThinkingNone wire],+ testCase "non-reasoning catalog model satisfies off without a field" $ do+ (body, translated) <- shapedCall Models.openai_gpt_4o_mini off emptyContext+ lookupTop "reasoning_effort" body @?= Nothing+ translated ^. #adjustments @?= [ThinkingDroppedUnsupportedModel ThinkingNone]+ checkEvidenceRequirements (EvidenceRequired EvidenceRequestedOnly) EvidenceModelObserved translated @?= [],+ testCase "strict complete and stream refuse off on a host with no controls before dispatch" $ do+ let model = emptyModel & #api .~ OpenAIChatCompletions & #reasoning .~ True & #compat .~ CompatOpenAICompletions (defaultOpenAICompletionsCompat {thinkingFormat = ThinkingFormatNone})+ opts = off & #evidence .~ Just (evidenceRequest "off" & #strictness .~ EvidenceRequired EvidenceRequestedOnly)+ describe m = describeThinkingShape (openaiCompletionsCompatFor m) (m ^. #reasoning)+ provider = apiProviderWith OpenAIChatCompletions (\_ _ _ -> error "stream dispatched") (\_ _ _ -> error "complete dispatched") & #describeThinking .~ describe & #strengthCeiling .~ EvidenceModelObserved+ reg <- newProviderRegistry+ registerApiProviderWith reg provider+ response <- completeRequestWith reg model emptyContext opts+ case responseError response of+ Just err -> err ^. #category @?= InvalidRequest+ Nothing -> assertFailure "strict off unexpectedly succeeded"+ events <- Stream.toList (streamRequestWith reg model emptyContext opts)+ case events of+ [EventStart _, EventError payload] -> (payload ^. #errorInfo) /= Nothing @?= True+ other -> assertFailure ("expected pre-dispatch stream refusal: " <> show other)+ ]+ where+ off = emptyOptions & #thinking .~ Just ThinkingNone