typesafe-ai-core (empty) → 0.1.0.0
raw patch · 20 files changed
+4897/−0 lines, 20 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, containers, deepseq, http-types, scientific, tasty, tasty-hunit, tasty-quickcheck, text, time, typesafe-ai-core, vector
Files
- CHANGELOG.md +22/−0
- LICENSE +28/−0
- README.md +39/−0
- spec/openapi.json +860/−0
- src/TypeSafe/Call.hs +421/−0
- src/TypeSafe/Content.hs +158/−0
- src/TypeSafe/Core.hs +100/−0
- src/TypeSafe/Error.hs +397/−0
- src/TypeSafe/Internal/Generic.hs +93/−0
- src/TypeSafe/Question.hs +695/−0
- src/TypeSafe/Retry.hs +193/−0
- src/TypeSafe/Wire.hs +773/−0
- test/Main.hs +26/−0
- test/TypeSafe/ArbitraryInstances.hs +177/−0
- test/TypeSafe/ConformanceSpec.hs +158/−0
- test/TypeSafe/ErrorSpec.hs +82/−0
- test/TypeSafe/JsonSchema.hs +230/−0
- test/TypeSafe/QuestionSpec.hs +280/−0
- test/TypeSafe/RetrySpec.hs +64/−0
- typesafe-ai-core.cabal +101/−0
+ CHANGELOG.md view
@@ -0,0 +1,22 @@+# Changelog for typesafe-ai-core++This package follows the [PVP](https://pvp.haskell.org) and is released+together with `typesafe-ai`, with the same version number.++## 0.1.0.0++First release. Checked against version 0.2.0 of the TypeSafe OpenAPI+specification.++- `TypeSafe.Wire`: every schema of the specification, with JSON codecs.+ Unknown question and answer types are preserved (`QuestionOther`,+ `AnswerOther`).+- `TypeSafe.Question`: typed Noul, Choice and Score questions. Options and+ levels come from `ChoiceOption` and `ScoreLevel` instances, which can be+ derived for enumerations. Questions combine with the `Applicative` instance+ of `Questions`.+- `TypeSafe.Call`: `systemOne`, `systemOneRaw` and `listModels` as values,+ per-call options, and the functions a transport needs.+- `TypeSafe.Error`: `TypeSafeError`, with error responses classified by+ status and error bodies parsed.+- `TypeSafe.Retry`: the retry policy of the official SDKs, as pure functions.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2026, byteally++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 HOLDER 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,39 @@+# typesafe-ai-core++Transport-agnostic bindings to [TypeSafe AI](https://typesafe.ai)'s System+One API: typed Noul, Choice and Score questions whose answers decode to your+own Haskell types, a one-to-one mirror of the OpenAPI schemas with JSON+codecs, and API calls as plain values.++This package does no networking. Use it with servant or any other HTTP+stack. For a ready-to-use client, depend on+[`typesafe-ai`](https://hackage.haskell.org/package/typesafe-ai) instead; it+re-exports everything here.++```haskell+data Department = Billing | Technical | Sales+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ChoiceOption)++routing :: Questions (Choice Department, Noul)+routing =+ (,) <$> ask "department" (choice "Which team should handle this?")+ <*> ask "is_urgent" (noul "Does this convey urgency?")++-- The request, for any HTTP client:+request :: Either RequestError Wire.SystemOneRequest+request = systemOneRequest jevLatest "Help! My payouts have been failing." routing++-- And the typed answers, from its response:+answers :: Wire.SystemOneResponse -> Either (NonEmpty AnswerError) (Evaluation (Choice Department, Noul))+answers = decodeEvaluation routing Nothing+```++Start with the documentation of `TypeSafe.Core` and `TypeSafe.Question`. The+[repository](https://github.com/byteally/typesafe-sdk) has more examples.++The bindings are checked against version `0.2.0` of the TypeSafe OpenAPI+specification (`apiSpecVersion`), which is included in the package+(`spec/openapi.json`).++This is a community SDK, not affiliated with or endorsed by TypeSafe AI.
+ spec/openapi.json view
@@ -0,0 +1,860 @@+{+ "components": {+ "schemas": {+ "Answer": {+ "description": "An answer whose type matches the corresponding question.",+ "discriminator": {+ "mapping": {+ "choice": "#/components/schemas/ChoiceAnswer",+ "noul": "#/components/schemas/NoulAnswer",+ "score": "#/components/schemas/ScoreAnswer"+ },+ "propertyName": "type"+ },+ "oneOf": [+ {+ "$ref": "#/components/schemas/NoulAnswer"+ },+ {+ "$ref": "#/components/schemas/ScoreAnswer"+ },+ {+ "$ref": "#/components/schemas/ChoiceAnswer"+ }+ ]+ },+ "ChoiceAnswer": {+ "description": "The selected choice, confidence, and probabilities for a choice question.",+ "properties": {+ "choice": {+ "description": "The name of the choice with the highest probability among the question's criteria.",+ "examples": [+ "angry"+ ],+ "title": "Choice",+ "type": "string"+ },+ "confidence": {+ "description": "Confidence in the selected choice, from 0 to 1. Higher values indicate greater certainty; use lower values to flag uncertain selections for review.",+ "examples": [+ 0.9+ ],+ "title": "Confidence",+ "type": "number"+ },+ "probabilities": {+ "additionalProperties": {+ "type": "number"+ },+ "description": "Probability of each choice in criteria, keyed by choice name, from 0 to 1. Shows how likely the alternatives are; values sum to approximately 1.",+ "examples": [+ {+ "angry": 0.8,+ "calm": 0.1,+ "excited": 0.1+ }+ ],+ "title": "Probabilities",+ "type": "object"+ },+ "type": {+ "const": "choice",+ "description": "Identifies a selection from the requested choices.",+ "examples": [+ "choice"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "choice",+ "confidence",+ "probabilities",+ "type"+ ],+ "title": "ChoiceAnswer",+ "type": "object"+ },+ "ChoiceQuestion": {+ "description": "A question that selects one option from the choices you define.",+ "properties": {+ "criteria": {+ "additionalProperties": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ]+ },+ "description": "Choice names and descriptions of when each applies. A choice without a description is interpreted by its name alone.",+ "examples": [+ {+ "angry": "An upset or hostile message",+ "calm": "A neutral or polite message",+ "excited": "An enthusiastic or eager message"+ }+ ],+ "title": "Criteria",+ "type": "object"+ },+ "instructions": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "What the model should decide when choosing an option.",+ "examples": [+ "What is the tone of this message?"+ ],+ "title": "Instructions"+ },+ "type": {+ "const": "choice",+ "description": "Identifies a question that selects one of the choices in criteria.",+ "examples": [+ "choice"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "criteria",+ "type"+ ],+ "title": "ChoiceQuestion",+ "type": "object"+ },+ "HTTPValidationError": {+ "description": "Request validation failures returned with HTTP status 422.",+ "properties": {+ "detail": {+ "description": "Validation errors describing which request values are missing or invalid.",+ "examples": [+ [+ {+ "loc": [+ "body",+ "state"+ ],+ "msg": "Field required",+ "type": "missing"+ }+ ]+ ],+ "items": {+ "$ref": "#/components/schemas/ValidationError"+ },+ "title": "Detail",+ "type": "array"+ }+ },+ "title": "HTTPValidationError",+ "type": "object"+ },+ "ModelMetadata": {+ "description": "A model or model alias available to the authenticated account.",+ "properties": {+ "description": {+ "description": "Human-readable description of the model and its capabilities.",+ "examples": [+ "General-purpose system one model."+ ],+ "title": "Description",+ "type": "string"+ },+ "name": {+ "description": "Model name or alias accepted by the request's model field.",+ "examples": [+ "jev-latest"+ ],+ "title": "Name",+ "type": "string"+ },+ "release_date": {+ "description": "Model release date, formatted as YYYY-MM-DD.",+ "examples": [+ "2026-09-15"+ ],+ "title": "Release Date",+ "type": "string"+ }+ },+ "required": [+ "name",+ "description",+ "release_date"+ ],+ "title": "ModelMetadata",+ "type": "object"+ },+ "ModelMetadataList": {+ "description": "Models and aliases available to the authenticated account.",+ "properties": {+ "models": {+ "description": "Available models and aliases. Use a model's name in POST /v1/systemone requests.",+ "examples": [+ [+ {+ "description": "General-purpose system one model.",+ "name": "jev-latest",+ "release_date": "2026-09-15"+ }+ ]+ ],+ "items": {+ "$ref": "#/components/schemas/ModelMetadata"+ },+ "title": "Models",+ "type": "array"+ }+ },+ "required": [+ "models"+ ],+ "title": "ModelMetadataList",+ "type": "object"+ },+ "NoulAnswer": {+ "description": "The probability of a yes answer or a true statement.",+ "properties": {+ "noul": {+ "description": "Probability of a yes answer or a true statement, from 0 to 1. Values near 1 favor yes or true, values near 0 favor no or false, and values near 0.5 indicate uncertainty.",+ "examples": [+ 0.98+ ],+ "title": "Noul",+ "type": "number"+ },+ "type": {+ "const": "noul",+ "description": "Identifies a yes/no answer.",+ "examples": [+ "noul"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "noul",+ "type"+ ],+ "title": "NoulAnswer",+ "type": "object"+ },+ "NoulCriteria": {+ "description": "Criteria defining what counts as a yes or no answer.",+ "properties": {+ "false": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "What counts as a no answer.",+ "examples": [+ "The message is a legitimate conversation."+ ],+ "title": "False"+ },+ "true": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "What counts as a yes answer.",+ "examples": [+ "The message is unsolicited advertising."+ ],+ "title": "True"+ }+ },+ "title": "NoulCriteria",+ "type": "object"+ },+ "NoulQuestion": {+ "description": "A yes/no question or statement, answered with the probability of yes or true.",+ "properties": {+ "criteria": {+ "anyOf": [+ {+ "$ref": "#/components/schemas/NoulCriteria"+ },+ {+ "type": "null"+ }+ ],+ "description": "Criteria clarifying what counts as a yes or no answer.",+ "examples": [+ {+ "false": "A legitimate conversation",+ "true": "Unsolicited advertising"+ }+ ]+ },+ "instructions": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "The yes/no question or statement to evaluate.",+ "examples": [+ "Is this message spam?",+ "This message contains unsolicited advertising.",+ {+ "task": "Identify unsolicited advertising."+ }+ ],+ "title": "Instructions"+ },+ "type": {+ "const": "noul",+ "description": "Identifies a yes/no question or statement.",+ "examples": [+ "noul"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "type"+ ],+ "title": "NoulQuestion",+ "type": "object"+ },+ "Question": {+ "description": "A question about the supplied content.",+ "discriminator": {+ "mapping": {+ "choice": "#/components/schemas/ChoiceQuestion",+ "noul": "#/components/schemas/NoulQuestion",+ "score": "#/components/schemas/ScoreQuestion"+ },+ "propertyName": "type"+ },+ "oneOf": [+ {+ "$ref": "#/components/schemas/NoulQuestion"+ },+ {+ "$ref": "#/components/schemas/ChoiceQuestion"+ },+ {+ "$ref": "#/components/schemas/ScoreQuestion"+ }+ ]+ },+ "ScoreAnswer": {+ "description": "An expected score with its rubric, confidence, and score-level probabilities.",+ "properties": {+ "confidence": {+ "description": "Confidence in the score, from 0 to 1. Higher values indicate greater certainty; use lower values to flag uncertain ratings for review.",+ "examples": [+ 0.9+ ],+ "title": "Confidence",+ "type": "number"+ },+ "legend": {+ "additionalProperties": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ }+ ]+ },+ "description": "The requested criteria mapped to their score levels, so you can interpret the score.",+ "examples": [+ {+ "0": "Can wait",+ "1": "Needs attention this week",+ "2": "Needs attention today"+ }+ ],+ "title": "Legend",+ "type": "object"+ },+ "probabilities": {+ "additionalProperties": {+ "type": "number"+ },+ "description": "Probability of each score level, from 0 to 1, using the same keys as legend. Shows how likely the alternatives are; values sum to approximately 1.",+ "examples": [+ {+ "0": 0.1,+ "1": 0.1,+ "2": 0.8+ }+ ],+ "title": "Probabilities",+ "type": "object"+ },+ "score": {+ "description": "Expected score: the probability-weighted average of the rubric levels. May fall between integer levels.",+ "examples": [+ 1.7+ ],+ "title": "Score",+ "type": "number"+ },+ "type": {+ "const": "score",+ "description": "Identifies a rating against the requested score levels.",+ "examples": [+ "score"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "score",+ "confidence",+ "legend",+ "probabilities",+ "type"+ ],+ "title": "ScoreAnswer",+ "type": "object"+ },+ "ScoreQuestion": {+ "description": "A question that assigns a score using an ordered rubric.",+ "properties": {+ "criteria": {+ "description": "Ordered descriptions of the score levels. Each description's position determines its score, starting at zero.",+ "examples": [+ [+ "Can wait",+ "Needs attention this week",+ "Needs attention today"+ ]+ ],+ "items": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ }+ ]+ },+ "minItems": 1,+ "title": "Criteria",+ "type": "array"+ },+ "instructions": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "What the model should rate.",+ "examples": [+ "How urgent is this message?"+ ],+ "title": "Instructions"+ },+ "type": {+ "const": "score",+ "description": "Identifies a question that rates the content using the levels in criteria.",+ "examples": [+ "score"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "criteria",+ "type"+ ],+ "title": "ScoreQuestion",+ "type": "object"+ },+ "SystemOneRequest": {+ "description": "Content and named questions to evaluate together using a TypeSafe model.",+ "properties": {+ "model": {+ "description": "Name or alias of the model to use. Available names are returned by GET /v1/models.",+ "examples": [+ "jev-latest"+ ],+ "title": "Model",+ "type": "string"+ },+ "questions": {+ "additionalProperties": {+ "$ref": "#/components/schemas/Question"+ },+ "description": "Questions to ask about the content, each with a name you choose. The response uses those names to identify the answers.",+ "examples": [+ {+ "billing": {+ "instructions": "Is this message about billing?",+ "type": "noul"+ }+ }+ ],+ "minProperties": 1,+ "title": "Questions",+ "type": "object"+ },+ "state": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ }+ ],+ "description": "The content all questions in this request refer to.",+ "examples": [+ "I was charged twice. Please help.",+ {+ "message": "Please help.",+ "subject": "Duplicate charge"+ }+ ],+ "title": "State"+ }+ },+ "required": [+ "model",+ "questions",+ "state"+ ],+ "title": "SystemOneRequest",+ "type": "object"+ },+ "SystemOneResponse": {+ "description": "Answers grouped by question name, with the model used and token usage.",+ "properties": {+ "answers": {+ "additionalProperties": {+ "$ref": "#/components/schemas/Answer"+ },+ "description": "Answers keyed by the question names supplied in the request. Each answer's type matches its question's type.",+ "examples": [+ {+ "billing": {+ "noul": 0.98,+ "type": "noul"+ }+ }+ ],+ "minProperties": 1,+ "title": "Answers",+ "type": "object"+ },+ "model": {+ "description": "Name of the model that answered the questions. May differ from the alias supplied in the request.",+ "examples": [+ "jev-latest"+ ],+ "title": "Model",+ "type": "string"+ },+ "usage": {+ "$ref": "#/components/schemas/Usage",+ "description": "Input and output token counts for this evaluation.",+ "examples": [+ {+ "input_tokens": 120,+ "output_tokens": 12+ }+ ]+ }+ },+ "required": [+ "model",+ "answers",+ "usage"+ ],+ "title": "SystemOneResponse",+ "type": "object"+ },+ "Usage": {+ "description": "Token usage for the request.",+ "properties": {+ "input_tokens": {+ "description": "Number of billable input tokens used to evaluate the request.",+ "examples": [+ 120+ ],+ "title": "Input Tokens",+ "type": "integer"+ },+ "output_tokens": {+ "description": "Number of output tokens used to answer the questions. Output tokens are currently free of charge.",+ "examples": [+ 12+ ],+ "title": "Output Tokens",+ "type": "integer"+ }+ },+ "required": [+ "input_tokens",+ "output_tokens"+ ],+ "title": "Usage",+ "type": "object"+ },+ "ValidationError": {+ "description": "A request validation error at a specific field or array element.",+ "properties": {+ "ctx": {+ "description": "Additional context used to explain the validation failure.",+ "examples": [+ {+ "min_length": 1+ }+ ],+ "title": "Context",+ "type": "object"+ },+ "input": {+ "description": "The input value that failed validation.",+ "examples": [+ {+ "type": "score"+ }+ ],+ "title": "Input"+ },+ "loc": {+ "description": "Path to the invalid value: the request location followed by field names and array indices.",+ "examples": [+ [+ "body",+ "questions",+ "urgency",+ "score",+ "criteria"+ ]+ ],+ "items": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "type": "integer"+ }+ ]+ },+ "title": "Location",+ "type": "array"+ },+ "msg": {+ "description": "Human-readable explanation of the validation failure.",+ "examples": [+ "Field required"+ ],+ "title": "Message",+ "type": "string"+ },+ "type": {+ "description": "Machine-readable validation error code.",+ "examples": [+ "missing"+ ],+ "title": "Error Type",+ "type": "string"+ }+ },+ "required": [+ "loc",+ "msg",+ "type"+ ],+ "title": "ValidationError",+ "type": "object"+ }+ },+ "securitySchemes": {+ "HTTPBearer": {+ "scheme": "bearer",+ "type": "http"+ }+ }+ },+ "info": {+ "description": "Ask yes/no questions, evaluate statements, select choices, or assign ratings to your content. Send your API key in the Authorization header as `Bearer <API_KEY>`. Use GET /v1/models to discover available model names.",+ "title": "TypeSafe",+ "version": "0.2.0"+ },+ "openapi": "3.1.0",+ "paths": {+ "/v1/models": {+ "get": {+ "description": "List the models and aliases available to the authenticated account.\n\nPass a returned model name as `model` in a POST /v1/systemone request.",+ "operationId": "models_v1_v1_models_get",+ "responses": {+ "200": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/ModelMetadataList"+ }+ }+ },+ "description": "Successful Response"+ },+ "422": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPValidationError"+ }+ }+ },+ "description": "Validation Error"+ }+ },+ "security": [+ {+ "HTTPBearer": []+ }+ ],+ "summary": "Models V1"+ }+ },+ "/v1/systemone": {+ "post": {+ "description": "Answer one or more questions about the content supplied in `state`.\n\nYou can mix question types in one request. Answers use the same names as the\nquestions, so you can match each result to its question. The response also includes\nthe model used and token usage.",+ "operationId": "systemone_v1_systemone_post",+ "requestBody": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/SystemOneRequest"+ }+ }+ },+ "required": true+ },+ "responses": {+ "200": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/SystemOneResponse"+ }+ }+ },+ "description": "Successful Response"+ },+ "422": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPValidationError"+ }+ }+ },+ "description": "Validation Error"+ }+ },+ "security": [+ {+ "HTTPBearer": []+ }+ ],+ "summary": "Systemone"+ }+ }+ }+}
+ src/TypeSafe/Call.hs view
@@ -0,0 +1,421 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : TypeSafe.Call+-- Description : API calls as values, independent of any HTTP library+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- A @'Call' a@ describes one API request and how to turn its response into+-- an @a@. It does no input or output: a /transport/ renders the call to an+-- 'HttpRequest', sends it with whatever HTTP stack it likes, and hands the+-- 'HttpResponse' back to 'parseResponse'. The @typesafe-ai@ package provides+-- a transport built on @http-client@; writing another one takes a few dozen+-- lines.+--+-- Calls are built from the endpoint functions and adjusted with the @with…@+-- functions:+--+-- @+-- 'withModel' \"jev-1.13.0\" ('systemOne' state triage) :: 'Call' ('Evaluation' Triage)+-- @+--+-- = Example+--+-- >>> let call = systemOne "I was charged twice. Please help." (ask "billing" (noul "Is this about billing?"))+-- >>> callEndpoint call+-- "POST /v1/systemone"+--+-- >>> let Right request = renderCall (CallDefaults jevLatest []) call+-- >>> traverse_ LBS.putStrLn (httpRequestBody request)+-- {"state":"I was charged twice. Please help.","model":"jev-latest","questions":{"billing":{"type":"noul","instructions":"Is this about billing?"}}}+--+-- >>> :{+-- let response =+-- HttpResponse+-- { httpResponseStatus = status200+-- , httpResponseHeaders = [("x-typesafe-request-id", "req_0123")]+-- , httpResponseBody = "{\"model\":\"jev-1.13.0\",\"answers\":{\"billing\":{\"type\":\"noul\",\"noul\":0.98}},\"usage\":{\"input_tokens\":120,\"output_tokens\":12}}"+-- }+-- :}+--+-- >>> let Right result = parseResponse call response+-- >>> evaluationAnswers result+-- Noul {noulProbability = 0.98}+-- >>> evaluationModel result+-- "jev-1.13.0"+-- >>> evaluationRequestId result+-- Just "req_0123"+module TypeSafe.Call+ ( -- * Calls+ Call+ , systemOne+ , systemOneRaw+ , listModels++ -- * Evaluations+ , Evaluation (..)++ -- * Per-call options+ , withModel+ , withHeaders+ , withExtraBody+ , withRetryPolicy+ , withTimeout++ -- * Using the typed layer with your own HTTP client+ , systemOneRequest+ , decodeEvaluation++ -- * Implementing a transport+ , CallDefaults (..)+ , HttpRequest (..)+ , HttpResponse (..)+ , renderCall+ , parseResponse+ , callEndpoint+ , callRetryPolicy+ , callTimeout+ , protectedHeaders+ , defaultBaseUrl+ , requestIdHeader+ ) where++import Control.DeepSeq (NFData)+import Data.Aeson (Object, eitherDecode', pairs, (.=))+import qualified Data.Aeson.Encoding as Encoding+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Bifunctor (first)+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe, isJust)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import Data.Time.Clock (NominalDiffTime)+import GHC.Generics (Generic)+import Network.HTTP.Types+ ( HeaderName+ , Method+ , RequestHeaders+ , ResponseHeaders+ , Status+ , statusIsSuccessful+ )+import TypeSafe.Content (Content)+import TypeSafe.Error+ ( AnswerError+ , RequestError+ , RequestId (..)+ , ResponseError (..)+ , ResponseProblem (..)+ , TypeSafeError (..)+ , apiErrorFromResponse+ )+import TypeSafe.Question (Questions, decodeAnswers, renderQuestions)+import TypeSafe.Retry (RetryPolicy)+import TypeSafe.Wire+ ( Answer+ , ModelMetadata+ , ModelMetadataList (..)+ , ModelName+ , QuestionId+ , SystemOneRequest (..)+ , SystemOneResponse (..)+ , Usage+ )++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Foldable (traverse_)+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS+-- >>> import Network.HTTP.Types (status200)+-- >>> import TypeSafe.Question+-- >>> import TypeSafe.Wire (jevLatest)++------------------------------------------------------------------------------+-- Calls++-- | One API request, and how to decode its response into an @a@.+data Call a = Call+ { callMethod :: !Method+ , callPath :: ![Text]+ , callBody :: !(Maybe (CallOptions -> ModelName -> Either RequestError LBS.ByteString))+ , callOptions :: !CallOptions+ , callDecode :: Maybe RequestId -> LBS.ByteString -> Either ResponseProblem a+ }++instance Functor Call where+ fmap f c = c {callDecode = \rid body -> f <$> callDecode c rid body}++data CallOptions = CallOptions+ { optionModel :: !(Maybe ModelName)+ , optionHeaders :: !RequestHeaders+ , optionExtraBody :: !Object+ , optionRetryPolicy :: !(Maybe RetryPolicy)+ , optionTimeout :: !(Maybe NominalDiffTime)+ }++noOptions :: CallOptions+noOptions = CallOptions Nothing [] KeyMap.empty Nothing Nothing++-- | Evaluate a state against typed questions (@POST \/v1\/systemone@).+--+-- The request uses the transport's default model (normally 'TypeSafe.Wire.jevLatest')+-- unless 'withModel' says otherwise. Every question sees the same state and+-- is answered independently; see <https://docs.typesafe.ai/api>.+--+-- The call fails with 'InvalidRequest', before anything is sent, if the+-- questions are empty, share an id, or are malformed.+systemOne :: Content -> Questions a -> Call (Evaluation a)+systemOne state questions =+ Call+ { callMethod = "POST"+ , callPath = ["v1", "systemone"]+ , callBody = Just $ \options defaultModel -> do+ rendered <- renderQuestions questions+ pure . encodeRequest options $+ SystemOneRequest+ { systemOneRequestState = state+ , systemOneRequestModel = fromMaybe defaultModel (optionModel options)+ , systemOneRequestQuestions = rendered+ }+ , callOptions = noOptions+ , callDecode = \rid body -> do+ response <- first MalformedBody (eitherDecode' body)+ first MismatchedAnswers (decodeEvaluation questions rid response)+ }++-- | Send a wire-level request as-is and receive the raw answers.+--+-- Nothing is validated locally. The model is the one in the request unless+-- 'withModel' overrides it.+systemOneRaw :: SystemOneRequest -> Call (Evaluation (Map QuestionId Answer))+systemOneRaw request =+ Call+ { callMethod = "POST"+ , callPath = ["v1", "systemone"]+ , callBody = Just $ \options _ ->+ Right . encodeRequest options $+ request+ { systemOneRequestModel =+ fromMaybe (systemOneRequestModel request) (optionModel options)+ }+ , callOptions = noOptions+ , callDecode = \rid body -> do+ response <- first MalformedBody (eitherDecode' body)+ pure (evaluation rid response (systemOneResponseAnswers response))+ }++-- | List the models and aliases available to the account+-- (@GET \/v1\/models@).+--+-- Versioned model ids are accepted by the @model@ field whether or not they+-- are listed.+listModels :: Call [ModelMetadata]+listModels =+ Call+ { callMethod = "GET"+ , callPath = ["v1", "models"]+ , callBody = Nothing+ , callOptions = noOptions+ , callDecode = \_ body -> modelMetadataListModels <$> first MalformedBody (eitherDecode' body)+ }++encodeRequest :: CallOptions -> SystemOneRequest -> LBS.ByteString+encodeRequest options r =+ Encoding.encodingToLazyByteString . pairs $+ "state" .= systemOneRequestState r+ <> "model" .= systemOneRequestModel r+ <> "questions" .= systemOneRequestQuestions r+ <> foldMap+ (uncurry (.=))+ [ kv+ | kv@(k, _) <- KeyMap.toList (optionExtraBody options)+ , k `notElem` ["state", "model", "questions"]+ ]++------------------------------------------------------------------------------+-- Evaluations++-- | The result of a 'systemOne' call: your typed answers, plus what the API+-- reported about the request.+data Evaluation a = Evaluation+ { evaluationAnswers :: !a+ -- ^ The decoded answers.+ , evaluationModel :: !ModelName+ -- ^ The versioned model that answered. Log it to know which model+ -- produced a result when you request an alias.+ , evaluationUsage :: !Usage+ -- ^ Token usage.+ , evaluationRequestId :: !(Maybe RequestId)+ -- ^ The request id assigned by the API.+ , evaluationResponse :: !SystemOneResponse+ -- ^ The complete response, including answers the typed questions did not+ -- ask for.+ }+ deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable)+ deriving anyclass (NFData)++evaluation :: Maybe RequestId -> SystemOneResponse -> a -> Evaluation a+evaluation rid response a =+ Evaluation+ { evaluationAnswers = a+ , evaluationModel = systemOneResponseModel response+ , evaluationUsage = systemOneResponseUsage response+ , evaluationRequestId = rid+ , evaluationResponse = response+ }++-- | Build the wire request for typed questions, for sending with your own+-- HTTP client, such as servant. Pair it with 'decodeEvaluation'.+systemOneRequest :: ModelName -> Content -> Questions a -> Either RequestError SystemOneRequest+systemOneRequest model state questions =+ SystemOneRequest state model <$> renderQuestions questions++-- | Decode a response to a request built with 'systemOneRequest'. The request+-- id is the @x-typesafe-request-id@ response header, if you have it.+decodeEvaluation+ :: Questions a+ -> Maybe RequestId+ -> SystemOneResponse+ -> Either (NonEmpty AnswerError) (Evaluation a)+decodeEvaluation questions rid response =+ evaluation rid response <$> decodeAnswers questions (systemOneResponseAnswers response)++------------------------------------------------------------------------------+-- Options++-- | Use this model (a versioned id or an alias) instead of the default.+withModel :: ModelName -> Call a -> Call a+withModel m = overOptions (\o -> o {optionModel = Just m})++-- | Send extra headers with this call. They override headers of the same name+-- configured on the client, but never the 'protectedHeaders'.+withHeaders :: RequestHeaders -> Call a -> Call a+withHeaders hs = overOptions (\o -> o {optionHeaders = optionHeaders o <> hs})++-- | Add top-level fields to the request body, to use API features that this+-- SDK does not know about yet. Fields the SDK sets itself (@state@, @model@,+-- @questions@) cannot be overridden this way. Only send fields the API+-- supports.+withExtraBody :: Object -> Call a -> Call a+withExtraBody extra = overOptions (\o -> o {optionExtraBody = extra <> optionExtraBody o})++-- | Retry this call with a different policy than the client's.+withRetryPolicy :: RetryPolicy -> Call a -> Call a+withRetryPolicy p = overOptions (\o -> o {optionRetryPolicy = Just p})++-- | Wait at most this many seconds for each attempt of this call.+withTimeout :: NominalDiffTime -> Call a -> Call a+withTimeout t = overOptions (\o -> o {optionTimeout = Just t})++overOptions :: (CallOptions -> CallOptions) -> Call a -> Call a+overOptions f c = c {callOptions = f (callOptions c)}++------------------------------------------------------------------------------+-- Transports++-- | Client-wide settings a transport supplies when rendering a call.+data CallDefaults = CallDefaults+ { callDefaultModel :: !ModelName+ -- ^ The model used unless the call sets one.+ , callDefaultHeaders :: !RequestHeaders+ -- ^ Extra headers for every call.+ }+ deriving stock (Eq, Show)++-- | An HTTP request, ready to send.+--+-- The transport adds the base URL, the @Authorization: Bearer …@ header and+-- its @User-Agent@.+data HttpRequest = HttpRequest+ { httpRequestMethod :: !Method+ , httpRequestPath :: ![Text]+ -- ^ Path segments, relative to the base URL.+ , httpRequestHeaders :: !RequestHeaders+ , httpRequestBody :: !(Maybe LBS.ByteString)+ -- ^ A JSON body, if the call has one.+ }+ deriving stock (Eq, Show)++-- | An HTTP response, as received by the transport.+data HttpResponse = HttpResponse+ { httpResponseStatus :: !Status+ , httpResponseHeaders :: !ResponseHeaders+ , httpResponseBody :: !LBS.ByteString+ }+ deriving stock (Eq, Show)++-- | Render a call, or report why it cannot be sent.+renderCall :: CallDefaults -> Call a -> Either TypeSafeError HttpRequest+renderCall defaults call = do+ body <-+ traverse+ (\encode -> first InvalidRequest (encode options (callDefaultModel defaults)))+ (callBody call)+ pure+ HttpRequest+ { httpRequestMethod = callMethod call+ , httpRequestPath = callPath call+ , httpRequestHeaders =+ ("Accept", "application/json")+ : [("Content-Type", "application/json") | isJust body]+ <> overriding (optionHeaders options) (callDefaultHeaders defaults)+ , httpRequestBody = body+ }+ where+ options = callOptions call+ overriding preferred fallback =+ filter+ ((`notElem` protectedHeaders) . fst)+ (preferred <> [h | h@(name, _) <- fallback, name `notElem` map fst preferred])++-- | Decode a response: the call's result for a 2xx status, a 'ServiceError'+-- otherwise.+parseResponse :: Call a -> HttpResponse -> Either TypeSafeError a+parseResponse call response+ | statusIsSuccessful status =+ first+ (\problem -> ResponseError (UnexpectedResponse (callEndpoint call) rid problem body))+ (callDecode call rid body)+ | otherwise =+ Left (ServiceError (apiErrorFromResponse (callEndpoint call) status headers body))+ where+ status = httpResponseStatus response+ headers = httpResponseHeaders response+ body = httpResponseBody response+ rid = RequestId . Text.decodeUtf8With Text.lenientDecode <$> lookup requestIdHeader headers++-- | The method and path of a call, such as @POST \/v1\/systemone@, for logs+-- and error messages.+callEndpoint :: Call a -> Text+callEndpoint c =+ Text.decodeUtf8With Text.lenientDecode (callMethod c) <> " /" <> Text.intercalate "/" (callPath c)++-- | The retry policy set with 'withRetryPolicy', if any.+callRetryPolicy :: Call a -> Maybe RetryPolicy+callRetryPolicy = optionRetryPolicy . callOptions++-- | The per-attempt timeout set with 'withTimeout', if any.+callTimeout :: Call a -> Maybe NominalDiffTime+callTimeout = optionTimeout . callOptions++-- | Headers that only the SDK sets: authentication, content negotiation and+-- SDK identification. Extra headers with these names are dropped.+protectedHeaders :: [HeaderName]+protectedHeaders = ["Authorization", "Accept", "Content-Type", "Content-Length", "User-Agent"]++-- | @https:\/\/api.typesafe.ai@+defaultBaseUrl :: Text+defaultBaseUrl = "https://api.typesafe.ai"++-- | The response header that carries the request id.+requestIdHeader :: HeaderName+requestIdHeader = "x-typesafe-request-id"
+ src/TypeSafe/Content.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : TypeSafe.Content+-- Description : Text or structured JSON content+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- The TypeSafe API accepts /content/ in several places: the @state@ being+-- evaluated, a question's @instructions@, the descriptions of Choice options,+-- Score levels and Noul criteria. Everywhere, content is either a plain string+-- or structured JSON (an object or an array). Numbers, booleans and @null@ are+-- not valid content on their own.+--+-- 'Content' models exactly that. With @OverloadedStrings@ a string literal is+-- 'Content':+--+-- >>> encode ("Help! My payouts have been failing for 3 days." :: Content)+-- "\"Help! My payouts have been failing for 3 days.\""+--+-- Structured content is usually built with 'contentObject' or, for any type+-- with a 'ToJSON' instance, 'contentJSON':+--+-- >>> encode (contentObject ["subject" .= ("Duplicate charge" :: Text), "priority" .= (2 :: Int)])+-- "{\"priority\":2,\"subject\":\"Duplicate charge\"}"+--+-- See <https://docs.typesafe.ai/concepts/state> for advice on structuring+-- state, and <https://docs.typesafe.ai/primitives/advanced> for structured+-- instructions and criteria.+module TypeSafe.Content+ ( Content (..)+ , contentText+ , contentObject+ , contentArray+ , contentJSON+ , contentFromValue+ , contentToValue+ ) where++import Control.DeepSeq (NFData)+import Data.Aeson+ ( FromJSON (..)+ , Object+ , ToJSON (..)+ , Value (..)+ )+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Types (Array, Pair)+import Data.String (IsString (..))+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Vector as Vector+import GHC.Generics (Generic)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Aeson (encode, (.=), toJSON)+-- >>> import Data.Text (Text)++-- | Text, or a structured JSON object or array.+--+-- Use 'ContentText' (or a string literal) for prose, and 'ContentObject' or+-- 'ContentArray' for records, chat logs and other structured data. Questions+-- can point at fields of structured state by path, for example+-- @\"Does \`ticket.messages[0].text\` request a refund?\"@.+data Content+ = -- | A plain string.+ ContentText !Text+ | -- | A JSON object.+ ContentObject !Object+ | -- | A JSON array.+ ContentArray !Array+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | String literals are 'ContentText'.+instance IsString Content where+ fromString = ContentText . Text.pack++instance ToJSON Content where+ toJSON = contentToValue+ toEncoding = \case+ ContentText t -> toEncoding t+ ContentObject o -> toEncoding o+ ContentArray a -> toEncoding a++-- | Accepts a string, object or array; rejects numbers, booleans and @null@.+instance FromJSON Content where+ parseJSON v = case contentFromValue v of+ Just c -> pure c+ Nothing -> fail ("expected a string, an object or an array, but got " <> describe v)+ where+ describe = \case+ Number _ -> "a number"+ Bool _ -> "a boolean"+ Null -> "null"+ _ -> "an unsupported value"++-- | Plain text content.+contentText :: Text -> Content+contentText = ContentText++-- | Build an object from key/value pairs, like 'Data.Aeson.object'.+--+-- >>> encode (contentObject ["message" .= ("Please help." :: Text)])+-- "{\"message\":\"Please help.\"}"+contentObject :: [Pair] -> Content+contentObject = ContentObject . KeyMap.fromList++-- | Build an array of JSON values.+--+-- >>> encode (contentArray [toJSON ("first" :: Text), toJSON ("second" :: Text)])+-- "[\"first\",\"second\"]"+contentArray :: [Value] -> Content+contentArray = ContentArray . Vector.fromList++-- | Content from any value with a 'ToJSON' instance.+--+-- Objects, arrays and strings map to the matching constructor. A scalar+-- (number, boolean or @null@) is not valid content on its own, so it is sent+-- as its JSON text instead.+--+-- >>> contentJSON (["a", "b"] :: [Text])+-- ContentArray [String "a",String "b"]+--+-- >>> contentJSON (42 :: Int)+-- ContentText "42"+contentJSON :: (ToJSON a) => a -> Content+contentJSON a = case toJSON a of+ String t -> ContentText t+ Object o -> ContentObject o+ Array xs -> ContentArray xs+ scalar -> ContentText (Text.decodeUtf8 (LBS.toStrict (Aeson.encode scalar)))++-- | Convert a JSON value, if it is a string, object or array.+--+-- >>> contentFromValue (toJSON True)+-- Nothing+contentFromValue :: Value -> Maybe Content+contentFromValue = \case+ String t -> Just (ContentText t)+ Object o -> Just (ContentObject o)+ Array xs -> Just (ContentArray xs)+ _ -> Nothing++-- | The JSON value sent on the wire.+contentToValue :: Content -> Value+contentToValue = \case+ ContentText t -> String t+ ContentObject o -> Object o+ ContentArray xs -> Array xs
+ src/TypeSafe/Core.hs view
@@ -0,0 +1,100 @@+-- |+-- Module : TypeSafe.Core+-- Description : Types, codecs and calls for the TypeSafe API, without HTTP+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- Everything needed to talk to the TypeSafe System One API+-- (<https://docs.typesafe.ai>) except the network. Most applications should+-- depend on the @typesafe-ai@ package instead, which re-exports this module+-- together with a ready-to-use client.+--+-- Depend on @typesafe-ai-core@ directly when you want to bring your own HTTP+-- stack: this package depends only on @aeson@, @http-types@ and GHC's boot+-- libraries.+--+-- = Layers+--+-- ["TypeSafe.Question"] typed questions and answers: Choice options and+-- Score levels are your own Haskell types.+--+-- ["TypeSafe.Call"] API calls as values, plus the functions a transport needs+-- to send them.+--+-- ["TypeSafe.Wire"] the OpenAPI schemas, one Haskell type per schema, with+-- JSON codecs. Not re-exported here; import it (qualified) when you need it.+--+-- ["TypeSafe.Error"], ["TypeSafe.Retry"] errors and the retry policy.+--+-- = With servant or another HTTP library+--+-- The wire types have 'Data.Aeson.ToJSON' and 'Data.Aeson.FromJSON'+-- instances, so describing the API in another framework takes a few lines.+-- With servant, for example:+--+-- @+-- import qualified TypeSafe.Wire as Wire+--+-- type TypeSafeAPI =+-- Header' '[Required, Strict] \"Authorization\" Text+-- :> \"v1\"+-- :> ( \"systemone\" :> ReqBody '[JSON] Wire.SystemOneRequest :> Post '[JSON] Wire.SystemOneResponse+-- :\<|\> \"models\" :> Get '[JSON] Wire.ModelMetadataList+-- )+-- @+--+-- The typed layer works with any such client: build the request with+-- 'systemOneRequest' and decode the response with 'decodeEvaluation'.+--+-- @+-- case 'systemOneRequest' 'jevLatest' state triage of+-- Left err -> … -- rejected locally+-- Right request -> do+-- response <- runClientM (systemOneClient auth request) env+-- … 'decodeEvaluation' triage Nothing response …+-- @+--+-- To reuse the retry policy, error classification and header handling of the+-- bundled client as well, write a transport instead: see "TypeSafe.Call".+module TypeSafe.Core+ ( -- * Content+ module TypeSafe.Content++ -- * Questions and answers+ , module TypeSafe.Question++ -- * Calls+ , module TypeSafe.Call++ -- * Errors+ , module TypeSafe.Error++ -- * Retries+ , module TypeSafe.Retry++ -- * Identifiers and response metadata+ , ModelName (..)+ , jevLatest+ , jevPreview+ , QuestionId (..)+ , Usage (..)+ , ModelMetadata (..)+ , modelMetadataReleaseDay+ , apiSpecVersion+ ) where++import TypeSafe.Call+import TypeSafe.Content+import TypeSafe.Error+import TypeSafe.Question+import TypeSafe.Retry+import TypeSafe.Wire+ ( ModelMetadata (..)+ , ModelName (..)+ , QuestionId (..)+ , Usage (..)+ , apiSpecVersion+ , jevLatest+ , jevPreview+ , modelMetadataReleaseDay+ )
+ src/TypeSafe/Error.hs view
@@ -0,0 +1,397 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : TypeSafe.Error+-- Description : Everything that can go wrong, as values+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- Every failure the SDK reports is a 'TypeSafeError'. It separates four+-- situations that callers usually handle differently:+--+-- ['InvalidRequest'] the request was rejected locally and nothing was sent,+-- for example two questions share an id. This is a bug in the calling code.+--+-- ['ServiceError'] the API answered with an error status. 'apiErrorKind'+-- says which one ('Unauthorized', 'RateLimited', 'Overloaded', …).+--+-- ['ConnectionError'] no HTTP response arrived: DNS, TLS, a reset+-- connection, or a timeout.+--+-- ['ResponseError'] the API answered successfully, but the body did not match+-- what was asked, for example a choice outside the options you offered.+--+-- Transports built on "TypeSafe.Call" retry transient failures (see+-- "TypeSafe.Retry") before reporting them.+module TypeSafe.Error+ ( -- * Errors+ TypeSafeError (..)+ , renderTypeSafeError++ -- * Local request validation+ , RequestError (..)+ , QuestionProblem (..)++ -- * Error responses+ , ApiError (..)+ , ApiErrorKind (..)+ , apiErrorKindFor+ , apiErrorFromResponse+ , ErrorBody (..)+ , ErrorDetail (..)+ , parseErrorBody+ , RequestId (..)++ -- * Connection failures+ , ConnectionError (..)++ -- * Unusable responses+ , ResponseError (..)+ , ResponseProblem (..)+ , AnswerError (..)+ , AnswerProblem (..)+ ) where++import Control.DeepSeq (NFData)+import Control.Exception (Exception (..), SomeException)+import Data.Aeson (FromJSON (..), Value (..), withObject, (.:?))+import qualified Data.Aeson as Aeson+import Data.Aeson.Types (parseMaybe)+import qualified Data.ByteString.Char8 as BS8+import qualified Data.ByteString.Lazy as LBS+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty+import Data.Maybe (fromMaybe, listToMaybe)+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import qualified Data.Text.Encoding.Error as Text+import GHC.Generics (Generic)+import Network.HTTP.Types (ResponseHeaders, Status (..))+import TypeSafe.Wire+ ( HTTPValidationError (..)+ , LocationSegment (..)+ , QuestionId (..)+ , ValidationError (..)+ )++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Network.HTTP.Types (status401, status422, status429)++-- | Any failure reported by the SDK.+--+-- 'displayException' renders a one-line, human-readable summary (see+-- 'renderTypeSafeError'). API keys are never part of an error.+data TypeSafeError+ = -- | The request was rejected before anything was sent.+ InvalidRequest !RequestError+ | -- | The API answered with an error status.+ ServiceError !ApiError+ | -- | No HTTP response was received.+ ConnectionError !ConnectionError+ | -- | A successful response that does not match the request.+ ResponseError !ResponseError+ deriving stock (Show, Generic)++instance Exception TypeSafeError where+ displayException = Text.unpack . renderTypeSafeError++-- | A one-line, human-readable description of an error.+--+-- >>> renderTypeSafeError (InvalidRequest (DuplicateQuestionId "is_urgent"))+-- "invalid request: two questions use the id \"is_urgent\""+renderTypeSafeError :: TypeSafeError -> Text+renderTypeSafeError = \case+ InvalidRequest e -> "invalid request: " <> renderRequestError e+ ServiceError e ->+ apiErrorEndpoint e+ <> " failed with HTTP "+ <> tshow (statusCode (apiErrorStatus e))+ <> " ("+ <> tshow (apiErrorKind e)+ <> ")"+ <> maybe "" (": " <>) (apiErrorMessage e)+ <> requestIdSuffix (apiErrorRequestId e)+ ConnectionError (ConnectionFailed endpoint cause) ->+ endpoint <> ": connection failed: " <> Text.pack (displayException cause)+ ConnectionError (ConnectionTimedOut endpoint) ->+ endpoint <> ": timed out waiting for a response"+ ResponseError e ->+ responseErrorEndpoint e+ <> ": unexpected response: "+ <> renderProblem (responseErrorProblem e)+ <> requestIdSuffix (responseErrorRequestId e)+ where+ requestIdSuffix = maybe "" (\(RequestId r) -> " [request id " <> r <> "]")+ renderProblem = \case+ MalformedBody msg -> Text.pack msg+ MismatchedAnswers errs -> Text.intercalate "; " (map renderAnswerError (NonEmpty.toList errs))++renderRequestError :: RequestError -> Text+renderRequestError = \case+ NoQuestions -> "a request needs at least one question"+ DuplicateQuestionId (QuestionId q) -> "two questions use the id " <> tshow q+ InvalidQuestion (QuestionId q) problem -> "question " <> tshow q <> ": " <> renderQuestionProblem problem+ where+ renderQuestionProblem = \case+ DuplicateOption o -> "two options are named " <> tshow o++renderAnswerError :: AnswerError -> Text+renderAnswerError (AnswerError (QuestionId q) problem) =+ "question " <> tshow q <> ": " <> case problem of+ MissingAnswer -> "no answer in the response"+ UnexpectedAnswerType expected actual -> "expected a " <> expected <> " answer, got " <> actual+ UnknownOption o -> "the answer mentions option " <> tshow o <> ", which was not offered"+ UnknownLevel l -> "the answer mentions level " <> tshow l <> ", which is outside the rubric"+ UndecodableAnswer msg -> msg++------------------------------------------------------------------------------+-- Request validation++-- | Why a request was rejected before sending.+data RequestError+ = -- | The request has no questions. The API requires at least one.+ NoQuestions+ | -- | Two questions share an id, so their answers could not be told apart.+ DuplicateQuestionId !QuestionId+ | -- | A question is malformed.+ InvalidQuestion !QuestionId !QuestionProblem+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | What is wrong with a single question.+data QuestionProblem+ = -- | Two Choice options map to the same name.+ DuplicateOption !Text+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++------------------------------------------------------------------------------+-- Error responses++-- | The value of the @x-typesafe-request-id@ response header. Include it when+-- you contact TypeSafe support about a request.+newtype RequestId = RequestId {unRequestId :: Text}+ deriving newtype (Eq, Ord, Show, IsString, NFData)++-- | An error response from the API.+data ApiError = ApiError+ { apiErrorKind :: !ApiErrorKind+ -- ^ What the status code means.+ , apiErrorStatus :: !Status+ -- ^ The HTTP status.+ , apiErrorMessage :: !(Maybe Text)+ -- ^ The server's explanation, when the body has one.+ , apiErrorBody :: !ErrorBody+ -- ^ The parsed response body.+ , apiErrorHeaders :: !ResponseHeaders+ -- ^ The response headers, including any @Retry-After@.+ , apiErrorRequestId :: !(Maybe RequestId)+ -- ^ The request id assigned by the API.+ , apiErrorEndpoint :: !Text+ -- ^ The method and path that failed, such as @POST \/v1\/systemone@.+ }+ deriving stock (Eq, Show, Generic)++-- | The meaning of an error status.+data ApiErrorKind+ = -- | 400: the request is invalid.+ BadRequest+ | -- | 401: the API key is invalid.+ Unauthorized+ | -- | 403: access is denied. The API also uses this status when no API key+ -- is sent.+ PermissionDenied+ | -- | 404: the resource does not exist. Check the base URL.+ NotFound+ | -- | 422: the body failed validation. The 'ErrorBody' says which field.+ UnprocessableEntity+ | -- | 429: the rate limit is exceeded. Retry after a delay.+ RateLimited+ | -- | 529: TypeSafe is temporarily overloaded. Retry after a delay.+ Overloaded+ | -- | Any other 5xx status.+ InternalServerError+ | -- | Any other status.+ UnexpectedStatus+ deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic)+ deriving anyclass (NFData)++-- | Classify an error status.+--+-- >>> map apiErrorKindFor [status401, status422, status429, toEnum 529, toEnum 503, toEnum 418]+-- [Unauthorized,UnprocessableEntity,RateLimited,Overloaded,InternalServerError,UnexpectedStatus]+apiErrorKindFor :: Status -> ApiErrorKind+apiErrorKindFor s = case statusCode s of+ 400 -> BadRequest+ 401 -> Unauthorized+ 403 -> PermissionDenied+ 404 -> NotFound+ 422 -> UnprocessableEntity+ 429 -> RateLimited+ 529 -> Overloaded+ c+ | c >= 500 && c < 600 -> InternalServerError+ | otherwise -> UnexpectedStatus++-- | Build an 'ApiError' from the endpoint (for example+-- @\"POST \/v1\/systemone\"@) and an error response.+apiErrorFromResponse :: Text -> Status -> ResponseHeaders -> LBS.ByteString -> ApiError+apiErrorFromResponse endpoint status headers body =+ ApiError+ { apiErrorKind = apiErrorKindFor status+ , apiErrorStatus = status+ , apiErrorMessage = errorBodyMessage parsed+ , apiErrorBody = parsed+ , apiErrorHeaders = headers+ , apiErrorRequestId = RequestId . decodeLenient <$> lookup "x-typesafe-request-id" headers+ , apiErrorEndpoint = endpoint+ }+ where+ parsed = parseErrorBody body++-- | The body of an error response.+data ErrorBody+ = -- | Field-level validation failures, sent with HTTP 422.+ BodyValidation !HTTPValidationError+ | -- | A structured error, such as+ -- @{\"detail\": {\"error_type\": \"authentication_error\", \"message\": …}}@.+ BodyDetail !ErrorDetail+ | -- | Some other JSON document.+ BodyJson !Value+ | -- | A body that is not JSON.+ BodyText !Text+ | -- | No body.+ BodyEmpty+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | The @detail@ object of a structured error.+data ErrorDetail = ErrorDetail+ { errorDetailType :: !(Maybe Text)+ -- ^ A machine-readable category, such as @authentication_error@.+ , errorDetailMessage :: !(Maybe Text)+ -- ^ A human-readable explanation.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | Parse an error response body.+--+-- >>> parseErrorBody "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Cannot authenticate with the server.\"}}"+-- BodyDetail (ErrorDetail {errorDetailType = Just "authentication_error", errorDetailMessage = Just "Cannot authenticate with the server."})+--+-- >>> parseErrorBody "{\"detail\":\"Not Found\"}"+-- BodyDetail (ErrorDetail {errorDetailType = Nothing, errorDetailMessage = Just "Not Found"})+--+-- >>> parseErrorBody "upstream connect error"+-- BodyText "upstream connect error"+parseErrorBody :: LBS.ByteString -> ErrorBody+parseErrorBody body+ | BS8.all (`elem` (" \t\r\n" :: String)) (LBS.toStrict body) = BodyEmpty+ | otherwise = case Aeson.decode' body of+ Nothing -> BodyText (decodeLenient (LBS.toStrict body))+ Just v -> fromMaybe (BodyJson v) (parseMaybe structured v)+ where+ structured = withObject "error" $ \o -> do+ detail <- o .:? "detail"+ case detail of+ Just (Array _) -> BodyValidation <$> parseJSON (Object o)+ Just (String msg) -> pure (BodyDetail (ErrorDetail Nothing (Just msg)))+ Just (Object d) -> BodyDetail <$> (ErrorDetail <$> d .:? "error_type" <*> d .:? "message")+ _ -> fail "not a structured error"++errorBodyMessage :: ErrorBody -> Maybe Text+errorBodyMessage = \case+ BodyDetail d -> errorDetailMessage d+ BodyValidation v -> renderValidation <$> (httpValidationErrorDetail v >>= listToMaybe)+ BodyText t -> Just (Text.take 500 t)+ BodyJson _ -> Nothing+ BodyEmpty -> Nothing+ where+ renderValidation e =+ Text.intercalate "." (map segment (validationErrorLoc e)) <> ": " <> validationErrorMsg e+ segment = \case+ LocationField f -> f+ LocationIndex i -> tshow i++------------------------------------------------------------------------------+-- Connection failures++-- | A request that got no HTTP response. The 'Text' is the endpoint, such as+-- @POST \/v1\/systemone@.+data ConnectionError+ = -- | The connection could not be made or broke: DNS, TLS, refused or reset.+ -- The exception comes from the transport; the SDK redacts credentials+ -- from it.+ ConnectionFailed !Text !SomeException+ | -- | No response arrived within the timeout.+ ConnectionTimedOut !Text+ deriving stock (Show, Generic)++------------------------------------------------------------------------------+-- Unusable responses++-- | A successful response that could not be used.+data ResponseError = UnexpectedResponse+ { responseErrorEndpoint :: !Text+ -- ^ The method and path, such as @POST \/v1\/systemone@.+ , responseErrorRequestId :: !(Maybe RequestId)+ -- ^ The request id assigned by the API.+ , responseErrorProblem :: !ResponseProblem+ -- ^ What is wrong.+ , responseErrorBody :: !LBS.ByteString+ -- ^ The raw response body.+ }+ deriving stock (Eq, Show, Generic)++-- | What is wrong with a successful response.+data ResponseProblem+ = -- | The body does not match the response schema. The message includes a+ -- JSON path to the offending value.+ MalformedBody !String+ | -- | The body is valid, but some answers do not fit their questions.+ MismatchedAnswers !(NonEmpty AnswerError)+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | A problem with the answer to one question.+data AnswerError = AnswerError+ { answerErrorQuestion :: !QuestionId+ -- ^ The question whose answer is unusable.+ , answerErrorProblem :: !AnswerProblem+ -- ^ What is wrong with it.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | What is wrong with an answer.+data AnswerProblem+ = -- | The response has no answer for the question.+ MissingAnswer+ | -- | The answer is of a different type: expected, then actual.+ UnexpectedAnswerType !Text !Text+ | -- | The answer names a Choice option that was not offered.+ UnknownOption !Text+ | -- | The answer names a Score level outside the rubric.+ UnknownLevel !Int+ | -- | A custom decoder (see 'TypeSafe.Question.otherQuestion') rejected the+ -- answer.+ UndecodableAnswer !Text+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++------------------------------------------------------------------------------++decodeLenient :: BS8.ByteString -> Text+decodeLenient = Text.decodeUtf8With Text.lenientDecode++tshow :: (Show a) => a -> Text+tshow = Text.pack . show
+ src/TypeSafe/Internal/Generic.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : TypeSafe.Internal.Generic+-- Description : Generic enumeration of nullary constructors+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- Support code for the default methods of 'TypeSafe.Question.ChoiceOption'+-- and 'TypeSafe.Question.ScoreLevel'. It is exposed so that the constraints of+-- those defaults can be named in user code; its contents may change between+-- minor versions.+module TypeSafe.Internal.Generic+ ( GEnumerate (..)+ , GConstructorName (..)+ , genericEnumerate+ , genericConstructorName+ ) where++import Data.Kind (Type)+import Data.List.NonEmpty (NonEmpty (..))+import GHC.Generics+import GHC.TypeLits (ErrorMessage (..), TypeError)++-- | Types whose generic representation is a sum of constructors without+-- fields.+class GEnumerate (f :: Type -> Type) where+ -- | Every value, in declaration order.+ genumerate :: [f p]++instance GEnumerate U1 where+ genumerate = [U1]++instance (GEnumerate f, GEnumerate g) => GEnumerate (f :+: g) where+ genumerate = map L1 genumerate <> map R1 genumerate++instance (GEnumerate f) => GEnumerate (D1 c f) where+ genumerate = map M1 genumerate++instance (GEnumerate f) => GEnumerate (C1 c f) where+ genumerate = map M1 genumerate++instance+ ( TypeError+ ( 'Text "Cannot derive the options of a type whose constructors have fields."+ ':$$: 'Text "Choice options and Score levels are derived for enumerations such as"+ ':$$: 'Text " data Department = Billing | Technical | Sales"+ ':$$: 'Text "Implement the class methods by hand, or use choiceBy / scoreBy."+ )+ ) =>+ GEnumerate (S1 c f)+ where+ genumerate = []++instance+ ( TypeError+ ( 'Text "Cannot derive the options of a type without constructors."+ ':$$: 'Text "A Choice needs at least one option and a Score at least one level."+ )+ ) =>+ GEnumerate V1+ where+ genumerate = []++-- | Every constructor of an enumeration, in declaration order.+genericEnumerate :: (Generic a, GEnumerate (Rep a)) => NonEmpty a+genericEnumerate = case map to genumerate of+ x : xs -> x :| xs+ -- Unreachable: types without constructors are rejected by the V1 instance.+ [] -> error "TypeSafe.Internal.Generic.genericEnumerate: no constructors"++-- | Types whose generic representation lets us name the constructor.+class GConstructorName (f :: Type -> Type) where+ gconstructorName :: f p -> String++instance (GConstructorName f) => GConstructorName (D1 c f) where+ gconstructorName (M1 x) = gconstructorName x++instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where+ gconstructorName (L1 x) = gconstructorName x+ gconstructorName (R1 x) = gconstructorName x++instance (Constructor c) => GConstructorName (C1 c f) where+ gconstructorName = conName++-- | The name of the constructor used to build a value.+genericConstructorName :: (Generic a, GConstructorName (Rep a)) => a -> String+genericConstructorName = gconstructorName . from
+ src/TypeSafe/Question.hs view
@@ -0,0 +1,695 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- |+-- Module : TypeSafe.Question+-- Description : Typed questions, typed answers+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- TypeSafe has three kinds of question, and each comes back as a different+-- kind of answer:+--+-- +------------+---------------------------+-----------------------------------------++-- | Question | Asks | Answer |+-- +============+===========================+=========================================++-- | 'noul' | Is this true? | 'Noul': the probability of yes |+-- +------------+---------------------------+-----------------------------------------++-- | 'choice' | Which of these options? | 'Choice': the option, its distribution |+-- | | | and a confidence |+-- +------------+---------------------------+-----------------------------------------++-- | 'score' | Which level of a rubric? | 'Score': an expected level, its |+-- | | | distribution and a confidence |+-- +------------+---------------------------+-----------------------------------------++--+-- A @'Question' a@ is one question whose answer decodes to an @a@. Choice+-- options and Score levels are ordinary Haskell types, so an answer can only+-- ever be one of the values you offered.+--+-- Questions are combined into a request with 'ask' and the 'Applicative'+-- instance of 'Questions'. Each question needs an id, and the ids of one+-- request must be distinct.+--+-- = Example+--+-- Declare the options and levels as enumerations:+--+-- >>> :{+-- data Department = Billing | Technical | Sales+-- deriving stock (Show, Eq, Generic)+-- deriving anyclass (ChoiceOption)+-- :}+--+-- >>> :{+-- data Frustration = Calm | Frustrated | VeryAngry+-- deriving stock (Show, Eq, Generic)+-- deriving anyclass (ScoreLevel)+-- :}+--+-- Then describe the result you want and the questions that produce it:+--+-- >>> :{+-- data Triage = Triage+-- { department :: Choice Department+-- , urgent :: Noul+-- , frustration :: Score Frustration+-- }+-- :}+--+-- >>> :{+-- triage :: Questions Triage+-- triage =+-- Triage+-- <$> ask "department" (choice "Which team should handle this?")+-- <*> ask "is_urgent" (noul "Does this convey urgency?")+-- <*> ask "frustration" (score "How frustrated is the customer?")+-- :}+--+-- The option and level names come from the constructors: @Billing@ is sent+-- as @billing@ and @VeryAngry@ as @very angry@. Override 'optionName',+-- 'optionDescription' and 'levelDescription' to say more.+--+-- @triage@ renders to the @questions@ of an API request+--+-- >>> either print (LBS.putStrLn . encode) (renderQuestions triage)+-- {"department":{"type":"choice","instructions":"Which team should handle this?","criteria":{"billing":null,"technical":null,"sales":null}},"frustration":{"type":"score","instructions":"How frustrated is the customer?","criteria":["calm","frustrated","very angry"]},"is_urgent":{"type":"noul","instructions":"Does this convey urgency?"}}+--+-- and decodes the answers of the response:+--+-- >>> :{+-- let Right answers = eitherDecode $ LBS.concat+-- [ "{\"department\":{\"type\":\"choice\",\"choice\":\"billing\",\"confidence\":0.81,"+-- , "\"probabilities\":{\"billing\":0.88,\"technical\":0.12,\"sales\":0.0}},"+-- , "\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95},"+-- , "\"frustration\":{\"type\":\"score\",\"score\":1.05,\"confidence\":0.92,"+-- , "\"legend\":{\"0\":\"calm\",\"1\":\"frustrated\",\"2\":\"very angry\"},"+-- , "\"probabilities\":{\"0\":0.0,\"1\":0.95,\"2\":0.05}}}"+-- ]+-- :}+--+-- >>> let Right result = decodeAnswers triage answers+-- >>> choiceSelected (department result)+-- Billing+-- >>> noulProbability (urgent result)+-- 0.95+-- >>> mostLikelyLevel (frustration result)+-- Frustrated+--+-- In a program you rarely call 'renderQuestions' or 'decodeAnswers'+-- yourself. Pass the 'Questions' to 'TypeSafe.Call.systemOne' and send the+-- call with a client, such as @TypeSafe.Client.send@ from the @typesafe-ai@+-- package.+--+-- = Why there is no @Monad@+--+-- 'Questions' is an 'Applicative' and deliberately not a 'Monad'. Every+-- question in a request sees the same state and is answered independently, in+-- parallel. A question cannot depend on another one's answer, so the types+-- do not let you write one that does. When a follow-up question really+-- depends on an answer, send a second request.+--+-- With @ApplicativeDo@ you can still use @do@ notation, provided no question+-- uses an earlier answer:+--+-- @+-- {-# LANGUAGE ApplicativeDo #-}+--+-- triage :: 'Questions' Triage+-- triage = do+-- department <- 'ask' \"department\" ('choice' \"Which team should handle this?\")+-- urgent <- 'ask' \"is_urgent\" ('noul' \"Does this convey urgency?\")+-- frustration <- 'ask' \"frustration\" ('score' \"How frustrated is the customer?\")+-- pure Triage {..}+-- @+--+-- = Many questions at once+--+-- 'Questions' is 'Traversable'-friendly, so fan-out patterns such as+-- scoring every passage of a search result are one 'traverse':+--+-- @+-- relevance :: Text -> [Text] -> 'Questions' [(Text, 'Noul')]+-- relevance query passages =+-- for (zip [0 :: Int ..] passages) $ \\(i, passage) ->+-- (,) passage+-- \<$\> 'ask' ('QuestionId' (\"passage_\" <> Text.pack (show i)))+-- ('noul' ('TypeSafe.Content.contentObject' [\"query\" .= query, \"passage\" .= passage, \"question\" .= (\"Does \`passage\` answer \`query\`?\" :: Text)]))+-- @+module TypeSafe.Question+ ( -- * Asking questions+ Questions+ , ask+ , askMap+ , questionIds+ , renderQuestions+ , decodeAnswers++ -- * A single question+ , Question+ , questionSpec+ , decodeAnswer++ -- * Noul: yes or no+ , noul+ , noulWith+ , Noul (..)++ -- * Choice: one of several options+ , choice+ , choiceBy+ , ChoiceOption (..)+ , Choice (..)+ , choiceProbability+ , rankedChoices++ -- * Score: a level of a rubric+ , score+ , scoreBy+ , scoreRubric+ , ScoreLevel (..)+ , Score (..)+ , scoreProbability+ , mostLikelyLevel+ , nearestLevel+ , normalizedScore++ -- * Other question types+ , rawQuestion+ , otherQuestion++ -- * Probability and confidence+ , Probability (..)+ , Confidence (..)+ , HasConfidence (..)+ ) where++import Control.DeepSeq (NFData)+import Control.Monad (unless)+import Data.Aeson (FromJSON (..), Object, ToJSON (..), camelTo2)+import Data.Aeson.Types (parseEither)+import Data.Bifunctor (first)+import Data.Foldable (toList, traverse_)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import Data.Maybe (fromMaybe)+import qualified Data.Map.Strict as Map+import Data.Ord (Down (..))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import GHC.Generics (Generic, Rep)+import TypeSafe.Content (Content (..))+import TypeSafe.Error+ ( AnswerError (..)+ , AnswerProblem (..)+ , QuestionProblem (..)+ , RequestError (..)+ )+import TypeSafe.Internal.Generic+ ( GConstructorName+ , GEnumerate+ , genericConstructorName+ , genericEnumerate+ )+import TypeSafe.Wire (QuestionId (..))+import qualified TypeSafe.Wire as Wire++-- $setup+-- >>> :set -XOverloadedStrings -XDeriveGeneric -XDeriveAnyClass -XDerivingStrategies+-- >>> import GHC.Generics (Generic)+-- >>> import Data.Aeson (encode, eitherDecode)+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS++------------------------------------------------------------------------------+-- Probability and confidence++-- | A probability between 0 and 1.+--+-- Numeric literals work directly, so thresholds read naturally:+-- @noulProbability answer >= 0.8@.+newtype Probability = Probability {unProbability :: Double}+ deriving newtype (Eq, Ord, Show, Num, Fractional, Floating, Real, RealFrac, NFData, ToJSON, FromJSON)++-- | How certain the model is about a Choice or a Score, between 0 and 1.+--+-- Confidence is derived from the shape of the probability distribution: a+-- peaked distribution gives high confidence. It is not the probability of the+-- selected option. Use it to decide whether to act on an answer or escalate+-- it; see <https://docs.typesafe.ai/confidence>.+newtype Confidence = Confidence {unConfidence :: Double}+ deriving newtype (Eq, Ord, Show, Num, Fractional, Floating, Real, RealFrac, NFData, ToJSON, FromJSON)++-- | Answers that report a 'Confidence'.+class HasConfidence a where+ confidence :: a -> Confidence++------------------------------------------------------------------------------+-- Answers++-- | The answer to a 'noul' question.+newtype Noul = Noul+ { noulProbability :: Probability+ -- ^ The probability that the answer is yes. Near 1 is a strong yes, near 0+ -- a strong no, and near 0.5 means the model is unsure.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | The answer to a 'choice' question over options of type @a@.+data Choice a = Choice+ { choiceSelected :: !a+ -- ^ The option with the highest probability.+ , choiceProbabilities :: !(NonEmpty (a, Probability))+ -- ^ Every option offered, in the order it was offered, with its+ -- probability. The probabilities sum to approximately 1.+ , choiceConfidence :: !Confidence+ -- ^ How certain the model is.+ }+ deriving stock (Eq, Show, Generic, Functor)+ deriving anyclass (NFData)++instance HasConfidence (Choice a) where+ confidence = choiceConfidence++-- | The probability of one option.+--+-- >>> choiceProbability "technical" (Choice "billing" (("billing", 0.88) :| [("technical", 0.12)]) 0.81)+-- 0.12+choiceProbability :: (Eq a) => a -> Choice a -> Probability+choiceProbability o = fromMaybe 0 . lookup o . toList . choiceProbabilities++-- | The options from most to least likely. Options with equal probability+-- keep the order they were offered in.+--+-- >>> rankedChoices (Choice "billing" (("sales", 0.02) :| [("billing", 0.88), ("technical", 0.1)]) 0.81)+-- ("billing",0.88) :| [("technical",0.1),("sales",2.0e-2)]+rankedChoices :: Choice a -> NonEmpty (a, Probability)+rankedChoices = NonEmpty.sortWith (Down . snd) . choiceProbabilities++-- | The answer to a 'score' question over levels of type @a@.+data Score a = Score+ { scoreValue :: !Double+ -- ^ The expected level: the probability-weighted average of the level+ -- indices, counting from 0. It can fall between two levels.+ , scoreProbabilities :: !(NonEmpty (a, Probability))+ -- ^ Every level, lowest first, with its probability. The probabilities+ -- sum to approximately 1.+ , scoreConfidence :: !Confidence+ -- ^ How certain the model is.+ }+ deriving stock (Eq, Show, Generic, Functor)+ deriving anyclass (NFData)++instance HasConfidence (Score a) where+ confidence = scoreConfidence++-- | The probability of one level.+scoreProbability :: (Eq a) => a -> Score a -> Probability+scoreProbability l = fromMaybe 0 . lookup l . toList . scoreProbabilities++-- | The level with the highest probability. On a tie, the lower level wins.+--+-- >>> mostLikelyLevel (Score 1.05 (("calm", 0) :| [("frustrated", 0.95), ("very angry", 0.05)]) 0.92)+-- "frustrated"+mostLikelyLevel :: Score a -> a+mostLikelyLevel = fst . foldr1 higher . scoreProbabilities+ where+ higher x y = if snd y > snd x then y else x++-- | The level closest to 'scoreValue'.+--+-- The expected level blends the distribution, so it can differ from+-- 'mostLikelyLevel' when the probability mass is spread out.+--+-- >>> nearestLevel (Score 1.6 (("low", 0.1) :| [("medium", 0.2), ("high", 0.7)]) 0.6)+-- "high"+nearestLevel :: Score a -> a+nearestLevel s = fst (levels NonEmpty.!! index)+ where+ levels = scoreProbabilities s+ lastIndex = NonEmpty.length levels - 1+ index = max 0 (min lastIndex (round (scoreValue s)))++-- | 'scoreValue' scaled to the range 0–1, so that scores from rubrics of+-- different lengths can be weighted and combined (see+-- <https://docs.typesafe.ai/patterns/composite-scoring>).+--+-- >>> normalizedScore (Score 1.5 (("low", 0.1) :| [("medium", 0.3), ("high", 0.6)]) 0.6)+-- 0.75+normalizedScore :: Score a -> Double+normalizedScore s+ | lastIndex <= 0 = 0+ | otherwise = scoreValue s / fromIntegral lastIndex+ where+ lastIndex = NonEmpty.length (scoreProbabilities s) - 1++------------------------------------------------------------------------------+-- Questions++-- | A single question whose answer decodes to an @a@.+--+-- Build questions with 'noul', 'choice', 'score' and friends, and adapt the+-- answer with 'fmap':+--+-- @+-- isUrgent :: 'Question' Bool+-- isUrgent = (\\a -> 'noulProbability' a >= 0.8) \<$\> 'noul' \"Does this convey urgency?\"+-- @+data Question a = Question+ { questionSpec_ :: !(Either QuestionProblem Wire.Question)+ , questionDecoder :: Wire.Answer -> Either AnswerProblem a+ }+ deriving stock (Functor)++-- | The wire representation of the question, or why it is malformed.+questionSpec :: Question a -> Either QuestionProblem Wire.Question+questionSpec = questionSpec_++-- | Decode the answer to this question.+decodeAnswer :: Question a -> Wire.Answer -> Either AnswerProblem a+decodeAnswer = questionDecoder++-- | A yes\/no question, or a statement to judge as true or false.+--+-- >>> LBS.putStrLn (either (const "") encode (questionSpec (noul "Does this convey urgency?")))+-- {"type":"noul","instructions":"Does this convey urgency?"}+noul :: Content -> Question Noul+noul instructions = noulQuestion (Wire.NoulQuestion (Just instructions) Nothing)++-- | A yes\/no question with descriptions of what a yes and a no mean.+--+-- >>> LBS.putStrLn (either (const "") encode (questionSpec (noulWith "Does this convey urgency?" "Explicitly time-sensitive" "No urgency expressed")))+-- {"type":"noul","instructions":"Does this convey urgency?","criteria":{"true":"Explicitly time-sensitive","false":"No urgency expressed"}}+noulWith+ :: Content+ -- ^ The question.+ -> Content+ -- ^ What a yes (a value near 1) means.+ -> Content+ -- ^ What a no (a value near 0) means.+ -> Question Noul+noulWith instructions yes no =+ noulQuestion+ ( Wire.NoulQuestion+ (Just instructions)+ (Just (Wire.NoulCriteria (Just yes) (Just no)))+ )++noulQuestion :: Wire.NoulQuestion -> Question Noul+noulQuestion q = Question (Right (Wire.QuestionNoul q)) $ \case+ Wire.AnswerNoul a -> Right (Noul (Probability (Wire.noulAnswerNoul a)))+ other -> Left (UnexpectedAnswerType "noul" (Wire.answerType other))++-- | Types whose values are the options of a Choice.+--+-- For an enumeration, derive the instance: the options are the constructors+-- in declaration order, named in snake case (@NeedsReview@ becomes+-- @needs_review@), without descriptions.+--+-- @+-- data Department = Billing | Technical | Sales+-- deriving stock (Show, Eq, Generic)+-- deriving anyclass ('ChoiceOption')+-- @+--+-- Descriptions tell the model when each option applies. Add them by+-- overriding 'optionDescription':+--+-- @+-- instance 'ChoiceOption' Department where+-- 'optionDescription' = Just . \\case+-- Billing -> \"Payments, invoicing, refunds\"+-- Technical -> \"Bugs, outages, integrations\"+-- Sales -> \"Pricing, upgrades, new accounts\"+-- @+--+-- The option name is what the model reads when there is no description,+-- so choose constructor names (or override 'optionName') with care. Names+-- must be distinct.+class ChoiceOption a where+ -- | Every option, in the order it is offered.+ choiceOptions :: NonEmpty a+ default choiceOptions :: (Generic a, GEnumerate (Rep a)) => NonEmpty a+ choiceOptions = genericEnumerate++ -- | The name sent to the API, and expected back in the answer.+ optionName :: a -> Text+ default optionName :: (Generic a, GConstructorName (Rep a)) => a -> Text+ optionName = Text.pack . camelTo2 '_' . genericConstructorName++ -- | When this option applies. 'Nothing' lets the name speak for itself.+ optionDescription :: a -> Maybe Content+ optionDescription _ = Nothing++-- | Pick one option of a 'ChoiceOption' type.+--+-- The option type is usually inferred from where the answer is used; you can+-- also fix it with a type application: @choice \@Department \"Which team?\"@.+choice :: (ChoiceOption a) => Content -> Question (Choice a)+choice instructions = choiceBy optionName optionDescription instructions choiceOptions++-- | Pick one of the given options, named and described by the two+-- functions. Use it when the options are only known at run time, such as a+-- catalogue loaded from a database.+--+-- >>> let skills = ("pdf", "Read and fill PDF files") :| [("xlsx", "Edit spreadsheets")]+-- >>> let q = choiceBy fst (Just . ContentText . snd) "Which skill fits the request?" skills+-- >>> LBS.putStrLn (either (const "") encode (questionSpec q))+-- {"type":"choice","instructions":"Which skill fits the request?","criteria":{"pdf":"Read and fill PDF files","xlsx":"Edit spreadsheets"}}+--+-- The names must be distinct. Otherwise the question is rejected, before+-- anything is sent, with 'DuplicateOption'.+choiceBy+ :: (a -> Text)+ -- ^ The name of an option.+ -> (a -> Maybe Content)+ -- ^ When the option applies, if the name is not enough.+ -> Content+ -- ^ What the model should decide.+ -> NonEmpty a+ -- ^ The options, in the order they are offered.+ -> Question (Choice a)+choiceBy name describe instructions options = Question spec decode+ where+ named = fmap (\o -> (name o, o)) options+ table = Map.fromList (toList named)+ spec = case firstDuplicate (map fst (toList named)) of+ Just dup -> Left (DuplicateOption dup)+ Nothing ->+ Right . Wire.QuestionChoice $+ Wire.ChoiceQuestion+ { Wire.choiceQuestionInstructions = Just instructions+ , Wire.choiceQuestionCriteria = [(n, describe o) | (n, o) <- toList named]+ }+ decode = \case+ Wire.AnswerChoice a -> do+ selected <- lookupOption (Wire.choiceAnswerChoice a)+ let probabilities = Wire.choiceAnswerProbabilities a+ traverse_ lookupOption (Map.keys probabilities)+ pure+ Choice+ { choiceSelected = selected+ , choiceProbabilities =+ fmap (\(n, o) -> (o, Probability (Map.findWithDefault 0 n probabilities))) named+ , choiceConfidence = Confidence (Wire.choiceAnswerConfidence a)+ }+ other -> Left (UnexpectedAnswerType "choice" (Wire.answerType other))+ lookupOption n = maybe (Left (UnknownOption n)) Right (Map.lookup n table)++-- | Types whose values are the levels of a Score rubric, lowest first.+--+-- For an enumeration, derive the instance: the levels are the constructors in+-- declaration order, described by their names in lower case words+-- (@VeryAngry@ becomes @very angry@).+--+-- Good level descriptions make scores far more consistent, so consider+-- writing them out:+--+-- @+-- data Severity = Cosmetic | Degraded | Outage+-- deriving stock (Show, Eq, Generic)+--+-- instance 'ScoreLevel' Severity where+-- 'levelDescription' = \\case+-- Cosmetic -> \"Cosmetic: nothing is broken\"+-- Degraded -> \"Degraded: a feature misbehaves but there is a workaround\"+-- Outage -> \"Outage: customers cannot use the product\"+-- @+class ScoreLevel a where+ -- | Every level, lowest first.+ scoreLevels :: NonEmpty a+ default scoreLevels :: (Generic a, GEnumerate (Rep a)) => NonEmpty a+ scoreLevels = genericEnumerate++ -- | What the level means.+ levelDescription :: a -> Content+ default levelDescription :: (Generic a, GConstructorName (Rep a)) => a -> Content+ levelDescription = ContentText . Text.pack . camelTo2 ' ' . genericConstructorName++-- | Rate the state on the levels of a 'ScoreLevel' type.+score :: (ScoreLevel a) => Content -> Question (Score a)+score instructions = scoreBy levelDescription instructions scoreLevels++-- | Rate the state on the given levels, lowest first, described by the+-- function.+scoreBy+ :: (a -> Content)+ -- ^ What a level means.+ -> Content+ -- ^ What the model should rate.+ -> NonEmpty a+ -- ^ The levels, lowest first. The API accepts up to 10.+ -> Question (Score a)+scoreBy describe instructions levels = Question spec decode+ where+ levelCount = NonEmpty.length levels+ spec =+ Right . Wire.QuestionScore $+ Wire.ScoreQuestion+ { Wire.scoreQuestionInstructions = Just instructions+ , Wire.scoreQuestionCriteria = fmap describe levels+ }+ decode = \case+ Wire.AnswerScore a -> do+ let probabilities = Wire.scoreAnswerProbabilities a+ traverse_+ (\i -> unless (i >= 0 && i < levelCount) (Left (UnknownLevel i)))+ (Map.keys probabilities)+ pure+ Score+ { scoreValue = Wire.scoreAnswerScore a+ , scoreProbabilities =+ NonEmpty.zipWith+ (\i l -> (l, Probability (Map.findWithDefault 0 i probabilities)))+ (0 :| [1 ..])+ levels+ , scoreConfidence = Confidence (Wire.scoreAnswerConfidence a)+ }+ other -> Left (UnexpectedAnswerType "score" (Wire.answerType other))++-- | Rate the state on a rubric given as descriptions, lowest first. The+-- levels of the answer are their indices, counting from 0.+--+-- >>> let q = scoreRubric "How frustrated is the customer?" ("Calm" :| ["Frustrated", "Very angry"])+-- >>> LBS.putStrLn (either (const "") encode (questionSpec q))+-- {"type":"score","instructions":"How frustrated is the customer?","criteria":["Calm","Frustrated","Very angry"]}+scoreRubric :: Content -> NonEmpty Content -> Question (Score Int)+scoreRubric instructions descriptions =+ fmap fst <$> scoreBy snd instructions (NonEmpty.zip (0 :| [1 ..]) descriptions)++-- | Send a question as-is and receive its answer as-is.+rawQuestion :: Wire.Question -> Question Wire.Answer+rawQuestion q = Question (Right q) Right++-- | A question of a type this SDK does not support yet, given by its @type@+-- tag and the rest of its JSON object. The answer is decoded with its+-- 'FromJSON' instance, from the complete answer object (including @type@).+--+-- This keeps new question types usable, with typed answers, before the SDK+-- adds first-class support for them.+otherQuestion :: (FromJSON a) => Text -> Object -> Question a+otherQuestion tag body = Question (Right (Wire.QuestionOther tag body)) $ \answer ->+ if Wire.answerType answer == tag+ then first (UndecodableAnswer . Text.pack) (parseEither parseJSON (toJSON answer))+ else Left (UnexpectedAnswerType tag (Wire.answerType answer))++------------------------------------------------------------------------------+-- Several questions++-- | Named questions to send in one request, and how to assemble their+-- answers into an @a@.+--+-- Combine them with 'ask' and the 'Applicative' instance; see the module+-- header for an example.+data Questions a = Questions+ { questionsEntries :: !(Seq (QuestionId, Either QuestionProblem Wire.Question))+ , questionsDecoder :: Map QuestionId Wire.Answer -> Collect a+ }+ deriving stock (Functor)++instance Applicative Questions where+ pure x = Questions Seq.empty (const (Collected x))+ Questions e1 d1 <*> Questions e2 d2 = Questions (e1 <> e2) (\answers -> d1 answers <*> d2 answers)++-- | Ask a question under an id. Its answer comes back under the same id; the+-- id itself is not shown to the model.+ask :: QuestionId -> Question a -> Questions a+ask qid q = Questions (Seq.singleton (qid, questionSpec q)) $ \answers ->+ case Map.lookup qid answers of+ Nothing -> failed (AnswerError qid MissingAnswer)+ Just a -> either (failed . AnswerError qid) Collected (decodeAnswer q a)+ where+ failed e = Failed (e :| [])++-- | Ask every question of a map, keyed by its id.+askMap :: Map QuestionId (Question a) -> Questions (Map QuestionId a)+askMap = Map.traverseWithKey ask++-- | The ids of the questions, in the order they were asked.+questionIds :: Questions a -> [QuestionId]+questionIds = map fst . toList . questionsEntries++-- | The @questions@ object of a request.+--+-- Fails if there are no questions, if two share an id, or if a question is+-- malformed; the first problem in the order of asking is reported.+--+-- >>> renderQuestions (pure ())+-- Left NoQuestions+--+-- >>> renderQuestions (ask "q" (noul "Is it?") *> ask "q" (noul "Is it really?"))+-- Left (DuplicateQuestionId "q")+renderQuestions :: Questions a -> Either RequestError (Map QuestionId Wire.Question)+renderQuestions qs+ | Seq.null entries = Left NoQuestions+ | otherwise = go Map.empty (toList entries)+ where+ entries = questionsEntries qs+ go acc [] = Right acc+ go acc ((qid, spec) : rest)+ | Map.member qid acc = Left (DuplicateQuestionId qid)+ | otherwise = case spec of+ Left problem -> Left (InvalidQuestion qid problem)+ Right q -> go (Map.insert qid q acc) rest++-- | Assemble the answers of a response. Reports every unusable answer, not+-- only the first.+decodeAnswers :: Questions a -> Map QuestionId Wire.Answer -> Either (NonEmpty AnswerError) a+decodeAnswers qs answers = case questionsDecoder qs answers of+ Failed errs -> Left errs+ Collected a -> Right a++------------------------------------------------------------------------------+-- Internals++-- | Like @Either (NonEmpty AnswerError)@, but '<*>' collects every error.+data Collect a+ = Failed !(NonEmpty AnswerError)+ | Collected a+ deriving stock (Functor)++instance Applicative Collect where+ pure = Collected+ Failed e1 <*> Failed e2 = Failed (e1 <> e2)+ Failed e <*> Collected _ = Failed e+ Collected _ <*> Failed e = Failed e+ Collected f <*> Collected x = Collected (f x)++firstDuplicate :: (Ord a) => [a] -> Maybe a+firstDuplicate = go Set.empty+ where+ go _ [] = Nothing+ go seen (x : xs)+ | Set.member x seen = Just x+ | otherwise = go (Set.insert x seen) xs
+ src/TypeSafe/Retry.hs view
@@ -0,0 +1,193 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : TypeSafe.Retry+-- Description : When and how long to wait before retrying+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- Retrying is the transport's job, but the policy is plain data so that+-- every transport behaves the same way. The defaults match the official+-- Python and JavaScript SDKs:+--+-- * up to 2 retries after the first attempt;+-- * retry on HTTP 408, 429 and any 5xx (including TypeSafe's 529+-- "overloaded"), on connection failures and on timeouts;+-- * exponential backoff from 0.5 s, doubling up to 5 s, with up to 25 %+-- jitter;+-- * honour @Retry-After@ and @retry-after-ms@ when the server asks for a+-- delay of at most 60 s;+-- * give up once 30 s have passed since the first attempt.+--+-- Every function here is pure; randomness and time are passed in, which also+-- makes the policy easy to test.+module TypeSafe.Retry+ ( -- * Policy+ RetryPolicy (..)+ , defaultRetryPolicy+ , noRetries++ -- * Decisions+ , isRetryable+ , retryDelay+ , backoffDelay+ , applyJitter+ , retryAfter+ ) where++import Control.Applicative ((<|>))+import Control.DeepSeq (NFData)+import qualified Data.ByteString.Char8 as BS8+import Data.Char (digitToInt, isDigit)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime)+import Data.Time.Format (defaultTimeLocale, parseTimeM)+import GHC.Generics (Generic)+import Network.HTTP.Types (ResponseHeaders, statusCode)+import TypeSafe.Error+ ( ApiError (..)+ , ConnectionError (..)+ , TypeSafeError (..)+ )++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Time (UTCTime (..), fromGregorian)+-- >>> let now = UTCTime (fromGregorian 2026 9 22) 0++-- | How a transport retries failed requests. Durations are in seconds.+data RetryPolicy = RetryPolicy+ { retryMaxRetries :: !Int+ -- ^ Retries after the first attempt. @0@ disables retrying.+ , retryInitialBackoff :: !NominalDiffTime+ -- ^ The first backoff delay. It doubles with every retry.+ , retryMaxBackoff :: !NominalDiffTime+ -- ^ The longest backoff delay.+ , retryJitter :: !Double+ -- ^ The largest fraction, between 0 and 1, randomly taken off each backoff+ -- delay so that clients do not retry in lockstep.+ , retryStatuses :: !(Set Int)+ -- ^ The HTTP status codes worth retrying.+ , retryRespectRetryAfter :: !Bool+ -- ^ Wait as long as the server asks with @Retry-After@ or+ -- @retry-after-ms@, up to 'retryMaxRetryAfter'.+ , retryMaxRetryAfter :: !NominalDiffTime+ -- ^ The longest server-requested delay to honour. Longer requests fall back+ -- to the backoff delay.+ , retryConnectionErrors :: !Bool+ -- ^ Retry requests that failed without a response.+ , retryTimeouts :: !Bool+ -- ^ Retry requests that timed out.+ , retryBudget :: !(Maybe NominalDiffTime)+ -- ^ Stop retrying when the next attempt would start this long after the+ -- first one. 'Nothing' means no limit.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | The policy described in the module header.+defaultRetryPolicy :: RetryPolicy+defaultRetryPolicy =+ RetryPolicy+ { retryMaxRetries = 2+ , retryInitialBackoff = 0.5+ , retryMaxBackoff = 5+ , retryJitter = 0.25+ , retryStatuses = Set.fromList (408 : 429 : [500 .. 599])+ , retryRespectRetryAfter = True+ , retryMaxRetryAfter = 60+ , retryConnectionErrors = True+ , retryTimeouts = True+ , retryBudget = Just 30+ }++-- | Never retry.+noRetries :: RetryPolicy+noRetries = defaultRetryPolicy {retryMaxRetries = 0}++-- | Whether the policy retries this error (ignoring the retry count and+-- budget). Local validation errors and unusable responses are never retried:+-- sending the same request again would fail the same way.+isRetryable :: RetryPolicy -> TypeSafeError -> Bool+isRetryable policy = \case+ ServiceError e -> statusCode (apiErrorStatus e) `Set.member` retryStatuses policy+ ConnectionError (ConnectionTimedOut _) -> retryTimeouts policy+ ConnectionError (ConnectionFailed _ _) -> retryConnectionErrors policy+ InvalidRequest _ -> False+ ResponseError _ -> False++-- | How long to wait before retry number @n@ (counting from 1).+--+-- A delay requested by the server wins when the policy honours it and it is+-- short enough; otherwise it is the backoff delay with jitter applied. The+-- 'Double' is a uniformly random number in [0, 1) that drives the jitter.+--+-- >>> retryDelay defaultRetryPolicy now 0 1 (ConnectionError (ConnectionTimedOut "POST /v1/systemone"))+-- 0.5s+retryDelay :: RetryPolicy -> UTCTime -> Double -> Int -> TypeSafeError -> NominalDiffTime+retryDelay policy now random n err = case serverDelay of+ Just d | retryRespectRetryAfter policy && d <= retryMaxRetryAfter policy -> d+ _ -> applyJitter policy random (backoffDelay policy n)+ where+ serverDelay = case err of+ ServiceError e -> retryAfter now (apiErrorHeaders e)+ _ -> Nothing++-- | The backoff delay before retry number @n@ (counting from 1), without+-- jitter.+--+-- >>> map (backoffDelay defaultRetryPolicy) [1 .. 6]+-- [0.5s,1s,2s,4s,5s,5s]+backoffDelay :: RetryPolicy -> Int -> NominalDiffTime+backoffDelay policy n =+ min (retryMaxBackoff policy) (retryInitialBackoff policy * 2 ^ max 0 (n - 1))++-- | Take a random part of at most 'retryJitter' off a delay. The 'Double' is+-- a uniformly random number in [0, 1).+--+-- >>> applyJitter defaultRetryPolicy 0.5 4+-- 3.5s+applyJitter :: RetryPolicy -> Double -> NominalDiffTime -> NominalDiffTime+applyJitter policy random delay =+ delay * realToFrac (1 - clamp (retryJitter policy) * clamp random)+ where+ clamp = max 0 . min 1++-- | The delay the server asks for, if any, from the @retry-after-ms@ header+-- (milliseconds) or the standard @Retry-After@ header (seconds, or an HTTP+-- date relative to the given current time).+--+-- >>> retryAfter now [("retry-after-ms", "250")]+-- Just 0.25s+--+-- >>> retryAfter now [("Retry-After", "3")]+-- Just 3s+--+-- >>> retryAfter now [("Retry-After", "Tue, 22 Sep 2026 00:00:10 GMT")]+-- Just 10s+retryAfter :: UTCTime -> ResponseHeaders -> Maybe NominalDiffTime+retryAfter now headers =+ case lookup "retry-after-ms" headers >>= decimal of+ Just ms -> Just (fromRational (ms / 1000))+ Nothing -> lookup "retry-after" headers >>= \v -> (fromRational <$> decimal v) <|> date v+ where+ date v =+ max 0 . (`diffUTCTime` now)+ <$> parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" (BS8.unpack (BS8.strip v))++-- | A non-negative decimal number such as @3@ or @1.25@, parsed exactly.+decimal :: BS8.ByteString -> Maybe Rational+decimal raw = case BS8.split '.' (BS8.strip raw) of+ [whole] | digits whole -> Just (integer whole)+ [whole, fraction]+ | digits whole && digits fraction ->+ Just (integer whole + integer fraction / 10 ^ BS8.length fraction)+ _ -> Nothing+ where+ digits s = not (BS8.null s) && BS8.all isDigit s+ integer = fromInteger . BS8.foldl' (\acc c -> acc * 10 + toInteger (digitToInt c)) 0
+ src/TypeSafe/Wire.hs view
@@ -0,0 +1,773 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- |+-- Module : TypeSafe.Wire+-- Description : The TypeSafe HTTP API, schema for schema+-- Copyright : (c) 2026 byteally+-- License : BSD-3-Clause+--+-- A one-to-one Haskell mirror of the schemas in the TypeSafe OpenAPI+-- specification (<https://api.typesafe.ai/openapi.json>), version+-- 'apiSpecVersion'.+--+-- Most programs never need this module: "TypeSafe.Question" builds these+-- values from typed questions and decodes the answers into your own types.+-- Reach for the wire types when you want to+--+-- * talk to the API through your own HTTP stack, such as servant, and only+-- borrow the JSON codecs,+-- * log, store or replay raw requests and responses, or+-- * use an API feature before this SDK has typed support for it (see+-- 'QuestionOther' and 'AnswerOther').+--+-- = Naming+--+-- Every schema becomes a type of the same name. Every property becomes a+-- field named after the schema, then the property in camel case:+-- @SystemOneRequest.state@ is 'systemOneRequestState' and+-- @Usage.input_tokens@ is 'usageInputTokens'. The fixed rule keeps the+-- field names unique without any language extensions and makes it simple to+-- check the bindings against a new version of the specification.+--+-- Schemas that use @oneOf@ with a @type@ discriminator (@Question@ and+-- @Answer@) become sum types. Their @type@ property is implied by the+-- constructor, so the variant records have no field for it.+--+-- = Forward compatibility+--+-- * Response objects ignore properties this version does not know about.+-- * Questions and answers of an unknown @type@ decode to 'QuestionOther' and+-- 'AnswerOther' instead of failing.+-- * 'ModelName' is open: any model id or alias the API accepts can be used.+--+-- = Example+--+-- The example request from the API reference:+--+-- >>> :{+-- let request =+-- SystemOneRequest+-- { systemOneRequestState = "Help! My payouts have been failing for 3 days."+-- , systemOneRequestModel = jevLatest+-- , systemOneRequestQuestions =+-- Map.fromList+-- [ ( "is_urgent"+-- , QuestionNoul+-- NoulQuestion+-- { noulQuestionInstructions = Just "Does this convey urgency?"+-- , noulQuestionCriteria = Nothing+-- }+-- )+-- ]+-- }+-- :}+--+-- >>> LBS.putStrLn (encode request)+-- {"state":"Help! My payouts have been failing for 3 days.","model":"jev-latest","questions":{"is_urgent":{"type":"noul","instructions":"Does this convey urgency?"}}}+--+-- and its response:+--+-- >>> :{+-- let body = "{\"model\":\"jev-1.13.0\",\"answers\":{\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95}},\"usage\":{\"input_tokens\":296,\"output_tokens\":20}}"+-- :}+--+-- >>> fmap systemOneResponseAnswers (eitherDecode body)+-- Right (fromList [("is_urgent",AnswerNoul (NoulAnswer {noulAnswerNoul = 0.95}))])+module TypeSafe.Wire+ ( -- * Specification version+ apiSpecVersion++ -- * Identifiers+ , ModelName (..)+ , jevLatest+ , jevPreview+ , QuestionId (..)++ -- * Evaluation request (@POST \/v1\/systemone@)+ , SystemOneRequest (..)+ , Question (..)+ , questionType+ , NoulQuestion (..)+ , NoulCriteria (..)+ , ChoiceQuestion (..)+ , ScoreQuestion (..)++ -- * Evaluation response+ , SystemOneResponse (..)+ , Answer (..)+ , answerType+ , NoulAnswer (..)+ , ChoiceAnswer (..)+ , ScoreAnswer (..)+ , Usage (..)++ -- * Models (@GET \/v1\/models@)+ , ModelMetadataList (..)+ , ModelMetadata (..)+ , modelMetadataReleaseDay++ -- * Validation errors (HTTP 422)+ , HTTPValidationError (..)+ , ValidationError (..)+ , LocationSegment (..)+ ) where++import Control.DeepSeq (NFData)+import Data.Aeson+ ( FromJSON (..)+ , FromJSONKey+ , Object+ , ToJSON (..)+ , ToJSONKey+ , Value (..)+ , object+ , pairs+ , withObject+ , withText+ , (.:)+ , (.:?)+ , (.=)+ )+import qualified Data.Aeson.Encoding as Encoding+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Aeson.Types (Parser, Series)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.String (IsString)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Time.Calendar (Day)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import GHC.Generics (Generic)+import TypeSafe.Content (Content)++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> import Data.Aeson (encode, eitherDecode)+-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS+-- >>> import qualified Data.Map.Strict as Map++-- | The @info.version@ of the OpenAPI specification these bindings mirror.+--+-- The test suite checks this against the vendored copy of the specification,+-- so it cannot silently fall out of date.+apiSpecVersion :: Text+apiSpecVersion = "0.2.0"++------------------------------------------------------------------------------+-- Identifiers++-- | The name of a model or model alias, as accepted by the request's @model@+-- field.+--+-- Aliases such as 'jevLatest' move when a new model ships. Pin a versioned id+-- (for example @\"jev-1.13.0\"@) if you have tuned thresholds against a+-- specific version. See <https://docs.typesafe.ai/models>.+newtype ModelName = ModelName {unModelName :: Text}+ deriving newtype (Eq, Ord, Show, IsString, ToJSON, FromJSON, NFData)++-- | The most recent stable, official release of Jev. The default model.+jevLatest :: ModelName+jevLatest = "jev-latest"++-- | The most recent release of Jev, whether or not it is an official one.+jevPreview :: ModelName+jevPreview = "jev-preview"++-- | A key you choose for a question. Its answer comes back under the same key.+--+-- Question ids are not sent to the model and do not influence the answer:+-- put the complete question in the instructions.+newtype QuestionId = QuestionId {unQuestionId :: Text}+ deriving newtype (Eq, Ord, Show, IsString, ToJSON, FromJSON, ToJSONKey, FromJSONKey, NFData)++------------------------------------------------------------------------------+-- Request++-- | Content and named questions to evaluate together (schema+-- @SystemOneRequest@).+data SystemOneRequest = SystemOneRequest+ { systemOneRequestState :: !Content+ -- ^ The content all questions in this request refer to.+ , systemOneRequestModel :: !ModelName+ -- ^ Name or alias of the model to use.+ , systemOneRequestQuestions :: !(Map QuestionId Question)+ -- ^ Questions keyed by a name you choose. The API requires at least one.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON SystemOneRequest where+ toJSON r =+ object+ [ "state" .= systemOneRequestState r+ , "model" .= systemOneRequestModel r+ , "questions" .= systemOneRequestQuestions r+ ]+ toEncoding r =+ pairs+ ( "state" .= systemOneRequestState r+ <> "model" .= systemOneRequestModel r+ <> "questions" .= systemOneRequestQuestions r+ )++instance FromJSON SystemOneRequest where+ parseJSON = withObject "SystemOneRequest" $ \o ->+ SystemOneRequest+ <$> o .: "state"+ <*> o .: "model"+ <*> o .: "questions"++-- | A question about the supplied content (schema @Question@).+data Question+ = -- | A yes\/no question.+ QuestionNoul !NoulQuestion+ | -- | Pick one of several named options.+ QuestionChoice !ChoiceQuestion+ | -- | Rate the content on an ordered rubric.+ QuestionScore !ScoreQuestion+ | -- | A question type this version of the SDK does not know about: the+ -- @type@ tag and the complete JSON object. It is sent exactly as given+ -- (with @type@ set to the tag), so new question types can be used before+ -- the SDK supports them.+ QuestionOther !Text !Object+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | The value of the question's @type@ discriminator.+--+-- >>> questionType (QuestionNoul (NoulQuestion Nothing Nothing))+-- "noul"+questionType :: Question -> Text+questionType = \case+ QuestionNoul _ -> "noul"+ QuestionChoice _ -> "choice"+ QuestionScore _ -> "score"+ QuestionOther t _ -> t++instance ToJSON Question where+ toJSON = \case+ QuestionNoul q -> toJSON q+ QuestionChoice q -> toJSON q+ QuestionScore q -> toJSON q+ QuestionOther t o -> Object (KeyMap.insert "type" (String t) o)+ toEncoding = \case+ QuestionNoul q -> toEncoding q+ QuestionChoice q -> toEncoding q+ QuestionScore q -> toEncoding q+ QuestionOther t o -> toEncoding (KeyMap.insert "type" (String t) o)++instance FromJSON Question where+ parseJSON = withObject "Question" $ \o -> do+ tag <- o .: "type"+ case tag of+ "noul" -> QuestionNoul <$> parseJSON (Object o)+ "choice" -> QuestionChoice <$> parseJSON (Object o)+ "score" -> QuestionScore <$> parseJSON (Object o)+ other -> pure (QuestionOther other o)++-- | A yes\/no question or statement, answered with the probability of yes+-- (schema @NoulQuestion@).+data NoulQuestion = NoulQuestion+ { noulQuestionInstructions :: !(Maybe Content)+ -- ^ The yes\/no question or statement to evaluate.+ , noulQuestionCriteria :: !(Maybe NoulCriteria)+ -- ^ What counts as a yes or a no.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON NoulQuestion where+ toJSON q =+ object $+ ("type" .= ("noul" :: Text))+ : optionalPairs+ [ ("instructions", toJSON <$> noulQuestionInstructions q)+ , ("criteria", toJSON <$> noulQuestionCriteria q)+ ]+ toEncoding q =+ pairs $+ ("type" .= ("noul" :: Text))+ <> optionalSeries "instructions" (noulQuestionInstructions q)+ <> optionalSeries "criteria" (noulQuestionCriteria q)++instance FromJSON NoulQuestion where+ parseJSON = withObject "NoulQuestion" $ \o -> do+ expectType "noul" o+ NoulQuestion+ <$> o .:? "instructions"+ <*> o .:? "criteria"++-- | What counts as a yes or a no (schema @NoulCriteria@).+data NoulCriteria = NoulCriteria+ { noulCriteriaTrue :: !(Maybe Content)+ -- ^ What a yes (a value near 1) means.+ , noulCriteriaFalse :: !(Maybe Content)+ -- ^ What a no (a value near 0) means.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON NoulCriteria where+ toJSON c =+ object $+ optionalPairs+ [ ("true", toJSON <$> noulCriteriaTrue c)+ , ("false", toJSON <$> noulCriteriaFalse c)+ ]+ toEncoding c =+ pairs $+ optionalSeries "true" (noulCriteriaTrue c)+ <> optionalSeries "false" (noulCriteriaFalse c)++instance FromJSON NoulCriteria where+ parseJSON = withObject "NoulCriteria" $ \o ->+ NoulCriteria+ <$> o .:? "true"+ <*> o .:? "false"++-- | A question that selects one option from the choices you define (schema+-- @ChoiceQuestion@).+data ChoiceQuestion = ChoiceQuestion+ { choiceQuestionInstructions :: !(Maybe Content)+ -- ^ What the model should decide.+ , choiceQuestionCriteria :: ![(Text, Maybe Content)]+ -- ^ Option names and, optionally, when each applies. An option without a+ -- description is interpreted by its name alone.+ --+ -- The options are sent in list order. Names must be unique; the API allows+ -- at most 255 options.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ChoiceQuestion where+ toJSON q =+ object $+ ("type" .= ("choice" :: Text))+ : ("criteria" .= object [Key.fromText k .= v | (k, v) <- choiceQuestionCriteria q])+ : optionalPairs [("instructions", toJSON <$> choiceQuestionInstructions q)]+ toEncoding q =+ pairs $+ ("type" .= ("choice" :: Text))+ <> optionalSeries "instructions" (choiceQuestionInstructions q)+ <> Encoding.pair "criteria" (pairs (foldMap (\(k, v) -> Key.fromText k .= v) (choiceQuestionCriteria q)))++instance FromJSON ChoiceQuestion where+ parseJSON = withObject "ChoiceQuestion" $ \o -> do+ expectType "choice" o+ criteria <- o .: "criteria" >>= withObject "criteria" (traverse parseOption . KeyMap.toList)+ ChoiceQuestion+ <$> o .:? "instructions"+ <*> pure criteria+ where+ parseOption (k, v) = (,) (Key.toText k) <$> parseJSON v++-- | A question that assigns a score using an ordered rubric (schema+-- @ScoreQuestion@).+data ScoreQuestion = ScoreQuestion+ { scoreQuestionInstructions :: !(Maybe Content)+ -- ^ What the model should rate.+ , scoreQuestionCriteria :: !(NonEmpty Content)+ -- ^ Ordered level descriptions. Each description's position is its score,+ -- starting at zero. The API accepts up to 10 levels.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ScoreQuestion where+ toJSON q =+ object $+ ("type" .= ("score" :: Text))+ : ("criteria" .= scoreQuestionCriteria q)+ : optionalPairs [("instructions", toJSON <$> scoreQuestionInstructions q)]+ toEncoding q =+ pairs $+ ("type" .= ("score" :: Text))+ <> optionalSeries "instructions" (scoreQuestionInstructions q)+ <> ("criteria" .= scoreQuestionCriteria q)++instance FromJSON ScoreQuestion where+ parseJSON = withObject "ScoreQuestion" $ \o -> do+ expectType "score" o+ ScoreQuestion+ <$> o .:? "instructions"+ <*> o .: "criteria"++------------------------------------------------------------------------------+-- Response++-- | Answers keyed by question name, with the model used and token usage+-- (schema @SystemOneResponse@).+data SystemOneResponse = SystemOneResponse+ { systemOneResponseModel :: !ModelName+ -- ^ The versioned model that answered. May differ from the alias in the+ -- request.+ , systemOneResponseAnswers :: !(Map QuestionId Answer)+ -- ^ One answer per question, under the question's id.+ , systemOneResponseUsage :: !Usage+ -- ^ Token usage for the request.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON SystemOneResponse where+ toJSON r =+ object+ [ "model" .= systemOneResponseModel r+ , "answers" .= systemOneResponseAnswers r+ , "usage" .= systemOneResponseUsage r+ ]+ toEncoding r =+ pairs+ ( "model" .= systemOneResponseModel r+ <> "answers" .= systemOneResponseAnswers r+ <> "usage" .= systemOneResponseUsage r+ )++instance FromJSON SystemOneResponse where+ parseJSON = withObject "SystemOneResponse" $ \o ->+ SystemOneResponse+ <$> o .: "model"+ <*> o .: "answers"+ <*> o .: "usage"++-- | An answer whose type matches its question (schema @Answer@).+data Answer+ = -- | The answer to a 'QuestionNoul'.+ AnswerNoul !NoulAnswer+ | -- | The answer to a 'QuestionChoice'.+ AnswerChoice !ChoiceAnswer+ | -- | The answer to a 'QuestionScore'.+ AnswerScore !ScoreAnswer+ | -- | An answer type this version of the SDK does not know about: the @type@+ -- tag and the complete JSON object.+ AnswerOther !Text !Object+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++-- | The value of the answer's @type@ discriminator.+answerType :: Answer -> Text+answerType = \case+ AnswerNoul _ -> "noul"+ AnswerChoice _ -> "choice"+ AnswerScore _ -> "score"+ AnswerOther t _ -> t++instance ToJSON Answer where+ toJSON = \case+ AnswerNoul a -> toJSON a+ AnswerChoice a -> toJSON a+ AnswerScore a -> toJSON a+ AnswerOther t o -> Object (KeyMap.insert "type" (String t) o)+ toEncoding = \case+ AnswerNoul a -> toEncoding a+ AnswerChoice a -> toEncoding a+ AnswerScore a -> toEncoding a+ AnswerOther t o -> toEncoding (KeyMap.insert "type" (String t) o)++instance FromJSON Answer where+ parseJSON = withObject "Answer" $ \o -> do+ tag <- o .: "type"+ case tag of+ "noul" -> AnswerNoul <$> parseJSON (Object o)+ "choice" -> AnswerChoice <$> parseJSON (Object o)+ "score" -> AnswerScore <$> parseJSON (Object o)+ other -> pure (AnswerOther other o)++-- | The probability of a yes answer (schema @NoulAnswer@).+newtype NoulAnswer = NoulAnswer+ { noulAnswerNoul :: Double+ -- ^ From 0 (no) to 1 (yes). Values near 0.5 indicate uncertainty.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON NoulAnswer where+ toJSON a = object ["type" .= ("noul" :: Text), "noul" .= noulAnswerNoul a]+ toEncoding a = pairs ("type" .= ("noul" :: Text) <> "noul" .= noulAnswerNoul a)++instance FromJSON NoulAnswer where+ parseJSON = withObject "NoulAnswer" $ \o -> do+ expectType "noul" o+ NoulAnswer <$> o .: "noul"++-- | The selected option, confidence and probabilities of a choice question+-- (schema @ChoiceAnswer@).+data ChoiceAnswer = ChoiceAnswer+ { choiceAnswerChoice :: !Text+ -- ^ The option with the highest probability.+ , choiceAnswerConfidence :: !Double+ -- ^ Confidence in the selection, from 0 to 1.+ , choiceAnswerProbabilities :: !(Map Text Double)+ -- ^ The probability of every option, keyed by option name. Sums to+ -- approximately 1.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ChoiceAnswer where+ toJSON a =+ object+ [ "type" .= ("choice" :: Text)+ , "choice" .= choiceAnswerChoice a+ , "confidence" .= choiceAnswerConfidence a+ , "probabilities" .= choiceAnswerProbabilities a+ ]+ toEncoding a =+ pairs+ ( "type" .= ("choice" :: Text)+ <> "choice" .= choiceAnswerChoice a+ <> "confidence" .= choiceAnswerConfidence a+ <> "probabilities" .= choiceAnswerProbabilities a+ )++instance FromJSON ChoiceAnswer where+ parseJSON = withObject "ChoiceAnswer" $ \o -> do+ expectType "choice" o+ ChoiceAnswer+ <$> o .: "choice"+ <*> o .: "confidence"+ <*> o .: "probabilities"++-- | An expected score with its rubric, confidence and level probabilities+-- (schema @ScoreAnswer@).+data ScoreAnswer = ScoreAnswer+ { scoreAnswerScore :: !Double+ -- ^ The probability-weighted average of the level indices. May fall between+ -- levels.+ , scoreAnswerConfidence :: !Double+ -- ^ Confidence in the score, from 0 to 1.+ , scoreAnswerLegend :: !(Map Int Content)+ -- ^ Each level index mapped back to its description.+ , scoreAnswerProbabilities :: !(Map Int Double)+ -- ^ The probability of each level, keyed by level index. Sums to+ -- approximately 1.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ScoreAnswer where+ toJSON a =+ object+ [ "type" .= ("score" :: Text)+ , "score" .= scoreAnswerScore a+ , "confidence" .= scoreAnswerConfidence a+ , "legend" .= scoreAnswerLegend a+ , "probabilities" .= scoreAnswerProbabilities a+ ]+ toEncoding a =+ pairs+ ( "type" .= ("score" :: Text)+ <> "score" .= scoreAnswerScore a+ <> "confidence" .= scoreAnswerConfidence a+ <> "legend" .= scoreAnswerLegend a+ <> "probabilities" .= scoreAnswerProbabilities a+ )++instance FromJSON ScoreAnswer where+ parseJSON = withObject "ScoreAnswer" $ \o -> do+ expectType "score" o+ ScoreAnswer+ <$> o .: "score"+ <*> o .: "confidence"+ <*> o .: "legend"+ <*> o .: "probabilities"++-- | Token usage for a request (schema @Usage@).+data Usage = Usage+ { usageInputTokens :: !Int+ -- ^ Billable input tokens.+ , usageOutputTokens :: !Int+ -- ^ Output tokens. Currently free of charge.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON Usage where+ toJSON u = object ["input_tokens" .= usageInputTokens u, "output_tokens" .= usageOutputTokens u]+ toEncoding u = pairs ("input_tokens" .= usageInputTokens u <> "output_tokens" .= usageOutputTokens u)++instance FromJSON Usage where+ parseJSON = withObject "Usage" $ \o ->+ Usage+ <$> o .: "input_tokens"+ <*> o .: "output_tokens"++------------------------------------------------------------------------------+-- Models++-- | The models and aliases available to the account (schema+-- @ModelMetadataList@).+newtype ModelMetadataList = ModelMetadataList+ { modelMetadataListModels :: [ModelMetadata]+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ModelMetadataList where+ toJSON l = object ["models" .= modelMetadataListModels l]+ toEncoding l = pairs ("models" .= modelMetadataListModels l)++instance FromJSON ModelMetadataList where+ parseJSON = withObject "ModelMetadataList" $ \o ->+ ModelMetadataList <$> o .: "models"++-- | A model or alias available to the account (schema @ModelMetadata@).+data ModelMetadata = ModelMetadata+ { modelMetadataName :: !ModelName+ -- ^ The name to send in the request's @model@ field.+ , modelMetadataDescription :: !Text+ -- ^ What the model is for.+ , modelMetadataReleaseDate :: !Text+ -- ^ The release date, formatted as @YYYY-MM-DD@. See+ -- 'modelMetadataReleaseDay'.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ModelMetadata where+ toJSON m =+ object+ [ "name" .= modelMetadataName m+ , "description" .= modelMetadataDescription m+ , "release_date" .= modelMetadataReleaseDate m+ ]+ toEncoding m =+ pairs+ ( "name" .= modelMetadataName m+ <> "description" .= modelMetadataDescription m+ <> "release_date" .= modelMetadataReleaseDate m+ )++instance FromJSON ModelMetadata where+ parseJSON = withObject "ModelMetadata" $ \o ->+ ModelMetadata+ <$> o .: "name"+ <*> o .: "description"+ <*> o .: "release_date"++-- | The release date as a 'Day', when it is a valid @YYYY-MM-DD@ date.+--+-- The date is kept as text in 'ModelMetadata' so that an unexpected format+-- never makes listing models fail.+--+-- >>> modelMetadataReleaseDay (ModelMetadata "jev-latest" "General-purpose system one model." "2026-09-15")+-- Just 2026-09-15+modelMetadataReleaseDay :: ModelMetadata -> Maybe Day+modelMetadataReleaseDay = iso8601ParseM . Text.unpack . modelMetadataReleaseDate++------------------------------------------------------------------------------+-- Validation errors++-- | The body of an HTTP 422 response (schema @HTTPValidationError@).+newtype HTTPValidationError = HTTPValidationError+ { httpValidationErrorDetail :: Maybe [ValidationError]+ -- ^ Which request values are missing or invalid.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON HTTPValidationError where+ toJSON e = object (optionalPairs [("detail", toJSON <$> httpValidationErrorDetail e)])+ toEncoding e = pairs (optionalSeries "detail" (httpValidationErrorDetail e))++instance FromJSON HTTPValidationError where+ parseJSON = withObject "HTTPValidationError" $ \o ->+ HTTPValidationError <$> o .:? "detail"++-- | One validation failure (schema @ValidationError@).+data ValidationError = ValidationError+ { validationErrorLoc :: ![LocationSegment]+ -- ^ Where the invalid value is: the request part, then field names and+ -- array indices, for example @body → questions → urgency → criteria@.+ , validationErrorMsg :: !Text+ -- ^ A human-readable explanation.+ , validationErrorType :: !Text+ -- ^ A machine-readable error code such as @missing@.+ , validationErrorInput :: !(Maybe Value)+ -- ^ The value that failed validation.+ , validationErrorCtx :: !(Maybe Object)+ -- ^ Extra context, such as the violated limit.+ }+ deriving stock (Eq, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON ValidationError where+ toJSON e =+ object $+ [ "loc" .= validationErrorLoc e+ , "msg" .= validationErrorMsg e+ , "type" .= validationErrorType e+ ]+ <> optionalPairs+ [ ("input", validationErrorInput e)+ , ("ctx", Object <$> validationErrorCtx e)+ ]+ toEncoding e =+ pairs $+ "loc" .= validationErrorLoc e+ <> "msg" .= validationErrorMsg e+ <> "type" .= validationErrorType e+ <> optionalSeries "input" (validationErrorInput e)+ <> optionalSeries "ctx" (validationErrorCtx e)++instance FromJSON ValidationError where+ parseJSON = withObject "ValidationError" $ \o ->+ ValidationError+ <$> o .: "loc"+ <*> o .: "msg"+ <*> o .: "type"+ <*> o .:? "input"+ <*> o .:? "ctx"++-- | One step of a 'validationErrorLoc' path.+data LocationSegment+ = -- | An object key.+ LocationField !Text+ | -- | An array index.+ LocationIndex !Int+ deriving stock (Eq, Ord, Show, Generic)+ deriving anyclass (NFData)++instance ToJSON LocationSegment where+ toJSON = \case+ LocationField t -> String t+ LocationIndex i -> toJSON i+ toEncoding = \case+ LocationField t -> toEncoding t+ LocationIndex i -> toEncoding i++instance FromJSON LocationSegment where+ parseJSON = \case+ String t -> pure (LocationField t)+ v -> LocationIndex <$> parseJSON v++------------------------------------------------------------------------------+-- Helpers++optionalPairs :: [(Text, Maybe Value)] -> [(Key.Key, Value)]+optionalPairs kvs = [(Key.fromText k, v) | (k, Just v) <- kvs]++optionalSeries :: (ToJSON v) => Key.Key -> Maybe v -> Series+optionalSeries k = maybe mempty (k .=)++-- | Require the @type@ discriminator to be the expected tag.+expectType :: Text -> Object -> Parser ()+expectType expected o = case KeyMap.lookup "type" o of+ Nothing -> fail ("missing \"type\": expected " <> show expected)+ Just v ->+ withText+ "type"+ ( \t ->+ if t == expected+ then pure ()+ else fail ("expected \"type\" to be " <> show expected <> ", got " <> show t)+ )+ v
+ test/Main.hs view
@@ -0,0 +1,26 @@+module Main (main) where++import Data.Maybe (fromMaybe)+import System.Environment (lookupEnv)+import Test.Tasty (defaultMain, testGroup)+import qualified TypeSafe.ConformanceSpec as Conformance+import qualified TypeSafe.ErrorSpec as Error+import TypeSafe.JsonSchema (loadSpec)+import qualified TypeSafe.QuestionSpec as Question+import qualified TypeSafe.RetrySpec as Retry++-- | Set @TYPESAFE_OPENAPI_SPEC@ to check the bindings against another copy of+-- the specification, such as a freshly downloaded one, without replacing the+-- vendored file.+main :: IO ()+main = do+ specPath <- fromMaybe "spec/openapi.json" <$> lookupEnv "TYPESAFE_OPENAPI_SPEC"+ spec <- loadSpec specPath+ defaultMain $+ testGroup+ "typesafe-ai-core"+ [ Conformance.tests spec+ , Question.tests+ , Error.tests+ , Retry.tests+ ]
+ test/TypeSafe/ArbitraryInstances.hs view
@@ -0,0 +1,177 @@+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Generators for the wire types. They only produce values the+-- specification allows, so every generated value must validate against it.+module TypeSafe.ArbitraryInstances+ ( genText+ , genContent+ , genJsonValue+ , genProbability+ ) where++import Data.Aeson (Value (..))+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.List (nub, sort)+import qualified Data.List.NonEmpty as NonEmpty+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector+import Test.QuickCheck+import TypeSafe.Content (Content (..))+import TypeSafe.Wire++genText :: Gen Text+genText =+ Text.pack+ <$> frequency+ [ (4, listOf (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> " _-.`?")))+ , (1, getPrintableString <$> arbitrary)+ , (1, listOf (elements "äöü€日本語🙂\"\\\n\t"))+ ]++genKey :: Gen Text+genKey = Text.pack <$> listOf1 (elements (['a' .. 'z'] <> "_"))++-- | Finite probabilities, so that JSON round trips are exact.+genProbability :: Gen Double+genProbability = elements [0, 0.05, 0.1, 0.12, 0.25, 0.5, 0.75, 0.81, 0.88, 0.95, 1]++genJsonValue :: Int -> Gen Value+genJsonValue depth =+ frequency $+ [ (3, String <$> genText)+ , (2, Number . fromIntegral <$> (arbitrary :: Gen Int))+ , (1, Bool <$> arbitrary)+ , (1, pure Null)+ ]+ <> [ (1, Object . KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue (depth - 1)))+ | depth > 0+ ]+ <> [ (1, Array . Vector.fromList <$> smallListOf (genJsonValue (depth - 1)))+ | depth > 0+ ]++smallListOf :: Gen a -> Gen [a]+smallListOf g = choose (0, 3) >>= \n -> vectorOf n g++genContent :: Gen Content+genContent =+ frequency+ [ (4, ContentText <$> genText)+ , (1, ContentObject . KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue 2))+ , (1, ContentArray . Vector.fromList <$> smallListOf (genJsonValue 2))+ ]++-- | Distinct keys in sorted order, so that decoding an object reproduces the+-- same list.+genSortedKeys :: Gen [Text]+genSortedKeys = sort . nub <$> listOf1 genKey++instance Arbitrary Content where+ arbitrary = genContent++instance Arbitrary ModelName where+ arbitrary = ModelName <$> genText++instance Arbitrary QuestionId where+ arbitrary = QuestionId <$> genText++instance Arbitrary SystemOneRequest where+ arbitrary =+ SystemOneRequest+ <$> arbitrary+ <*> arbitrary+ <*> (Map.fromList <$> listOf1 ((,) <$> arbitrary <*> arbitrary))++instance Arbitrary Question where+ arbitrary =+ oneof+ [ QuestionNoul <$> arbitrary+ , QuestionChoice <$> arbitrary+ , QuestionScore <$> arbitrary+ ]++instance Arbitrary NoulQuestion where+ arbitrary = NoulQuestion <$> arbitrary <*> arbitrary++instance Arbitrary NoulCriteria where+ arbitrary = NoulCriteria <$> arbitrary <*> arbitrary++instance Arbitrary ChoiceQuestion where+ arbitrary = do+ keys <- genSortedKeys+ ChoiceQuestion+ <$> arbitrary+ <*> traverse (\k -> (,) k <$> arbitrary) keys++instance Arbitrary ScoreQuestion where+ arbitrary =+ ScoreQuestion+ <$> arbitrary+ <*> (NonEmpty.fromList <$> (choose (1, 10) >>= \n -> vectorOf n arbitrary))++instance Arbitrary SystemOneResponse where+ arbitrary =+ SystemOneResponse+ <$> arbitrary+ <*> (Map.fromList <$> listOf1 ((,) <$> arbitrary <*> arbitrary))+ <*> arbitrary++instance Arbitrary Answer where+ arbitrary =+ oneof+ [ AnswerNoul <$> arbitrary+ , AnswerChoice <$> arbitrary+ , AnswerScore <$> arbitrary+ ]++instance Arbitrary NoulAnswer where+ arbitrary = NoulAnswer <$> genProbability++instance Arbitrary ChoiceAnswer where+ arbitrary = do+ keys <- genSortedKeys+ ChoiceAnswer+ <$> elements keys+ <*> genProbability+ <*> (Map.fromList <$> traverse (\k -> (,) k <$> genProbability) keys)++instance Arbitrary ScoreAnswer where+ arbitrary = do+ levels <- choose (1, 10)+ ScoreAnswer+ <$> (fromIntegral <$> choose (0, levels - 1 :: Int))+ <*> genProbability+ <*> (Map.fromList <$> traverse (\i -> (,) i <$> arbitrary) [0 .. levels - 1])+ <*> (Map.fromList <$> traverse (\i -> (,) i <$> genProbability) [0 .. levels - 1])++instance Arbitrary Usage where+ arbitrary = Usage <$> (getNonNegative <$> arbitrary) <*> (getNonNegative <$> arbitrary)++instance Arbitrary ModelMetadataList where+ arbitrary = ModelMetadataList <$> smallListOf arbitrary++instance Arbitrary ModelMetadata where+ arbitrary =+ ModelMetadata+ <$> arbitrary+ <*> genText+ <*> elements ["2026-09-15", "2026-01-31", "not a date"]++instance Arbitrary HTTPValidationError where+ arbitrary = HTTPValidationError <$> liftArbitrary (smallListOf arbitrary)++instance Arbitrary ValidationError where+ arbitrary =+ ValidationError+ <$> smallListOf arbitrary+ <*> genText+ <*> genText+ <*> liftArbitrary (genJsonValue 2 `suchThat` (/= Null))+ <*> liftArbitrary (KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue 1))++instance Arbitrary LocationSegment where+ arbitrary = oneof [LocationField <$> genText, LocationIndex . getNonNegative <$> arbitrary]
+ test/TypeSafe/ConformanceSpec.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Checks the bindings in "TypeSafe.Wire" and "TypeSafe.Call" against the+-- vendored OpenAPI specification (@spec/openapi.json@).+--+-- When TypeSafe publishes a new version of the specification, replace the+-- vendored file (see @scripts/sync-spec.sh@) and run these tests: each+-- failure names an endpoint, schema, property or keyword that the bindings+-- do not cover yet.+module TypeSafe.ConformanceSpec (tests) where++import Control.Monad (forM_)+import Data.Aeson (FromJSON, ToJSON (..), Value (..))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Either (isLeft)+import Data.List (nub, sort)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Proxy (Proxy (..))+import qualified Data.Set as Set+import Data.Text (Text)+import qualified Data.Text as Text+import Test.QuickCheck (Arbitrary, Gen, arbitrary, generate, vectorOf)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=))+import Test.Tasty.QuickCheck (counterexample, testProperty, (===))+import TypeSafe.ArbitraryInstances ()+import TypeSafe.Call (callEndpoint, listModels, systemOne, systemOneRaw)+import TypeSafe.JsonSchema+import TypeSafe.Question (ask, noul)+import TypeSafe.Wire++-- | A Haskell type bound to a schema of the specification.+data Binding = forall a. (Arbitrary a, ToJSON a, FromJSON a, Eq a, Show a) => Binding Text (Proxy a)++-- | Every schema the SDK binds. A schema added to the specification makes the+-- \"every schema is bound\" test fail until it is listed here.+bindings :: [Binding]+bindings =+ [ Binding "Answer" (Proxy :: Proxy Answer)+ , Binding "ChoiceAnswer" (Proxy :: Proxy ChoiceAnswer)+ , Binding "ChoiceQuestion" (Proxy :: Proxy ChoiceQuestion)+ , Binding "HTTPValidationError" (Proxy :: Proxy HTTPValidationError)+ , Binding "ModelMetadata" (Proxy :: Proxy ModelMetadata)+ , Binding "ModelMetadataList" (Proxy :: Proxy ModelMetadataList)+ , Binding "NoulAnswer" (Proxy :: Proxy NoulAnswer)+ , Binding "NoulCriteria" (Proxy :: Proxy NoulCriteria)+ , Binding "NoulQuestion" (Proxy :: Proxy NoulQuestion)+ , Binding "Question" (Proxy :: Proxy Question)+ , Binding "ScoreAnswer" (Proxy :: Proxy ScoreAnswer)+ , Binding "ScoreQuestion" (Proxy :: Proxy ScoreQuestion)+ , Binding "SystemOneRequest" (Proxy :: Proxy SystemOneRequest)+ , Binding "SystemOneResponse" (Proxy :: Proxy SystemOneResponse)+ , Binding "Usage" (Proxy :: Proxy Usage)+ , Binding "ValidationError" (Proxy :: Proxy ValidationError)+ ]++-- | Every operation the SDK can call, as @(METHOD, path)@.+sdkOperations :: [(Text, Text)]+sdkOperations =+ nub+ [ (method, path)+ | endpoint <-+ [ callEndpoint (systemOne "state" (ask "q" (noul "?")))+ , callEndpoint (systemOneRaw (SystemOneRequest "state" jevLatest mempty))+ , callEndpoint listModels+ ]+ , let (method, path) = fmap Text.strip (Text.breakOn " " endpoint)+ ]++tests :: Spec -> TestTree+tests spec =+ testGroup+ "OpenAPI conformance"+ [ testCase "apiSpecVersion matches the vendored specification" $+ Just apiSpecVersion @?= specVersion spec+ , testCase "every operation is bound" $+ sort sdkOperations @?= sort (specOperations spec)+ , testCase "every schema is bound" $+ sort [name | Binding name _ <- bindings] @?= sort (specSchemaNames spec)+ , testCase "the schema validator understands every keyword in use" $+ nub (filter (`notElem` supportedKeywords) (specKeywords spec)) @?= []+ , testCase "question constructors match the Question discriminator" $+ sort+ [ questionType (QuestionNoul (NoulQuestion Nothing Nothing))+ , questionType (QuestionChoice (ChoiceQuestion Nothing []))+ , questionType (QuestionScore (ScoreQuestion Nothing ("level" :| [])))+ ]+ @?= sort (discriminatorTags spec "Question")+ , testCase "answer constructors match the Answer discriminator" $+ sort+ [ answerType (AnswerNoul (NoulAnswer 0))+ , answerType (AnswerChoice (ChoiceAnswer "a" 0 mempty))+ , answerType (AnswerScore (ScoreAnswer 0 0 mempty mempty))+ ]+ @?= sort (discriminatorTags spec "Answer")+ , testCase "unknown question and answer types pass through unchanged" $ do+ let question = Aeson.object ["type" Aeson..= ("rank" :: Text), "items" Aeson..= [1 :: Int, 2]]+ fmap toJSON (Aeson.eitherDecode (Aeson.encode question) :: Either String Question) @?= Right question+ let answer = Aeson.object ["type" Aeson..= ("rank" :: Text), "order" Aeson..= [2 :: Int, 1]]+ fmap toJSON (Aeson.eitherDecode (Aeson.encode answer) :: Either String Answer) @?= Right answer+ , testGroup "schemas" (map (schemaTests spec) bindings)+ ]++schemaTests :: Spec -> Binding -> TestTree+schemaTests spec (Binding name (_ :: Proxy a)) =+ testGroup (Text.unpack name) $+ [ testProperty "encoded values validate against the schema" $ \(x :: a) ->+ let errors = validate spec (schemaRef name) (toJSON x)+ in counterexample (unlines errors) (null errors)+ , testProperty "toEncoding agrees with toJSON" $ \(x :: a) ->+ Aeson.decode (Aeson.encode x) === Just (toJSON x)+ , testProperty "decoding inverts encoding" $ \(x :: a) ->+ Aeson.eitherDecode (Aeson.encode x) === Right x+ ]+ <> [ testCase "encodes exactly the declared properties" $ do+ samples <- generate (vectorOf 500 (arbitrary :: Gen a))+ let emitted = Set.unions [Set.fromList (objectKeys (toJSON x)) | x <- samples]+ emitted @?= Set.fromList properties+ | not (null properties)+ ]+ <> [ testCase "requires the required properties and only those" $ do+ samples <- generate (vectorOf 50 (arbitrary :: Gen a))+ forM_ samples $ \x -> forM_ (objectKeys (toJSON x)) $ \p -> do+ let decoded = decodeValue (withoutKey p (toJSON x))+ if p `elem` required+ then assertBool ("decoded without required property " <> show p) (isLeft decoded)+ else case decoded of+ Left err -> assertFailure ("optional property " <> show p <> " is required by the decoder: " <> err)+ Right _ -> pure ()+ | not (null properties)+ ]+ <> [ testCase "the specification's examples validate and decode" $ do+ let example = Object (KeyMap.fromList [(Key.fromText p, v) | (p, v) <- examples])+ validate spec (schemaRef name) example @?= []+ case decodeValue example of+ Left err -> assertFailure ("cannot decode " <> show example <> ": " <> err)+ Right _ -> pure ()+ | not (null properties)+ , all (`elem` map fst examples) required+ ]+ where+ properties = objectProperties spec name+ required = requiredProperties spec name+ examples = propertyExamples spec name+ decodeValue :: Value -> Either String a+ decodeValue v = Aeson.eitherDecode (Aeson.encode v)++objectKeys :: Value -> [Text]+objectKeys (Object o) = map Key.toText (KeyMap.keys o)+objectKeys _ = []++withoutKey :: Text -> Value -> Value+withoutKey k (Object o) = Object (KeyMap.delete (Key.fromText k) o)+withoutKey _ v = v
+ test/TypeSafe/ErrorSpec.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE OverloadedStrings #-}++-- | Error bodies and their classification, using bodies recorded from the+-- live API where possible.+module TypeSafe.ErrorSpec (tests) where++import Data.Aeson (toJSON)+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as Text+import Network.HTTP.Types (Status, mkStatus, status401, status403, status422)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (assertBool, testCase, (@?=))+import TypeSafe.Error+import TypeSafe.Wire (HTTPValidationError (..), LocationSegment (..), ValidationError (..))++tests :: TestTree+tests =+ testGroup+ "Errors"+ [ testCase "status codes map to kinds" $+ map (apiErrorKindFor . code) [400, 401, 403, 404, 408, 422, 429, 500, 502, 529, 302]+ @?= [ BadRequest+ , Unauthorized+ , PermissionDenied+ , NotFound+ , UnexpectedStatus+ , UnprocessableEntity+ , RateLimited+ , InternalServerError+ , InternalServerError+ , Overloaded+ , UnexpectedStatus+ ]+ , testCase "a missing API key (recorded: HTTP 403)" $ do+ let e = apiErrorFromResponse "GET /v1/models" status403 [("x-typesafe-request-id", "req_01a0")] missingKeyBody+ apiErrorKind e @?= PermissionDenied+ apiErrorMessage e @?= Just "Must supply an API key! Check your request and try again."+ apiErrorRequestId e @?= Just "req_01a0"+ apiErrorBody e+ @?= BodyDetail (ErrorDetail (Just "authentication_error") (Just "Must supply an API key! Check your request and try again."))+ , testCase "an invalid API key (recorded: HTTP 401)" $+ apiErrorKind (apiErrorFromResponse "GET /v1/models" status401 [] invalidKeyBody) @?= Unauthorized+ , testCase "validation errors keep every field" $ do+ let e = apiErrorFromResponse "POST /v1/systemone" status422 [] validationBody+ apiErrorBody e+ @?= BodyValidation+ ( HTTPValidationError+ ( Just+ [ ValidationError+ [LocationField "body", LocationField "questions", LocationField "urgency", LocationField "criteria", LocationIndex 0]+ "Input should be a valid string"+ "string_type"+ (Just "3")+ Nothing+ ]+ )+ )+ apiErrorMessage e @?= Just "body.questions.urgency.criteria.0: Input should be a valid string"+ , testCase "bodies that are not structured errors" $ do+ parseErrorBody "" @?= BodyEmpty+ parseErrorBody " \n" @?= BodyEmpty+ parseErrorBody "<html>Bad gateway</html>" @?= BodyText "<html>Bad gateway</html>"+ parseErrorBody "[1,2]" @?= BodyJson (toJSON [1, 2 :: Int])+ , testCase "rendered errors are one line and name the request" $ do+ let rendered =+ renderTypeSafeError+ (ServiceError (apiErrorFromResponse "GET /v1/models" status401 [("x-typesafe-request-id", "req_9")] invalidKeyBody))+ rendered+ @?= "GET /v1/models failed with HTTP 401 (Unauthorized): Cannot authenticate with the server. \+ \Please check your API key and try again. [request id req_9]"+ assertBool "single line" (not (Text.any (== '\n') rendered))+ ]+ where+ code :: Int -> Status+ code c = mkStatus c ""++missingKeyBody, invalidKeyBody, validationBody :: LBS.ByteString+missingKeyBody = "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Must supply an API key! Check your request and try again.\"}}"+invalidKeyBody = "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Cannot authenticate with the server. Please check your API key and try again.\"}}"+validationBody =+ "{\"detail\":[{\"type\":\"string_type\",\"loc\":[\"body\",\"questions\",\"urgency\",\"criteria\",0],\+ \\"msg\":\"Input should be a valid string\",\"input\":\"3\"}]}"
+ test/TypeSafe/JsonSchema.hs view
@@ -0,0 +1,230 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++-- | A small validator for the subset of JSON Schema that FastAPI emits in+-- OpenAPI 3.1 documents.+--+-- Unknown keywords are reported as errors rather than ignored. When a new+-- version of the TypeSafe specification starts using a keyword this+-- validator does not understand, the conformance tests fail and point at it,+-- instead of silently passing.+module TypeSafe.JsonSchema+ ( Spec+ , loadSpec+ , specVersion+ , specOperations+ , specSchemaNames+ , schemaRef+ , lookupSchema+ , objectProperties+ , requiredProperties+ , discriminatorTags+ , propertyExamples+ , specKeywords+ , supportedKeywords+ , validate+ ) where++import Data.Aeson (Value (..))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Key as Key+import qualified Data.Aeson.KeyMap as KeyMap+import Data.Foldable (toList)+import Data.Maybe (fromMaybe, mapMaybe)+import qualified Data.Scientific as Scientific+import Data.Text (Text)+import qualified Data.Text as Text+import qualified Data.Vector as Vector++-- | A parsed OpenAPI document.+newtype Spec = Spec Value++loadSpec :: FilePath -> IO Spec+loadSpec path =+ Aeson.eitherDecodeFileStrict path >>= \case+ Left err -> fail ("cannot parse " <> path <> ": " <> err)+ Right v -> pure (Spec v)++at :: [Text] -> Value -> Maybe Value+at [] v = Just v+at (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= at ks+at _ _ = Nothing++keysOf :: Value -> [Text]+keysOf (Object o) = map Key.toText (KeyMap.keys o)+keysOf _ = []++-- | @info.version@.+specVersion :: Spec -> Maybe Text+specVersion (Spec v) = case at ["info", "version"] v of+ Just (String t) -> Just t+ _ -> Nothing++-- | Every operation, as @(METHOD, path)@.+specOperations :: Spec -> [(Text, Text)]+specOperations (Spec v) =+ [ (Text.toUpper method, path)+ | path <- keysOf (fromMaybe Null (at ["paths"] v))+ , method <- keysOf (fromMaybe Null (at ["paths", path] v))+ ]++-- | The names under @components.schemas@.+specSchemaNames :: Spec -> [Text]+specSchemaNames (Spec v) = keysOf (fromMaybe Null (at ["components", "schemas"] v))++-- | A schema that refers to a named component.+schemaRef :: Text -> Value+schemaRef name = Aeson.object ["$ref" Aeson..= ("#/components/schemas/" <> name)]++lookupSchema :: Spec -> Text -> Maybe Value+lookupSchema (Spec v) name = at ["components", "schemas", name] v++-- | The declared properties of an object schema.+objectProperties :: Spec -> Text -> [Text]+objectProperties spec name = keysOf (fromMaybe Null (lookupSchema spec name >>= at ["properties"]))++-- | The required properties of an object schema.+requiredProperties :: Spec -> Text -> [Text]+requiredProperties spec name = case lookupSchema spec name >>= at ["required"] of+ Just (Array xs) -> [t | String t <- toList xs]+ _ -> []++-- | The tags of a discriminated union, from its @discriminator.mapping@.+discriminatorTags :: Spec -> Text -> [Text]+discriminatorTags spec name = keysOf (fromMaybe Null (lookupSchema spec name >>= at ["discriminator", "mapping"]))++-- | The first example of every property of an object schema that has one.+propertyExamples :: Spec -> Text -> [(Text, Value)]+propertyExamples spec name =+ mapMaybe+ ( \p -> case lookupSchema spec name >>= at ["properties", p, "examples"] of+ Just (Array xs) | not (Vector.null xs) -> Just (p, Vector.head xs)+ _ -> Nothing+ )+ (objectProperties spec name)++-- | Every JSON Schema keyword used anywhere under @components.schemas@.+specKeywords :: Spec -> [Text]+specKeywords (Spec v) = case at ["components", "schemas"] v of+ Just (Object schemas) -> concatMap schemaKeys (KeyMap.elems schemas)+ _ -> []+ where+ schemaKeys = \case+ Object s -> map Key.toText (KeyMap.keys s) <> concatMap (uncurry nested) (KeyMap.toList s)+ _ -> []+ nested k sub = case (Key.toText k, sub) of+ ("properties", Object props) -> concatMap schemaKeys (KeyMap.elems props)+ ("additionalProperties", Object _) -> schemaKeys sub+ ("items", Object _) -> schemaKeys sub+ ("anyOf", Array alts) -> concatMap schemaKeys (toList alts)+ ("oneOf", Array alts) -> concatMap schemaKeys (toList alts)+ _ -> []++-- | The keywords 'validate' understands.+supportedKeywords :: [Text]+supportedKeywords =+ [ "$ref", "type", "const", "properties", "required", "additionalProperties", "items"+ , "minItems", "minProperties", "anyOf", "oneOf"+ , "discriminator", "title", "description", "examples", "default"+ ]++-- | Validate a JSON value against a schema. Returns one message per problem,+-- each prefixed with a JSON path; an empty list means the value is valid.+validate :: Spec -> Value -> Value -> [String]+validate spec = go "$"+ where+ go :: String -> Value -> Value -> [String]+ go path schema value = case schema of+ Bool True -> []+ Bool False -> [path <> ": no value is allowed here"]+ Object s -> concatMap (keyword path s value) (KeyMap.toList s)+ _ -> [path <> ": malformed schema " <> show schema]++ keyword :: String -> Aeson.Object -> Value -> (Key.Key, Value) -> [String]+ keyword path s value (k, arg) = case Key.toText k of+ "$ref" -> case arg of+ String ref+ | Just name <- Text.stripPrefix "#/components/schemas/" ref+ , Just target <- lookupSchema spec name ->+ go path target value+ _ -> [path <> ": cannot resolve $ref " <> show arg]+ "type" -> case arg of+ String t -> [path <> ": expected " <> Text.unpack t <> ", got " <> kind value | not (hasType t value)]+ Array ts ->+ [ path <> ": expected one of " <> show (toList ts) <> ", got " <> kind value+ | not (or [hasType t value | String t <- toList ts])+ ]+ _ -> [path <> ": malformed type"]+ "const" -> [path <> ": expected " <> show arg <> ", got " <> show value | arg /= value]+ "properties" -> case (arg, value) of+ (Object props, Object o) ->+ concat+ [ go (path <> "." <> Key.toString p) propSchema v+ | (p, propSchema) <- KeyMap.toList props+ , Just v <- [KeyMap.lookup p o]+ ]+ _ -> []+ "required" -> case (arg, value) of+ (Array names, Object o) ->+ [ path <> ": missing required property " <> Text.unpack n+ | String n <- toList names+ , not (KeyMap.member (Key.fromText n) o)+ ]+ _ -> []+ "additionalProperties" -> case value of+ Object o ->+ let declared = case KeyMap.lookup "properties" s of+ Just (Object props) -> props+ _ -> KeyMap.empty+ in concat+ [ go (path <> "." <> Key.toString p) arg v+ | (p, v) <- KeyMap.toList o+ , not (KeyMap.member p declared)+ ]+ _ -> []+ "items" -> case value of+ Array xs -> concat [go (path <> "[" <> show i <> "]") arg x | (i, x) <- zip [0 :: Int ..] (toList xs)]+ _ -> []+ "minItems" -> case (arg, value) of+ (Number n, Array xs) -> [path <> ": fewer than " <> show n <> " items" | fromIntegral (length xs) < n]+ _ -> []+ "minProperties" -> case (arg, value) of+ (Number n, Object o) -> [path <> ": fewer than " <> show n <> " properties" | fromIntegral (KeyMap.size o) < n]+ _ -> []+ "anyOf" -> case arg of+ Array alternatives+ | any null [go path alt value | alt <- toList alternatives] -> []+ | otherwise -> [path <> ": matches none of the anyOf alternatives"]+ _ -> [path <> ": malformed anyOf"]+ "oneOf" -> case arg of+ Array alternatives ->+ let matching = length (filter null [go path alt value | alt <- toList alternatives])+ in [path <> ": matches " <> show matching <> " oneOf alternatives, expected exactly 1" | matching /= 1]+ _ -> [path <> ": malformed oneOf"]+ -- Annotations that do not constrain values.+ "discriminator" -> []+ "title" -> []+ "description" -> []+ "examples" -> []+ "default" -> []+ other -> [path <> ": unsupported JSON Schema keyword " <> show other <> "; teach TypeSafe.JsonSchema about it"]++ hasType :: Text -> Value -> Bool+ hasType t v = case (t, v) of+ ("string", String _) -> True+ ("number", Number _) -> True+ ("integer", Number n) -> Scientific.isInteger n+ ("boolean", Bool _) -> True+ ("object", Object _) -> True+ ("array", Array _) -> True+ ("null", Null) -> True+ _ -> False++ kind :: Value -> String+ kind = \case+ String _ -> "a string"+ Number _ -> "a number"+ Bool _ -> "a boolean"+ Object _ -> "an object"+ Array _ -> "an array"+ Null -> "null"
+ test/TypeSafe/QuestionSpec.hs view
@@ -0,0 +1,280 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++-- | The typed question layer and calls built from it.+module TypeSafe.QuestionSpec (tests) where++import Data.Aeson (FromJSON (..), Value (..), eitherDecode, encode, object, withObject, (.:), (.=))+import qualified Data.Aeson.KeyMap as KeyMap+import qualified Data.ByteString.Lazy.Char8 as LBS+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NonEmpty+import Data.Map.Strict (Map)+import qualified Data.Map.Strict as Map+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.HTTP.Types (status200, status422)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=))+import TypeSafe.Core+import qualified TypeSafe.Wire as Wire++data Department = Billing | Technical | Sales+ deriving stock (Show, Eq, Ord, Generic)+ deriving anyclass (ChoiceOption)++data Tone = Zealous | Angry | NeedsReview+ deriving stock (Show, Eq, Generic)++instance ChoiceOption Tone where+ optionDescription = \case+ Zealous -> Just "Enthusiastic"+ _ -> Nothing++data Frustration = Calm | Frustrated | VeryAngry+ deriving stock (Show, Eq, Generic)+ deriving anyclass (ScoreLevel)++data Triage = Triage+ { triageDepartment :: Choice Department+ , triageUrgent :: Noul+ , triageFrustration :: Score Frustration+ }+ deriving stock (Show, Eq)++triage :: Questions Triage+triage =+ Triage+ <$> ask "department" (choice "Which team should handle this?")+ <*> ask "is_urgent" (noul "Does this convey urgency?")+ <*> ask "frustration" (score "How frustrated is the customer?")++answersOf :: LBS.ByteString -> Map QuestionId Wire.Answer+answersOf body = either error id (eitherDecode body)++sampleAnswers :: Map QuestionId Wire.Answer+sampleAnswers =+ answersOf+ "{\"department\":{\"type\":\"choice\",\"choice\":\"billing\",\"confidence\":0.81,\+ \\"probabilities\":{\"billing\":0.88,\"technical\":0.12,\"sales\":0.0}},\+ \\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95},\+ \\"frustration\":{\"type\":\"score\",\"score\":1.05,\"confidence\":0.92,\+ \\"legend\":{\"0\":\"calm\",\"1\":\"frustrated\",\"2\":\"very angry\"},\+ \\"probabilities\":{\"0\":0.0,\"1\":0.95,\"2\":0.05}}}"++specOf :: Question a -> Value+specOf q = either (error . show) (either error id . eitherDecode . encode) (questionSpec q)++-- | The answers must fail to decode with exactly these problems.+decodesTo :: (Show a) => Either (NonEmpty AnswerError) a -> [AnswerError] -> Assertion+decodesTo result expected = case result of+ Left errs -> NonEmpty.toList errs @?= expected+ Right a -> assertFailure ("decoded unexpectedly: " <> show a)++tests :: TestTree+tests =+ testGroup+ "Questions"+ [ testGroup+ "rendering"+ [ testCase "derived options are snake case, in declaration order, with descriptions" $+ specOf (choice @Tone "What is the tone?")+ @?= object+ [ "type" .= ("choice" :: Text)+ , "instructions" .= ("What is the tone?" :: Text)+ , "criteria" .= object ["zealous" .= ("Enthusiastic" :: Text), "angry" .= Null, "needs_review" .= Null]+ ]+ , testCase "options are sent in declaration order, not sorted" $+ either show (LBS.unpack . encode) (questionSpec (choice @Tone "?"))+ @?= "{\"type\":\"choice\",\"instructions\":\"?\",\"criteria\":{\"zealous\":\"Enthusiastic\",\"angry\":null,\"needs_review\":null}}"+ , testCase "derived levels are lower-case words, lowest first" $+ specOf (score @Frustration "How frustrated?")+ @?= object+ [ "type" .= ("score" :: Text)+ , "instructions" .= ("How frustrated?" :: Text)+ , "criteria" .= ["calm" :: Text, "frustrated", "very angry"]+ ]+ , testCase "noulWith sends both criteria" $+ specOf (noulWith "Spam?" "Unsolicited advertising" "A legitimate message")+ @?= object+ [ "type" .= ("noul" :: Text)+ , "instructions" .= ("Spam?" :: Text)+ , "criteria" .= object ["true" .= ("Unsolicited advertising" :: Text), "false" .= ("A legitimate message" :: Text)]+ ]+ , testCase "a request needs a question" $+ renderQuestions (pure ()) @?= Left NoQuestions+ , testCase "question ids must be distinct" $+ renderQuestions (ask "a" (noul "1") *> ask "b" (noul "2") *> ask "a" (noul "3"))+ @?= Left (DuplicateQuestionId "a")+ , testCase "option names must be distinct" $+ renderQuestions (ask "tone" (choiceBy (const "same") (const Nothing) "?" (1 :| [2 :: Int])))+ @?= Left (InvalidQuestion "tone" (DuplicateOption "same"))+ , testCase "questionIds keeps the order of asking" $+ questionIds triage @?= ["department", "is_urgent", "frustration"]+ , testCase "askMap asks every question" $+ fmap Map.keys (renderQuestions (askMap (Map.fromList [("x", noul "?"), ("y", noul "!")])))+ @?= Right ["x", "y"]+ ]+ , testGroup+ "decoding"+ [ testCase "a complete response decodes to the typed result" $+ decodeAnswers triage sampleAnswers+ @?= Right+ Triage+ { triageDepartment =+ Choice Billing ((Billing, 0.88) :| [(Technical, 0.12), (Sales, 0)]) 0.81+ , triageUrgent = Noul 0.95+ , triageFrustration =+ Score 1.05 ((Calm, 0) :| [(Frustrated, 0.95), (VeryAngry, 0.05)]) 0.92+ }+ , testCase "every unusable answer is reported" $+ decodeAnswers triage (Map.delete "is_urgent" (Map.insert "frustration" (Wire.AnswerNoul (Wire.NoulAnswer 1)) sampleAnswers))+ `decodesTo` [ AnswerError "is_urgent" MissingAnswer+ , AnswerError "frustration" (UnexpectedAnswerType "score" "noul")+ ]+ , testCase "a choice outside the offered options is rejected" $+ decodeAnswers+ (ask "d" (choice @Department "?"))+ (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"legal\",\"confidence\":1,\"probabilities\":{\"legal\":1}}}")+ `decodesTo` [AnswerError "d" (UnknownOption "legal")]+ , testCase "a probability for an option that was not offered is rejected" $+ decodeAnswers+ (ask "d" (choice @Department "?"))+ (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"sales\",\"confidence\":1,\"probabilities\":{\"sales\":0.5,\"legal\":0.5}}}")+ `decodesTo` [AnswerError "d" (UnknownOption "legal")]+ , testCase "options missing from the probabilities count as 0" $+ fmap choiceProbabilities+ ( decodeAnswers+ (ask "d" (choice @Department "?"))+ (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"sales\",\"confidence\":1,\"probabilities\":{\"sales\":1}}}")+ )+ @?= Right ((Billing, 0) :| [(Technical, 0), (Sales, 1)])+ , testCase "a score level outside the rubric is rejected" $+ decodeAnswers+ (ask "f" (score @Frustration "?"))+ (answersOf "{\"f\":{\"type\":\"score\",\"score\":3,\"confidence\":1,\"legend\":{},\"probabilities\":{\"3\":1}}}")+ `decodesTo` [AnswerError "f" (UnknownLevel 3)]+ , testCase "scoreRubric levels are indices" $+ fmap (fmap fst . scoreProbabilities)+ ( decodeAnswers+ (ask "f" (scoreRubric "?" ("low" :| ["high"])))+ (answersOf "{\"f\":{\"type\":\"score\",\"score\":0.2,\"confidence\":0.6,\"legend\":{},\"probabilities\":{\"0\":0.8,\"1\":0.2}}}")+ )+ @?= Right (0 :| [1])+ , testCase "otherQuestion decodes new answer types with FromJSON" $+ decodeAnswers+ (ask "r" (otherQuestion "rank" (KeyMap.fromList [("items", toJSONList' ["a", "b"])])))+ (answersOf "{\"r\":{\"type\":\"rank\",\"order\":[\"b\",\"a\"]}}")+ @?= Right (Ranking ["b", "a"])+ , testCase "rawQuestion passes the answer through" $+ decodeAnswers (ask "q" (rawQuestion (Wire.QuestionNoul (Wire.NoulQuestion (Just "?") Nothing)))) sampleAnswers+ `decodesTo` [AnswerError "q" MissingAnswer]+ ]+ , testGroup+ "answer helpers"+ [ testCase "rankedChoices sorts by probability, keeping offer order on ties" $+ rankedChoices (Choice 'b' (('a', 0.25) :| [('b', 0.5), ('c', 0.25)]) 0.5)+ @?= (('b', 0.5) :| [('a', 0.25), ('c', 0.25)])+ , testCase "choiceProbability of an unknown option is 0" $+ choiceProbability 'z' (Choice 'a' (('a', 1) :| []) 1) @?= 0+ , testCase "mostLikelyLevel prefers the lower level on a tie" $+ mostLikelyLevel (Score 0.5 ((0 :: Int, 0.5) :| [(1, 0.5)]) 0) @?= 0+ , testCase "nearestLevel clamps to the rubric" $+ map (\v -> nearestLevel (Score v ((0 :: Int, 1) :| [(1, 0), (2, 0)]) 1)) [-1, 0.4, 0.6, 1.5, 7]+ @?= [0, 0, 1, 2, 2]+ , testCase "normalizedScore scales to 0-1" $+ map (\v -> normalizedScore (Score v (('a', 1) :| [('b', 0), ('c', 0)]) 1)) [0, 1, 2] @?= [0, 0.5, 1]+ , testCase "normalizedScore of a one-level rubric is 0" $+ normalizedScore (Score 0 (('a', 1) :| []) 1) @?= 0+ , testCase "confidence is shared by Choice and Score" $+ (confidence (Choice 'a' (('a', 1) :| []) 0.7), confidence (Score 0 (('a', 1) :| []) 0.3))+ @?= (0.7, 0.3)+ ]+ , testGroup+ "calls"+ [ testCase "systemOne uses the default model" $+ bodyOf (renderCall defaults (systemOne "hi" (ask "q" (noul "?"))))+ `rightIs` Just "{\"state\":\"hi\",\"model\":\"jev-latest\",\"questions\":{\"q\":{\"type\":\"noul\",\"instructions\":\"?\"}}}"+ , testCase "withModel overrides the default model" $+ fmap (lookupKey "model") (bodyJson (renderCall defaults (withModel "jev-1.13.0" (systemOne "hi" (ask "q" (noul "?"))))))+ @?= Right (Just (String "jev-1.13.0"))+ , testCase "withExtraBody adds fields but cannot replace the SDK's" $+ fmap (\o -> (lookupKey "beam_width" o, lookupKey "model" o))+ ( bodyJson+ ( renderCall defaults . withExtraBody (KeyMap.fromList [("beam_width", Number 4), ("model", "evil")]) $+ systemOne "hi" (ask "q" (noul "?"))+ )+ )+ @?= Right (Just (Number 4), Just (String "jev-latest"))+ , testCase "systemOneRaw keeps the request's model unless overridden" $ do+ let raw = Wire.SystemOneRequest "hi" "jev-1.13.0" (Map.fromList [("q", Wire.QuestionNoul (Wire.NoulQuestion (Just "?") Nothing))])+ fmap (lookupKey "model") (bodyJson (renderCall defaults (systemOneRaw raw))) @?= Right (Just (String "jev-1.13.0"))+ fmap (lookupKey "model") (bodyJson (renderCall defaults (withModel "jev-preview" (systemOneRaw raw)))) @?= Right (Just (String "jev-preview"))+ , testCase "invalid questions are rejected before sending" $+ case renderCall defaults (systemOne "hi" (pure ())) of+ Left (InvalidRequest NoQuestions) -> pure ()+ other -> assertFailure (show other)+ , testCase "listModels is a GET without a body" $+ fmap (\r -> (httpRequestMethod r, httpRequestPath r, httpRequestBody r, lookup "Content-Type" (httpRequestHeaders r))) (renderCall defaults listModels)+ `rightIs` ("GET", ["v1", "models"], Nothing, Nothing)+ , testCase "per-call headers win over client headers; protected headers are dropped" $+ fmap httpRequestHeaders+ ( renderCall+ defaults {callDefaultHeaders = [("X-Team", "search"), ("X-Trace", "client"), ("Authorization", "Bearer stolen")]}+ (withHeaders [("X-Trace", "call"), ("Accept", "text/html")] listModels)+ )+ `rightIs` [("Accept", "application/json"), ("X-Trace", "call"), ("X-Team", "search")]+ , testCase "a 2xx body that does not match the schema is a ResponseError" $+ case parseResponse listModels (HttpResponse status200 [("x-typesafe-request-id", "req_1")] "{\"models\": 3}") of+ Left (ResponseError e) -> do+ responseErrorRequestId e @?= Just "req_1"+ responseErrorEndpoint e @?= "GET /v1/models"+ other -> assertFailure (show other)+ , testCase "an error status is a ServiceError" $+ case parseResponse listModels (HttpResponse status422 [] "{\"detail\":[{\"loc\":[\"body\",\"state\"],\"msg\":\"Field required\",\"type\":\"missing\"}]}") of+ Left (ServiceError e) -> do+ apiErrorKind e @?= UnprocessableEntity+ apiErrorMessage e @?= Just "body.state: Field required"+ other -> assertFailure (show other)+ , testCase "a typed evaluation keeps the raw response" $ do+ let body =+ "{\"model\":\"jev-1.13.0\",\"answers\":{\"q\":{\"type\":\"noul\",\"noul\":0.5},\"extra\":{\"type\":\"noul\",\"noul\":0.1}},\+ \\"usage\":{\"input_tokens\":7,\"output_tokens\":2}}"+ case parseResponse (systemOne "hi" (ask "q" (noul "?"))) (HttpResponse status200 [] body) of+ Right e -> do+ evaluationAnswers e @?= Noul 0.5+ evaluationUsage e @?= Usage 7 2+ Map.keys (Wire.systemOneResponseAnswers (evaluationResponse e)) @?= ["extra", "q"]+ Left err -> assertFailure (show err)+ , testCase "systemOneRequest and decodeEvaluation work without a Call" $ do+ request <- either (assertFailure . show) pure (systemOneRequest jevLatest "hi" triage)+ Map.keys (Wire.systemOneRequestQuestions request) @?= ["department", "frustration", "is_urgent"]+ let response = Wire.SystemOneResponse "jev-1.13.0" sampleAnswers (Usage 1 1)+ fmap (choiceSelected . triageDepartment . evaluationAnswers) (decodeEvaluation triage Nothing response)+ @?= Right Billing+ ]+ ]+ where+ defaults = CallDefaults jevLatest []+ bodyOf = fmap (fmap LBS.unpack . httpRequestBody)+ bodyJson r = case r of+ Left e -> Left (show e)+ Right req -> maybe (Left "no body") eitherDecode (httpRequestBody req)+ lookupKey k o = KeyMap.lookup k (o :: KeyMap.KeyMap Value)+ rightIs :: (Eq a, Show a) => Either TypeSafeError a -> a -> Assertion+ rightIs r expected = case r of+ Right a -> a @?= expected+ Left e -> assertFailure (show e)+ toJSONList' :: [Text] -> Value+ toJSONList' = Array . foldMap pure . map String++-- | An answer type the SDK does not know about.+newtype Ranking = Ranking [Text]+ deriving stock (Show, Eq)++instance FromJSON Ranking where+ parseJSON = withObject "Ranking" $ \o -> Ranking <$> o .: "order"
+ test/TypeSafe/RetrySpec.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE OverloadedStrings #-}++module TypeSafe.RetrySpec (tests) where++import Control.Exception (toException)+import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, fromGregorian)+import Data.Time.Format (defaultTimeLocale, formatTime)+import qualified Data.ByteString.Char8 as BS8+import Network.HTTP.Types (ResponseHeaders, mkStatus)+import Test.Tasty (TestTree, testGroup)+import Test.Tasty.HUnit (testCase, (@?=))+import Test.Tasty.QuickCheck (choose, forAll, testProperty, (.&&.))+import TypeSafe.Error+import TypeSafe.Retry++now :: UTCTime+now = UTCTime (fromGregorian 2026 9 22) 43200++serviceError :: Int -> ResponseHeaders -> TypeSafeError+serviceError c headers = ServiceError (apiErrorFromResponse "POST /v1/systemone" (mkStatus c "") headers "")++tests :: TestTree+tests =+ testGroup+ "Retries"+ [ testCase "transient statuses are retried, client errors are not" $+ map (\c -> isRetryable defaultRetryPolicy (serviceError c [])) [408, 429, 500, 503, 529, 400, 401, 403, 404, 422]+ @?= [True, True, True, True, True, False, False, False, False, False]+ , testCase "connection failures and timeouts follow their switches" $ do+ let failed = ConnectionError (ConnectionFailed "GET /v1/models" (toException (userError "reset")))+ timedOut = ConnectionError (ConnectionTimedOut "GET /v1/models")+ map (isRetryable defaultRetryPolicy) [failed, timedOut] @?= [True, True]+ isRetryable defaultRetryPolicy {retryConnectionErrors = False} failed @?= False+ isRetryable defaultRetryPolicy {retryTimeouts = False} timedOut @?= False+ , testCase "invalid requests are never retried" $+ isRetryable defaultRetryPolicy (InvalidRequest NoQuestions) @?= False+ , testCase "backoff doubles up to the maximum" $+ map (backoffDelay defaultRetryPolicy) [1 .. 6] @?= [0.5, 1, 2, 4, 5, 5]+ , testCase "zero initial backoff disables waiting" $+ backoffDelay defaultRetryPolicy {retryInitialBackoff = 0} 3 @?= 0+ , testProperty "jitter only shortens the delay, by at most the jitter fraction" $+ forAll (choose (0, 0.999999)) $ \u ->+ let d = applyJitter defaultRetryPolicy u 4+ in (d <= 4) .&&. (d >= 3)+ , testCase "retry-after-ms wins over Retry-After" $+ retryAfter now [("Retry-After", "10"), ("retry-after-ms", "1500")] @?= Just 1.5+ , testCase "Retry-After as seconds and as a date" $ do+ retryAfter now [("retry-after", "7")] @?= Just 7+ retryAfter now [("Retry-After", httpDate (addUTCTime 42 now))] @?= Just 42+ retryAfter now [("Retry-After", httpDate (addUTCTime (-5) now))] @?= Just 0+ , testCase "malformed Retry-After headers are ignored" $ do+ retryAfter now [("Retry-After", "soon")] @?= Nothing+ retryAfter now [("Retry-After", "-3")] @?= Nothing+ retryAfter now [] @?= Nothing+ , testCase "a short server delay replaces the backoff" $+ retryDelay defaultRetryPolicy now 0.5 1 (serviceError 429 [("retry-after-ms", "200")]) @?= 0.2+ , testCase "a server delay above the maximum falls back to backoff" $+ retryDelay defaultRetryPolicy now 0 2 (serviceError 429 [("Retry-After", "3600")]) @?= 1+ , testCase "server delays can be ignored" $+ retryDelay defaultRetryPolicy {retryRespectRetryAfter = False} now 0 1 (serviceError 429 [("Retry-After", "3")])+ @?= (0.5 :: NominalDiffTime)+ ]+ where+ httpDate = BS8.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT"
+ typesafe-ai-core.cabal view
@@ -0,0 +1,101 @@+cabal-version: 3.0+name: typesafe-ai-core+version: 0.1.0.0+synopsis: Types, JSON codecs and typed questions for the TypeSafe AI API+description:+ Transport-agnostic bindings to the TypeSafe System One API+ (<https://docs.typesafe.ai>): typed Noul, Choice and Score questions whose+ answers decode to your own Haskell types, a one-to-one mirror of the+ OpenAPI schemas, and API calls as plain values.+ .+ This package does no networking, so it can be used with servant or any+ other HTTP stack. For a ready-to-use client, depend on @typesafe-ai@.+ .+ Start with "TypeSafe.Core" and "TypeSafe.Question".+ .+ This is a community SDK, not affiliated with or endorsed by TypeSafe AI.++homepage: https://github.com/byteally/typesafe-sdk+bug-reports: https://github.com/byteally/typesafe-sdk/issues+license: BSD-3-Clause+license-file: LICENSE+author: Magesh B+maintainer: magesh85@gmail.com+copyright: 2026 byteally+category: AI, Web, API+build-type: Simple+tested-with:+ GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1++extra-doc-files:+ CHANGELOG.md+ README.md++extra-source-files:+ spec/openapi.json++source-repository head+ type: git+ location: https://github.com/byteally/typesafe-sdk.git+ subdir: typesafe-ai-core++common warnings+ ghc-options:+ -Wall -Wcompat -Widentities -Wincomplete-record-updates+ -Wincomplete-uni-patterns -Wmissing-deriving-strategies+ -Wpartial-fields -Wredundant-constraints -Wunused-packages++library+ import: warnings+ hs-source-dirs: src+ default-language: Haskell2010+ exposed-modules:+ TypeSafe.Call+ TypeSafe.Content+ TypeSafe.Core+ TypeSafe.Error+ TypeSafe.Internal.Generic+ TypeSafe.Question+ TypeSafe.Retry+ TypeSafe.Wire++ build-depends:+ , aeson >=2.1 && <2.4+ , base >=4.18 && <4.23+ , bytestring >=0.11.3 && <0.13+ , containers >=0.6.7 && <0.9+ , deepseq >=1.4.8 && <1.6+ , http-types >=0.12.3 && <0.13+ , text >=2.0 && <2.2+ , time >=1.12 && <1.17+ , vector >=0.13 && <0.14++test-suite spec+ import: warnings+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ TypeSafe.ArbitraryInstances+ TypeSafe.ConformanceSpec+ TypeSafe.ErrorSpec+ TypeSafe.JsonSchema+ TypeSafe.QuestionSpec+ TypeSafe.RetrySpec++ build-depends:+ , aeson+ , base+ , bytestring+ , containers+ , http-types+ , QuickCheck >=2.14 && <2.19+ , scientific >=0.3 && <0.4+ , tasty >=1.4 && <1.6+ , tasty-hunit >=0.10 && <0.11+ , tasty-quickcheck >=0.10 && <0.12+ , text+ , time+ , typesafe-ai-core+ , vector