diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/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/src/TypeSafe.hs b/src/TypeSafe.hs new file mode 100644 --- /dev/null +++ b/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/src/TypeSafe/Client.hs b/src/TypeSafe/Client.hs new file mode 100644 --- /dev/null +++ b/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/src/TypeSafe/Tutorial.hs b/src/TypeSafe/Tutorial.hs new file mode 100644 --- /dev/null +++ b/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/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/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.cabal b/typesafe-ai.cabal new file mode 100644 --- /dev/null +++ b/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