diff --git a/.github/dependabot.yml b/.github/dependabot.yml new file mode 100644 index 0000000..3a626c3 --- /dev/null +++ b/.github/dependabot.yml @@ -0,0 +1,6 @@ +version: 2 +updates: + - package-ecosystem: github-actions + directory: / + schedule: + interval: monthly diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..aaa4b54 --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,117 @@ +name: CI + +on: + push: + branches: [main] + pull_request: + workflow_dispatch: + +concurrency: + group: ci-${{ github.ref }} + cancel-in-progress: true + +jobs: + build: + name: GHC ${{ matrix.ghc }} on ${{ matrix.os }} + runs-on: ${{ matrix.os }} + strategy: + fail-fast: false + matrix: + os: [ubuntu-latest] + ghc: ["9.6", "9.8", "9.10", "9.12", "9.14"] + include: + - os: macos-latest + ghc: "9.12" + - os: windows-latest + ghc: "9.12" + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: latest + cabal-update: true + + - name: Resolve dependencies + run: cabal build all --dry-run + + - uses: actions/cache@v4 + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: cabal-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-${{ hashFiles('dist-newstyle/cache/plan.json') }} + restore-keys: cabal-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}- + + - name: Build + run: cabal build all + + - name: Test + run: cabal test all --test-show-details=direct + + - name: Documentation + run: cabal haddock typesafe-ai-core typesafe-ai + + doctest: + name: Examples in the documentation + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: "9.12" + cabal-version: latest + cabal-update: true + + - uses: actions/cache@v4 + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: doctest-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-${{ hashFiles('**/*.cabal') }} + restore-keys: doctest-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}- + + - name: Install doctest + run: cabal install doctest --ignore-project --overwrite-policy=always --installdir="$HOME/.local/bin" + + # --with-repl (cabal 3.16 or later) runs doctest in place of GHCi while + # GHC still builds the dependencies. --with-compiler would make cabal + # rebuild the local typesafe-ai-core library with doctest, which fails. + - name: Run doctest + run: | + for package in typesafe-ai-core typesafe-ai; do + cabal repl "$package" --with-repl="$HOME/.local/bin/doctest" --repl-options=-w + done + + hackage: + name: Hackage readiness + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: "9.12" + cabal-version: latest + cabal-update: true + + - name: cabal check + run: | + for package in typesafe-ai-core typesafe-ai; do + (cd "$package" && cabal check) + done + + - name: Build and test from the source distributions + # Catches files missing from extra-source-files, such as the vendored + # OpenAPI specification the conformance tests read. + run: | + cabal sdist typesafe-ai-core typesafe-ai + mkdir "$RUNNER_TEMP/sdist" + for tarball in dist-newstyle/sdist/*.tar.gz; do + tar -xzf "$tarball" -C "$RUNNER_TEMP/sdist" + done + cd "$RUNNER_TEMP/sdist" + printf 'packages: */*.cabal\ntests: True\n' > cabal.project + cabal build all + cabal test all --test-show-details=direct diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml new file mode 100644 index 0000000..90af09e --- /dev/null +++ b/.github/workflows/release.yml @@ -0,0 +1,78 @@ +name: Release + +# Push a tag such as v0.1.0.0 to upload both packages to Hackage as package +# candidates. Review the candidates on Hackage, then run this workflow by hand +# with "publish" checked to publish them. See MAINTAINING.md. + +on: + push: + tags: ["v*"] + workflow_dispatch: + inputs: + publish: + description: Publish the release on Hackage (otherwise upload candidates) + type: boolean + default: false + +permissions: + contents: write + +jobs: + release: + runs-on: ubuntu-latest + environment: hackage + steps: + - uses: actions/checkout@v4 + + - uses: haskell-actions/setup@v2 + id: setup + with: + ghc-version: "9.12" + cabal-version: latest + cabal-update: true + + - name: Check that the tag matches the package versions + if: startsWith(github.ref, 'refs/tags/') + run: | + tag="${GITHUB_REF_NAME#v}" + for package in typesafe-ai-core typesafe-ai; do + version="$(sed -n 's/^version: *//p' "$package/$package.cabal")" + if [ "$version" != "$tag" ]; then + echo "$package is version $version, but the tag is $GITHUB_REF_NAME" >&2 + exit 1 + fi + done + + - name: Build and test + run: | + cabal build all + cabal test all --test-show-details=direct + + - name: Package + run: | + for package in typesafe-ai-core typesafe-ai; do + (cd "$package" && cabal check) + done + cabal sdist typesafe-ai-core typesafe-ai + cabal haddock typesafe-ai-core typesafe-ai --haddock-for-hackage + + - name: Upload to Hackage + env: + HACKAGE_TOKEN: ${{ secrets.HACKAGE_TOKEN }} + PUBLISH: ${{ inputs.publish && '--publish' || '' }} + run: | + # typesafe-ai depends on typesafe-ai-core, so the core goes first. + for package in typesafe-ai-core typesafe-ai; do + cabal upload $PUBLISH --token "$HACKAGE_TOKEN" dist-newstyle/sdist/"$package"-[0-9]*.tar.gz + cabal upload $PUBLISH --documentation --token "$HACKAGE_TOKEN" dist-newstyle/"$package"-[0-9]*-docs.tar.gz + done + + - name: Create the GitHub release + if: inputs.publish + env: + GH_TOKEN: ${{ github.token }} + run: | + version="$(sed -n 's/^version: *//p' typesafe-ai/typesafe-ai.cabal)" + # The notes are the changelog section of this version. + awk -v v="$version" '$0 ~ "^## " v { found = 1; next } found && /^## / { exit } found' typesafe-ai/CHANGELOG.md > "$RUNNER_TEMP/notes.md" + gh release create "v$version" --title "v$version" --notes-file "$RUNNER_TEMP/notes.md" diff --git a/.github/workflows/spec-drift.yml b/.github/workflows/spec-drift.yml new file mode 100644 index 0000000..3593d32 --- /dev/null +++ b/.github/workflows/spec-drift.yml @@ -0,0 +1,87 @@ +name: API specification drift + +# Checks every day whether TypeSafe has published a new version of its OpenAPI +# specification. When it has, this opens (or updates) a pull request that +# replaces the vendored copy, with a summary of the changes and the list of +# conformance tests that fail against it: the to-do list for updating the +# bindings. See MAINTAINING.md. + +on: + schedule: + - cron: "23 5 * * *" + workflow_dispatch: + +permissions: + contents: write + pull-requests: write + +jobs: + drift: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v4 + + - name: Compare with the published specification + id: sync + run: | + if scripts/sync-spec.sh --summary "$RUNNER_TEMP/summary.md"; then + if [ -s "$RUNNER_TEMP/summary.md" ]; then + echo "changed=true" >> "$GITHUB_OUTPUT" + else + echo "changed=false" >> "$GITHUB_OUTPUT" + fi + else + exit 1 + fi + + - uses: haskell-actions/setup@v2 + if: steps.sync.outputs.changed == 'true' + id: setup + with: + ghc-version: "9.12" + cabal-version: latest + cabal-update: true + + - uses: actions/cache@v4 + if: steps.sync.outputs.changed == 'true' + with: + path: ${{ steps.setup.outputs.cabal-store }} + key: drift-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}-${{ hashFiles('**/*.cabal') }} + restore-keys: drift-${{ runner.os }}-ghc-${{ steps.setup.outputs.ghc-version }}- + + - name: Run the conformance tests against the new specification + if: steps.sync.outputs.changed == 'true' + run: | + summary="$RUNNER_TEMP/summary.md" + set +e + cabal test typesafe-ai-core --test-show-details=direct > "$RUNNER_TEMP/tests.log" 2>&1 + status=$? + set -e + { + echo "## Conformance tests" + echo + if [ "$status" -eq 0 ]; then + echo "All tests pass against the new specification. Review the changes above, bump \`apiSpecVersion\` if the version changed, and add typed support for any new features." + else + echo "These tests fail against the new specification. Each one names something the bindings do not cover yet:" + echo + echo '```' + grep -E 'FAIL|expected:|but got:|failed' "$RUNNER_TEMP/tests.log" | head -100 + echo '```' + fi + echo + echo "See MAINTAINING.md for how to update the bindings." + } >> "$summary" + + - uses: peter-evans/create-pull-request@v7 + if: steps.sync.outputs.changed == 'true' + with: + # A token other than GITHUB_TOKEN lets the pull request trigger CI. + token: ${{ secrets.SPEC_SYNC_TOKEN || github.token }} + branch: api-spec-update + delete-branch: true + commit-message: Update the vendored TypeSafe OpenAPI specification + title: Update the vendored TypeSafe OpenAPI specification + body-path: ${{ runner.temp }}/summary.md + labels: api-update + add-paths: typesafe-ai-core/spec/openapi.json diff --git a/MAINTAINING.md b/MAINTAINING.md new file mode 100644 index 0000000..7746edf --- /dev/null +++ b/MAINTAINING.md @@ -0,0 +1,145 @@ +# Maintaining typesafe-sdk + +How to keep the bindings in step with the TypeSafe API and release them to +Hackage. + +## Repository layout + +| Path | Contents | +| --- | --- | +| `typesafe-ai-core/` | Hackage package: types, codecs, calls. No HTTP. | +| `typesafe-ai-core/spec/openapi.json` | The vendored OpenAPI specification, normalised with `jq -S`. | +| `typesafe-ai-core/test/TypeSafe/ConformanceSpec.hs` | The tests that check the bindings against the specification. | +| `typesafe-ai/` | Hackage package: the `http-client` transport. | +| `examples/` | Example programs. Built by CI, not published. | +| `scripts/sync-spec.sh` | Compares the published specification with the vendored copy. | +| `.github/workflows/` | `ci.yml`, `spec-drift.yml` (daily specification check), `release.yml`. | + +## Versioning + +Both packages follow the [PVP](https://pvp.haskell.org) (`A.B.C.D`) and are +always released together with the same version. `typesafe-ai` depends on +`typesafe-ai-core >=A.B.C && `), to both `toJSON` and `toEncoding`, and to `parseJSON` (`.:` if required, `.:?` otherwise). Add it to the generator in `test/TypeSafe/ArbitraryInstances.hs`. Then expose it in the typed layer where it makes sense. | +| makes a property required, or optional | `requires the required properties and only those` | Switch between `.:` and `.:?`, and between `a` and `Maybe a`. | +| changes a property's type | `encoded values validate against the schema` | Change the field's type. | +| adds a schema | `every schema is bound` | Add a type to `TypeSafe.Wire` and a `Binding` to `ConformanceSpec.hs`. | +| adds a question or answer type | `question constructors match the Question discriminator` | Add constructors to `Question` and `Answer`, then a smart constructor and answer type in `TypeSafe.Question`, like `noul`/`Noul`. | +| adds an endpoint | `every operation is bound` | Add a `Call` in `TypeSafe.Call`, and add it to `sdkOperations` in `ConformanceSpec.hs`. | +| uses a new JSON Schema keyword | `the schema validator understands every keyword in use` | Teach `test/TypeSafe/JsonSchema.hs` the keyword. | +| changes `info.version` | `apiSpecVersion matches the vendored specification` | Update `apiSpecVersion`. | + +Then: + +- document new fields and functions with Haddock comments, with a doctest + example where possible; +- add unit tests in `test/TypeSafe/QuestionSpec.hs` for typed behaviour; +- update the changelogs and the version table in `README.md`; +- bump the versions (see above) in both `.cabal` files, and the + `typesafe-ai-core` bound in `typesafe-ai.cabal`. + +## Releasing + +One-time setup: + +1. Create a Hackage account with upload rights for both packages. The first + upload of a package name claims it. +2. Create an API token on Hackage (*Account* → *Manage API tokens*) and add + it to the repository as the `HACKAGE_TOKEN` secret of a `hackage` + environment. Requiring a reviewer on that environment is a good idea. + +For each release: + +1. Update `CHANGELOG.md` in both packages. The release notes are taken from + the `## ` section of `typesafe-ai/CHANGELOG.md`. +2. Set `version:` in both `.cabal` files and update the dependency bound. +3. Check locally: + + ```sh + cabal test all + (cd typesafe-ai-core && cabal check) && (cd typesafe-ai && cabal check) + ``` + +4. Tag and push: `git tag v0.1.0.0 && git push origin v0.1.0.0`. The + `release` workflow tests, packages and uploads both packages and their + documentation as Hackage **candidates**. +5. Review the candidates on Hackage. +6. Run the `release` workflow by hand with *publish* checked. It publishes + `typesafe-ai-core`, then `typesafe-ai`, and creates the GitHub release. + +To release from a workstation instead: + +```sh +cabal sdist typesafe-ai-core typesafe-ai +cabal haddock typesafe-ai-core typesafe-ai --haddock-for-hackage +for p in typesafe-ai-core typesafe-ai; do + cabal upload --publish --token "$HACKAGE_TOKEN" dist-newstyle/sdist/$p-*.tar.gz + cabal upload --publish --documentation --token "$HACKAGE_TOKEN" dist-newstyle/$p-*-docs.tar.gz +done +``` + +## Conventions + +- Commit messages, pull requests and issues describe the change for human + readers. They do not carry tool or assistant attribution trailers. +- Warnings are errors in the project build (`cabal.project`), but not in the + released packages, so that a new GHC warning never breaks a user's build. diff --git a/README.md b/README.md index 2741905..462422a 100644 --- a/README.md +++ b/README.md @@ -1,2 +1,224 @@ # typesafe-sdk -Haskell SDK for TypeSafe AI + +[![CI](https://github.com/byteally/typesafe-sdk/actions/workflows/ci.yml/badge.svg)](https://github.com/byteally/typesafe-sdk/actions/workflows/ci.yml) +[![Hackage](https://img.shields.io/hackage/v/typesafe-ai.svg)](https://hackage.haskell.org/package/typesafe-ai) + +Haskell SDK for [TypeSafe AI](https://typesafe.ai)'s System One API. Send +text or JSON state with typed questions, and get back answers that decode to +your own Haskell types: + +```haskell +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, OverloadedStrings #-} + +import GHC.Generics (Generic) +import TypeSafe + +data Department = Billing | Technical | Sales + deriving stock (Show, Eq, Generic) + deriving anyclass (ChoiceOption) + +data Frustration = Calm | Frustrated | VeryAngry + deriving stock (Show, Eq, Generic) + deriving anyclass (ScoreLevel) + +data Triage = Triage + { department :: Choice Department + , urgent :: Noul + , frustration :: Score Frustration + } + +triage :: Questions Triage +triage = + Triage + <$> ask "department" (choice "Which team should handle this?") + <*> ask "is_urgent" (noul "Does this convey urgency?") + <*> ask "frustration" (score "How frustrated is the customer?") + +main :: IO () +main = do + client <- newClientFromEnv -- reads TYPESAFE_API_KEY + result <- send client (systemOne "Help! My payouts have been failing for 3 days." triage) + let answers = evaluationAnswers result + print (choiceSelected (department answers), choiceConfidence (department answers)) + print (noulProbability (urgent answers)) + print (mostLikelyLevel (frustration answers)) +``` + +`choiceSelected` is a `Department`: an option the model was not offered can +never reach your code. All three questions go out in one request and are +answered in parallel. + +## Packages + +| Package | What it contains | Depends on | +| --- | --- | --- | +| [`typesafe-ai`](typesafe-ai) | The client: `newClientFromEnv`, `send`, retries, timeouts, logging hooks. Re-exports everything below. | `http-client`, `http-client-tls` | +| [`typesafe-ai-core`](typesafe-ai-core) | Typed questions and answers, the OpenAPI schemas as Haskell types with JSON codecs, API calls as values, errors, the retry policy. **No HTTP library.** | `aeson`, `http-types`, boot packages | + +Most applications depend on `typesafe-ai` only. Depend on `typesafe-ai-core` +alone to use your own HTTP stack, such as servant. + +## Installing + +Add the package to your `.cabal` file: + +```cabal +build-depends: typesafe-ai ^>=0.1 +``` + +The SDK supports GHC 9.6 to 9.14. CI builds and tests it on Linux, and with +one GHC version on macOS and Windows. + +## Documentation + +- [`TypeSafe.Tutorial`](https://hackage.haskell.org/package/typesafe-ai/docs/TypeSafe-Tutorial.html): + a guided tour, from the first request to confidence routing, composite + scores, error handling and testing. +- The module documentation on Hackage. Every example that can run without a + network is checked by [doctest](https://github.com/sol/doctest). +- [`examples/`](examples): runnable programs. Try + `TYPESAFE_API_KEY=... cabal run typesafe-quickstart`. +- TypeSafe's own documentation: . + +## Design + +### Types all the way to the answer + +- **Options and levels are types.** `choice` and `score` take their options + and levels from a type with a `ChoiceOption` or `ScoreLevel` instance, + usually derived for an enumeration. The answer is decoded back into that + type, and an answer outside it is reported as an error. +- **Questions compose with `Applicative`.** `Questions a` describes a request + and how to build an `a` from its answers. It is deliberately not a `Monad`: + questions in one request are answered independently, so a question that + depends on another's answer needs a second request, and the types say so. +- **Probability and confidence are distinct types.** `Probability` and + `Confidence` are newtypes, so a Noul's probability cannot be mistaken for a + Choice's confidence. Both still accept numeric literals (`>= 0.8`). +- **Errors are values.** `TypeSafeError` separates requests rejected locally, + error responses (classified as `Unauthorized`, `RateLimited`, + `Overloaded`, …), connection failures and responses that do not fit the + request. `sendEither` returns them; `send` throws them. + +### Independent of any web framework + +`typesafe-ai-core` does no I/O. An API call is a value, `Call a`, that a +transport renders to an `HttpRequest`, sends however it likes, and decodes +from an `HttpResponse`. The bundled transport uses `http-client`. The retry +policy, error classification and header handling live in the core, so +every transport behaves the same way. + +To use servant or anything else, you can either describe the API +over the wire types: + +```haskell +import qualified TypeSafe.Wire as Wire + +type TypeSafeAPI = + Header' '[Required, Strict] "Authorization" Text + :> "v1" + :> ( "systemone" :> ReqBody '[JSON] Wire.SystemOneRequest :> Post '[JSON] Wire.SystemOneResponse + :<|> "models" :> Get '[JSON] Wire.ModelMetadataList + ) +``` + +and still use typed questions with `systemOneRequest` and +`decodeEvaluation`, or write a transport around `renderCall` and +`parseResponse` to reuse the retry and error logic as well. + +### Why `http-client` + +We considered `http-client`, `req` and `wreq`: + +- **`http-client` + `http-client-tls`** is the foundation the others (and + servant-client) are built on. It is small, stable and maintained, and + gives direct control over what an SDK needs: a shared, thread-safe + connection `Manager`, per-request timeouts, streaming bodies and exception + types. Applications that already use servant-client or `http-conduit` + already have it, and can pass their `Manager` to `newClientWith`. +- **`req`** has a pleasant type-safe API for *applications*, but an SDK + exposes its own typed API anyway, so `req`'s URL and option types would + stay internal. It would add dependencies (`modern-uri`, `retry`, + `monad-control`, …) and its `MonadHttp` class and retry machinery, which + overlap with the SDK's own. +- **`wreq`** depends on `lens` and sees little maintenance. It is a poor + choice of dependency for a library. + +The SDK talks to two endpoints with JSON bodies, so the layer over +`http-client` is small. Because the transport is separate from everything +else, switching to another HTTP library later would change only +`TypeSafe.Client`. + +### Efficiency + +- Requests are encoded straight to bytes with aeson's `toEncoding`, without + building an intermediate `Value`. Choice options keep the order you + declared them in. +- One `Client` keeps a pool of keep-alive TLS connections and is safe to + share between threads (see [`examples/Concurrent.hs`](examples/Concurrent.hs)). +- Many questions fit in one request, and the docs encourage it: extra + questions barely change latency and cost only their own tokens. + +## Keeping up with the API + +TypeSafe publishes an OpenAPI specification at +. A copy is vendored in +[`typesafe-ai-core/spec/openapi.json`](typesafe-ai-core/spec/openapi.json), +and the bindings are tested against it: + +- **Conformance tests** check that every operation and schema in the + specification is bound. They also check that every property is encoded, + that required properties are required and optional ones optional, and that + the discriminators match the Haskell constructors. Generated values must + validate against the schemas, and the specification's own examples must + decode. The tests fail when the specification uses a JSON Schema keyword + they do not understand, rather than silently passing. +- **A daily workflow** ([`spec-drift.yml`](.github/workflows/spec-drift.yml)) + fetches the published specification. When it changes, the workflow opens a + pull request that updates the vendored copy. The PR description summarises + what changed and lists the conformance tests that now fail: the to-do list + for the update. +- **`scripts/sync-spec.sh`** does the same locally. + +The SDK keeps working with newer APIs in the meantime. It ignores unknown +response fields and keeps answers of unknown types. `withExtraBody` sends new +request fields, and `otherQuestion` sends new question types. + +[MAINTAINING.md](MAINTAINING.md) describes how to update the bindings and +release them. + +### Versions + +Both packages follow the [PVP](https://pvp.haskell.org) and are released +together, with the same version number. `apiSpecVersion` reports the API +specification a release was checked against. + +| SDK | TypeSafe API specification | +| --- | --- | +| 0.1.0.0 | 0.2.0 | + +## Development + +```sh +cabal build all +cabal test all # unit, conformance and mock-server tests +TYPESAFE_LIVE_TESTS=1 TYPESAFE_API_KEY=... cabal test typesafe-ai # plus the live API +scripts/sync-spec.sh --check # is the vendored specification current? +``` + +Run the documentation examples with +[doctest](https://github.com/sol/doctest) (needs cabal 3.16 or later for +`--with-repl`): + +```sh +cabal install doctest --ignore-project +cabal repl typesafe-ai-core --with-repl=doctest --repl-options=-w +cabal repl typesafe-ai --with-repl=doctest --repl-options=-w +``` + +## License + +BSD-3-Clause. See [LICENSE](LICENSE). + +This is a community SDK, maintained by [byteally](https://github.com/byteally). +It is not affiliated with or endorsed by TypeSafe AI. diff --git a/cabal.project b/cabal.project new file mode 100644 index 0000000..c45526d --- /dev/null +++ b/cabal.project @@ -0,0 +1,12 @@ +packages: + typesafe-ai-core + typesafe-ai + examples + +tests: True + +package typesafe-ai-core + ghc-options: -Werror + +package typesafe-ai + ghc-options: -Werror diff --git a/examples/Concurrent.hs b/examples/Concurrent.hs new file mode 100644 index 0000000..abffc3f --- /dev/null +++ b/examples/Concurrent.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Share one 'Client' between threads. The client is thread-safe and reuses +-- connections from its pool, so concurrent requests do not pay for a new TLS +-- handshake each time. Rate limits (HTTP 429) are retried with backoff. +-- +-- Prefer putting many questions in one request when they share a state; use +-- concurrency for requests with different states. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-concurrent +module Main (main) where + +import Control.Concurrent.Async (mapConcurrently) +import TypeSafe + +main :: IO () +main = do + client <- newClientFromEnv + let reviews = + [ "Arrived broken and support never answered." + , "Does exactly what it says. Five stars." + , "It's fine, I guess." + , "Stopped working after a week, but the replacement is great." + ] + positive review = systemOne review (ask "positive" (noul "Is the review positive overall?")) + results <- mapConcurrently (send client . positive) reviews + mapM_ (\(review, r) -> putStrLn (show (noulProbability (evaluationAnswers r)) <> " " <> show review)) (zip reviews results) diff --git a/examples/ConfidenceRouting.hs b/examples/ConfidenceRouting.hs new file mode 100644 index 0000000..1a6cf33 --- /dev/null +++ b/examples/ConfidenceRouting.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Confidence-gated routing (): +-- act on the answer automatically when the model is confident, and send the +-- ranked alternatives to a person otherwise. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-confidence-routing +module Main (main) where + +import Data.List.NonEmpty (NonEmpty) +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic) +import TypeSafe + +data Intent = Refund | Rebooking | Information | Other + deriving stock (Show, Eq, Generic) + deriving anyclass (ChoiceOption) + +data Route + = Automate Intent + | Review (NonEmpty (Intent, Probability)) + deriving stock (Show) + +route :: Choice Intent -> Route +route answer + | confidence answer >= 0.8 = Automate (choiceSelected answer) + | otherwise = Review (rankedChoices answer) + +main :: IO () +main = do + client <- newClientFromEnv + let messages :: [Text] + messages = + [ "My flight was cancelled. I want my money back." + , "Can I change my booking, or get a voucher, or maybe a refund? Not sure what's best." + ] + mapM_ + ( \message -> do + result <- send client (systemOne (contentText message) (ask "intent" (choice "What is the main request?"))) + putStrLn (Text.unpack message) + putStrLn (" -> " <> show (route (evaluationAnswers result))) + ) + messages diff --git a/examples/FanOut.hs b/examples/FanOut.hs new file mode 100644 index 0000000..5edf279 --- /dev/null +++ b/examples/FanOut.hs @@ -0,0 +1,106 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Two patterns from , each in a single +-- request: +-- +-- * /speculative fan-out/ with /composite scoring/: ask every question the +-- code might need about a bug report, weight the scores in code, and use +-- the severity only if it really is a bug report; +-- +-- * /re-ranking/: one question per candidate passage, generated with +-- 'traverse'. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-fan-out +module Main (main) where + +import Data.Aeson ((.=)) +import Data.List (sortOn) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Ord (Down (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Traversable (for) +import GHC.Generics (Generic) +import TypeSafe + +data Severity = Cosmetic | Degraded | Outage + deriving stock (Show, Eq, Generic) + +instance ScoreLevel Severity where + levelDescription = \case + Cosmetic -> "Cosmetic: nothing is broken" + Degraded -> "Degraded: a feature misbehaves but there is a workaround" + Outage -> "Outage: customers cannot use the product" + +data Detail = Vague | Partial | Reproducible + deriving stock (Show, Eq, Generic) + +instance ScoreLevel Detail where + levelDescription = \case + Vague -> "Vague: no steps, versions or errors" + Partial -> "Partial: some context, but an engineer would need to ask questions" + Reproducible -> "Reproducible: steps, versions and error messages are included" + +data Report = Report + { isBugReport :: Noul + , severity :: Score Severity + , detail :: Score Detail + , frustration :: Score Int + } + +-- | Every question is asked, even the ones that only matter for bug reports: +-- extra questions in the same request are nearly free. +report :: Questions Report +report = + Report + <$> ask "is_bug_report" (noul "Does the message report a software defect?") + <*> ask "severity" (score "How severe is the reported problem?") + <*> ask "detail" (score "How much does the report give an engineer to work with?") + <*> ask "frustration" (scoreRubric "How frustrated is the customer?" ("Calm" :| ["Annoyed", "Angry"])) + +-- | Weights live in code, where they are easy to review and change. +priority :: Report -> Maybe Double +priority r + | noulProbability (isBugReport r) < 0.5 = Nothing + | otherwise = + Just $ + 0.5 * normalizedScore (severity r) + + 0.3 * normalizedScore (frustration r) + + 0.2 * normalizedScore (detail r) + +-- | One Noul per passage, all in the same request. +relevance :: Text -> [Text] -> Questions [(Text, Noul)] +relevance query passages = + for (zip [0 :: Int ..] passages) $ \(i, passage) -> + (,) passage + <$> ask + (QuestionId ("passage_" <> Text.pack (show i))) + ( noul + ( contentObject + [ "query" .= query + , "passage" .= passage + , "question" .= ("Does `passage` answer `query`?" :: Text) + ] + ) + ) + +main :: IO () +main = do + client <- newClientFromEnv + + bug <- + send client . systemOne "Checkout returns HTTP 500 for every order since the 2.3 release. Steps: add any item, press Pay." $ + report + putStrLn ("Priority: " <> maybe "not a bug report" show (priority (evaluationAnswers bug))) + + let passages = + [ "Refunds are issued to the original payment method within 5 business days." + , "Our offices are closed on public holidays." + , "Duplicate charges are refunded automatically once confirmed by support." + ] + ranked <- send client (systemOne "Ranking passages" (relevance "How long does a refund take?" passages)) + mapM_ (\(passage, answer) -> putStrLn (show (noulProbability answer) <> " " <> Text.unpack passage)) $ + sortOn (Down . noulProbability . snd) (evaluationAnswers ranked) diff --git a/examples/ForwardCompatibility.hs b/examples/ForwardCompatibility.hs new file mode 100644 index 0000000..bb429f1 --- /dev/null +++ b/examples/ForwardCompatibility.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Escape hatches for API features this version of the SDK does not know +-- about yet, and the wire-level API underneath the typed one. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-forward-compatibility +module Main (main) where + +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy.Char8 as LBS +import qualified Data.Map.Strict as Map +import TypeSafe +import qualified TypeSafe.Wire as Wire + +main :: IO () +main = do + client <- newClientFromEnv + + -- 1. The wire-level request: exactly the JSON the API documents. + let raw = + Wire.SystemOneRequest + { Wire.systemOneRequestState = "I was charged twice. Please help." + , Wire.systemOneRequestModel = jevLatest + , Wire.systemOneRequestQuestions = + Map.fromList + [ ("billing", Wire.QuestionNoul (Wire.NoulQuestion (Just "Is this about billing?") Nothing)) + ] + } + answers <- send client (systemOneRaw raw) + print (evaluationAnswers answers) + + -- 2. The complete response of a typed call is always available, including + -- answers of types this SDK version cannot decode. + typed <- send client (systemOne "I was charged twice." (ask "billing" (noul "Is this about billing?"))) + print (Wire.systemOneResponseAnswers (evaluationResponse typed)) + + -- 3. Extra top-level request fields, for request options the SDK does not + -- know yet. The field below is made up, so the request is only rendered + -- here, not sent: only send fields the API supports. + let call = + withExtraBody (KeyMap.fromList [("example_option", "value")]) $ + systemOne "I was charged twice." (ask "billing" (noul "Is this about billing?")) + either print (mapM_ LBS.putStrLn . httpRequestBody) (renderCall (CallDefaults jevLatest []) call) diff --git a/examples/Models.hs b/examples/Models.hs new file mode 100644 index 0000000..6ff910a --- /dev/null +++ b/examples/Models.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | List the models available to the account, then pin a model version for +-- one call and handle errors explicitly. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-models +module Main (main) where + +import Control.Exception (throwIO) +import Data.Maybe (fromMaybe) +import qualified Data.Text as Text +import qualified Data.Text.IO as Text +import TypeSafe + +main :: IO () +main = do + config <- clientConfigFromEnv >>= either throwIO pure + client <- newClient config {configLogger = stderrLogger} + + models <- send client listModels + mapM_ + (\m -> putStrLn (show (modelMetadataName m) <> " " <> show (modelMetadataReleaseDay m) <> " " <> Text.unpack (modelMetadataDescription m))) + models + + -- Pinning a version keeps answers stable when the alias moves. + outcome <- + sendEither client . withModel "jev-1.13.0" . withTimeout 5 $ + systemOne "The invoice total is wrong." (ask "billing" (noul "Is this about billing?")) + case outcome of + Right result -> putStrLn ("billing: " <> show (noulProbability (evaluationAnswers result))) + Left (ServiceError e) + | apiErrorKind e `elem` [BadRequest, UnprocessableEntity] -> + Text.putStrLn ("The request was rejected: " <> fromMaybe "no details" (apiErrorMessage e)) + Left err -> Text.putStrLn (renderTypeSafeError err) diff --git a/examples/Quickstart.hs b/examples/Quickstart.hs new file mode 100644 index 0000000..efb1d1b --- /dev/null +++ b/examples/Quickstart.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Triage a support message with one request and three typed questions. +-- +-- > TYPESAFE_API_KEY=... cabal run typesafe-quickstart +module Main (main) where + +import GHC.Generics (Generic) +import TypeSafe + +-- | Which team should handle the message. Deriving 'ChoiceOption' offers the +-- constructors as options; the instance adds descriptions. +data Department = Billing | Technical | Sales + deriving stock (Show, Eq, Generic) + +instance ChoiceOption Department where + optionDescription = + Just . \case + Billing -> "Payments, invoicing, refunds" + Technical -> "Bugs, outages, integrations" + Sales -> "Pricing, upgrades, new accounts" + +-- | How frustrated the customer is, lowest level first. +data Frustration = Calm | Frustrated | VeryAngry + deriving stock (Show, Eq, Generic) + +instance ScoreLevel Frustration where + levelDescription = \case + Calm -> "Calm, just stating facts" + Frustrated -> "Frustrated but civil" + VeryAngry -> "Very angry, strong language" + +data Triage = Triage + { department :: Choice Department + , urgent :: Noul + , frustration :: Score Frustration + } + +-- | Three independent questions about the same state, sent in one request. +triage :: Questions Triage +triage = + Triage + <$> ask "department" (choice "Which team should handle this?") + <*> ask "is_urgent" (noulWith "Does this convey urgency?" "Explicitly time-sensitive" "No urgency expressed") + <*> ask "frustration" (score "How frustrated is the customer?") + +main :: IO () +main = do + client <- newClientFromEnv + result <- send client (systemOne "Help! My payouts have been failing for 3 days." triage) + + let answers = evaluationAnswers result + putStrLn $ + "Department: " + <> show (choiceSelected (department answers)) + <> " (confidence " + <> show (choiceConfidence (department answers)) + <> ")" + putStrLn $ "Urgent: " <> show (noulProbability (urgent answers)) + putStrLn $ + "Frustration: " + <> show (mostLikelyLevel (frustration answers)) + <> " (expected level " + <> show (scoreValue (frustration answers)) + <> ")" + putStrLn $ + "Answered by " + <> show (evaluationModel result) + <> " using " + <> show (usageInputTokens (evaluationUsage result)) + <> " input tokens" diff --git a/examples/typesafe-ai-examples.cabal b/examples/typesafe-ai-examples.cabal new file mode 100644 index 0000000..a590810 --- /dev/null +++ b/examples/typesafe-ai-examples.cabal @@ -0,0 +1,54 @@ +cabal-version: 3.0 +name: typesafe-ai-examples +version: 0.1.0.0 +synopsis: Runnable examples for the typesafe-ai package +description: + Example programs for @typesafe-ai@. They are built by CI so that they keep + compiling, but this package is not published to Hackage. + . + Run one with an API key, for example: + . + > TYPESAFE_API_KEY=... cabal run typesafe-quickstart + +license: BSD-3-Clause +author: Magesh B +maintainer: magesh85@gmail.com +category: AI +build-type: Simple + +common example + default-language: Haskell2010 + hs-source-dirs: . + ghc-options: -Wall -Wcompat -threaded -rtsopts + build-depends: + , base >=4.18 && <5 + , typesafe-ai + +executable typesafe-quickstart + import: example + main-is: Quickstart.hs + +executable typesafe-fan-out + import: example + main-is: FanOut.hs + build-depends: aeson, text + +executable typesafe-confidence-routing + import: example + main-is: ConfidenceRouting.hs + build-depends: text + +executable typesafe-concurrent + import: example + main-is: Concurrent.hs + build-depends: async >=2.2 && <2.3 + +executable typesafe-models + import: example + main-is: Models.hs + build-depends: text + +executable typesafe-forward-compatibility + import: example + main-is: ForwardCompatibility.hs + build-depends: aeson, bytestring, containers diff --git a/scripts/sync-spec.sh b/scripts/sync-spec.sh new file mode 100755 index 0000000..706bd13 --- /dev/null +++ b/scripts/sync-spec.sh @@ -0,0 +1,105 @@ +#!/usr/bin/env bash +# Compare the published TypeSafe OpenAPI specification with the vendored copy +# in typesafe-ai-core/spec/openapi.json, and optionally replace it. +# +# Usage: +# scripts/sync-spec.sh replace the vendored copy if the spec changed +# scripts/sync-spec.sh --check only report; exit 1 if the spec changed +# scripts/sync-spec.sh --summary FILE +# also write a Markdown summary to FILE +# +# The specification is normalised with `jq -S` (sorted keys, fixed +# indentation) so that diffs only show real changes. After replacing it, run +# +# cabal test typesafe-ai-core +# +# The conformance tests then name every operation, schema, property and +# keyword the bindings do not cover yet. See MAINTAINING.md. +# +# Requires curl and jq. Set TYPESAFE_OPENAPI_URL to use another URL. +set -euo pipefail + +url="${TYPESAFE_OPENAPI_URL:-https://api.typesafe.ai/openapi.json}" +root="$(cd "$(dirname "${BASH_SOURCE[0]}")/.." && pwd)" +vendored="$root/typesafe-ai-core/spec/openapi.json" + +check=false +summary="" +while [ $# -gt 0 ]; do + case "$1" in + --check) check=true ;; + --summary) summary="$2"; shift ;; + -h | --help) sed -n '2,20p' "$0"; exit 0 ;; + *) echo "unknown argument: $1" >&2; exit 2 ;; + esac + shift +done + +work="$(mktemp -d)" +trap 'rm -rf "$work"' EXIT + +curl --fail --silent --show-error --location "$url" | jq -S . > "$work/published.json" + +# One line per structural fact of a specification, so that `diff` shows what +# was added and removed. Property lines include the property's schema without +# its documentation, so a type change shows up as a removal plus an addition. +outline() { + jq -r ' + def shape: del(.description, .examples, .title) | tojson; + "version \(.info.version)", + (.paths | to_entries[] | .key as $path | .value | keys[] | "operation \(ascii_upcase) \($path)"), + (.components.schemas | to_entries[] | .key as $schema | .value | + "schema \($schema)", + ((.properties // {}) | to_entries[] | "property \($schema).\(.key): \(.value | shape)"), + ((.required // [])[] | "required \($schema).\(.)"), + ((.discriminator.mapping // {}) | keys[] | "variant \($schema).\(.)")) + ' "$1" | LC_ALL=C sort +} + +old_version="$(jq -r .info.version "$vendored")" +new_version="$(jq -r .info.version "$work/published.json")" + +if cmp --silent "$vendored" "$work/published.json"; then + echo "The vendored specification is up to date (version $old_version)." + [ -n "$summary" ] && : > "$summary" + exit 0 +fi + +outline "$vendored" > "$work/old.txt" +outline "$work/published.json" > "$work/new.txt" +added="$(LC_ALL=C comm -13 "$work/old.txt" "$work/new.txt")" +removed="$(LC_ALL=C comm -23 "$work/old.txt" "$work/new.txt")" + +report() { + echo "## TypeSafe API specification changed" + echo + echo "Vendored version: \`$old_version\`, published version: \`$new_version\` ($url)." + echo + if [ -z "$added$removed" ]; then + echo "Only documentation changed (descriptions, titles or examples)." + else + if [ -n "$added" ]; then + echo "### Added" + echo + printf '%s\n' "$added" | sed 's/^/- `/; s/$/`/' + echo + fi + if [ -n "$removed" ]; then + echo "### Removed" + echo + printf '%s\n' "$removed" | sed 's/^/- `/; s/$/`/' + echo + fi + fi +} + +report +[ -n "$summary" ] && report > "$summary" + +if $check; then + exit 1 +fi + +cp "$work/published.json" "$vendored" +echo +echo "Updated $vendored. Now run: cabal test typesafe-ai-core" diff --git a/typesafe-ai-core/CHANGELOG.md b/typesafe-ai-core/CHANGELOG.md new file mode 100644 index 0000000..70f39a7 --- /dev/null +++ b/typesafe-ai-core/CHANGELOG.md @@ -0,0 +1,22 @@ +# Changelog for typesafe-ai-core + +This package follows the [PVP](https://pvp.haskell.org) and is released +together with `typesafe-ai`, with the same version number. + +## 0.1.0.0 + +First release. Checked against version 0.2.0 of the TypeSafe OpenAPI +specification. + +- `TypeSafe.Wire`: every schema of the specification, with JSON codecs. + Unknown question and answer types are preserved (`QuestionOther`, + `AnswerOther`). +- `TypeSafe.Question`: typed Noul, Choice and Score questions. Options and + levels come from `ChoiceOption` and `ScoreLevel` instances, which can be + derived for enumerations. Questions combine with the `Applicative` instance + of `Questions`. +- `TypeSafe.Call`: `systemOne`, `systemOneRaw` and `listModels` as values, + per-call options, and the functions a transport needs. +- `TypeSafe.Error`: `TypeSafeError`, with error responses classified by + status and error bodies parsed. +- `TypeSafe.Retry`: the retry policy of the official SDKs, as pure functions. diff --git a/typesafe-ai-core/LICENSE b/typesafe-ai-core/LICENSE new file mode 100644 index 0000000..945b9f1 --- /dev/null +++ b/typesafe-ai-core/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2026, byteally + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/typesafe-ai-core/README.md b/typesafe-ai-core/README.md new file mode 100644 index 0000000..685d53e --- /dev/null +++ b/typesafe-ai-core/README.md @@ -0,0 +1,39 @@ +# typesafe-ai-core + +Transport-agnostic bindings to [TypeSafe AI](https://typesafe.ai)'s System +One API: typed Noul, Choice and Score questions whose answers decode to your +own Haskell types, a one-to-one mirror of the OpenAPI schemas with JSON +codecs, and API calls as plain values. + +This package does no networking. Use it with servant or any other HTTP +stack. For a ready-to-use client, depend on +[`typesafe-ai`](https://hackage.haskell.org/package/typesafe-ai) instead; it +re-exports everything here. + +```haskell +data Department = Billing | Technical | Sales + deriving stock (Show, Eq, Generic) + deriving anyclass (ChoiceOption) + +routing :: Questions (Choice Department, Noul) +routing = + (,) <$> ask "department" (choice "Which team should handle this?") + <*> ask "is_urgent" (noul "Does this convey urgency?") + +-- The request, for any HTTP client: +request :: Either RequestError Wire.SystemOneRequest +request = systemOneRequest jevLatest "Help! My payouts have been failing." routing + +-- And the typed answers, from its response: +answers :: Wire.SystemOneResponse -> Either (NonEmpty AnswerError) (Evaluation (Choice Department, Noul)) +answers = decodeEvaluation routing Nothing +``` + +Start with the documentation of `TypeSafe.Core` and `TypeSafe.Question`. The +[repository](https://github.com/byteally/typesafe-sdk) has more examples. + +The bindings are checked against version `0.2.0` of the TypeSafe OpenAPI +specification (`apiSpecVersion`), which is included in the package +(`spec/openapi.json`). + +This is a community SDK, not affiliated with or endorsed by TypeSafe AI. diff --git a/typesafe-ai-core/spec/openapi.json b/typesafe-ai-core/spec/openapi.json new file mode 100644 index 0000000..d4aa8d4 --- /dev/null +++ b/typesafe-ai-core/spec/openapi.json @@ -0,0 +1,860 @@ +{ + "components": { + "schemas": { + "Answer": { + "description": "An answer whose type matches the corresponding question.", + "discriminator": { + "mapping": { + "choice": "#/components/schemas/ChoiceAnswer", + "noul": "#/components/schemas/NoulAnswer", + "score": "#/components/schemas/ScoreAnswer" + }, + "propertyName": "type" + }, + "oneOf": [ + { + "$ref": "#/components/schemas/NoulAnswer" + }, + { + "$ref": "#/components/schemas/ScoreAnswer" + }, + { + "$ref": "#/components/schemas/ChoiceAnswer" + } + ] + }, + "ChoiceAnswer": { + "description": "The selected choice, confidence, and probabilities for a choice question.", + "properties": { + "choice": { + "description": "The name of the choice with the highest probability among the question's criteria.", + "examples": [ + "angry" + ], + "title": "Choice", + "type": "string" + }, + "confidence": { + "description": "Confidence in the selected choice, from 0 to 1. Higher values indicate greater certainty; use lower values to flag uncertain selections for review.", + "examples": [ + 0.9 + ], + "title": "Confidence", + "type": "number" + }, + "probabilities": { + "additionalProperties": { + "type": "number" + }, + "description": "Probability of each choice in criteria, keyed by choice name, from 0 to 1. Shows how likely the alternatives are; values sum to approximately 1.", + "examples": [ + { + "angry": 0.8, + "calm": 0.1, + "excited": 0.1 + } + ], + "title": "Probabilities", + "type": "object" + }, + "type": { + "const": "choice", + "description": "Identifies a selection from the requested choices.", + "examples": [ + "choice" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "choice", + "confidence", + "probabilities", + "type" + ], + "title": "ChoiceAnswer", + "type": "object" + }, + "ChoiceQuestion": { + "description": "A question that selects one option from the choices you define.", + "properties": { + "criteria": { + "additionalProperties": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ] + }, + "description": "Choice names and descriptions of when each applies. A choice without a description is interpreted by its name alone.", + "examples": [ + { + "angry": "An upset or hostile message", + "calm": "A neutral or polite message", + "excited": "An enthusiastic or eager message" + } + ], + "title": "Criteria", + "type": "object" + }, + "instructions": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ], + "description": "What the model should decide when choosing an option.", + "examples": [ + "What is the tone of this message?" + ], + "title": "Instructions" + }, + "type": { + "const": "choice", + "description": "Identifies a question that selects one of the choices in criteria.", + "examples": [ + "choice" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "criteria", + "type" + ], + "title": "ChoiceQuestion", + "type": "object" + }, + "HTTPValidationError": { + "description": "Request validation failures returned with HTTP status 422.", + "properties": { + "detail": { + "description": "Validation errors describing which request values are missing or invalid.", + "examples": [ + [ + { + "loc": [ + "body", + "state" + ], + "msg": "Field required", + "type": "missing" + } + ] + ], + "items": { + "$ref": "#/components/schemas/ValidationError" + }, + "title": "Detail", + "type": "array" + } + }, + "title": "HTTPValidationError", + "type": "object" + }, + "ModelMetadata": { + "description": "A model or model alias available to the authenticated account.", + "properties": { + "description": { + "description": "Human-readable description of the model and its capabilities.", + "examples": [ + "General-purpose system one model." + ], + "title": "Description", + "type": "string" + }, + "name": { + "description": "Model name or alias accepted by the request's model field.", + "examples": [ + "jev-latest" + ], + "title": "Name", + "type": "string" + }, + "release_date": { + "description": "Model release date, formatted as YYYY-MM-DD.", + "examples": [ + "2026-09-15" + ], + "title": "Release Date", + "type": "string" + } + }, + "required": [ + "name", + "description", + "release_date" + ], + "title": "ModelMetadata", + "type": "object" + }, + "ModelMetadataList": { + "description": "Models and aliases available to the authenticated account.", + "properties": { + "models": { + "description": "Available models and aliases. Use a model's name in POST /v1/systemone requests.", + "examples": [ + [ + { + "description": "General-purpose system one model.", + "name": "jev-latest", + "release_date": "2026-09-15" + } + ] + ], + "items": { + "$ref": "#/components/schemas/ModelMetadata" + }, + "title": "Models", + "type": "array" + } + }, + "required": [ + "models" + ], + "title": "ModelMetadataList", + "type": "object" + }, + "NoulAnswer": { + "description": "The probability of a yes answer or a true statement.", + "properties": { + "noul": { + "description": "Probability of a yes answer or a true statement, from 0 to 1. Values near 1 favor yes or true, values near 0 favor no or false, and values near 0.5 indicate uncertainty.", + "examples": [ + 0.98 + ], + "title": "Noul", + "type": "number" + }, + "type": { + "const": "noul", + "description": "Identifies a yes/no answer.", + "examples": [ + "noul" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "noul", + "type" + ], + "title": "NoulAnswer", + "type": "object" + }, + "NoulCriteria": { + "description": "Criteria defining what counts as a yes or no answer.", + "properties": { + "false": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ], + "description": "What counts as a no answer.", + "examples": [ + "The message is a legitimate conversation." + ], + "title": "False" + }, + "true": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ], + "description": "What counts as a yes answer.", + "examples": [ + "The message is unsolicited advertising." + ], + "title": "True" + } + }, + "title": "NoulCriteria", + "type": "object" + }, + "NoulQuestion": { + "description": "A yes/no question or statement, answered with the probability of yes or true.", + "properties": { + "criteria": { + "anyOf": [ + { + "$ref": "#/components/schemas/NoulCriteria" + }, + { + "type": "null" + } + ], + "description": "Criteria clarifying what counts as a yes or no answer.", + "examples": [ + { + "false": "A legitimate conversation", + "true": "Unsolicited advertising" + } + ] + }, + "instructions": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ], + "description": "The yes/no question or statement to evaluate.", + "examples": [ + "Is this message spam?", + "This message contains unsolicited advertising.", + { + "task": "Identify unsolicited advertising." + } + ], + "title": "Instructions" + }, + "type": { + "const": "noul", + "description": "Identifies a yes/no question or statement.", + "examples": [ + "noul" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "type" + ], + "title": "NoulQuestion", + "type": "object" + }, + "Question": { + "description": "A question about the supplied content.", + "discriminator": { + "mapping": { + "choice": "#/components/schemas/ChoiceQuestion", + "noul": "#/components/schemas/NoulQuestion", + "score": "#/components/schemas/ScoreQuestion" + }, + "propertyName": "type" + }, + "oneOf": [ + { + "$ref": "#/components/schemas/NoulQuestion" + }, + { + "$ref": "#/components/schemas/ChoiceQuestion" + }, + { + "$ref": "#/components/schemas/ScoreQuestion" + } + ] + }, + "ScoreAnswer": { + "description": "An expected score with its rubric, confidence, and score-level probabilities.", + "properties": { + "confidence": { + "description": "Confidence in the score, from 0 to 1. Higher values indicate greater certainty; use lower values to flag uncertain ratings for review.", + "examples": [ + 0.9 + ], + "title": "Confidence", + "type": "number" + }, + "legend": { + "additionalProperties": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + } + ] + }, + "description": "The requested criteria mapped to their score levels, so you can interpret the score.", + "examples": [ + { + "0": "Can wait", + "1": "Needs attention this week", + "2": "Needs attention today" + } + ], + "title": "Legend", + "type": "object" + }, + "probabilities": { + "additionalProperties": { + "type": "number" + }, + "description": "Probability of each score level, from 0 to 1, using the same keys as legend. Shows how likely the alternatives are; values sum to approximately 1.", + "examples": [ + { + "0": 0.1, + "1": 0.1, + "2": 0.8 + } + ], + "title": "Probabilities", + "type": "object" + }, + "score": { + "description": "Expected score: the probability-weighted average of the rubric levels. May fall between integer levels.", + "examples": [ + 1.7 + ], + "title": "Score", + "type": "number" + }, + "type": { + "const": "score", + "description": "Identifies a rating against the requested score levels.", + "examples": [ + "score" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "score", + "confidence", + "legend", + "probabilities", + "type" + ], + "title": "ScoreAnswer", + "type": "object" + }, + "ScoreQuestion": { + "description": "A question that assigns a score using an ordered rubric.", + "properties": { + "criteria": { + "description": "Ordered descriptions of the score levels. Each description's position determines its score, starting at zero.", + "examples": [ + [ + "Can wait", + "Needs attention this week", + "Needs attention today" + ] + ], + "items": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + } + ] + }, + "minItems": 1, + "title": "Criteria", + "type": "array" + }, + "instructions": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + }, + { + "type": "null" + } + ], + "description": "What the model should rate.", + "examples": [ + "How urgent is this message?" + ], + "title": "Instructions" + }, + "type": { + "const": "score", + "description": "Identifies a question that rates the content using the levels in criteria.", + "examples": [ + "score" + ], + "title": "Type", + "type": "string" + } + }, + "required": [ + "criteria", + "type" + ], + "title": "ScoreQuestion", + "type": "object" + }, + "SystemOneRequest": { + "description": "Content and named questions to evaluate together using a TypeSafe model.", + "properties": { + "model": { + "description": "Name or alias of the model to use. Available names are returned by GET /v1/models.", + "examples": [ + "jev-latest" + ], + "title": "Model", + "type": "string" + }, + "questions": { + "additionalProperties": { + "$ref": "#/components/schemas/Question" + }, + "description": "Questions to ask about the content, each with a name you choose. The response uses those names to identify the answers.", + "examples": [ + { + "billing": { + "instructions": "Is this message about billing?", + "type": "noul" + } + } + ], + "minProperties": 1, + "title": "Questions", + "type": "object" + }, + "state": { + "anyOf": [ + { + "type": "string" + }, + { + "additionalProperties": true, + "type": "object" + }, + { + "items": {}, + "type": "array" + } + ], + "description": "The content all questions in this request refer to.", + "examples": [ + "I was charged twice. Please help.", + { + "message": "Please help.", + "subject": "Duplicate charge" + } + ], + "title": "State" + } + }, + "required": [ + "model", + "questions", + "state" + ], + "title": "SystemOneRequest", + "type": "object" + }, + "SystemOneResponse": { + "description": "Answers grouped by question name, with the model used and token usage.", + "properties": { + "answers": { + "additionalProperties": { + "$ref": "#/components/schemas/Answer" + }, + "description": "Answers keyed by the question names supplied in the request. Each answer's type matches its question's type.", + "examples": [ + { + "billing": { + "noul": 0.98, + "type": "noul" + } + } + ], + "minProperties": 1, + "title": "Answers", + "type": "object" + }, + "model": { + "description": "Name of the model that answered the questions. May differ from the alias supplied in the request.", + "examples": [ + "jev-latest" + ], + "title": "Model", + "type": "string" + }, + "usage": { + "$ref": "#/components/schemas/Usage", + "description": "Input and output token counts for this evaluation.", + "examples": [ + { + "input_tokens": 120, + "output_tokens": 12 + } + ] + } + }, + "required": [ + "model", + "answers", + "usage" + ], + "title": "SystemOneResponse", + "type": "object" + }, + "Usage": { + "description": "Token usage for the request.", + "properties": { + "input_tokens": { + "description": "Number of billable input tokens used to evaluate the request.", + "examples": [ + 120 + ], + "title": "Input Tokens", + "type": "integer" + }, + "output_tokens": { + "description": "Number of output tokens used to answer the questions. Output tokens are currently free of charge.", + "examples": [ + 12 + ], + "title": "Output Tokens", + "type": "integer" + } + }, + "required": [ + "input_tokens", + "output_tokens" + ], + "title": "Usage", + "type": "object" + }, + "ValidationError": { + "description": "A request validation error at a specific field or array element.", + "properties": { + "ctx": { + "description": "Additional context used to explain the validation failure.", + "examples": [ + { + "min_length": 1 + } + ], + "title": "Context", + "type": "object" + }, + "input": { + "description": "The input value that failed validation.", + "examples": [ + { + "type": "score" + } + ], + "title": "Input" + }, + "loc": { + "description": "Path to the invalid value: the request location followed by field names and array indices.", + "examples": [ + [ + "body", + "questions", + "urgency", + "score", + "criteria" + ] + ], + "items": { + "anyOf": [ + { + "type": "string" + }, + { + "type": "integer" + } + ] + }, + "title": "Location", + "type": "array" + }, + "msg": { + "description": "Human-readable explanation of the validation failure.", + "examples": [ + "Field required" + ], + "title": "Message", + "type": "string" + }, + "type": { + "description": "Machine-readable validation error code.", + "examples": [ + "missing" + ], + "title": "Error Type", + "type": "string" + } + }, + "required": [ + "loc", + "msg", + "type" + ], + "title": "ValidationError", + "type": "object" + } + }, + "securitySchemes": { + "HTTPBearer": { + "scheme": "bearer", + "type": "http" + } + } + }, + "info": { + "description": "Ask yes/no questions, evaluate statements, select choices, or assign ratings to your content. Send your API key in the Authorization header as `Bearer `. Use GET /v1/models to discover available model names.", + "title": "TypeSafe", + "version": "0.2.0" + }, + "openapi": "3.1.0", + "paths": { + "/v1/models": { + "get": { + "description": "List the models and aliases available to the authenticated account.\n\nPass a returned model name as `model` in a POST /v1/systemone request.", + "operationId": "models_v1_v1_models_get", + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/ModelMetadataList" + } + } + }, + "description": "Successful Response" + }, + "422": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/HTTPValidationError" + } + } + }, + "description": "Validation Error" + } + }, + "security": [ + { + "HTTPBearer": [] + } + ], + "summary": "Models V1" + } + }, + "/v1/systemone": { + "post": { + "description": "Answer one or more questions about the content supplied in `state`.\n\nYou can mix question types in one request. Answers use the same names as the\nquestions, so you can match each result to its question. The response also includes\nthe model used and token usage.", + "operationId": "systemone_v1_systemone_post", + "requestBody": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/SystemOneRequest" + } + } + }, + "required": true + }, + "responses": { + "200": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/SystemOneResponse" + } + } + }, + "description": "Successful Response" + }, + "422": { + "content": { + "application/json": { + "schema": { + "$ref": "#/components/schemas/HTTPValidationError" + } + } + }, + "description": "Validation Error" + } + }, + "security": [ + { + "HTTPBearer": [] + } + ], + "summary": "Systemone" + } + } + } +} diff --git a/typesafe-ai-core/src/TypeSafe/Call.hs b/typesafe-ai-core/src/TypeSafe/Call.hs new file mode 100644 index 0000000..8e55390 --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Call.hs @@ -0,0 +1,421 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : TypeSafe.Call +-- Description : API calls as values, independent of any HTTP library +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- A @'Call' a@ describes one API request and how to turn its response into +-- an @a@. It does no input or output: a /transport/ renders the call to an +-- 'HttpRequest', sends it with whatever HTTP stack it likes, and hands the +-- 'HttpResponse' back to 'parseResponse'. The @typesafe-ai@ package provides +-- a transport built on @http-client@; writing another one takes a few dozen +-- lines. +-- +-- Calls are built from the endpoint functions and adjusted with the @with…@ +-- functions: +-- +-- @ +-- 'withModel' \"jev-1.13.0\" ('systemOne' state triage) :: 'Call' ('Evaluation' Triage) +-- @ +-- +-- = Example +-- +-- >>> let call = systemOne "I was charged twice. Please help." (ask "billing" (noul "Is this about billing?")) +-- >>> callEndpoint call +-- "POST /v1/systemone" +-- +-- >>> let Right request = renderCall (CallDefaults jevLatest []) call +-- >>> traverse_ LBS.putStrLn (httpRequestBody request) +-- {"state":"I was charged twice. Please help.","model":"jev-latest","questions":{"billing":{"type":"noul","instructions":"Is this about billing?"}}} +-- +-- >>> :{ +-- let response = +-- HttpResponse +-- { httpResponseStatus = status200 +-- , httpResponseHeaders = [("x-typesafe-request-id", "req_0123")] +-- , httpResponseBody = "{\"model\":\"jev-1.13.0\",\"answers\":{\"billing\":{\"type\":\"noul\",\"noul\":0.98}},\"usage\":{\"input_tokens\":120,\"output_tokens\":12}}" +-- } +-- :} +-- +-- >>> let Right result = parseResponse call response +-- >>> evaluationAnswers result +-- Noul {noulProbability = 0.98} +-- >>> evaluationModel result +-- "jev-1.13.0" +-- >>> evaluationRequestId result +-- Just "req_0123" +module TypeSafe.Call + ( -- * Calls + Call + , systemOne + , systemOneRaw + , listModels + + -- * Evaluations + , Evaluation (..) + + -- * Per-call options + , withModel + , withHeaders + , withExtraBody + , withRetryPolicy + , withTimeout + + -- * Using the typed layer with your own HTTP client + , systemOneRequest + , decodeEvaluation + + -- * Implementing a transport + , CallDefaults (..) + , HttpRequest (..) + , HttpResponse (..) + , renderCall + , parseResponse + , callEndpoint + , callRetryPolicy + , callTimeout + , protectedHeaders + , defaultBaseUrl + , requestIdHeader + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson (Object, eitherDecode', pairs, (.=)) +import qualified Data.Aeson.Encoding as Encoding +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Bifunctor (first) +import qualified Data.ByteString.Lazy as LBS +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe, isJust) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import Data.Time.Clock (NominalDiffTime) +import GHC.Generics (Generic) +import Network.HTTP.Types + ( HeaderName + , Method + , RequestHeaders + , ResponseHeaders + , Status + , statusIsSuccessful + ) +import TypeSafe.Content (Content) +import TypeSafe.Error + ( AnswerError + , RequestError + , RequestId (..) + , ResponseError (..) + , ResponseProblem (..) + , TypeSafeError (..) + , apiErrorFromResponse + ) +import TypeSafe.Question (Questions, decodeAnswers, renderQuestions) +import TypeSafe.Retry (RetryPolicy) +import TypeSafe.Wire + ( Answer + , ModelMetadata + , ModelMetadataList (..) + , ModelName + , QuestionId + , SystemOneRequest (..) + , SystemOneResponse (..) + , Usage + ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Foldable (traverse_) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS +-- >>> import Network.HTTP.Types (status200) +-- >>> import TypeSafe.Question +-- >>> import TypeSafe.Wire (jevLatest) + +------------------------------------------------------------------------------ +-- Calls + +-- | One API request, and how to decode its response into an @a@. +data Call a = Call + { callMethod :: !Method + , callPath :: ![Text] + , callBody :: !(Maybe (CallOptions -> ModelName -> Either RequestError LBS.ByteString)) + , callOptions :: !CallOptions + , callDecode :: Maybe RequestId -> LBS.ByteString -> Either ResponseProblem a + } + +instance Functor Call where + fmap f c = c {callDecode = \rid body -> f <$> callDecode c rid body} + +data CallOptions = CallOptions + { optionModel :: !(Maybe ModelName) + , optionHeaders :: !RequestHeaders + , optionExtraBody :: !Object + , optionRetryPolicy :: !(Maybe RetryPolicy) + , optionTimeout :: !(Maybe NominalDiffTime) + } + +noOptions :: CallOptions +noOptions = CallOptions Nothing [] KeyMap.empty Nothing Nothing + +-- | Evaluate a state against typed questions (@POST \/v1\/systemone@). +-- +-- The request uses the transport's default model (normally 'TypeSafe.Wire.jevLatest') +-- unless 'withModel' says otherwise. Every question sees the same state and +-- is answered independently; see . +-- +-- The call fails with 'InvalidRequest', before anything is sent, if the +-- questions are empty, share an id, or are malformed. +systemOne :: Content -> Questions a -> Call (Evaluation a) +systemOne state questions = + Call + { callMethod = "POST" + , callPath = ["v1", "systemone"] + , callBody = Just $ \options defaultModel -> do + rendered <- renderQuestions questions + pure . encodeRequest options $ + SystemOneRequest + { systemOneRequestState = state + , systemOneRequestModel = fromMaybe defaultModel (optionModel options) + , systemOneRequestQuestions = rendered + } + , callOptions = noOptions + , callDecode = \rid body -> do + response <- first MalformedBody (eitherDecode' body) + first MismatchedAnswers (decodeEvaluation questions rid response) + } + +-- | Send a wire-level request as-is and receive the raw answers. +-- +-- Nothing is validated locally. The model is the one in the request unless +-- 'withModel' overrides it. +systemOneRaw :: SystemOneRequest -> Call (Evaluation (Map QuestionId Answer)) +systemOneRaw request = + Call + { callMethod = "POST" + , callPath = ["v1", "systemone"] + , callBody = Just $ \options _ -> + Right . encodeRequest options $ + request + { systemOneRequestModel = + fromMaybe (systemOneRequestModel request) (optionModel options) + } + , callOptions = noOptions + , callDecode = \rid body -> do + response <- first MalformedBody (eitherDecode' body) + pure (evaluation rid response (systemOneResponseAnswers response)) + } + +-- | List the models and aliases available to the account +-- (@GET \/v1\/models@). +-- +-- Versioned model ids are accepted by the @model@ field whether or not they +-- are listed. +listModels :: Call [ModelMetadata] +listModels = + Call + { callMethod = "GET" + , callPath = ["v1", "models"] + , callBody = Nothing + , callOptions = noOptions + , callDecode = \_ body -> modelMetadataListModels <$> first MalformedBody (eitherDecode' body) + } + +encodeRequest :: CallOptions -> SystemOneRequest -> LBS.ByteString +encodeRequest options r = + Encoding.encodingToLazyByteString . pairs $ + "state" .= systemOneRequestState r + <> "model" .= systemOneRequestModel r + <> "questions" .= systemOneRequestQuestions r + <> foldMap + (uncurry (.=)) + [ kv + | kv@(k, _) <- KeyMap.toList (optionExtraBody options) + , k `notElem` ["state", "model", "questions"] + ] + +------------------------------------------------------------------------------ +-- Evaluations + +-- | The result of a 'systemOne' call: your typed answers, plus what the API +-- reported about the request. +data Evaluation a = Evaluation + { evaluationAnswers :: !a + -- ^ The decoded answers. + , evaluationModel :: !ModelName + -- ^ The versioned model that answered. Log it to know which model + -- produced a result when you request an alias. + , evaluationUsage :: !Usage + -- ^ Token usage. + , evaluationRequestId :: !(Maybe RequestId) + -- ^ The request id assigned by the API. + , evaluationResponse :: !SystemOneResponse + -- ^ The complete response, including answers the typed questions did not + -- ask for. + } + deriving stock (Eq, Show, Generic, Functor, Foldable, Traversable) + deriving anyclass (NFData) + +evaluation :: Maybe RequestId -> SystemOneResponse -> a -> Evaluation a +evaluation rid response a = + Evaluation + { evaluationAnswers = a + , evaluationModel = systemOneResponseModel response + , evaluationUsage = systemOneResponseUsage response + , evaluationRequestId = rid + , evaluationResponse = response + } + +-- | Build the wire request for typed questions, for sending with your own +-- HTTP client, such as servant. Pair it with 'decodeEvaluation'. +systemOneRequest :: ModelName -> Content -> Questions a -> Either RequestError SystemOneRequest +systemOneRequest model state questions = + SystemOneRequest state model <$> renderQuestions questions + +-- | Decode a response to a request built with 'systemOneRequest'. The request +-- id is the @x-typesafe-request-id@ response header, if you have it. +decodeEvaluation + :: Questions a + -> Maybe RequestId + -> SystemOneResponse + -> Either (NonEmpty AnswerError) (Evaluation a) +decodeEvaluation questions rid response = + evaluation rid response <$> decodeAnswers questions (systemOneResponseAnswers response) + +------------------------------------------------------------------------------ +-- Options + +-- | Use this model (a versioned id or an alias) instead of the default. +withModel :: ModelName -> Call a -> Call a +withModel m = overOptions (\o -> o {optionModel = Just m}) + +-- | Send extra headers with this call. They override headers of the same name +-- configured on the client, but never the 'protectedHeaders'. +withHeaders :: RequestHeaders -> Call a -> Call a +withHeaders hs = overOptions (\o -> o {optionHeaders = optionHeaders o <> hs}) + +-- | Add top-level fields to the request body, to use API features that this +-- SDK does not know about yet. Fields the SDK sets itself (@state@, @model@, +-- @questions@) cannot be overridden this way. Only send fields the API +-- supports. +withExtraBody :: Object -> Call a -> Call a +withExtraBody extra = overOptions (\o -> o {optionExtraBody = extra <> optionExtraBody o}) + +-- | Retry this call with a different policy than the client's. +withRetryPolicy :: RetryPolicy -> Call a -> Call a +withRetryPolicy p = overOptions (\o -> o {optionRetryPolicy = Just p}) + +-- | Wait at most this many seconds for each attempt of this call. +withTimeout :: NominalDiffTime -> Call a -> Call a +withTimeout t = overOptions (\o -> o {optionTimeout = Just t}) + +overOptions :: (CallOptions -> CallOptions) -> Call a -> Call a +overOptions f c = c {callOptions = f (callOptions c)} + +------------------------------------------------------------------------------ +-- Transports + +-- | Client-wide settings a transport supplies when rendering a call. +data CallDefaults = CallDefaults + { callDefaultModel :: !ModelName + -- ^ The model used unless the call sets one. + , callDefaultHeaders :: !RequestHeaders + -- ^ Extra headers for every call. + } + deriving stock (Eq, Show) + +-- | An HTTP request, ready to send. +-- +-- The transport adds the base URL, the @Authorization: Bearer …@ header and +-- its @User-Agent@. +data HttpRequest = HttpRequest + { httpRequestMethod :: !Method + , httpRequestPath :: ![Text] + -- ^ Path segments, relative to the base URL. + , httpRequestHeaders :: !RequestHeaders + , httpRequestBody :: !(Maybe LBS.ByteString) + -- ^ A JSON body, if the call has one. + } + deriving stock (Eq, Show) + +-- | An HTTP response, as received by the transport. +data HttpResponse = HttpResponse + { httpResponseStatus :: !Status + , httpResponseHeaders :: !ResponseHeaders + , httpResponseBody :: !LBS.ByteString + } + deriving stock (Eq, Show) + +-- | Render a call, or report why it cannot be sent. +renderCall :: CallDefaults -> Call a -> Either TypeSafeError HttpRequest +renderCall defaults call = do + body <- + traverse + (\encode -> first InvalidRequest (encode options (callDefaultModel defaults))) + (callBody call) + pure + HttpRequest + { httpRequestMethod = callMethod call + , httpRequestPath = callPath call + , httpRequestHeaders = + ("Accept", "application/json") + : [("Content-Type", "application/json") | isJust body] + <> overriding (optionHeaders options) (callDefaultHeaders defaults) + , httpRequestBody = body + } + where + options = callOptions call + overriding preferred fallback = + filter + ((`notElem` protectedHeaders) . fst) + (preferred <> [h | h@(name, _) <- fallback, name `notElem` map fst preferred]) + +-- | Decode a response: the call's result for a 2xx status, a 'ServiceError' +-- otherwise. +parseResponse :: Call a -> HttpResponse -> Either TypeSafeError a +parseResponse call response + | statusIsSuccessful status = + first + (\problem -> ResponseError (UnexpectedResponse (callEndpoint call) rid problem body)) + (callDecode call rid body) + | otherwise = + Left (ServiceError (apiErrorFromResponse (callEndpoint call) status headers body)) + where + status = httpResponseStatus response + headers = httpResponseHeaders response + body = httpResponseBody response + rid = RequestId . Text.decodeUtf8With Text.lenientDecode <$> lookup requestIdHeader headers + +-- | The method and path of a call, such as @POST \/v1\/systemone@, for logs +-- and error messages. +callEndpoint :: Call a -> Text +callEndpoint c = + Text.decodeUtf8With Text.lenientDecode (callMethod c) <> " /" <> Text.intercalate "/" (callPath c) + +-- | The retry policy set with 'withRetryPolicy', if any. +callRetryPolicy :: Call a -> Maybe RetryPolicy +callRetryPolicy = optionRetryPolicy . callOptions + +-- | The per-attempt timeout set with 'withTimeout', if any. +callTimeout :: Call a -> Maybe NominalDiffTime +callTimeout = optionTimeout . callOptions + +-- | Headers that only the SDK sets: authentication, content negotiation and +-- SDK identification. Extra headers with these names are dropped. +protectedHeaders :: [HeaderName] +protectedHeaders = ["Authorization", "Accept", "Content-Type", "Content-Length", "User-Agent"] + +-- | @https:\/\/api.typesafe.ai@ +defaultBaseUrl :: Text +defaultBaseUrl = "https://api.typesafe.ai" + +-- | The response header that carries the request id. +requestIdHeader :: HeaderName +requestIdHeader = "x-typesafe-request-id" diff --git a/typesafe-ai-core/src/TypeSafe/Content.hs b/typesafe-ai-core/src/TypeSafe/Content.hs new file mode 100644 index 0000000..0491d30 --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Content.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : TypeSafe.Content +-- Description : Text or structured JSON content +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- The TypeSafe API accepts /content/ in several places: the @state@ being +-- evaluated, a question's @instructions@, the descriptions of Choice options, +-- Score levels and Noul criteria. Everywhere, content is either a plain string +-- or structured JSON (an object or an array). Numbers, booleans and @null@ are +-- not valid content on their own. +-- +-- 'Content' models exactly that. With @OverloadedStrings@ a string literal is +-- 'Content': +-- +-- >>> encode ("Help! My payouts have been failing for 3 days." :: Content) +-- "\"Help! My payouts have been failing for 3 days.\"" +-- +-- Structured content is usually built with 'contentObject' or, for any type +-- with a 'ToJSON' instance, 'contentJSON': +-- +-- >>> encode (contentObject ["subject" .= ("Duplicate charge" :: Text), "priority" .= (2 :: Int)]) +-- "{\"priority\":2,\"subject\":\"Duplicate charge\"}" +-- +-- See for advice on structuring +-- state, and for structured +-- instructions and criteria. +module TypeSafe.Content + ( Content (..) + , contentText + , contentObject + , contentArray + , contentJSON + , contentFromValue + , contentToValue + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson + ( FromJSON (..) + , Object + , ToJSON (..) + , Value (..) + ) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (Array, Pair) +import Data.String (IsString (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Vector as Vector +import GHC.Generics (Generic) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Aeson (encode, (.=), toJSON) +-- >>> import Data.Text (Text) + +-- | Text, or a structured JSON object or array. +-- +-- Use 'ContentText' (or a string literal) for prose, and 'ContentObject' or +-- 'ContentArray' for records, chat logs and other structured data. Questions +-- can point at fields of structured state by path, for example +-- @\"Does \`ticket.messages[0].text\` request a refund?\"@. +data Content + = -- | A plain string. + ContentText !Text + | -- | A JSON object. + ContentObject !Object + | -- | A JSON array. + ContentArray !Array + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | String literals are 'ContentText'. +instance IsString Content where + fromString = ContentText . Text.pack + +instance ToJSON Content where + toJSON = contentToValue + toEncoding = \case + ContentText t -> toEncoding t + ContentObject o -> toEncoding o + ContentArray a -> toEncoding a + +-- | Accepts a string, object or array; rejects numbers, booleans and @null@. +instance FromJSON Content where + parseJSON v = case contentFromValue v of + Just c -> pure c + Nothing -> fail ("expected a string, an object or an array, but got " <> describe v) + where + describe = \case + Number _ -> "a number" + Bool _ -> "a boolean" + Null -> "null" + _ -> "an unsupported value" + +-- | Plain text content. +contentText :: Text -> Content +contentText = ContentText + +-- | Build an object from key/value pairs, like 'Data.Aeson.object'. +-- +-- >>> encode (contentObject ["message" .= ("Please help." :: Text)]) +-- "{\"message\":\"Please help.\"}" +contentObject :: [Pair] -> Content +contentObject = ContentObject . KeyMap.fromList + +-- | Build an array of JSON values. +-- +-- >>> encode (contentArray [toJSON ("first" :: Text), toJSON ("second" :: Text)]) +-- "[\"first\",\"second\"]" +contentArray :: [Value] -> Content +contentArray = ContentArray . Vector.fromList + +-- | Content from any value with a 'ToJSON' instance. +-- +-- Objects, arrays and strings map to the matching constructor. A scalar +-- (number, boolean or @null@) is not valid content on its own, so it is sent +-- as its JSON text instead. +-- +-- >>> contentJSON (["a", "b"] :: [Text]) +-- ContentArray [String "a",String "b"] +-- +-- >>> contentJSON (42 :: Int) +-- ContentText "42" +contentJSON :: (ToJSON a) => a -> Content +contentJSON a = case toJSON a of + String t -> ContentText t + Object o -> ContentObject o + Array xs -> ContentArray xs + scalar -> ContentText (Text.decodeUtf8 (LBS.toStrict (Aeson.encode scalar))) + +-- | Convert a JSON value, if it is a string, object or array. +-- +-- >>> contentFromValue (toJSON True) +-- Nothing +contentFromValue :: Value -> Maybe Content +contentFromValue = \case + String t -> Just (ContentText t) + Object o -> Just (ContentObject o) + Array xs -> Just (ContentArray xs) + _ -> Nothing + +-- | The JSON value sent on the wire. +contentToValue :: Content -> Value +contentToValue = \case + ContentText t -> String t + ContentObject o -> Object o + ContentArray xs -> Array xs diff --git a/typesafe-ai-core/src/TypeSafe/Core.hs b/typesafe-ai-core/src/TypeSafe/Core.hs new file mode 100644 index 0000000..3136830 --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Core.hs @@ -0,0 +1,100 @@ +-- | +-- Module : TypeSafe.Core +-- Description : Types, codecs and calls for the TypeSafe API, without HTTP +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- Everything needed to talk to the TypeSafe System One API +-- () except the network. Most applications should +-- depend on the @typesafe-ai@ package instead, which re-exports this module +-- together with a ready-to-use client. +-- +-- Depend on @typesafe-ai-core@ directly when you want to bring your own HTTP +-- stack: this package depends only on @aeson@, @http-types@ and GHC's boot +-- libraries. +-- +-- = Layers +-- +-- ["TypeSafe.Question"] typed questions and answers: Choice options and +-- Score levels are your own Haskell types. +-- +-- ["TypeSafe.Call"] API calls as values, plus the functions a transport needs +-- to send them. +-- +-- ["TypeSafe.Wire"] the OpenAPI schemas, one Haskell type per schema, with +-- JSON codecs. Not re-exported here; import it (qualified) when you need it. +-- +-- ["TypeSafe.Error"], ["TypeSafe.Retry"] errors and the retry policy. +-- +-- = With servant or another HTTP library +-- +-- The wire types have 'Data.Aeson.ToJSON' and 'Data.Aeson.FromJSON' +-- instances, so describing the API in another framework takes a few lines. +-- With servant, for example: +-- +-- @ +-- import qualified TypeSafe.Wire as Wire +-- +-- type TypeSafeAPI = +-- Header' '[Required, Strict] \"Authorization\" Text +-- :> \"v1\" +-- :> ( \"systemone\" :> ReqBody '[JSON] Wire.SystemOneRequest :> Post '[JSON] Wire.SystemOneResponse +-- :\<|\> \"models\" :> Get '[JSON] Wire.ModelMetadataList +-- ) +-- @ +-- +-- The typed layer works with any such client: build the request with +-- 'systemOneRequest' and decode the response with 'decodeEvaluation'. +-- +-- @ +-- case 'systemOneRequest' 'jevLatest' state triage of +-- Left err -> … -- rejected locally +-- Right request -> do +-- response <- runClientM (systemOneClient auth request) env +-- … 'decodeEvaluation' triage Nothing response … +-- @ +-- +-- To reuse the retry policy, error classification and header handling of the +-- bundled client as well, write a transport instead: see "TypeSafe.Call". +module TypeSafe.Core + ( -- * Content + module TypeSafe.Content + + -- * Questions and answers + , module TypeSafe.Question + + -- * Calls + , module TypeSafe.Call + + -- * Errors + , module TypeSafe.Error + + -- * Retries + , module TypeSafe.Retry + + -- * Identifiers and response metadata + , ModelName (..) + , jevLatest + , jevPreview + , QuestionId (..) + , Usage (..) + , ModelMetadata (..) + , modelMetadataReleaseDay + , apiSpecVersion + ) where + +import TypeSafe.Call +import TypeSafe.Content +import TypeSafe.Error +import TypeSafe.Question +import TypeSafe.Retry +import TypeSafe.Wire + ( ModelMetadata (..) + , ModelName (..) + , QuestionId (..) + , Usage (..) + , apiSpecVersion + , jevLatest + , jevPreview + , modelMetadataReleaseDay + ) diff --git a/typesafe-ai-core/src/TypeSafe/Error.hs b/typesafe-ai-core/src/TypeSafe/Error.hs new file mode 100644 index 0000000..8a114ef --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Error.hs @@ -0,0 +1,397 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : TypeSafe.Error +-- Description : Everything that can go wrong, as values +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- Every failure the SDK reports is a 'TypeSafeError'. It separates four +-- situations that callers usually handle differently: +-- +-- ['InvalidRequest'] the request was rejected locally and nothing was sent, +-- for example two questions share an id. This is a bug in the calling code. +-- +-- ['ServiceError'] the API answered with an error status. 'apiErrorKind' +-- says which one ('Unauthorized', 'RateLimited', 'Overloaded', …). +-- +-- ['ConnectionError'] no HTTP response arrived: DNS, TLS, a reset +-- connection, or a timeout. +-- +-- ['ResponseError'] the API answered successfully, but the body did not match +-- what was asked, for example a choice outside the options you offered. +-- +-- Transports built on "TypeSafe.Call" retry transient failures (see +-- "TypeSafe.Retry") before reporting them. +module TypeSafe.Error + ( -- * Errors + TypeSafeError (..) + , renderTypeSafeError + + -- * Local request validation + , RequestError (..) + , QuestionProblem (..) + + -- * Error responses + , ApiError (..) + , ApiErrorKind (..) + , apiErrorKindFor + , apiErrorFromResponse + , ErrorBody (..) + , ErrorDetail (..) + , parseErrorBody + , RequestId (..) + + -- * Connection failures + , ConnectionError (..) + + -- * Unusable responses + , ResponseError (..) + , ResponseProblem (..) + , AnswerError (..) + , AnswerProblem (..) + ) where + +import Control.DeepSeq (NFData) +import Control.Exception (Exception (..), SomeException) +import Data.Aeson (FromJSON (..), Value (..), withObject, (.:?)) +import qualified Data.Aeson as Aeson +import Data.Aeson.Types (parseMaybe) +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as LBS +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Maybe (fromMaybe, listToMaybe) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import GHC.Generics (Generic) +import Network.HTTP.Types (ResponseHeaders, Status (..)) +import TypeSafe.Wire + ( HTTPValidationError (..) + , LocationSegment (..) + , QuestionId (..) + , ValidationError (..) + ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Network.HTTP.Types (status401, status422, status429) + +-- | Any failure reported by the SDK. +-- +-- 'displayException' renders a one-line, human-readable summary (see +-- 'renderTypeSafeError'). API keys are never part of an error. +data TypeSafeError + = -- | The request was rejected before anything was sent. + InvalidRequest !RequestError + | -- | The API answered with an error status. + ServiceError !ApiError + | -- | No HTTP response was received. + ConnectionError !ConnectionError + | -- | A successful response that does not match the request. + ResponseError !ResponseError + deriving stock (Show, Generic) + +instance Exception TypeSafeError where + displayException = Text.unpack . renderTypeSafeError + +-- | A one-line, human-readable description of an error. +-- +-- >>> renderTypeSafeError (InvalidRequest (DuplicateQuestionId "is_urgent")) +-- "invalid request: two questions use the id \"is_urgent\"" +renderTypeSafeError :: TypeSafeError -> Text +renderTypeSafeError = \case + InvalidRequest e -> "invalid request: " <> renderRequestError e + ServiceError e -> + apiErrorEndpoint e + <> " failed with HTTP " + <> tshow (statusCode (apiErrorStatus e)) + <> " (" + <> tshow (apiErrorKind e) + <> ")" + <> maybe "" (": " <>) (apiErrorMessage e) + <> requestIdSuffix (apiErrorRequestId e) + ConnectionError (ConnectionFailed endpoint cause) -> + endpoint <> ": connection failed: " <> Text.pack (displayException cause) + ConnectionError (ConnectionTimedOut endpoint) -> + endpoint <> ": timed out waiting for a response" + ResponseError e -> + responseErrorEndpoint e + <> ": unexpected response: " + <> renderProblem (responseErrorProblem e) + <> requestIdSuffix (responseErrorRequestId e) + where + requestIdSuffix = maybe "" (\(RequestId r) -> " [request id " <> r <> "]") + renderProblem = \case + MalformedBody msg -> Text.pack msg + MismatchedAnswers errs -> Text.intercalate "; " (map renderAnswerError (NonEmpty.toList errs)) + +renderRequestError :: RequestError -> Text +renderRequestError = \case + NoQuestions -> "a request needs at least one question" + DuplicateQuestionId (QuestionId q) -> "two questions use the id " <> tshow q + InvalidQuestion (QuestionId q) problem -> "question " <> tshow q <> ": " <> renderQuestionProblem problem + where + renderQuestionProblem = \case + DuplicateOption o -> "two options are named " <> tshow o + +renderAnswerError :: AnswerError -> Text +renderAnswerError (AnswerError (QuestionId q) problem) = + "question " <> tshow q <> ": " <> case problem of + MissingAnswer -> "no answer in the response" + UnexpectedAnswerType expected actual -> "expected a " <> expected <> " answer, got " <> actual + UnknownOption o -> "the answer mentions option " <> tshow o <> ", which was not offered" + UnknownLevel l -> "the answer mentions level " <> tshow l <> ", which is outside the rubric" + UndecodableAnswer msg -> msg + +------------------------------------------------------------------------------ +-- Request validation + +-- | Why a request was rejected before sending. +data RequestError + = -- | The request has no questions. The API requires at least one. + NoQuestions + | -- | Two questions share an id, so their answers could not be told apart. + DuplicateQuestionId !QuestionId + | -- | A question is malformed. + InvalidQuestion !QuestionId !QuestionProblem + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | What is wrong with a single question. +data QuestionProblem + = -- | Two Choice options map to the same name. + DuplicateOption !Text + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +------------------------------------------------------------------------------ +-- Error responses + +-- | The value of the @x-typesafe-request-id@ response header. Include it when +-- you contact TypeSafe support about a request. +newtype RequestId = RequestId {unRequestId :: Text} + deriving newtype (Eq, Ord, Show, IsString, NFData) + +-- | An error response from the API. +data ApiError = ApiError + { apiErrorKind :: !ApiErrorKind + -- ^ What the status code means. + , apiErrorStatus :: !Status + -- ^ The HTTP status. + , apiErrorMessage :: !(Maybe Text) + -- ^ The server's explanation, when the body has one. + , apiErrorBody :: !ErrorBody + -- ^ The parsed response body. + , apiErrorHeaders :: !ResponseHeaders + -- ^ The response headers, including any @Retry-After@. + , apiErrorRequestId :: !(Maybe RequestId) + -- ^ The request id assigned by the API. + , apiErrorEndpoint :: !Text + -- ^ The method and path that failed, such as @POST \/v1\/systemone@. + } + deriving stock (Eq, Show, Generic) + +-- | The meaning of an error status. +data ApiErrorKind + = -- | 400: the request is invalid. + BadRequest + | -- | 401: the API key is invalid. + Unauthorized + | -- | 403: access is denied. The API also uses this status when no API key + -- is sent. + PermissionDenied + | -- | 404: the resource does not exist. Check the base URL. + NotFound + | -- | 422: the body failed validation. The 'ErrorBody' says which field. + UnprocessableEntity + | -- | 429: the rate limit is exceeded. Retry after a delay. + RateLimited + | -- | 529: TypeSafe is temporarily overloaded. Retry after a delay. + Overloaded + | -- | Any other 5xx status. + InternalServerError + | -- | Any other status. + UnexpectedStatus + deriving stock (Eq, Ord, Show, Read, Enum, Bounded, Generic) + deriving anyclass (NFData) + +-- | Classify an error status. +-- +-- >>> map apiErrorKindFor [status401, status422, status429, toEnum 529, toEnum 503, toEnum 418] +-- [Unauthorized,UnprocessableEntity,RateLimited,Overloaded,InternalServerError,UnexpectedStatus] +apiErrorKindFor :: Status -> ApiErrorKind +apiErrorKindFor s = case statusCode s of + 400 -> BadRequest + 401 -> Unauthorized + 403 -> PermissionDenied + 404 -> NotFound + 422 -> UnprocessableEntity + 429 -> RateLimited + 529 -> Overloaded + c + | c >= 500 && c < 600 -> InternalServerError + | otherwise -> UnexpectedStatus + +-- | Build an 'ApiError' from the endpoint (for example +-- @\"POST \/v1\/systemone\"@) and an error response. +apiErrorFromResponse :: Text -> Status -> ResponseHeaders -> LBS.ByteString -> ApiError +apiErrorFromResponse endpoint status headers body = + ApiError + { apiErrorKind = apiErrorKindFor status + , apiErrorStatus = status + , apiErrorMessage = errorBodyMessage parsed + , apiErrorBody = parsed + , apiErrorHeaders = headers + , apiErrorRequestId = RequestId . decodeLenient <$> lookup "x-typesafe-request-id" headers + , apiErrorEndpoint = endpoint + } + where + parsed = parseErrorBody body + +-- | The body of an error response. +data ErrorBody + = -- | Field-level validation failures, sent with HTTP 422. + BodyValidation !HTTPValidationError + | -- | A structured error, such as + -- @{\"detail\": {\"error_type\": \"authentication_error\", \"message\": …}}@. + BodyDetail !ErrorDetail + | -- | Some other JSON document. + BodyJson !Value + | -- | A body that is not JSON. + BodyText !Text + | -- | No body. + BodyEmpty + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The @detail@ object of a structured error. +data ErrorDetail = ErrorDetail + { errorDetailType :: !(Maybe Text) + -- ^ A machine-readable category, such as @authentication_error@. + , errorDetailMessage :: !(Maybe Text) + -- ^ A human-readable explanation. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | Parse an error response body. +-- +-- >>> parseErrorBody "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Cannot authenticate with the server.\"}}" +-- BodyDetail (ErrorDetail {errorDetailType = Just "authentication_error", errorDetailMessage = Just "Cannot authenticate with the server."}) +-- +-- >>> parseErrorBody "{\"detail\":\"Not Found\"}" +-- BodyDetail (ErrorDetail {errorDetailType = Nothing, errorDetailMessage = Just "Not Found"}) +-- +-- >>> parseErrorBody "upstream connect error" +-- BodyText "upstream connect error" +parseErrorBody :: LBS.ByteString -> ErrorBody +parseErrorBody body + | BS8.all (`elem` (" \t\r\n" :: String)) (LBS.toStrict body) = BodyEmpty + | otherwise = case Aeson.decode' body of + Nothing -> BodyText (decodeLenient (LBS.toStrict body)) + Just v -> fromMaybe (BodyJson v) (parseMaybe structured v) + where + structured = withObject "error" $ \o -> do + detail <- o .:? "detail" + case detail of + Just (Array _) -> BodyValidation <$> parseJSON (Object o) + Just (String msg) -> pure (BodyDetail (ErrorDetail Nothing (Just msg))) + Just (Object d) -> BodyDetail <$> (ErrorDetail <$> d .:? "error_type" <*> d .:? "message") + _ -> fail "not a structured error" + +errorBodyMessage :: ErrorBody -> Maybe Text +errorBodyMessage = \case + BodyDetail d -> errorDetailMessage d + BodyValidation v -> renderValidation <$> (httpValidationErrorDetail v >>= listToMaybe) + BodyText t -> Just (Text.take 500 t) + BodyJson _ -> Nothing + BodyEmpty -> Nothing + where + renderValidation e = + Text.intercalate "." (map segment (validationErrorLoc e)) <> ": " <> validationErrorMsg e + segment = \case + LocationField f -> f + LocationIndex i -> tshow i + +------------------------------------------------------------------------------ +-- Connection failures + +-- | A request that got no HTTP response. The 'Text' is the endpoint, such as +-- @POST \/v1\/systemone@. +data ConnectionError + = -- | The connection could not be made or broke: DNS, TLS, refused or reset. + -- The exception comes from the transport; the SDK redacts credentials + -- from it. + ConnectionFailed !Text !SomeException + | -- | No response arrived within the timeout. + ConnectionTimedOut !Text + deriving stock (Show, Generic) + +------------------------------------------------------------------------------ +-- Unusable responses + +-- | A successful response that could not be used. +data ResponseError = UnexpectedResponse + { responseErrorEndpoint :: !Text + -- ^ The method and path, such as @POST \/v1\/systemone@. + , responseErrorRequestId :: !(Maybe RequestId) + -- ^ The request id assigned by the API. + , responseErrorProblem :: !ResponseProblem + -- ^ What is wrong. + , responseErrorBody :: !LBS.ByteString + -- ^ The raw response body. + } + deriving stock (Eq, Show, Generic) + +-- | What is wrong with a successful response. +data ResponseProblem + = -- | The body does not match the response schema. The message includes a + -- JSON path to the offending value. + MalformedBody !String + | -- | The body is valid, but some answers do not fit their questions. + MismatchedAnswers !(NonEmpty AnswerError) + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | A problem with the answer to one question. +data AnswerError = AnswerError + { answerErrorQuestion :: !QuestionId + -- ^ The question whose answer is unusable. + , answerErrorProblem :: !AnswerProblem + -- ^ What is wrong with it. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | What is wrong with an answer. +data AnswerProblem + = -- | The response has no answer for the question. + MissingAnswer + | -- | The answer is of a different type: expected, then actual. + UnexpectedAnswerType !Text !Text + | -- | The answer names a Choice option that was not offered. + UnknownOption !Text + | -- | The answer names a Score level outside the rubric. + UnknownLevel !Int + | -- | A custom decoder (see 'TypeSafe.Question.otherQuestion') rejected the + -- answer. + UndecodableAnswer !Text + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +------------------------------------------------------------------------------ + +decodeLenient :: BS8.ByteString -> Text +decodeLenient = Text.decodeUtf8With Text.lenientDecode + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/typesafe-ai-core/src/TypeSafe/Internal/Generic.hs b/typesafe-ai-core/src/TypeSafe/Internal/Generic.hs new file mode 100644 index 0000000..c16d766 --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Internal/Generic.hs @@ -0,0 +1,93 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | +-- Module : TypeSafe.Internal.Generic +-- Description : Generic enumeration of nullary constructors +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- Support code for the default methods of 'TypeSafe.Question.ChoiceOption' +-- and 'TypeSafe.Question.ScoreLevel'. It is exposed so that the constraints of +-- those defaults can be named in user code; its contents may change between +-- minor versions. +module TypeSafe.Internal.Generic + ( GEnumerate (..) + , GConstructorName (..) + , genericEnumerate + , genericConstructorName + ) where + +import Data.Kind (Type) +import Data.List.NonEmpty (NonEmpty (..)) +import GHC.Generics +import GHC.TypeLits (ErrorMessage (..), TypeError) + +-- | Types whose generic representation is a sum of constructors without +-- fields. +class GEnumerate (f :: Type -> Type) where + -- | Every value, in declaration order. + genumerate :: [f p] + +instance GEnumerate U1 where + genumerate = [U1] + +instance (GEnumerate f, GEnumerate g) => GEnumerate (f :+: g) where + genumerate = map L1 genumerate <> map R1 genumerate + +instance (GEnumerate f) => GEnumerate (D1 c f) where + genumerate = map M1 genumerate + +instance (GEnumerate f) => GEnumerate (C1 c f) where + genumerate = map M1 genumerate + +instance + ( TypeError + ( 'Text "Cannot derive the options of a type whose constructors have fields." + ':$$: 'Text "Choice options and Score levels are derived for enumerations such as" + ':$$: 'Text " data Department = Billing | Technical | Sales" + ':$$: 'Text "Implement the class methods by hand, or use choiceBy / scoreBy." + ) + ) => + GEnumerate (S1 c f) + where + genumerate = [] + +instance + ( TypeError + ( 'Text "Cannot derive the options of a type without constructors." + ':$$: 'Text "A Choice needs at least one option and a Score at least one level." + ) + ) => + GEnumerate V1 + where + genumerate = [] + +-- | Every constructor of an enumeration, in declaration order. +genericEnumerate :: (Generic a, GEnumerate (Rep a)) => NonEmpty a +genericEnumerate = case map to genumerate of + x : xs -> x :| xs + -- Unreachable: types without constructors are rejected by the V1 instance. + [] -> error "TypeSafe.Internal.Generic.genericEnumerate: no constructors" + +-- | Types whose generic representation lets us name the constructor. +class GConstructorName (f :: Type -> Type) where + gconstructorName :: f p -> String + +instance (GConstructorName f) => GConstructorName (D1 c f) where + gconstructorName (M1 x) = gconstructorName x + +instance (GConstructorName f, GConstructorName g) => GConstructorName (f :+: g) where + gconstructorName (L1 x) = gconstructorName x + gconstructorName (R1 x) = gconstructorName x + +instance (Constructor c) => GConstructorName (C1 c f) where + gconstructorName = conName + +-- | The name of the constructor used to build a value. +genericConstructorName :: (Generic a, GConstructorName (Rep a)) => a -> String +genericConstructorName = gconstructorName . from diff --git a/typesafe-ai-core/src/TypeSafe/Question.hs b/typesafe-ai-core/src/TypeSafe/Question.hs new file mode 100644 index 0000000..56af0b5 --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Question.hs @@ -0,0 +1,695 @@ +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : TypeSafe.Question +-- Description : Typed questions, typed answers +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- TypeSafe has three kinds of question, and each comes back as a different +-- kind of answer: +-- +-- +------------+---------------------------+-----------------------------------------+ +-- | Question | Asks | Answer | +-- +============+===========================+=========================================+ +-- | 'noul' | Is this true? | 'Noul': the probability of yes | +-- +------------+---------------------------+-----------------------------------------+ +-- | 'choice' | Which of these options? | 'Choice': the option, its distribution | +-- | | | and a confidence | +-- +------------+---------------------------+-----------------------------------------+ +-- | 'score' | Which level of a rubric? | 'Score': an expected level, its | +-- | | | distribution and a confidence | +-- +------------+---------------------------+-----------------------------------------+ +-- +-- A @'Question' a@ is one question whose answer decodes to an @a@. Choice +-- options and Score levels are ordinary Haskell types, so an answer can only +-- ever be one of the values you offered. +-- +-- Questions are combined into a request with 'ask' and the 'Applicative' +-- instance of 'Questions'. Each question needs an id, and the ids of one +-- request must be distinct. +-- +-- = Example +-- +-- Declare the options and levels as enumerations: +-- +-- >>> :{ +-- data Department = Billing | Technical | Sales +-- deriving stock (Show, Eq, Generic) +-- deriving anyclass (ChoiceOption) +-- :} +-- +-- >>> :{ +-- data Frustration = Calm | Frustrated | VeryAngry +-- deriving stock (Show, Eq, Generic) +-- deriving anyclass (ScoreLevel) +-- :} +-- +-- Then describe the result you want and the questions that produce it: +-- +-- >>> :{ +-- data Triage = Triage +-- { department :: Choice Department +-- , urgent :: Noul +-- , frustration :: Score Frustration +-- } +-- :} +-- +-- >>> :{ +-- triage :: Questions Triage +-- triage = +-- Triage +-- <$> ask "department" (choice "Which team should handle this?") +-- <*> ask "is_urgent" (noul "Does this convey urgency?") +-- <*> ask "frustration" (score "How frustrated is the customer?") +-- :} +-- +-- The option and level names come from the constructors: @Billing@ is sent +-- as @billing@ and @VeryAngry@ as @very angry@. Override 'optionName', +-- 'optionDescription' and 'levelDescription' to say more. +-- +-- @triage@ renders to the @questions@ of an API request +-- +-- >>> either print (LBS.putStrLn . encode) (renderQuestions triage) +-- {"department":{"type":"choice","instructions":"Which team should handle this?","criteria":{"billing":null,"technical":null,"sales":null}},"frustration":{"type":"score","instructions":"How frustrated is the customer?","criteria":["calm","frustrated","very angry"]},"is_urgent":{"type":"noul","instructions":"Does this convey urgency?"}} +-- +-- and decodes the answers of the response: +-- +-- >>> :{ +-- let Right answers = eitherDecode $ LBS.concat +-- [ "{\"department\":{\"type\":\"choice\",\"choice\":\"billing\",\"confidence\":0.81," +-- , "\"probabilities\":{\"billing\":0.88,\"technical\":0.12,\"sales\":0.0}}," +-- , "\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95}," +-- , "\"frustration\":{\"type\":\"score\",\"score\":1.05,\"confidence\":0.92," +-- , "\"legend\":{\"0\":\"calm\",\"1\":\"frustrated\",\"2\":\"very angry\"}," +-- , "\"probabilities\":{\"0\":0.0,\"1\":0.95,\"2\":0.05}}}" +-- ] +-- :} +-- +-- >>> let Right result = decodeAnswers triage answers +-- >>> choiceSelected (department result) +-- Billing +-- >>> noulProbability (urgent result) +-- 0.95 +-- >>> mostLikelyLevel (frustration result) +-- Frustrated +-- +-- In a program you rarely call 'renderQuestions' or 'decodeAnswers' +-- yourself. Pass the 'Questions' to 'TypeSafe.Call.systemOne' and send the +-- call with a client, such as @TypeSafe.Client.send@ from the @typesafe-ai@ +-- package. +-- +-- = Why there is no @Monad@ +-- +-- 'Questions' is an 'Applicative' and deliberately not a 'Monad'. Every +-- question in a request sees the same state and is answered independently, in +-- parallel. A question cannot depend on another one's answer, so the types +-- do not let you write one that does. When a follow-up question really +-- depends on an answer, send a second request. +-- +-- With @ApplicativeDo@ you can still use @do@ notation, provided no question +-- uses an earlier answer: +-- +-- @ +-- {-# LANGUAGE ApplicativeDo #-} +-- +-- triage :: 'Questions' Triage +-- triage = do +-- department <- 'ask' \"department\" ('choice' \"Which team should handle this?\") +-- urgent <- 'ask' \"is_urgent\" ('noul' \"Does this convey urgency?\") +-- frustration <- 'ask' \"frustration\" ('score' \"How frustrated is the customer?\") +-- pure Triage {..} +-- @ +-- +-- = Many questions at once +-- +-- 'Questions' is 'Traversable'-friendly, so fan-out patterns such as +-- scoring every passage of a search result are one 'traverse': +-- +-- @ +-- relevance :: Text -> [Text] -> 'Questions' [(Text, 'Noul')] +-- relevance query passages = +-- for (zip [0 :: Int ..] passages) $ \\(i, passage) -> +-- (,) passage +-- \<$\> 'ask' ('QuestionId' (\"passage_\" <> Text.pack (show i))) +-- ('noul' ('TypeSafe.Content.contentObject' [\"query\" .= query, \"passage\" .= passage, \"question\" .= (\"Does \`passage\` answer \`query\`?\" :: Text)])) +-- @ +module TypeSafe.Question + ( -- * Asking questions + Questions + , ask + , askMap + , questionIds + , renderQuestions + , decodeAnswers + + -- * A single question + , Question + , questionSpec + , decodeAnswer + + -- * Noul: yes or no + , noul + , noulWith + , Noul (..) + + -- * Choice: one of several options + , choice + , choiceBy + , ChoiceOption (..) + , Choice (..) + , choiceProbability + , rankedChoices + + -- * Score: a level of a rubric + , score + , scoreBy + , scoreRubric + , ScoreLevel (..) + , Score (..) + , scoreProbability + , mostLikelyLevel + , nearestLevel + , normalizedScore + + -- * Other question types + , rawQuestion + , otherQuestion + + -- * Probability and confidence + , Probability (..) + , Confidence (..) + , HasConfidence (..) + ) where + +import Control.DeepSeq (NFData) +import Control.Monad (unless) +import Data.Aeson (FromJSON (..), Object, ToJSON (..), camelTo2) +import Data.Aeson.Types (parseEither) +import Data.Bifunctor (first) +import Data.Foldable (toList, traverse_) +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import Data.Maybe (fromMaybe) +import qualified Data.Map.Strict as Map +import Data.Ord (Down (..)) +import Data.Sequence (Seq) +import qualified Data.Sequence as Seq +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import GHC.Generics (Generic, Rep) +import TypeSafe.Content (Content (..)) +import TypeSafe.Error + ( AnswerError (..) + , AnswerProblem (..) + , QuestionProblem (..) + , RequestError (..) + ) +import TypeSafe.Internal.Generic + ( GConstructorName + , GEnumerate + , genericConstructorName + , genericEnumerate + ) +import TypeSafe.Wire (QuestionId (..)) +import qualified TypeSafe.Wire as Wire + +-- $setup +-- >>> :set -XOverloadedStrings -XDeriveGeneric -XDeriveAnyClass -XDerivingStrategies +-- >>> import GHC.Generics (Generic) +-- >>> import Data.Aeson (encode, eitherDecode) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS + +------------------------------------------------------------------------------ +-- Probability and confidence + +-- | A probability between 0 and 1. +-- +-- Numeric literals work directly, so thresholds read naturally: +-- @noulProbability answer >= 0.8@. +newtype Probability = Probability {unProbability :: Double} + deriving newtype (Eq, Ord, Show, Num, Fractional, Floating, Real, RealFrac, NFData, ToJSON, FromJSON) + +-- | How certain the model is about a Choice or a Score, between 0 and 1. +-- +-- Confidence is derived from the shape of the probability distribution: a +-- peaked distribution gives high confidence. It is not the probability of the +-- selected option. Use it to decide whether to act on an answer or escalate +-- it; see . +newtype Confidence = Confidence {unConfidence :: Double} + deriving newtype (Eq, Ord, Show, Num, Fractional, Floating, Real, RealFrac, NFData, ToJSON, FromJSON) + +-- | Answers that report a 'Confidence'. +class HasConfidence a where + confidence :: a -> Confidence + +------------------------------------------------------------------------------ +-- Answers + +-- | The answer to a 'noul' question. +newtype Noul = Noul + { noulProbability :: Probability + -- ^ The probability that the answer is yes. Near 1 is a strong yes, near 0 + -- a strong no, and near 0.5 means the model is unsure. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The answer to a 'choice' question over options of type @a@. +data Choice a = Choice + { choiceSelected :: !a + -- ^ The option with the highest probability. + , choiceProbabilities :: !(NonEmpty (a, Probability)) + -- ^ Every option offered, in the order it was offered, with its + -- probability. The probabilities sum to approximately 1. + , choiceConfidence :: !Confidence + -- ^ How certain the model is. + } + deriving stock (Eq, Show, Generic, Functor) + deriving anyclass (NFData) + +instance HasConfidence (Choice a) where + confidence = choiceConfidence + +-- | The probability of one option. +-- +-- >>> choiceProbability "technical" (Choice "billing" (("billing", 0.88) :| [("technical", 0.12)]) 0.81) +-- 0.12 +choiceProbability :: (Eq a) => a -> Choice a -> Probability +choiceProbability o = fromMaybe 0 . lookup o . toList . choiceProbabilities + +-- | The options from most to least likely. Options with equal probability +-- keep the order they were offered in. +-- +-- >>> rankedChoices (Choice "billing" (("sales", 0.02) :| [("billing", 0.88), ("technical", 0.1)]) 0.81) +-- ("billing",0.88) :| [("technical",0.1),("sales",2.0e-2)] +rankedChoices :: Choice a -> NonEmpty (a, Probability) +rankedChoices = NonEmpty.sortWith (Down . snd) . choiceProbabilities + +-- | The answer to a 'score' question over levels of type @a@. +data Score a = Score + { scoreValue :: !Double + -- ^ The expected level: the probability-weighted average of the level + -- indices, counting from 0. It can fall between two levels. + , scoreProbabilities :: !(NonEmpty (a, Probability)) + -- ^ Every level, lowest first, with its probability. The probabilities + -- sum to approximately 1. + , scoreConfidence :: !Confidence + -- ^ How certain the model is. + } + deriving stock (Eq, Show, Generic, Functor) + deriving anyclass (NFData) + +instance HasConfidence (Score a) where + confidence = scoreConfidence + +-- | The probability of one level. +scoreProbability :: (Eq a) => a -> Score a -> Probability +scoreProbability l = fromMaybe 0 . lookup l . toList . scoreProbabilities + +-- | The level with the highest probability. On a tie, the lower level wins. +-- +-- >>> mostLikelyLevel (Score 1.05 (("calm", 0) :| [("frustrated", 0.95), ("very angry", 0.05)]) 0.92) +-- "frustrated" +mostLikelyLevel :: Score a -> a +mostLikelyLevel = fst . foldr1 higher . scoreProbabilities + where + higher x y = if snd y > snd x then y else x + +-- | The level closest to 'scoreValue'. +-- +-- The expected level blends the distribution, so it can differ from +-- 'mostLikelyLevel' when the probability mass is spread out. +-- +-- >>> nearestLevel (Score 1.6 (("low", 0.1) :| [("medium", 0.2), ("high", 0.7)]) 0.6) +-- "high" +nearestLevel :: Score a -> a +nearestLevel s = fst (levels NonEmpty.!! index) + where + levels = scoreProbabilities s + lastIndex = NonEmpty.length levels - 1 + index = max 0 (min lastIndex (round (scoreValue s))) + +-- | 'scoreValue' scaled to the range 0–1, so that scores from rubrics of +-- different lengths can be weighted and combined (see +-- ). +-- +-- >>> normalizedScore (Score 1.5 (("low", 0.1) :| [("medium", 0.3), ("high", 0.6)]) 0.6) +-- 0.75 +normalizedScore :: Score a -> Double +normalizedScore s + | lastIndex <= 0 = 0 + | otherwise = scoreValue s / fromIntegral lastIndex + where + lastIndex = NonEmpty.length (scoreProbabilities s) - 1 + +------------------------------------------------------------------------------ +-- Questions + +-- | A single question whose answer decodes to an @a@. +-- +-- Build questions with 'noul', 'choice', 'score' and friends, and adapt the +-- answer with 'fmap': +-- +-- @ +-- isUrgent :: 'Question' Bool +-- isUrgent = (\\a -> 'noulProbability' a >= 0.8) \<$\> 'noul' \"Does this convey urgency?\" +-- @ +data Question a = Question + { questionSpec_ :: !(Either QuestionProblem Wire.Question) + , questionDecoder :: Wire.Answer -> Either AnswerProblem a + } + deriving stock (Functor) + +-- | The wire representation of the question, or why it is malformed. +questionSpec :: Question a -> Either QuestionProblem Wire.Question +questionSpec = questionSpec_ + +-- | Decode the answer to this question. +decodeAnswer :: Question a -> Wire.Answer -> Either AnswerProblem a +decodeAnswer = questionDecoder + +-- | A yes\/no question, or a statement to judge as true or false. +-- +-- >>> LBS.putStrLn (either (const "") encode (questionSpec (noul "Does this convey urgency?"))) +-- {"type":"noul","instructions":"Does this convey urgency?"} +noul :: Content -> Question Noul +noul instructions = noulQuestion (Wire.NoulQuestion (Just instructions) Nothing) + +-- | A yes\/no question with descriptions of what a yes and a no mean. +-- +-- >>> LBS.putStrLn (either (const "") encode (questionSpec (noulWith "Does this convey urgency?" "Explicitly time-sensitive" "No urgency expressed"))) +-- {"type":"noul","instructions":"Does this convey urgency?","criteria":{"true":"Explicitly time-sensitive","false":"No urgency expressed"}} +noulWith + :: Content + -- ^ The question. + -> Content + -- ^ What a yes (a value near 1) means. + -> Content + -- ^ What a no (a value near 0) means. + -> Question Noul +noulWith instructions yes no = + noulQuestion + ( Wire.NoulQuestion + (Just instructions) + (Just (Wire.NoulCriteria (Just yes) (Just no))) + ) + +noulQuestion :: Wire.NoulQuestion -> Question Noul +noulQuestion q = Question (Right (Wire.QuestionNoul q)) $ \case + Wire.AnswerNoul a -> Right (Noul (Probability (Wire.noulAnswerNoul a))) + other -> Left (UnexpectedAnswerType "noul" (Wire.answerType other)) + +-- | Types whose values are the options of a Choice. +-- +-- For an enumeration, derive the instance: the options are the constructors +-- in declaration order, named in snake case (@NeedsReview@ becomes +-- @needs_review@), without descriptions. +-- +-- @ +-- data Department = Billing | Technical | Sales +-- deriving stock (Show, Eq, Generic) +-- deriving anyclass ('ChoiceOption') +-- @ +-- +-- Descriptions tell the model when each option applies. Add them by +-- overriding 'optionDescription': +-- +-- @ +-- instance 'ChoiceOption' Department where +-- 'optionDescription' = Just . \\case +-- Billing -> \"Payments, invoicing, refunds\" +-- Technical -> \"Bugs, outages, integrations\" +-- Sales -> \"Pricing, upgrades, new accounts\" +-- @ +-- +-- The option name is what the model reads when there is no description, +-- so choose constructor names (or override 'optionName') with care. Names +-- must be distinct. +class ChoiceOption a where + -- | Every option, in the order it is offered. + choiceOptions :: NonEmpty a + default choiceOptions :: (Generic a, GEnumerate (Rep a)) => NonEmpty a + choiceOptions = genericEnumerate + + -- | The name sent to the API, and expected back in the answer. + optionName :: a -> Text + default optionName :: (Generic a, GConstructorName (Rep a)) => a -> Text + optionName = Text.pack . camelTo2 '_' . genericConstructorName + + -- | When this option applies. 'Nothing' lets the name speak for itself. + optionDescription :: a -> Maybe Content + optionDescription _ = Nothing + +-- | Pick one option of a 'ChoiceOption' type. +-- +-- The option type is usually inferred from where the answer is used; you can +-- also fix it with a type application: @choice \@Department \"Which team?\"@. +choice :: (ChoiceOption a) => Content -> Question (Choice a) +choice instructions = choiceBy optionName optionDescription instructions choiceOptions + +-- | Pick one of the given options, named and described by the two +-- functions. Use it when the options are only known at run time, such as a +-- catalogue loaded from a database. +-- +-- >>> let skills = ("pdf", "Read and fill PDF files") :| [("xlsx", "Edit spreadsheets")] +-- >>> let q = choiceBy fst (Just . ContentText . snd) "Which skill fits the request?" skills +-- >>> LBS.putStrLn (either (const "") encode (questionSpec q)) +-- {"type":"choice","instructions":"Which skill fits the request?","criteria":{"pdf":"Read and fill PDF files","xlsx":"Edit spreadsheets"}} +-- +-- The names must be distinct. Otherwise the question is rejected, before +-- anything is sent, with 'DuplicateOption'. +choiceBy + :: (a -> Text) + -- ^ The name of an option. + -> (a -> Maybe Content) + -- ^ When the option applies, if the name is not enough. + -> Content + -- ^ What the model should decide. + -> NonEmpty a + -- ^ The options, in the order they are offered. + -> Question (Choice a) +choiceBy name describe instructions options = Question spec decode + where + named = fmap (\o -> (name o, o)) options + table = Map.fromList (toList named) + spec = case firstDuplicate (map fst (toList named)) of + Just dup -> Left (DuplicateOption dup) + Nothing -> + Right . Wire.QuestionChoice $ + Wire.ChoiceQuestion + { Wire.choiceQuestionInstructions = Just instructions + , Wire.choiceQuestionCriteria = [(n, describe o) | (n, o) <- toList named] + } + decode = \case + Wire.AnswerChoice a -> do + selected <- lookupOption (Wire.choiceAnswerChoice a) + let probabilities = Wire.choiceAnswerProbabilities a + traverse_ lookupOption (Map.keys probabilities) + pure + Choice + { choiceSelected = selected + , choiceProbabilities = + fmap (\(n, o) -> (o, Probability (Map.findWithDefault 0 n probabilities))) named + , choiceConfidence = Confidence (Wire.choiceAnswerConfidence a) + } + other -> Left (UnexpectedAnswerType "choice" (Wire.answerType other)) + lookupOption n = maybe (Left (UnknownOption n)) Right (Map.lookup n table) + +-- | Types whose values are the levels of a Score rubric, lowest first. +-- +-- For an enumeration, derive the instance: the levels are the constructors in +-- declaration order, described by their names in lower case words +-- (@VeryAngry@ becomes @very angry@). +-- +-- Good level descriptions make scores far more consistent, so consider +-- writing them out: +-- +-- @ +-- data Severity = Cosmetic | Degraded | Outage +-- deriving stock (Show, Eq, Generic) +-- +-- instance 'ScoreLevel' Severity where +-- 'levelDescription' = \\case +-- Cosmetic -> \"Cosmetic: nothing is broken\" +-- Degraded -> \"Degraded: a feature misbehaves but there is a workaround\" +-- Outage -> \"Outage: customers cannot use the product\" +-- @ +class ScoreLevel a where + -- | Every level, lowest first. + scoreLevels :: NonEmpty a + default scoreLevels :: (Generic a, GEnumerate (Rep a)) => NonEmpty a + scoreLevels = genericEnumerate + + -- | What the level means. + levelDescription :: a -> Content + default levelDescription :: (Generic a, GConstructorName (Rep a)) => a -> Content + levelDescription = ContentText . Text.pack . camelTo2 ' ' . genericConstructorName + +-- | Rate the state on the levels of a 'ScoreLevel' type. +score :: (ScoreLevel a) => Content -> Question (Score a) +score instructions = scoreBy levelDescription instructions scoreLevels + +-- | Rate the state on the given levels, lowest first, described by the +-- function. +scoreBy + :: (a -> Content) + -- ^ What a level means. + -> Content + -- ^ What the model should rate. + -> NonEmpty a + -- ^ The levels, lowest first. The API accepts up to 10. + -> Question (Score a) +scoreBy describe instructions levels = Question spec decode + where + levelCount = NonEmpty.length levels + spec = + Right . Wire.QuestionScore $ + Wire.ScoreQuestion + { Wire.scoreQuestionInstructions = Just instructions + , Wire.scoreQuestionCriteria = fmap describe levels + } + decode = \case + Wire.AnswerScore a -> do + let probabilities = Wire.scoreAnswerProbabilities a + traverse_ + (\i -> unless (i >= 0 && i < levelCount) (Left (UnknownLevel i))) + (Map.keys probabilities) + pure + Score + { scoreValue = Wire.scoreAnswerScore a + , scoreProbabilities = + NonEmpty.zipWith + (\i l -> (l, Probability (Map.findWithDefault 0 i probabilities))) + (0 :| [1 ..]) + levels + , scoreConfidence = Confidence (Wire.scoreAnswerConfidence a) + } + other -> Left (UnexpectedAnswerType "score" (Wire.answerType other)) + +-- | Rate the state on a rubric given as descriptions, lowest first. The +-- levels of the answer are their indices, counting from 0. +-- +-- >>> let q = scoreRubric "How frustrated is the customer?" ("Calm" :| ["Frustrated", "Very angry"]) +-- >>> LBS.putStrLn (either (const "") encode (questionSpec q)) +-- {"type":"score","instructions":"How frustrated is the customer?","criteria":["Calm","Frustrated","Very angry"]} +scoreRubric :: Content -> NonEmpty Content -> Question (Score Int) +scoreRubric instructions descriptions = + fmap fst <$> scoreBy snd instructions (NonEmpty.zip (0 :| [1 ..]) descriptions) + +-- | Send a question as-is and receive its answer as-is. +rawQuestion :: Wire.Question -> Question Wire.Answer +rawQuestion q = Question (Right q) Right + +-- | A question of a type this SDK does not support yet, given by its @type@ +-- tag and the rest of its JSON object. The answer is decoded with its +-- 'FromJSON' instance, from the complete answer object (including @type@). +-- +-- This keeps new question types usable, with typed answers, before the SDK +-- adds first-class support for them. +otherQuestion :: (FromJSON a) => Text -> Object -> Question a +otherQuestion tag body = Question (Right (Wire.QuestionOther tag body)) $ \answer -> + if Wire.answerType answer == tag + then first (UndecodableAnswer . Text.pack) (parseEither parseJSON (toJSON answer)) + else Left (UnexpectedAnswerType tag (Wire.answerType answer)) + +------------------------------------------------------------------------------ +-- Several questions + +-- | Named questions to send in one request, and how to assemble their +-- answers into an @a@. +-- +-- Combine them with 'ask' and the 'Applicative' instance; see the module +-- header for an example. +data Questions a = Questions + { questionsEntries :: !(Seq (QuestionId, Either QuestionProblem Wire.Question)) + , questionsDecoder :: Map QuestionId Wire.Answer -> Collect a + } + deriving stock (Functor) + +instance Applicative Questions where + pure x = Questions Seq.empty (const (Collected x)) + Questions e1 d1 <*> Questions e2 d2 = Questions (e1 <> e2) (\answers -> d1 answers <*> d2 answers) + +-- | Ask a question under an id. Its answer comes back under the same id; the +-- id itself is not shown to the model. +ask :: QuestionId -> Question a -> Questions a +ask qid q = Questions (Seq.singleton (qid, questionSpec q)) $ \answers -> + case Map.lookup qid answers of + Nothing -> failed (AnswerError qid MissingAnswer) + Just a -> either (failed . AnswerError qid) Collected (decodeAnswer q a) + where + failed e = Failed (e :| []) + +-- | Ask every question of a map, keyed by its id. +askMap :: Map QuestionId (Question a) -> Questions (Map QuestionId a) +askMap = Map.traverseWithKey ask + +-- | The ids of the questions, in the order they were asked. +questionIds :: Questions a -> [QuestionId] +questionIds = map fst . toList . questionsEntries + +-- | The @questions@ object of a request. +-- +-- Fails if there are no questions, if two share an id, or if a question is +-- malformed; the first problem in the order of asking is reported. +-- +-- >>> renderQuestions (pure ()) +-- Left NoQuestions +-- +-- >>> renderQuestions (ask "q" (noul "Is it?") *> ask "q" (noul "Is it really?")) +-- Left (DuplicateQuestionId "q") +renderQuestions :: Questions a -> Either RequestError (Map QuestionId Wire.Question) +renderQuestions qs + | Seq.null entries = Left NoQuestions + | otherwise = go Map.empty (toList entries) + where + entries = questionsEntries qs + go acc [] = Right acc + go acc ((qid, spec) : rest) + | Map.member qid acc = Left (DuplicateQuestionId qid) + | otherwise = case spec of + Left problem -> Left (InvalidQuestion qid problem) + Right q -> go (Map.insert qid q acc) rest + +-- | Assemble the answers of a response. Reports every unusable answer, not +-- only the first. +decodeAnswers :: Questions a -> Map QuestionId Wire.Answer -> Either (NonEmpty AnswerError) a +decodeAnswers qs answers = case questionsDecoder qs answers of + Failed errs -> Left errs + Collected a -> Right a + +------------------------------------------------------------------------------ +-- Internals + +-- | Like @Either (NonEmpty AnswerError)@, but '<*>' collects every error. +data Collect a + = Failed !(NonEmpty AnswerError) + | Collected a + deriving stock (Functor) + +instance Applicative Collect where + pure = Collected + Failed e1 <*> Failed e2 = Failed (e1 <> e2) + Failed e <*> Collected _ = Failed e + Collected _ <*> Failed e = Failed e + Collected f <*> Collected x = Collected (f x) + +firstDuplicate :: (Ord a) => [a] -> Maybe a +firstDuplicate = go Set.empty + where + go _ [] = Nothing + go seen (x : xs) + | Set.member x seen = Just x + | otherwise = go (Set.insert x seen) xs diff --git a/typesafe-ai-core/src/TypeSafe/Retry.hs b/typesafe-ai-core/src/TypeSafe/Retry.hs new file mode 100644 index 0000000..782b37f --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Retry.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : TypeSafe.Retry +-- Description : When and how long to wait before retrying +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- Retrying is the transport's job, but the policy is plain data so that +-- every transport behaves the same way. The defaults match the official +-- Python and JavaScript SDKs: +-- +-- * up to 2 retries after the first attempt; +-- * retry on HTTP 408, 429 and any 5xx (including TypeSafe's 529 +-- "overloaded"), on connection failures and on timeouts; +-- * exponential backoff from 0.5 s, doubling up to 5 s, with up to 25 % +-- jitter; +-- * honour @Retry-After@ and @retry-after-ms@ when the server asks for a +-- delay of at most 60 s; +-- * give up once 30 s have passed since the first attempt. +-- +-- Every function here is pure; randomness and time are passed in, which also +-- makes the policy easy to test. +module TypeSafe.Retry + ( -- * Policy + RetryPolicy (..) + , defaultRetryPolicy + , noRetries + + -- * Decisions + , isRetryable + , retryDelay + , backoffDelay + , applyJitter + , retryAfter + ) where + +import Control.Applicative ((<|>)) +import Control.DeepSeq (NFData) +import qualified Data.ByteString.Char8 as BS8 +import Data.Char (digitToInt, isDigit) +import Data.Set (Set) +import qualified Data.Set as Set +import Data.Time.Clock (NominalDiffTime, UTCTime, diffUTCTime) +import Data.Time.Format (defaultTimeLocale, parseTimeM) +import GHC.Generics (Generic) +import Network.HTTP.Types (ResponseHeaders, statusCode) +import TypeSafe.Error + ( ApiError (..) + , ConnectionError (..) + , TypeSafeError (..) + ) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Time (UTCTime (..), fromGregorian) +-- >>> let now = UTCTime (fromGregorian 2026 9 22) 0 + +-- | How a transport retries failed requests. Durations are in seconds. +data RetryPolicy = RetryPolicy + { retryMaxRetries :: !Int + -- ^ Retries after the first attempt. @0@ disables retrying. + , retryInitialBackoff :: !NominalDiffTime + -- ^ The first backoff delay. It doubles with every retry. + , retryMaxBackoff :: !NominalDiffTime + -- ^ The longest backoff delay. + , retryJitter :: !Double + -- ^ The largest fraction, between 0 and 1, randomly taken off each backoff + -- delay so that clients do not retry in lockstep. + , retryStatuses :: !(Set Int) + -- ^ The HTTP status codes worth retrying. + , retryRespectRetryAfter :: !Bool + -- ^ Wait as long as the server asks with @Retry-After@ or + -- @retry-after-ms@, up to 'retryMaxRetryAfter'. + , retryMaxRetryAfter :: !NominalDiffTime + -- ^ The longest server-requested delay to honour. Longer requests fall back + -- to the backoff delay. + , retryConnectionErrors :: !Bool + -- ^ Retry requests that failed without a response. + , retryTimeouts :: !Bool + -- ^ Retry requests that timed out. + , retryBudget :: !(Maybe NominalDiffTime) + -- ^ Stop retrying when the next attempt would start this long after the + -- first one. 'Nothing' means no limit. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The policy described in the module header. +defaultRetryPolicy :: RetryPolicy +defaultRetryPolicy = + RetryPolicy + { retryMaxRetries = 2 + , retryInitialBackoff = 0.5 + , retryMaxBackoff = 5 + , retryJitter = 0.25 + , retryStatuses = Set.fromList (408 : 429 : [500 .. 599]) + , retryRespectRetryAfter = True + , retryMaxRetryAfter = 60 + , retryConnectionErrors = True + , retryTimeouts = True + , retryBudget = Just 30 + } + +-- | Never retry. +noRetries :: RetryPolicy +noRetries = defaultRetryPolicy {retryMaxRetries = 0} + +-- | Whether the policy retries this error (ignoring the retry count and +-- budget). Local validation errors and unusable responses are never retried: +-- sending the same request again would fail the same way. +isRetryable :: RetryPolicy -> TypeSafeError -> Bool +isRetryable policy = \case + ServiceError e -> statusCode (apiErrorStatus e) `Set.member` retryStatuses policy + ConnectionError (ConnectionTimedOut _) -> retryTimeouts policy + ConnectionError (ConnectionFailed _ _) -> retryConnectionErrors policy + InvalidRequest _ -> False + ResponseError _ -> False + +-- | How long to wait before retry number @n@ (counting from 1). +-- +-- A delay requested by the server wins when the policy honours it and it is +-- short enough; otherwise it is the backoff delay with jitter applied. The +-- 'Double' is a uniformly random number in [0, 1) that drives the jitter. +-- +-- >>> retryDelay defaultRetryPolicy now 0 1 (ConnectionError (ConnectionTimedOut "POST /v1/systemone")) +-- 0.5s +retryDelay :: RetryPolicy -> UTCTime -> Double -> Int -> TypeSafeError -> NominalDiffTime +retryDelay policy now random n err = case serverDelay of + Just d | retryRespectRetryAfter policy && d <= retryMaxRetryAfter policy -> d + _ -> applyJitter policy random (backoffDelay policy n) + where + serverDelay = case err of + ServiceError e -> retryAfter now (apiErrorHeaders e) + _ -> Nothing + +-- | The backoff delay before retry number @n@ (counting from 1), without +-- jitter. +-- +-- >>> map (backoffDelay defaultRetryPolicy) [1 .. 6] +-- [0.5s,1s,2s,4s,5s,5s] +backoffDelay :: RetryPolicy -> Int -> NominalDiffTime +backoffDelay policy n = + min (retryMaxBackoff policy) (retryInitialBackoff policy * 2 ^ max 0 (n - 1)) + +-- | Take a random part of at most 'retryJitter' off a delay. The 'Double' is +-- a uniformly random number in [0, 1). +-- +-- >>> applyJitter defaultRetryPolicy 0.5 4 +-- 3.5s +applyJitter :: RetryPolicy -> Double -> NominalDiffTime -> NominalDiffTime +applyJitter policy random delay = + delay * realToFrac (1 - clamp (retryJitter policy) * clamp random) + where + clamp = max 0 . min 1 + +-- | The delay the server asks for, if any, from the @retry-after-ms@ header +-- (milliseconds) or the standard @Retry-After@ header (seconds, or an HTTP +-- date relative to the given current time). +-- +-- >>> retryAfter now [("retry-after-ms", "250")] +-- Just 0.25s +-- +-- >>> retryAfter now [("Retry-After", "3")] +-- Just 3s +-- +-- >>> retryAfter now [("Retry-After", "Tue, 22 Sep 2026 00:00:10 GMT")] +-- Just 10s +retryAfter :: UTCTime -> ResponseHeaders -> Maybe NominalDiffTime +retryAfter now headers = + case lookup "retry-after-ms" headers >>= decimal of + Just ms -> Just (fromRational (ms / 1000)) + Nothing -> lookup "retry-after" headers >>= \v -> (fromRational <$> decimal v) <|> date v + where + date v = + max 0 . (`diffUTCTime` now) + <$> parseTimeM True defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" (BS8.unpack (BS8.strip v)) + +-- | A non-negative decimal number such as @3@ or @1.25@, parsed exactly. +decimal :: BS8.ByteString -> Maybe Rational +decimal raw = case BS8.split '.' (BS8.strip raw) of + [whole] | digits whole -> Just (integer whole) + [whole, fraction] + | digits whole && digits fraction -> + Just (integer whole + integer fraction / 10 ^ BS8.length fraction) + _ -> Nothing + where + digits s = not (BS8.null s) && BS8.all isDigit s + integer = fromInteger . BS8.foldl' (\acc c -> acc * 10 + toInteger (digitToInt c)) 0 diff --git a/typesafe-ai-core/src/TypeSafe/Wire.hs b/typesafe-ai-core/src/TypeSafe/Wire.hs new file mode 100644 index 0000000..6366c5c --- /dev/null +++ b/typesafe-ai-core/src/TypeSafe/Wire.hs @@ -0,0 +1,773 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | +-- Module : TypeSafe.Wire +-- Description : The TypeSafe HTTP API, schema for schema +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- A one-to-one Haskell mirror of the schemas in the TypeSafe OpenAPI +-- specification (), version +-- 'apiSpecVersion'. +-- +-- Most programs never need this module: "TypeSafe.Question" builds these +-- values from typed questions and decodes the answers into your own types. +-- Reach for the wire types when you want to +-- +-- * talk to the API through your own HTTP stack, such as servant, and only +-- borrow the JSON codecs, +-- * log, store or replay raw requests and responses, or +-- * use an API feature before this SDK has typed support for it (see +-- 'QuestionOther' and 'AnswerOther'). +-- +-- = Naming +-- +-- Every schema becomes a type of the same name. Every property becomes a +-- field named after the schema, then the property in camel case: +-- @SystemOneRequest.state@ is 'systemOneRequestState' and +-- @Usage.input_tokens@ is 'usageInputTokens'. The fixed rule keeps the +-- field names unique without any language extensions and makes it simple to +-- check the bindings against a new version of the specification. +-- +-- Schemas that use @oneOf@ with a @type@ discriminator (@Question@ and +-- @Answer@) become sum types. Their @type@ property is implied by the +-- constructor, so the variant records have no field for it. +-- +-- = Forward compatibility +-- +-- * Response objects ignore properties this version does not know about. +-- * Questions and answers of an unknown @type@ decode to 'QuestionOther' and +-- 'AnswerOther' instead of failing. +-- * 'ModelName' is open: any model id or alias the API accepts can be used. +-- +-- = Example +-- +-- The example request from the API reference: +-- +-- >>> :{ +-- let request = +-- SystemOneRequest +-- { systemOneRequestState = "Help! My payouts have been failing for 3 days." +-- , systemOneRequestModel = jevLatest +-- , systemOneRequestQuestions = +-- Map.fromList +-- [ ( "is_urgent" +-- , QuestionNoul +-- NoulQuestion +-- { noulQuestionInstructions = Just "Does this convey urgency?" +-- , noulQuestionCriteria = Nothing +-- } +-- ) +-- ] +-- } +-- :} +-- +-- >>> LBS.putStrLn (encode request) +-- {"state":"Help! My payouts have been failing for 3 days.","model":"jev-latest","questions":{"is_urgent":{"type":"noul","instructions":"Does this convey urgency?"}}} +-- +-- and its response: +-- +-- >>> :{ +-- let body = "{\"model\":\"jev-1.13.0\",\"answers\":{\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95}},\"usage\":{\"input_tokens\":296,\"output_tokens\":20}}" +-- :} +-- +-- >>> fmap systemOneResponseAnswers (eitherDecode body) +-- Right (fromList [("is_urgent",AnswerNoul (NoulAnswer {noulAnswerNoul = 0.95}))]) +module TypeSafe.Wire + ( -- * Specification version + apiSpecVersion + + -- * Identifiers + , ModelName (..) + , jevLatest + , jevPreview + , QuestionId (..) + + -- * Evaluation request (@POST \/v1\/systemone@) + , SystemOneRequest (..) + , Question (..) + , questionType + , NoulQuestion (..) + , NoulCriteria (..) + , ChoiceQuestion (..) + , ScoreQuestion (..) + + -- * Evaluation response + , SystemOneResponse (..) + , Answer (..) + , answerType + , NoulAnswer (..) + , ChoiceAnswer (..) + , ScoreAnswer (..) + , Usage (..) + + -- * Models (@GET \/v1\/models@) + , ModelMetadataList (..) + , ModelMetadata (..) + , modelMetadataReleaseDay + + -- * Validation errors (HTTP 422) + , HTTPValidationError (..) + , ValidationError (..) + , LocationSegment (..) + ) where + +import Control.DeepSeq (NFData) +import Data.Aeson + ( FromJSON (..) + , FromJSONKey + , Object + , ToJSON (..) + , ToJSONKey + , Value (..) + , object + , pairs + , withObject + , withText + , (.:) + , (.:?) + , (.=) + ) +import qualified Data.Aeson.Encoding as Encoding +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Aeson.Types (Parser, Series) +import Data.List.NonEmpty (NonEmpty) +import Data.Map.Strict (Map) +import Data.String (IsString) +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time.Calendar (Day) +import Data.Time.Format.ISO8601 (iso8601ParseM) +import GHC.Generics (Generic) +import TypeSafe.Content (Content) + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Aeson (encode, eitherDecode) +-- >>> import qualified Data.ByteString.Lazy.Char8 as LBS +-- >>> import qualified Data.Map.Strict as Map + +-- | The @info.version@ of the OpenAPI specification these bindings mirror. +-- +-- The test suite checks this against the vendored copy of the specification, +-- so it cannot silently fall out of date. +apiSpecVersion :: Text +apiSpecVersion = "0.2.0" + +------------------------------------------------------------------------------ +-- Identifiers + +-- | The name of a model or model alias, as accepted by the request's @model@ +-- field. +-- +-- Aliases such as 'jevLatest' move when a new model ships. Pin a versioned id +-- (for example @\"jev-1.13.0\"@) if you have tuned thresholds against a +-- specific version. See . +newtype ModelName = ModelName {unModelName :: Text} + deriving newtype (Eq, Ord, Show, IsString, ToJSON, FromJSON, NFData) + +-- | The most recent stable, official release of Jev. The default model. +jevLatest :: ModelName +jevLatest = "jev-latest" + +-- | The most recent release of Jev, whether or not it is an official one. +jevPreview :: ModelName +jevPreview = "jev-preview" + +-- | A key you choose for a question. Its answer comes back under the same key. +-- +-- Question ids are not sent to the model and do not influence the answer: +-- put the complete question in the instructions. +newtype QuestionId = QuestionId {unQuestionId :: Text} + deriving newtype (Eq, Ord, Show, IsString, ToJSON, FromJSON, ToJSONKey, FromJSONKey, NFData) + +------------------------------------------------------------------------------ +-- Request + +-- | Content and named questions to evaluate together (schema +-- @SystemOneRequest@). +data SystemOneRequest = SystemOneRequest + { systemOneRequestState :: !Content + -- ^ The content all questions in this request refer to. + , systemOneRequestModel :: !ModelName + -- ^ Name or alias of the model to use. + , systemOneRequestQuestions :: !(Map QuestionId Question) + -- ^ Questions keyed by a name you choose. The API requires at least one. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON SystemOneRequest where + toJSON r = + object + [ "state" .= systemOneRequestState r + , "model" .= systemOneRequestModel r + , "questions" .= systemOneRequestQuestions r + ] + toEncoding r = + pairs + ( "state" .= systemOneRequestState r + <> "model" .= systemOneRequestModel r + <> "questions" .= systemOneRequestQuestions r + ) + +instance FromJSON SystemOneRequest where + parseJSON = withObject "SystemOneRequest" $ \o -> + SystemOneRequest + <$> o .: "state" + <*> o .: "model" + <*> o .: "questions" + +-- | A question about the supplied content (schema @Question@). +data Question + = -- | A yes\/no question. + QuestionNoul !NoulQuestion + | -- | Pick one of several named options. + QuestionChoice !ChoiceQuestion + | -- | Rate the content on an ordered rubric. + QuestionScore !ScoreQuestion + | -- | A question type this version of the SDK does not know about: the + -- @type@ tag and the complete JSON object. It is sent exactly as given + -- (with @type@ set to the tag), so new question types can be used before + -- the SDK supports them. + QuestionOther !Text !Object + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The value of the question's @type@ discriminator. +-- +-- >>> questionType (QuestionNoul (NoulQuestion Nothing Nothing)) +-- "noul" +questionType :: Question -> Text +questionType = \case + QuestionNoul _ -> "noul" + QuestionChoice _ -> "choice" + QuestionScore _ -> "score" + QuestionOther t _ -> t + +instance ToJSON Question where + toJSON = \case + QuestionNoul q -> toJSON q + QuestionChoice q -> toJSON q + QuestionScore q -> toJSON q + QuestionOther t o -> Object (KeyMap.insert "type" (String t) o) + toEncoding = \case + QuestionNoul q -> toEncoding q + QuestionChoice q -> toEncoding q + QuestionScore q -> toEncoding q + QuestionOther t o -> toEncoding (KeyMap.insert "type" (String t) o) + +instance FromJSON Question where + parseJSON = withObject "Question" $ \o -> do + tag <- o .: "type" + case tag of + "noul" -> QuestionNoul <$> parseJSON (Object o) + "choice" -> QuestionChoice <$> parseJSON (Object o) + "score" -> QuestionScore <$> parseJSON (Object o) + other -> pure (QuestionOther other o) + +-- | A yes\/no question or statement, answered with the probability of yes +-- (schema @NoulQuestion@). +data NoulQuestion = NoulQuestion + { noulQuestionInstructions :: !(Maybe Content) + -- ^ The yes\/no question or statement to evaluate. + , noulQuestionCriteria :: !(Maybe NoulCriteria) + -- ^ What counts as a yes or a no. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON NoulQuestion where + toJSON q = + object $ + ("type" .= ("noul" :: Text)) + : optionalPairs + [ ("instructions", toJSON <$> noulQuestionInstructions q) + , ("criteria", toJSON <$> noulQuestionCriteria q) + ] + toEncoding q = + pairs $ + ("type" .= ("noul" :: Text)) + <> optionalSeries "instructions" (noulQuestionInstructions q) + <> optionalSeries "criteria" (noulQuestionCriteria q) + +instance FromJSON NoulQuestion where + parseJSON = withObject "NoulQuestion" $ \o -> do + expectType "noul" o + NoulQuestion + <$> o .:? "instructions" + <*> o .:? "criteria" + +-- | What counts as a yes or a no (schema @NoulCriteria@). +data NoulCriteria = NoulCriteria + { noulCriteriaTrue :: !(Maybe Content) + -- ^ What a yes (a value near 1) means. + , noulCriteriaFalse :: !(Maybe Content) + -- ^ What a no (a value near 0) means. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON NoulCriteria where + toJSON c = + object $ + optionalPairs + [ ("true", toJSON <$> noulCriteriaTrue c) + , ("false", toJSON <$> noulCriteriaFalse c) + ] + toEncoding c = + pairs $ + optionalSeries "true" (noulCriteriaTrue c) + <> optionalSeries "false" (noulCriteriaFalse c) + +instance FromJSON NoulCriteria where + parseJSON = withObject "NoulCriteria" $ \o -> + NoulCriteria + <$> o .:? "true" + <*> o .:? "false" + +-- | A question that selects one option from the choices you define (schema +-- @ChoiceQuestion@). +data ChoiceQuestion = ChoiceQuestion + { choiceQuestionInstructions :: !(Maybe Content) + -- ^ What the model should decide. + , choiceQuestionCriteria :: ![(Text, Maybe Content)] + -- ^ Option names and, optionally, when each applies. An option without a + -- description is interpreted by its name alone. + -- + -- The options are sent in list order. Names must be unique; the API allows + -- at most 255 options. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ChoiceQuestion where + toJSON q = + object $ + ("type" .= ("choice" :: Text)) + : ("criteria" .= object [Key.fromText k .= v | (k, v) <- choiceQuestionCriteria q]) + : optionalPairs [("instructions", toJSON <$> choiceQuestionInstructions q)] + toEncoding q = + pairs $ + ("type" .= ("choice" :: Text)) + <> optionalSeries "instructions" (choiceQuestionInstructions q) + <> Encoding.pair "criteria" (pairs (foldMap (\(k, v) -> Key.fromText k .= v) (choiceQuestionCriteria q))) + +instance FromJSON ChoiceQuestion where + parseJSON = withObject "ChoiceQuestion" $ \o -> do + expectType "choice" o + criteria <- o .: "criteria" >>= withObject "criteria" (traverse parseOption . KeyMap.toList) + ChoiceQuestion + <$> o .:? "instructions" + <*> pure criteria + where + parseOption (k, v) = (,) (Key.toText k) <$> parseJSON v + +-- | A question that assigns a score using an ordered rubric (schema +-- @ScoreQuestion@). +data ScoreQuestion = ScoreQuestion + { scoreQuestionInstructions :: !(Maybe Content) + -- ^ What the model should rate. + , scoreQuestionCriteria :: !(NonEmpty Content) + -- ^ Ordered level descriptions. Each description's position is its score, + -- starting at zero. The API accepts up to 10 levels. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ScoreQuestion where + toJSON q = + object $ + ("type" .= ("score" :: Text)) + : ("criteria" .= scoreQuestionCriteria q) + : optionalPairs [("instructions", toJSON <$> scoreQuestionInstructions q)] + toEncoding q = + pairs $ + ("type" .= ("score" :: Text)) + <> optionalSeries "instructions" (scoreQuestionInstructions q) + <> ("criteria" .= scoreQuestionCriteria q) + +instance FromJSON ScoreQuestion where + parseJSON = withObject "ScoreQuestion" $ \o -> do + expectType "score" o + ScoreQuestion + <$> o .:? "instructions" + <*> o .: "criteria" + +------------------------------------------------------------------------------ +-- Response + +-- | Answers keyed by question name, with the model used and token usage +-- (schema @SystemOneResponse@). +data SystemOneResponse = SystemOneResponse + { systemOneResponseModel :: !ModelName + -- ^ The versioned model that answered. May differ from the alias in the + -- request. + , systemOneResponseAnswers :: !(Map QuestionId Answer) + -- ^ One answer per question, under the question's id. + , systemOneResponseUsage :: !Usage + -- ^ Token usage for the request. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON SystemOneResponse where + toJSON r = + object + [ "model" .= systemOneResponseModel r + , "answers" .= systemOneResponseAnswers r + , "usage" .= systemOneResponseUsage r + ] + toEncoding r = + pairs + ( "model" .= systemOneResponseModel r + <> "answers" .= systemOneResponseAnswers r + <> "usage" .= systemOneResponseUsage r + ) + +instance FromJSON SystemOneResponse where + parseJSON = withObject "SystemOneResponse" $ \o -> + SystemOneResponse + <$> o .: "model" + <*> o .: "answers" + <*> o .: "usage" + +-- | An answer whose type matches its question (schema @Answer@). +data Answer + = -- | The answer to a 'QuestionNoul'. + AnswerNoul !NoulAnswer + | -- | The answer to a 'QuestionChoice'. + AnswerChoice !ChoiceAnswer + | -- | The answer to a 'QuestionScore'. + AnswerScore !ScoreAnswer + | -- | An answer type this version of the SDK does not know about: the @type@ + -- tag and the complete JSON object. + AnswerOther !Text !Object + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +-- | The value of the answer's @type@ discriminator. +answerType :: Answer -> Text +answerType = \case + AnswerNoul _ -> "noul" + AnswerChoice _ -> "choice" + AnswerScore _ -> "score" + AnswerOther t _ -> t + +instance ToJSON Answer where + toJSON = \case + AnswerNoul a -> toJSON a + AnswerChoice a -> toJSON a + AnswerScore a -> toJSON a + AnswerOther t o -> Object (KeyMap.insert "type" (String t) o) + toEncoding = \case + AnswerNoul a -> toEncoding a + AnswerChoice a -> toEncoding a + AnswerScore a -> toEncoding a + AnswerOther t o -> toEncoding (KeyMap.insert "type" (String t) o) + +instance FromJSON Answer where + parseJSON = withObject "Answer" $ \o -> do + tag <- o .: "type" + case tag of + "noul" -> AnswerNoul <$> parseJSON (Object o) + "choice" -> AnswerChoice <$> parseJSON (Object o) + "score" -> AnswerScore <$> parseJSON (Object o) + other -> pure (AnswerOther other o) + +-- | The probability of a yes answer (schema @NoulAnswer@). +newtype NoulAnswer = NoulAnswer + { noulAnswerNoul :: Double + -- ^ From 0 (no) to 1 (yes). Values near 0.5 indicate uncertainty. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON NoulAnswer where + toJSON a = object ["type" .= ("noul" :: Text), "noul" .= noulAnswerNoul a] + toEncoding a = pairs ("type" .= ("noul" :: Text) <> "noul" .= noulAnswerNoul a) + +instance FromJSON NoulAnswer where + parseJSON = withObject "NoulAnswer" $ \o -> do + expectType "noul" o + NoulAnswer <$> o .: "noul" + +-- | The selected option, confidence and probabilities of a choice question +-- (schema @ChoiceAnswer@). +data ChoiceAnswer = ChoiceAnswer + { choiceAnswerChoice :: !Text + -- ^ The option with the highest probability. + , choiceAnswerConfidence :: !Double + -- ^ Confidence in the selection, from 0 to 1. + , choiceAnswerProbabilities :: !(Map Text Double) + -- ^ The probability of every option, keyed by option name. Sums to + -- approximately 1. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ChoiceAnswer where + toJSON a = + object + [ "type" .= ("choice" :: Text) + , "choice" .= choiceAnswerChoice a + , "confidence" .= choiceAnswerConfidence a + , "probabilities" .= choiceAnswerProbabilities a + ] + toEncoding a = + pairs + ( "type" .= ("choice" :: Text) + <> "choice" .= choiceAnswerChoice a + <> "confidence" .= choiceAnswerConfidence a + <> "probabilities" .= choiceAnswerProbabilities a + ) + +instance FromJSON ChoiceAnswer where + parseJSON = withObject "ChoiceAnswer" $ \o -> do + expectType "choice" o + ChoiceAnswer + <$> o .: "choice" + <*> o .: "confidence" + <*> o .: "probabilities" + +-- | An expected score with its rubric, confidence and level probabilities +-- (schema @ScoreAnswer@). +data ScoreAnswer = ScoreAnswer + { scoreAnswerScore :: !Double + -- ^ The probability-weighted average of the level indices. May fall between + -- levels. + , scoreAnswerConfidence :: !Double + -- ^ Confidence in the score, from 0 to 1. + , scoreAnswerLegend :: !(Map Int Content) + -- ^ Each level index mapped back to its description. + , scoreAnswerProbabilities :: !(Map Int Double) + -- ^ The probability of each level, keyed by level index. Sums to + -- approximately 1. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ScoreAnswer where + toJSON a = + object + [ "type" .= ("score" :: Text) + , "score" .= scoreAnswerScore a + , "confidence" .= scoreAnswerConfidence a + , "legend" .= scoreAnswerLegend a + , "probabilities" .= scoreAnswerProbabilities a + ] + toEncoding a = + pairs + ( "type" .= ("score" :: Text) + <> "score" .= scoreAnswerScore a + <> "confidence" .= scoreAnswerConfidence a + <> "legend" .= scoreAnswerLegend a + <> "probabilities" .= scoreAnswerProbabilities a + ) + +instance FromJSON ScoreAnswer where + parseJSON = withObject "ScoreAnswer" $ \o -> do + expectType "score" o + ScoreAnswer + <$> o .: "score" + <*> o .: "confidence" + <*> o .: "legend" + <*> o .: "probabilities" + +-- | Token usage for a request (schema @Usage@). +data Usage = Usage + { usageInputTokens :: !Int + -- ^ Billable input tokens. + , usageOutputTokens :: !Int + -- ^ Output tokens. Currently free of charge. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON Usage where + toJSON u = object ["input_tokens" .= usageInputTokens u, "output_tokens" .= usageOutputTokens u] + toEncoding u = pairs ("input_tokens" .= usageInputTokens u <> "output_tokens" .= usageOutputTokens u) + +instance FromJSON Usage where + parseJSON = withObject "Usage" $ \o -> + Usage + <$> o .: "input_tokens" + <*> o .: "output_tokens" + +------------------------------------------------------------------------------ +-- Models + +-- | The models and aliases available to the account (schema +-- @ModelMetadataList@). +newtype ModelMetadataList = ModelMetadataList + { modelMetadataListModels :: [ModelMetadata] + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ModelMetadataList where + toJSON l = object ["models" .= modelMetadataListModels l] + toEncoding l = pairs ("models" .= modelMetadataListModels l) + +instance FromJSON ModelMetadataList where + parseJSON = withObject "ModelMetadataList" $ \o -> + ModelMetadataList <$> o .: "models" + +-- | A model or alias available to the account (schema @ModelMetadata@). +data ModelMetadata = ModelMetadata + { modelMetadataName :: !ModelName + -- ^ The name to send in the request's @model@ field. + , modelMetadataDescription :: !Text + -- ^ What the model is for. + , modelMetadataReleaseDate :: !Text + -- ^ The release date, formatted as @YYYY-MM-DD@. See + -- 'modelMetadataReleaseDay'. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ModelMetadata where + toJSON m = + object + [ "name" .= modelMetadataName m + , "description" .= modelMetadataDescription m + , "release_date" .= modelMetadataReleaseDate m + ] + toEncoding m = + pairs + ( "name" .= modelMetadataName m + <> "description" .= modelMetadataDescription m + <> "release_date" .= modelMetadataReleaseDate m + ) + +instance FromJSON ModelMetadata where + parseJSON = withObject "ModelMetadata" $ \o -> + ModelMetadata + <$> o .: "name" + <*> o .: "description" + <*> o .: "release_date" + +-- | The release date as a 'Day', when it is a valid @YYYY-MM-DD@ date. +-- +-- The date is kept as text in 'ModelMetadata' so that an unexpected format +-- never makes listing models fail. +-- +-- >>> modelMetadataReleaseDay (ModelMetadata "jev-latest" "General-purpose system one model." "2026-09-15") +-- Just 2026-09-15 +modelMetadataReleaseDay :: ModelMetadata -> Maybe Day +modelMetadataReleaseDay = iso8601ParseM . Text.unpack . modelMetadataReleaseDate + +------------------------------------------------------------------------------ +-- Validation errors + +-- | The body of an HTTP 422 response (schema @HTTPValidationError@). +newtype HTTPValidationError = HTTPValidationError + { httpValidationErrorDetail :: Maybe [ValidationError] + -- ^ Which request values are missing or invalid. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON HTTPValidationError where + toJSON e = object (optionalPairs [("detail", toJSON <$> httpValidationErrorDetail e)]) + toEncoding e = pairs (optionalSeries "detail" (httpValidationErrorDetail e)) + +instance FromJSON HTTPValidationError where + parseJSON = withObject "HTTPValidationError" $ \o -> + HTTPValidationError <$> o .:? "detail" + +-- | One validation failure (schema @ValidationError@). +data ValidationError = ValidationError + { validationErrorLoc :: ![LocationSegment] + -- ^ Where the invalid value is: the request part, then field names and + -- array indices, for example @body → questions → urgency → criteria@. + , validationErrorMsg :: !Text + -- ^ A human-readable explanation. + , validationErrorType :: !Text + -- ^ A machine-readable error code such as @missing@. + , validationErrorInput :: !(Maybe Value) + -- ^ The value that failed validation. + , validationErrorCtx :: !(Maybe Object) + -- ^ Extra context, such as the violated limit. + } + deriving stock (Eq, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON ValidationError where + toJSON e = + object $ + [ "loc" .= validationErrorLoc e + , "msg" .= validationErrorMsg e + , "type" .= validationErrorType e + ] + <> optionalPairs + [ ("input", validationErrorInput e) + , ("ctx", Object <$> validationErrorCtx e) + ] + toEncoding e = + pairs $ + "loc" .= validationErrorLoc e + <> "msg" .= validationErrorMsg e + <> "type" .= validationErrorType e + <> optionalSeries "input" (validationErrorInput e) + <> optionalSeries "ctx" (validationErrorCtx e) + +instance FromJSON ValidationError where + parseJSON = withObject "ValidationError" $ \o -> + ValidationError + <$> o .: "loc" + <*> o .: "msg" + <*> o .: "type" + <*> o .:? "input" + <*> o .:? "ctx" + +-- | One step of a 'validationErrorLoc' path. +data LocationSegment + = -- | An object key. + LocationField !Text + | -- | An array index. + LocationIndex !Int + deriving stock (Eq, Ord, Show, Generic) + deriving anyclass (NFData) + +instance ToJSON LocationSegment where + toJSON = \case + LocationField t -> String t + LocationIndex i -> toJSON i + toEncoding = \case + LocationField t -> toEncoding t + LocationIndex i -> toEncoding i + +instance FromJSON LocationSegment where + parseJSON = \case + String t -> pure (LocationField t) + v -> LocationIndex <$> parseJSON v + +------------------------------------------------------------------------------ +-- Helpers + +optionalPairs :: [(Text, Maybe Value)] -> [(Key.Key, Value)] +optionalPairs kvs = [(Key.fromText k, v) | (k, Just v) <- kvs] + +optionalSeries :: (ToJSON v) => Key.Key -> Maybe v -> Series +optionalSeries k = maybe mempty (k .=) + +-- | Require the @type@ discriminator to be the expected tag. +expectType :: Text -> Object -> Parser () +expectType expected o = case KeyMap.lookup "type" o of + Nothing -> fail ("missing \"type\": expected " <> show expected) + Just v -> + withText + "type" + ( \t -> + if t == expected + then pure () + else fail ("expected \"type\" to be " <> show expected <> ", got " <> show t) + ) + v diff --git a/typesafe-ai-core/test/Main.hs b/typesafe-ai-core/test/Main.hs new file mode 100644 index 0000000..889ef51 --- /dev/null +++ b/typesafe-ai-core/test/Main.hs @@ -0,0 +1,26 @@ +module Main (main) where + +import Data.Maybe (fromMaybe) +import System.Environment (lookupEnv) +import Test.Tasty (defaultMain, testGroup) +import qualified TypeSafe.ConformanceSpec as Conformance +import qualified TypeSafe.ErrorSpec as Error +import TypeSafe.JsonSchema (loadSpec) +import qualified TypeSafe.QuestionSpec as Question +import qualified TypeSafe.RetrySpec as Retry + +-- | Set @TYPESAFE_OPENAPI_SPEC@ to check the bindings against another copy of +-- the specification, such as a freshly downloaded one, without replacing the +-- vendored file. +main :: IO () +main = do + specPath <- fromMaybe "spec/openapi.json" <$> lookupEnv "TYPESAFE_OPENAPI_SPEC" + spec <- loadSpec specPath + defaultMain $ + testGroup + "typesafe-ai-core" + [ Conformance.tests spec + , Question.tests + , Error.tests + , Retry.tests + ] diff --git a/typesafe-ai-core/test/TypeSafe/ArbitraryInstances.hs b/typesafe-ai-core/test/TypeSafe/ArbitraryInstances.hs new file mode 100644 index 0000000..f60b6ea --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/ArbitraryInstances.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +-- | Generators for the wire types. They only produce values the +-- specification allows, so every generated value must validate against it. +module TypeSafe.ArbitraryInstances + ( genText + , genContent + , genJsonValue + , genProbability + ) where + +import Data.Aeson (Value (..)) +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.List (nub, sort) +import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector +import Test.QuickCheck +import TypeSafe.Content (Content (..)) +import TypeSafe.Wire + +genText :: Gen Text +genText = + Text.pack + <$> frequency + [ (4, listOf (elements (['a' .. 'z'] <> ['A' .. 'Z'] <> ['0' .. '9'] <> " _-.`?"))) + , (1, getPrintableString <$> arbitrary) + , (1, listOf (elements "äöü€日本語🙂\"\\\n\t")) + ] + +genKey :: Gen Text +genKey = Text.pack <$> listOf1 (elements (['a' .. 'z'] <> "_")) + +-- | Finite probabilities, so that JSON round trips are exact. +genProbability :: Gen Double +genProbability = elements [0, 0.05, 0.1, 0.12, 0.25, 0.5, 0.75, 0.81, 0.88, 0.95, 1] + +genJsonValue :: Int -> Gen Value +genJsonValue depth = + frequency $ + [ (3, String <$> genText) + , (2, Number . fromIntegral <$> (arbitrary :: Gen Int)) + , (1, Bool <$> arbitrary) + , (1, pure Null) + ] + <> [ (1, Object . KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue (depth - 1))) + | depth > 0 + ] + <> [ (1, Array . Vector.fromList <$> smallListOf (genJsonValue (depth - 1))) + | depth > 0 + ] + +smallListOf :: Gen a -> Gen [a] +smallListOf g = choose (0, 3) >>= \n -> vectorOf n g + +genContent :: Gen Content +genContent = + frequency + [ (4, ContentText <$> genText) + , (1, ContentObject . KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue 2)) + , (1, ContentArray . Vector.fromList <$> smallListOf (genJsonValue 2)) + ] + +-- | Distinct keys in sorted order, so that decoding an object reproduces the +-- same list. +genSortedKeys :: Gen [Text] +genSortedKeys = sort . nub <$> listOf1 genKey + +instance Arbitrary Content where + arbitrary = genContent + +instance Arbitrary ModelName where + arbitrary = ModelName <$> genText + +instance Arbitrary QuestionId where + arbitrary = QuestionId <$> genText + +instance Arbitrary SystemOneRequest where + arbitrary = + SystemOneRequest + <$> arbitrary + <*> arbitrary + <*> (Map.fromList <$> listOf1 ((,) <$> arbitrary <*> arbitrary)) + +instance Arbitrary Question where + arbitrary = + oneof + [ QuestionNoul <$> arbitrary + , QuestionChoice <$> arbitrary + , QuestionScore <$> arbitrary + ] + +instance Arbitrary NoulQuestion where + arbitrary = NoulQuestion <$> arbitrary <*> arbitrary + +instance Arbitrary NoulCriteria where + arbitrary = NoulCriteria <$> arbitrary <*> arbitrary + +instance Arbitrary ChoiceQuestion where + arbitrary = do + keys <- genSortedKeys + ChoiceQuestion + <$> arbitrary + <*> traverse (\k -> (,) k <$> arbitrary) keys + +instance Arbitrary ScoreQuestion where + arbitrary = + ScoreQuestion + <$> arbitrary + <*> (NonEmpty.fromList <$> (choose (1, 10) >>= \n -> vectorOf n arbitrary)) + +instance Arbitrary SystemOneResponse where + arbitrary = + SystemOneResponse + <$> arbitrary + <*> (Map.fromList <$> listOf1 ((,) <$> arbitrary <*> arbitrary)) + <*> arbitrary + +instance Arbitrary Answer where + arbitrary = + oneof + [ AnswerNoul <$> arbitrary + , AnswerChoice <$> arbitrary + , AnswerScore <$> arbitrary + ] + +instance Arbitrary NoulAnswer where + arbitrary = NoulAnswer <$> genProbability + +instance Arbitrary ChoiceAnswer where + arbitrary = do + keys <- genSortedKeys + ChoiceAnswer + <$> elements keys + <*> genProbability + <*> (Map.fromList <$> traverse (\k -> (,) k <$> genProbability) keys) + +instance Arbitrary ScoreAnswer where + arbitrary = do + levels <- choose (1, 10) + ScoreAnswer + <$> (fromIntegral <$> choose (0, levels - 1 :: Int)) + <*> genProbability + <*> (Map.fromList <$> traverse (\i -> (,) i <$> arbitrary) [0 .. levels - 1]) + <*> (Map.fromList <$> traverse (\i -> (,) i <$> genProbability) [0 .. levels - 1]) + +instance Arbitrary Usage where + arbitrary = Usage <$> (getNonNegative <$> arbitrary) <*> (getNonNegative <$> arbitrary) + +instance Arbitrary ModelMetadataList where + arbitrary = ModelMetadataList <$> smallListOf arbitrary + +instance Arbitrary ModelMetadata where + arbitrary = + ModelMetadata + <$> arbitrary + <*> genText + <*> elements ["2026-09-15", "2026-01-31", "not a date"] + +instance Arbitrary HTTPValidationError where + arbitrary = HTTPValidationError <$> liftArbitrary (smallListOf arbitrary) + +instance Arbitrary ValidationError where + arbitrary = + ValidationError + <$> smallListOf arbitrary + <*> genText + <*> genText + <*> liftArbitrary (genJsonValue 2 `suchThat` (/= Null)) + <*> liftArbitrary (KeyMap.fromList <$> smallListOf ((,) <$> (Key.fromText <$> genKey) <*> genJsonValue 1)) + +instance Arbitrary LocationSegment where + arbitrary = oneof [LocationField <$> genText, LocationIndex . getNonNegative <$> arbitrary] diff --git a/typesafe-ai-core/test/TypeSafe/ConformanceSpec.hs b/typesafe-ai-core/test/TypeSafe/ConformanceSpec.hs new file mode 100644 index 0000000..c753b10 --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/ConformanceSpec.hs @@ -0,0 +1,158 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Checks the bindings in "TypeSafe.Wire" and "TypeSafe.Call" against the +-- vendored OpenAPI specification (@spec/openapi.json@). +-- +-- When TypeSafe publishes a new version of the specification, replace the +-- vendored file (see @scripts/sync-spec.sh@) and run these tests: each +-- failure names an endpoint, schema, property or keyword that the bindings +-- do not cover yet. +module TypeSafe.ConformanceSpec (tests) where + +import Control.Monad (forM_) +import Data.Aeson (FromJSON, ToJSON (..), Value (..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Either (isLeft) +import Data.List (nub, sort) +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Proxy (Proxy (..)) +import qualified Data.Set as Set +import Data.Text (Text) +import qualified Data.Text as Text +import Test.QuickCheck (Arbitrary, Gen, arbitrary, generate, vectorOf) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) +import Test.Tasty.QuickCheck (counterexample, testProperty, (===)) +import TypeSafe.ArbitraryInstances () +import TypeSafe.Call (callEndpoint, listModels, systemOne, systemOneRaw) +import TypeSafe.JsonSchema +import TypeSafe.Question (ask, noul) +import TypeSafe.Wire + +-- | A Haskell type bound to a schema of the specification. +data Binding = forall a. (Arbitrary a, ToJSON a, FromJSON a, Eq a, Show a) => Binding Text (Proxy a) + +-- | Every schema the SDK binds. A schema added to the specification makes the +-- \"every schema is bound\" test fail until it is listed here. +bindings :: [Binding] +bindings = + [ Binding "Answer" (Proxy :: Proxy Answer) + , Binding "ChoiceAnswer" (Proxy :: Proxy ChoiceAnswer) + , Binding "ChoiceQuestion" (Proxy :: Proxy ChoiceQuestion) + , Binding "HTTPValidationError" (Proxy :: Proxy HTTPValidationError) + , Binding "ModelMetadata" (Proxy :: Proxy ModelMetadata) + , Binding "ModelMetadataList" (Proxy :: Proxy ModelMetadataList) + , Binding "NoulAnswer" (Proxy :: Proxy NoulAnswer) + , Binding "NoulCriteria" (Proxy :: Proxy NoulCriteria) + , Binding "NoulQuestion" (Proxy :: Proxy NoulQuestion) + , Binding "Question" (Proxy :: Proxy Question) + , Binding "ScoreAnswer" (Proxy :: Proxy ScoreAnswer) + , Binding "ScoreQuestion" (Proxy :: Proxy ScoreQuestion) + , Binding "SystemOneRequest" (Proxy :: Proxy SystemOneRequest) + , Binding "SystemOneResponse" (Proxy :: Proxy SystemOneResponse) + , Binding "Usage" (Proxy :: Proxy Usage) + , Binding "ValidationError" (Proxy :: Proxy ValidationError) + ] + +-- | Every operation the SDK can call, as @(METHOD, path)@. +sdkOperations :: [(Text, Text)] +sdkOperations = + nub + [ (method, path) + | endpoint <- + [ callEndpoint (systemOne "state" (ask "q" (noul "?"))) + , callEndpoint (systemOneRaw (SystemOneRequest "state" jevLatest mempty)) + , callEndpoint listModels + ] + , let (method, path) = fmap Text.strip (Text.breakOn " " endpoint) + ] + +tests :: Spec -> TestTree +tests spec = + testGroup + "OpenAPI conformance" + [ testCase "apiSpecVersion matches the vendored specification" $ + Just apiSpecVersion @?= specVersion spec + , testCase "every operation is bound" $ + sort sdkOperations @?= sort (specOperations spec) + , testCase "every schema is bound" $ + sort [name | Binding name _ <- bindings] @?= sort (specSchemaNames spec) + , testCase "the schema validator understands every keyword in use" $ + nub (filter (`notElem` supportedKeywords) (specKeywords spec)) @?= [] + , testCase "question constructors match the Question discriminator" $ + sort + [ questionType (QuestionNoul (NoulQuestion Nothing Nothing)) + , questionType (QuestionChoice (ChoiceQuestion Nothing [])) + , questionType (QuestionScore (ScoreQuestion Nothing ("level" :| []))) + ] + @?= sort (discriminatorTags spec "Question") + , testCase "answer constructors match the Answer discriminator" $ + sort + [ answerType (AnswerNoul (NoulAnswer 0)) + , answerType (AnswerChoice (ChoiceAnswer "a" 0 mempty)) + , answerType (AnswerScore (ScoreAnswer 0 0 mempty mempty)) + ] + @?= sort (discriminatorTags spec "Answer") + , testCase "unknown question and answer types pass through unchanged" $ do + let question = Aeson.object ["type" Aeson..= ("rank" :: Text), "items" Aeson..= [1 :: Int, 2]] + fmap toJSON (Aeson.eitherDecode (Aeson.encode question) :: Either String Question) @?= Right question + let answer = Aeson.object ["type" Aeson..= ("rank" :: Text), "order" Aeson..= [2 :: Int, 1]] + fmap toJSON (Aeson.eitherDecode (Aeson.encode answer) :: Either String Answer) @?= Right answer + , testGroup "schemas" (map (schemaTests spec) bindings) + ] + +schemaTests :: Spec -> Binding -> TestTree +schemaTests spec (Binding name (_ :: Proxy a)) = + testGroup (Text.unpack name) $ + [ testProperty "encoded values validate against the schema" $ \(x :: a) -> + let errors = validate spec (schemaRef name) (toJSON x) + in counterexample (unlines errors) (null errors) + , testProperty "toEncoding agrees with toJSON" $ \(x :: a) -> + Aeson.decode (Aeson.encode x) === Just (toJSON x) + , testProperty "decoding inverts encoding" $ \(x :: a) -> + Aeson.eitherDecode (Aeson.encode x) === Right x + ] + <> [ testCase "encodes exactly the declared properties" $ do + samples <- generate (vectorOf 500 (arbitrary :: Gen a)) + let emitted = Set.unions [Set.fromList (objectKeys (toJSON x)) | x <- samples] + emitted @?= Set.fromList properties + | not (null properties) + ] + <> [ testCase "requires the required properties and only those" $ do + samples <- generate (vectorOf 50 (arbitrary :: Gen a)) + forM_ samples $ \x -> forM_ (objectKeys (toJSON x)) $ \p -> do + let decoded = decodeValue (withoutKey p (toJSON x)) + if p `elem` required + then assertBool ("decoded without required property " <> show p) (isLeft decoded) + else case decoded of + Left err -> assertFailure ("optional property " <> show p <> " is required by the decoder: " <> err) + Right _ -> pure () + | not (null properties) + ] + <> [ testCase "the specification's examples validate and decode" $ do + let example = Object (KeyMap.fromList [(Key.fromText p, v) | (p, v) <- examples]) + validate spec (schemaRef name) example @?= [] + case decodeValue example of + Left err -> assertFailure ("cannot decode " <> show example <> ": " <> err) + Right _ -> pure () + | not (null properties) + , all (`elem` map fst examples) required + ] + where + properties = objectProperties spec name + required = requiredProperties spec name + examples = propertyExamples spec name + decodeValue :: Value -> Either String a + decodeValue v = Aeson.eitherDecode (Aeson.encode v) + +objectKeys :: Value -> [Text] +objectKeys (Object o) = map Key.toText (KeyMap.keys o) +objectKeys _ = [] + +withoutKey :: Text -> Value -> Value +withoutKey k (Object o) = Object (KeyMap.delete (Key.fromText k) o) +withoutKey _ v = v diff --git a/typesafe-ai-core/test/TypeSafe/ErrorSpec.hs b/typesafe-ai-core/test/TypeSafe/ErrorSpec.hs new file mode 100644 index 0000000..26f9811 --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/ErrorSpec.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Error bodies and their classification, using bodies recorded from the +-- live API where possible. +module TypeSafe.ErrorSpec (tests) where + +import Data.Aeson (toJSON) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as Text +import Network.HTTP.Types (Status, mkStatus, status401, status403, status422) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import TypeSafe.Error +import TypeSafe.Wire (HTTPValidationError (..), LocationSegment (..), ValidationError (..)) + +tests :: TestTree +tests = + testGroup + "Errors" + [ testCase "status codes map to kinds" $ + map (apiErrorKindFor . code) [400, 401, 403, 404, 408, 422, 429, 500, 502, 529, 302] + @?= [ BadRequest + , Unauthorized + , PermissionDenied + , NotFound + , UnexpectedStatus + , UnprocessableEntity + , RateLimited + , InternalServerError + , InternalServerError + , Overloaded + , UnexpectedStatus + ] + , testCase "a missing API key (recorded: HTTP 403)" $ do + let e = apiErrorFromResponse "GET /v1/models" status403 [("x-typesafe-request-id", "req_01a0")] missingKeyBody + apiErrorKind e @?= PermissionDenied + apiErrorMessage e @?= Just "Must supply an API key! Check your request and try again." + apiErrorRequestId e @?= Just "req_01a0" + apiErrorBody e + @?= BodyDetail (ErrorDetail (Just "authentication_error") (Just "Must supply an API key! Check your request and try again.")) + , testCase "an invalid API key (recorded: HTTP 401)" $ + apiErrorKind (apiErrorFromResponse "GET /v1/models" status401 [] invalidKeyBody) @?= Unauthorized + , testCase "validation errors keep every field" $ do + let e = apiErrorFromResponse "POST /v1/systemone" status422 [] validationBody + apiErrorBody e + @?= BodyValidation + ( HTTPValidationError + ( Just + [ ValidationError + [LocationField "body", LocationField "questions", LocationField "urgency", LocationField "criteria", LocationIndex 0] + "Input should be a valid string" + "string_type" + (Just "3") + Nothing + ] + ) + ) + apiErrorMessage e @?= Just "body.questions.urgency.criteria.0: Input should be a valid string" + , testCase "bodies that are not structured errors" $ do + parseErrorBody "" @?= BodyEmpty + parseErrorBody " \n" @?= BodyEmpty + parseErrorBody "Bad gateway" @?= BodyText "Bad gateway" + parseErrorBody "[1,2]" @?= BodyJson (toJSON [1, 2 :: Int]) + , testCase "rendered errors are one line and name the request" $ do + let rendered = + renderTypeSafeError + (ServiceError (apiErrorFromResponse "GET /v1/models" status401 [("x-typesafe-request-id", "req_9")] invalidKeyBody)) + rendered + @?= "GET /v1/models failed with HTTP 401 (Unauthorized): Cannot authenticate with the server. \ + \Please check your API key and try again. [request id req_9]" + assertBool "single line" (not (Text.any (== '\n') rendered)) + ] + where + code :: Int -> Status + code c = mkStatus c "" + +missingKeyBody, invalidKeyBody, validationBody :: LBS.ByteString +missingKeyBody = "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Must supply an API key! Check your request and try again.\"}}" +invalidKeyBody = "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Cannot authenticate with the server. Please check your API key and try again.\"}}" +validationBody = + "{\"detail\":[{\"type\":\"string_type\",\"loc\":[\"body\",\"questions\",\"urgency\",\"criteria\",0],\ + \\"msg\":\"Input should be a valid string\",\"input\":\"3\"}]}" diff --git a/typesafe-ai-core/test/TypeSafe/JsonSchema.hs b/typesafe-ai-core/test/TypeSafe/JsonSchema.hs new file mode 100644 index 0000000..f6e7708 --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/JsonSchema.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | A small validator for the subset of JSON Schema that FastAPI emits in +-- OpenAPI 3.1 documents. +-- +-- Unknown keywords are reported as errors rather than ignored. When a new +-- version of the TypeSafe specification starts using a keyword this +-- validator does not understand, the conformance tests fail and point at it, +-- instead of silently passing. +module TypeSafe.JsonSchema + ( Spec + , loadSpec + , specVersion + , specOperations + , specSchemaNames + , schemaRef + , lookupSchema + , objectProperties + , requiredProperties + , discriminatorTags + , propertyExamples + , specKeywords + , supportedKeywords + , validate + ) where + +import Data.Aeson (Value (..)) +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Key as Key +import qualified Data.Aeson.KeyMap as KeyMap +import Data.Foldable (toList) +import Data.Maybe (fromMaybe, mapMaybe) +import qualified Data.Scientific as Scientific +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Vector as Vector + +-- | A parsed OpenAPI document. +newtype Spec = Spec Value + +loadSpec :: FilePath -> IO Spec +loadSpec path = + Aeson.eitherDecodeFileStrict path >>= \case + Left err -> fail ("cannot parse " <> path <> ": " <> err) + Right v -> pure (Spec v) + +at :: [Text] -> Value -> Maybe Value +at [] v = Just v +at (k : ks) (Object o) = KeyMap.lookup (Key.fromText k) o >>= at ks +at _ _ = Nothing + +keysOf :: Value -> [Text] +keysOf (Object o) = map Key.toText (KeyMap.keys o) +keysOf _ = [] + +-- | @info.version@. +specVersion :: Spec -> Maybe Text +specVersion (Spec v) = case at ["info", "version"] v of + Just (String t) -> Just t + _ -> Nothing + +-- | Every operation, as @(METHOD, path)@. +specOperations :: Spec -> [(Text, Text)] +specOperations (Spec v) = + [ (Text.toUpper method, path) + | path <- keysOf (fromMaybe Null (at ["paths"] v)) + , method <- keysOf (fromMaybe Null (at ["paths", path] v)) + ] + +-- | The names under @components.schemas@. +specSchemaNames :: Spec -> [Text] +specSchemaNames (Spec v) = keysOf (fromMaybe Null (at ["components", "schemas"] v)) + +-- | A schema that refers to a named component. +schemaRef :: Text -> Value +schemaRef name = Aeson.object ["$ref" Aeson..= ("#/components/schemas/" <> name)] + +lookupSchema :: Spec -> Text -> Maybe Value +lookupSchema (Spec v) name = at ["components", "schemas", name] v + +-- | The declared properties of an object schema. +objectProperties :: Spec -> Text -> [Text] +objectProperties spec name = keysOf (fromMaybe Null (lookupSchema spec name >>= at ["properties"])) + +-- | The required properties of an object schema. +requiredProperties :: Spec -> Text -> [Text] +requiredProperties spec name = case lookupSchema spec name >>= at ["required"] of + Just (Array xs) -> [t | String t <- toList xs] + _ -> [] + +-- | The tags of a discriminated union, from its @discriminator.mapping@. +discriminatorTags :: Spec -> Text -> [Text] +discriminatorTags spec name = keysOf (fromMaybe Null (lookupSchema spec name >>= at ["discriminator", "mapping"])) + +-- | The first example of every property of an object schema that has one. +propertyExamples :: Spec -> Text -> [(Text, Value)] +propertyExamples spec name = + mapMaybe + ( \p -> case lookupSchema spec name >>= at ["properties", p, "examples"] of + Just (Array xs) | not (Vector.null xs) -> Just (p, Vector.head xs) + _ -> Nothing + ) + (objectProperties spec name) + +-- | Every JSON Schema keyword used anywhere under @components.schemas@. +specKeywords :: Spec -> [Text] +specKeywords (Spec v) = case at ["components", "schemas"] v of + Just (Object schemas) -> concatMap schemaKeys (KeyMap.elems schemas) + _ -> [] + where + schemaKeys = \case + Object s -> map Key.toText (KeyMap.keys s) <> concatMap (uncurry nested) (KeyMap.toList s) + _ -> [] + nested k sub = case (Key.toText k, sub) of + ("properties", Object props) -> concatMap schemaKeys (KeyMap.elems props) + ("additionalProperties", Object _) -> schemaKeys sub + ("items", Object _) -> schemaKeys sub + ("anyOf", Array alts) -> concatMap schemaKeys (toList alts) + ("oneOf", Array alts) -> concatMap schemaKeys (toList alts) + _ -> [] + +-- | The keywords 'validate' understands. +supportedKeywords :: [Text] +supportedKeywords = + [ "$ref", "type", "const", "properties", "required", "additionalProperties", "items" + , "minItems", "minProperties", "anyOf", "oneOf" + , "discriminator", "title", "description", "examples", "default" + ] + +-- | Validate a JSON value against a schema. Returns one message per problem, +-- each prefixed with a JSON path; an empty list means the value is valid. +validate :: Spec -> Value -> Value -> [String] +validate spec = go "$" + where + go :: String -> Value -> Value -> [String] + go path schema value = case schema of + Bool True -> [] + Bool False -> [path <> ": no value is allowed here"] + Object s -> concatMap (keyword path s value) (KeyMap.toList s) + _ -> [path <> ": malformed schema " <> show schema] + + keyword :: String -> Aeson.Object -> Value -> (Key.Key, Value) -> [String] + keyword path s value (k, arg) = case Key.toText k of + "$ref" -> case arg of + String ref + | Just name <- Text.stripPrefix "#/components/schemas/" ref + , Just target <- lookupSchema spec name -> + go path target value + _ -> [path <> ": cannot resolve $ref " <> show arg] + "type" -> case arg of + String t -> [path <> ": expected " <> Text.unpack t <> ", got " <> kind value | not (hasType t value)] + Array ts -> + [ path <> ": expected one of " <> show (toList ts) <> ", got " <> kind value + | not (or [hasType t value | String t <- toList ts]) + ] + _ -> [path <> ": malformed type"] + "const" -> [path <> ": expected " <> show arg <> ", got " <> show value | arg /= value] + "properties" -> case (arg, value) of + (Object props, Object o) -> + concat + [ go (path <> "." <> Key.toString p) propSchema v + | (p, propSchema) <- KeyMap.toList props + , Just v <- [KeyMap.lookup p o] + ] + _ -> [] + "required" -> case (arg, value) of + (Array names, Object o) -> + [ path <> ": missing required property " <> Text.unpack n + | String n <- toList names + , not (KeyMap.member (Key.fromText n) o) + ] + _ -> [] + "additionalProperties" -> case value of + Object o -> + let declared = case KeyMap.lookup "properties" s of + Just (Object props) -> props + _ -> KeyMap.empty + in concat + [ go (path <> "." <> Key.toString p) arg v + | (p, v) <- KeyMap.toList o + , not (KeyMap.member p declared) + ] + _ -> [] + "items" -> case value of + Array xs -> concat [go (path <> "[" <> show i <> "]") arg x | (i, x) <- zip [0 :: Int ..] (toList xs)] + _ -> [] + "minItems" -> case (arg, value) of + (Number n, Array xs) -> [path <> ": fewer than " <> show n <> " items" | fromIntegral (length xs) < n] + _ -> [] + "minProperties" -> case (arg, value) of + (Number n, Object o) -> [path <> ": fewer than " <> show n <> " properties" | fromIntegral (KeyMap.size o) < n] + _ -> [] + "anyOf" -> case arg of + Array alternatives + | any null [go path alt value | alt <- toList alternatives] -> [] + | otherwise -> [path <> ": matches none of the anyOf alternatives"] + _ -> [path <> ": malformed anyOf"] + "oneOf" -> case arg of + Array alternatives -> + let matching = length (filter null [go path alt value | alt <- toList alternatives]) + in [path <> ": matches " <> show matching <> " oneOf alternatives, expected exactly 1" | matching /= 1] + _ -> [path <> ": malformed oneOf"] + -- Annotations that do not constrain values. + "discriminator" -> [] + "title" -> [] + "description" -> [] + "examples" -> [] + "default" -> [] + other -> [path <> ": unsupported JSON Schema keyword " <> show other <> "; teach TypeSafe.JsonSchema about it"] + + hasType :: Text -> Value -> Bool + hasType t v = case (t, v) of + ("string", String _) -> True + ("number", Number _) -> True + ("integer", Number n) -> Scientific.isInteger n + ("boolean", Bool _) -> True + ("object", Object _) -> True + ("array", Array _) -> True + ("null", Null) -> True + _ -> False + + kind :: Value -> String + kind = \case + String _ -> "a string" + Number _ -> "a number" + Bool _ -> "a boolean" + Object _ -> "an object" + Array _ -> "an array" + Null -> "null" diff --git a/typesafe-ai-core/test/TypeSafe/QuestionSpec.hs b/typesafe-ai-core/test/TypeSafe/QuestionSpec.hs new file mode 100644 index 0000000..1b1c66f --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/QuestionSpec.hs @@ -0,0 +1,280 @@ +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} + +-- | The typed question layer and calls built from it. +module TypeSafe.QuestionSpec (tests) where + +import Data.Aeson (FromJSON (..), Value (..), eitherDecode, encode, object, withObject, (.:), (.=)) +import qualified Data.Aeson.KeyMap as KeyMap +import qualified Data.ByteString.Lazy.Char8 as LBS +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmpty +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as Map +import Data.Text (Text) +import GHC.Generics (Generic) +import Network.HTTP.Types (status200, status422) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (Assertion, assertFailure, testCase, (@?=)) +import TypeSafe.Core +import qualified TypeSafe.Wire as Wire + +data Department = Billing | Technical | Sales + deriving stock (Show, Eq, Ord, Generic) + deriving anyclass (ChoiceOption) + +data Tone = Zealous | Angry | NeedsReview + deriving stock (Show, Eq, Generic) + +instance ChoiceOption Tone where + optionDescription = \case + Zealous -> Just "Enthusiastic" + _ -> Nothing + +data Frustration = Calm | Frustrated | VeryAngry + deriving stock (Show, Eq, Generic) + deriving anyclass (ScoreLevel) + +data Triage = Triage + { triageDepartment :: Choice Department + , triageUrgent :: Noul + , triageFrustration :: Score Frustration + } + deriving stock (Show, Eq) + +triage :: Questions Triage +triage = + Triage + <$> ask "department" (choice "Which team should handle this?") + <*> ask "is_urgent" (noul "Does this convey urgency?") + <*> ask "frustration" (score "How frustrated is the customer?") + +answersOf :: LBS.ByteString -> Map QuestionId Wire.Answer +answersOf body = either error id (eitherDecode body) + +sampleAnswers :: Map QuestionId Wire.Answer +sampleAnswers = + answersOf + "{\"department\":{\"type\":\"choice\",\"choice\":\"billing\",\"confidence\":0.81,\ + \\"probabilities\":{\"billing\":0.88,\"technical\":0.12,\"sales\":0.0}},\ + \\"is_urgent\":{\"type\":\"noul\",\"noul\":0.95},\ + \\"frustration\":{\"type\":\"score\",\"score\":1.05,\"confidence\":0.92,\ + \\"legend\":{\"0\":\"calm\",\"1\":\"frustrated\",\"2\":\"very angry\"},\ + \\"probabilities\":{\"0\":0.0,\"1\":0.95,\"2\":0.05}}}" + +specOf :: Question a -> Value +specOf q = either (error . show) (either error id . eitherDecode . encode) (questionSpec q) + +-- | The answers must fail to decode with exactly these problems. +decodesTo :: (Show a) => Either (NonEmpty AnswerError) a -> [AnswerError] -> Assertion +decodesTo result expected = case result of + Left errs -> NonEmpty.toList errs @?= expected + Right a -> assertFailure ("decoded unexpectedly: " <> show a) + +tests :: TestTree +tests = + testGroup + "Questions" + [ testGroup + "rendering" + [ testCase "derived options are snake case, in declaration order, with descriptions" $ + specOf (choice @Tone "What is the tone?") + @?= object + [ "type" .= ("choice" :: Text) + , "instructions" .= ("What is the tone?" :: Text) + , "criteria" .= object ["zealous" .= ("Enthusiastic" :: Text), "angry" .= Null, "needs_review" .= Null] + ] + , testCase "options are sent in declaration order, not sorted" $ + either show (LBS.unpack . encode) (questionSpec (choice @Tone "?")) + @?= "{\"type\":\"choice\",\"instructions\":\"?\",\"criteria\":{\"zealous\":\"Enthusiastic\",\"angry\":null,\"needs_review\":null}}" + , testCase "derived levels are lower-case words, lowest first" $ + specOf (score @Frustration "How frustrated?") + @?= object + [ "type" .= ("score" :: Text) + , "instructions" .= ("How frustrated?" :: Text) + , "criteria" .= ["calm" :: Text, "frustrated", "very angry"] + ] + , testCase "noulWith sends both criteria" $ + specOf (noulWith "Spam?" "Unsolicited advertising" "A legitimate message") + @?= object + [ "type" .= ("noul" :: Text) + , "instructions" .= ("Spam?" :: Text) + , "criteria" .= object ["true" .= ("Unsolicited advertising" :: Text), "false" .= ("A legitimate message" :: Text)] + ] + , testCase "a request needs a question" $ + renderQuestions (pure ()) @?= Left NoQuestions + , testCase "question ids must be distinct" $ + renderQuestions (ask "a" (noul "1") *> ask "b" (noul "2") *> ask "a" (noul "3")) + @?= Left (DuplicateQuestionId "a") + , testCase "option names must be distinct" $ + renderQuestions (ask "tone" (choiceBy (const "same") (const Nothing) "?" (1 :| [2 :: Int]))) + @?= Left (InvalidQuestion "tone" (DuplicateOption "same")) + , testCase "questionIds keeps the order of asking" $ + questionIds triage @?= ["department", "is_urgent", "frustration"] + , testCase "askMap asks every question" $ + fmap Map.keys (renderQuestions (askMap (Map.fromList [("x", noul "?"), ("y", noul "!")]))) + @?= Right ["x", "y"] + ] + , testGroup + "decoding" + [ testCase "a complete response decodes to the typed result" $ + decodeAnswers triage sampleAnswers + @?= Right + Triage + { triageDepartment = + Choice Billing ((Billing, 0.88) :| [(Technical, 0.12), (Sales, 0)]) 0.81 + , triageUrgent = Noul 0.95 + , triageFrustration = + Score 1.05 ((Calm, 0) :| [(Frustrated, 0.95), (VeryAngry, 0.05)]) 0.92 + } + , testCase "every unusable answer is reported" $ + decodeAnswers triage (Map.delete "is_urgent" (Map.insert "frustration" (Wire.AnswerNoul (Wire.NoulAnswer 1)) sampleAnswers)) + `decodesTo` [ AnswerError "is_urgent" MissingAnswer + , AnswerError "frustration" (UnexpectedAnswerType "score" "noul") + ] + , testCase "a choice outside the offered options is rejected" $ + decodeAnswers + (ask "d" (choice @Department "?")) + (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"legal\",\"confidence\":1,\"probabilities\":{\"legal\":1}}}") + `decodesTo` [AnswerError "d" (UnknownOption "legal")] + , testCase "a probability for an option that was not offered is rejected" $ + decodeAnswers + (ask "d" (choice @Department "?")) + (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"sales\",\"confidence\":1,\"probabilities\":{\"sales\":0.5,\"legal\":0.5}}}") + `decodesTo` [AnswerError "d" (UnknownOption "legal")] + , testCase "options missing from the probabilities count as 0" $ + fmap choiceProbabilities + ( decodeAnswers + (ask "d" (choice @Department "?")) + (answersOf "{\"d\":{\"type\":\"choice\",\"choice\":\"sales\",\"confidence\":1,\"probabilities\":{\"sales\":1}}}") + ) + @?= Right ((Billing, 0) :| [(Technical, 0), (Sales, 1)]) + , testCase "a score level outside the rubric is rejected" $ + decodeAnswers + (ask "f" (score @Frustration "?")) + (answersOf "{\"f\":{\"type\":\"score\",\"score\":3,\"confidence\":1,\"legend\":{},\"probabilities\":{\"3\":1}}}") + `decodesTo` [AnswerError "f" (UnknownLevel 3)] + , testCase "scoreRubric levels are indices" $ + fmap (fmap fst . scoreProbabilities) + ( decodeAnswers + (ask "f" (scoreRubric "?" ("low" :| ["high"]))) + (answersOf "{\"f\":{\"type\":\"score\",\"score\":0.2,\"confidence\":0.6,\"legend\":{},\"probabilities\":{\"0\":0.8,\"1\":0.2}}}") + ) + @?= Right (0 :| [1]) + , testCase "otherQuestion decodes new answer types with FromJSON" $ + decodeAnswers + (ask "r" (otherQuestion "rank" (KeyMap.fromList [("items", toJSONList' ["a", "b"])]))) + (answersOf "{\"r\":{\"type\":\"rank\",\"order\":[\"b\",\"a\"]}}") + @?= Right (Ranking ["b", "a"]) + , testCase "rawQuestion passes the answer through" $ + decodeAnswers (ask "q" (rawQuestion (Wire.QuestionNoul (Wire.NoulQuestion (Just "?") Nothing)))) sampleAnswers + `decodesTo` [AnswerError "q" MissingAnswer] + ] + , testGroup + "answer helpers" + [ testCase "rankedChoices sorts by probability, keeping offer order on ties" $ + rankedChoices (Choice 'b' (('a', 0.25) :| [('b', 0.5), ('c', 0.25)]) 0.5) + @?= (('b', 0.5) :| [('a', 0.25), ('c', 0.25)]) + , testCase "choiceProbability of an unknown option is 0" $ + choiceProbability 'z' (Choice 'a' (('a', 1) :| []) 1) @?= 0 + , testCase "mostLikelyLevel prefers the lower level on a tie" $ + mostLikelyLevel (Score 0.5 ((0 :: Int, 0.5) :| [(1, 0.5)]) 0) @?= 0 + , testCase "nearestLevel clamps to the rubric" $ + map (\v -> nearestLevel (Score v ((0 :: Int, 1) :| [(1, 0), (2, 0)]) 1)) [-1, 0.4, 0.6, 1.5, 7] + @?= [0, 0, 1, 2, 2] + , testCase "normalizedScore scales to 0-1" $ + map (\v -> normalizedScore (Score v (('a', 1) :| [('b', 0), ('c', 0)]) 1)) [0, 1, 2] @?= [0, 0.5, 1] + , testCase "normalizedScore of a one-level rubric is 0" $ + normalizedScore (Score 0 (('a', 1) :| []) 1) @?= 0 + , testCase "confidence is shared by Choice and Score" $ + (confidence (Choice 'a' (('a', 1) :| []) 0.7), confidence (Score 0 (('a', 1) :| []) 0.3)) + @?= (0.7, 0.3) + ] + , testGroup + "calls" + [ testCase "systemOne uses the default model" $ + bodyOf (renderCall defaults (systemOne "hi" (ask "q" (noul "?")))) + `rightIs` Just "{\"state\":\"hi\",\"model\":\"jev-latest\",\"questions\":{\"q\":{\"type\":\"noul\",\"instructions\":\"?\"}}}" + , testCase "withModel overrides the default model" $ + fmap (lookupKey "model") (bodyJson (renderCall defaults (withModel "jev-1.13.0" (systemOne "hi" (ask "q" (noul "?")))))) + @?= Right (Just (String "jev-1.13.0")) + , testCase "withExtraBody adds fields but cannot replace the SDK's" $ + fmap (\o -> (lookupKey "beam_width" o, lookupKey "model" o)) + ( bodyJson + ( renderCall defaults . withExtraBody (KeyMap.fromList [("beam_width", Number 4), ("model", "evil")]) $ + systemOne "hi" (ask "q" (noul "?")) + ) + ) + @?= Right (Just (Number 4), Just (String "jev-latest")) + , testCase "systemOneRaw keeps the request's model unless overridden" $ do + let raw = Wire.SystemOneRequest "hi" "jev-1.13.0" (Map.fromList [("q", Wire.QuestionNoul (Wire.NoulQuestion (Just "?") Nothing))]) + fmap (lookupKey "model") (bodyJson (renderCall defaults (systemOneRaw raw))) @?= Right (Just (String "jev-1.13.0")) + fmap (lookupKey "model") (bodyJson (renderCall defaults (withModel "jev-preview" (systemOneRaw raw)))) @?= Right (Just (String "jev-preview")) + , testCase "invalid questions are rejected before sending" $ + case renderCall defaults (systemOne "hi" (pure ())) of + Left (InvalidRequest NoQuestions) -> pure () + other -> assertFailure (show other) + , testCase "listModels is a GET without a body" $ + fmap (\r -> (httpRequestMethod r, httpRequestPath r, httpRequestBody r, lookup "Content-Type" (httpRequestHeaders r))) (renderCall defaults listModels) + `rightIs` ("GET", ["v1", "models"], Nothing, Nothing) + , testCase "per-call headers win over client headers; protected headers are dropped" $ + fmap httpRequestHeaders + ( renderCall + defaults {callDefaultHeaders = [("X-Team", "search"), ("X-Trace", "client"), ("Authorization", "Bearer stolen")]} + (withHeaders [("X-Trace", "call"), ("Accept", "text/html")] listModels) + ) + `rightIs` [("Accept", "application/json"), ("X-Trace", "call"), ("X-Team", "search")] + , testCase "a 2xx body that does not match the schema is a ResponseError" $ + case parseResponse listModels (HttpResponse status200 [("x-typesafe-request-id", "req_1")] "{\"models\": 3}") of + Left (ResponseError e) -> do + responseErrorRequestId e @?= Just "req_1" + responseErrorEndpoint e @?= "GET /v1/models" + other -> assertFailure (show other) + , testCase "an error status is a ServiceError" $ + case parseResponse listModels (HttpResponse status422 [] "{\"detail\":[{\"loc\":[\"body\",\"state\"],\"msg\":\"Field required\",\"type\":\"missing\"}]}") of + Left (ServiceError e) -> do + apiErrorKind e @?= UnprocessableEntity + apiErrorMessage e @?= Just "body.state: Field required" + other -> assertFailure (show other) + , testCase "a typed evaluation keeps the raw response" $ do + let body = + "{\"model\":\"jev-1.13.0\",\"answers\":{\"q\":{\"type\":\"noul\",\"noul\":0.5},\"extra\":{\"type\":\"noul\",\"noul\":0.1}},\ + \\"usage\":{\"input_tokens\":7,\"output_tokens\":2}}" + case parseResponse (systemOne "hi" (ask "q" (noul "?"))) (HttpResponse status200 [] body) of + Right e -> do + evaluationAnswers e @?= Noul 0.5 + evaluationUsage e @?= Usage 7 2 + Map.keys (Wire.systemOneResponseAnswers (evaluationResponse e)) @?= ["extra", "q"] + Left err -> assertFailure (show err) + , testCase "systemOneRequest and decodeEvaluation work without a Call" $ do + request <- either (assertFailure . show) pure (systemOneRequest jevLatest "hi" triage) + Map.keys (Wire.systemOneRequestQuestions request) @?= ["department", "frustration", "is_urgent"] + let response = Wire.SystemOneResponse "jev-1.13.0" sampleAnswers (Usage 1 1) + fmap (choiceSelected . triageDepartment . evaluationAnswers) (decodeEvaluation triage Nothing response) + @?= Right Billing + ] + ] + where + defaults = CallDefaults jevLatest [] + bodyOf = fmap (fmap LBS.unpack . httpRequestBody) + bodyJson r = case r of + Left e -> Left (show e) + Right req -> maybe (Left "no body") eitherDecode (httpRequestBody req) + lookupKey k o = KeyMap.lookup k (o :: KeyMap.KeyMap Value) + rightIs :: (Eq a, Show a) => Either TypeSafeError a -> a -> Assertion + rightIs r expected = case r of + Right a -> a @?= expected + Left e -> assertFailure (show e) + toJSONList' :: [Text] -> Value + toJSONList' = Array . foldMap pure . map String + +-- | An answer type the SDK does not know about. +newtype Ranking = Ranking [Text] + deriving stock (Show, Eq) + +instance FromJSON Ranking where + parseJSON = withObject "Ranking" $ \o -> Ranking <$> o .: "order" diff --git a/typesafe-ai-core/test/TypeSafe/RetrySpec.hs b/typesafe-ai-core/test/TypeSafe/RetrySpec.hs new file mode 100644 index 0000000..911d459 --- /dev/null +++ b/typesafe-ai-core/test/TypeSafe/RetrySpec.hs @@ -0,0 +1,64 @@ +{-# LANGUAGE OverloadedStrings #-} + +module TypeSafe.RetrySpec (tests) where + +import Control.Exception (toException) +import Data.Time (NominalDiffTime, UTCTime (..), addUTCTime, fromGregorian) +import Data.Time.Format (defaultTimeLocale, formatTime) +import qualified Data.ByteString.Char8 as BS8 +import Network.HTTP.Types (ResponseHeaders, mkStatus) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) +import Test.Tasty.QuickCheck (choose, forAll, testProperty, (.&&.)) +import TypeSafe.Error +import TypeSafe.Retry + +now :: UTCTime +now = UTCTime (fromGregorian 2026 9 22) 43200 + +serviceError :: Int -> ResponseHeaders -> TypeSafeError +serviceError c headers = ServiceError (apiErrorFromResponse "POST /v1/systemone" (mkStatus c "") headers "") + +tests :: TestTree +tests = + testGroup + "Retries" + [ testCase "transient statuses are retried, client errors are not" $ + map (\c -> isRetryable defaultRetryPolicy (serviceError c [])) [408, 429, 500, 503, 529, 400, 401, 403, 404, 422] + @?= [True, True, True, True, True, False, False, False, False, False] + , testCase "connection failures and timeouts follow their switches" $ do + let failed = ConnectionError (ConnectionFailed "GET /v1/models" (toException (userError "reset"))) + timedOut = ConnectionError (ConnectionTimedOut "GET /v1/models") + map (isRetryable defaultRetryPolicy) [failed, timedOut] @?= [True, True] + isRetryable defaultRetryPolicy {retryConnectionErrors = False} failed @?= False + isRetryable defaultRetryPolicy {retryTimeouts = False} timedOut @?= False + , testCase "invalid requests are never retried" $ + isRetryable defaultRetryPolicy (InvalidRequest NoQuestions) @?= False + , testCase "backoff doubles up to the maximum" $ + map (backoffDelay defaultRetryPolicy) [1 .. 6] @?= [0.5, 1, 2, 4, 5, 5] + , testCase "zero initial backoff disables waiting" $ + backoffDelay defaultRetryPolicy {retryInitialBackoff = 0} 3 @?= 0 + , testProperty "jitter only shortens the delay, by at most the jitter fraction" $ + forAll (choose (0, 0.999999)) $ \u -> + let d = applyJitter defaultRetryPolicy u 4 + in (d <= 4) .&&. (d >= 3) + , testCase "retry-after-ms wins over Retry-After" $ + retryAfter now [("Retry-After", "10"), ("retry-after-ms", "1500")] @?= Just 1.5 + , testCase "Retry-After as seconds and as a date" $ do + retryAfter now [("retry-after", "7")] @?= Just 7 + retryAfter now [("Retry-After", httpDate (addUTCTime 42 now))] @?= Just 42 + retryAfter now [("Retry-After", httpDate (addUTCTime (-5) now))] @?= Just 0 + , testCase "malformed Retry-After headers are ignored" $ do + retryAfter now [("Retry-After", "soon")] @?= Nothing + retryAfter now [("Retry-After", "-3")] @?= Nothing + retryAfter now [] @?= Nothing + , testCase "a short server delay replaces the backoff" $ + retryDelay defaultRetryPolicy now 0.5 1 (serviceError 429 [("retry-after-ms", "200")]) @?= 0.2 + , testCase "a server delay above the maximum falls back to backoff" $ + retryDelay defaultRetryPolicy now 0 2 (serviceError 429 [("Retry-After", "3600")]) @?= 1 + , testCase "server delays can be ignored" $ + retryDelay defaultRetryPolicy {retryRespectRetryAfter = False} now 0 1 (serviceError 429 [("Retry-After", "3")]) + @?= (0.5 :: NominalDiffTime) + ] + where + httpDate = BS8.pack . formatTime defaultTimeLocale "%a, %d %b %Y %H:%M:%S GMT" diff --git a/typesafe-ai-core/typesafe-ai-core.cabal b/typesafe-ai-core/typesafe-ai-core.cabal new file mode 100644 index 0000000..04a4899 --- /dev/null +++ b/typesafe-ai-core/typesafe-ai-core.cabal @@ -0,0 +1,101 @@ +cabal-version: 3.0 +name: typesafe-ai-core +version: 0.1.0.0 +synopsis: Types, JSON codecs and typed questions for the TypeSafe AI API +description: + Transport-agnostic bindings to the TypeSafe System One API + (): typed Noul, Choice and Score questions whose + answers decode to your own Haskell types, a one-to-one mirror of the + OpenAPI schemas, and API calls as plain values. + . + This package does no networking, so it can be used with servant or any + other HTTP stack. For a ready-to-use client, depend on @typesafe-ai@. + . + Start with "TypeSafe.Core" and "TypeSafe.Question". + . + This is a community SDK, not affiliated with or endorsed by TypeSafe AI. + +homepage: https://github.com/byteally/typesafe-sdk +bug-reports: https://github.com/byteally/typesafe-sdk/issues +license: BSD-3-Clause +license-file: LICENSE +author: Magesh B +maintainer: magesh85@gmail.com +copyright: 2026 byteally +category: AI, Web, API +build-type: Simple +tested-with: + GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1 + +extra-doc-files: + CHANGELOG.md + README.md + +extra-source-files: + spec/openapi.json + +source-repository head + type: git + location: https://github.com/byteally/typesafe-sdk.git + subdir: typesafe-ai-core + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-deriving-strategies + -Wpartial-fields -Wredundant-constraints -Wunused-packages + +library + import: warnings + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + TypeSafe.Call + TypeSafe.Content + TypeSafe.Core + TypeSafe.Error + TypeSafe.Internal.Generic + TypeSafe.Question + TypeSafe.Retry + TypeSafe.Wire + + build-depends: + , aeson >=2.1 && <2.4 + , base >=4.18 && <4.23 + , bytestring >=0.11.3 && <0.13 + , containers >=0.6.7 && <0.9 + , deepseq >=1.4.8 && <1.6 + , http-types >=0.12.3 && <0.13 + , text >=2.0 && <2.2 + , time >=1.12 && <1.17 + , vector >=0.13 && <0.14 + +test-suite spec + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + main-is: Main.hs + other-modules: + TypeSafe.ArbitraryInstances + TypeSafe.ConformanceSpec + TypeSafe.ErrorSpec + TypeSafe.JsonSchema + TypeSafe.QuestionSpec + TypeSafe.RetrySpec + + build-depends: + , aeson + , base + , bytestring + , containers + , http-types + , QuickCheck >=2.14 && <2.19 + , scientific >=0.3 && <0.4 + , tasty >=1.4 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , tasty-quickcheck >=0.10 && <0.12 + , text + , time + , typesafe-ai-core + , vector diff --git a/typesafe-ai/CHANGELOG.md b/typesafe-ai/CHANGELOG.md new file mode 100644 index 0000000..24ef8de --- /dev/null +++ b/typesafe-ai/CHANGELOG.md @@ -0,0 +1,18 @@ +# Changelog for typesafe-ai + +This package follows the [PVP](https://pvp.haskell.org) and is released +together with `typesafe-ai-core`, with the same version number. + +## 0.1.0.0 + +First release. Checked against version 0.2.0 of the TypeSafe OpenAPI +specification. + +- `TypeSafe.Client`: an `http-client` transport with a shared TLS connection + pool, per-attempt timeouts, retries with exponential backoff and jitter that + honour `Retry-After` and `retry-after-ms`, and a logging hook. +- Configuration from `TYPESAFE_API_KEY`, `TYPESAFE_BASE_URL` and + `TYPESAFE_DEFAULT_MODEL`, like the official Python and JavaScript SDKs. +- `TypeSafe` re-exports the whole API, and the package re-exports the modules + of `typesafe-ai-core`. +- `TypeSafe.Tutorial`: a guided tour of the SDK. diff --git a/typesafe-ai/LICENSE b/typesafe-ai/LICENSE new file mode 100644 index 0000000..945b9f1 --- /dev/null +++ b/typesafe-ai/LICENSE @@ -0,0 +1,28 @@ +BSD 3-Clause License + +Copyright (c) 2026, byteally + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +1. Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/typesafe-ai/README.md b/typesafe-ai/README.md new file mode 100644 index 0000000..c268c2e --- /dev/null +++ b/typesafe-ai/README.md @@ -0,0 +1,44 @@ +# typesafe-ai + +A Haskell client for [TypeSafe AI](https://typesafe.ai)'s System One API. +Send text or JSON state with typed questions, and get back answers that decode +to your own Haskell types. + +```haskell +{-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, OverloadedStrings #-} + +import GHC.Generics (Generic) +import TypeSafe + +data Department = Billing | Technical | Sales + deriving stock (Show, Eq, Generic) + deriving anyclass (ChoiceOption) + +main :: IO () +main = do + client <- newClientFromEnv -- reads TYPESAFE_API_KEY + result <- + send client $ + systemOne "Help! My payouts have been failing for 3 days." $ + (,) <$> ask "department" (choice "Which team should handle this?") + <*> ask "is_urgent" (noul "Does this convey urgency?") + let (department, urgent) = evaluationAnswers result + print (choiceSelected department :: Department, choiceConfidence department) + print (noulProbability urgent) +``` + +- Choice options and Score levels are your own types; the answer can only be + one of them. +- Questions combine with `Applicative`, and many questions fit in one + request. +- Built on `http-client`, with a shared TLS connection pool, per-attempt + timeouts, and retries with exponential backoff that honour `Retry-After`. +- Errors are values that separate local validation, error responses, + connection failures and unexpected responses. + +Read `TypeSafe.Tutorial` for a guided tour. The types, codecs and calls live +in [`typesafe-ai-core`](https://hackage.haskell.org/package/typesafe-ai-core), +which has no HTTP dependency. The +[repository](https://github.com/byteally/typesafe-sdk) has runnable examples. + +This is a community SDK, not affiliated with or endorsed by TypeSafe AI. diff --git a/typesafe-ai/src/TypeSafe.hs b/typesafe-ai/src/TypeSafe.hs new file mode 100644 index 0000000..37d7276 --- /dev/null +++ b/typesafe-ai/src/TypeSafe.hs @@ -0,0 +1,59 @@ +-- | +-- Module : TypeSafe +-- Description : Typed questions for the TypeSafe System One API +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- A client for TypeSafe's System One API (). +-- Send a /state/ (text or JSON) with typed questions, and get back answers +-- your code can use directly: a probability for a yes\/no 'noul', one of your +-- own options for a 'choice', a level of your own rubric for a 'score'. +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, OverloadedStrings #-} +-- +-- import GHC.Generics (Generic) +-- import TypeSafe +-- +-- data Department = Billing | Technical | Sales +-- deriving stock (Show, Generic) +-- deriving anyclass ('ChoiceOption') +-- +-- main :: IO () +-- main = do +-- client <- 'newClientFromEnv' +-- result <- +-- 'send' client $ +-- 'systemOne' \"Help! My payouts have been failing for 3 days.\" $ +-- (,) +-- \<$\> 'ask' \"department\" ('choice' \"Which team should handle this?\") +-- \<*\> 'ask' \"is_urgent\" ('noul' \"Does this convey urgency?\") +-- let (department, urgent) = 'evaluationAnswers' result +-- print ('choiceSelected' department :: Department, 'choiceConfidence' department) +-- print ('noulProbability' urgent) +-- @ +-- +-- "TypeSafe.Tutorial" walks through the library step by step. The other +-- modules are: +-- +-- ["TypeSafe.Question"] questions and answers ('noul', 'choice', 'score', +-- 'ask'). +-- +-- ["TypeSafe.Call"] the API calls ('systemOne', 'listModels') and per-call +-- options ('withModel', 'withTimeout', …). +-- +-- ["TypeSafe.Client"] the HTTP client ('newClientFromEnv', 'send'). +-- +-- ["TypeSafe.Error"], ["TypeSafe.Retry"] errors and the retry policy. +-- +-- ["TypeSafe.Wire"] the raw OpenAPI schemas. Not re-exported. +-- +-- The types, codecs and calls live in the @typesafe-ai-core@ package, which +-- has no HTTP dependency; this package adds the @http-client@ transport. +module TypeSafe + ( module TypeSafe.Core + , module TypeSafe.Client + ) where + +import TypeSafe.Client +import TypeSafe.Core diff --git a/typesafe-ai/src/TypeSafe/Client.hs b/typesafe-ai/src/TypeSafe/Client.hs new file mode 100644 index 0000000..6e3122e --- /dev/null +++ b/typesafe-ai/src/TypeSafe/Client.hs @@ -0,0 +1,446 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | +-- Module : TypeSafe.Client +-- Description : A TypeSafe API client built on http-client +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- Sends 'Call's (see "TypeSafe.Call") to the TypeSafe API over +-- @http-client@, with TLS, connection reuse, timeouts and retries. +-- +-- @ +-- import TypeSafe +-- +-- main :: IO () +-- main = do +-- client <- 'newClientFromEnv' -- reads TYPESAFE_API_KEY +-- result <- 'send' client $ +-- 'systemOne' \"Help! My payouts have been failing for 3 days.\" +-- ('ask' \"is_urgent\" ('noul' \"Does this convey urgency?\")) +-- print ('noulProbability' ('evaluationAnswers' result)) +-- @ +-- +-- A 'Client' is immutable and thread-safe. Create one per application and +-- share it: its connection pool is what makes repeated calls fast. +-- +-- = Timeouts and retries +-- +-- Each attempt must complete within 'configTimeout' (10 seconds by default, +-- see 'withTimeout' to change it per call). Failed attempts are retried +-- according to 'configRetryPolicy', or the policy set with 'withRetryPolicy'; +-- see "TypeSafe.Retry" for the defaults. +module TypeSafe.Client + ( -- * Clients + Client + , newClient + , newClientWith + , newClientFromEnv + , clientConfig + + -- * Sending calls + , send + , sendEither + + -- * Configuration + , ClientConfig (..) + , defaultClientConfig + , clientConfigFromEnv + , ApiKey + , mkApiKey + , ConfigError (..) + + -- ** Environment variables + , apiKeyEnv + , baseUrlEnv + , defaultModelEnv + + -- * Logging + , LogEvent (..) + , LogStage (..) + , renderLogEvent + , stderrLogger + + -- * Identification + , userAgent + + -- * Re-exports + , Manager + ) where + +import Control.Concurrent (threadDelay) +import Control.Exception (Exception (..), throwIO, toException, try) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Char8 as BS8 +import Data.Maybe (fromMaybe) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import qualified Data.Text.Encoding.Error as Text +import qualified Data.Text.IO as Text +import Data.Time.Clock (NominalDiffTime, getCurrentTime) +import Data.Version (showVersion) +import GHC.Clock (getMonotonicTime) +import GHC.Generics (Generic) +import Numeric (showFFloat) +import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..), Manager) +import qualified Network.HTTP.Client as HTTP +import Network.HTTP.Client.TLS (newTlsManager) +import Network.HTTP.Types (RequestHeaders, Status, statusCode, urlEncode) +import qualified Paths_typesafe_ai as Paths +import System.Environment (lookupEnv) +import System.IO (stderr) +import qualified System.Info as Info +import System.Random (randomRIO) +import System.Timeout (timeout) +import TypeSafe.Core + +-- $setup +-- >>> :set -XOverloadedStrings + +------------------------------------------------------------------------------ +-- Configuration + +-- | A validated API key. Its 'Show' instance never reveals the key. +newtype ApiKey = ApiKey BS.ByteString + +instance Show ApiKey where + show _ = "" + +-- | Validate an API key. Surrounding whitespace, such as the newline at the +-- end of a key file, is removed; an empty key or one containing whitespace, +-- control or non-ASCII characters is rejected. +-- +-- >>> mkApiKey " ts_live_abc123\n" +-- Right +-- +-- >>> mkApiKey "ts live" +-- Left (InvalidApiKey "the API key contains whitespace, control or non-ASCII characters") +mkApiKey :: Text -> Either ConfigError ApiKey +mkApiKey raw + | Text.null key = Left (InvalidApiKey "the API key is empty") + | Text.any (\c -> c < '!' || c > '~') key = + Left (InvalidApiKey "the API key contains whitespace, control or non-ASCII characters") + | otherwise = Right (ApiKey (Text.encodeUtf8 key)) + where + key = Text.strip raw + +-- | Why a client could not be configured. +data ConfigError + = -- | No API key was given, and 'apiKeyEnv' is unset or blank. + MissingApiKey + | -- | The API key is malformed. + InvalidApiKey !Text + | -- | The base URL cannot be parsed: the URL and the reason. + InvalidBaseUrl !Text !Text + | -- | The timeout is not positive. + InvalidTimeout !NominalDiffTime + deriving stock (Eq, Show, Generic) + +instance Exception ConfigError where + displayException = \case + MissingApiKey -> "no TypeSafe API key: set " <> Text.unpack apiKeyEnv <> " or pass one to mkApiKey" + InvalidApiKey reason -> "invalid TypeSafe API key: " <> Text.unpack reason + InvalidBaseUrl url reason -> "invalid TypeSafe base URL " <> show url <> ": " <> Text.unpack reason + InvalidTimeout t -> "invalid timeout " <> show t <> ": it must be positive" + +-- | Client settings. Start from 'defaultClientConfig' or +-- 'clientConfigFromEnv' and override fields with record update syntax: +-- +-- @ +-- (defaultClientConfig key) {'configTimeout' = Just 30, 'configLogger' = 'stderrLogger'} +-- @ +data ClientConfig = ClientConfig + { configApiKey :: !ApiKey + -- ^ Sent as @Authorization: Bearer …@. + , configBaseUrl :: !Text + -- ^ The API root, 'defaultBaseUrl' by default. It may include a path + -- prefix, for example to go through an AI gateway. + , configDefaultModel :: !ModelName + -- ^ The model for calls that do not set one with 'withModel'. + , configRetryPolicy :: !RetryPolicy + -- ^ How failed attempts are retried. + , configTimeout :: !(Maybe NominalDiffTime) + -- ^ How long each attempt may take, in seconds. 'Nothing' waits forever. + , configHeaders :: !RequestHeaders + -- ^ Extra headers for every request. The 'protectedHeaders' cannot be + -- overridden. + , configLogger :: !(LogEvent -> IO ()) + -- ^ Called for every attempt, retry and result. Plug in your logging + -- library here; the default discards everything. Events never contain the + -- API key or request bodies. + } + +-- | The defaults: 'defaultBaseUrl', 'jevLatest', 'defaultRetryPolicy', a +-- 10 second timeout, no extra headers and no logging. +defaultClientConfig :: ApiKey -> ClientConfig +defaultClientConfig key = + ClientConfig + { configApiKey = key + , configBaseUrl = defaultBaseUrl + , configDefaultModel = jevLatest + , configRetryPolicy = defaultRetryPolicy + , configTimeout = Just 10 + , configHeaders = [] + , configLogger = \_ -> pure () + } + +-- | @TYPESAFE_API_KEY@: the API key. Required by 'clientConfigFromEnv'. +apiKeyEnv :: Text +apiKeyEnv = "TYPESAFE_API_KEY" + +-- | @TYPESAFE_BASE_URL@: overrides 'configBaseUrl'. +baseUrlEnv :: Text +baseUrlEnv = "TYPESAFE_BASE_URL" + +-- | @TYPESAFE_DEFAULT_MODEL@: overrides 'configDefaultModel'. +defaultModelEnv :: Text +defaultModelEnv = "TYPESAFE_DEFAULT_MODEL" + +-- | 'defaultClientConfig' with the API key, base URL and default model read +-- from 'apiKeyEnv', 'baseUrlEnv' and 'defaultModelEnv'. Blank variables count +-- as unset. These are the same variables the official Python and JavaScript +-- SDKs read. +clientConfigFromEnv :: IO (Either ConfigError ClientConfig) +clientConfigFromEnv = do + key <- env apiKeyEnv + baseUrl <- env baseUrlEnv + model <- env defaultModelEnv + pure $ do + apiKey <- maybe (Left MissingApiKey) mkApiKey key + let config = defaultClientConfig apiKey + pure + config + { configBaseUrl = fromMaybe (configBaseUrl config) baseUrl + , configDefaultModel = maybe (configDefaultModel config) ModelName model + } + where + env name = do + value <- lookupEnv (Text.unpack name) + pure $ case Text.strip . Text.pack <$> value of + Just v | not (Text.null v) -> Just v + _ -> Nothing + +------------------------------------------------------------------------------ +-- Clients + +-- | A configured connection to the TypeSafe API. +data Client = Client + { clientConfig_ :: !ClientConfig + , clientManager :: !Manager + , clientBaseRequest :: !HTTP.Request + } + +-- | The configuration a client was created with. +clientConfig :: Client -> ClientConfig +clientConfig = clientConfig_ + +-- | Create a client with its own TLS connection pool. Throws 'ConfigError' +-- if the configuration is invalid. +newClient :: ClientConfig -> IO Client +newClient config = do + manager <- newTlsManager + either throwIO pure (newClientWith manager config) + +-- | Create a client that shares an existing @http-client@ 'Manager', for +-- example with servant-client or your own HTTP code. The manager must +-- support TLS for @https@ URLs (see "Network.HTTP.Client.TLS"). +newClientWith :: Manager -> ClientConfig -> Either ConfigError Client +newClientWith manager config = do + case configTimeout config of + Just t | t <= 0 -> Left (InvalidTimeout t) + _ -> Right () + base <- parseBaseUrl (configBaseUrl config) + pure Client {clientConfig_ = config, clientManager = manager, clientBaseRequest = base} + +-- | 'newClient' with 'clientConfigFromEnv'. Throws 'ConfigError' if +-- @TYPESAFE_API_KEY@ is not set or a variable is invalid. +newClientFromEnv :: IO Client +newClientFromEnv = clientConfigFromEnv >>= either throwIO newClient + +parseBaseUrl :: Text -> Either ConfigError HTTP.Request +parseBaseUrl url = case HTTP.parseRequest (Text.unpack url) of + Left e -> Left (InvalidBaseUrl url (Text.pack (reason e))) + Right r + | not (BS.null (HTTP.queryString r)) || BS8.elem '#' (HTTP.path r) -> + Left (InvalidBaseUrl url "the base URL must not have a query string or fragment") + | otherwise -> Right r + where + reason e = case fromException e of + Just (InvalidUrlException _ why) -> why + _ -> displayException e + +------------------------------------------------------------------------------ +-- Sending + +-- | Send a call and return its result. Throws 'TypeSafeError' once retries +-- are exhausted. +send :: Client -> Call a -> IO a +send client call = sendEither client call >>= either throwIO pure + +-- | Send a call and return its result or the error, after any retries. +-- Exceptions that are not about the request, such as asynchronous +-- exceptions, propagate as usual. +sendEither :: Client -> Call a -> IO (Either TypeSafeError a) +sendEither client call = case renderCall defaults call of + Left err -> do + logEvent 0 (Failed err) + pure (Left err) + Right request -> do + start <- getMonotonicTime + attempt start (toHttpRequest client request) 1 + where + config = clientConfig_ client + defaults = CallDefaults (configDefaultModel config) (configHeaders config) + policy = fromMaybe (configRetryPolicy config) (callRetryPolicy call) + limit = maybe (configTimeout config) Just (callTimeout call) + endpoint = callEndpoint call + logEvent n stage = configLogger config (LogEvent endpoint n stage) + + attempt start request n = do + logEvent n Sending + began <- getMonotonicTime + outcome <- exchange request + finished <- getMonotonicTime + let latency = realToFrac (finished - began) + result <- case outcome of + Left err -> pure (Left err) + Right response -> do + logEvent n (Received (HTTP.responseStatus response) latency (requestIdOf response)) + pure (parseResponse call (fromHttpResponse response)) + case result of + Right a -> pure (Right a) + Left err + | n <= retryMaxRetries policy && isRetryable policy err -> do + now <- getCurrentTime + random <- randomRIO (0, 1) + let delay = retryDelay policy now random n err + elapsed <- subtract start <$> getMonotonicTime + if maybe False (\budget -> realToFrac elapsed + delay >= budget) (retryBudget policy) + then giveUp n err + else do + logEvent n (Retrying delay err) + threadDelay (microseconds delay) + attempt start request (n + 1) + | otherwise -> giveUp n err + + giveUp n err = do + logEvent n (Failed err) + pure (Left err) + + exchange request = do + let run = try (HTTP.httpLbs request (clientManager client)) + outcome <- case limit of + Nothing -> Just <$> run + Just t -> timeout (microseconds t) run + pure $ case outcome of + Nothing -> Left (ConnectionError (ConnectionTimedOut endpoint)) + Just (Left e) -> Left (classify e) + Just (Right response) -> Right response + + classify :: HttpException -> TypeSafeError + classify = \case + HttpExceptionRequest _ ResponseTimeout -> ConnectionError (ConnectionTimedOut endpoint) + HttpExceptionRequest _ ConnectionTimeout -> ConnectionError (ConnectionTimedOut endpoint) + HttpExceptionRequest r content -> + ConnectionError (ConnectionFailed endpoint (toException (HttpExceptionRequest (redact r) content))) + e -> ConnectionError (ConnectionFailed endpoint (toException e)) + + redact r = + r + { HTTP.requestHeaders = + [(name, if name == "Authorization" then "" else value) | (name, value) <- HTTP.requestHeaders r] + } + + requestIdOf response = RequestId . Text.decodeUtf8With Text.lenientDecode <$> lookup requestIdHeader (HTTP.responseHeaders response) + +toHttpRequest :: Client -> HttpRequest -> HTTP.Request +toHttpRequest client r = + base + { HTTP.method = httpRequestMethod r + , HTTP.path = basePath <> "/" <> BS.intercalate "/" (map (urlEncode False . Text.encodeUtf8) (httpRequestPath r)) + , HTTP.requestHeaders = + ("Authorization", "Bearer " <> key) + : ("User-Agent", userAgent) + : httpRequestHeaders r + , HTTP.requestBody = maybe mempty HTTP.RequestBodyLBS (httpRequestBody r) + , HTTP.responseTimeout = HTTP.responseTimeoutNone + } + where + base = clientBaseRequest client + basePath = BS8.dropWhileEnd (== '/') (HTTP.path base) + ApiKey key = configApiKey (clientConfig_ client) + +fromHttpResponse :: HTTP.Response LBS.ByteString -> HttpResponse +fromHttpResponse response = + HttpResponse (HTTP.responseStatus response) (HTTP.responseHeaders response) (HTTP.responseBody response) + +microseconds :: NominalDiffTime -> Int +microseconds t = max 1 (ceiling (t * 1000000)) + +-- | The @User-Agent@ sent with every request, such as +-- @typesafe-ai-haskell\/0.1.0.0 (ghc-9.12)@. +userAgent :: BS.ByteString +userAgent = + BS8.pack $ + "typesafe-ai-haskell/" + <> showVersion Paths.version + <> " (" + <> Info.compilerName + <> "-" + <> showVersion Info.compilerVersion + <> ")" + +------------------------------------------------------------------------------ +-- Logging + +-- | Something that happened while sending a call. +data LogEvent = LogEvent + { logEndpoint :: !Text + -- ^ The method and path, such as @POST \/v1\/systemone@. + , logAttempt :: !Int + -- ^ The attempt number, from 1; 0 for calls rejected before sending. + , logStage :: !LogStage + } + deriving stock (Show, Generic) + +-- | The stages of an attempt. +data LogStage + = -- | The request is about to be sent. + Sending + | -- | A response arrived: its status, how long it took, and its request id. + Received !Status !NominalDiffTime !(Maybe RequestId) + | -- | The attempt failed and will be retried after the delay. + Retrying !NominalDiffTime !TypeSafeError + | -- | The call failed for good. + Failed !TypeSafeError + deriving stock (Show, Generic) + +-- | A one-line description of an event. +renderLogEvent :: LogEvent -> Text +renderLogEvent (LogEvent endpoint n stage) = + "[typesafe] " <> endpoint <> " (attempt " <> tshow n <> "): " <> case stage of + Sending -> "sending" + Received status latency rid -> + "HTTP " + <> tshow (statusCode status) + <> " in " + <> seconds latency + <> maybe "" (\(RequestId r) -> " [" <> r <> "]") rid + Retrying delay err -> "retrying in " <> seconds delay <> " after: " <> renderTypeSafeError err + Failed err -> "failed: " <> renderTypeSafeError err + + where + seconds t = Text.pack (showFFloat (Just 3) (realToFrac t :: Double) "s") + +-- | A logger that prints every event to standard error, for debugging. +stderrLogger :: LogEvent -> IO () +stderrLogger = Text.hPutStrLn stderr . renderLogEvent + +tshow :: (Show a) => a -> Text +tshow = Text.pack . show diff --git a/typesafe-ai/src/TypeSafe/Tutorial.hs b/typesafe-ai/src/TypeSafe/Tutorial.hs new file mode 100644 index 0000000..7b04e7a --- /dev/null +++ b/typesafe-ai/src/TypeSafe/Tutorial.hs @@ -0,0 +1,385 @@ +{-# OPTIONS_GHC -Wno-unused-imports #-} + +-- | +-- Module : TypeSafe.Tutorial +-- Description : A guided tour of the TypeSafe SDK +-- Copyright : (c) 2026 byteally +-- License : BSD-3-Clause +-- +-- This module contains no code; it is a tutorial. The examples assume +-- +-- @ +-- {-# LANGUAGE DeriveAnyClass, DeriveGeneric, DerivingStrategies, LambdaCase, OverloadedStrings #-} +-- +-- import Data.Aeson ((.=)) +-- import Data.Text (Text) +-- import GHC.Generics (Generic) +-- import TypeSafe +-- @ +-- +-- Complete, runnable programs are in the @examples@ directory of the +-- repository. +module TypeSafe.Tutorial + ( -- * 1. What TypeSafe does + -- $what + + -- * 2. A client + -- $client + + -- * 3. The first question + -- $first + + -- * 4. Choosing a question type + -- $types + + -- * 5. Options and levels are types + -- $options + + -- * 6. Many questions, one request + -- $many + + -- * 7. Structured state + -- $state + + -- * 8. Acting on confidence + -- $confidence + + -- * 9. Combining scores in code + -- $composite + + -- * 10. When a question depends on an answer + -- $dependent + + -- * 11. Errors and retries + -- $errors + + -- * 12. Models + -- $models + + -- * 13. Testing code that uses the SDK + -- $testing + + -- * 14. When the API grows + -- $evolution + ) where + +import TypeSafe + +-- $what +-- +-- TypeSafe's System One models make fast, structured judgments. You send a +-- /state/ (the content to judge: text, a record, a conversation) and a set of +-- named /questions/. Each question comes back as a typed answer, never as +-- prose, so the calling code stays in control: +-- +-- * a 'noul' asks /is this true?/ and returns a 'Probability'; +-- * a 'choice' asks /which of these options?/ and returns one of the options +-- you offered, with a probability for each and a 'Confidence'; +-- * a 'score' asks /which level of this rubric?/ and returns an expected +-- level, a probability for each level and a 'Confidence'. +-- +-- Ask for judgments a knowledgeable person makes in a second, and compose the +-- answers in Haskell. See . + +-- $client +-- +-- Create an API key in the TypeSafe console and export it: +-- +-- > export TYPESAFE_API_KEY=... +-- +-- Then create one 'Client' for the whole program. It is thread-safe and keeps +-- a pool of connections, so share it rather than creating one per call. +-- +-- @ +-- client <- 'newClientFromEnv' +-- @ +-- +-- 'newClientFromEnv' also reads @TYPESAFE_BASE_URL@ and +-- @TYPESAFE_DEFAULT_MODEL@. To configure the client in code instead: +-- +-- @ +-- key <- either throwIO pure ('mkApiKey' keyFromVault) +-- client <- +-- 'newClient' +-- ('defaultClientConfig' key) +-- { 'configTimeout' = Just 5 +-- , 'configRetryPolicy' = 'defaultRetryPolicy' {'retryMaxRetries' = 4} +-- , 'configLogger' = 'stderrLogger' +-- } +-- @ +-- +-- If your application already has an @http-client@ 'Manager' (for example +-- one shared with servant-client), pass it to 'newClientWith'. + +-- $first +-- +-- A call is a value describing a request. 'send' runs it: +-- +-- @ +-- result <- +-- 'send' client $ +-- 'systemOne' \"Help! My payouts have been failing for 3 days.\" $ +-- 'ask' \"is_urgent\" ('noul' \"Does this convey urgency?\") +-- +-- print ('noulProbability' ('evaluationAnswers' result)) -- 0.95 +-- print ('evaluationModel' result) -- \"jev-1.13.0\" +-- print ('usageInputTokens' ('evaluationUsage' result)) -- 296 +-- @ +-- +-- The id passed to 'ask' (@\"is_urgent\"@) only matches the answer to its +-- question. It is not shown to the model, so put the whole question in the +-- instructions. + +-- $types +-- +-- Pick the type whose answer your code can act on directly +-- (): +-- +-- * __Noul__ for a clean yes\/no condition, where the probability itself is +-- useful: \"Does the customer request a refund?\". 'noulWith' also says +-- what a yes and a no mean. +-- +-- * __Choice__ for one of a known set of unordered options: routing to a +-- department, classifying a document. Add an @other@ option when the list +-- might not cover every input. +-- +-- * __Score__ for a position on a spectrum that you can describe level by +-- level: severity, frustration, skill. +-- +-- A Noul of 0.5 means the model is unsure, not that something is \"half +-- true\". To measure how much, use a Score. + +-- $options +-- +-- Choice options and Score levels are ordinary Haskell types. Derive the +-- classes for an enumeration: +-- +-- @ +-- data Department = Billing | Technical | Sales +-- deriving stock (Show, Eq, Generic) +-- deriving anyclass ('ChoiceOption') +-- +-- data Frustration = Calm | Frustrated | VeryAngry +-- deriving stock (Show, Eq, Generic) +-- deriving anyclass ('ScoreLevel') +-- @ +-- +-- The answer to @'choice' \"Which team should handle this?\"@ is then a +-- @'Choice' Department@, and 'choiceSelected' can only be one of the three +-- constructors: an option the model was not offered is reported as an error +-- ('UnknownOption'), never passed to your code. +-- +-- Constructors are sent in snake case (@billing@) for options and as words +-- (@very angry@) for levels. Descriptions make the model far more accurate, +-- so write them for anything that is not obvious from the name: +-- +-- @ +-- instance 'ChoiceOption' Department where +-- 'optionDescription' = Just . \\case +-- Billing -> \"Payments, invoicing, refunds\" +-- Technical -> \"Bugs, outages, integrations\" +-- Sales -> \"Pricing, upgrades, new accounts\" +-- +-- instance 'ScoreLevel' Frustration where +-- 'levelDescription' = \\case +-- Calm -> \"Calm, just stating facts\" +-- Frustrated -> \"Frustrated but civil\" +-- VeryAngry -> \"Very angry, strong language\" +-- @ +-- +-- When the options are only known at run time, such as a catalogue from a +-- database, use 'choiceBy' and 'scoreBy', or 'scoreRubric' for a rubric of +-- plain descriptions: +-- +-- @ +-- skill :: NonEmpty Skill -> 'Question' ('Choice' Skill) +-- skill = 'choiceBy' skillName (Just . 'contentText' . skillSummary) \"Which skill fits the request?\" +-- @ + +-- $many +-- +-- Every question in a request sees the same state and is evaluated in +-- parallel, so extra questions barely change latency and cost only their own +-- tokens. Ask everything you might need in one request +-- () and let the code ignore what +-- it does not use. +-- +-- 'Questions' is an 'Applicative'. Describe the record you want and the +-- questions that fill it: +-- +-- @ +-- data Triage = Triage +-- { department :: 'Choice' Department +-- , urgent :: 'Noul' +-- , frustration :: 'Score' Frustration +-- } +-- +-- triage :: 'Questions' Triage +-- triage = +-- Triage +-- \<$\> 'ask' \"department\" ('choice' \"Which team should handle this?\") +-- \<*\> 'ask' \"is_urgent\" ('noul' \"Does this convey urgency?\") +-- \<*\> 'ask' \"frustration\" ('score' \"How frustrated is the customer?\") +-- +-- result <- 'send' client ('systemOne' ticketText triage) +-- @ +-- +-- Questions generated from data are one 'traverse' away. This scores every +-- passage of a search result in a single request: +-- +-- @ +-- relevance :: Text -> [Text] -> 'Questions' [(Text, 'Noul')] +-- relevance query passages = +-- for (zip [0 :: Int ..] passages) $ \\(i, passage) -> +-- (,) passage +-- \<$\> 'ask' +-- ('QuestionId' (\"passage_\" <> Text.pack (show i))) +-- ('noul' ('contentObject' [\"query\" .= query, \"passage\" .= passage, \"question\" .= (\"Does \`passage\` answer \`query\`?\" :: Text)])) +-- @ +-- +-- Ids must be distinct within a request; a clash is reported as +-- 'DuplicateQuestionId' before anything is sent. + +-- $state +-- +-- The state can be a string or structured JSON. Structure helps: questions +-- can point at a field by its path, in backticks +-- (). +-- +-- @ +-- state :: 'Content' +-- state = +-- 'contentObject' +-- [ \"ticket\" .= ticket -- any ToJSON value +-- , \"refund_policy\" .= policyText +-- ] +-- +-- refundRequested :: 'Question' 'Noul' +-- refundRequested = 'noul' \"Does \`ticket.messages[0].text\` request a refund?\" +-- @ +-- +-- Instructions and descriptions accept structure too, which keeps long +-- context out of the question sentence +-- (). + +-- $confidence +-- +-- Choice and Score answers carry a 'Confidence' besides their probabilities. +-- The answer says /what/; the confidence says /whether to act on it/ +-- (): +-- +-- @ +-- route :: 'Choice' Department -> Action +-- route answer +-- | 'confidence' answer >= 0.8 = Assign ('choiceSelected' answer) +-- | otherwise = SendToHuman ('rankedChoices' answer) +-- @ +-- +-- Tune thresholds on your own data, and pin the model version you tuned +-- them against (see "12. Models"). + +-- $composite +-- +-- Split a complex judgment into atomic scores and combine them with weights +-- that live in code (). +-- 'normalizedScore' puts rubrics of any length on a 0–1 scale: +-- +-- @ +-- priority :: 'Questions' Double +-- priority = +-- (\\sev fru inf -> 0.5 * 'normalizedScore' sev + 0.3 * 'normalizedScore' fru + 0.2 * 'normalizedScore' inf) +-- \<$\> 'ask' \"severity\" ('score' \@Severity \"How severe is the bug?\") +-- \<*\> 'ask' \"frustration\" ('score' \@Frustration \"How frustrated is the customer?\") +-- \<*\> 'ask' \"info\" ('score' \@Detail \"How much does the report give an engineer to work with?\") +-- @ +-- +-- When priorities change, change the weights, not the prompts. + +-- $dependent +-- +-- Questions in a request are independent: one answer is not context for +-- another. That is why 'Questions' is an 'Applicative' and not a 'Monad'; +-- the types cannot express a question that depends on an answer of the same +-- request. +-- +-- When the next question really depends on an answer, because you need it +-- to fetch more data or to decide which options to offer, make a second +-- request: +-- +-- @ +-- category <- 'evaluationAnswers' \<$\> 'send' client ('systemOne' doc ('ask' \"category\" ('choice' \"Which category?\"))) +-- let subcategories = subcategoriesOf ('choiceSelected' category) +-- detail <- 'send' client ('systemOne' doc ('ask' \"sub\" ('choiceBy' name (const Nothing) \"Which subcategory?\" subcategories))) +-- @ +-- +-- If the second request's questions could have been asked against the +-- original state, ask them in the first request instead. + +-- $errors +-- +-- 'send' throws a 'TypeSafeError'; 'sendEither' returns it. The constructors +-- separate what callers usually handle differently: +-- +-- @ +-- 'sendEither' client call >>= \\case +-- Right result -> use result +-- Left ('InvalidRequest' problem) -> bug problem -- nothing was sent +-- Left ('ServiceError' e) -> case 'apiErrorKind' e of +-- 'Unauthorized' -> checkTheKey +-- 'RateLimited' -> backOff -- already retried +-- _ -> report ('apiErrorMessage' e) ('apiErrorRequestId' e) +-- Left ('ConnectionError' _) -> networkTrouble +-- Left ('ResponseError' e) -> report ('responseErrorProblem' e) ('responseErrorRequestId' e) +-- @ +-- +-- Rate limiting (429), overload (529), other 5xx statuses, timeouts and +-- connection failures are retried with exponential backoff before an error +-- is reported, honouring the server's @Retry-After@. Adjust the policy per +-- client ('configRetryPolicy') or per call ('withRetryPolicy'); see +-- "TypeSafe.Retry". +-- +-- Include 'apiErrorRequestId' when you contact TypeSafe support. + +-- $models +-- +-- Calls use 'jevLatest' unless the client or the call says otherwise. An +-- alias moves when a new model ships, so if you have tuned thresholds, pin a +-- version: +-- +-- @ +-- 'send' client ('withModel' \"jev-1.13.0\" ('systemOne' state triage)) +-- @ +-- +-- 'evaluationModel' always reports the versioned model that answered. +-- 'listModels' returns the names available to your account. + +-- $testing +-- +-- Calls are values, so the code that builds them can be tested without a +-- network. 'renderCall' shows exactly what would be sent, and +-- 'parseResponse' decodes a recorded response: +-- +-- @ +-- let call = 'systemOne' ticket triage +-- 'renderCall' ('CallDefaults' 'jevLatest' []) call -- the HTTP request +-- 'parseResponse' call ('HttpResponse' status200 [] recordedBody) +-- @ +-- +-- For higher-level tests, abstract over sending in your own code, for +-- example with a record of functions or an effect, and interpret calls with +-- 'parseResponse' over canned responses. + +-- $evolution +-- +-- The SDK keeps working as the API gains features: +-- +-- * unknown fields in responses are ignored; +-- * answers of an unknown type are kept (see 'TypeSafe.Wire.AnswerOther' and +-- 'evaluationResponse'); +-- * 'withExtraBody' sends request fields the SDK does not know yet; +-- * 'otherQuestion' sends a new question type and decodes its answer with +-- your own 'Data.Aeson.FromJSON' instance. +-- +-- Prefer upgrading the SDK once it supports the feature properly. +-- 'apiSpecVersion' is the version of the API specification the installed +-- SDK was checked against. diff --git a/typesafe-ai/test/Main.hs b/typesafe-ai/test/Main.hs new file mode 100644 index 0000000..c8ac5f7 --- /dev/null +++ b/typesafe-ai/test/Main.hs @@ -0,0 +1,313 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Tests the http-client transport against a local mock of the API. +-- +-- Set @TYPESAFE_LIVE_TESTS=1@ and @TYPESAFE_API_KEY@ to also run a few +-- requests against the real API. +module Main (main) where + +import Control.Concurrent (threadDelay) +import Control.Exception (SomeException, evaluate, try) +import Control.Monad (unless) +import qualified Data.Aeson as Aeson +import qualified Data.ByteString.Lazy as LBS +import Data.IORef +import Data.List (isInfixOf) +import Data.Maybe (isJust) +import qualified Data.Text as Text +import Data.Time.Calendar (fromGregorian) +import Network.HTTP.Client (defaultManagerSettings, newManager) +import Network.HTTP.Types +import qualified Network.Wai as Wai +import Network.Wai.Handler.Warp (testWithApplication) +import System.Environment (lookupEnv, setEnv, unsetEnv) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) +import TypeSafe + +-- | A request as the mock server saw it. +data Seen = Seen + { seenMethod :: Method + , seenPath :: [Text.Text] + , seenHeaders :: RequestHeaders + , seenBody :: LBS.ByteString + } + +-- | Run a mock API that answers requests with the given responses in order, +-- repeating the last one. +withMockApi :: [IO Wai.Response] -> (Int -> IORef [Seen] -> IO a) -> IO a +withMockApi responses action = do + seen <- newIORef [] + script <- newIORef responses + let app request respond = do + body <- Wai.strictRequestBody request + modifyIORef' seen (<> [Seen (Wai.requestMethod request) (Wai.pathInfo request) (Wai.requestHeaders request) body]) + next <- atomicModifyIORef' script $ \pending -> case pending of + [r] -> ([r], r) + r : rs -> (rs, r) + [] -> ([], pure (Wai.responseLBS status500 [] "no scripted response")) + next >>= respond + testWithApplication (pure app) (\port -> action port seen) + +json :: Status -> ResponseHeaders -> LBS.ByteString -> IO Wai.Response +json status headers body = pure (Wai.responseLBS status (("Content-Type", "application/json") : headers) body) + +okNoul :: IO Wai.Response +okNoul = + json + status200 + [("x-typesafe-request-id", "req_mock")] + "{\"model\":\"jev-1.13.0\",\"answers\":{\"billing\":{\"type\":\"noul\",\"noul\":0.98}},\"usage\":{\"input_tokens\":120,\"output_tokens\":12}}" + +billing :: Call (Evaluation Noul) +billing = systemOne "I was charged twice." (ask "billing" (noul "Is this about billing?")) + +testKey :: ApiKey +testKey = either (error . show) id (mkApiKey "ts_test_secret_value") + +-- | A client for the mock API, with fast retries, recording log events. +mockClient :: Int -> (ClientConfig -> ClientConfig) -> IO (Client, IORef [LogEvent]) +mockClient port adjust = do + events <- newIORef [] + manager <- newManager defaultManagerSettings + let config = + adjust + (defaultClientConfig testKey) + { configBaseUrl = "http://127.0.0.1:" <> Text.pack (show port) + , configRetryPolicy = + defaultRetryPolicy {retryInitialBackoff = 0.01, retryMaxBackoff = 0.02} + , configLogger = \e -> modifyIORef' events (<> [e]) + } + client <- either (fail . show) pure (newClientWith manager config) + pure (client, events) + +attempts :: IORef [Seen] -> IO Int +attempts seen = length <$> readIORef seen + +main :: IO () +main = do + live <- liveTests + defaultMain (testGroup "typesafe-ai" (transportTests : configTests : live)) + +transportTests :: TestTree +transportTests = + testGroup + "http-client transport" + [ testCase "sends a typed call and decodes the answer" $ + withMockApi [okNoul] $ \port seen -> do + (client, _) <- mockClient port id + result <- send client billing + evaluationAnswers result @?= Noul 0.98 + evaluationRequestId result @?= Just "req_mock" + [request] <- readIORef seen + seenMethod request @?= "POST" + seenPath request @?= ["v1", "systemone"] + Aeson.decode (seenBody request) + @?= Just + ( Aeson.object + [ "state" Aeson..= ("I was charged twice." :: Text.Text) + , "model" Aeson..= ("jev-latest" :: Text.Text) + , "questions" Aeson..= Aeson.object ["billing" Aeson..= Aeson.object ["type" Aeson..= ("noul" :: Text.Text), "instructions" Aeson..= ("Is this about billing?" :: Text.Text)]] + ] + ) + , testCase "authenticates, identifies itself and negotiates JSON" $ + withMockApi [okNoul] $ \port seen -> do + (client, _) <- mockClient port id + _ <- send client billing + [request] <- readIORef seen + let header name = lookup name (seenHeaders request) + header "Authorization" @?= Just "Bearer ts_test_secret_value" + header "Content-Type" @?= Just "application/json" + header "Accept" @?= Just "application/json" + assertBool "user agent" (maybe False ("typesafe-ai-haskell/" `LBS.isPrefixOf`) (LBS.fromStrict <$> header "User-Agent")) + , testCase "extra headers cannot replace the protected ones" $ + withMockApi [okNoul] $ \port seen -> do + (client, _) <- mockClient port (\c -> c {configHeaders = [("X-Team", "search"), ("Authorization", "Bearer other")]}) + _ <- send client (withHeaders [("User-Agent", "spoof"), ("X-Call", "1")] billing) + [request] <- readIORef seen + let values name = [v | (n, v) <- seenHeaders request, n == name] + values "Authorization" @?= ["Bearer ts_test_secret_value"] + values "User-Agent" @?= [userAgent] + values "X-Team" @?= ["search"] + values "X-Call" @?= ["1"] + , testCase "a base URL with a path prefix is kept" $ + withMockApi [okNoul] $ \port seen -> do + (client, _) <- mockClient port (\c -> c {configBaseUrl = configBaseUrl c <> "/gateway/typesafe/"}) + _ <- send client billing + map seenPath <$> readIORef seen >>= (@?= [["gateway", "typesafe", "v1", "systemone"]]) + , testCase "lists models" $ + withMockApi [json status200 [] "{\"models\":[{\"name\":\"jev-latest\",\"description\":\"General-purpose system one model.\",\"release_date\":\"2026-09-15\"}]}"] $ + \port seen -> do + (client, _) <- mockClient port id + models <- send client listModels + map modelMetadataName models @?= ["jev-latest"] + map modelMetadataReleaseDay models @?= [Just (fromGregorian 2026 9 15)] + [request] <- readIORef seen + (seenMethod request, seenBody request) @?= ("GET", "") + , testCase "retries a rate limit, honouring retry-after-ms" $ + withMockApi [json status429 [("retry-after-ms", "30")] "{}", okNoul] $ \port seen -> do + (client, events) <- mockClient port id + result <- sendEither client billing + fmap evaluationAnswers result `rightIs` Noul 0.98 + attempts seen >>= (@?= 2) + delays <- mapRetries <$> readIORef events + delays @?= [0.03] + , testCase "retries an overloaded API until the retries run out" $ + withMockApi [json (mkStatus 529 "Overloaded") [] "{\"detail\":{\"message\":\"busy\"}}"] $ \port seen -> do + (client, events) <- mockClient port id + result <- sendEither client billing + case result of + Left (ServiceError e) -> (apiErrorKind e, apiErrorMessage e) @?= (Overloaded, Just "busy") + other -> assertFailure (show (fmap evaluationAnswers other)) + attempts seen >>= (@?= 3) + stages <- map logStage <$> readIORef events + length [() | Retrying _ _ <- stages] @?= 2 + length [() | Failed _ <- stages] @?= 1 + , testCase "does not retry a validation error" $ + withMockApi [json status422 [] "{\"detail\":[{\"loc\":[\"body\",\"state\"],\"msg\":\"Field required\",\"type\":\"missing\"}]}"] $ + \port seen -> do + (client, _) <- mockClient port id + result <- sendEither client billing + case result of + Left (ServiceError e) -> apiErrorKind e @?= UnprocessableEntity + other -> assertFailure (show (fmap evaluationAnswers other)) + attempts seen >>= (@?= 1) + , testCase "a per-call retry policy wins" $ + withMockApi [json status503 [] ""] $ \port seen -> do + (client, _) <- mockClient port id + _ <- sendEither client (withRetryPolicy noRetries billing) + attempts seen >>= (@?= 1) + , testCase "stops when the retry budget would be exceeded" $ + withMockApi [json status503 [] ""] $ \port seen -> do + (client, _) <- + mockClient port $ \c -> + c {configRetryPolicy = (configRetryPolicy c) {retryInitialBackoff = 1, retryMaxBackoff = 1, retryBudget = Just 0.5}} + _ <- sendEither client billing + attempts seen >>= (@?= 1) + , testCase "times out a slow attempt" $ + withMockApi [threadDelay 2000000 >> okNoul] $ \port _ -> do + (client, _) <- mockClient port (\c -> c {configRetryPolicy = noRetries}) + result <- sendEither client (withTimeout 0.2 billing) + case result of + Left (ConnectionError (ConnectionTimedOut endpoint)) -> endpoint @?= "POST /v1/systemone" + other -> assertFailure (show (fmap evaluationAnswers other)) + , testCase "reports a refused connection without leaking the key" $ do + port <- withMockApi [okNoul] (\port _ -> pure port) -- the port is closed afterwards + (client, events) <- mockClient port id + result <- sendEither client billing + case result of + Left err@(ConnectionError (ConnectionFailed _ _)) -> do + let shown = show err <> Text.unpack (renderTypeSafeError err) + assertBool "the key must not appear in the error" (not ("ts_test_secret_value" `isInfixOf` shown)) + other -> assertFailure (show (fmap evaluationAnswers other)) + stages <- map logStage <$> readIORef events + length [() | Sending <- stages] @?= 3 + , testCase "rejects invalid questions without sending anything" $ + withMockApi [okNoul] $ \port seen -> do + (client, _) <- mockClient port id + result <- sendEither client (systemOne "state" (pure ())) + case result of + Left (InvalidRequest NoQuestions) -> pure () + other -> assertFailure (show (fmap evaluationAnswers other)) + attempts seen >>= (@?= 0) + , testCase "send throws what sendEither returns" $ + withMockApi [json status401 [] "{\"detail\":{\"error_type\":\"authentication_error\",\"message\":\"Cannot authenticate\"}}"] $ + \port _ -> do + (client, _) <- mockClient port id + thrown <- try (send client billing >>= evaluate) + case thrown of + Left (ServiceError e) -> apiErrorKind e @?= Unauthorized + Left other -> assertFailure (show other) + Right _ -> assertFailure "expected an exception" + ] + where + mapRetries events = [delay | LogEvent _ _ (Retrying delay _) <- events] + rightIs result expected = case result of + Right a -> a @?= expected + Left e -> assertFailure (show e) + +configTests :: TestTree +configTests = + testGroup + "configuration" + [ testCase "API keys are trimmed and validated" $ do + fmap show (mkApiKey " ts_abc\n") @?= Right "" + mkApiKey "" `isLeftWith` "empty" + mkApiKey "ts abc" `isLeftWith` "whitespace" + mkApiKey "ts_\233" `isLeftWith` "non-ASCII" + , -- The environment is global to the process and tasty runs tests in + -- parallel, so every scenario that changes it lives in this one test. + testCase "configuration comes from the environment" $ do + withEnv [("TYPESAFE_API_KEY", Just " ts_env \n"), ("TYPESAFE_BASE_URL", Just "https://gateway.example/typesafe"), ("TYPESAFE_DEFAULT_MODEL", Just "jev-1.13.0")] $ do + config <- clientConfigFromEnv >>= either (fail . show) pure + configBaseUrl config @?= "https://gateway.example/typesafe" + configDefaultModel config @?= "jev-1.13.0" + withEnv [("TYPESAFE_API_KEY", Just "ts_env"), ("TYPESAFE_BASE_URL", Just " "), ("TYPESAFE_DEFAULT_MODEL", Nothing)] $ do + config <- clientConfigFromEnv >>= either (fail . show) pure + configBaseUrl config @?= defaultBaseUrl + configDefaultModel config @?= jevLatest + withEnv [("TYPESAFE_API_KEY", Nothing)] $ + fmap (either Just (const Nothing)) clientConfigFromEnv >>= (@?= Just MissingApiKey) + withEnv [("TYPESAFE_API_KEY", Just " ")] $ + fmap (either Just (const Nothing)) clientConfigFromEnv >>= (@?= Just MissingApiKey) + , testCase "invalid base URLs and timeouts are rejected" $ do + manager <- newManager defaultManagerSettings + let rejected config = either Just (const Nothing) (newClientWith manager config) + fmap isInvalidUrl (rejected (defaultClientConfig testKey) {configBaseUrl = "not a url"}) @?= Just True + fmap isInvalidUrl (rejected (defaultClientConfig testKey) {configBaseUrl = "https://api.typesafe.ai?x=1"}) @?= Just True + rejected (defaultClientConfig testKey) {configTimeout = Just 0} @?= Just (InvalidTimeout 0) + , testCase "newClient throws a ConfigError" $ do + thrown <- try (newClient (defaultClientConfig testKey) {configBaseUrl = "ftp:/nope"}) + case thrown of + Left (InvalidBaseUrl url _) -> url @?= "ftp:/nope" + Left other -> assertFailure (show other) + Right _ -> assertFailure "expected an exception" + ] + where + isInvalidUrl (InvalidBaseUrl _ _) = True + isInvalidUrl _ = False + isLeftWith result fragment = case result of + Left (InvalidApiKey reason) -> assertBool (Text.unpack reason) (fragment `Text.isInfixOf` reason) + Left other -> assertFailure (show other) + Right _ -> assertFailure "expected the key to be rejected" + +withEnv :: [(String, Maybe String)] -> IO a -> IO a +withEnv vars action = do + saved <- traverse (\(k, _) -> (,) k <$> lookupEnv k) vars + mapM_ set vars + result <- try action + mapM_ set saved + either (\e -> fail (show (e :: SomeException))) pure result + where + set (k, v) = maybe (unsetEnv k) (setEnv k) v + +-- | Requests against the real API, when enabled. The configuration is read +-- before any test runs, because other tests change the environment. +liveTests :: IO [TestTree] +liveTests = do + enabled <- lookupEnv "TYPESAFE_LIVE_TESTS" + configured <- clientConfigFromEnv + pure $ case configured of + Right config + | enabled == Just "1" -> + [ testGroup + "live API" + [ testCase "lists models" $ do + client <- newClient config + models <- send client listModels + assertBool "at least one model" (not (null models)) + , testCase "answers a typed question" $ do + client <- newClient config + result <- send client billing + let p = noulProbability (evaluationAnswers result) + assertBool "a probability" (p >= 0 && p <= 1) + assertBool "a request id" (isJust (evaluationRequestId result)) + , testCase "rejects a bad key" $ do + client <- newClient config {configApiKey = testKey, configRetryPolicy = noRetries} + result <- sendEither client listModels + case result of + Left (ServiceError e) -> unless (apiErrorKind e `elem` [Unauthorized, PermissionDenied]) (assertFailure (show e)) + other -> assertFailure (show other) + ] + ] + _ -> [] diff --git a/typesafe-ai/typesafe-ai.cabal b/typesafe-ai/typesafe-ai.cabal new file mode 100644 index 0000000..4f63bde --- /dev/null +++ b/typesafe-ai/typesafe-ai.cabal @@ -0,0 +1,100 @@ +cabal-version: 3.0 +name: typesafe-ai +version: 0.1.0.0 +synopsis: Client for the TypeSafe AI System One API +description: + A client for TypeSafe's System One API (): send + text or JSON state with typed Noul (yes/no), Choice and Score questions, and + get back answers that decode to your own Haskell types. + . + Built on @http-client@ with TLS, connection reuse, per-attempt timeouts and + retries with exponential backoff that honour @Retry-After@. + . + The types, JSON codecs and calls are in @typesafe-ai-core@, which has no + HTTP dependency, so they can also be used with servant or any other HTTP + stack. + . + Start with "TypeSafe" and "TypeSafe.Tutorial". + . + This is a community SDK, not affiliated with or endorsed by TypeSafe AI. + +homepage: https://github.com/byteally/typesafe-sdk +bug-reports: https://github.com/byteally/typesafe-sdk/issues +license: BSD-3-Clause +license-file: LICENSE +author: Magesh B +maintainer: magesh85@gmail.com +copyright: 2026 byteally +category: AI, Web, API +build-type: Simple +tested-with: + GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.2 || ==9.14.1 + +extra-doc-files: + CHANGELOG.md + README.md + +source-repository head + type: git + location: https://github.com/byteally/typesafe-sdk.git + subdir: typesafe-ai + +common warnings + ghc-options: + -Wall -Wcompat -Widentities -Wincomplete-record-updates + -Wincomplete-uni-patterns -Wmissing-deriving-strategies + -Wpartial-fields -Wredundant-constraints -Wunused-packages + +library + import: warnings + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: + TypeSafe + TypeSafe.Client + TypeSafe.Tutorial + + other-modules: Paths_typesafe_ai + autogen-modules: Paths_typesafe_ai + + -- Depending on typesafe-ai alone gives access to the whole API. + reexported-modules: + , TypeSafe.Call + , TypeSafe.Content + , TypeSafe.Core + , TypeSafe.Error + , TypeSafe.Question + , TypeSafe.Retry + , TypeSafe.Wire + + build-depends: + , base >=4.18 && <4.23 + , bytestring >=0.11.3 && <0.13 + , http-client >=0.7.13 && <0.8 + , http-client-tls >=0.3.6.2 && <0.5 + , http-types >=0.12.3 && <0.13 + , random >=1.2 && <1.4 + , text >=2.0 && <2.2 + , time >=1.12 && <1.17 + , typesafe-ai-core >=0.1.0.0 && <0.1.1 + +test-suite spec + import: warnings + type: exitcode-stdio-1.0 + hs-source-dirs: test + default-language: Haskell2010 + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + , aeson + , base + , bytestring + , http-client + , http-types + , tasty >=1.4 && <1.6 + , tasty-hunit >=0.10 && <0.11 + , text + , time + , typesafe-ai + , wai >=3.2 && <3.3 + , warp >=3.3 && <3.5