typesafe-hs (empty) → 0.1.0.0
raw patch · 33 files changed
+3721/−0 lines, 33 filesdep +QuickCheckdep +aesondep +base
Dependencies added: QuickCheck, aeson, base, bytestring, containers, http-client-tls, http-types, scientific, servant, servant-client, servant-client-core, servant-server, tasty, tasty-hunit, tasty-quickcheck, text, time, typesafe-hs, vector, wai, warp
Files
- CHANGELOG.md +10/−0
- LICENSE +28/−0
- README.md +59/−0
- scripts/check-spec-drift.sh +32/−0
- spec/openapi.json +1322/−0
- src/TypeSafe/V1.hs +91/−0
- src/TypeSafe/Wire.hs +15/−0
- src/TypeSafe/Wire/Common.hs +97/−0
- src/TypeSafe/Wire/Error.hs +140/−0
- src/TypeSafe/Wire/Internal/Number.hs +11/−0
- src/TypeSafe/Wire/Models.hs +43/−0
- src/TypeSafe/Wire/Request.hs +253/−0
- src/TypeSafe/Wire/Response.hs +190/−0
- test/Main.hs +30/−0
- test/TypeSafe/Conformance/JsonSchema.hs +227/−0
- test/TypeSafe/Conformance/OperationsTest.hs +80/−0
- test/TypeSafe/Conformance/SchemaTest.hs +202/−0
- test/TypeSafe/ReadmeExample.hs +37/−0
- test/TypeSafe/ReadmeExampleTest.hs +32/−0
- test/TypeSafe/SpecVersionTest.hs +9/−0
- test/TypeSafe/Test/Arbitrary.hs +122/−0
- test/TypeSafe/Test/MockServer.hs +59/−0
- test/TypeSafe/V1Test.hs +104/−0
- test/TypeSafe/Wire/CommonTest.hs +46/−0
- test/TypeSafe/Wire/RequestTest.hs +121/−0
- test/TypeSafe/Wire/ResponseTest.hs +149/−0
- test/golden/baikai-request.bytes +1/−0
- test/golden/baikai-request.json +9/−0
- test/golden/baikai-response-missing-confidence.json +36/−0
- test/golden/baikai-response-missing-score.json +36/−0
- test/golden/baikai-response.json +9/−0
- test/golden/validation-error-422.json +1/−0
- typesafe-hs.cabal +120/−0
+ CHANGELOG.md view
@@ -0,0 +1,10 @@+# Changelog++## 0.1.0.0 — 2026-10-25++- Bind all 21 schemas in the OpenAPI 0.2.0 document fetched on 2026-10-24.+- Encode ordered System One questions and choice criteria deterministically, with duplicate-reporting helpers and exact-byte goldens.+- Decode lossless Scientific answers, required fields, unknown discriminator tags, model metadata and structured error bodies, including HTTPBadRequestError.+- Expose a shared NamedRoutes servant API and client with optional danger-zone headers and unchanged ClientError failures.+- Add generated schema conformance, published examples, loopback integration, specification drift checks and a compiled README example.+- Support JSON bodies and inline image assets; defer multipart image upload.
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2026 Nadeem Bitar++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,59 @@+# typesafe-hs++Haskell wire types, deterministic JSON codecs and a servant client for TypeSafe's System One API. Version 0.1.0.0 targets the vendored OpenAPI 0.2.0 document fetched on 2026-10-24, including all 21 schemas, box questions, inline image assets and the model listing.++Use GHC 9.12.4. Add `typesafe-hs ^>=0.1` to your application's Cabal dependencies. `TypeSafe.Wire` exports the wire surface; `TypeSafe.V1` exports the shared servant `API`, named routes and authenticated methods. The example also imports bytestring, containers, text and vector, so list those dependencies in your application.++The example prints the exact request bytes and calls the API. Credential lookup belongs to the application. The same module is compiled by the test suite; tests exercise its pure request construction without making a live API call.++<!-- README:BEGIN -->+```haskell+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module TypeSafe.ReadmeExample (main, request) where++import Data.ByteString.Lazy.Char8 qualified as LBS+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import System.Environment (lookupEnv)+import TypeSafe.V1+import TypeSafe.Wire++request :: SystemOneRequest+request =+ SystemOneRequest+ { model = jevLatest,+ state = ContentText "Checkout is unavailable.",+ questions =+ Vector.singleton+ ("urgent", QuestionNoul (NoulQuestion (Just (ContentText "Is service blocked?")) Nothing)),+ assets = Map.empty+ }++main :: IO ()+main = do+ LBS.putStrLn (encodeSystemOneRequest request)+ key <- maybe (fail "Set TYPESAFE_API_KEY") (pure . Text.pack) =<< lookupEnv "TYPESAFE_API_KEY"+ env <- getClientEnv defaultBaseUrl+ let methods = makeMethods env key+ response <- methods.createSystemOne request+ print response.answers+ print response.usage.inputTokens++```+<!-- README:END -->++The client accepts a caller-supplied servant `ClientEnv`. `getClientEnv` is a convenience using the TLS manager's defaults; construct your own environment to configure its manager. Failures throw servant-client's unchanged `ClientError`, preserving the raw status, headers and bytes in `FailureResponse`. `parseErrorBody` is a separate pure helper.++The library adds no retries, status classification, credential or base-URL environment lookup, logging, or timeout policy beyond the supplied manager. JSON bodies support inline images via `Asset.dataBase64`; multipart uploads are deferred. Enable image or long-context headers with `createSystemOneWith` and `DangerZone`.++Request questions and choice criteria encode in vector order. `encodeSystemOneRequest` returns the exact bytes servant sends. Duplicate names and labels are preserved and reported by `duplicateQuestionNames` and `duplicateChoiceLabels`; validate them before sending. Decoding JSON objects does not recover declaration order. Optional nullable content is omitted for `Nothing`; a choice-criteria value of `Nothing` encodes as JSON null.++Probabilities, confidences and scores remain `Scientific`, including extreme exponents. Required keys must be present, integral counts must fit `Int`, and unknown question or answer tags remain explicit `QuestionOther` or `AnswerOther` values. Wire decoders leave semantic validation to the caller. `ValidationError.input` is the current API's optional string preview.++Fields use plain names and the library exports no field selector functions such as `model`, `state` or `left`. Enable `OverloadedRecordDot` to read fields. Wire types derive `Generic`, so applications can also use generic-lens `#label` access and updates by importing `Data.Generics.Labels ()`; the library takes no lens dependency.++Run `nix develop -c cabal test all` for codec, golden, loopback, README and OpenAPI conformance checks. `scripts/check-spec-drift.sh` fetches and compares the published document, returning 0 for current, 1 for drift and 2 for a fetch or parse error. It writes only with `--write`. To assess another document without replacing the baseline, run the tests with `TYPESAFE_OPENAPI_SPEC=/path/to/openapi.json`.
+ scripts/check-spec-drift.sh view
@@ -0,0 +1,32 @@+#!/bin/sh+set -eu++usage() { echo "usage: $0 [--write]" >&2; exit 2; }+write=false+case "${1:-}" in+ '') [ "$#" -eq 0 ] || usage ;;+ --write) [ "$#" -eq 1 ] || usage; write=true ;;+ *) usage ;;+esac+for tool in curl jq diff; do+ command -v "$tool" >/dev/null 2>&1 || { echo "missing tool: $tool" >&2; exit 2; }+done+root=$(CDPATH= cd -- "$(dirname -- "$0")/.." && pwd)+tmp=$(mktemp -d) || exit 2+trap 'rm -rf "$tmp"' EXIT HUP INT TERM+url=${TYPESAFE_OPENAPI_URL:-https://api.typesafe.ai/openapi.json}+if ! curl -fsS --max-time 30 "$url" -o "$tmp/published.json"; then+ echo "could not fetch $url" >&2; exit 2+fi+if ! jq -e -S . "$tmp/published.json" > "$tmp/new.json" ||+ ! jq -e -S . "$root/spec/openapi.json" > "$tmp/old.json"; then+ echo "invalid or unreadable OpenAPI document" >&2; exit 2+fi+status=0+diff -u "$tmp/old.json" "$tmp/new.json" || status=$?+case "$status" in+ 0) echo "spec/openapi.json is current (info.version $(jq -r '.info.version' "$tmp/new.json"))" ;;+ 1) echo "spec/openapi.json has drifted from $url"+ if "$write"; then cp "$tmp/new.json" "$root/spec/openapi.json"; else exit 1; fi ;;+ *) echo "could not compare OpenAPI documents" >&2; exit 2 ;;+esac
+ spec/openapi.json view
@@ -0,0 +1,1322 @@+{+ "components": {+ "schemas": {+ "Answer": {+ "description": "An answer whose type matches the corresponding question.",+ "discriminator": {+ "mapping": {+ "box": "#/components/schemas/BoxAnswer",+ "choice": "#/components/schemas/ChoiceAnswer",+ "noul": "#/components/schemas/NoulAnswer",+ "score": "#/components/schemas/ScoreAnswer"+ },+ "propertyName": "type"+ },+ "oneOf": [+ {+ "$ref": "#/components/schemas/NoulAnswer",+ "title": "Noul"+ },+ {+ "$ref": "#/components/schemas/ChoiceAnswer",+ "title": "Choice"+ },+ {+ "$ref": "#/components/schemas/ScoreAnswer",+ "title": "Score"+ },+ {+ "$ref": "#/components/schemas/BoxAnswer",+ "title": "Box"+ }+ ]+ },+ "Asset": {+ "description": "An image that replaces its placeholder: its bytes in data_base64 with their format, or, in a multipart request, the name of the image part that holds them. Requests with images must send the header TypeSafe-Danger-Zone-Images: true.",+ "properties": {+ "data_base64": {+ "description": "Base64-encoded image data.",+ "title": "Data Base64",+ "type": "string"+ },+ "format": {+ "description": "The image format, required with data_base64. The actual format is detected from the bytes.",+ "enum": [+ "png",+ "jpg",+ "jpeg"+ ],+ "title": "Format",+ "type": "string"+ },+ "part": {+ "description": "In a multipart request, the name of the image part this asset uses. With part, data_base64 is ignored.",+ "title": "Part",+ "type": "string"+ },+ "type": {+ "const": "image",+ "description": "Identifies an image asset.",+ "title": "Type",+ "type": "string"+ }+ },+ "title": "Asset",+ "type": "object"+ },+ "BoxAnswer": {+ "description": "A located box with normalized edge coordinates and confidence.",+ "properties": {+ "box": {+ "$ref": "#/components/schemas/BoxCoordinates",+ "description": "The box's edges as fractions of image height and width, from 0 to 1. Each coordinate is the expected value of its edge's predicted position.",+ "examples": [+ {+ "bottom": 0.66,+ "left": 0.19,+ "right": 0.68,+ "top": 0.2+ }+ ]+ },+ "confidence": {+ "anyOf": [+ {+ "type": "number"+ },+ {+ "type": "null"+ }+ ],+ "description": "Confidence for the given box, from 0 to 1, with 1 being more confident. Null when the model does not provide confidence.",+ "examples": [+ null,+ 0.9+ ],+ "title": "Confidence"+ },+ "type": {+ "const": "box",+ "description": "Identifies a box answer.",+ "examples": [+ "box"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "type",+ "box",+ "confidence"+ ],+ "title": "BoxAnswer",+ "type": "object"+ },+ "BoxCoordinates": {+ "description": "Normalized box edges. Vertical coordinates are measured from the top of the image; horizontal coordinates are measured from the left.",+ "properties": {+ "bottom": {+ "description": "Bottom edge of the box, as a fraction of image height from the top (0-1).",+ "examples": [+ 0.66+ ],+ "title": "Bottom",+ "type": "number"+ },+ "left": {+ "description": "Left edge of the box, as a fraction of image width from the left (0-1).",+ "examples": [+ 0.19+ ],+ "title": "Left",+ "type": "number"+ },+ "right": {+ "description": "Right edge of the box, as a fraction of image width from the left (0-1).",+ "examples": [+ 0.68+ ],+ "title": "Right",+ "type": "number"+ },+ "top": {+ "description": "Top edge of the box, as a fraction of image height from the top (0-1).",+ "examples": [+ 0.2+ ],+ "title": "Top",+ "type": "number"+ }+ },+ "required": [+ "top",+ "bottom",+ "left",+ "right"+ ],+ "title": "BoxCoordinates",+ "type": "object"+ },+ "BoxQuestion": {+ "description": "A question that locates what its instructions describe in the request's image. Requests with box questions must send the header TypeSafe-Danger-Zone-Images: true.",+ "properties": {+ "instructions": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ },+ {+ "items": {},+ "type": "array"+ },+ {+ "type": "null"+ }+ ],+ "description": "What to locate in the image.",+ "title": "Instructions",+ "x-accepts": "string | object | array"+ },+ "type": {+ "const": "box",+ "description": "Identifies a box question.",+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "type"+ ],+ "title": "BoxQuestion",+ "type": "object"+ },+ "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": [+ "type",+ "choice",+ "confidence",+ "probabilities"+ ],+ "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"+ }+ ],+ "x-accepts": "string | object | array"+ },+ "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"+ }+ ],+ "maxProperties": 255,+ "minProperties": 1,+ "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",+ "x-accepts": "string | object | array"+ },+ "type": {+ "const": "choice",+ "description": "Identifies a question that selects one of the choices in criteria.",+ "examples": [+ "choice"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "type",+ "criteria"+ ],+ "title": "ChoiceQuestion",+ "type": "object"+ },+ "HTTPBadRequestError": {+ "description": "Application validation failures returned with HTTP status 400.",+ "properties": {+ "detail": {+ "anyOf": [+ {+ "type": "string"+ },+ {+ "additionalProperties": true,+ "type": "object"+ }+ ],+ "description": "Explanation of the invalid request. String details and message fields are bounded, with shortened text ending with ….",+ "title": "Detail"+ }+ },+ "required": [+ "detail"+ ],+ "title": "HTTPBadRequestError",+ "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": [+ "type",+ "noul"+ ],+ "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",+ "x-accepts": "string | object | array"+ },+ "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",+ "x-accepts": "string | object | array"+ }+ },+ "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",+ "x-accepts": "string | object | array"+ },+ "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": {+ "box": "#/components/schemas/BoxQuestion",+ "choice": "#/components/schemas/ChoiceQuestion",+ "noul": "#/components/schemas/NoulQuestion",+ "score": "#/components/schemas/ScoreQuestion"+ },+ "propertyName": "type"+ },+ "oneOf": [+ {+ "$ref": "#/components/schemas/NoulQuestion",+ "title": "Noul"+ },+ {+ "$ref": "#/components/schemas/ChoiceQuestion",+ "title": "Choice"+ },+ {+ "$ref": "#/components/schemas/ScoreQuestion",+ "title": "Score"+ },+ {+ "$ref": "#/components/schemas/BoxQuestion",+ "title": "Box"+ }+ ]+ },+ "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"+ }+ ],+ "x-accepts": "string | object | 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": [+ "type",+ "score",+ "confidence",+ "legend",+ "probabilities"+ ],+ "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"+ }+ ],+ "x-accepts": "string | object | array"+ },+ "maxItems": 10,+ "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",+ "x-accepts": "string | object | array"+ },+ "type": {+ "const": "score",+ "description": "Identifies a question that rates the content using the levels in criteria.",+ "examples": [+ "score"+ ],+ "title": "Type",+ "type": "string"+ }+ },+ "required": [+ "type",+ "criteria"+ ],+ "title": "ScoreQuestion",+ "type": "object"+ },+ "SystemOneRequest": {+ "description": "Content and named questions to evaluate together using a TypeSafe model.",+ "properties": {+ "assets": {+ "additionalProperties": {+ "$ref": "#/components/schemas/Asset"+ },+ "description": "Media assets keyed by an opaque placeholder (recommend a per-image UUID). Each placeholder, wherever it appears as or inside a string in state, question instructions, or criteria, is replaced with the asset. Image assets require a vision-language model.",+ "minProperties": 1,+ "title": "Assets",+ "type": "object"+ },+ "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",+ "x-accepts": "string | object | array"+ }+ },+ "required": [+ "model",+ "state",+ "questions"+ ],+ "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. Entries may be omitted or shortened.",+ "examples": [+ {+ "min_length": 1+ }+ ],+ "title": "Context",+ "type": "object"+ },+ "input": {+ "description": "Text preview of the rejected input. May be shortened with ….",+ "examples": [+ "{\"type\":\"score\"}"+ ],+ "title": "Input",+ "type": "string"+ },+ "loc": {+ "description": "Path to the invalid value: the request location followed by field names and array indices. May be empty.",+ "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. May be shortened with ….",+ "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"+ },+ "400": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPBadRequestError"+ }+ }+ },+ "description": "Bad Request"+ },+ "422": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPValidationError"+ }+ }+ },+ "description": "Validation Error"+ }+ },+ "security": [+ {+ "HTTPBearer": []+ }+ ],+ "summary": "List models"+ }+ },+ "/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",+ "parameters": [+ {+ "description": "Set to true to use assets or box questions.",+ "example": "true",+ "in": "header",+ "name": "TypeSafe-Danger-Zone-Images",+ "schema": {+ "enum": [+ "true"+ ],+ "type": "string"+ }+ },+ {+ "description": "Set to true to use long context.",+ "example": "true",+ "in": "header",+ "name": "TypeSafe-Danger-Zone-Long-Context",+ "schema": {+ "enum": [+ "true"+ ],+ "type": "string"+ }+ }+ ],+ "requestBody": {+ "content": {+ "application/json": {+ "examples": {+ "box": {+ "summary": "Box (requires TypeSafe-Danger-Zone-Images: true)",+ "value": {+ "assets": {+ "photo": {+ "data_base64": "iVBORw0KGgoAAAANSUhEUgAAABAAAAAQCAIAAACQkWg2AAAAHElEQVR4nGP4TyJgoKcGBgbsaFQDfTUQB4aDBgDAen2fpitsVAAAAABJRU5ErkJggg==",+ "format": "png",+ "type": "image"+ }+ },+ "model": "jev-preview",+ "questions": {+ "red_rectangle": {+ "instructions": "Locate the red rectangle.",+ "type": "box"+ }+ },+ "state": "photo"+ }+ },+ "choice": {+ "summary": "Choice",+ "value": {+ "model": "jev-latest",+ "questions": {+ "tone": {+ "criteria": {+ "angry": "An upset or hostile message",+ "calm": "A neutral or polite message",+ "excited": "An enthusiastic or eager message"+ },+ "instructions": "What is the tone of this message?",+ "type": "choice"+ }+ },+ "state": "I was charged twice for my subscription this month. Please refund the extra charge."+ }+ },+ "noul": {+ "summary": "Noul",+ "value": {+ "model": "jev-latest",+ "questions": {+ "billing": {+ "instructions": "Is this message about billing?",+ "type": "noul"+ }+ },+ "state": "I was charged twice for my subscription this month. Please refund the extra charge."+ }+ },+ "score": {+ "summary": "Score",+ "value": {+ "model": "jev-latest",+ "questions": {+ "urgency": {+ "criteria": [+ "Can wait",+ "Needs attention this week",+ "Needs attention today"+ ],+ "instructions": "How urgent is this message?",+ "type": "score"+ }+ },+ "state": "I was charged twice for my subscription this month. Please refund the extra charge."+ }+ }+ },+ "schema": {+ "$ref": "#/components/schemas/SystemOneRequest"+ }+ },+ "multipart/form-data": {+ "encoding": {+ "request": {+ "contentType": "application/json"+ }+ },+ "schema": {+ "additionalProperties": {+ "contentMediaType": "image/*",+ "description": "An image, named by the asset part that uses it.",+ "type": "string"+ },+ "description": "The JSON request as the first part, named request, then each image as its own part. Every image part needs a unique, non-empty name and must be used by exactly one asset's part.",+ "properties": {+ "request": {+ "contentMediaType": "application/json",+ "contentSchema": {+ "$ref": "#/components/schemas/SystemOneRequest"+ },+ "description": "The JSON request, as the first part."+ }+ },+ "required": [+ "request"+ ],+ "type": "object"+ }+ }+ },+ "required": true+ },+ "responses": {+ "200": {+ "content": {+ "application/json": {+ "examples": {+ "box": {+ "summary": "Box",+ "value": {+ "answers": {+ "red_rectangle": {+ "box": {+ "bottom": 0.66,+ "left": 0.19,+ "right": 0.68,+ "top": 0.2+ },+ "confidence": null,+ "type": "box"+ }+ },+ "model": "jev-preview",+ "usage": {+ "input_tokens": 285,+ "output_tokens": 20+ }+ }+ },+ "choice": {+ "summary": "Choice",+ "value": {+ "answers": {+ "tone": {+ "choice": "calm",+ "confidence": 0.7,+ "probabilities": {+ "angry": 0.15,+ "calm": 0.8,+ "excited": 0.05+ },+ "type": "choice"+ }+ },+ "model": "jev-latest",+ "usage": {+ "input_tokens": 120,+ "output_tokens": 12+ }+ }+ },+ "noul": {+ "summary": "Noul",+ "value": {+ "answers": {+ "billing": {+ "noul": 0.98,+ "type": "noul"+ }+ },+ "model": "jev-latest",+ "usage": {+ "input_tokens": 120,+ "output_tokens": 12+ }+ }+ },+ "score": {+ "summary": "Score",+ "value": {+ "answers": {+ "urgency": {+ "confidence": 0.55,+ "legend": {+ "0": "Can wait",+ "1": "Needs attention this week",+ "2": "Needs attention today"+ },+ "probabilities": {+ "0": 0.1,+ "1": 0.1,+ "2": 0.8+ },+ "score": 1.7,+ "type": "score"+ }+ },+ "model": "jev-latest",+ "usage": {+ "input_tokens": 120,+ "output_tokens": 12+ }+ }+ }+ },+ "schema": {+ "$ref": "#/components/schemas/SystemOneResponse"+ }+ }+ },+ "description": "Successful Response"+ },+ "400": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPBadRequestError"+ }+ }+ },+ "description": "Bad Request"+ },+ "422": {+ "content": {+ "application/json": {+ "schema": {+ "$ref": "#/components/schemas/HTTPValidationError"+ }+ }+ },+ "description": "Validation Error"+ }+ },+ "security": [+ {+ "HTTPBearer": []+ }+ ],+ "summary": "System One"+ }+ }+ },+ "servers": [+ {+ "url": "https://api.typesafe.ai"+ }+ ]+}
+ src/TypeSafe/V1.hs view
@@ -0,0 +1,91 @@+-- | Servant routes and a policy-free client for the System One API.+module TypeSafe.V1+ ( API,+ Routes (..),+ SystemOneEndpoint,+ ModelsEndpoint,+ Methods (..),+ DangerZone (..),+ noDangerZone,+ getClientEnv,+ makeMethods,+ ClientEnv,+ ClientError (..),+ )+where++import Control.Exception (throwIO)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)+import Network.HTTP.Client.TLS qualified as TLS+import Servant.API+import Servant.Client+import Servant.Client.Generic (genericClientHoist)+import TypeSafe.Wire++-- | @POST /v1/systemone@ with bearer auth and optional danger-zone headers.+type SystemOneEndpoint =+ Header' '[Required, Strict] "Authorization" Text+ :> "v1"+ :> "systemone"+ :> Header' '[Optional, Strict] "TypeSafe-Danger-Zone-Images" Text+ :> Header' '[Optional, Strict] "TypeSafe-Danger-Zone-Long-Context" Text+ :> ReqBody '[JSON] SystemOneRequest+ :> Post '[JSON] SystemOneResponse++-- | @GET /v1/models@ with bearer auth.+type ModelsEndpoint =+ Header' '[Required, Strict] "Authorization" Text+ :> "v1"+ :> "models"+ :> Get '[JSON] ModelMetadataList++-- | Every API operation, with auth declared on each endpoint.+data Routes mode = Routes+ { systemOne :: mode :- SystemOneEndpoint,+ models :: mode :- ModelsEndpoint+ }+ deriving stock (Generic)++-- | The shared client/server API contract.+type API = NamedRoutes Routes++-- | Each enabled flag sends its header as @true@; disabled flags omit it.+data DangerZone = DangerZone {images :: !Bool, longContext :: !Bool}+ deriving stock (Generic, Eq, Show)++-- | Send neither danger-zone header.+noDangerZone :: DangerZone+noDangerZone = DangerZone False False++-- | Authenticated methods; failures throw unmodified 'ClientError'.+data Methods = Methods+ { createSystemOne :: SystemOneRequest -> IO SystemOneResponse,+ createSystemOneWith :: DangerZone -> SystemOneRequest -> IO SystemOneResponse,+ listModels :: IO ModelMetadataList+ }+ deriving stock (Generic)++-- | Parse a base URL and create a TLS manager with its default settings.+-- Build a 'ClientEnv' with servant-client's @mkClientEnv@ to customize the manager.+getClientEnv :: Text -> IO ClientEnv+getClientEnv url = do+ base <- parseBaseUrl (Text.unpack url)+ manager <- TLS.newTlsManagerWith TLS.tlsManagerSettings+ pure (mkClientEnv manager base)++-- | Add @Bearer <key>@ and run the routes without retries or error translation.+makeMethods :: ClientEnv -> Text -> Methods+makeMethods env key = Methods {createSystemOne, createSystemOneWith, listModels}+ where+ run :: ClientM a -> IO a+ run action = runClientM action env >>= either throwIO pure+ routes :: Routes (AsClientT IO)+ routes = genericClientHoist run+ auth = "Bearer " <> key+ flag True = Just "true"+ flag False = Nothing+ createSystemOneWith zone = routes.systemOne auth (flag zone.images) (flag zone.longContext)+ createSystemOne = createSystemOneWith noDangerZone+ listModels = routes.models auth
+ src/TypeSafe/Wire.hs view
@@ -0,0 +1,15 @@+-- | Wire types and pure codecs for TypeSafe. Consumers can import this module alone.+module TypeSafe.Wire+ ( module TypeSafe.Wire.Common,+ module TypeSafe.Wire.Request,+ module TypeSafe.Wire.Response,+ module TypeSafe.Wire.Models,+ module TypeSafe.Wire.Error,+ )+where++import TypeSafe.Wire.Common+import TypeSafe.Wire.Error+import TypeSafe.Wire.Models+import TypeSafe.Wire.Request+import TypeSafe.Wire.Response
+ src/TypeSafe/Wire/Common.hs view
@@ -0,0 +1,97 @@+-- | Shared wire primitives. Import "TypeSafe.Wire" for the complete surface.+module TypeSafe.Wire.Common+ ( apiSpecVersion,+ ModelName (..),+ QuestionName (..),+ jevLatest,+ jevPreview,+ Content (..),+ contentFromValue,+ contentToValue,+ requestIdHeader,+ dangerZoneImagesHeader,+ dangerZoneLongContextHeader,+ systemOnePath,+ modelsPath,+ defaultBaseUrl,+ )+where++import Data.Aeson+import Data.String (IsString)+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.HTTP.Types (HeaderName)++-- | Version label of the vendored OpenAPI document (R10).+apiSpecVersion :: Text+apiSpecVersion = "0.2.0"++-- | An open model name or alias (R8).+newtype ModelName = ModelName Text+ deriving stock (Generic, Show)+ deriving newtype (Eq, Ord, IsString, ToJSON, FromJSON, ToJSONKey, FromJSONKey)++-- | An open caller-chosen question name (R8).+newtype QuestionName = QuestionName Text+ deriving stock (Generic, Show)+ deriving newtype (Eq, Ord, IsString, ToJSON, FromJSON, ToJSONKey, FromJSONKey)++-- | Published model aliases; no behavior is inferred from them (R8).+jevLatest, jevPreview :: ModelName+jevLatest = "jev-latest"+jevPreview = "jev-preview"++-- | Content is a string, object or array, never a scalar or null (R7).+data Content = ContentText !Text | ContentObject !Object | ContentArray !Array+ deriving stock (Generic, Eq, Show)++instance ToJSON Content where+ toJSON = contentToValue+ toEncoding (ContentText t) = toEncoding t+ toEncoding (ContentObject o) = toEncoding o+ toEncoding (ContentArray a) = toEncoding a++instance FromJSON Content where+ parseJSON v = case contentFromValue v of+ Just c -> pure c+ Nothing -> fail ("expected a string, object or array, got " <> kind v)+ where+ kind (Number _) = "number"+ kind (Bool _) = "boolean"+ kind Null = "null"+ kind _ = "unsupported value"++-- | Reject values outside the content union without stringifying them (R7).+contentFromValue :: Value -> Maybe Content+contentFromValue (String t) = Just (ContentText t)+contentFromValue (Object o) = Just (ContentObject o)+contentFromValue (Array a) = Just (ContentArray a)+contentFromValue _ = Nothing++-- | Preserve the underlying JSON structure (R7).+contentToValue :: Content -> Value+contentToValue (ContentText t) = String t+contentToValue (ContentObject o) = Object o+contentToValue (ContentArray a) = Array a++-- | Response request-id header (R6).+requestIdHeader :: HeaderName+requestIdHeader = "x-typesafe-request-id"++-- | Optional image feature header (R6).+dangerZoneImagesHeader :: HeaderName+dangerZoneImagesHeader = "TypeSafe-Danger-Zone-Images"++-- | Optional long-context feature header (R6).+dangerZoneLongContextHeader :: HeaderName+dangerZoneLongContextHeader = "TypeSafe-Danger-Zone-Long-Context"++-- | System One and model-listing path segments (R6).+systemOnePath, modelsPath :: [Text]+systemOnePath = ["v1", "systemone"]+modelsPath = ["v1", "models"]++-- | Default API base URL, with no environment lookup (R6).+defaultBaseUrl :: Text+defaultBaseUrl = "https://api.typesafe.ai"
+ src/TypeSafe/Wire/Error.hs view
@@ -0,0 +1,140 @@+-- | Pure error-body codecs and total parsing, with no status classification.+module TypeSafe.Wire.Error+ ( LocationSegment (..),+ ValidationError (..),+ HTTPValidationError (..),+ HTTPBadRequestError (..),+ BadRequestDetail (..),+ ErrorDetail (..),+ ErrorBody (..),+ parseErrorBody,+ )+where++import Data.Aeson+import Data.Aeson.Encoding qualified as Encoding+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseMaybe)+import Data.ByteString.Lazy qualified as LBS+import Data.Text (Text)+import Data.Text.Encoding qualified as Text+import Data.Vector (Vector)+import GHC.Generics (Generic)+import TypeSafe.Wire.Internal.Number++optionalPair :: (ToJSON a) => Key -> Maybe a -> Encoding.Series+optionalPair k = maybe mempty (k .=)++optionalValue :: (ToJSON a) => Key -> Maybe a -> [(Key, Value)]+optionalValue k = maybe [] (\v -> [k .= v])++-- | A field name or bounded integral array index.+data LocationSegment = LocationField !Text | LocationIndex !Int+ deriving stock (Generic, Eq, Show)++instance ToJSON LocationSegment where+ toJSON (LocationField t) = toJSON t+ toJSON (LocationIndex n) = toJSON n+ toEncoding (LocationField t) = toEncoding t+ toEncoding (LocationIndex n) = toEncoding n++instance FromJSON LocationSegment where+ parseJSON (String t) = pure (LocationField t)+ parseJSON v = LocationIndex <$> parseBoundedIntegral v++-- | One validation failure, with its path, explanation, code, optional text preview and context.+data ValidationError = ValidationError+ { loc :: !(Vector LocationSegment),+ msg :: !(Text),+ type_ :: !(Text),+ input :: !(Maybe Text),+ ctx :: !(Maybe Object)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ValidationError where+ toJSON x = object $ [] <> ["loc" .= x.loc] <> ["msg" .= x.msg] <> ["type" .= x.type_] <> optionalValue "input" x.input <> optionalValue "ctx" x.ctx+ toEncoding x = pairs $ "loc" .= x.loc <> "msg" .= x.msg <> "type" .= x.type_ <> optionalPair "input" x.input <> optionalPair "ctx" x.ctx++instance FromJSON ValidationError where+ parseJSON = withObject "ValidationError" $ \o -> ValidationError <$> o .: "loc" <*> o .: "msg" <*> o .: "type" <*> o .:! "input" <*> o .:! "ctx"++-- | Validation envelope; detail may be absent, but a present detail must be an array.+data HTTPValidationError = HTTPValidationError+ { detail :: !(Maybe (Vector ValidationError))+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON HTTPValidationError where+ toJSON x = object $ [] <> optionalValue "detail" x.detail+ toEncoding x = pairs $ optionalPair "detail" x.detail++instance FromJSON HTTPValidationError where+ parseJSON = withObject "HTTPValidationError" $ \o -> HTTPValidationError <$> o .:! "detail"++-- | Application error detail is either text or an arbitrary JSON object.+data BadRequestDetail = BadRequestDetailText !Text | BadRequestDetailObject !Object+ deriving stock (Generic, Eq, Show)++instance ToJSON BadRequestDetail where+ toJSON (BadRequestDetailText t) = String t+ toJSON (BadRequestDetailObject o) = Object o+ toEncoding (BadRequestDetailText t) = toEncoding t+ toEncoding (BadRequestDetailObject o) = toEncoding o++instance FromJSON BadRequestDetail where+ parseJSON (String t) = pure (BadRequestDetailText t)+ parseJSON (Object o) = pure (BadRequestDetailObject o)+ parseJSON _ = fail "expected a string or object detail"++-- | Application-validation detail, required as text or an arbitrary object.+data HTTPBadRequestError = HTTPBadRequestError+ { detail :: !(BadRequestDetail)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON HTTPBadRequestError where+ toJSON x = object $ [] <> ["detail" .= x.detail]+ toEncoding x = pairs $ "detail" .= x.detail++instance FromJSON HTTPBadRequestError where+ parseJSON = withObject "HTTPBadRequestError" $ \o -> HTTPBadRequestError <$> o .: "detail"++-- | Observed structured detail with a required message and optional error_type.+data ErrorDetail = ErrorDetail+ { errorType :: !(Maybe Text),+ message :: !(Text)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ErrorDetail where+ toJSON x = object $ [] <> optionalValue "error_type" x.errorType <> ["message" .= x.message]+ toEncoding x = pairs $ optionalPair "error_type" x.errorType <> "message" .= x.message++instance FromJSON ErrorDetail where+ parseJSON = withObject "ErrorDetail" $ \o -> ErrorDetail <$> o .:! "error_type" <*> o .: "message"++-- | Recognized body shapes, or complete JSON, text and empty fallbacks.+data ErrorBody+ = ErrorBodyValidation !HTTPValidationError+ | ErrorBodyDetail !ErrorDetail+ | ErrorBodyDetailText !Text+ | ErrorBodyJson !Value+ | ErrorBodyText !Text+ | ErrorBodyEmpty+ deriving stock (Generic, Eq, Show)++-- | Parse bytes without needing a status code. Invalid UTF-8 is replaced (R6).+parseErrorBody :: LBS.ByteString -> ErrorBody+parseErrorBody bytes+ | LBS.null bytes = ErrorBodyEmpty+ | otherwise = case eitherDecode bytes of+ Left _ -> ErrorBodyText (Text.decodeUtf8Lenient (LBS.toStrict bytes))+ Right value -> classify value+ where+ classify value@(Object o) = case KeyMap.lookup "detail" o of+ Just (Array _) | Just body <- parseMaybe parseJSON value -> ErrorBodyValidation body+ Just obj@(Object _) | Just d <- parseMaybe parseJSON obj -> ErrorBodyDetail d+ Just (String t) -> ErrorBodyDetailText t+ _ -> ErrorBodyJson value+ classify value = ErrorBodyJson value
+ src/TypeSafe/Wire/Internal/Number.hs view
@@ -0,0 +1,11 @@+module TypeSafe.Wire.Internal.Number (parseBoundedIntegral) where++import Data.Aeson (Value, withScientific)+import Data.Aeson.Types (Parser)+import Data.Scientific (isInteger, toBoundedInteger)++parseBoundedIntegral :: Value -> Parser Int+parseBoundedIntegral = withScientific "integral Int" $ \n ->+ if isInteger n+ then maybe (fail "integer outside Int range") pure (toBoundedInteger n)+ else fail "expected an integral number"
+ src/TypeSafe/Wire/Models.hs view
@@ -0,0 +1,43 @@+-- | Model metadata preserves release dates verbatim, with an optional day parser.+module TypeSafe.Wire.Models (ModelMetadataList (..), ModelMetadata (..), releaseDay) where++import Data.Aeson+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Time.Calendar (Day)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Data.Vector (Vector)+import GHC.Generics (Generic)+import TypeSafe.Wire.Common++-- | The available models returned by GET /v1/models, in server-provided order.+data ModelMetadataList = ModelMetadataList+ { models :: !(Vector ModelMetadata)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ModelMetadataList where+ toJSON x = object $ [] <> ["models" .= x.models]+ toEncoding x = pairs $ "models" .= x.models++instance FromJSON ModelMetadataList where+ parseJSON = withObject "ModelMetadataList" $ \o -> ModelMetadataList <$> o .: "models"++-- | Model metadata with verbatim release-date text; use releaseDay to parse a day.+data ModelMetadata = ModelMetadata+ { name :: !(ModelName),+ description :: !(Text),+ releaseDate :: !(Text)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ModelMetadata where+ toJSON x = object $ [] <> ["name" .= x.name] <> ["description" .= x.description] <> ["release_date" .= x.releaseDate]+ toEncoding x = pairs $ "name" .= x.name <> "description" .= x.description <> "release_date" .= x.releaseDate++instance FromJSON ModelMetadata where+ parseJSON = withObject "ModelMetadata" $ \o -> ModelMetadata <$> o .: "name" <*> o .: "description" <*> o .: "release_date"++-- | Parse YYYY-MM-DD when possible; unusual dates still decode as text (R9).+releaseDay :: ModelMetadata -> Maybe Day+releaseDay m = iso8601ParseM (Text.unpack m.releaseDate)
+ src/TypeSafe/Wire/Request.hs view
@@ -0,0 +1,253 @@+-- | Ordered request codecs. Decoding objects does not preserve declaration order.+module TypeSafe.Wire.Request+ ( SystemOneRequest (..),+ Question (..),+ NoulQuestion (..),+ NoulCriteria (..),+ ChoiceQuestion (..),+ ScoreQuestion (..),+ BoxQuestion (..),+ Asset (..),+ ImageFormat (..),+ encodeSystemOneRequest,+ duplicateQuestionNames,+ duplicateChoiceLabels,+ )+where++import Control.Monad (unless)+import Data.Aeson+import Data.Aeson.Encoding qualified as Encoding+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser)+import Data.ByteString.Lazy (ByteString)+import Data.List.NonEmpty (NonEmpty)+import Data.Map.Strict (Map)+import Data.Map.Strict qualified as Map+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Vector (Vector)+import Data.Vector qualified as Vector+import GHC.Generics (Generic)+import TypeSafe.Wire.Common++-- | Questions retain caller order when encoding; decoded order is unspecified.+data SystemOneRequest = SystemOneRequest+ { model :: !ModelName,+ state :: !Content,+ questions :: !(Vector (QuestionName, Question)),+ assets :: !(Map Text Asset)+ }+ deriving stock (Generic, Eq, Show)++-- | Known variants and complete unknown objects for forward compatibility.+data Question+ = QuestionNoul !NoulQuestion+ | QuestionChoice !ChoiceQuestion+ | QuestionScore !ScoreQuestion+ | QuestionBox !BoxQuestion+ | QuestionOther !Text !Object+ deriving stock (Generic, Eq, Show)++-- | A yes/no question with optional instructions and criteria.+data NoulQuestion = NoulQuestion+ {instructions :: !(Maybe Content), criteria :: !(Maybe NoulCriteria)}+ deriving stock (Generic, Eq, Show)++-- | Optional descriptions for the true and false outcomes.+data NoulCriteria = NoulCriteria+ {true :: !(Maybe Content), false :: !(Maybe Content)}+ deriving stock (Generic, Eq, Show)++-- | Criteria retain vector order on encode; decoded order is unspecified.+data ChoiceQuestion = ChoiceQuestion+ {instructions :: !(Maybe Content), criteria :: !(Vector (Text, Maybe Content))}+ deriving stock (Generic, Eq, Show)++-- | A rating question with ordered, nonempty score levels.+data ScoreQuestion = ScoreQuestion+ {instructions :: !(Maybe Content), criteria :: !(NonEmpty Content)}+ deriving stock (Generic, Eq, Show)++-- | An image localization question with optional instructions.+data BoxQuestion = BoxQuestion {instructions :: !(Maybe Content)}+ deriving stock (Generic, Eq, Show)++-- | Image formats declared by the specification.+data ImageFormat = ImageFormatPng | ImageFormatJpg | ImageFormatJpeg+ deriving stock (Generic, Eq, Show, Enum, Bounded)++-- | Inline JSON assets; multipart transport is outside the initial release.+data Asset = Asset+ {format :: !(Maybe ImageFormat), dataBase64 :: !(Maybe Text), part :: !(Maybe Text)}+ deriving stock (Generic, Eq, Show)++optionalPair :: (ToJSON a) => Key -> Maybe a -> Encoding.Series+optionalPair k = maybe mempty (k .=)++optionalValue :: (ToJSON a) => Key -> Maybe a -> [Pair]+optionalValue k = maybe [] (\v -> [k .= v])++type Pair = (Key, Value)++requireTag :: Text -> Object -> Parser ()+requireTag expected o = do+ tag <- o .: "type"+ unless (tag == expected) (fail "unexpected question discriminator")++instance ToJSON SystemOneRequest where+ toJSON r =+ object $+ [ "model" .= r.model,+ "state" .= r.state,+ "questions" .= Object (KeyMap.fromList [(Key.fromText k, toJSON q) | (QuestionName k, q) <- Vector.toList r.questions])+ ]+ <> ["assets" .= r.assets | not (Map.null r.assets)]+ toEncoding r =+ pairs $+ "model" .= r.model+ <> "state" .= r.state+ <> Encoding.pair "questions" (pairs (foldMap (\(QuestionName k, q) -> Key.fromText k .= q) r.questions))+ <> if Map.null r.assets then mempty else "assets" .= r.assets++instance FromJSON SystemOneRequest where+ parseJSON = withObject "SystemOneRequest" $ \o ->+ SystemOneRequest+ <$> o .: "model"+ <*> o .: "state"+ <*> (Vector.fromList . Map.toList <$> o .: "questions")+ <*> o .:! "assets" .!= Map.empty++instance ToJSON Question where+ toJSON (QuestionNoul q) = toJSON q+ toJSON (QuestionChoice q) = toJSON q+ toJSON (QuestionScore q) = toJSON q+ toJSON (QuestionBox q) = toJSON q+ toJSON (QuestionOther tag o) = Object (KeyMap.insert "type" (String tag) o)+ toEncoding (QuestionNoul q) = toEncoding q+ toEncoding (QuestionChoice q) = toEncoding q+ toEncoding (QuestionScore q) = toEncoding q+ toEncoding (QuestionBox q) = toEncoding q+ toEncoding (QuestionOther tag o) = toEncoding (KeyMap.insert "type" (String tag) o)++instance FromJSON Question where+ parseJSON v =+ withObject+ "Question"+ ( \o -> do+ tag <- o .: "type"+ case tag of+ "noul" -> QuestionNoul <$> parseJSON v+ "choice" -> QuestionChoice <$> parseJSON v+ "score" -> QuestionScore <$> parseJSON v+ "box" -> QuestionBox <$> parseJSON v+ _ -> pure (QuestionOther tag o)+ )+ v++instance ToJSON NoulQuestion where+ toJSON q = object $ ["type" .= ("noul" :: Text)] <> optionalValue "instructions" q.instructions <> optionalValue "criteria" q.criteria+ toEncoding q = pairs $ "type" .= ("noul" :: Text) <> optionalPair "instructions" q.instructions <> optionalPair "criteria" q.criteria++instance FromJSON NoulQuestion where+ parseJSON = withObject "NoulQuestion" $ \o -> requireTag "noul" o *> (NoulQuestion <$> o .:? "instructions" <*> o .:? "criteria")++instance ToJSON NoulCriteria where+ toJSON c = object $ optionalValue "true" c.true <> optionalValue "false" c.false+ toEncoding c = pairs $ optionalPair "true" c.true <> optionalPair "false" c.false++instance FromJSON NoulCriteria where+ parseJSON = withObject "NoulCriteria" $ \o -> NoulCriteria <$> o .:? "true" <*> o .:? "false"++instance ToJSON ChoiceQuestion where+ toJSON q =+ object $+ ["type" .= ("choice" :: Text)]+ <> optionalValue "instructions" q.instructions+ <> ["criteria" .= Object (KeyMap.fromList [(Key.fromText k, toJSON v) | (k, v) <- Vector.toList q.criteria])]+ toEncoding q =+ pairs $+ "type" .= ("choice" :: Text)+ <> optionalPair "instructions" q.instructions+ <> Encoding.pair "criteria" (pairs (foldMap (\(k, v) -> Key.fromText k .= v) q.criteria))++instance FromJSON ChoiceQuestion where+ parseJSON = withObject "ChoiceQuestion" $ \o ->+ requireTag "choice" o+ *> ( ChoiceQuestion+ <$> o .:? "instructions"+ <*> (Vector.fromList . Map.toList <$> o .: "criteria")+ )++instance ToJSON ScoreQuestion where+ toJSON q = object $ ["type" .= ("score" :: Text)] <> optionalValue "instructions" q.instructions <> ["criteria" .= q.criteria]+ toEncoding q = pairs $ "type" .= ("score" :: Text) <> optionalPair "instructions" q.instructions <> "criteria" .= q.criteria++instance FromJSON ScoreQuestion where+ parseJSON = withObject "ScoreQuestion" $ \o -> requireTag "score" o *> (ScoreQuestion <$> o .:? "instructions" <*> o .: "criteria")++instance ToJSON BoxQuestion where+ toJSON q = object $ ["type" .= ("box" :: Text)] <> optionalValue "instructions" q.instructions+ toEncoding q = pairs $ "type" .= ("box" :: Text) <> optionalPair "instructions" q.instructions++instance FromJSON BoxQuestion where+ parseJSON = withObject "BoxQuestion" $ \o -> requireTag "box" o *> (BoxQuestion <$> o .:? "instructions")++instance ToJSON ImageFormat where+ toJSON = String . imageFormatText+ toEncoding = toEncoding . imageFormatText++instance FromJSON ImageFormat where+ parseJSON = withText "ImageFormat" $ \case+ "png" -> pure ImageFormatPng+ "jpg" -> pure ImageFormatJpg+ "jpeg" -> pure ImageFormatJpeg+ _ -> fail "expected png, jpg or jpeg"++imageFormatText :: ImageFormat -> Text+imageFormatText ImageFormatPng = "png"+imageFormatText ImageFormatJpg = "jpg"+imageFormatText ImageFormatJpeg = "jpeg"++instance ToJSON Asset where+ toJSON a =+ object $+ ["type" .= ("image" :: Text)]+ <> optionalValue "format" a.format+ <> optionalValue "data_base64" a.dataBase64+ <> optionalValue "part" a.part+ toEncoding a =+ pairs $+ "type" .= ("image" :: Text)+ <> optionalPair "format" a.format+ <> optionalPair "data_base64" a.dataBase64+ <> optionalPair "part" a.part++instance FromJSON Asset where+ parseJSON = withObject "Asset" $ \o -> do+ case KeyMap.lookup "type" o of+ Nothing -> pure ()+ Just (String "image") -> pure ()+ _ -> fail "expected image asset"+ Asset <$> o .:! "format" <*> o .:! "data_base64" <*> o .:! "part"++-- | Exact deterministic bytes used by aeson and servant's JSON renderer (R3).+encodeSystemOneRequest :: SystemOneRequest -> ByteString+encodeSystemOneRequest = Encoding.encodingToLazyByteString . toEncoding++-- | Repeated names once each, in order of first repetition; encoding keeps them.+duplicateQuestionNames :: SystemOneRequest -> [QuestionName]+duplicateQuestionNames r = duplicates (map fst (Vector.toList r.questions))++-- | Repeated choice labels once each, in order of first repetition.+duplicateChoiceLabels :: ChoiceQuestion -> [Text]+duplicateChoiceLabels q = duplicates (map fst (Vector.toList q.criteria))++duplicates :: (Ord a) => [a] -> [a]+duplicates = go Set.empty Set.empty+ where+ go _ _ [] = []+ go seen reported (x : xs)+ | Set.member x seen && Set.notMember x reported = x : go seen (Set.insert x reported) xs+ | otherwise = go (Set.insert x seen) reported xs
+ src/TypeSafe/Wire/Response.hs view
@@ -0,0 +1,190 @@+-- | Lossless success-response codecs. Semantic validation belongs to callers.+module TypeSafe.Wire.Response+ ( SystemOneResponse (..),+ Answer (..),+ NoulAnswer (..),+ ChoiceAnswer (..),+ ScoreAnswer (..),+ BoxAnswer (..),+ BoxCoordinates (..),+ Usage (..),+ decodeSystemOneResponse,+ finiteDouble,+ unitInterval,+ )+where++import Control.Monad (unless)+import Data.Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (Parser)+import Data.ByteString.Lazy (ByteString)+import Data.Map.Strict (Map)+import Data.Scientific (Scientific, toBoundedRealFloat)+import Data.Text (Text)+import Data.Text qualified as Text+import GHC.Generics (Generic)+import TypeSafe.Wire.Common+import TypeSafe.Wire.Internal.Number++requireTag :: Text -> Object -> Parser ()+requireTag expected o = do+ tag <- o .: "type"+ unless (tag == expected) (fail "unexpected answer discriminator")++-- | A model's answers keyed by caller-chosen question names, with token usage.+data SystemOneResponse = SystemOneResponse+ { model :: !(ModelName),+ answers :: !(Map QuestionName Answer),+ usage :: !(Usage)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON SystemOneResponse where+ toJSON x = object $ [] <> ["model" .= x.model] <> ["answers" .= x.answers] <> ["usage" .= x.usage]+ toEncoding x = pairs $ "model" .= x.model <> "answers" .= x.answers <> "usage" .= x.usage++instance FromJSON SystemOneResponse where+ parseJSON = withObject "SystemOneResponse" $ \o -> SystemOneResponse <$> o .: "model" <*> o .: "answers" <*> o .: "usage"++-- | Known variants and complete unknown objects for forward compatibility.+data Answer+ = AnswerNoul !NoulAnswer+ | AnswerChoice !ChoiceAnswer+ | AnswerScore !ScoreAnswer+ | AnswerBox !BoxAnswer+ | AnswerOther !Text !Object+ deriving stock (Generic, Eq, Show)++instance ToJSON Answer where+ toJSON (AnswerNoul a) = toJSON a+ toJSON (AnswerChoice a) = toJSON a+ toJSON (AnswerScore a) = toJSON a+ toJSON (AnswerBox a) = toJSON a+ toJSON (AnswerOther tag o) = Object (KeyMap.insert "type" (String tag) o)+ toEncoding (AnswerNoul a) = toEncoding a+ toEncoding (AnswerChoice a) = toEncoding a+ toEncoding (AnswerScore a) = toEncoding a+ toEncoding (AnswerBox a) = toEncoding a+ toEncoding (AnswerOther tag o) = toEncoding (KeyMap.insert "type" (String tag) o)++instance FromJSON Answer where+ parseJSON v =+ withObject+ "Answer"+ ( \o -> do+ tag <- o .: "type"+ case tag of+ "noul" -> AnswerNoul <$> parseJSON v+ "choice" -> AnswerChoice <$> parseJSON v+ "score" -> AnswerScore <$> parseJSON v+ "box" -> AnswerBox <$> parseJSON v+ _ -> pure (AnswerOther tag o)+ )+ v++-- | The probability of yes or true, preserved without range checks.+data NoulAnswer = NoulAnswer+ { noul :: !(Scientific)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON NoulAnswer where+ toJSON x = object $ ["type" .= ("noul" :: Text)] <> ["noul" .= x.noul]+ toEncoding x = pairs $ "type" .= ("noul" :: Text) <> "noul" .= x.noul++instance FromJSON NoulAnswer where+ parseJSON = withObject "NoulAnswer" $ \o -> requireTag "noul" o *> (NoulAnswer <$> o .: "noul")++-- | The selected label, its confidence and the complete label-probability map.+data ChoiceAnswer = ChoiceAnswer+ { choice :: !(Text),+ confidence :: !(Scientific),+ probabilities :: !(Map Text Scientific)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ChoiceAnswer where+ toJSON x = object $ ["type" .= ("choice" :: Text)] <> ["choice" .= x.choice] <> ["confidence" .= x.confidence] <> ["probabilities" .= x.probabilities]+ toEncoding x = pairs $ "type" .= ("choice" :: Text) <> "choice" .= x.choice <> "confidence" .= x.confidence <> "probabilities" .= x.probabilities++instance FromJSON ChoiceAnswer where+ parseJSON = withObject "ChoiceAnswer" $ \o -> requireTag "choice" o *> (ChoiceAnswer <$> o .: "choice" <*> o .: "confidence" <*> o .: "probabilities")++-- | An expected rating, its confidence and the verbatim level legend and probabilities.+data ScoreAnswer = ScoreAnswer+ { score :: !(Scientific),+ confidence :: !(Scientific),+ legend :: !(Map Text Content),+ probabilities :: !(Map Text Scientific)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON ScoreAnswer where+ toJSON x = object $ ["type" .= ("score" :: Text)] <> ["score" .= x.score] <> ["confidence" .= x.confidence] <> ["legend" .= x.legend] <> ["probabilities" .= x.probabilities]+ toEncoding x = pairs $ "type" .= ("score" :: Text) <> "score" .= x.score <> "confidence" .= x.confidence <> "legend" .= x.legend <> "probabilities" .= x.probabilities++instance FromJSON ScoreAnswer where+ parseJSON = withObject "ScoreAnswer" $ \o -> requireTag "score" o *> (ScoreAnswer <$> o .: "score" <*> o .: "confidence" <*> o .: "legend" <*> o .: "probabilities")++-- | An image box with required confidence that may explicitly be null on the wire.+data BoxAnswer = BoxAnswer+ { box :: !(BoxCoordinates),+ confidence :: !(Maybe Scientific)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON BoxAnswer where+ toJSON x = object $ ["type" .= ("box" :: Text)] <> ["box" .= x.box] <> ["confidence" .= x.confidence]+ toEncoding x = pairs $ "type" .= ("box" :: Text) <> "box" .= x.box <> "confidence" .= x.confidence++instance FromJSON BoxAnswer where+ parseJSON = withObject "BoxAnswer" $ \o -> requireTag "box" o *> (BoxAnswer <$> o .: "box" <*> o .: "confidence")++-- | Image-edge coordinates as fractions of height and width, preserved without clamping.+data BoxCoordinates = BoxCoordinates+ { top :: !(Scientific),+ bottom :: !(Scientific),+ left :: !(Scientific),+ right :: !(Scientific)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON BoxCoordinates where+ toJSON x = object $ [] <> ["top" .= x.top] <> ["bottom" .= x.bottom] <> ["left" .= x.left] <> ["right" .= x.right]+ toEncoding x = pairs $ "top" .= x.top <> "bottom" .= x.bottom <> "left" .= x.left <> "right" .= x.right++instance FromJSON BoxCoordinates where+ parseJSON = withObject "BoxCoordinates" $ \o -> BoxCoordinates <$> o .: "top" <*> o .: "bottom" <*> o .: "left" <*> o .: "right"++-- | Integral token counts; decoding rejects fractions and values outside Int.+data Usage = Usage+ { inputTokens :: !(Int),+ outputTokens :: !(Int)+ }+ deriving stock (Generic, Eq, Show)++instance ToJSON Usage where+ toJSON x = object $ [] <> ["input_tokens" .= x.inputTokens] <> ["output_tokens" .= x.outputTokens]+ toEncoding x = pairs $ "input_tokens" .= x.inputTokens <> "output_tokens" .= x.outputTokens++instance FromJSON Usage where+ parseJSON = withObject "Usage" $ \o -> Usage <$> (o .: "input_tokens" >>= parseBoundedIntegral) <*> (o .: "output_tokens" >>= parseBoundedIntegral)++-- | Decode without converting or validating probabilities (R4, R5).+decodeSystemOneResponse :: ByteString -> Either Text SystemOneResponse+decodeSystemOneResponse = either (Left . Text.pack) Right . eitherDecode++-- | Convert to Double only if representable, rejecting overflow and underflow.+finiteDouble :: Scientific -> Either Text Double+finiteDouble n = case toBoundedRealFloat n of+ Left _ -> Left "number outside the representable Double range"+ Right d+ | isInfinite d || isNaN d -> Left "number is not finite"+ | otherwise -> Right d++-- | Consumer helper; wire decoders never call this range check.+unitInterval :: Scientific -> Either Text Double+unitInterval n+ | n < 0 || n > 1 = Left "number outside [0, 1]"+ | otherwise = finiteDouble n
+ test/Main.hs view
@@ -0,0 +1,30 @@+module Main (main) where++import Data.Maybe (fromMaybe)+import System.Environment (lookupEnv)+import Test.Tasty+import TypeSafe.Conformance.JsonSchema (loadSpec)+import TypeSafe.Conformance.OperationsTest qualified+import TypeSafe.Conformance.SchemaTest qualified+import TypeSafe.ReadmeExampleTest qualified+import TypeSafe.SpecVersionTest qualified+import TypeSafe.V1Test qualified+import TypeSafe.Wire.CommonTest qualified+import TypeSafe.Wire.RequestTest qualified+import TypeSafe.Wire.ResponseTest qualified++main :: IO ()+main = do+ spec <- loadSpec . fromMaybe "spec/openapi.json" =<< lookupEnv "TYPESAFE_OPENAPI_SPEC"+ defaultMain $+ testGroup+ "typesafe-hs"+ [ TypeSafe.SpecVersionTest.tests spec,+ TypeSafe.ReadmeExampleTest.tests,+ TypeSafe.Conformance.SchemaTest.tests spec,+ TypeSafe.Conformance.OperationsTest.tests spec,+ TypeSafe.V1Test.tests,+ TypeSafe.Wire.CommonTest.tests,+ TypeSafe.Wire.RequestTest.tests,+ TypeSafe.Wire.ResponseTest.tests+ ]
+ test/TypeSafe/Conformance/JsonSchema.hs view
@@ -0,0 +1,227 @@+-- | Test-only reader and validator for the audited OpenAPI/JSON Schema subset.+module TypeSafe.Conformance.JsonSchema where++import Data.Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.Foldable (toList)+import Data.List (nub, sort)+import Data.Maybe (fromMaybe)+import Data.Scientific qualified as Scientific+import Data.Text (Text)+import Data.Text qualified as Text++newtype Spec = Spec Value++loadSpec :: FilePath -> IO Spec+loadSpec path = do+ value <- either fail pure =<< eitherDecodeFileStrict path+ case value of+ Object _ -> pure (Spec value)+ _ -> fail "OpenAPI document must be an object"++specFromValue :: Value -> Spec+specFromValue = Spec++at :: [Text] -> Value -> Value+at [] v = v+at (k : ks) (Object o) = maybe Null (at ks) (KM.lookup (Key.fromText k) o)+at _ _ = Null++entries :: Value -> [(Text, Value)]+entries (Object o) = [(Key.toText k, v) | (k, v) <- KM.toList o]+entries _ = []++array :: Value -> [Value]+array (Array xs) = toList xs+array _ = []++textValue :: Value -> Maybe Text+textValue (String t) = Just t+textValue _ = Nothing++specVersion :: Spec -> Maybe Text+specVersion (Spec v) = textValue (at ["info", "version"] v)++operations :: Spec -> [(Text, Text, Value)]+operations (Spec v) = [(Text.toUpper method, path, op) | (path, item) <- entries (at ["paths"] v), (method, op) <- entries item, method `elem` methods]++methods :: [Text]+methods = ["get", "post", "put", "delete", "patch", "head", "options", "trace"]++specOperations :: Spec -> [(Text, Text)]+specOperations spec = [(m, p) | (m, p, _) <- operations spec]++specSchemaNames :: Spec -> [Text]+specSchemaNames (Spec v) = map fst (entries (at ["components", "schemas"] v))++lookupSchema :: Spec -> Text -> Maybe Value+lookupSchema (Spec v) name = case at ["components", "schemas"] v of+ Object o -> KM.lookup (Key.fromText name) o+ _ -> Nothing++schemaRef :: Text -> Value+schemaRef name = object ["$ref" .= ("#/components/schemas/" <> name)]++objectProperties :: Spec -> Text -> [Text]+objectProperties spec name = maybe [] (map fst . entries . at ["properties"]) (lookupSchema spec name)++requiredProperties :: Spec -> Text -> [Text]+requiredProperties spec name = maybe [] (foldMap (maybe [] pure . textValue) . array . at ["required"]) (lookupSchema spec name)++discriminatorTags :: Spec -> Text -> [Text]+discriminatorTags spec name = maybe [] (map fst . entries . at ["discriminator", "mapping"]) (lookupSchema spec name)++propertyExamples :: Spec -> Text -> [(Text, [Value])]+propertyExamples spec name = [(k, array (at ["examples"] s)) | (k, s) <- maybe [] (entries . at ["properties"]) (lookupSchema spec name)]++mediaObjects :: Spec -> [(Text, Text, Text, Text, Value)]+mediaObjects spec =+ concat+ [ [(m, p, "request", ct, media) | (ct, media) <- entries (at ["requestBody", "content"] op)]+ <> [(m, p, status, ct, media) | (status, response) <- entries (at ["responses"] op), (ct, media) <- entries (at ["content"] response)]+ | (m, p, op) <- operations spec+ ]++operationContentTypes :: Spec -> [(Text, Text, Text, Text)]+operationContentTypes spec = [(m, p, w, ct) | (m, p, w, ct, _) <- mediaObjects spec]++operationExamples :: Spec -> [(Text, Text, Text, Text, Value)]+operationExamples spec = [(m, p, w, name, at ["value"] ex) | (m, p, w, "application/json", media) <- mediaObjects spec, (name, ex) <- entries (at ["examples"] media)]++operationParameters :: Spec -> [(Text, Text, Text, Text, Value)]+operationParameters spec = [(m, p, fromMaybe "" (textValue (at ["name"] param)), fromMaybe "" (textValue (at ["in"] param)), at ["schema"] param) | (m, p, op) <- operations spec, param <- array (at ["parameters"] op)]++operationSecurity :: Spec -> [(Text, Text, Value)]+operationSecurity spec = [(m, p, at ["security"] op) | (m, p, op) <- operations spec]++securitySchemes :: Spec -> Value+securitySchemes (Spec v) = at ["components", "securitySchemes"] v++serverUrls :: Spec -> [Text]+serverUrls (Spec v) = [url | s <- array (at ["servers"] v), Just url <- [textValue (at ["url"] s)]]++schemaRoots :: Spec -> [Value]+schemaRoots spec@(Spec v) =+ map snd (entries (at ["components", "schemas"] v))+ <> [s | (_, _, _, _, s) <- operationParameters spec]+ <> [at ["schema"] media | (_, _, _, _, media) <- mediaObjects spec]++schemaNodes :: Value -> [Value]+schemaNodes value@(Object o) =+ value+ : concat+ [ case Key.toText k of+ "properties" -> concatMap (schemaNodes . snd) (entries v)+ "additionalProperties" -> schemaNodes v+ "items" -> schemaNodes v+ "anyOf" -> concatMap schemaNodes (array v)+ "oneOf" -> concatMap schemaNodes (array v)+ "contentSchema" -> schemaNodes v+ _ -> []+ | (k, v) <- KM.toList o+ ]+schemaNodes v = [v]++supportedKeywords :: [Text]+supportedKeywords = ["$ref", "type", "const", "enum", "properties", "required", "additionalProperties", "items", "minItems", "maxItems", "minProperties", "maxProperties", "anyOf", "oneOf", "title", "description", "examples", "default", "discriminator", "x-accepts", "contentMediaType", "contentSchema"]++unsupportedKeywords :: Spec -> [Text]+unsupportedKeywords spec = sort . nub $ [k | root <- schemaRoots spec, node <- schemaNodes root, (k, _) <- entries node, k `notElem` supportedKeywords]++unsupportedOpenApiFields :: Spec -> [Text]+unsupportedOpenApiFields spec@(Spec root) =+ check "root" ["openapi", "info", "paths", "components", "servers"] root+ <> check "info" ["title", "description", "version"] (at ["info"] root)+ <> check "components" ["schemas", "securitySchemes"] (at ["components"] root)+ <> ["root missing " <> k | k <- ["openapi", "info", "paths", "components"], at [k] root == Null]+ <> ["components.schemas must be a nonempty object" | null (specSchemaNames spec)]+ <> ["unsupported OpenAPI version" | at ["openapi"] root /= String "3.1.0"]+ <> concat [check ("paths." <> p) methods item | (p, item) <- entries (at ["paths"] root)]+ <> concat [auditOperation m p op | (m, p, op) <- operations spec]+ <> concat+ [ check (m <> " " <> p <> " " <> w <> " " <> ct) ["schema", "examples", "encoding"] media+ <> concat [check ("example." <> name) ["summary", "description", "value"] ex | (name, ex) <- entries (at ["examples"] media)]+ | (m, p, w, ct, media) <- mediaObjects spec+ ]+ <> concat+ [ check ("securitySchemes." <> name) ["type", "scheme", "description"] s+ <> ["unsupported security scheme " <> name | at ["type"] s /= String "http" || at ["scheme"] s /= String "bearer"]+ | (name, s) <- entries (securitySchemes spec)+ ]+ where+ check path allowed value =+ [path <> "." <> k | (k, _) <- entries value, k `notElem` allowed]+ <> [path <> " must be an object" | case value of Object _ -> False; _ -> True]+ auditOperation m p op =+ let prefix = m <> " " <> p+ in check prefix ["summary", "description", "operationId", "parameters", "requestBody", "responses", "security"] op+ <> concat+ [ check (prefix <> " parameter") ["name", "in", "description", "schema", "example", "required"] param+ <> [prefix <> " unsupported parameter location" | at ["in"] param /= String "header"]+ | param <- array (at ["parameters"] op)+ ]+ <> [prefix <> " unknown security scheme " <> name | security <- array (at ["security"] op), (name, _) <- entries security, name `notElem` map fst (entries (securitySchemes spec))]+ <> (if at ["requestBody"] op == Null then [] else check (prefix <> " requestBody") ["content", "required", "description"] (at ["requestBody"] op))+ <> concat [check (prefix <> " response " <> status) ["description", "content"] response | (status, response) <- entries (at ["responses"] op)]++validate :: Spec -> Value -> Value -> [String]+validate spec = go (0 :: Int) "$"+ where+ go depth path schema value+ | depth > 64 = [path <> ": schema reference recursion limit exceeded"]+ | otherwise = case schema of+ Bool True -> []+ Bool False -> [path <> ": no value allowed"]+ Object s -> concatMap (keyword (depth + 1) path s value) (KM.toList s)+ _ -> [path <> ": malformed schema"]+ keyword depth path s value (key, arg) =+ let recur = go depth+ err message = [path <> ": " <> message]+ count predicate message = [path <> ": " <> message | predicate]+ in case Key.toText key of+ "$ref" -> case arg of+ String ref | Just name <- Text.stripPrefix "#/components/schemas/" ref, Just target <- lookupSchema spec name -> recur path target value+ _ -> err ("unresolved reference " <> show arg)+ "type" -> case arg of+ String t -> count (not (hasType t value)) ("expected " <> Text.unpack t)+ _ -> err "malformed type"+ "const" -> count (value /= arg) "constant mismatch"+ "enum" -> case arg of+ Array values -> count (value `notElem` toList values) "enum mismatch"+ _ -> err "malformed enum"+ "properties" -> case (arg, value) of+ (Object props, Object obj) -> concat [recur (path <> "." <> Key.toString k) child v | (k, child) <- KM.toList props, Just v <- [KM.lookup k obj]]+ _ -> []+ "required" -> case (arg, value) of+ (Array names, Object obj) -> [path <> ": missing required property " <> Text.unpack name | String name <- toList names, not (KM.member (Key.fromText name) obj)]+ _ -> []+ "additionalProperties" -> case value of+ Object obj ->+ let declared = map fst (entries (at ["properties"] (Object s)))+ in concat [recur (path <> "." <> Text.unpack k) arg v | (k, v) <- entries (Object obj), k `notElem` declared]+ _ -> []+ "items" -> case value of+ Array xs -> concat [recur (path <> "[" <> show i <> "]") arg v | (i, v) <- zip [0 :: Int ..] (toList xs)]+ _ -> []+ "minItems" -> case (arg, value) of (Number n, Array xs) -> count (fromIntegral (length xs) < n) "too few items"; _ -> []+ "maxItems" -> case (arg, value) of (Number n, Array xs) -> count (fromIntegral (length xs) > n) "too many items"; _ -> []+ "minProperties" -> case (arg, value) of (Number n, Object o) -> count (fromIntegral (KM.size o) < n) "too few properties"; _ -> []+ "maxProperties" -> case (arg, value) of (Number n, Object o) -> count (fromIntegral (KM.size o) > n) "too many properties"; _ -> []+ "anyOf" -> case arg of+ Array alts -> count (not (any (null . (\alt -> recur path alt value)) (toList alts))) "no anyOf alternative matches"+ _ -> err "malformed anyOf"+ "oneOf" -> case arg of+ Array alts -> count (length (filter (null . (\alt -> recur path alt value)) (toList alts)) /= 1) "expected exactly one oneOf alternative"+ _ -> err "malformed oneOf"+ annotation | annotation `elem` ["title", "description", "examples", "default", "discriminator", "x-accepts", "contentMediaType", "contentSchema"] -> []+ other -> err ("unsupported JSON Schema keyword " <> show other)+ 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
+ test/TypeSafe/Conformance/OperationsTest.hs view
@@ -0,0 +1,80 @@+module TypeSafe.Conformance.OperationsTest (tests) where++import Control.Exception (throwIO)+import Control.Monad (forM_)+import Data.Aeson+import Data.Aeson.Types (parseEither)+import Data.ByteString.Builder (toLazyByteString)+import Data.ByteString.Lazy qualified as LBS+import Data.Foldable (toList)+import Data.IORef+import Data.List (sort)+import Data.Sequence qualified as Seq+import Data.String (fromString)+import Data.Text qualified as Text+import Data.Text.Encoding qualified as Text+import Network.HTTP.Types+import Servant.Client.Core+import Servant.Client.Generic (genericClient)+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Conformance.JsonSchema+import TypeSafe.V1 (Routes (..))+import TypeSafe.Wire++newtype Capture a = Capture (IORef [Request] -> LBS.ByteString -> IO a)++runCapture :: Capture a -> IORef [Request] -> LBS.ByteString -> IO a+runCapture (Capture action) = action++instance Functor Capture where+ fmap f (Capture action) = Capture $ \ref body -> f <$> action ref body++instance Applicative Capture where+ pure x = Capture $ \_ _ -> pure x+ Capture f <*> Capture x = Capture $ \ref body -> f ref body <*> x ref body++instance Monad Capture where+ Capture action >>= f = Capture $ \ref body -> action ref body >>= \x -> runCapture (f x) ref body++instance RunClient Capture where+ runRequestAcceptStatus _ request = Capture $ \ref body -> do+ modifyIORef' ref (request :)+ pure Response {responseStatusCode = status200, responseHeaders = Seq.singleton (hContentType, "application/json"), responseHttpVersion = http11, responseBody = body}+ throwClientError err = Capture $ \_ _ -> throwIO err++tests :: Spec -> TestTree+tests spec = testCase "every operation is bound with declared security, headers and JSON" $ do+ ref <- newIORef []+ let routes = genericClient @Routes @Capture+ requests = [v | ("POST", "/v1/systemone", "request", "noul", v) <- operationExamples spec]+ replies = [v | ("POST", "/v1/systemone", "200", "noul", v) <- operationExamples spec]+ requestValue <- case requests of [v] -> pure v; _ -> fail "missing noul request example"+ replyValue <- case replies of [v] -> pure v; _ -> fail "missing noul response example"+ request <- either fail pure (parseEither parseJSON requestValue)+ response <- runCapture (routes.systemOne "Bearer test-token" (Just "true") (Just "true") request) ref (encode replyValue)+ toJSON response @?= replyValue+ let models = ModelMetadataList mempty+ validate spec (schemaRef "ModelMetadataList") (toJSON models) @?= []+ runCapture (routes.models "Bearer test-token") ref (encode models) >>= (@?= models)+ captured <- readIORef ref+ let operation r = (Text.decodeUtf8 (requestMethod r), Text.decodeUtf8 (LBS.toStrict (toLazyByteString (requestPath r))))+ sort (map operation captured) @?= sort (specOperations spec)+ forM_ captured $ \r -> do+ let (method, path) = operation r+ params = [(name, location, schema) | (m, p, name, location, schema) <- operationParameters spec, m == method, p == path]+ headers = toList (requestHeaders r)+ names = [name | (name, _, _) <- params]+ lookup hAuthorization headers @?= Just "Bearer test-token"+ sort [h | (h, _) <- headers, h `notElem` [hAuthorization, hAccept]] @?= sort [fromString (Text.unpack name) | name <- names]+ [security | (m, p, security) <- operationSecurity spec, m == method, p == path] @?= [toJSON [object ["HTTPBearer" .= ([] :: [Value])]]]+ forM_ params $ \(name, location, schema) -> do+ location @?= "header"+ value <- maybe (fail ("missing header " <> Text.unpack name)) pure (lookup (fromString (Text.unpack name)) headers)+ validate spec schema (String (Text.decodeUtf8 value)) @?= []+ case requestBody r of+ Nothing -> method @?= "GET"+ Just (RequestBodyLBS bytes, media) -> do+ media @?= "application/json;charset=utf-8"+ eitherDecode @Value bytes @?= Right requestValue+ Just _ -> assertFailure "unexpected request body representation"
+ test/TypeSafe/Conformance/SchemaTest.hs view
@@ -0,0 +1,202 @@+{-# LANGUAGE ExistentialQuantification #-}++module TypeSafe.Conformance.SchemaTest (tests, excludedContentTypes, setAt) where++import Control.Monad (forM_)+import Data.Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types (parseEither)+import Data.Either (isLeft)+import Data.List (nub, sort)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Proxy (Proxy (..))+import Data.Set qualified as Set+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Test.QuickCheck (Arbitrary, Gen, arbitrary, forAll, generate, vectorOf)+import Test.Tasty+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck (counterexample, testProperty, (===))+import TypeSafe.Conformance.JsonSchema+import TypeSafe.Test.Arbitrary+import TypeSafe.Wire++data Binding+ = forall a.+ (Arbitrary a, ToJSON a, FromJSON a, Eq a, Show a) =>+ Binding Text (Proxy a) RoundTrip [FieldBinding a]++data RoundTrip = ExactRoundTrip | JsonRoundTrip++data FieldBinding a = FieldBinding Text (a -> Maybe Value)++bindings :: [Binding]+bindings =+ [ Binding "SystemOneRequest" (Proxy @SystemOneRequest) JsonRoundTrip [FieldBinding "model" (\r -> Just (toJSON r.model)), FieldBinding "state" (\r -> Just (toJSON r.state)), FieldBinding "questions" (\r -> Just (object [Key.fromText n .= q | (QuestionName n, q) <- V.toList r.questions])), FieldBinding "assets" (\r -> if Map.null r.assets then Nothing else Just (toJSON r.assets))],+ Binding "Question" (Proxy @Question) JsonRoundTrip [],+ Binding "NoulQuestion" (Proxy @NoulQuestion) ExactRoundTrip [FieldBinding "instructions" (\r -> toJSON <$> r.instructions), FieldBinding "criteria" (\r -> toJSON <$> r.criteria)],+ Binding "NoulCriteria" (Proxy @NoulCriteria) ExactRoundTrip [FieldBinding "true" (\r -> toJSON <$> r.true), FieldBinding "false" (\r -> toJSON <$> r.false)],+ Binding "ChoiceQuestion" (Proxy @ChoiceQuestion) JsonRoundTrip [FieldBinding "instructions" (\r -> toJSON <$> r.instructions), FieldBinding "criteria" (\r -> Just (object [Key.fromText k .= v | (k, v) <- V.toList r.criteria]))],+ Binding "ScoreQuestion" (Proxy @ScoreQuestion) ExactRoundTrip [FieldBinding "instructions" (\r -> toJSON <$> r.instructions), FieldBinding "criteria" (\r -> Just (toJSON r.criteria))],+ Binding "BoxQuestion" (Proxy @BoxQuestion) ExactRoundTrip [FieldBinding "instructions" (\r -> toJSON <$> r.instructions)],+ Binding "Asset" (Proxy @Asset) ExactRoundTrip [FieldBinding "format" (\r -> toJSON <$> r.format), FieldBinding "data_base64" (\r -> toJSON <$> r.dataBase64), FieldBinding "part" (\r -> toJSON <$> r.part)],+ Binding "SystemOneResponse" (Proxy @SystemOneResponse) ExactRoundTrip [FieldBinding "model" (\r -> Just (toJSON r.model)), FieldBinding "answers" (\r -> Just (toJSON r.answers)), FieldBinding "usage" (\r -> Just (toJSON r.usage))],+ Binding "Answer" (Proxy @Answer) ExactRoundTrip [],+ Binding "NoulAnswer" (Proxy @NoulAnswer) ExactRoundTrip [FieldBinding "noul" (\r -> Just (toJSON r.noul))],+ Binding "ChoiceAnswer" (Proxy @ChoiceAnswer) ExactRoundTrip [FieldBinding "choice" (\r -> Just (toJSON r.choice)), FieldBinding "confidence" (\r -> Just (toJSON r.confidence)), FieldBinding "probabilities" (\r -> Just (toJSON r.probabilities))],+ Binding "ScoreAnswer" (Proxy @ScoreAnswer) ExactRoundTrip [FieldBinding "score" (\r -> Just (toJSON r.score)), FieldBinding "confidence" (\r -> Just (toJSON r.confidence)), FieldBinding "legend" (\r -> Just (toJSON r.legend)), FieldBinding "probabilities" (\r -> Just (toJSON r.probabilities))],+ Binding "BoxAnswer" (Proxy @BoxAnswer) ExactRoundTrip [FieldBinding "box" (\r -> Just (toJSON r.box)), FieldBinding "confidence" (\r -> Just (toJSON r.confidence))],+ Binding "BoxCoordinates" (Proxy @BoxCoordinates) ExactRoundTrip [FieldBinding "top" (\r -> Just (toJSON r.top)), FieldBinding "bottom" (\r -> Just (toJSON r.bottom)), FieldBinding "left" (\r -> Just (toJSON r.left)), FieldBinding "right" (\r -> Just (toJSON r.right))],+ Binding "Usage" (Proxy @Usage) ExactRoundTrip [FieldBinding "input_tokens" (\r -> Just (toJSON r.inputTokens)), FieldBinding "output_tokens" (\r -> Just (toJSON r.outputTokens))],+ Binding "ModelMetadata" (Proxy @ModelMetadata) ExactRoundTrip [FieldBinding "name" (\r -> Just (toJSON r.name)), FieldBinding "description" (\r -> Just (toJSON r.description)), FieldBinding "release_date" (\r -> Just (toJSON r.releaseDate))],+ Binding "ModelMetadataList" (Proxy @ModelMetadataList) ExactRoundTrip [FieldBinding "models" (\r -> Just (toJSON r.models))],+ Binding "HTTPValidationError" (Proxy @HTTPValidationError) ExactRoundTrip [FieldBinding "detail" (\r -> toJSON <$> r.detail)],+ Binding "ValidationError" (Proxy @ValidationError) ExactRoundTrip [FieldBinding "loc" (\r -> Just (toJSON r.loc)), FieldBinding "msg" (\r -> Just (toJSON r.msg)), FieldBinding "type" (\r -> Just (toJSON r.type_)), FieldBinding "input" (\r -> toJSON <$> r.input), FieldBinding "ctx" (\r -> toJSON <$> r.ctx)],+ Binding "HTTPBadRequestError" (Proxy @HTTPBadRequestError) ExactRoundTrip [FieldBinding "detail" (\r -> Just (toJSON r.detail))]+ ]++excludedContentTypes :: [(Text, Text, Text, Text)]+-- Remove this exclusion when docs/plans/7-send-images-with-multipart-system-one-requests.md is accepted.+excludedContentTypes = [("POST", "/v1/systemone", "request", "multipart/form-data")]++contentErrors :: Spec -> [(Text, Text, Text, Text)]+contentErrors spec =+ [entry | entry@(_, _, _, ct) <- operationContentTypes spec, ct /= "application/json", entry `notElem` excludedContentTypes]+ <> [entry | entry <- excludedContentTypes, entry `notElem` operationContentTypes spec]++setAt :: [Text] -> Value -> Value -> Value+setAt [] replacement _ = replacement+setAt (k : ks) replacement (Object o) = Object (KM.insert (Key.fromText k) (setAt ks replacement (maybe (Object KM.empty) id (KM.lookup (Key.fromText k) o))) o)+setAt path replacement _ = setAt path replacement (Object KM.empty)++tests :: Spec -> TestTree+tests spec@(Spec root) =+ testGroup "OpenAPI conformance" $+ [ testCase "every schema is bound" $ sort [name | Binding name _ _ _ <- bindings] @?= sort (specSchemaNames spec),+ testCase "the schema validator understands every keyword in use" $ unsupportedKeywords spec @?= [],+ testCase "every OpenAPI field in use is understood" $ unsupportedOpenApiFields spec @?= [],+ testCase "every content type is bound or explicitly excluded" $ contentErrors spec @?= [],+ testCase "unknown keyword meta-test" $ do+ let mutant = specFromValue (setAt ["components", "schemas", "Usage", "properties", "input_tokens", "pattern"] (String "^a") root)+ unsupportedKeywords mutant @?= ["pattern"]+ assertBool "validator rejects unknown keyword" (not (null (validate mutant (schemaRef "Usage") (toJSON (Usage 1 2))))),+ testCase "unknown OpenAPI feature meta-test" $ do+ let mutant = specFromValue (setAt ["paths", "/v1/systemone", "post", "callbacks"] (object []) root)+ assertBool "callbacks reported" (any (Text.isInfixOf "callbacks") (unsupportedOpenApiFields mutant)),+ testCase "unknown content type meta-test" $ do+ let mutant = specFromValue (setAt ["paths", "/v1/systemone", "post", "requestBody", "content", "application/x-msgpack"] (object []) root)+ assertBool "content type rejected" (not (null (contentErrors mutant))),+ testCase "validator asserts integer, enum, bounds and required properties" $ do+ validate spec (schemaRef "Usage") (toJSON (Usage 1 2)) @?= []+ let invalid schema value = assertBool (show value) (not (null (validate spec schema value)))+ invalid (schemaRef "Usage") (object ["input_tokens" .= Number 1.5, "output_tokens" .= Number 1])+ invalid (at ["properties", "format"] (maybe Null id (lookupSchema spec "Asset"))) (String "gif")+ invalid (schemaRef "ScoreQuestion") (object ["type" .= String "score", "criteria" .= replicate 11 (String "level")])+ invalid (schemaRef "ChoiceQuestion") (object ["type" .= String "choice", "criteria" .= object []])+ invalid (schemaRef "SystemOneResponse") (object ["model" .= String "m", "usage" .= toJSON (Usage 0 0), "answers" .= object []]),+ testCase "constructors match discriminator mappings" $ do+ sort (map knownQuestionTag questionSamples) @?= sort (map Just (discriminatorTags spec "Question"))+ sort (map knownAnswerTag answerSamples) @?= sort (map Just (discriminatorTags spec "Answer"))+ eitherDecode @Question "{\"type\":\"box\"}" @?= Right (QuestionBox (BoxQuestion Nothing)),+ testProperty "unknown questions preserve their complete encoded object" $ forAll genUnknownQuestion $ \q ->+ fmap toJSON (eitherDecode @Question (encode q)) === Right (toJSON q),+ testProperty "unknown answers preserve their complete encoded object" $ forAll genUnknownAnswer $ \a ->+ fmap toJSON (eitherDecode @Answer (encode a)) === Right (toJSON a),+ testCase "constants match document" $ do+ serverUrls spec @?= [defaultBaseUrl]+ sort (nub [p | (_, p) <- specOperations spec]) @?= sort ["/" <> Text.intercalate "/" systemOnePath, "/" <> Text.intercalate "/" modelsPath]+ sort (nub [n | (_, _, n, _, _) <- operationParameters spec]) @?= ["TypeSafe-Danger-Zone-Images", "TypeSafe-Danger-Zone-Long-Context"]+ ]+ <> map (schemaTests spec) bindings+ <> [exampleTest spec m p w name value | (m, p, w, name, value) <- operationExamples spec]++schemaTests :: Spec -> Binding -> TestTree+schemaTests spec (Binding name (_ :: Proxy a) roundTrip fields) =+ testGroup (Text.unpack name) $+ [ testProperty "encoded values validate" $ \(x :: a) ->+ let errors = validate spec (schemaRef name) (toJSON x) in counterexample (unlines errors) (null errors),+ testProperty "toEncoding agrees with toJSON" $ \(x :: a) -> eitherDecode @Value (encode x) === Right (toJSON x),+ testProperty "decoding inverts encoding" $ \(x :: a) -> case roundTrip of+ ExactRoundTrip -> eitherDecode @a (encode x) === Right x+ JsonRoundTrip -> fmap toJSON (eitherDecode @a (encode x)) === Right (toJSON x)+ ]+ <> if null properties+ then []+ else+ [ testCase "emits exactly the declared properties" $ do+ samples <- generate (vectorOf 500 (arbitrary :: Gen a))+ Set.unions [Set.fromList (map fst (entries (toJSON x))) | x <- samples] @?= Set.fromList properties,+ testCase "requires the required properties and only those" $ do+ samples <- generate (vectorOf 50 (arbitrary :: Gen a))+ forM_ samples $ \x -> case toJSON x of+ Object o -> forM_ (KM.keys o) $ \key ->+ isLeft (parseEither (parseJSON @a) (Object (KM.delete key o))) @?= (Key.toText key `elem` requiredProperties spec name)+ _ -> assertFailure "expected object",+ testCase "property names map to plain Haskell fields" $ do+ let implied = ["type" | name `elem` ["Asset", "NoulQuestion", "ChoiceQuestion", "ScoreQuestion", "BoxQuestion", "NoulAnswer", "ChoiceAnswer", "ScoreAnswer", "BoxAnswer"]]+ sort ([key | FieldBinding key _ <- fields] <> implied) @?= sort properties+ samples <- generate (vectorOf 50 (arbitrary :: Gen a))+ forM_ samples $ \x -> case toJSON x of+ Object o -> forM_ fields $ \(FieldBinding key getter) -> KM.lookup (Key.fromText key) o @?= getter x+ _ -> assertFailure "expected object",+ testCase "property examples validate and assembled objects decode" $ do+ let schema = maybe Null id (lookupSchema spec name)+ examples = propertyExamples spec name+ forM_ examples $ \(key, values) -> forM_ values $ \value -> validate spec (at ["properties", key] schema) value @?= []+ let first = [(Key.fromText key, v) | (key, v : _) <- examples]+ if all (\key -> KM.member (Key.fromText key) (KM.fromList first)) (requiredProperties spec name)+ then do+ let value = Object (KM.fromList first)+ validate spec (schemaRef name) value @?= []+ case parseEither (parseJSON @a) value of+ Left err -> assertFailure err+ Right _ -> pure ()+ else pure ()+ ]+ where+ properties = objectProperties spec name++exampleTest :: Spec -> Text -> Text -> Text -> Text -> Value -> TestTree+exampleTest spec method path where_ name value = testCase (Text.unpack (method <> " " <> path <> " " <> where_ <> " example " <> name)) $ do+ let schemas = [at ["schema"] media | (m, p, w, "application/json", media) <- mediaObjects spec, m == method, p == path, w == where_]+ case schemas of+ [schema] -> do+ validate spec schema value @?= []+ case at ["$ref"] schema of+ String ref | Just schemaName <- Text.stripPrefix "#/components/schemas/" ref -> do+ let matching = [binding | binding@(Binding n _ _ _) <- bindings, n == schemaName]+ case matching of+ [Binding _ (_ :: Proxy a) _ _] -> case parseEither (parseJSON @a) value of+ Left err -> assertFailure err+ Right decoded -> toJSON decoded @?= value+ _ -> assertFailure ("unbound example schema " <> Text.unpack schemaName)+ _ -> assertFailure "example schema must be a component reference"+ _ -> assertFailure "example has no unique media schema"++questionSamples :: [Question]+questionSamples = [QuestionNoul (NoulQuestion Nothing Nothing), QuestionChoice (ChoiceQuestion Nothing (V.singleton ("a", Nothing))), QuestionScore (ScoreQuestion Nothing (ContentText "level" :| [])), QuestionBox (BoxQuestion Nothing)]++answerSamples :: [Answer]+answerSamples = [AnswerNoul (NoulAnswer 0), AnswerChoice (ChoiceAnswer "a" 0 Map.empty), AnswerScore (ScoreAnswer 0 0 Map.empty Map.empty), AnswerBox (BoxAnswer (BoxCoordinates 0 1 0 1) Nothing)]++encodedTag :: (ToJSON a) => a -> Maybe Text+encodedTag value = textValue (at ["type"] (toJSON value))++knownQuestionTag :: Question -> Maybe Text+knownQuestionTag q = case q of+ QuestionNoul a -> encodedTag a+ QuestionChoice a -> encodedTag a+ QuestionScore a -> encodedTag a+ QuestionBox a -> encodedTag a+ QuestionOther _ _ -> Nothing++knownAnswerTag :: Answer -> Maybe Text+knownAnswerTag a = case a of+ AnswerNoul x -> encodedTag x+ AnswerChoice x -> encodedTag x+ AnswerScore x -> encodedTag x+ AnswerBox x -> encodedTag x+ AnswerOther _ _ -> Nothing
+ test/TypeSafe/ReadmeExample.hs view
@@ -0,0 +1,37 @@+-- README:BEGIN+{-# LANGUAGE GHC2024 #-}+{-# LANGUAGE OverloadedRecordDot #-}+{-# LANGUAGE OverloadedStrings #-}++module TypeSafe.ReadmeExample (main, request) where++import Data.ByteString.Lazy.Char8 qualified as LBS+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import System.Environment (lookupEnv)+import TypeSafe.V1+import TypeSafe.Wire++request :: SystemOneRequest+request =+ SystemOneRequest+ { model = jevLatest,+ state = ContentText "Checkout is unavailable.",+ questions =+ Vector.singleton+ ("urgent", QuestionNoul (NoulQuestion (Just (ContentText "Is service blocked?")) Nothing)),+ assets = Map.empty+ }++main :: IO ()+main = do+ LBS.putStrLn (encodeSystemOneRequest request)+ key <- maybe (fail "Set TYPESAFE_API_KEY") (pure . Text.pack) =<< lookupEnv "TYPESAFE_API_KEY"+ env <- getClientEnv defaultBaseUrl+ let methods = makeMethods env key+ response <- methods.createSystemOne request+ print response.answers+ print response.usage.inputTokens++-- README:END
+ test/TypeSafe/ReadmeExampleTest.hs view
@@ -0,0 +1,32 @@+module TypeSafe.ReadmeExampleTest (tests) where++import Data.Text (Text)+import Data.Text qualified as Text+import Data.Text.IO qualified as Text+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.ReadmeExample qualified as Example+import TypeSafe.Wire++tests :: TestTree+tests =+ testGroup+ "README example"+ [ testCase "README code is byte-equal to the compiled example" $ do+ readme <- Text.readFile "README.md"+ source <- Text.readFile "test/TypeSafe/ReadmeExample.hs"+ shown <- either fail pure (between "<!-- README:BEGIN -->\n```haskell\n" "```\n<!-- README:END -->" readme)+ compiled <- either fail pure (between "-- README:BEGIN\n" "-- README:END" source)+ shown @?= compiled,+ testCase "example bytes and record-dot access" $ do+ encodeSystemOneRequest Example.request @?= "{\"model\":\"jev-latest\",\"state\":\"Checkout is unavailable.\",\"questions\":{\"urgent\":{\"type\":\"noul\",\"instructions\":\"Is service blocked?\"}}}"+ response <- either (fail . Text.unpack) pure (decodeSystemOneResponse "{\"model\":\"m\",\"answers\":{\"urgent\":{\"type\":\"noul\",\"noul\":0.83}},\"usage\":{\"input_tokens\":120,\"output_tokens\":3}}")+ response.usage.inputTokens @?= 120+ ]++between :: Text -> Text -> Text -> Either String Text+between start end input = do+ let (_, suffix) = Text.breakOn start input+ rest <- maybe (Left "missing example start marker") Right (Text.stripPrefix start suffix)+ let (body, ending) = Text.breakOn end rest+ if Text.null ending then Left "missing example end marker" else Right body
+ test/TypeSafe/SpecVersionTest.hs view
@@ -0,0 +1,9 @@+module TypeSafe.SpecVersionTest (tests) where++import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Conformance.JsonSchema (Spec, specVersion)+import TypeSafe.Wire++tests :: Spec -> TestTree+tests spec = testCase "apiSpecVersion matches loaded OpenAPI info.version" $ specVersion spec @?= Just apiSpecVersion
+ test/TypeSafe/Test/Arbitrary.hs view
@@ -0,0 +1,122 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Schema-valid generators, separate from unknown-discriminator generators.+module TypeSafe.Test.Arbitrary (genText, genNumber, genUnknownQuestion, genUnknownAnswer) where++import Data.Aeson+import Data.Aeson.Key qualified as Key+import Data.Aeson.KeyMap qualified as KM+import Data.List.NonEmpty qualified as NE+import Data.Map.Strict qualified as Map+import Data.Scientific (Scientific, scientific)+import Data.Text (Text)+import Data.Text qualified as Text+import Data.Vector qualified as V+import Test.QuickCheck+import TypeSafe.Wire++genText :: Gen Text+genText = Text.pack <$> resize 15 (listOf (elements (['a' .. 'z'] <> ['0' .. '9'] <> " _-.`?äöü€日本語🙂\"\\\n\t")))++genNumber :: Gen Scientific+genNumber = frequency [(4, scientific <$> choose (-10000, 10000) <*> choose (-5, 5)), (1, elements [scientific 1 400, scientific (-3) (-500)])]++optional :: Gen a -> Gen (Maybe a)+optional g = frequency [(1, pure Nothing), (2, Just <$> g)]++small :: Gen a -> Gen [a]+small g = chooseInt (0, 3) >>= flip vectorOf g++json :: Int -> Gen Value+json depth =+ oneof $+ [String <$> genText, Number <$> genNumber, Bool <$> arbitrary, pure Null]+ <> if depth <= 0 then [] else [Array . V.fromList <$> small (json (depth - 1)), Object <$> obj (depth - 1)]++obj :: Int -> Gen Object+obj depth = KM.fromList <$> small ((,) <$> (Key.fromText <$> genText) <*> json depth)++instance Arbitrary Content where+ arbitrary = oneof [ContentText <$> genText, ContentObject <$> obj 2, ContentArray . V.fromList <$> small (json 2)]++instance Arbitrary ModelName where arbitrary = ModelName <$> genText++instance Arbitrary QuestionName where arbitrary = QuestionName <$> genText++instance Arbitrary NoulCriteria where arbitrary = NoulCriteria <$> optional arbitrary <*> optional arbitrary++instance Arbitrary NoulQuestion where arbitrary = NoulQuestion <$> optional arbitrary <*> optional arbitrary++instance Arbitrary ChoiceQuestion where+ arbitrary = do+ n <- chooseInt (1, 8)+ -- Fixed distinct labels let shuffled declaration order vary independently.+ keys <- shuffle [Text.pack ("label" <> show i) | i <- [1 .. n]]+ ChoiceQuestion <$> optional arbitrary <*> (V.fromList <$> traverse (\k -> (k,) <$> optional arbitrary) keys)++instance Arbitrary ScoreQuestion where+ arbitrary = ScoreQuestion <$> optional arbitrary <*> (NE.fromList <$> (chooseInt (1, 10) >>= flip vectorOf arbitrary))++instance Arbitrary BoxQuestion where arbitrary = BoxQuestion <$> optional arbitrary++instance Arbitrary ImageFormat where arbitrary = elements [minBound .. maxBound]++instance Arbitrary Asset where arbitrary = Asset <$> optional arbitrary <*> optional genText <*> optional genText++instance Arbitrary Question where+ arbitrary = oneof [QuestionNoul <$> arbitrary, QuestionChoice <$> arbitrary, QuestionScore <$> arbitrary, QuestionBox <$> arbitrary]++instance Arbitrary SystemOneRequest where+ arbitrary = do+ n <- chooseInt (1, 4)+ keys <- shuffle [QuestionName (Text.pack ("question" <> show i)) | i <- [1 .. n]]+ qs <- V.fromList <$> traverse (\k -> (k,) <$> arbitrary) keys+ assets <- frequency [(1, pure Map.empty), (2, Map.fromList <$> traverse (\i -> (Text.pack ("asset" <> show i),) <$> arbitrary) [1 :: Int, 2])]+ SystemOneRequest <$> arbitrary <*> arbitrary <*> pure qs <*> pure assets++instance Arbitrary NoulAnswer where arbitrary = NoulAnswer <$> genNumber++instance Arbitrary ChoiceAnswer where arbitrary = ChoiceAnswer <$> genText <*> genNumber <*> (Map.fromList <$> small ((,) <$> genText <*> genNumber))++instance Arbitrary ScoreAnswer where+ arbitrary = ScoreAnswer <$> genNumber <*> genNumber <*> (Map.fromList <$> small ((,) <$> genText <*> arbitrary)) <*> (Map.fromList <$> small ((,) <$> genText <*> genNumber))++instance Arbitrary BoxCoordinates where arbitrary = BoxCoordinates <$> genNumber <*> genNumber <*> genNumber <*> genNumber++instance Arbitrary BoxAnswer where arbitrary = BoxAnswer <$> arbitrary <*> optional genNumber++instance Arbitrary Answer where+ arbitrary = oneof [AnswerNoul <$> arbitrary, AnswerChoice <$> arbitrary, AnswerScore <$> arbitrary, AnswerBox <$> arbitrary]++instance Arbitrary Usage where+ arbitrary = Usage <$> count <*> count+ where+ count = frequency [(1, pure 0), (1, pure maxBound), (4, chooseInt (0, 100000))]++instance Arbitrary SystemOneResponse where+ arbitrary = do+ n <- chooseInt (1, 4)+ answers <- traverse (\i -> (QuestionName (Text.pack ("q" <> show i)),) <$> arbitrary) [1 .. n]+ SystemOneResponse <$> arbitrary <*> pure (Map.fromList answers) <*> arbitrary++instance Arbitrary ModelMetadata where+ arbitrary = ModelMetadata <$> arbitrary <*> genText <*> elements ["2026-09-15", "2026-01-31"]++instance Arbitrary ModelMetadataList where arbitrary = ModelMetadataList . V.fromList <$> small arbitrary++instance Arbitrary LocationSegment where arbitrary = oneof [LocationField <$> genText, LocationIndex <$> arbitrary]++instance Arbitrary ValidationError where+ arbitrary = ValidationError <$> (V.fromList <$> small arbitrary) <*> genText <*> genText <*> optional genText <*> optional (obj 1)++instance Arbitrary HTTPValidationError where arbitrary = HTTPValidationError <$> optional (V.fromList <$> small arbitrary)++instance Arbitrary BadRequestDetail where arbitrary = oneof [BadRequestDetailText <$> genText, BadRequestDetailObject <$> obj 2]++instance Arbitrary HTTPBadRequestError where arbitrary = HTTPBadRequestError <$> arbitrary++genUnknownQuestion :: Gen Question+genUnknownQuestion = QuestionOther <$> elements ["future", "polygon", "rank"] <*> obj 2++genUnknownAnswer :: Gen Answer+genUnknownAnswer = AnswerOther <$> elements ["future", "polygon", "rank"] <*> obj 2
+ test/TypeSafe/Test/MockServer.hs view
@@ -0,0 +1,59 @@+module TypeSafe.Test.MockServer (Captured (..), Reply (..), withMockServer) where++import Control.Monad.IO.Class (liftIO)+import Data.ByteString (ByteString)+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.IORef+import Data.Proxy (Proxy (..))+import Network.HTTP.Types+import Network.Wai qualified as Wai+import Network.Wai.Handler.Warp (testWithApplication)+import Servant (throwError)+import Servant.Server hiding (respond)+import Servant.Server.Generic (AsServer)+import TypeSafe.V1+import TypeSafe.Wire++data Captured = Captured+ {method :: !ByteString, path :: !ByteString, headers :: ![Header], body :: !LBS.ByteString}++data Reply+ = ReplySuccess SystemOneResponse+ | ReplyError Status [Header] LBS.ByteString+ | ReplyRaw Status [Header] LBS.ByteString++withMockServer :: IORef Reply -> ModelMetadataList -> (Int -> IO (Maybe Captured) -> IO a) -> IO a+withMockServer reply models action = do+ captured <- newIORef Nothing+ let server :: Routes AsServer+ server =+ Routes+ { systemOne = \_ _ _ _ -> do+ current <- liftIO (readIORef reply)+ case current of+ ReplySuccess response -> pure response+ ReplyError status hs bytes ->+ throwError+ ServerError+ { errHTTPCode = statusCode status,+ errReasonPhrase = BS.unpack (statusMessage status),+ errBody = bytes,+ errHeaders = hs+ }+ ReplyRaw _ _ _ -> throwError err500,+ models = \_ -> pure models+ }+ app request respond = do+ bytes <- Wai.strictRequestBody request+ writeIORef captured (Just (Captured (Wai.requestMethod request) (Wai.rawPathInfo request) (Wai.requestHeaders request) bytes))+ current <- readIORef reply+ case current of+ ReplyRaw status hs body -> respond (Wai.responseLBS status hs body)+ _ -> do+ chunks <- newIORef (LBS.toChunks bytes)+ let next = atomicModifyIORef' chunks $ \case+ [] -> ([], mempty)+ x : xs -> (xs, x)+ serve (Proxy @API) server (Wai.setRequestBodyChunks next request) respond+ testWithApplication (pure app) (\port -> action port (readIORef captured))
+ test/TypeSafe/V1Test.hs view
@@ -0,0 +1,104 @@+module TypeSafe.V1Test (tests) where++import Control.Exception (SomeException, try)+import Data.Aeson+import Data.ByteString.Char8 qualified as BS+import Data.ByteString.Lazy qualified as LBS+import Data.Foldable (toList)+import Data.IORef+import Data.Proxy (Proxy (..))+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import GHC.TypeLits (symbolVal)+import Network.HTTP.Types+import Servant.Client qualified as Client+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Test.MockServer+import TypeSafe.V1+import TypeSafe.Wire++modelsFixture :: ModelMetadataList+modelsFixture = ModelMetadataList (Vector.singleton (ModelMetadata "jev-latest" "Test model" "2026-09-15"))++withClient :: (Methods -> IORef Reply -> IO Captured -> IO ()) -> IO ()+withClient action = do+ response <- either fail pure =<< eitherDecodeFileStrict "test/golden/baikai-response.json"+ reply <- newIORef (ReplySuccess response)+ withMockServer reply modelsFixture $ \port readCapture -> do+ env <- getClientEnv (Text.pack ("http://127.0.0.1:" <> show port))+ let capture = readCapture >>= maybe (fail "no request captured") pure+ action (makeMethods env "test-key") reply capture++requestFixture :: IO SystemOneRequest+requestFixture = either fail pure =<< eitherDecodeFileStrict "test/golden/baikai-request.json"++tests :: TestTree+tests =+ testGroup+ "TypeSafe.V1"+ [ testCase "loopback bytes, bearer token and response" $ withClient $ \methods _ capture -> do+ request <- requestFixture+ expected <- either fail pure =<< eitherDecodeFileStrict "test/golden/baikai-response.json"+ methods.createSystemOne request >>= (@?= expected)+ seen <- capture+ seen.method @?= "POST"+ seen.path @?= "/v1/systemone"+ seen.body @?= encodeSystemOneRequest request+ lookup hAuthorization seen.headers @?= Just "Bearer test-key"+ assertBool "JSON content type" (maybe False (BS.isPrefixOf "application/json") (lookup hContentType seen.headers))+ lookup dangerZoneImagesHeader seen.headers @?= Nothing+ lookup dangerZoneLongContextHeader seen.headers @?= Nothing,+ testCase "FailureResponse preserves status, headers and exact body" $ withClient $ \methods reply _ -> do+ bytes <- LBS.readFile "test/golden/validation-error-422.json"+ writeIORef reply (ReplyError status422 [(hContentType, "application/json"), (requestIdHeader, "req_test")] bytes)+ request <- requestFixture+ result <- try @ClientError (methods.createSystemOne request)+ case result of+ Left (FailureResponse _ response) -> do+ Client.responseStatusCode response @?= status422+ lookup requestIdHeader (toList (Client.responseHeaders response)) @?= Just "req_test"+ Client.responseBody response @?= bytes+ case parseErrorBody (Client.responseBody response) of+ ErrorBodyValidation body -> case body.detail of+ Just entries -> (Vector.head entries).msg @?= "Field required"+ Nothing -> assertFailure "detail missing"+ other -> assertFailure (show other)+ other -> assertFailure (show other),+ testCase "danger-zone flags emit only requested headers" $ withClient $ \methods _ capture -> do+ request <- requestFixture+ _ <- methods.createSystemOneWith (DangerZone True False) request+ first <- capture+ lookup dangerZoneImagesHeader first.headers @?= Just "true"+ lookup dangerZoneLongContextHeader first.headers @?= Nothing+ _ <- methods.createSystemOneWith (DangerZone False True) request+ second <- capture+ lookup dangerZoneImagesHeader second.headers @?= Nothing+ lookup dangerZoneLongContextHeader second.headers @?= Just "true",+ testCase "listModels route" $ withClient $ \methods _ capture -> do+ methods.listModels >>= (@?= modelsFixture)+ seen <- capture+ seen.method @?= "GET"+ seen.path @?= "/v1/models"+ lookup hAuthorization seen.headers @?= Just "Bearer test-key",+ testCase "getClientEnv parses default URL" $ do+ env <- getClientEnv defaultBaseUrl+ Client.baseUrl env @?= Client.BaseUrl Client.Https "api.typesafe.ai" 443 "",+ testCase "getClientEnv rejects malformed URL" $ do+ result <- try @SomeException (getClientEnv "not a url")+ case result of+ Left _ -> pure ()+ Right _ -> assertFailure "invalid URL accepted",+ testCase "invalid successful response stays DecodeFailure" $ withClient $ \methods reply _ -> do+ writeIORef reply (ReplyRaw status200 [(hContentType, "application/json")] "{\"model\":\"m\",\"answers\":{}}")+ request <- requestFixture+ result <- try @ClientError (methods.createSystemOne request)+ case result of+ Left (DecodeFailure _ _) -> pure ()+ other -> assertFailure (show other),+ testCase "type-level header names match constants" $ do+ (BS.pack (symbolVal (Proxy @"TypeSafe-Danger-Zone-Images"))) @?= "TypeSafe-Danger-Zone-Images"+ (BS.pack (symbolVal (Proxy @"TypeSafe-Danger-Zone-Long-Context"))) @?= "TypeSafe-Danger-Zone-Long-Context"+ dangerZoneImagesHeader @?= "TypeSafe-Danger-Zone-Images"+ dangerZoneLongContextHeader @?= "TypeSafe-Danger-Zone-Long-Context"+ ]
+ test/TypeSafe/Wire/CommonTest.hs view
@@ -0,0 +1,46 @@+module TypeSafe.Wire.CommonTest (tests) where++import Data.Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Vector qualified as Vector+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Wire++tests :: TestTree+tests =+ testGroup "TypeSafe.Wire.Common" $+ [ testCase "string" $ decode @Content "\"hi\"" @?= Just (ContentText "hi"),+ testCase "object" $ decode @Content "{}" @?= Just (ContentObject KeyMap.empty),+ testCase "array" $ decode @Content "[]" @?= Just (ContentArray Vector.empty),+ testCase "name newtypes" $ do+ encode (ModelName "jev-latest") @?= "\"jev-latest\""+ encode ("x" :: QuestionName) @?= "\"x\"",+ testCase "constants" $ do+ jevLatest @?= "jev-latest"+ jevPreview @?= "jev-preview"+ requestIdHeader @?= "x-typesafe-request-id"+ dangerZoneImagesHeader @?= "TypeSafe-Danger-Zone-Images"+ dangerZoneLongContextHeader @?= "TypeSafe-Danger-Zone-Long-Context"+ systemOnePath @?= ["v1", "systemone"]+ modelsPath @?= ["v1", "models"]+ defaultBaseUrl @?= "https://api.typesafe.ai",+ testCase "nested objects encode in stable sorted order" $ do+ let bytes =+ """+ {"b":1,"a":{"d":2,"c":3}}+ """+ c <- either fail pure (eitherDecode @Content bytes)+ encode c @?= "{\"a\":{\"c\":3,\"d\":2},\"b\":1}"+ ]+ <> [ testCase ("reject " <> show v) $ do+ contentFromValue v @?= Nothing+ decode @Content (encode v) @?= Nothing+ | v <- [Number 1, Bool True, Null]+ ]+ <> [ testCase ("preserve " <> show v) $ do+ contentToValue <$> contentFromValue v @?= Just v+ c <- maybe (fail "bad content") pure (contentFromValue v)+ encode c @?= encode v+ | v <- [String "hi", object ["a" .= object ["b" .= (1 :: Int)]], toJSON ([1, 2] :: [Int])]+ ]
+ test/TypeSafe/Wire/RequestTest.hs view
@@ -0,0 +1,121 @@+module TypeSafe.Wire.RequestTest (tests, fixture) where++import Data.Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither)+import Data.ByteString.Char8 qualified as Strict+import Data.ByteString.Lazy qualified as LBS+import Data.ByteString.Lazy.Char8 qualified as B+import Data.Either (isLeft)+import Data.List.NonEmpty (NonEmpty (..))+import Data.Map.Strict qualified as Map+import Data.Text qualified as Text+import Data.Vector qualified as Vector+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Wire++fixture :: SystemOneRequest+fixture =+ SystemOneRequest+ jevLatest+ (ContentObject (KeyMap.singleton "ticket" (String "Checkout is unavailable.")))+ ( Vector.fromList+ [ ("urgent", QuestionNoul (NoulQuestion (Just (ContentText "Is service blocked?")) Nothing)),+ ( "category",+ QuestionChoice+ ( ChoiceQuestion+ (Just (ContentText "Classify the issue."))+ (Vector.fromList [("billing", Just (ContentText "Payment issue")), ("technical", Just (ContentText "Product malfunction"))])+ )+ ),+ ( "severity",+ QuestionScore+ ( ScoreQuestion+ (Just (ContentText "Rate impact."))+ (ContentText "Minor" :| [ContentText "Disruptive", ContentText "Blocking"])+ )+ )+ ]+ )+ Map.empty++tests :: TestTree+tests =+ testGroup+ "TypeSafe.Wire.Request"+ [ testCase "structural golden R11" $ do+ expected <- either fail pure =<< eitherDecodeFileStrict @Value "test/golden/baikai-request.json"+ eitherDecode @Value (encodeSystemOneRequest fixture) @?= Right expected,+ testCase "exact bytes golden R3" $ do+ expected <- LBS.readFile "test/golden/baikai-request.bytes"+ encodeSystemOneRequest fixture @?= expected,+ testCase "encode and deterministic helper agree" $ do+ encode fixture @?= encodeSystemOneRequest fixture+ encodeSystemOneRequest fixture @?= encodeSystemOneRequest fixture,+ testCase "declared question and choice order" $ do+ let q = QuestionChoice (ChoiceQuestion Nothing (Vector.fromList [("technical", Nothing), ("billing", Nothing)]))+ r = SystemOneRequest "m" (ContentText "s") (Vector.fromList [("z", q), ("a", q), ("m", q)]) Map.empty+ encode r @?= "{\"model\":\"m\",\"state\":\"s\",\"questions\":{\"z\":{\"type\":\"choice\",\"criteria\":{\"technical\":null,\"billing\":null}},\"a\":{\"type\":\"choice\",\"criteria\":{\"technical\":null,\"billing\":null}},\"m\":{\"type\":\"choice\",\"criteria\":{\"technical\":null,\"billing\":null}}}}",+ testCase "optional fields and nullable values" $ do+ encode (NoulQuestion Nothing Nothing) @?= "{\"type\":\"noul\"}"+ encode (NoulCriteria (Just (ContentText "y")) Nothing) @?= "{\"true\":\"y\"}"+ eitherDecode @NoulQuestion "{\"type\":\"noul\",\"instructions\":null}" @?= Right (NoulQuestion Nothing Nothing),+ testCase "unknown tag preserves complete object" $ do+ let v = object ["type" .= ("future" :: Text.Text), "x" .= ([1, 2] :: [Int])]+ q <- either fail pure (parseEither parseJSON v :: Either String Question)+ case q of+ QuestionOther tag obj -> do+ tag @?= "future"+ Object obj @?= v+ toJSON q @?= v+ eitherDecode @Value (encode q) @?= Right v+ _ -> assertFailure "unknown question was coerced",+ testCase "content remains structured and scalar state fails" $ do+ let r = SystemOneRequest "m" (ContentArray Vector.empty) Vector.empty Map.empty+ eitherDecode @Value (encode r) @?= Right (toJSON r)+ assertBool "array, not string" (Strict.isInfixOf "\"state\":[]" (LBS.toStrict (encode r)))+ mapM_+ (\v -> assertBool "scalar rejected" (isLeft (eitherDecode @SystemOneRequest v)))+ ["{\"model\":\"m\",\"state\":42,\"questions\":{}}", "{\"model\":\"m\",\"state\":null,\"questions\":{}}"],+ testCase "assets absent or nonempty" $ do+ assertBool "empty omitted" (not (Strict.isInfixOf "\"assets\"" (LBS.toStrict (encode fixture))))+ r <- either fail pure (eitherDecode @SystemOneRequest (encode fixture))+ r.assets @?= Map.empty+ let a = Asset (Just ImageFormatPng) (Just "AA==") Nothing+ withAsset = SystemOneRequest fixture.model fixture.state fixture.questions (Map.singleton "photo" a)+ assertBool "inline asset" (Strict.isInfixOf "\"assets\":{\"photo\":{\"type\":\"image\",\"format\":\"png\",\"data_base64\":\"AA==\"}}" (LBS.toStrict (encode withAsset)))+ eitherDecode @Asset (encode a) @?= Right a,+ testCase "published request examples decode" $ do+ spec <- either fail pure =<< eitherDecodeFileStrict @Value "spec/openapi.json"+ examples <-+ either fail pure $+ parseEither+ ( withObject "spec" $ \o -> do+ paths <- o .: "paths"+ post <- (paths .: "/v1/systemone") >>= (.: "post")+ body <- post .: "requestBody"+ content <- body .: "content"+ json <- content .: "application/json"+ json .: "examples"+ )+ spec+ mapM_+ ( \(name, example) -> do+ value <- either fail pure $ parseEither (withObject "example" (.: "value")) example+ q <- either fail pure (parseEither parseJSON value :: Either String SystemOneRequest)+ assertBool (show name) (not (Vector.null q.questions))+ )+ (KeyMap.toList examples),+ testCase "duplicates are reported without collapsing bytes" $ do+ let q = QuestionBox (BoxQuestion Nothing)+ r = SystemOneRequest "m" (ContentText "s") (Vector.fromList [("a", q), ("b", q), ("a", q), ("a", q), ("b", q)]) Map.empty+ duplicateQuestionNames r @?= ["a", "b"]+ length (Text.breakOnAll "\"a\":" (Text.pack (B.unpack (encode r)))) @?= 3+ duplicateChoiceLabels (ChoiceQuestion Nothing (Vector.fromList [("billing", Nothing), ("billing", Nothing)])) @?= ["billing"],+ testCase "required fields and malformed known tags fail" $ do+ assertBool "choice criteria required" (isLeft (eitherDecode @ChoiceQuestion "{\"type\":\"choice\"}"))+ assertBool "nonempty score" (isLeft (eitherDecode @ScoreQuestion "{\"type\":\"score\",\"criteria\":[]}"))+ assertBool "state required" (isLeft (eitherDecode @SystemOneRequest "{\"model\":\"m\",\"questions\":{}}"))+ assertBool "known malformed is not Other" (isLeft (eitherDecode @Question "{\"type\":\"choice\"}"))+ ]
+ test/TypeSafe/Wire/ResponseTest.hs view
@@ -0,0 +1,149 @@+module TypeSafe.Wire.ResponseTest (tests, fixture) where++import Data.Aeson+import Data.Aeson.KeyMap qualified as KeyMap+import Data.Aeson.Types (parseEither)+import Data.ByteString.Lazy qualified as LBS+import Data.Either (isLeft)+import Data.Map.Strict qualified as Map+import Data.Scientific (scientific)+import Data.Time.Calendar (fromGregorian)+import Data.Vector qualified as Vector+import Test.Tasty+import Test.Tasty.HUnit+import TypeSafe.Wire++fixture :: SystemOneResponse+fixture =+ SystemOneResponse+ "jev-fixture-version"+ ( Map.fromList+ [ ("urgent", AnswerNoul (NoulAnswer 0.83)),+ ("category", AnswerChoice (ChoiceAnswer "technical" 0.65 (Map.fromList [("billing", 0.2), ("technical", 0.7)]))),+ ( "severity",+ AnswerScore+ ( ScoreAnswer+ 1.5+ 0.55+ (Map.fromList [("0", ContentText "Minor"), ("1", ContentText "Disruptive"), ("2", ContentText "Blocking")])+ (Map.fromList [("0", 0.1), ("1", 0.3), ("2", 0.6)])+ )+ )+ ]+ )+ (Usage 120 3)++tests :: TestTree+tests =+ testGroup+ "Wire.Response"+ [ testGroup+ "success bodies"+ [ testCase "baikai golden decodes to all expected values" $ do+ bytes <- LBS.readFile "test/golden/baikai-response.json"+ decodeSystemOneResponse bytes @?= Right fixture+ fixture.usage.inputTokens @?= 120,+ testCase "negative goldens fail" $+ mapM_+ ( \name -> do+ bytes <- LBS.readFile ("test/golden/baikai-response-missing-" <> name <> ".json")+ assertBool name (isLeft (decodeSystemOneResponse bytes))+ )+ ["confidence", "score"],+ testCase "huge numbers survive without semantic validation" $ do+ eitherDecode @NoulAnswer "{\"type\":\"noul\",\"noul\":1e400}" @?= Right (NoulAnswer (scientific 1 400))+ assertBool "overflow" (isLeft (finiteDouble (scientific 1 400)))+ assertBool "unit interval" (isLeft (unitInterval 1.5))+ unitInterval 0.5 @?= Right 0.5+ eitherDecode @ChoiceAnswer "{\"type\":\"choice\",\"choice\":\"x\",\"confidence\":1.5,\"probabilities\":{}}" @?= Right (ChoiceAnswer "x" 1.5 Map.empty),+ testCase "token counts are bounded integral Ints" $ do+ assertBool "fraction" (isLeft (eitherDecode @Usage "{\"input_tokens\":3.5,\"output_tokens\":1}"))+ assertBool "range" (isLeft (eitherDecode @Usage "{\"input_tokens\":1e30,\"output_tokens\":1}"))+ eitherDecode @Usage "{\"input_tokens\":1.2e3,\"output_tokens\":0}" @?= Right (Usage 1200 0),+ testCase "unknown answers retain their complete object" $ do+ let v = object ["type" .= String "polygon", "points" .= ([1, 2] :: [Int])]+ a <- either fail pure (parseEither parseJSON v :: Either String Answer)+ case a of+ AnswerOther tag o -> do+ tag @?= "polygon"+ Object o @?= v+ _ -> assertFailure "unknown answer coerced"+ toJSON a @?= v+ eitherDecode @Value (encode a) @?= Right v,+ testCase "required fields of each success object" $ do+ missing fixture ["model", "answers", "usage"]+ missing (ChoiceAnswer "x" 0.2 Map.empty) ["type", "choice", "confidence", "probabilities"]+ missing (ScoreAnswer 1 0.2 Map.empty Map.empty) ["type", "score", "confidence", "legend", "probabilities"]+ missing (Usage 1 2) ["input_tokens", "output_tokens"]+ missing (BoxAnswer (BoxCoordinates 0 1 0 1) Nothing) ["type", "box", "confidence"]+ assertBool "bad tag" (isLeft (eitherDecode @Answer "{\"type\":7}")),+ testCase "extra fields ignored and nullable confidence retained" $ do+ eitherDecode @NoulAnswer "{\"type\":\"noul\",\"noul\":2,\"rationale\":\"x\"}" @?= Right (NoulAnswer 2)+ let box = BoxAnswer (BoxCoordinates 0 1 0 1) Nothing+ eitherDecode @BoxAnswer (encode box) @?= Right box+ eitherDecode @SystemOneResponse (encode fixture) @?= Right fixture+ eitherDecode @Value (encode fixture) @?= Right (toJSON fixture)+ ],+ testGroup+ "model listing"+ [ testCase "listing decodes, ignores tags and parses day" $ do+ m <- either fail pure (eitherDecode @ModelMetadataList "{\"models\":[{\"name\":\"jev-latest\",\"description\":\"General\",\"release_date\":\"2026-09-15\",\"tags\":[\"default\"]}]}")+ releaseDay (Vector.head m.models) @?= Just (fromGregorian 2026 9 15)+ eitherDecode @ModelMetadataList (encode m) @?= Right m,+ testCase "required metadata fields and verbatim unusual date" $ do+ missing (ModelMetadata "m" "d" "soon") ["name", "description", "release_date"]+ missing (ModelMetadataList Vector.empty) ["models"]+ releaseDay (ModelMetadata "m" "d" "soon") @?= Nothing+ releaseDay (ModelMetadata "m" "d" "2026-13-01") @?= Nothing+ ],+ testGroup+ "error bodies"+ [ testCase "validation detail with bounded location index and string preview" $ do+ let v = ValidationError (Vector.fromList [LocationField "body", LocationIndex 0]) "required" "missing" (Just "null") (Just (KeyMap.singleton "min_length" (Number 1)))+ body = HTTPValidationError (Just (Vector.singleton v))+ parseErrorBody (encode body) @?= ErrorBodyValidation body+ eitherDecode @ValidationError (encode v) @?= Right v+ eitherDecode @HTTPValidationError "{}" @?= Right (HTTPValidationError Nothing),+ testCase "current HTTPBadRequestError union" $ do+ eitherDecode @HTTPBadRequestError "{\"detail\":\"bad request\"}" @?= Right (HTTPBadRequestError (BadRequestDetailText "bad request"))+ let b = HTTPBadRequestError (BadRequestDetailObject (KeyMap.singleton "message" (String "x")))+ eitherDecode @HTTPBadRequestError (encode b) @?= Right b+ missing b ["detail"]+ assertBool "null rejected" (isLeft (eitherDecode @HTTPBadRequestError "{\"detail\":null}")),+ testCase "structured and text detail" $ do+ parseErrorBody "{\"detail\":{\"error_type\":\"api_usage_error\",\"message\":\"Unknown model: x\"}}" @?= ErrorBodyDetail (ErrorDetail (Just "api_usage_error") "Unknown model: x")+ parseErrorBody "{\"detail\":\"fastapi style\"}" @?= ErrorBodyDetailText "fastapi style",+ testCase "unrecognized or malformed JSON stays raw" $+ mapM_+ ( \bytes -> do+ v <- either fail pure (eitherDecode @Value bytes)+ parseErrorBody bytes @?= ErrorBodyJson v+ )+ [ "{}",+ "{\"error\":{\"message\":\"invalid api key\"}}",+ "{\"error\":\"plain string\"}",+ "{\"message\":\"top-level message\"}",+ "{\"code\":7}",+ "{\"detail\":[{\"msg\":\"no loc\"}]}",+ "{\"detail\":[{\"loc\":[1.5],\"msg\":\"m\",\"type\":\"t\"}]}",+ "{\"detail\":[{\"loc\":[1e30],\"msg\":\"m\",\"type\":\"t\"}]}",+ "{\"detail\":[{\"loc\":[],\"msg\":\"m\",\"type\":\"t\",\"input\":null}]}"+ ],+ testCase "text, invalid UTF8 and empty" $ do+ parseErrorBody "<h1>bad gateway</h1>" @?= ErrorBodyText "<h1>bad gateway</h1>"+ parseErrorBody (LBS.pack [255, 254]) @?= ErrorBodyText "\xfffd\xfffd"+ parseErrorBody "" @?= ErrorBodyEmpty+ ]+ ]++missing :: forall a. (ToJSON a, FromJSON a) => a -> [Key] -> Assertion+missing value keys = case toJSON value of+ Object o ->+ mapM_+ ( \key ->+ assertBool+ ("required " <> show key)+ (isLeft (parseEither (parseJSON @a) (Object (KeyMap.delete key o))))+ )+ keys+ _ -> assertFailure "expected object fixture"
+ test/golden/baikai-request.bytes view
@@ -0,0 +1,1 @@+{"model":"jev-latest","state":{"ticket":"Checkout is unavailable."},"questions":{"urgent":{"type":"noul","instructions":"Is service blocked?"},"category":{"type":"choice","instructions":"Classify the issue.","criteria":{"billing":"Payment issue","technical":"Product malfunction"}},"severity":{"type":"score","instructions":"Rate impact.","criteria":["Minor","Disruptive","Blocking"]}}}
+ test/golden/baikai-request.json view
@@ -0,0 +1,9 @@+{+ "model": "jev-latest",+ "state": {"ticket": "Checkout is unavailable."},+ "questions": {+ "urgent": {"type": "noul", "instructions": "Is service blocked?"},+ "category": {"type": "choice", "instructions": "Classify the issue.", "criteria": {"billing": "Payment issue", "technical": "Product malfunction"}},+ "severity": {"type": "score", "instructions": "Rate impact.", "criteria": ["Minor", "Disruptive", "Blocking"]}+ }+}
+ test/golden/baikai-response-missing-confidence.json view
@@ -0,0 +1,36 @@+{+ "answers": {+ "urgent": {+ "type": "noul",+ "noul": 0.83+ },+ "category": {+ "type": "choice",+ "probabilities": {+ "billing": 0.2,+ "technical": 0.7+ },+ "choice": "technical"+ },+ "severity": {+ "type": "score",+ "probabilities": {+ "0": 0.1,+ "1": 0.3,+ "2": 0.6+ },+ "score": 1.5,+ "confidence": 0.55,+ "legend": {+ "0": "Minor",+ "1": "Disruptive",+ "2": "Blocking"+ }+ }+ },+ "usage": {+ "input_tokens": 120,+ "output_tokens": 3+ },+ "model": "jev-fixture-version"+}
+ test/golden/baikai-response-missing-score.json view
@@ -0,0 +1,36 @@+{+ "answers": {+ "urgent": {+ "type": "noul",+ "noul": 0.83+ },+ "category": {+ "type": "choice",+ "probabilities": {+ "billing": 0.2,+ "technical": 0.7+ },+ "choice": "technical",+ "confidence": 0.65+ },+ "severity": {+ "type": "score",+ "probabilities": {+ "0": 0.1,+ "1": 0.3,+ "2": 0.6+ },+ "confidence": 0.55,+ "legend": {+ "0": "Minor",+ "1": "Disruptive",+ "2": "Blocking"+ }+ }+ },+ "usage": {+ "input_tokens": 120,+ "output_tokens": 3+ },+ "model": "jev-fixture-version"+}
+ test/golden/baikai-response.json view
@@ -0,0 +1,9 @@+{+ "answers": {+ "urgent": {"type": "noul", "noul": 0.83},+ "category": {"type": "choice", "probabilities": {"billing": 0.2, "technical": 0.7}, "choice": "technical", "confidence": 0.65},+ "severity": {"type": "score", "probabilities": {"0": 0.1, "1": 0.3, "2": 0.6}, "score": 1.5, "confidence": 0.55, "legend": {"0": "Minor", "1": "Disruptive", "2": "Blocking"}}+ },+ "usage": {"input_tokens": 120, "output_tokens": 3},+ "model": "jev-fixture-version"+}
+ test/golden/validation-error-422.json view
@@ -0,0 +1,1 @@+{"detail":[{"loc":["body","questions","urgency","score","criteria"],"msg":"Field required","type":"missing"}]}
+ typesafe-hs.cabal view
@@ -0,0 +1,120 @@+cabal-version: 3.12+name: typesafe-hs+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+copyright: Copyright (c) 2026 Nadeem Bitar+author: Nadeem Bitar+maintainer: nadeem@gmail.com+homepage: https://github.com/shinzui/typesafe-hs+bug-reports: https://github.com/shinzui/typesafe-hs/issues+description:+ Haskell types, deterministic request encoding and lossless response decoding+ for the TypeSafe System One API, mirroring the vendored OpenAPI 0.2.0+ document, plus servant routes and authenticated client methods. Applications+ own retries, failure classification, credentials, logging and timeout policy.++extra-doc-files:+ CHANGELOG.md+ README.md++synopsis: Wire types and servant client for the TypeSafe System One API+category: AI, Web+build-type: Simple+tested-with: ghc ==9.12.4+extra-source-files:+ scripts/check-spec-drift.sh+ spec/openapi.json+ test/golden/*.bytes+ test/golden/*.json++common common+ default-language: GHC2024+ default-extensions:+ DeriveAnyClass+ DuplicateRecordFields+ NoFieldSelectors+ OverloadedLabels+ OverloadedRecordDot+ OverloadedStrings++ ghc-options: -Wall++library+ import: common+ hs-source-dirs: src+ exposed-modules:+ TypeSafe.V1+ TypeSafe.Wire+ TypeSafe.Wire.Common+ TypeSafe.Wire.Error+ TypeSafe.Wire.Models+ TypeSafe.Wire.Request+ TypeSafe.Wire.Response++ other-modules: TypeSafe.Wire.Internal.Number+ build-depends:+ aeson ^>=2.2,+ base >=4.20 && <5,+ bytestring ^>=0.12,+ containers ^>=0.7,+ http-client-tls >=0.3.5 && <0.5,+ http-types ^>=0.12,+ scientific ^>=0.3,+ servant >=0.20.3 && <0.21,+ servant-client ^>=0.20,+ servant-client-core >=0.20.3 && <0.22,+ text ^>=2.1,+ time ^>=1.14,+ vector ^>=0.13,++test-suite typesafe-hs-test+ import: common+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Main.hs+ other-modules:+ TypeSafe.Conformance.JsonSchema+ TypeSafe.Conformance.OperationsTest+ TypeSafe.Conformance.SchemaTest+ TypeSafe.ReadmeExample+ TypeSafe.ReadmeExampleTest+ TypeSafe.SpecVersionTest+ TypeSafe.Test.Arbitrary+ TypeSafe.Test.MockServer+ TypeSafe.V1Test+ TypeSafe.Wire.CommonTest+ TypeSafe.Wire.RequestTest+ TypeSafe.Wire.ResponseTest++ default-extensions: MultilineStrings+ ghc-options:+ -threaded+ -rtsopts+ -with-rtsopts=-N++ build-depends:+ QuickCheck >=2.14 && <2.19,+ aeson,+ base,+ bytestring ^>=0.12,+ containers,+ http-types,+ scientific,+ servant,+ servant-client,+ servant-client-core,+ servant-server >=0.20 && <0.21,+ tasty >=1.4 && <1.6,+ tasty-hunit ^>=0.10,+ tasty-quickcheck >=0.10 && <0.12,+ text,+ time,+ typesafe-hs,+ vector ^>=0.13,+ wai >=3.2.4 && <3.3,+ warp >=3.3 && <3.5,++source-repository head+ type: git+ location: https://github.com/shinzui/typesafe-hs.git