baikai-typesafe (empty) → 0.1.0.0
raw patch · 13 files changed
+1129/−0 lines, 13 filesdep +aesondep +baikaidep +baikai-typesafe
Dependencies added: aeson, baikai, baikai-typesafe, base, bytestring, case-insensitive, containers, directory, filepath, generic-lens, http-client, http-types, lens, scientific, servant-client, streamly, streamly-core, tasty, tasty-hunit, temporary, text, time, typesafe-hs, vector, wai, warp
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +151/−0
- baikai-typesafe.cabal +121/−0
- src/Baikai/Provider/TypeSafe/Api.hs +163/−0
- src/Baikai/Provider/TypeSafe/Internal/Request.hs +79/−0
- src/Baikai/Provider/TypeSafe/Internal/Response.hs +75/−0
- test/HttpFixture.hs +47/−0
- test/Main.hs +317/−0
- test/fixtures/dspy-2026-09-26-response.json +30/−0
- test/fixtures/request.json +29/−0
- test/fixtures/response.json +37/−0
- test/fixtures/schema.json +45/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## 0.1.0.0 - 2026-10-25++- Initial TypeSafe System One judgment provider.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2026 Nadeem Bitar++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Nadeem Bitar nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,151 @@+# baikai-typesafe++TypeSafe System One judgments for Baikai. Install `baikai-typesafe` with `baikai`.+Register `Baikai.Provider.TypeSafe.Api.typesafeProvider` explicitly, select+`Baikai.Models.Generated.typesafe_jev_latest`, send `contextOf [userData state]`,+and set `Options.responseFormat` to `JsonSchema (jsonSchemaFormat "ticket" schema)`.+Use `flattenAssistantData` to read chosen values, complete distributions and+provider confidence. Both complete and synthetic streaming calls work.++Set `TYPESAFE_API_KEY` for the official host. Custom base URLs require an explicit+`Options.apiKey` source; model and option header overrides are case-insensitive.+Generation, reasoning, tool choice, speed, system prompts and history are refused+before dispatch. Clear generation defaults after routing with `isJudgmentOnly`.++See the repository guide at `docs/user/typesafe-judgments.md` and the compiled+CAP-27 example in `docs/capabilities/typesafe-judgments.md` for schema declarations,+probabilities, typed errors, base overrides, persistence and consumer migration.+The provider depends on released `typesafe-hs ^>=0.1.0.0`, uses core transport+classification and runs no retry loop. Answer evidence is content, independent of+optional per-call evidence.+++# TypeSafe judgments++Add `baikai-typesafe ^>=0.1.0.0` and `baikai ^>=0.9.0` to the Cabal+dependencies. Both packages are available on Hackage.+The provider uses the released `typesafe-hs ^>=0.1.0.0` wire client without a+checkout override.++Register `Baikai.Provider.TypeSafe.Api.typesafeProvider` with+`registerApiProviderWith` on your explicit registry. Select+`Baikai.Models.Generated.typesafe_jev_latest` or `typesafe_jev_preview`.+`isJudgmentOnly model` queries the catalog fact; provider names and `jev-` prefixes+are not routing rules.++Supply `contextOf [userData state]` with a JSON string, object or array, or one+`user` text message. Put a `JsonSchema (jsonSchemaFormat "ticket" schemaValue)`+in `Options.responseFormat`. The schema must be an object with nonempty+`properties`. A boolean asks a predicate; a distinct string enum asks a choice+(1–255 labels); an integer enum containing exactly 0 to N−1 asks a score+(2–10 levels). Described `anyOf` or `oneOf` const branches attach choice/level+criteria, including true/false predicate criteria. Property descriptions become+instructions, defaulting to the property name. Instructions and descriptions+must be text, objects or arrays, with null allowed only for optional criteria.+Missing score descriptions use their decimal indices.++Question order follows `required` when it lists every property exactly once;+otherwise it is ascending property key. All properties are answered. Unsupported+schema constraints are refused by path. `additionalProperties`, when supplied,+must be false. `JsonSchemaFormat.name` and `strict` are local metadata.++A complete example is the repository CAP-27 record; its shape+compiles in `baikai-smoke:test:doc-shapes`. The exact three-question request and+response are in `baikai-typesafe/test/fixtures/` and are exercised against a local+HTTP fixture by the provider's offline suite.++The official host resolves `TYPESAFE_API_KEY`; an explicit `Options.apiKey` wins.+Custom gateways require an explicit source, including `ApiKeyEnv+"TYPESAFE_API_KEY"` if forwarding that credential is intentional. Override+`Model.baseUrl` with a root or trailing `/v1`; gateway prefixes are retained.+Header precedence is provider defaults, model headers, then option headers,+case-insensitively. Redirects are disabled. A positive `timeoutMs` bounds the+whole call including body reading; cancellation closes the response. There are+no internal retries.++Read `flattenAssistantData (response ^. #message . #content)`. Each block carries+`value`, optional `probabilities`, optional `confidence`, and+`method = Just "provider_classification"`. Predicates use true at probability+≥0.5; choices preserve the selected label even when it is not the argmax;+TypeSafe scores preserve the reported expected score, including fractions.+Neither confidence nor score is derived locally. Distributions need not sum to+one. Baikai checks finite values, declared answer names and keys, required wire+fields and score legends before emitting data.++Both complete and stream dispatch work. The wire call is non-streaming; events+are `EventStart`, `DataStart`, `DataEnd`, `EventDone`, or an error terminal without+a data success event. Local unsupported inputs return non-retryable+`InvalidRequest` with `UnsupportedFeature path`; the recognized upstream+unknown-model error supplies `UnsupportedModel id`. Malformed replies are+`DecodeFailure`. HTTP status and transport failures use core classification.++Every explicit generation, sampling, reasoning, speed and tool-choice control+is refused, including explicit standard speed. An absent control, empty stop+sequences and `CacheRetentionNone` pass. System prompts, tools and multi-turn+history are refused. Transport options, metadata and evidence stay available;+metadata remains local. Unknown catalog prices are unavailable estimates.++Answer probabilities and confidence are content. They survive named+`Baikai.Response.JSON.responseToJSON` / `responseFromJSON`, terminal traces, call+logs and OpenTelemetry even without call evidence opt-in. Optional call evidence+separately records the actual request, observed model, usage and+`x-typesafe-request-id`; it never substitutes a requested model for an observation.++For `mori://shinzui/shikumi/plans/63-declare-decision-outputs-and-route-them-to-system-one-models`,+route on `isJudgmentOnly` before generative structured-output capability checks,+clear post-routing generation defaults, send one `UserData`, and retain+`AssistantData` in the consumer's existing response codec. Compare its schema+reader against `compileJudgments`, including the question-order rule. Do not add+conflicting Response instances or reuse cached call evidence as a fresh+observation. Cached answers can retain their distributions after removing+per-call evidence.++The live suite skips unless explicitly selected, even when a key exists:++```bash+cabal test baikai-smoke:test:typesafe-live+cabal test baikai-smoke:test:typesafe-live --test-options='--live'+```++The second command performs one paid call and requires a nonempty key. Offline+fixture success is separate from live verification.++## Minimal request++This uses the same public calls compiled by the doc-shapes and selected live suites:++```haskell+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+module Main (main) where++import Baikai+import Baikai.Models.Generated (typesafe_jev_latest)+import Baikai.Provider.TypeSafe.Api (typesafeProvider)+import Control.Lens ((&), (.~), (^.))+import Data.Generics.Labels ()+import Data.Aeson qualified as Aeson+import Data.Text (Text)++main :: IO ()+main = do+ registry <- newProviderRegistry+ registerApiProviderWith registry typesafeProvider+ let questionSchema = Aeson.object+ [ "type" Aeson..= ("object" :: Text)+ , "properties" Aeson..= Aeson.object+ [ "urgent" Aeson..= Aeson.object+ [ "type" Aeson..= ("boolean" :: Text)+ , "description" Aeson..= ("Is service blocked?" :: Text)+ ]+ ]+ , "additionalProperties" Aeson..= False+ ]+ state = Aeson.object ["ticket" Aeson..= ("Checkout is unavailable." :: Text)]+ context = contextOf [userData state]+ options = emptyOptions & #responseFormat .~ Just (JsonSchema (jsonSchemaFormat "ticket" questionSchema))+ response <- completeRequestWith registry typesafe_jev_latest context options+ case responseError response of+ Just err -> print err+ Nothing -> print (flattenAssistantData (response ^. #message . #content))+```
+ baikai-typesafe.cabal view
@@ -0,0 +1,121 @@+cabal-version: 3.4+name: baikai-typesafe+version: 0.1.0.0+synopsis: TypeSafe judgment provider for Baikai+description:+ Submit closed-set judgments to TypeSafe System One using Baikai's explicit+ provider registry. Preserve structured answers, probabilities and confidence+ through synthetic streams, response persistence and call evidence, with strict+ request/reply validation, scoped HTTP cancellation and no internal retries.++homepage: https://github.com/shinzui/baikai+bug-reports: https://github.com/shinzui/baikai/issues+license: BSD-3-Clause+license-file: LICENSE+author: Nadeem Bitar+maintainer: nadeem@gmail.com+category: AI+build-type: Simple+tested-with: ghc ==9.12.4+extra-doc-files:+ CHANGELOG.md+ README.md++extra-source-files: test/fixtures/*.json++common common-options+ ghc-options:+ -Wall+ -Wcompat+ -Widentities+ -Wincomplete-uni-patterns+ -Wincomplete-record-updates+ -Wredundant-constraints+ -fhide-source-paths+ -Wmissing-export-lists+ -Wpartial-fields+ -Wmissing-deriving-strategies++ -- Exhaustiveness is an error, not a warning. A non-exhaustive match+ -- is a crash the compiler already found: it fails at runtime, on+ -- whichever input reaches the missing branch, usually in front of a+ -- user. This is not hypothetical here — adding a constructor to+ -- AgentRunFailure left `failureExitCode` non-exhaustive and shipped a+ -- pattern-match failure on `baikai agent run --require-evidence`,+ -- because the warning scrolled past in a build log.+ --+ -- Promoted individually rather than through -Werror, which would also+ -- fail the build on warnings that are stylistic or that a future GHC+ -- invents, and would push people toward blanket suppression.+ ghc-options:+ -Werror=incomplete-patterns+ -Werror=incomplete-uni-patterns+ -Werror=incomplete-record-updates++ default-language: GHC2024+ default-extensions:+ DeriveAnyClass+ DuplicateRecordFields+ OverloadedLabels+ OverloadedStrings++library+ import: common-options+ hs-source-dirs: src+ exposed-modules:+ Baikai.Provider.TypeSafe.Api+ Baikai.Provider.TypeSafe.Internal.Request+ Baikai.Provider.TypeSafe.Internal.Response++ other-modules: Paths_baikai_typesafe+ autogen-modules: Paths_baikai_typesafe+ build-depends:+ aeson ^>=2.2,+ baikai ^>=0.9.0,+ base >=4.20 && <5,+ bytestring ^>=0.12,+ case-insensitive ^>=1.2,+ containers ^>=0.7,+ generic-lens ^>=2.3,+ http-client ^>=0.7,+ http-types ^>=0.12,+ lens ^>=5.3,+ scientific ^>=0.3,+ servant-client ^>=0.20,+ streamly >=0.11 && <0.13,+ streamly-core >=0.3 && <0.5,+ text ^>=2.1,+ time ^>=1.14,+ typesafe-hs ^>=0.1.0.0,+ vector ^>=0.13,++test-suite baikai-typesafe-test+ import: common-options+ ghc-options: -threaded+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules: HttpFixture+ build-depends:+ aeson,+ baikai,+ baikai-typesafe,+ base,+ bytestring,+ containers,+ directory,+ filepath,+ generic-lens,+ http-types,+ lens,+ streamly,+ streamly-core,+ tasty,+ tasty-hunit,+ temporary,+ text,+ time,+ typesafe-hs,+ vector,+ wai ^>=3.2,+ warp ^>=3.4,
+ src/Baikai/Provider/TypeSafe/Api.hs view
@@ -0,0 +1,163 @@+-- | Explicitly registered, non-streaming HTTP judgments with atomic data events.+module Baikai.Provider.TypeSafe.Api (register, typesafeProvider, typesafeStream) where++import Baikai+import Baikai.Evidence qualified as E+import Baikai.Evidence.Build qualified as Build+import Baikai.Http qualified as Http+import Baikai.Provider.Transport.Classify (classifyTransportException)+import Baikai.Provider.TypeSafe.Internal.Request qualified as R+import Baikai.Provider.TypeSafe.Internal.Response qualified as D+import Baikai.Url qualified as Url+import Control.Exception (SomeAsyncException, SomeException, displayException, fromException, throwIO, try)+import Control.Lens ((&), (.~), (^.))+import Data.Aeson qualified as A+import Data.ByteString.Lazy qualified as BL+import Data.CaseInsensitive qualified as CI+import Data.Generics.Labels ()+import Data.IORef+import Data.Map.Strict qualified as Map+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.Encoding qualified as TE+import Data.Text.Encoding.Error (lenientDecode)+import Data.Time (UTCTime, diffUTCTime, getCurrentTime)+import Data.Vector qualified as V+import Data.Version (showVersion)+import Network.HTTP.Client qualified as H+import Network.HTTP.Types.Header (ResponseHeaders)+import Network.HTTP.Types.Status (statusCode)+import Paths_baikai_typesafe qualified as Paths+import Servant.Client qualified as Client+import Streamly.Data.Stream (Stream)+import System.Timeout (timeout)+import TypeSafe.Wire qualified as W++register :: IO ()+register = registerApiProvider typesafeProvider++typesafeProvider :: ApiProvider+typesafeProvider =+ apiProvider TypeSafeSystemOne typesafeStream+ & #describeThinking .~ (\_ opts -> Build.requestedTranslation opts)+ & #strengthCeiling .~ E.declaredStrength TypeSafeSystemOne+ & #structuredOutput .~ declaredStructuredOutput TypeSafeSystemOne++typesafeStream :: Model -> Context -> Options -> Stream IO AssistantMessageEvent+typesafeStream = liftCompleteToStream completeTypeSafe++completeTypeSafe :: Model -> Context -> Options -> IO Response+completeTypeSafe m ctx opts = do+ started <- getCurrentTime+ headerRef <- newIORef []+ bodyRef <- newIORef Nothing+ envelopeRef <- newIORef (Build.dispatchEnvelope m opts)+ let base = if T.null (m ^. #baseUrl) then W.defaultBaseUrl else m ^. #baseUrl+ action = do+ (js, wire) <- either throwIO pure (R.prepareRequest m ctx opts)+ let bytes = R.requestBytes wire+ envelope = fromMaybe A.Null (A.decode bytes)+ writeIORef envelopeRef envelope+ case opts ^. #timeoutMs of+ Just ms | ms <= 0 -> throwIO (unsupportedFeature "Options.timeoutMs" "timeoutMs must be positive")+ _ -> pure ()+ case Url.baseUrlProblem base of+ Just why -> throwIO (invalidRequest ("Model.baseUrl is not usable: " <> why))+ Nothing -> pure ()+ canonical <- either (throwIO . invalidRequest) pure (Http.canonicalBaseUrl base)+ key <- case opts ^. #apiKey of+ Just source -> resolveApiKey source+ Nothing -> case defaultApiKeyEnvForBaseUrl base of+ Just env -> resolveApiKey (ApiKeyEnv env)+ Nothing -> throwIO (authError "Custom TypeSafe hosts require an explicit Options.apiKey source")+ env <- Http.getClientEnvCached base+ request <- H.parseRequest (Client.showBaseUrl canonical <> "/v1/systemone")+ let headers = Map.unions [opts ^. #headers, m ^. #headers, Map.fromList [("Authorization", "Bearer " <> key), ("Content-Type", "application/json")]]+ req =+ request+ { H.method = "POST",+ H.requestBody = H.RequestBodyLBS bytes,+ H.requestHeaders = [(CI.mk (TE.encodeUtf8 (renderHeaderName k)), TE.encodeUtf8 v) | (k, v) <- Map.toList headers],+ H.redirectCount = 0,+ H.checkResponse = \_ _ -> pure (),+ H.responseTimeout = H.responseTimeoutNone+ }+ H.withResponse req (Client.manager env) $ \response -> do+ writeIORef headerRef (H.responseHeaders response)+ body <- BL.fromChunks <$> H.brConsume (H.responseBody response)+ writeIORef bodyRef (Just body)+ let status = statusCode (H.responseStatus response)+ if status >= 200 && status < 300+ then either throwIO pure (D.decodeResponse m js body)+ else do+ now <- getCurrentTime+ throwIO (statusError m now status (H.responseHeaders response) body)+ bounded = case opts ^. #timeoutMs of+ Just ms | ms > 0 -> do+ result <- timeout (fromInteger (min (toInteger (maxBound :: Int)) (toInteger ms * 1000))) action+ maybe (throwIO ((providerError ("TypeSafe call exceeded timeoutMs=" <> T.pack (show ms))) & #category .~ TransientError)) pure result+ _ -> action+ result <- trySync bounded+ ended <- getCurrentTime+ headers <- readIORef headerRef+ body <- readIORef bodyRef+ envelope <- readIORef envelopeRef+ let latency = max 0 (round (diffUTCTime ended started * 1000))+ err = either Just (const Nothing) result+ response = case result of+ Left e -> errorResponse m ended latency e+ Right (dat, _, u) ->+ emptyResponse+ & #model .~ m+ & #api .~ (m ^. #api)+ & #provider .~ (m ^. #provider)+ & #latencyMs .~ latency+ & #message .~ AssistantPayload (V.singleton (AssistantData dat)) u Stop Nothing (Just ended)+ (observedModel, observedUsage) = maybe (Unobserved, Unobserved) (D.responseObservations m) body+ requestId = maybe Unobserved (Observed . TE.decodeUtf8With lenientDecode) (lookup W.requestIdHeader headers)+ responseCommitment = case result of+ Right _ -> Observed (commitmentDigest (A.object ["content" A..= (response ^. #message . #content), "stop_reason" A..= Stop, "usage" A..= E.usageEnvelope (response ^. #message . #usage)]))+ Left _ -> maybe Unobserved (\bytes -> Observed (commitmentDigest (fromMaybe (A.String (TE.decodeUtf8With lenientDecode (BL.toStrict bytes))) (A.decode bytes)))) body+ evidence <- Build.minimalEvidenceAt base m opts TransportHttpApi (Build.requestedTranslation opts) envelope started ended (if isJustError err then E.CallFailed else CallSucceeded) err+ let enrich e =+ e+ & #observedModel .~ observedModel+ & #usage .~ observedUsage+ & #providerRequestId .~ requestId+ & #responseCommitment .~ responseCommitment+ & #strength .~ E.deriveStrength observedModel requestId Unobserved+ & #endpoint . #implementationVersion .~ Just (T.pack (showVersion Paths.version))+ pure (response & #evidence .~ fmap enrich evidence)+ where+ isJustError Nothing = False; isJustError (Just _) = True++trySync :: IO a -> IO (Either BaikaiError a)+trySync action = do+ result <- try action+ case result of+ Right x -> pure (Right x)+ Left e+ | Just async <- (fromException e :: Maybe SomeAsyncException) -> throwIO async+ | otherwise -> pure (Left (exceptionError e))++exceptionError :: SomeException -> BaikaiError+exceptionError e = case fromException e of+ Just be -> be+ Nothing -> fromMaybe (providerError (T.pack (displayException e))) (classifyTransportException e)++statusError :: Model -> UTCTime -> Int -> ResponseHeaders -> BL.ByteString -> BaikaiError+statusError m now status headers bytes =+ let reference = fromMaybe now (lookup "Date" headers >>= parseHttpDate . TE.decodeUtf8With lenientDecode)+ retry = lookup "Retry-After" headers >>= retryAfterSecondsAt reference . TE.decodeUtf8With lenientDecode+ wire = W.parseErrorBody bytes+ detail = case wire of+ W.ErrorBodyDetail d -> d ^. #message+ W.ErrorBodyDetailText t -> t+ W.ErrorBodyValidation v -> case v ^. #detail >>= (V.!? 0) of+ Just d -> T.intercalate "." [case x of { W.LocationField t -> t; W.LocationIndex i -> T.pack (show i) } | x <- V.toList (d ^. #loc)] <> ": " <> d ^. #msg+ Nothing -> "TypeSafe validation error"+ _ -> TE.decodeUtf8With lenientDecode (BL.toStrict bytes)+ base = httpError status retry detail+ in case wire of+ W.ErrorBodyDetail d | status == 400, d ^. #errorType == Just "api_usage_error", "Unknown model:" `T.isPrefixOf` (d ^. #message) -> base & #requestProblem .~ Just (UnsupportedModel (m ^. #modelId))+ _ -> base
+ src/Baikai/Provider/TypeSafe/Internal/Request.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase #-}++module Baikai.Provider.TypeSafe.Internal.Request (prepareRequest, requestBytes) where++import Baikai+import Control.Lens ((^.))+import Data.Aeson (Value (..))+import Data.Aeson.Key qualified+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy (ByteString)+import Data.Generics.Labels ()+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import TypeSafe.Wire qualified as W++requestBytes :: W.SystemOneRequest -> ByteString+requestBytes = W.encodeSystemOneRequest++prepareRequest :: Model -> Context -> Options -> Either BaikaiError (Judgments, W.SystemOneRequest)+prepareRequest m ctx opts = do+ (msg, js) <- prepareJudgment ctx opts+ state <- case msg of+ UserMessage p -> case V.toList (p ^. #content) of+ [UserText (TextContent t)] | InputText `elem` (m ^. #input) -> pure (W.ContentText t)+ [UserData v] | InputData `elem` (m ^. #input) -> requiredContent "Context.messages[0].content[0]" v+ [_] -> refused "Context.messages[0].content[0]" "unsupported input part or undeclared input modality"+ _ -> refused "Context.messages[0].content" "exactly one text or data part required"+ _ -> refused "Context.messages[0]" "expected user message"+ questions <- traverse question (judgmentList js)+ pure (js, W.SystemOneRequest (W.ModelName (m ^. #modelId)) state questions Map.empty)+ where+ question j = do+ let path = "Options.responseFormat.schema.properties." <> j ^. #name+ instr <- requiredContent (path <> ".description") (j ^. #instructions)+ q <- case j ^. #kind of+ PredicateJudgment cs -> do+ criteria <- traverse (\(yes, no) -> W.NoulCriteria <$> optionalContent (criterionPath path (Bool True) 0) yes <*> optionalContent (criterionPath path (Bool False) 1) no) cs+ pure (W.QuestionNoul (W.NoulQuestion (Just instr) criteria))+ ChoiceJudgment choices -> do+ cs <- V.imapM (\i (label, desc) -> (label,) <$> traverse (optionalContent (criterionPath path (String label) i)) desc >>= \(l, d) -> pure (l, d >>= id)) choices+ pure (W.QuestionChoice (W.ChoiceQuestion (Just instr) cs))+ ScoreJudgment levels -> do+ cs <- V.imapM (\i d -> requiredContent (criterionPath path (Number (fromIntegral i)) i) (maybe (String (T.pack (show i))) id d)) levels+ case NE.nonEmpty (V.toList cs) of+ Just nonempty -> pure (W.QuestionScore (W.ScoreQuestion (Just instr) nonempty))+ Nothing -> refused path "empty score levels"+ pure (W.QuestionName (j ^. #name), q)+ -- Retain the actual schema branch path when a dialect rejects a description.+ criterionPath path wanted fallback =+ let propertyName = T.drop (T.length "Options.responseFormat.schema.properties.") path+ property = do+ JsonSchema f <- opts ^. #responseFormat+ Object root <- Just (f ^. #schema)+ Object props <- KM.lookup "properties" root+ Object prop <- KM.lookup (Data.Aeson.Key.fromText propertyName) props+ pure prop+ branches = do+ prop <- property+ let keyword = if KM.member "oneOf" prop then "oneOf" else "anyOf"+ Array xs <- KM.lookup keyword prop+ let matches (Object b) = KM.lookup "const" b == Just wanted+ matches _ = False+ pure (Data.Aeson.Key.toText keyword, maybe fallback id (V.findIndex matches xs))+ in case branches of+ Just (keyword, i) -> path <> "." <> keyword <> "[" <> T.pack (show i) <> "].description"+ Nothing -> path <> ".description"++refused :: Text -> Text -> Either BaikaiError a+refused p why = Left (unsupportedFeature p (p <> ": " <> why))++requiredContent :: Text -> Value -> Either BaikaiError W.Content+requiredContent p v = maybe (refused p "TypeSafe content must be text, object or array") Right (W.contentFromValue v)++optionalContent :: Text -> Value -> Either BaikaiError (Maybe W.Content)+optionalContent _ Null = Right Nothing+optionalContent p v = Just <$> requiredContent p v
+ src/Baikai/Provider/TypeSafe/Internal/Response.hs view
@@ -0,0 +1,75 @@+module Baikai.Provider.TypeSafe.Internal.Response (decodeResponse, responseObservations) where++import Baikai+import Baikai.Cost.Pricing (computeCost)+import Control.Lens ((&), (.~), (^.))+import Control.Monad (unless)+import Data.Aeson qualified as A+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy (ByteString)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as T+import Data.Vector qualified as V+import TypeSafe.Wire qualified as W++decodeResponse :: Model -> Judgments -> ByteString -> Either BaikaiError (DataContent, Text, Usage)+decodeResponse m js bytes = do+ r <- either (Left . decodeError) Right (W.decodeSystemOneResponse bytes)+ (model, u) <- responseFacts m r+ answers <- Map.fromList <$> traverse answer (Map.toList (r ^. #answers))+ dat <- validateAnswers js answers+ pure (dat, model, u)+ where+ answer (W.QuestionName n, a) = do+ let err :: Text -> Either BaikaiError a+ err why = Left (decodeError (n <> ": " <> why))+ number = either (Left . decodeError . ((n <> ": ") <>)) Right+ unit = number . W.unitInterval+ neutral <- case a of+ W.AnswerNoul noul -> PredicateAnswer <$> unit (noul ^. #noul)+ W.AnswerChoice choice -> ChoiceAnswer (choice ^. #choice) <$> traverse unit (choice ^. #probabilities) <*> (Just <$> unit (choice ^. #confidence))+ W.AnswerScore score -> do+ case lookupJudgment n js of+ Just j | ScoreJudgment levels <- j ^. #kind -> do+ let expectedLegend = Map.fromList [(T.pack (show i), maybe (A.String (T.pack (show i))) id desc) | (i, desc) <- zip [0 :: Int ..] (V.toList levels)]+ unless (fmap W.contentToValue (score ^. #legend) == expectedLegend) (err "legend differs from declared levels")+ _ -> err "score answer for undeclared or non-score question"+ ScoreAnswer <$> (Just <$> number (W.finiteDouble (score ^. #score))) <*> traverse unit (score ^. #probabilities) <*> (Just <$> unit (score ^. #confidence))+ W.AnswerBox _ -> err "box answers are unsupported"+ W.AnswerOther tag _ -> err ("unknown answer type " <> tag)+ pure (n, neutral)++responseFacts :: Model -> W.SystemOneResponse -> Either BaikaiError (Text, Usage)+responseFacts m r = do+ let W.ModelName model = r ^. #model+ unless (not (T.null (T.strip model))) (Left (decodeError "model must be nonempty"))+ u <- wireUsage m (r ^. #usage)+ pure (model, u)++wireUsage :: Model -> W.Usage -> Either BaikaiError Usage+wireUsage m w = do+ let i = w ^. #inputTokens; o = w ^. #outputTokens+ unless (i >= 0 && o >= 0) (Left (decodeError "usage token counts must be nonnegative"))+ let u =+ zeroUsage+ & #inputTokens .~ fromIntegral i+ & #outputTokens .~ fromIntegral o+ & #totalTokens .~ (fromIntegral i + fromIntegral o)+ & #availability .~ Just (UsageAvailability Set.empty False Set.empty)+ pure (u & #cost .~ computeCost m u)++-- | Keep independently valid observations even when an answer is malformed.+responseObservations :: Model -> ByteString -> (Observed Text, Observed Usage)+responseObservations m bytes = case A.decode bytes of+ Just (A.Object o) ->+ ( case KM.lookup "model" o of+ Just (A.String t) | not (T.null (T.strip t)) -> Observed t+ _ -> Unobserved,+ case KM.lookup "usage" o of+ Just v | A.Success w <- A.fromJSON v, Right u <- wireUsage m w -> Observed u+ _ -> Unobserved+ )+ _ -> (Unobserved, Unobserved)
+ test/HttpFixture.hs view
@@ -0,0 +1,47 @@+module HttpFixture (Fixture (..), Captured (..), Body (..), withFixture) where++import Control.Concurrent (threadDelay)+import Control.Concurrent.MVar+import Control.Exception (IOException, catch, finally)+import Control.Monad (forever, void)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Builder qualified as Builder+import Data.ByteString.Lazy qualified as BL+import Data.IORef+import Data.Text (Text)+import Data.Text qualified as T+import Network.HTTP.Types+import Network.Wai qualified as Wai+import Network.Wai.Handler.Warp qualified as Warp++data Captured = Captured {path :: ByteString, headers :: RequestHeaders, body :: BL.ByteString}+ deriving stock (Eq, Show)++data Body = Reply BL.ByteString | Stalled++data Fixture = Fixture {base :: Text, captures :: IO [Captured], requested :: MVar (), closed :: MVar ()}++withFixture :: Int -> ResponseHeaders -> Body -> (Fixture -> IO a) -> IO a+withFixture code responseHeaders responseBody action = do+ ref <- newIORef []+ started <- newEmptyMVar+ ended <- newEmptyMVar+ let app request respond = do+ bytes <- Wai.strictRequestBody request+ modifyIORef' ref (<> [Captured (Wai.rawPathInfo request) (Wai.requestHeaders request) bytes])+ void (tryPutMVar started ())+ case responseBody of+ Reply response -> respond (Wai.responseLBS (mkStatus code "fixture") responseHeaders response)+ Stalled ->+ respond+ ( Wai.responseStream+ status200+ responseHeaders+ ( \write flush ->+ (flush >> forever (write (Builder.byteString (BS.replicate 65536 120)) >> flush >> threadDelay 10000))+ `finally` void (tryPutMVar ended ())+ )+ )+ Warp.testWithApplication (pure app) $ \port ->+ action (Fixture ("http://127.0.0.1:" <> T.pack (show port)) (readIORef ref) started ended)
+ test/Main.hs view
@@ -0,0 +1,317 @@+module Main (main) where++import Baikai+import Baikai.Cost.Log qualified as Log+import Baikai.Evidence qualified as Ev+import Baikai.Models.Generated (typesafe_jev_latest)+import Baikai.Provider.TypeSafe.Api (typesafeProvider)+import Baikai.Provider.TypeSafe.Internal.Request qualified as R+import Baikai.Provider.TypeSafe.Internal.Response qualified as D+import Baikai.Trace qualified as Trace+import Baikai.Trace.Event qualified as Tr+import Baikai.Trace.Sink qualified as Sink+import Control.Concurrent (forkIO, threadDelay, throwTo)+import Control.Concurrent.MVar+import Control.Exception (AsyncException (ThreadKilled), SomeException, try)+import Control.Lens ((&), (.~), (^.))+import Control.Monad (forM_)+import Data.Aeson qualified as A+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types (parseEither)+import Data.ByteString.Lazy qualified as BL+import Data.Either (isLeft)+import Data.Generics.Labels ()+import Data.Map.Strict qualified as Map+import Data.Text (Text)+import Data.Text qualified+import Data.Vector qualified as V+import HttpFixture qualified as F+import Streamly.Data.Stream qualified as Stream+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import System.Timeout (timeout)+import Test.Tasty+import Test.Tasty.HUnit++fixture :: String -> IO A.Value+fixture n = BL.readFile ("test/fixtures/" <> n <> ".json") >>= either assertFailure pure . A.eitherDecode++validContext :: Context+validContext = contextOf [userData (A.object ["ticket" A..= ("Checkout is unavailable." :: Text)])]++options :: A.Value -> Options+options s = emptyOptions & #responseFormat .~ Just (JsonSchema (jsonSchemaFormat "fixture" s))++set :: [Text] -> A.Value -> A.Value -> A.Value+set [] v _ = v+set (k : ks) v (A.Object o) = A.Object (KM.insert (K.fromText k) (set ks v (maybe A.Null id (KM.lookup (K.fromText k) o))) o)+set _ _ old = old++delete :: [Text] -> A.Value -> A.Value+delete [k] (A.Object o) = A.Object (KM.delete (K.fromText k) o)+delete (k : ks) (A.Object o) = A.Object (maybe o (\v -> KM.insert (K.fromText k) (delete ks v) o) (KM.lookup (K.fromText k) o))+delete _ old = old++main :: IO ()+main = defaultMain (testGroup "TypeSafe" [pureTests, httpTests])++pureTests :: TestTree+pureTests =+ testGroup+ "wire contract"+ [ testCase "exact request, criteria variant and preserved response" $ do+ s <- fixture "schema"+ expected <- fixture "request"+ reply <- fixture "response"+ forM_ [False, True] $ \criteria -> do+ let schema = if criteria then set ["properties", "urgent"] (A.object ["description" A..= ("Is service blocked?" :: Text), "anyOf" A..= [A.object ["const" A..= True, "description" A..= ("Blocked" :: Text)], A.object ["const" A..= False, "description" A..= ("Degraded or fine" :: Text)]]]) s else s+ (js, request) <- either (assertFailure . show) pure (R.prepareRequest typesafe_jev_latest validContext (options schema))+ let wanted = if criteria then set ["questions", "urgent", "criteria"] (A.object ["true" A..= ("Blocked" :: Text), "false" A..= ("Degraded or fine" :: Text)]) expected else expected+ A.eitherDecode (R.requestBytes request) @?= Right wanted+ (dat, observed, u) <- either (assertFailure . show) pure (D.decodeResponse typesafe_jev_latest js (A.encode reply))+ observed @?= "jev-fixture-version"+ u ^. #inputTokens @?= 120+ dat ^. #value @?= A.object ["urgent" A..= True, "category" A..= ("technical" :: Text), "severity" A..= (1.5 :: Double)]+ dat ^. #confidence @?= Just (Map.fromList [("category", 0.65), ("severity", 0.55)]),+ testCase "numeric and boolean descriptions and scalar state are typed refusals" $ do+ s <- fixture "schema"+ forM_ [A.Number 0, A.Bool False] $ \v -> do+ case R.prepareRequest typesafe_jev_latest validContext (options (set ["properties", "severity", "description"] v s)) of+ Left e -> e ^. #requestProblem @?= Just (UnsupportedFeature "Options.responseFormat.schema.properties.severity.description")+ _ -> assertFailure "instruction refusal required"+ forM_ [A.Null, A.Bool True, A.Number 1] $ \v ->+ assertBool "scalar state refused" (isLeft (R.prepareRequest typesafe_jev_latest (contextOf [userData v]) (options s))),+ testCase "malformed answer and response matrix" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ (js, _) <- either (assertFailure . show) pure (R.prepareRequest typesafe_jev_latest validContext (options s))+ forM_ (malformed reply) $ \bad -> case D.decodeResponse typesafe_jev_latest js (A.encode bad) of+ Left e -> e ^. #category @?= DecodeFailure+ Right _ -> assertFailure "malformed response accepted"+ forM_ ["{}", "[]", "{", "null"] $ \bytes -> assertBool "bad envelope" (isLeft (D.decodeResponse typesafe_jev_latest js bytes))+ old <- BL.readFile "test/fixtures/dspy-2026-09-26-response.json"+ assertBool "dated DSPy shape rejected" (isLeft (D.decodeResponse typesafe_jev_latest js old))+ ]++registry :: IO ProviderRegistry+registry = do+ reg <- newProviderRegistry+ registerApiProviderWith reg typesafeProvider+ pure reg++call :: Bool -> ProviderRegistry -> Model -> Context -> Options -> IO Response+call False = completeRequestWith+call True = \reg m c o -> do+ es <- Stream.toList (streamRequestWith reg m c o)+ length [() | EventStart _ <- es] @?= 1+ length (filter isTerminal es) @?= 1+ let success = not (null [() | EventDone _ <- es])+ length [() | DataStart _ <- es] @?= if success then 1 else 0+ length [() | DataEnd _ <- es] @?= if success then 1 else 0+ Stream.fold (reassembleResponse m) (Stream.fromList es)++fixtureModel :: F.Fixture -> Model+fixtureModel server = typesafe_jev_latest & #baseUrl .~ F.base server++fixtureOptions :: A.Value -> Options+fixtureOptions s = options s & #apiKey .~ Just (ApiKeyLiteral "fixture-key")++httpTests :: TestTree+httpTests =+ testGroup+ "registered HTTP"+ [ testCase "exact POST through complete and stream, evidence, response codec, trace and both logs" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ wanted <- fixture "request"+ forM_ [False, True] $ \streaming -> F.withFixture 200 [("x-typesafe-request-id", "fixture-42")] (F.Reply (A.encode reply)) $ \server -> do+ reg <- registry+ let m = fixtureModel server+ o = fixtureOptions s & #evidence .~ Just (evidenceRequest "fixture")+ r <- call streaming reg m validContext o+ responseError r @?= Nothing+ let ds = flattenAssistantData (r ^. #message . #content)+ V.length ds @?= 1+ case r ^. #evidence of+ Just e -> do+ e ^. #requestedModel @?= "jev-latest"+ e ^. #observedModel @?= Observed "jev-fixture-version"+ e ^. #providerRequestId @?= Observed "fixture-42"+ e ^. #responseId @?= Unobserved+ e ^. #requestCommitment @?= commitmentDigest wanted+ assertBool "pricing is unavailable" (PricingUnavailable `elem` (estimateReasons ((r ^. #message . #usage . #cost) ^. #basis)))+ Nothing -> assertFailure "evidence missing"+ case parseEither responseFromJSON (responseToJSON r) of+ Left e -> assertFailure e+ Right decoded -> canonicalEncode (responseToJSON decoded) @?= canonicalEncode (responseToJSON r)+ captured <- F.captures server+ case captured of+ [F.Captured path headers bytes] -> do+ path @?= "/v1/systemone"+ lookup "Authorization" headers @?= Just "Bearer fixture-key"+ A.eitherDecode bytes @?= Right wanted+ _ -> assertFailure (show captured)+ withSystemTempDirectory "typesafe-evidence" $ \dir -> do+ sink <- Sink.fileSink (dir </> "trace.jsonl")+ Log.withCallLog (Log.callLogConfig (dir </> "calls.jsonl")) $ \h -> do+ _ <- Trace.runRequestWithRegistry reg sink h m validContext (fixtureOptions s)+ _ <- Log.runRequestWithLogWith reg h m validContext (fixtureOptions s)+ pure ()+ traceBytes <- BL.readFile (dir </> "trace.jsonl")+ let traceLines = filter (not . BL.null) (BL.split 10 traceBytes)+ ts <- either assertFailure pure (traverse A.eitherDecode traceLines :: Either String [Tr.TraceEvent])+ [d | Tr.CallFinished {Tr.structuredData = d} <- ts] @?= [Just ds]+ logBytes <- BL.readFile (dir </> "calls.jsonl")+ logs <- either assertFailure pure (traverse A.eitherDecode (filter (not . BL.null) (BL.split 10 logBytes)) :: Either String [Log.CallLogEntry])+ map (^. #structuredData) logs @?= replicate 2 (Just ds),+ testCase "HTTP noul criteria variant, accepted cardinalities, strict/opted-out evidence and custom-host auth" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ wanted <- fixture "request"+ let criteria = A.object ["description" A..= ("Is service blocked?" :: Text), "anyOf" A..= [A.object ["const" A..= True, "description" A..= ("Blocked" :: Text)], A.object ["const" A..= False, "description" A..= ("Degraded or fine" :: Text)]]]+ schema = set ["properties", "urgent"] criteria s+ expected = set ["questions", "urgent", "criteria"] (A.object ["true" A..= ("Blocked" :: Text), "false" A..= ("Degraded or fine" :: Text)]) wanted+ forM_ [False, True] $ \streaming -> F.withFixture 200 [("x-typesafe-request-id", "fixture-42")] (F.Reply (A.encode reply)) $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions schema & #evidence .~ Just (evidenceRequest "strict" & #strictness .~ EvidenceRequired EvidenceModelObserved))+ responseError r @?= Nothing+ case r ^. #evidence of Just _ -> pure (); _ -> assertFailure "required evidence missing"+ captured <- F.captures server+ case captured of [F.Captured _ _ b] -> A.eitherDecode b @?= Right expected; _ -> assertFailure "one request expected"+ optedOut <- call streaming reg (fixtureModel server) validContext (fixtureOptions schema)+ optedOut ^. #evidence @?= Nothing+ F.withFixture 200 [] (F.Reply (A.encode reply)) $ \server -> do+ reg <- registry+ r <- call False reg (fixtureModel server) validContext (options s)+ fmap (^. #category) (responseError r) @?= Just AuthError+ F.captures server >>= (@?= [])+ defaultApiKeyEnvForBaseUrl "https://api.typesafe.ai/v1" @?= Just "TYPESAFE_API_KEY"+ forM_ [255, 2, 10] $ \n -> do+ let isChoice = n == 255+ labels = if isChoice then map (A.String . Data.Text.pack . show) [0 .. n - 1] else map A.toJSON [0 .. n - 1 :: Int]+ schemaN = A.object ["type" A..= ("object" :: Text), "properties" A..= A.object ["x" A..= A.object ["enum" A..= labels]]]+ assertBool "boundary compiles and maps" (not (isLeft (R.prepareRequest typesafe_jev_latest validContext (options schemaN))))+ let probabilities = A.object [(K.fromText (showText i), A.toJSON (1 / fromIntegral n :: Double)) | i <- [0 .. n - 1]]+ answer =+ if isChoice+ then A.object ["type" A..= ("choice" :: Text), "choice" A..= ("0" :: Text), "probabilities" A..= probabilities, "confidence" A..= (0.5 :: Double)]+ else A.object ["type" A..= ("score" :: Text), "score" A..= (0.5 :: Double), "probabilities" A..= probabilities, "confidence" A..= (0.5 :: Double), "legend" A..= A.object [(K.fromText (showText i), A.String (showText i)) | i <- [0 .. n - 1]]]+ response = A.object ["model" A..= ("fixture" :: Text), "usage" A..= A.object ["input_tokens" A..= (1 :: Int), "output_tokens" A..= (1 :: Int)], "answers" A..= A.object ["x" A..= answer]]+ forM_ [False, True] $ \streaming -> F.withFixture 200 [] (F.Reply (A.encode response)) $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions schemaN)+ responseError r @?= Nothing,+ testCase "preflight refusal matrix dispatches zero requests in both public modes" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ F.withFixture 200 [] (F.Reply (A.encode reply)) $ \server -> do+ reg <- registry+ let m = fixtureModel server+ o = fixtureOptions s+ badSchemas = [A.object [], set ["properties"] (A.object []) s, set ["properties", "urgent"] (A.object ["type" A..= ("string" :: Text)]) s, set ["properties", "urgent", "description"] (A.Bool False) s, set ["properties", "urgent"] (A.object ["enum" A..= ([0 :: Int])]) s, set ["properties", "urgent"] (A.object ["enum" A..= ([0 :: Int .. 10])]) s, set ["properties", "urgent"] (A.object ["enum" A..= [show i | i <- [1 .. 256 :: Int]]]) s]+ badOptions =+ [o & #maxTokens .~ Just 1, o & #temperature .~ Just 0, o & #topP .~ Just 1, o & #stopSequences .~ ["x"], o & #seed .~ Just 1, o & #frequencyPenalty .~ Just 0, o & #presencePenalty .~ Just 0, o & #thinking .~ Just ThinkingLow, o & #cacheRetention .~ Just CacheRetentionLong, o & #speed .~ Just SpeedFast, o & #responseFormat .~ Nothing, o & #responseFormat .~ Just JsonObject, o & #timeoutMs .~ Just 0]+ <> [o & #toolChoice .~ Just t | t <- [ToolChoiceAuto, ToolChoiceNone, ToolChoiceRequired, ToolChoiceSpecific "x"]]+ <> [fixtureOptions bad | bad <- badSchemas]+ badContexts = [emptyContext, contextOf [user "a", user "b"], contextOf [assistant "wrong"], validContext & #systemPrompt .~ Just "", validContext & #tools .~ V.singleton emptyTool, contextOf [UserMessage (UserPayload V.empty Nothing)], contextOf [UserMessage (UserPayload (V.fromList [UserText (TextContent "x"), UserData A.Null]) Nothing)], contextOf [UserMessage (UserPayload (V.singleton (UserImage emptyImageContent)) Nothing)], contextOf [userData A.Null]]+ forM_ [False, True] $ \streaming -> forM_ ([(validContext, bad) | bad <- badOptions] <> [(bad, o) | bad <- badContexts]) $ \(c, op) -> do+ r <- call streaming reg m c op+ case responseError r of+ Just e -> do e ^. #category @?= InvalidRequest; assertBool "typed refusal" (case e ^. #requestProblem of Just (UnsupportedFeature _) -> True; _ -> False)+ Nothing -> assertFailure "expected local refusal"+ F.captures server >>= (@?= []),+ testCase "malformed HTTP successes never emit data and retain observations" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ forM_ [False, True] $ \streaming -> forM_ (malformed reply <> [A.Array V.empty]) $ \bad ->+ F.withFixture 200 [("x-typesafe-request-id", "fixture-42")] (F.Reply (A.encode bad)) $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions s & #evidence .~ Just (evidenceRequest "malformed"))+ fmap (^. #category) (responseError r) @?= Just DecodeFailure+ flattenAssistantData (r ^. #message . #content) @?= V.empty+ fmap (length) (F.captures server) >>= (@?= 1)+ case r ^. #evidence of+ Just e -> e ^. #providerRequestId @?= Observed "fixture-42"+ Nothing -> assertFailure "failed call evidence absent",+ testCase "HTTP classification, exact unknown-model detection, Retry-After and no retries" $ do+ s <- fixture "schema"+ let errors = [(401, AuthError), (403, AuthError), (429, RateLimited), (400, InvalidRequest), (422, InvalidRequest), (500, TransientError), (529, TransientError)]+ forM_ [False, True] $ \streaming -> forM_ errors $ \(code, category) ->+ F.withFixture code [("Retry-After", "7")] (F.Reply "{\"error\":\"fixture\"}") $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions s)+ fmap (^. #category) (responseError r) @?= Just category+ fmap (^. #retryAfterSeconds) (responseError r) @?= Just (Just 7)+ fmap length (F.captures server) >>= (@?= 1)+ forM_ [True, False] $ \known ->+ let body = A.object ["detail" A..= A.object ["error_type" A..= (if known then "api_usage_error" else "another" :: Text), "message" A..= ("Unknown model: missing" :: Text)]]+ in F.withFixture 400 [] (F.Reply (A.encode body)) $ \server -> do+ reg <- registry+ r <- call False reg (fixtureModel server) validContext (fixtureOptions s)+ fmap (^. #requestProblem) (responseError r) @?= Just (if known then Just (UnsupportedModel "jev-latest") else Nothing)+ F.withFixture 422 [] (F.Reply "{\"detail\":[{\"loc\":[\"body\",\"questions\",0],\"msg\":\"bad question\",\"type\":\"value_error\"}]}") $ \server -> do+ reg <- registry+ r <- call False reg (fixtureModel server) validContext (fixtureOptions s)+ assertBool "validation path surfaced" (maybe False (Data.Text.isInfixOf "body.questions.0: bad question" . (^. #message)) (responseError r)),+ testCase "truncated JSON, invalid usage/model, choice-not-argmax and redirect handling" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ forM_ [False, True] $ \streaming -> forM_ ["{", "null", "[]"] $ \bytes -> F.withFixture 200 [] (F.Reply bytes) $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions s)+ fmap (^. #category) (responseError r) @?= Just DecodeFailure+ fmap length (F.captures server) >>= (@?= 1)+ F.withFixture 200 [] (F.Reply (A.encode (set ["answers", "category", "choice"] (A.String "billing") reply))) $ \server -> do+ reg <- registry+ r <- call False reg (fixtureModel server) validContext (fixtureOptions s)+ case V.toList (flattenAssistantData (r ^. #message . #content)) of+ [d] -> case d ^. #value of A.Object o -> KM.lookup "category" o @?= Just (A.String "billing"); _ -> assertFailure "object expected"+ _ -> assertFailure "one data block expected"+ F.withFixture 302 [("Location", "/must-not-follow")] (F.Reply "{}") $ \server -> do+ reg <- registry+ r <- call False reg (fixtureModel server) validContext (fixtureOptions s)+ assertBool "redirect fails in band" (case responseError r of Just _ -> True; _ -> False)+ fmap length (F.captures server) >>= (@?= 1),+ testCase "base normalization and case-insensitive header precedence" $ do+ s <- fixture "schema"+ reply <- fixture "response"+ forM_ ["", "/v1", "/gateway/v1/"] $ \suffix -> F.withFixture 200 [] (F.Reply (A.encode reply)) $ \server -> do+ reg <- registry+ let m = fixtureModel server & #baseUrl .~ (F.base server <> suffix) & #headers .~ Map.singleton "authorization" "Bearer model"+ o = fixtureOptions s & #headers .~ Map.singleton "AUTHORIZATION" "Bearer option"+ r <- call False reg m validContext o+ responseError r @?= Nothing+ captured <- F.captures server+ case captured of+ [F.Captured path headers _] -> do+ path @?= (if suffix == "/gateway/v1/" then "/gateway/v1/systemone" else "/v1/systemone")+ lookup "Authorization" headers @?= Just "Bearer option"+ _ -> assertFailure "one request expected",+ testCase "whole-call timeout and async cancellation close a stalled response" $ do+ s <- fixture "schema"+ forM_ [False, True] $ \streaming -> F.withFixture 200 [("x-typesafe-request-id", "stalled")] F.Stalled $ \server -> do+ reg <- registry+ r <- call streaming reg (fixtureModel server) validContext (fixtureOptions s & #timeoutMs .~ Just 100)+ fmap (^. #category) (responseError r) @?= Just TransientError+ timeout 2000000 (readMVar (F.closed server)) >>= (@?= Just ())+ F.withFixture 200 [] F.Stalled $ \server -> do+ reg <- registry+ done <- newEmptyMVar+ tid <- forkIO $ (try (call True reg (fixtureModel server) validContext (fixtureOptions s)) :: IO (Either SomeException Response)) >>= putMVar done+ timeout 2000000 (readMVar (F.requested server)) >>= (@?= Just ())+ threadDelay 50000+ throwTo tid ThreadKilled+ result <- timeout 2000000 (takeMVar done)+ assertBool "cancellation propagates" (case result of Just (Left _) -> True; _ -> False)+ timeout 2000000 (readMVar (F.closed server)) >>= (@?= Just ())+ ]++malformed :: A.Value -> [A.Value]+malformed reply = map ($ reply) (mutations <> numeric)+ where+ mutations = [set ["usage", "input_tokens"] (A.Number 1.5), set ["usage", "output_tokens"] (A.Bool True), set ["usage", "output_tokens"] (A.Number 1e400), set ["model"] (A.Number 1), set ["answers", "severity", "score"] (A.Number 1e400), set ["answers", "severity", "score"] (A.Number 3), delete ["answers", "urgent"], set ["answers", "extra"] (A.object ["type" A..= ("noul" :: Text), "noul" A..= (0.2 :: Double)]), set ["answers", "urgent", "type"] (A.String "unknown"), set ["answers", "urgent"] (A.object ["type" A..= ("box" :: Text), "box" A..= A.object ["top" A..= (0 :: Int), "bottom" A..= (1 :: Int), "left" A..= (0 :: Int), "right" A..= (1 :: Int)], "confidence" A..= A.Null]), delete ["answers", "category", "confidence"], delete ["answers", "severity", "score"], delete ["answers", "severity", "legend"], set ["answers", "severity", "legend", "0"] (A.String "wrong"), delete ["usage"], delete ["model"], set ["usage", "input_tokens"] (A.Number (-1)), set ["model"] (A.String ""), set ["answers", "category", "choice"] (A.String "other"), delete ["answers", "category", "probabilities", "billing"], set ["answers", "category", "probabilities", "extra"] (A.Number 0)]+ numeric = [set path v | path <- [["answers", "urgent", "noul"], ["answers", "category", "confidence"], ["answers", "severity", "probabilities", "0"]], v <- [A.Number (-0.1), A.Number 1.1, A.Number 1e400, A.Number (-1e-400), A.Bool True, A.String "bad"]]++showText :: Int -> Text+showText = Data.Text.pack . show
+ test/fixtures/dspy-2026-09-26-response.json view
@@ -0,0 +1,30 @@+{+ "answers": {+ "urgent": {+ "type": "noul",+ "noul": 0.83+ },+ "category": {+ "type": "choice",+ "probabilities": {+ "billing": 0.2,+ "technical": 0.7+ },+ "choice": "technical"+ },+ "severity": {+ "type": "score",+ "probabilities": {+ "0": 0.1,+ "1": 0.3,+ "2": 0.6+ },+ "score": 1.5+ }+ },+ "usage": {+ "input_tokens": 120,+ "output_tokens": 3+ },+ "model": "jev-fixture-version"+}
+ test/fixtures/request.json view
@@ -0,0 +1,29 @@+{+ "model": "jev-latest",+ "state": {+ "ticket": "Checkout is unavailable."+ },+ "questions": {+ "urgent": {+ "type": "noul",+ "instructions": "Is service blocked?"+ },+ "category": {+ "type": "choice",+ "instructions": "Classify the issue.",+ "criteria": {+ "billing": "Payment issue",+ "technical": "Product malfunction"+ }+ },+ "severity": {+ "type": "score",+ "instructions": "Rate impact.",+ "criteria": [+ "Minor",+ "Disruptive",+ "Blocking"+ ]+ }+ }+}
+ test/fixtures/response.json view
@@ -0,0 +1,37 @@+{+ "answers": {+ "urgent": {+ "type": "noul",+ "noul": 0.83+ },+ "category": {+ "type": "choice",+ "probabilities": {+ "billing": 0.2,+ "technical": 0.7+ },+ "choice": "technical",+ "confidence": 0.65+ },+ "severity": {+ "type": "score",+ "probabilities": {+ "0": 0.1,+ "1": 0.3,+ "2": 0.6+ },+ "score": 1.5,+ "confidence": 0.55,+ "legend": {+ "0": "Minor",+ "1": "Disruptive",+ "2": "Blocking"+ }+ }+ },+ "usage": {+ "input_tokens": 120,+ "output_tokens": 3+ },+ "model": "jev-fixture-version"+}
+ test/fixtures/schema.json view
@@ -0,0 +1,45 @@+{+ "type": "object",+ "properties": {+ "urgent": {+ "type": "boolean",+ "description": "Is service blocked?"+ },+ "category": {+ "description": "Classify the issue.",+ "anyOf": [+ {+ "const": "billing",+ "description": "Payment issue"+ },+ {+ "const": "technical",+ "description": "Product malfunction"+ }+ ]+ },+ "severity": {+ "description": "Rate impact.",+ "anyOf": [+ {+ "const": 0,+ "description": "Minor"+ },+ {+ "const": 1,+ "description": "Disruptive"+ },+ {+ "const": 2,+ "description": "Blocking"+ }+ ]+ }+ },+ "required": [+ "urgent",+ "category",+ "severity"+ ],+ "additionalProperties": false+}