diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,84 @@ ## [Unreleased] +## [baikai 0.2.0.0] - 2026-06-21 + +### Added + +- `Usage`, `Cost`, and `CostBreakdown` now have `Semigroup`/`Monoid` + instances that add field-by-field, plus `sumUsage :: Foldable f => f + Usage -> Usage`, so callers can total per-call usage and cost. + `reasoningTokens` combines as presence-wins (`Nothing` only when both + operands are `Nothing`). +- A categorised error model: `BaikaiError` is now a record carrying an + `ErrorCategory` (`AuthError`, `RateLimited`, `ContextOverflow`, + `InvalidRequest`, `TransientError`, `DecodeFailure`, `ProcessFailure`, + `ProviderUnavailable`, `OtherError`), an optional HTTP `httpStatus`, a + `retryAfterSeconds` hint, and a subprocess `exitCode`. New smart + constructors (`providerError`, `invalidRequest`, `decodeError`, + `processError`, `rateLimited`, `authError`, `providerUnavailable`), + the `isRetryable` predicate, and the pure `classifyHttpStatus` / + `classifyHttpStatusWithBody` helpers let callers implement retry + policy without parsing error text. `ErrorCategory` and `BaikaiError` + serialize to JSON. +- `Response` and the streaming `EventError`'s `TerminalPayload` now + carry `errorInfo :: Maybe BaikaiError`, so a failed `completeRequest` + (or a drained stream) exposes the structured category/retry hint + in-band. `Baikai.Stream.Event` gains `doneTerminal` / `errorTerminal` + constructors. + +### Changed + +- **Breaking:** `BaikaiError`'s four flat constructors + (`ProviderError`, `RequestInvalid`, `DecodeError`, `ProcessError`) + were replaced by the record above. Migrate by lowercasing to the + smart constructors — `ProviderError "x"` becomes `providerError "x"`, + `ProcessError n "x"` becomes `processError n "x"`, etc. +- **Breaking:** `Baikai.Stream.Event.TerminalPayload` and + `Baikai.Response.Response` gained an `errorInfo` field; build + `TerminalPayload` via `doneTerminal` / `errorTerminal`. + +### Fixed + +- Restored JSON decoding for `BaikaiError` values with omitted optional + metadata fields. + +## [baikai-claude 0.2.0.0] - 2026-06-21 + +### Added + +- The Anthropic API and `claude -p` CLI providers now classify failures + into the typed `BaikaiError` categories: HTTP errors (via the caught + `servant-client` `ClientError`) map status/`Retry-After`/body onto + `AuthError` / `RateLimited` / `ContextOverflow` / `InvalidRequest` / + `TransientError`, and mid-stream Anthropic `error` events are + classified by their error type. The result is surfaced on + `Response.errorInfo`. + +## [baikai-openai 0.2.0.0] - 2026-06-21 + +### Added + +- The OpenAI/OpenAI-compatible API and `codex exec` CLI providers now + classify failures into the typed `BaikaiError` categories the same way + as `baikai-claude` (HTTP `ClientError` for status-based errors, + streamed error text for mid-stream errors), surfaced on + `Response.errorInfo`. + +## [baikai-trace-otel 0.2.0.0] - 2026-06-21 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with + the `baikai 0.2.0.0` breaking API release. + +## [baikai-effectful 0.2.0.0] - 2026-06-21 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.2.0` for compatibility with + the `baikai 0.2.0.0` breaking API release. + ## [baikai 0.1.1.0] - 2026-06-12 ### Added diff --git a/baikai.cabal b/baikai.cabal --- a/baikai.cabal +++ b/baikai.cabal @@ -1,6 +1,6 @@ cabal-version: 3.4 name: baikai -version: 0.1.1.0 +version: 0.2.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -102,18 +102,47 @@ , scientific , text ^>=2.1 +executable baikai-fetch-models + import: common-options + hs-source-dirs: fetch + main-is: FetchModels.hs + other-modules: FetchModelsCore + + -- The main module is named @FetchModels@ (not @Main@) so the pure + -- core can be compiled into the test suite alongside its own + -- @Main.hs@ without a module-name clash. + ghc-options: -main-is FetchModels + build-depends: + , aeson + , baikai + , base >=4.20 && <5 + , bytestring + , containers + , directory + , filepath + , http-client + , http-client-tls + , scientific + , text ^>=2.1 + , vector + test-suite baikai-test import: common-options type: exitcode-stdio-1.0 - hs-source-dirs: test + hs-source-dirs: test fetch main-is: Main.hs other-modules: AgentAssetsSpec CatalogSpec CostSpec EmbeddingSpec + ErrorInfoSpec + ErrorSpec + FetchModelsCore + FetchModelsSpec InteractiveSpec TraceSpec + UsageSpec build-tool-depends: baikai:baikai-gen-models build-depends: @@ -121,10 +150,12 @@ , baikai , base , bytestring + , containers , directory , filepath , openai , process + , scientific , stm , streamly-core >=0.3 && <0.5 , tasty diff --git a/fetch/FetchModels.hs b/fetch/FetchModels.hs new file mode 100644 --- /dev/null +++ b/fetch/FetchModels.hs @@ -0,0 +1,193 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Executable @baikai-fetch-models@: refresh baikai's catalog JSON +-- from upstream sources (primarily @https:\/\/models.dev\/api.json@). +-- +-- Pipeline role: this tool does @network -> catalog JSON@. The +-- existing @baikai-gen-models@ does @catalog JSON -> Generated.hs@. +-- The two stay separate so the network never runs at build time and +-- the catalog JSON stays a human-reviewable @git diff@ artifact. +-- +-- Typical use, from the repo root: +-- +-- > cabal run baikai-fetch-models -- fetch live, rewrite data/models/{anthropic,openai}.json +-- > cabal run baikai-gen-models -- regenerate Generated.hs +-- > git --no-pager diff baikai/data/models -- review before committing +-- +-- Flags: +-- +-- * @--from-url URL@ — upstream document (default +-- @https:\/\/models.dev\/api.json@). +-- * @--from-file PATH@ — read a local document instead of the network +-- (used by tests and for offline work). +-- * @--out-dir DIR@ — directory to write @\.json@ into +-- (default @\\/data\/models@). +-- * @--provider {openai|anthropic|all}@ — which catalogs to emit +-- (default @all@). +-- * @--stdout@ — print to stdout instead of writing files. +-- +-- All normalization, curation, and rendering logic lives in the pure +-- 'FetchModelsCore' module so it can be unit-tested without IO; this +-- module is only the impure shell (arg parsing, network fetch, file +-- writing). +module FetchModels (main, fetchUpstream) where + +import Control.Exception (catch) +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import FetchModelsCore +import Network.HTTP.Client (HttpException, httpLbs, parseUrlThrow, responseBody) +import Network.HTTP.Client.TLS (newTlsManager) +import System.Directory (doesFileExist, getCurrentDirectory) +import System.Environment (getArgs) +import System.Exit (die) +import System.FilePath (takeDirectory, ()) + +-- | Which provider(s) to emit. +data ProviderSel = SelOpenAI | SelAnthropic | SelAll + deriving stock (Eq, Show) + +-- | Parsed command-line options. +data Options = Options + { optFromUrl :: !String, + optFromFile :: !(Maybe FilePath), + optOutDir :: !(Maybe FilePath), + optProvider :: !ProviderSel, + optStdout :: !Bool + } + +defaultOptions :: Options +defaultOptions = + Options + { optFromUrl = "https://models.dev/api.json", + optFromFile = Nothing, + optOutDir = Nothing, + optProvider = SelAll, + optStdout = False + } + +main :: IO () +main = do + args <- getArgs + opts <- parseArgs args + raw <- loadUpstreamBytes opts + upstream <- case parseUpstream raw of + Left err -> die $ "baikai-fetch-models: failed to parse upstream JSON: " <> err + Right u -> pure u + let catalogs = map (catalogFor upstream) (selectedSpecs (optProvider opts)) + if optStdout opts + then mapM_ (BS.putStr . renderCatalog) catalogs + else do + outDir <- resolveOutDir (optOutDir opts) + mapM_ (writeCatalog outDir) catalogs + +-- | Obtain the raw upstream bytes: a local file when @--from-file@ is +-- set, otherwise a live GET. A network/HTTP failure ('HttpException', +-- which 'parseUrlThrow' raises for non-2xx responses) is turned into a +-- clean non-zero exit with nothing written. +loadUpstreamBytes :: Options -> IO BSL.ByteString +loadUpstreamBytes opts = case optFromFile opts of + Just path -> BSL.readFile path + Nothing -> + fetchUpstream (optFromUrl opts) + `catch` \e -> + die $ + "baikai-fetch-models: failed to fetch " + <> optFromUrl opts + <> ": " + <> show (e :: HttpException) + +-- | GET a URL over TLS and return the body. 'parseUrlThrow' makes any +-- non-2xx status raise an 'HttpException' (handled by the caller), so +-- a 404 or server error never reaches the parser or the filesystem. +fetchUpstream :: String -> IO BSL.ByteString +fetchUpstream url = do + manager <- newTlsManager + req <- parseUrlThrow url + responseBody <$> httpLbs req manager + +-- | Build a provider's catalog from the parsed upstream document, +-- defaulting to an empty model map if the provider is absent. +catalogFor :: Map Text (Map Text UpstreamModel) -> ProviderSpec -> Catalog +catalogFor upstream spec = + normalizeProvider spec (Map.findWithDefault Map.empty (psProvider spec) upstream) + +-- | Write one catalog to @\\/\.json@ in a single +-- 'BS.writeFile' (so a crash mid-run cannot leave a truncated file) +-- and report what was written. +writeCatalog :: FilePath -> Catalog -> IO () +writeCatalog dir cat = do + let path = dir (Text.unpack (cProvider cat) <> ".json") + BS.writeFile path (renderCatalog cat) + putStrLn $ + "Wrote " <> path <> " (" <> show (length (cModels cat)) <> " models)" + +-- | The provider specs selected by @--provider@. +selectedSpecs :: ProviderSel -> [ProviderSpec] +selectedSpecs = \case + SelOpenAI -> [openaiSpec] + SelAnthropic -> [anthropicSpec] + SelAll -> [anthropicSpec, openaiSpec] + +-- | Resolve the output directory, anchoring the default against the +-- @baikai@ package directory the same way @baikai-gen-models@ does. +resolveOutDir :: Maybe FilePath -> IO FilePath +resolveOutDir (Just d) = pure d +resolveOutDir Nothing = do + mPkg <- locatePackageDir + case mPkg of + Nothing -> + die + "baikai-fetch-models: could not locate baikai.cabal in any \ + \ancestor directory; pass --out-dir explicitly" + Just pkg -> pure (pkg "data/models") + +-- | Locate the directory containing @baikai.cabal@ by walking up from +-- the current working directory, also checking a @baikai@ subdir at +-- each level so invocation from the repo root works. Mirrors +-- @baikai-gen-models@. +locatePackageDir :: IO (Maybe FilePath) +locatePackageDir = getCurrentDirectory >>= walk + where + walk dir = do + here <- doesFileExist (dir "baikai.cabal") + if here + then pure (Just dir) + else do + sub <- doesFileExist (dir "baikai" "baikai.cabal") + if sub + then pure (Just (dir "baikai")) + else + let parent = takeDirectory dir + in if parent == dir then pure Nothing else walk parent + +-- | Parse the flags; anything else is a hard error, mirroring +-- @baikai-gen-models@'s strict arg handling. +parseArgs :: [String] -> IO Options +parseArgs = go defaultOptions + where + go o [] = pure o + go o ("--from-url" : v : rest) = go o {optFromUrl = v} rest + go o ("--from-file" : v : rest) = go o {optFromFile = Just v} rest + go o ("--out-dir" : v : rest) = go o {optOutDir = Just v} rest + go o ("--provider" : v : rest) = do + sel <- parseProvider v + go o {optProvider = sel} rest + go o ("--stdout" : rest) = go o {optStdout = True} rest + go _ (a : _) = die $ "baikai-fetch-models: unknown argument " <> show a + +parseProvider :: String -> IO ProviderSel +parseProvider = \case + "openai" -> pure SelOpenAI + "anthropic" -> pure SelAnthropic + "all" -> pure SelAll + other -> + die $ + "baikai-fetch-models: unknown --provider " + <> show other + <> " (expected openai, anthropic, or all)" diff --git a/fetch/FetchModelsCore.hs b/fetch/FetchModelsCore.hs new file mode 100644 --- /dev/null +++ b/fetch/FetchModelsCore.hs @@ -0,0 +1,377 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure core of the @baikai-fetch-models@ tool: parse a +-- models.dev-shaped payload, normalize it into baikai's catalog JSON +-- shape, and render that JSON with formatting matched to the +-- hand-maintained files under @baikai\/data\/models\/@. +-- +-- This module is deliberately free of @IO@ and of any network +-- dependency so it can be unit-tested directly (see +-- @baikai\/test\/FetchModelsSpec.hs@) and so the network fetch lives +-- only in the thin executable wrapper @baikai\/fetch\/FetchModels.hs@. +-- +-- == Curation policy +-- +-- baikai's catalog is an intentionally curated short list, not an +-- exhaustive mirror of models.dev. Only models whose ids appear in the +-- per-provider include set ('openaiInclude', 'anthropicInclude') are +-- emitted, and only if upstream marks them @tool_call: true@. For +-- @openai@ this excludes Responses-API-only ids (@*-pro@, @*-codex@, +-- @*-deep-research@) because @baikai/data/models/openai.json@ speaks +-- @openai-chat-completions@ and 'Baikai.Api' has no Responses tag. +module FetchModelsCore + ( -- * Upstream shape (subset of models.dev fields we consume) + UpstreamModel (..), + parseUpstream, + + -- * Output catalog shape + CatalogModel (..), + CatalogCost (..), + Catalog (..), + + -- * Provider specs and normalization + ProviderSpec (..), + openaiSpec, + anthropicSpec, + openaiInclude, + anthropicInclude, + normalizeProvider, + + -- * Rendering + renderCatalog, + ) +where + +import Baikai.Model (InputModality (..)) +import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.ByteString (ByteString) +import Data.ByteString.Lazy qualified as BSL +import Data.List (sortOn) +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe (fromMaybe) +import Data.Scientific (FPFormat (Fixed), Scientific, formatScientific) +import Data.Set (Set) +import Data.Set qualified as Set +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (encodeUtf8) + +-- * Upstream shape ---------------------------------------------------- + +-- | The subset of a models.dev model object that we consume. Every +-- optional field defaults the way pi-mono's scraper does: missing +-- numbers become 0 at normalization time, missing arrays become empty. +data UpstreamModel = UpstreamModel + { uId :: !Text, + uName :: !(Maybe Text), + uToolCall :: !Bool, + uReasoning :: !Bool, + uCtx :: !(Maybe Integer), + uMaxOut :: !(Maybe Integer), + uCostIn :: !(Maybe Scientific), + uCostOut :: !(Maybe Scientific), + uCacheRead :: !(Maybe Scientific), + uCacheWrite :: !(Maybe Scientific), + uInputMods :: ![Text] + } + deriving stock (Eq, Show) + +instance FromJSON UpstreamModel where + parseJSON = Aeson.withObject "UpstreamModel" $ \o -> do + uId <- o .: "id" + uName <- o .:? "name" + uToolCall <- o .:? "tool_call" .!= False + uReasoning <- o .:? "reasoning" .!= False + mLimit <- o .:? "limit" + mCost <- o .:? "cost" + mMods <- o .:? "modalities" + pure + UpstreamModel + { uId = uId, + uName = uName, + uToolCall = uToolCall, + uReasoning = uReasoning, + uCtx = mLimit >>= limitContext, + uMaxOut = mLimit >>= limitOutput, + uCostIn = mCost >>= costIn, + uCostOut = mCost >>= costOut, + uCacheRead = mCost >>= costCacheRead, + uCacheWrite = mCost >>= costCacheWrite, + uInputMods = maybe [] modalitiesInput mMods + } + +-- | @limit@ sub-object. +data Limit = Limit + { limitContext :: !(Maybe Integer), + limitOutput :: !(Maybe Integer) + } + +instance FromJSON Limit where + parseJSON = Aeson.withObject "limit" $ \o -> + Limit <$> o .:? "context" <*> o .:? "output" + +-- | @cost@ sub-object (US dollars per million tokens). +data Cost = Cost + { costIn :: !(Maybe Scientific), + costOut :: !(Maybe Scientific), + costCacheRead :: !(Maybe Scientific), + costCacheWrite :: !(Maybe Scientific) + } + +instance FromJSON Cost where + parseJSON = Aeson.withObject "cost" $ \o -> + Cost + <$> o .:? "input" + <*> o .:? "output" + <*> o .:? "cache_read" + <*> o .:? "cache_write" + +-- | @modalities@ sub-object; we only read @input@. +newtype Modalities = Modalities {modalitiesInput :: [Text]} + +instance FromJSON Modalities where + parseJSON = Aeson.withObject "modalities" $ \o -> + Modalities <$> o .:? "input" .!= [] + +-- | One provider object in the models.dev document. We only read the +-- @models@ map; every other provider field is ignored. +newtype UpstreamProvider = UpstreamProvider {upModels :: Map Text UpstreamModel} + +instance FromJSON UpstreamProvider where + parseJSON = Aeson.withObject "UpstreamProvider" $ \o -> + UpstreamProvider <$> o .:? "models" .!= Map.empty + +-- | Parse a full models.dev document into @provider -> (modelId -> +-- model)@. The top-level document is a JSON object keyed by provider +-- id; each provider object carries a @models@ map keyed by model id. +parseUpstream :: BSL.ByteString -> Either String (Map Text (Map Text UpstreamModel)) +parseUpstream bs = Map.map upModels <$> Aeson.eitherDecode bs + +-- * Output catalog shape --------------------------------------------- + +-- | Per-million-token cost rates, in the catalog's field names. +data CatalogCost = CatalogCost + { ccInput :: !Scientific, + ccOutput :: !Scientific, + ccCacheRead :: !Scientific, + ccCacheWrite :: !Scientific + } + deriving stock (Eq, Show) + +-- | One emitted catalog model. @enabled@ is always @true@ for emitted +-- models, so it is not stored here; the renderer writes it literally. +data CatalogModel = CatalogModel + { cmId :: !Text, + cmName :: !Text, + cmReasoning :: !Bool, + cmInput :: ![InputModality], + cmCost :: !CatalogCost, + cmContextWindow :: !Integer, + cmMaxOutputTokens :: !Integer + } + deriving stock (Eq, Show) + +-- | A whole catalog file: one provider and its curated models. +data Catalog = Catalog + { cProvider :: !Text, + cBaseUrl :: !Text, + cApi :: !Text, + cModels :: ![CatalogModel] + } + deriving stock (Eq, Show) + +-- * Provider specs and normalization --------------------------------- + +-- | What a provider needs to be normalized: its identity in the +-- catalog and the curation predicate selecting which upstream model +-- ids to keep. +data ProviderSpec = ProviderSpec + { psProvider :: !Text, + psBaseUrl :: !Text, + psApi :: !Text, + psInclude :: !(Text -> Bool) + } + +-- | Curation include set for OpenAI: the chat-completions-compatible +-- current line. Responses-API-only ids (@*-pro@, @*-codex@, +-- @*-deep-research@) are deliberately absent. +openaiInclude :: Set Text +openaiInclude = + Set.fromList + [ "gpt-5.5", + "gpt-5.4", + "gpt-5.4-mini", + "gpt-5.4-nano", + "gpt-5.2", + "gpt-5.1", + "gpt-5", + "gpt-5-mini", + "gpt-5-nano", + "gpt-4.1", + "gpt-4.1-mini", + "gpt-4.1-nano", + "gpt-4o", + "gpt-4o-mini", + "o3", + "o3-mini", + "o4-mini", + "o1" + ] + +-- | Curation include set for Anthropic: the current generations. +anthropicInclude :: Set Text +anthropicInclude = + Set.fromList + [ "claude-opus-4-8", + "claude-opus-4-7", + "claude-opus-4-6", + "claude-opus-4-5", + "claude-sonnet-4-6", + "claude-sonnet-4-5", + "claude-haiku-4-5", + "claude-fable-5" + ] + +-- | Provider spec for OpenAI's first-party chat-completions endpoint. +openaiSpec :: ProviderSpec +openaiSpec = + ProviderSpec + { psProvider = "openai", + psBaseUrl = "https://api.openai.com", + psApi = "openai-chat-completions", + psInclude = (`Set.member` openaiInclude) + } + +-- | Provider spec for Anthropic's first-party messages endpoint. +anthropicSpec :: ProviderSpec +anthropicSpec = + ProviderSpec + { psProvider = "anthropic", + psBaseUrl = "https://api.anthropic.com", + psApi = "anthropic-messages", + psInclude = (`Set.member` anthropicInclude) + } + +-- | Normalize one provider's upstream models into a 'Catalog'. Keeps +-- only @tool_call == True@ models that pass the curation predicate, +-- maps each upstream model to a 'CatalogModel' (dropping @pdf@ and any +-- non-text/image modality; missing costs and limits default to 0 so a +-- human notices), and sorts by model id for deterministic output. +normalizeProvider :: ProviderSpec -> Map Text UpstreamModel -> Catalog +normalizeProvider spec upstream = + Catalog + { cProvider = psProvider spec, + cBaseUrl = psBaseUrl spec, + cApi = psApi spec, + cModels = sortOn cmId (map toCatalogModel kept) + } + where + kept = + [ m + | m <- Map.elems upstream, + uToolCall m, + psInclude spec (uId m) + ] + toCatalogModel m = + CatalogModel + { cmId = uId m, + cmName = fromMaybe (uId m) (uName m), + cmReasoning = uReasoning m, + cmInput = + if "image" `elem` uInputMods m + then [InputText, InputImage] + else [InputText], + cmCost = + CatalogCost + { ccInput = fromMaybe 0 (uCostIn m), + ccOutput = fromMaybe 0 (uCostOut m), + ccCacheRead = fromMaybe 0 (uCacheRead m), + ccCacheWrite = fromMaybe 0 (uCacheWrite m) + }, + cmContextWindow = fromMaybe 0 (uCtx m), + cmMaxOutputTokens = fromMaybe 0 (uMaxOut m) + } + +-- * Rendering --------------------------------------------------------- + +-- | Render a 'Catalog' as catalog JSON, byte-for-byte in the style of +-- the hand-maintained files: 2-space indent, an inline @input@ array, +-- costs as decimal numbers with a trailing @.0@ on whole values, and a +-- trailing newline. +renderCatalog :: Catalog -> ByteString +renderCatalog cat = encodeUtf8 (Text.unlines (renderLines cat)) + +renderLines :: Catalog -> [Text] +renderLines cat = + ["{"] + ++ [ " \"provider\": " <> jsonString (cProvider cat) <> ",", + " \"baseUrl\": " <> jsonString (cBaseUrl cat) <> ",", + " \"api\": " <> jsonString (cApi cat) <> ",", + " \"compat\": \"auto\"," + ] + ++ modelsSection (cModels cat) + ++ ["}"] + +modelsSection :: [CatalogModel] -> [Text] +modelsSection [] = [" \"models\": []"] +modelsSection ms = + [" \"models\": ["] + ++ concat (addBlockCommas (map renderModel ms)) + ++ [" ]"] + +-- | Append a trailing comma to the last line of each block except the +-- final one, so emitted model objects are comma-separated. +addBlockCommas :: [[Text]] -> [[Text]] +addBlockCommas [] = [] +addBlockCommas [b] = [b] +addBlockCommas (b : rest) = appendCommaToLast b : addBlockCommas rest + where + appendCommaToLast xs = case reverse xs of + [] -> xs + (lastLine : front) -> reverse ((lastLine <> ",") : front) + +renderModel :: CatalogModel -> [Text] +renderModel m = + [ " {", + " \"id\": " <> jsonString (cmId m) <> ",", + " \"name\": " <> jsonString (cmName m) <> ",", + " \"reasoning\": " <> jsonBool (cmReasoning m) <> ",", + " \"input\": " <> renderInput (cmInput m) <> ",", + " \"cost\": {", + " \"input\": " <> renderNum (ccInput c) <> ",", + " \"output\": " <> renderNum (ccOutput c) <> ",", + " \"cacheRead\": " <> renderNum (ccCacheRead c) <> ",", + " \"cacheWrite\": " <> renderNum (ccCacheWrite c), + " },", + " \"contextWindow\": " <> Text.pack (show (cmContextWindow m)) <> ",", + " \"maxOutputTokens\": " <> Text.pack (show (cmMaxOutputTokens m)) <> ",", + " \"enabled\": true", + " }" + ] + where + c = cmCost m + +renderInput :: [InputModality] -> Text +renderInput ms = "[" <> Text.intercalate ", " (map one ms) <> "]" + where + one InputText = "\"text\"" + one InputImage = "\"image\"" + +jsonBool :: Bool -> Text +jsonBool True = "true" +jsonBool False = "false" + +-- | Render a cost as a fixed-point decimal. Whole values gain a +-- trailing @.0@ (e.g. @15@ → @15.0@) to match the existing files; +-- fractional values keep their natural decimal form (e.g. @0.075@). +renderNum :: Scientific -> Text +renderNum = Text.pack . formatScientific Fixed Nothing + +-- | Render a 'Text' as a JSON string literal, escaping backslashes and +-- double quotes (sufficient for model ids and display names). +jsonString :: Text -> Text +jsonString t = + "\"" <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" t) <> "\"" diff --git a/src/Baikai/Auth.hs b/src/Baikai/Auth.hs --- a/src/Baikai/Auth.hs +++ b/src/Baikai/Auth.hs @@ -13,7 +13,7 @@ ) where -import Baikai.Error (BaikaiError (..)) +import Baikai.Error (authError) import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Aeson (ToJSON (toJSON), object, (.=)) @@ -47,8 +47,8 @@ renderApiKeySourceForDebug (ApiKeyEnv name) = "ApiKeyEnv " <> Text.pack (show name) --- | Resolve a key source to a plain 'Text'. Throws 'ProviderError' (a --- constructor of 'BaikaiError') if 'ApiKeyEnv' is used and the named variable +-- | Resolve a key source to a plain 'Text'. Throws a 'BaikaiError' in the +-- 'Baikai.Error.AuthError' category if 'ApiKeyEnv' is used and the named variable -- is unset. resolveApiKey :: (MonadIO m) => ApiKeySource -> m Text resolveApiKey (ApiKeyLiteral t) = pure t @@ -56,4 +56,4 @@ liftIO $ Environment.lookupEnv name >>= \case Just v -> pure (Text.pack v) - Nothing -> throwIO (ProviderError ("env var " <> Text.pack name <> " is not set")) + Nothing -> throwIO (authError ("env var " <> Text.pack name <> " is not set")) diff --git a/src/Baikai/Cost.hs b/src/Baikai/Cost.hs --- a/src/Baikai/Cost.hs +++ b/src/Baikai/Cost.hs @@ -37,6 +37,28 @@ _Cost :: Cost _Cost = Cost {usd = 0, breakdown = _CostBreakdown} +-- Field-wise combination so callers can total per-call costs with +-- '(<>)'/'mconcat'. 'mempty' reuses the existing zero value, so the +-- identity laws hold by construction (adding zero rationals). + +instance Semigroup CostBreakdown where + a <> b = + CostBreakdown + { inputUsd = inputUsd a + inputUsd b, + outputUsd = outputUsd a + outputUsd b, + cachedInputUsd = cachedInputUsd a + cachedInputUsd b, + cachedWriteUsd = cachedWriteUsd a + cachedWriteUsd b + } + +instance Monoid CostBreakdown where + mempty = _CostBreakdown + +instance Semigroup Cost where + a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b} + +instance Monoid Cost where + mempty = _Cost + instance ToJSON CostBreakdown where toJSON cb = object diff --git a/src/Baikai/Error.hs b/src/Baikai/Error.hs --- a/src/Baikai/Error.hs +++ b/src/Baikai/Error.hs @@ -1,13 +1,210 @@ -module Baikai.Error (BaikaiError (..)) where +module Baikai.Error + ( BaikaiError (..), + ErrorCategory (..), -import Control.Exception (Exception) + -- * Smart constructors + providerError, + invalidRequest, + decodeError, + processError, + rateLimited, + authError, + providerUnavailable, + + -- * Accessors + isRetryable, + + -- * Pure classification helpers for provider packages + classifyHttpStatus, + classifyHttpStatusWithBody, + bodyIndicatesOverflow, + ) +where + +import Control.Exception (Exception (displayException)) +import Data.Aeson + ( FromJSON (parseJSON), + Options (constructorTagModifier, fieldLabelModifier), + ToJSON (toJSON), + camelTo2, + defaultOptions, + genericParseJSON, + genericToJSON, + ) import Data.Text (Text) +import Data.Text qualified as Text import GHC.Generics (Generic) -data BaikaiError - = ProviderError !Text - | RequestInvalid !Text - | DecodeError !Text - | ProcessError !Int !Text +-- | A provider-neutral category for a failed call. Callers switch on +-- this to decide policy (retry, surface to user, abort). The set is +-- closed and stable; new HTTP nuances map onto an existing member +-- rather than growing this type. +data ErrorCategory + = -- | Authentication/authorization failure: missing or rejected + -- credentials (HTTP 401/403, or a missing API-key env var). + AuthError + | -- | The provider rate-limited the request (HTTP 429). Usually + -- retryable after a delay; see 'retryAfterSeconds'. + RateLimited + | -- | The request exceeded the model's context window or a related + -- size limit. Not retryable as-is; the caller must shrink input. + ContextOverflow + | -- | The request was malformed or otherwise rejected as invalid + -- (HTTP 400/404/422). Not retryable without changes. + InvalidRequest + | -- | A transient server-side or network failure (HTTP 408/5xx, or a + -- connection error). Safe to retry, ideally with backoff. + TransientError + | -- | The response could not be decoded/parsed into the expected + -- shape. + DecodeFailure + | -- | A subprocess (the @claude -p@ or @codex exec@ CLI provider) + -- exited non-zero. The exit code is in 'exitCode'. + ProcessFailure + | -- | No provider handler was registered for the model's API tag. + ProviderUnavailable + | -- | Anything not covered above. + OtherError deriving stock (Eq, Show, Generic) - deriving anyclass (Exception) + +-- | Categories serialize as snake_case strings (e.g. @"rate_limited"@). +instance ToJSON ErrorCategory where + toJSON = + genericToJSON + defaultOptions {constructorTagModifier = camelTo2 '_'} + +instance FromJSON ErrorCategory where + parseJSON = + genericParseJSON + defaultOptions {constructorTagModifier = camelTo2 '_'} + +-- | A failed baikai call. The 'category' drives caller policy; the +-- remaining fields carry optional structured hints. No record-field +-- prefixes (project convention): fields are plain names. +data BaikaiError = BaikaiError + { category :: !ErrorCategory, + -- | Human-readable detail, safe to log. + message :: !Text, + -- | The HTTP status code, when the failure came from an HTTP call. + httpStatus :: !(Maybe Int), + -- | Seconds to wait before retrying, parsed from a @Retry-After@ + -- header when present and integer-valued. + retryAfterSeconds :: !(Maybe Int), + -- | The subprocess exit code, for 'ProcessFailure'. + exitCode :: !(Maybe Int) + } + deriving stock (Eq, Show, Generic) + +-- | Fields serialize as snake_case (e.g. @http_status@, @retry_after_seconds@). +instance ToJSON BaikaiError where + toJSON = + genericToJSON + defaultOptions {fieldLabelModifier = camelTo2 '_'} + +instance FromJSON BaikaiError where + parseJSON = + genericParseJSON + defaultOptions {fieldLabelModifier = camelTo2 '_'} + +instance Exception BaikaiError where + displayException e = + "BaikaiError(" <> show (category e) <> "): " <> Text.unpack (message e) + +-- | Base value with everything absent; used by smart constructors. +baseError :: ErrorCategory -> Text -> BaikaiError +baseError c m = + BaikaiError + { category = c, + message = m, + httpStatus = Nothing, + retryAfterSeconds = Nothing, + exitCode = Nothing + } + +-- Smart constructors. These keep call sites close to the old API: an +-- old @ProviderError "x"@ becomes @providerError "x"@, etc. + +-- | A generic provider failure with no further classification. +providerError :: Text -> BaikaiError +providerError = baseError OtherError + +-- | A request rejected as invalid. +invalidRequest :: Text -> BaikaiError +invalidRequest = baseError InvalidRequest + +-- | A response that failed to decode. +decodeError :: Text -> BaikaiError +decodeError = baseError DecodeFailure + +-- | A subprocess that exited non-zero. First argument is the exit code. +processError :: Int -> Text -> BaikaiError +processError code m = (baseError ProcessFailure m) {exitCode = Just code} + +-- | A rate-limit failure with an optional retry-after hint (seconds). +rateLimited :: Maybe Int -> Text -> BaikaiError +rateLimited secs m = + (baseError RateLimited m) {retryAfterSeconds = secs, httpStatus = Just 429} + +-- | An authentication/authorization or credential-configuration failure. +authError :: Text -> BaikaiError +authError = baseError AuthError + +-- | No provider handler registered for a model's API tag. +providerUnavailable :: Text -> BaikaiError +providerUnavailable = baseError ProviderUnavailable + +-- | Whether the application may sensibly retry this error. True for +-- rate limits and transient server/network failures; False otherwise. +-- (Note: 'retryAfterSeconds' may still be 'Nothing' even when this is +-- True, meaning "retryable but no server-suggested delay".) +isRetryable :: BaikaiError -> Bool +isRetryable e = case category e of + RateLimited -> True + TransientError -> True + _ -> False + +-- | Map an HTTP status code (and an optional already-parsed +-- retry-after-seconds value) to a category. Pure and network-free so it +-- can be unit-tested in the core package; provider packages call it +-- after extracting the status from their SDK's exception type. +-- +-- The body of a 400 may indicate a context-window overflow, but this +-- helper only sees the status code; callers that can inspect the body +-- should special-case overflow before falling back here. +classifyHttpStatus :: Int -> Maybe Int -> ErrorCategory +classifyHttpStatus status _retryAfter + | status == 401 || status == 403 = AuthError + | status == 429 = RateLimited + | status == 408 = TransientError + | status == 400 || status == 404 || status == 422 = InvalidRequest + | status >= 500 = TransientError + | otherwise = OtherError + +-- | Like 'classifyHttpStatus', but also inspects the response body so a +-- 400/422 whose body signals a context-window overflow is categorised +-- as 'ContextOverflow' rather than the plain 'InvalidRequest' the status +-- alone would give. All other statuses defer to 'classifyHttpStatus'. +classifyHttpStatusWithBody :: Int -> Maybe Int -> Text -> ErrorCategory +classifyHttpStatusWithBody status retryAfter body + | (status == 400 || status == 422) && bodyIndicatesOverflow body = + ContextOverflow + | otherwise = classifyHttpStatus status retryAfter + +-- | Whether an error body's text contains a known context-window +-- overflow marker (case-insensitive). Covers the phrasings used by the +-- Anthropic and OpenAI APIs. +bodyIndicatesOverflow :: Text -> Bool +bodyIndicatesOverflow body = + any (`Text.isInfixOf` lower) markers + where + lower = Text.toLower body + markers = + [ "context length", + "context_length_exceeded", + "maximum context", + "context window", + "prompt is too long", + "too many tokens", + "request_too_large", + "too many total text bytes" + ] diff --git a/src/Baikai/Models/Generated.hs b/src/Baikai/Models/Generated.hs --- a/src/Baikai/Models/Generated.hs +++ b/src/Baikai/Models/Generated.hs @@ -23,6 +23,28 @@ import Data.Map.Strict qualified as Map import Data.Ratio ((%)) +anthropic_claude_fable_5 :: Model +anthropic_claude_fable_5 = + Model + { modelId = "claude-fable-5" + , name = "Claude Fable 5" + , api = AnthropicMessages + , provider = "anthropic" + , baseUrl = "https://api.anthropic.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 10 % 1 + , outputCost = 50 % 1 + , cacheReadCost = 1 % 1 + , cacheWriteCost = 25 % 2 + } + , contextWindow = 1000000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + anthropic_claude_haiku_4_5 :: Model anthropic_claude_haiku_4_5 = Model @@ -31,42 +53,64 @@ , api = AnthropicMessages , provider = "anthropic" , baseUrl = "https://api.anthropic.com" - , reasoning = False + , reasoning = True , input = [InputText, InputImage] , cost = ModelCost - { inputCost = 4 % 5 - , outputCost = 4 % 1 - , cacheReadCost = 2 % 25 - , cacheWriteCost = 1 % 1 + { inputCost = 1 % 1 + , outputCost = 5 % 1 + , cacheReadCost = 1 % 10 + , cacheWriteCost = 5 % 4 } , contextWindow = 200000 - , maxOutputTokens = 8192 + , maxOutputTokens = 64000 , headers = Map.empty , compat = CompatNone } -anthropic_claude_haiku_4_5_20251001 :: Model -anthropic_claude_haiku_4_5_20251001 = +anthropic_claude_opus_4_5 :: Model +anthropic_claude_opus_4_5 = Model - { modelId = "claude-haiku-4-5-20251001" - , name = "Claude Haiku 4.5 (2025-10-01)" + { modelId = "claude-opus-4-5" + , name = "Claude Opus 4.5" , api = AnthropicMessages , provider = "anthropic" , baseUrl = "https://api.anthropic.com" - , reasoning = False + , reasoning = True , input = [InputText, InputImage] , cost = ModelCost - { inputCost = 4 % 5 - , outputCost = 4 % 1 - , cacheReadCost = 2 % 25 - , cacheWriteCost = 1 % 1 + { inputCost = 5 % 1 + , outputCost = 25 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 25 % 4 } , contextWindow = 200000 - , maxOutputTokens = 8192 + , maxOutputTokens = 64000 , headers = Map.empty , compat = CompatNone } +anthropic_claude_opus_4_6 :: Model +anthropic_claude_opus_4_6 = + Model + { modelId = "claude-opus-4-6" + , name = "Claude Opus 4.6" + , api = AnthropicMessages + , provider = "anthropic" + , baseUrl = "https://api.anthropic.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 1 + , outputCost = 25 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 25 % 4 + } + , contextWindow = 1000000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + anthropic_claude_opus_4_7 :: Model anthropic_claude_opus_4_7 = Model @@ -78,13 +122,57 @@ , reasoning = True , input = [InputText, InputImage] , cost = ModelCost - { inputCost = 15 % 1 - , outputCost = 75 % 1 - , cacheReadCost = 3 % 2 - , cacheWriteCost = 75 % 4 + { inputCost = 5 % 1 + , outputCost = 25 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 25 % 4 } + , contextWindow = 1000000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +anthropic_claude_opus_4_8 :: Model +anthropic_claude_opus_4_8 = + Model + { modelId = "claude-opus-4-8" + , name = "Claude Opus 4.8" + , api = AnthropicMessages + , provider = "anthropic" + , baseUrl = "https://api.anthropic.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 1 + , outputCost = 25 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 25 % 4 + } + , contextWindow = 1000000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +anthropic_claude_sonnet_4_5 :: Model +anthropic_claude_sonnet_4_5 = + Model + { modelId = "claude-sonnet-4-5" + , name = "Claude Sonnet 4.5" + , api = AnthropicMessages + , provider = "anthropic" + , baseUrl = "https://api.anthropic.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 3 % 1 + , outputCost = 15 % 1 + , cacheReadCost = 3 % 10 + , cacheWriteCost = 15 % 4 + } , contextWindow = 200000 - , maxOutputTokens = 8192 + , maxOutputTokens = 64000 , headers = Map.empty , compat = CompatNone } @@ -97,7 +185,7 @@ , api = AnthropicMessages , provider = "anthropic" , baseUrl = "https://api.anthropic.com" - , reasoning = False + , reasoning = True , input = [InputText, InputImage] , cost = ModelCost { inputCost = 3 % 1 @@ -105,8 +193,8 @@ , cacheReadCost = 3 % 10 , cacheWriteCost = 15 % 4 } - , contextWindow = 200000 - , maxOutputTokens = 8192 + , contextWindow = 1000000 + , maxOutputTokens = 64000 , headers = Map.empty , compat = CompatNone } @@ -155,6 +243,72 @@ , compat = CompatNone } +openai_gpt_4_1 :: Model +openai_gpt_4_1 = + Model + { modelId = "gpt-4.1" + , name = "GPT-4.1" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = False + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 2 % 1 + , outputCost = 8 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 1047576 + , maxOutputTokens = 32768 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_4_1_mini :: Model +openai_gpt_4_1_mini = + Model + { modelId = "gpt-4.1-mini" + , name = "GPT-4.1 mini" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = False + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 2 % 5 + , outputCost = 8 % 5 + , cacheReadCost = 1 % 10 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 1047576 + , maxOutputTokens = 32768 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_4_1_nano :: Model +openai_gpt_4_1_nano = + Model + { modelId = "gpt-4.1-nano" + , name = "GPT-4.1 nano" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = False + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 1 % 10 + , outputCost = 2 % 5 + , cacheReadCost = 1 % 40 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 1047576 + , maxOutputTokens = 32768 + , headers = Map.empty + , compat = CompatNone + } + openai_gpt_4o :: Model openai_gpt_4o = Model @@ -199,11 +353,209 @@ , compat = CompatNone } +openai_gpt_5 :: Model +openai_gpt_5 = + Model + { modelId = "gpt-5" + , name = "GPT-5" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 4 + , outputCost = 10 % 1 + , cacheReadCost = 1 % 8 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_1 :: Model +openai_gpt_5_1 = + Model + { modelId = "gpt-5.1" + , name = "GPT-5.1" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 4 + , outputCost = 10 % 1 + , cacheReadCost = 1 % 8 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_2 :: Model +openai_gpt_5_2 = + Model + { modelId = "gpt-5.2" + , name = "GPT-5.2" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 7 % 4 + , outputCost = 14 % 1 + , cacheReadCost = 7 % 40 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_4 :: Model +openai_gpt_5_4 = + Model + { modelId = "gpt-5.4" + , name = "GPT-5.4" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 2 + , outputCost = 15 % 1 + , cacheReadCost = 1 % 4 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 1050000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_4_mini :: Model +openai_gpt_5_4_mini = + Model + { modelId = "gpt-5.4-mini" + , name = "GPT-5.4 mini" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 3 % 4 + , outputCost = 9 % 2 + , cacheReadCost = 3 % 40 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_4_nano :: Model +openai_gpt_5_4_nano = + Model + { modelId = "gpt-5.4-nano" + , name = "GPT-5.4 nano" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 1 % 5 + , outputCost = 5 % 4 + , cacheReadCost = 1 % 50 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_5 :: Model +openai_gpt_5_5 = + Model + { modelId = "gpt-5.5" + , name = "GPT-5.5" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 5 % 1 + , outputCost = 30 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 1050000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_mini :: Model +openai_gpt_5_mini = + Model + { modelId = "gpt-5-mini" + , name = "GPT-5 Mini" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 1 % 4 + , outputCost = 2 % 1 + , cacheReadCost = 1 % 40 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + +openai_gpt_5_nano :: Model +openai_gpt_5_nano = + Model + { modelId = "gpt-5-nano" + , name = "GPT-5 Nano" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 1 % 20 + , outputCost = 2 % 5 + , cacheReadCost = 1 % 200 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 400000 + , maxOutputTokens = 128000 + , headers = Map.empty + , compat = CompatNone + } + openai_o1 :: Model openai_o1 = Model { modelId = "o1" - , name = "OpenAI o1" + , name = "o1" , api = OpenAIChatCompletions , provider = "openai" , baseUrl = "https://api.openai.com" @@ -221,24 +573,68 @@ , compat = CompatNone } -openai_o1_mini :: Model -openai_o1_mini = +openai_o3 :: Model +openai_o3 = Model - { modelId = "o1-mini" - , name = "OpenAI o1-mini" + { modelId = "o3" + , name = "o3" , api = OpenAIChatCompletions , provider = "openai" , baseUrl = "https://api.openai.com" , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 2 % 1 + , outputCost = 8 % 1 + , cacheReadCost = 1 % 2 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 200000 + , maxOutputTokens = 100000 + , headers = Map.empty + , compat = CompatNone + } + +openai_o3_mini :: Model +openai_o3_mini = + Model + { modelId = "o3-mini" + , name = "o3-mini" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True , input = [InputText] , cost = ModelCost - { inputCost = 3 % 1 - , outputCost = 12 % 1 - , cacheReadCost = 3 % 2 + { inputCost = 11 % 10 + , outputCost = 22 % 5 + , cacheReadCost = 11 % 20 , cacheWriteCost = 0 % 1 } - , contextWindow = 128000 - , maxOutputTokens = 65536 + , contextWindow = 200000 + , maxOutputTokens = 100000 + , headers = Map.empty + , compat = CompatNone + } + +openai_o4_mini :: Model +openai_o4_mini = + Model + { modelId = "o4-mini" + , name = "o4-mini" + , api = OpenAIChatCompletions + , provider = "openai" + , baseUrl = "https://api.openai.com" + , reasoning = True + , input = [InputText, InputImage] + , cost = ModelCost + { inputCost = 11 % 10 + , outputCost = 22 % 5 + , cacheReadCost = 11 % 40 + , cacheWriteCost = 0 % 1 + } + , contextWindow = 200000 + , maxOutputTokens = 100000 , headers = Map.empty , compat = CompatNone } diff --git a/src/Baikai/Provider/Cli/Internal.hs b/src/Baikai/Provider/Cli/Internal.hs --- a/src/Baikai/Provider/Cli/Internal.hs +++ b/src/Baikai/Provider/Cli/Internal.hs @@ -101,8 +101,8 @@ maybeApply (Just a) f b = f a b -- | Decode UTF-8 bytes leniently, replacing invalid sequences with --- U+FFFD. Used for surfacing CLI stderr in --- 'Baikai.Error.ProcessError'. +-- U+FFFD. Used for surfacing CLI stderr in a +-- 'Baikai.Error.ProcessFailure' error. decodeUtf8Lenient :: ByteString -> Text decodeUtf8Lenient = Text.decodeUtf8With Text.lenientDecode diff --git a/src/Baikai/Provider/Registry.hs b/src/Baikai/Provider/Registry.hs --- a/src/Baikai/Provider/Registry.hs +++ b/src/Baikai/Provider/Registry.hs @@ -9,8 +9,9 @@ -- sets, or use the global convenience registry for simple scripts. -- -- 'completeRequest' looks the handler up by the 'Model'\'s 'Api' --- tag and dispatches; it throws 'Baikai.Error.ProviderError' when --- no handler is registered for that tag. +-- tag and dispatches; it throws a 'Baikai.Error.BaikaiError' in the +-- 'Baikai.Error.ProviderUnavailable' category when no handler is +-- registered for that tag. module Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, @@ -27,7 +28,7 @@ import Baikai.Api (Api, renderApi) import Baikai.Context (Context) -import Baikai.Error (BaikaiError (..)) +import Baikai.Error (providerUnavailable) import Baikai.Model (Model (..)) import Baikai.Options (Options) import Baikai.Response (Response) @@ -87,7 +88,7 @@ lookupApiProvider = lookupApiProviderWith globalProviderRegistry -- | Dispatch a synchronous request through the registered handler --- for the model's 'Api' tag. Throws 'ProviderError' when no handler +-- for the model's 'Api' tag. Throws a 'ProviderUnavailable' error when no handler -- is registered for that tag. completeRequestWith :: ProviderRegistry -> Model -> Context -> Options -> IO Response completeRequestWith reg m ctx opts = do @@ -96,7 +97,7 @@ Just p -> complete p m ctx opts Nothing -> throwIO $ - ProviderError ("No provider registered for API: " <> renderApi (api m)) + providerUnavailable ("No provider registered for API: " <> renderApi (api m)) -- | Dispatch a synchronous request through the process-global registry. completeRequest :: Model -> Context -> Options -> IO Response diff --git a/src/Baikai/Response.hs b/src/Baikai/Response.hs --- a/src/Baikai/Response.hs +++ b/src/Baikai/Response.hs @@ -19,6 +19,7 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent) +import Baikai.Error (BaikaiError) import Baikai.Message (AssistantPayload (..), Message (..)) import Baikai.Model (Model, _Model) import Baikai.StopReason (StopReason (..)) @@ -36,7 +37,14 @@ api :: !Api, provider :: !Text, responseId :: !(Maybe Text), - latencyMs :: !Integer + latencyMs :: !Integer, + -- | Structured error detail when the call failed in-band + -- (@stopReason = ErrorReason@): the category, HTTP status, and any + -- retry-after hint. 'Nothing' on success or when the provider could + -- not classify the failure. Lets a caller branch on + -- 'Baikai.Error.category' / 'Baikai.Error.isRetryable' without + -- parsing 'errorMessage' text. + errorInfo :: !(Maybe BaikaiError) } deriving stock (Eq, Show, Generic) @@ -58,7 +66,8 @@ api = Custom "", provider = "", responseId = Nothing, - latencyMs = 0 + latencyMs = 0, + errorInfo = Nothing } -- | Wrap the response payload as a conversation 'AssistantMessage'. diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -31,6 +31,7 @@ ) import Baikai.Content qualified as Content import Baikai.Context (Context) +import Baikai.Error (BaikaiError, providerUnavailable) import Baikai.Message (AssistantPayload (..), Message (AssistantMessage)) import Baikai.Message qualified as Msg import Baikai.Model (Model) @@ -51,8 +52,11 @@ StartPayload (..), TerminalPayload (..), ToolCallEndPayload (..), + doneTerminal, + errorTerminal, ) import Baikai.Usage (_Usage) +import Control.Exception (fromException) import Control.Exception qualified import Control.Lens ((%~), (&), (.~), (^.)) import Data.Aeson qualified as Aeson @@ -126,8 +130,10 @@ textBuf :: !(IntMap Text), thinkBuf :: !(IntMap Text), toolArgsBuf :: !(IntMap Text), - -- | 'Just (reason, msg)' once 'EventDone' or 'EventError' fires. - terminal :: !(Maybe (StopReason, Message)) + -- | 'Just (reason, msg, errorInfo)' once 'EventDone' or 'EventError' + -- fires. @errorInfo@ is the structured error from an 'EventError' + -- terminal (if the provider classified it), 'Nothing' otherwise. + terminal :: !(Maybe (StopReason, Message, Maybe BaikaiError)) } deriving stock (Show, Generic) @@ -181,18 +187,18 @@ & #blocks %~ IntMap.insert i (AssistantToolCall tc) & #toolArgsBuf %~ IntMap.delete i EventDone TerminalPayload {reason = r, message = msg} -> - s & #terminal .~ Just (r, msg) - EventError TerminalPayload {reason = r, message = msg} -> - s & #terminal .~ Just (r, msg) + s & #terminal .~ Just (r, msg, Nothing) + EventError TerminalPayload {reason = r, message = msg, errorInfo = ei} -> + s & #terminal .~ Just (r, msg, ei) finalizeState :: ReassemblyState -> IO Response finalizeState s = do now <- getCurrentTime let m = s ^. #model assembled = assembleBlocks s - (terminalMsg, terminalReason) = case s ^. #terminal of - Just (r, msg) -> (msg, r) - Nothing -> (synthesizeTerminal now assembled, Stop) + (terminalMsg, terminalReason, terminalError) = case s ^. #terminal of + Just (r, msg, ei) -> (msg, r, ei) + Nothing -> (synthesizeTerminal now assembled, Stop, Nothing) message' = overrideBlocksAndReason terminalReason terminalMsg assembled now endTs = message' ^. #timestamp latency = case s ^. #startTime of @@ -206,7 +212,8 @@ api = m ^. #api, provider = m ^. #provider, responseId = Nothing, - latencyMs = latency + latencyMs = latency, + errorInfo = terminalError } -- | Project the closed content blocks in 'contentIndex' order, plus @@ -325,7 +332,7 @@ reason = payload ^. #stopReason in [EventStart StartPayload {partial = skeleton}] <> blockEvents - <> [EventDone TerminalPayload {reason = reason, message = msg}] + <> [EventDone (doneTerminal reason msg)] blockEvent :: Int -> AssistantContent -> [AssistantMessageEvent] blockEvent i = \case @@ -350,30 +357,39 @@ errorEvent :: Control.Exception.SomeException -> IO AssistantMessageEvent errorEvent e = do now <- getCurrentTime - let msg = + -- When a @complete@ handler threw a typed 'BaikaiError' (the CLI, + -- 'Baikai.Auth', and registry paths do), preserve it structurally so a + -- caller draining this lifted stream still gets the category and any + -- retry hint. Otherwise fall back to the displayed exception text. + let mErr = fromException e :: Maybe BaikaiError + errText = case mErr of + Just be -> be ^. #message + Nothing -> Text.pack (Control.Exception.displayException e) + msg = AssistantMessage AssistantPayload { Msg.content = Vector.empty, Msg.usage = _Usage, Msg.stopReason = ErrorReason, - Msg.errorMessage = Just (Text.pack (Control.Exception.displayException e)), + Msg.errorMessage = Just errText, Msg.timestamp = now } - pure (EventError TerminalPayload {reason = ErrorReason, message = msg}) + pure (EventError (errorTerminal ErrorReason msg mErr)) -- | The single 'EventError' value used when no provider is -- registered for the model's API tag. noProviderEvent :: Model -> IO AssistantMessageEvent noProviderEvent m = do now <- getCurrentTime - let msg = + let detail = "No provider registered for API: " <> renderApi (m ^. #api) + be = providerUnavailable detail + msg = AssistantMessage AssistantPayload { Msg.content = Vector.empty, Msg.usage = _Usage, Msg.stopReason = ErrorReason, - Msg.errorMessage = - Just ("No provider registered for API: " <> renderApi (m ^. #api)), + Msg.errorMessage = Just detail, Msg.timestamp = now } - pure (EventError TerminalPayload {reason = ErrorReason, message = msg}) + pure (EventError (errorTerminal ErrorReason msg (Just be))) diff --git a/src/Baikai/Stream/Event.hs b/src/Baikai/Stream/Event.hs --- a/src/Baikai/Stream/Event.hs +++ b/src/Baikai/Stream/Event.hs @@ -31,11 +31,14 @@ BlockEndPayload (..), ToolCallEndPayload (..), TerminalPayload (..), + doneTerminal, + errorTerminal, isTerminal, ) where import Baikai.Content (ToolCall) +import Baikai.Error (BaikaiError) import Baikai.Message (Message) import Baikai.StopReason (StopReason) import Data.Aeson (ToJSON) @@ -148,10 +151,26 @@ -- resolved 'StopReason' and the assembled 'message'. data TerminalPayload = TerminalPayload { reason :: !StopReason, - message :: !Message + message :: !Message, + -- | Structured error detail for an 'EventError' terminal: the + -- category, HTTP status, and any retry-after hint a caller needs to + -- decide retry policy. 'Nothing' for a successful 'EventDone' + -- terminal and for error terminals a provider could not classify. + errorInfo :: !(Maybe BaikaiError) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) + +-- | Build a success terminal payload ('errorInfo' is always 'Nothing'). +-- Prefer this over the raw 'TerminalPayload' constructor so a new field +-- can never be left uninitialised at a construction site. +doneTerminal :: StopReason -> Message -> TerminalPayload +doneTerminal r m = TerminalPayload {reason = r, message = m, errorInfo = Nothing} + +-- | Build an error terminal payload carrying optional structured error +-- detail. Prefer this over the raw 'TerminalPayload' constructor. +errorTerminal :: StopReason -> Message -> Maybe BaikaiError -> TerminalPayload +errorTerminal r m e = TerminalPayload {reason = r, message = m, errorInfo = e} -- | 'True' when the event terminates the stream — exactly one -- 'EventDone' or 'EventError' is emitted per call. diff --git a/src/Baikai/Usage.hs b/src/Baikai/Usage.hs --- a/src/Baikai/Usage.hs +++ b/src/Baikai/Usage.hs @@ -6,7 +6,7 @@ -- billing dimensions. 'cost' is always populated — providers without -- pricing data fill it with '_Cost' (zero across all rates) rather than -- a 'Nothing' that every cost-reading caller would have to handle. -module Baikai.Usage (Usage (..), _Usage) where +module Baikai.Usage (Usage (..), _Usage, sumUsage) where import Baikai.Cost (Cost, _Cost) import Data.Aeson @@ -16,6 +16,7 @@ defaultOptions, genericToJSON, ) +import Data.Maybe (fromMaybe) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -46,3 +47,30 @@ totalTokens = 0, cost = _Cost } + +-- | Combine two optional reasoning-token counts. Presence wins: an +-- absent side counts as zero, but the result is only 'Nothing' when +-- both sides are 'Nothing', so a non-reasoning call summed with a +-- reasoning call keeps the reasoning total. +combineReasoning :: Maybe Natural -> Maybe Natural -> Maybe Natural +combineReasoning Nothing Nothing = Nothing +combineReasoning a b = Just (fromMaybe 0 a + fromMaybe 0 b) + +instance Semigroup Usage where + a <> b = + Usage + { inputTokens = inputTokens a + inputTokens b, + outputTokens = outputTokens a + outputTokens b, + cacheReadTokens = cacheReadTokens a + cacheReadTokens b, + cacheWriteTokens = cacheWriteTokens a + cacheWriteTokens b, + reasoningTokens = combineReasoning (reasoningTokens a) (reasoningTokens b), + totalTokens = totalTokens a + totalTokens b, + cost = cost a <> cost b + } + +instance Monoid Usage where + mempty = _Usage + +-- | Total a collection of per-call usages into one. +sumUsage :: (Foldable f) => f Usage -> Usage +sumUsage = foldl' (<>) mempty diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -138,7 +138,8 @@ api = Custom "test", provider = "claude-api", responseId = Nothing, - latencyMs = 100 + latencyMs = 100, + errorInfo = Nothing } -- Register a handler under a private API tag that returns a canned @@ -162,7 +163,8 @@ api = cannedApi, provider = "canned", responseId = Nothing, - latencyMs = 7 + latencyMs = 7, + errorInfo = Nothing } registerCanned :: Response -> IO () diff --git a/test/ErrorInfoSpec.hs b/test/ErrorInfoSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorInfoSpec.hs @@ -0,0 +1,65 @@ +-- | End-to-end check that a structured error set on an 'EventError' +-- terminal is threaded through reassembly onto the 'Response' a caller +-- gets back from 'completeRequest'. This is the user-visible payoff of +-- the in-band error-classification work: branch on category/retry +-- without parsing error text. +module ErrorInfoSpec (tests) where + +import Baikai +import Baikai.Prelude +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) + +errApi :: Api +errApi = Custom "baikai-errinfo" + +errModel :: Model +errModel = + _Model + & #modelId + .~ "err-model" + & #api + .~ errApi + & #provider + .~ "test" + +-- | A stream that emits a single 'EventError' carrying a structured +-- 'RateLimited' error with a retry-after hint. +errStream :: Model -> Context -> Options -> Stream.Stream IO AssistantMessageEvent +errStream _ _ _ = + let payload = + (_Response ^. #message) + & #stopReason + .~ ErrorReason + & #errorMessage + .~ Just "rate limited, slow down" + term = + errorTerminal + ErrorReason + (AssistantMessage payload) + (Just (rateLimited (Just 5) "rate limited, slow down")) + in Stream.fromList [EventError term] + +registerErr :: IO () +registerErr = + registerApiProvider + ApiProvider + { apiTag = errApi, + stream = errStream, + complete = streamingComplete errStream + } + +tests :: TestTree +tests = + testGroup + "Response.errorInfo threading" + [ testCase "completeRequest surfaces structured errorInfo" $ do + registerErr + resp <- completeRequest errModel _Context _Options + case resp ^. #errorInfo of + Just be -> do + be ^. #category @?= RateLimited + be ^. #retryAfterSeconds @?= Just 5 + Nothing -> assertFailure "expected Response.errorInfo to be populated" + ] diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs new file mode 100644 --- /dev/null +++ b/test/ErrorSpec.hs @@ -0,0 +1,92 @@ +module ErrorSpec (tests) where + +import Baikai.Error + ( BaikaiError (..), + ErrorCategory (..), + classifyHttpStatus, + classifyHttpStatusWithBody, + decodeError, + invalidRequest, + isRetryable, + processError, + rateLimited, + ) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Error" + [ classifyTests, + bodyClassifyTests, + retryTests, + constructorTests + ] + +bodyClassifyTests :: TestTree +bodyClassifyTests = + testGroup + "classifyHttpStatusWithBody" + [ testCase "400 + overflow body -> ContextOverflow" $ + classifyHttpStatusWithBody 400 Nothing "This model's maximum context length is 8192 tokens" + @?= ContextOverflow, + testCase "400 + prompt-too-long body -> ContextOverflow" $ + classifyHttpStatusWithBody 400 Nothing "prompt is too long: 9000 tokens > 8000" + @?= ContextOverflow, + testCase "400 + ordinary body -> InvalidRequest" $ + classifyHttpStatusWithBody 400 Nothing "missing required field 'model'" + @?= InvalidRequest, + testCase "429 + overflow-looking body still RateLimited (status wins)" $ + classifyHttpStatusWithBody 429 Nothing "context length whatever" + @?= RateLimited, + testCase "500 defers to status -> TransientError" $ + classifyHttpStatusWithBody 500 Nothing "context length" @?= TransientError + ] + +classifyTests :: TestTree +classifyTests = + testGroup + "classifyHttpStatus" + [ testCase "401 -> AuthError" $ classifyHttpStatus 401 Nothing @?= AuthError, + testCase "403 -> AuthError" $ classifyHttpStatus 403 Nothing @?= AuthError, + testCase "429 -> RateLimited" $ classifyHttpStatus 429 Nothing @?= RateLimited, + testCase "408 -> TransientError" $ classifyHttpStatus 408 Nothing @?= TransientError, + testCase "400 -> InvalidRequest" $ classifyHttpStatus 400 Nothing @?= InvalidRequest, + testCase "404 -> InvalidRequest" $ classifyHttpStatus 404 Nothing @?= InvalidRequest, + testCase "422 -> InvalidRequest" $ classifyHttpStatus 422 Nothing @?= InvalidRequest, + testCase "500 -> TransientError" $ classifyHttpStatus 500 Nothing @?= TransientError, + testCase "502 -> TransientError" $ classifyHttpStatus 502 Nothing @?= TransientError, + testCase "503 -> TransientError" $ classifyHttpStatus 503 Nothing @?= TransientError, + testCase "418 -> OtherError" $ classifyHttpStatus 418 Nothing @?= OtherError + ] + +retryTests :: TestTree +retryTests = + testGroup + "isRetryable / retryAfterSeconds" + [ testCase "rate limited is retryable" $ + isRetryable (rateLimited (Just 30) "slow down") @?= True, + testCase "rate limited carries retry-after" $ + retryAfterSeconds (rateLimited (Just 30) "slow down") @?= Just 30, + testCase "rate limited sets httpStatus 429" $ + httpStatus (rateLimited Nothing "slow down") @?= Just 429, + testCase "invalid request is not retryable" $ + isRetryable (invalidRequest "bad shape") @?= False, + testCase "decode failure is not retryable" $ + isRetryable (decodeError "garbled") @?= False + ] + +constructorTests :: TestTree +constructorTests = + testGroup + "smart constructors" + [ testCase "processError carries exit code" $ + exitCode (processError 2 "boom") @?= Just 2, + testCase "processError category is ProcessFailure" $ + category (processError 2 "boom") @?= ProcessFailure, + testCase "invalidRequest category" $ + category (invalidRequest "x") @?= InvalidRequest, + testCase "decodeError category" $ + category (decodeError "x") @?= DecodeFailure + ] diff --git a/test/FetchModelsSpec.hs b/test/FetchModelsSpec.hs new file mode 100644 --- /dev/null +++ b/test/FetchModelsSpec.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Unit tests for the pure core of @baikai-fetch-models@ +-- ('FetchModelsCore'): filtering, curation, modality mapping, cost +-- defaulting, and rendering, exercised against a checked-in +-- models.dev-shaped fixture. No network is involved. +module FetchModelsSpec (tests) where + +import Baikai.Model (InputModality (..)) +import Data.ByteString.Lazy qualified as BSL +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Text.Encoding (decodeUtf8) +import FetchModelsCore +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, testCase, (@?=)) + +-- | Path to the fixture, relative to the @baikai@ package directory +-- (tests run with that as the working directory, as 'CatalogSpec' +-- relies on for its @src/...@ path). +fixturePath :: FilePath +fixturePath = "test/fixtures/models-dev-sample.json" + +loadUpstream :: IO (Map Text (Map Text UpstreamModel)) +loadUpstream = do + raw <- BSL.readFile fixturePath + case parseUpstream raw of + Left err -> error ("fixture parse failed: " <> err) + Right u -> pure u + +-- | Build a provider catalog from the fixture. +catalogFor :: Map Text (Map Text UpstreamModel) -> ProviderSpec -> Catalog +catalogFor upstream spec = + normalizeProvider spec (Map.findWithDefault Map.empty (psProvider spec) upstream) + +-- | Expected OpenAI catalog after normalization. @gpt-5-pro@ is +-- excluded by curation (Responses-API-only) and @gpt-legacy-nontool@ +-- by the @tool_call@ filter; models sort by id, so @gpt-5-nano@ +-- precedes @gpt-5.4@. +expectedOpenAI :: Catalog +expectedOpenAI = + Catalog + { cProvider = "openai", + cBaseUrl = "https://api.openai.com", + cApi = "openai-chat-completions", + cModels = + [ CatalogModel + { cmId = "gpt-5-nano", + cmName = "GPT-5 Nano", + cmReasoning = True, + cmInput = [InputText, InputImage], + cmCost = CatalogCost 0.05 0.4 0 0, + cmContextWindow = 400000, + cmMaxOutputTokens = 128000 + }, + CatalogModel + { cmId = "gpt-5.4", + cmName = "GPT-5.4", + cmReasoning = True, + cmInput = [InputText, InputImage], + cmCost = CatalogCost 2.5 15 0.25 0, + cmContextWindow = 1050000, + cmMaxOutputTokens = 128000 + } + ] + } + +tests :: TestTree +tests = + testGroup + "Baikai.FetchModels" + [ testCase "OpenAI normalization filters, curates, and maps fields" $ do + upstream <- loadUpstream + catalogFor upstream openaiSpec @?= expectedOpenAI, + testCase "tool_call: false model is excluded" $ do + upstream <- loadUpstream + let ids = map cmId (cModels (catalogFor upstream openaiSpec)) + assertBool "gpt-legacy-nontool must be filtered" ("gpt-legacy-nontool" `notElem` ids), + testCase "Responses-API-only id is excluded by curation" $ do + upstream <- loadUpstream + let ids = map cmId (cModels (catalogFor upstream openaiSpec)) + assertBool "gpt-5-pro must be excluded" ("gpt-5-pro" `notElem` ids), + testCase "pdf modality is dropped" $ do + upstream <- loadUpstream + let rendered = renderText (catalogFor upstream openaiSpec) + assertBool + "input renders as [\"text\", \"image\"] with no pdf" + ("\"input\": [\"text\", \"image\"]" `Text.isInfixOf` rendered) + assertBool "no pdf in rendered output" (not ("pdf" `Text.isInfixOf` rendered)), + testCase "missing cache costs default to 0.0 in rendered output" $ do + upstream <- loadUpstream + let rendered = renderText (catalogFor upstream openaiSpec) + assertBool + "cacheRead 0.0 present (gpt-5-nano default)" + ("\"cacheRead\": 0.0" `Text.isInfixOf` rendered) + assertBool + "cacheWrite 0.0 present" + ("\"cacheWrite\": 0.0" `Text.isInfixOf` rendered), + testCase "whole-number costs render with a trailing .0" $ do + upstream <- loadUpstream + let rendered = renderText (catalogFor upstream openaiSpec) + assertBool + "output 15 renders as 15.0" + ("\"output\": 15.0" `Text.isInfixOf` rendered), + testCase "Anthropic curation keeps exactly the one fixture model" $ do + upstream <- loadUpstream + let ids = map cmId (cModels (catalogFor upstream anthropicSpec)) + ids @?= ["claude-opus-4-5"] + ] + +renderText :: Catalog -> Text +renderText = decodeUtf8 . renderCatalog diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -11,11 +11,15 @@ import Data.Text qualified as Text import Data.Vector qualified as V import EmbeddingSpec qualified +import ErrorInfoSpec qualified +import ErrorSpec qualified +import FetchModelsSpec qualified import InteractiveSpec qualified import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) import TraceSpec qualified +import UsageSpec qualified -- | Ground the test provider on a 'Custom' API tag so it does not -- clash with the real Anthropic/OpenAI handlers if a future test @@ -78,8 +82,12 @@ CatalogSpec.tests, CostSpec.tests, EmbeddingSpec.tests, + ErrorInfoSpec.tests, + ErrorSpec.tests, + FetchModelsSpec.tests, InteractiveSpec.tests, - TraceSpec.tests + TraceSpec.tests, + UsageSpec.tests ] tests :: TestTree diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -3,7 +3,7 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) import Baikai.Context (Context (..), _Context) -import Baikai.Error (BaikaiError (..)) +import Baikai.Error (BaikaiError, providerError) import Baikai.Message (AssistantPayload (..), user) import Baikai.Model (Model (..), _Model) import Baikai.Options (Options, _Options) @@ -69,7 +69,8 @@ api = a, provider = "stub.trace", responseId = Nothing, - latencyMs = 0 + latencyMs = 0, + errorInfo = Nothing } registerOk :: Api -> IO () @@ -110,7 +111,7 @@ pure (), testCase "encodes failure as ErrorReason in the response" $ do let a = Custom "baikai-trace-silent-fail" - registerFail a (ProviderError "boom") + registerFail a (providerError "boom") resp <- withTrace silent (stubModel a) stubContext stubOptions let AssistantPayload {stopReason = sr, errorMessage = em} = resp ^. #message sr @?= ErrorReason @@ -142,7 +143,7 @@ memoryFailTest = testCase "memory sink records CallStarted then CallFailed on stream error" $ do let a = Custom "baikai-trace-memory-fail" - registerFail a (ProviderError "stub-failure") + registerFail a (providerError "stub-failure") (ref, sink) <- memorySink resp <- withTrace sink (stubModel a) stubContext stubOptions -- The producer-side failure surfaces as an ErrorReason on the diff --git a/test/UsageSpec.hs b/test/UsageSpec.hs new file mode 100644 --- /dev/null +++ b/test/UsageSpec.hs @@ -0,0 +1,120 @@ +module UsageSpec (tests) where + +import Baikai.Cost (Cost (..), CostBreakdown (..), _Cost, _CostBreakdown) +import Baikai.Usage (Usage (..), sumUsage, _Usage) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Baikai.Usage" + [ identityTests, + additionTests, + reasoningTests, + costTests, + sumUsageTests + ] + +-- | A non-trivial usage value for identity checks. +u0 :: Usage +u0 = + _Usage + { inputTokens = 10, + outputTokens = 5, + cacheReadTokens = 2, + cacheWriteTokens = 1, + reasoningTokens = Just 3, + totalTokens = 18, + cost = costOf 1 2 3 4 + } + +-- | Build a 'Cost' whose breakdown carries the four given USD/100 rates +-- and whose 'usd' is their sum (so the totals stay self-consistent). +costOf :: Rational -> Rational -> Rational -> Rational -> Cost +costOf i o ci cw = + Cost + { usd = (i + o + ci + cw) / 100, + breakdown = + CostBreakdown + { inputUsd = i / 100, + outputUsd = o / 100, + cachedInputUsd = ci / 100, + cachedWriteUsd = cw / 100 + } + } + +identityTests :: TestTree +identityTests = + testGroup + "monoid identity" + [ testCase "mempty <> u == u" $ (mempty <> u0) @?= u0, + testCase "u <> mempty == u" $ (u0 <> mempty) @?= u0, + testCase "mempty == _Usage" $ (mempty :: Usage) @?= _Usage + ] + +additionTests :: TestTree +additionTests = + testGroup + "field-wise addition" + [ testCase "numeric fields add" $ do + let a = _Usage {inputTokens = 10, outputTokens = 5, cacheReadTokens = 2, cacheWriteTokens = 1, totalTokens = 15} + b = _Usage {inputTokens = 3, outputTokens = 1, cacheReadTokens = 4, cacheWriteTokens = 5, totalTokens = 4} + s = a <> b + inputTokens s @?= 13 + outputTokens s @?= 6 + cacheReadTokens s @?= 6 + cacheWriteTokens s @?= 6 + totalTokens s @?= 19 + ] + +reasoningTests :: TestTree +reasoningTests = + testGroup + "reasoningTokens presence rule" + [ testCase "Just <> Nothing == Just" $ + reasoningTokens (rJust 5 <> rNothing) @?= Just 5, + testCase "Nothing <> Just == Just" $ + reasoningTokens (rNothing <> rJust 5) @?= Just 5, + testCase "Nothing <> Nothing == Nothing" $ + reasoningTokens (rNothing <> rNothing) @?= Nothing, + testCase "Just <> Just sums" $ + reasoningTokens (rJust 2 <> rJust 3) @?= Just 5 + ] + where + rJust n = _Usage {reasoningTokens = Just n} + rNothing = _Usage {reasoningTokens = Nothing} + +costTests :: TestTree +costTests = + testGroup + "cost totals add" + [ testCase "usd and breakdown add" $ do + let a = _Usage {cost = costOf 1 0 0 0} + b = _Usage {cost = costOf 2 0 0 0} + c = cost (a <> b) + usd c @?= 3 / 100 + inputUsd (breakdown c) @?= 3 / 100, + testCase "breakdown is a monoid" $ do + let s = breakdown (costOf 1 2 3 4) <> breakdown (costOf 5 6 7 8) + inputUsd s @?= 6 / 100 + outputUsd s @?= 8 / 100 + cachedInputUsd s @?= 10 / 100 + cachedWriteUsd s @?= 12 / 100, + testCase "mempty cost is zero" $ do + (mempty :: Cost) @?= _Cost + (mempty :: CostBreakdown) @?= _CostBreakdown + ] + +sumUsageTests :: TestTree +sumUsageTests = + testGroup + "sumUsage" + [ testCase "sumUsage equals chained <>" $ do + let u1 = _Usage {inputTokens = 1, totalTokens = 1} + u2 = _Usage {inputTokens = 2, totalTokens = 2} + u3 = _Usage {inputTokens = 3, totalTokens = 3} + sumUsage [u1, u2, u3] @?= (u1 <> u2 <> u3), + testCase "sumUsage [] == mempty" $ + sumUsage [] @?= (mempty :: Usage) + ]