diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## 0.1.0.0 - 2026-10-25 + +- Initial TypeSafe System One judgment provider. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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)) +``` diff --git a/baikai-typesafe.cabal b/baikai-typesafe.cabal new file mode 100644 --- /dev/null +++ b/baikai-typesafe.cabal @@ -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, diff --git a/src/Baikai/Provider/TypeSafe/Api.hs b/src/Baikai/Provider/TypeSafe/Api.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/TypeSafe/Api.hs @@ -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 diff --git a/src/Baikai/Provider/TypeSafe/Internal/Request.hs b/src/Baikai/Provider/TypeSafe/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/TypeSafe/Internal/Request.hs @@ -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 diff --git a/src/Baikai/Provider/TypeSafe/Internal/Response.hs b/src/Baikai/Provider/TypeSafe/Internal/Response.hs new file mode 100644 --- /dev/null +++ b/src/Baikai/Provider/TypeSafe/Internal/Response.hs @@ -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) diff --git a/test/HttpFixture.hs b/test/HttpFixture.hs new file mode 100644 --- /dev/null +++ b/test/HttpFixture.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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 diff --git a/test/fixtures/dspy-2026-09-26-response.json b/test/fixtures/dspy-2026-09-26-response.json new file mode 100644 --- /dev/null +++ b/test/fixtures/dspy-2026-09-26-response.json @@ -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" +} diff --git a/test/fixtures/request.json b/test/fixtures/request.json new file mode 100644 --- /dev/null +++ b/test/fixtures/request.json @@ -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" + ] + } + } +} diff --git a/test/fixtures/response.json b/test/fixtures/response.json new file mode 100644 --- /dev/null +++ b/test/fixtures/response.json @@ -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" +} diff --git a/test/fixtures/schema.json b/test/fixtures/schema.json new file mode 100644 --- /dev/null +++ b/test/fixtures/schema.json @@ -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 +}