diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,102 @@ ## [Unreleased] +## [baikai 0.3.0.0] - 2026-07-03 + +### Added + +- Added the documented record-update bases `emptyOptions`, `emptyContext`, + `emptyModel`, `emptyResponse`, `emptyTool`, `emptyTextContent`, + `emptyThinkingContent`, `emptyToolCall`, `emptyImageContent`, + `emptyEmbeddingModel`, plus zero-valued bases `zeroUsage`, `zeroCost`, + `zeroCostBreakdown`, and `zeroModelCost`. +- Added `firstEmbedding`, a total accessor for OpenAI-compatible embedding + responses. +- Added `responseError`, `errorResponse`, `httpError`, and + `parseRetryAfterSeconds` for the in-band error contract. + +### Changed + +- **Breaking:** Constructors for evolvable records are no longer exported: + `Options`, `Context`, `Model`, `OpenAICompletionsCompat`, + `AnthropicMessagesCompat`, and `InteractiveLaunchRequest` are built from + exported base values plus record updates. +- **Breaking:** The `_X` base values are deprecated in favor of the new + `empty*` and `zero*` names; the aliases remain for this release. +- **Breaking:** Removed `unModel`; use `mkModel` or `emptyModel` record + updates. +- **Breaking:** Renamed `InteractiveLaunchRequest.model` to `modelId`. +- **Breaking:** `Response.latencyMs` and trace event `latencyMs` fields are + now `Int`. +- **Breaking:** `completeRequest` / `completeRequestWith` no longer throw + `BaikaiError` for unregistered API tags; they return an error-shaped + `Response`. +- **Breaking:** CLI providers now report subprocess/decode/provider failures + in-band as error-shaped `Response`s. +- **Breaking:** `errorTerminal` now requires a `BaikaiError`, enforcing + structured error details for `EventError` construction sites. +- Documented that `Baikai.Prelude` is a convenience module outside the PVP + stability contract and that `.Internal` modules have no compatibility + guarantees. + +### Fixed + +- Empty embedding `data` arrays now produce a typed `decodeError` instead of + crashing on an empty vector. +- The model-fetch JSON renderer now delegates string escaping to aeson. +- The model generator now fails on sanitized Haskell identifier collisions + instead of rendering duplicate bindings. +- Live HTTP status, `Retry-After`, and network-failure classification now + works on both API providers. +- `content_filter` / Anthropic refusals terminate as classified `EventError` + terminals, and `liftCompleteToStream` preserves error-shaped responses. + +## [baikai-claude 0.3.0.0] - 2026-07-03 + +### Changed + +- **Breaking:** `Baikai.Provider.Claude.ErrorClass` moved to + `Baikai.Provider.Claude.Internal.ErrorClass`. +- **Breaking:** `mapRequest` and pure request-shaping helpers moved from + `Baikai.Provider.Claude.Api` to + `Baikai.Provider.Claude.Internal.Request`. +- **Breaking:** `ClaudeCliConfig` and `ClaudeInteractiveConfig` constructors + are no longer exported; start from their default config values and update + fields. +- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`. + +## [baikai-openai 0.3.0.0] - 2026-07-03 + +### Changed + +- **Breaking:** `Baikai.Provider.OpenAI.ErrorClass` moved to + `Baikai.Provider.OpenAI.Internal.ErrorClass`. +- **Breaking:** `mapRequest` and pure request-shaping helpers moved from + `Baikai.Provider.OpenAI.Api` to + `Baikai.Provider.OpenAI.Internal.Request`. +- **Breaking:** `CodexCliConfig` and `CodexInteractiveConfig` constructors are + no longer exported; start from their default config values and update fields. +- **Breaking:** CLI and interactive `extraArgs` fields are now `[Text]`. + +## [baikai-trace-otel 0.3.0.0] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. +- Adjusted to the core trace event `latencyMs :: Int` type. + +## [baikai-effectful 0.3.0.0] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. + +## [baikai-kit 0.1.0.1] - 2026-07-03 + +### Changed + +- Updated the `baikai` dependency bound to `^>=0.3.0`. + ## [baikai 0.2.0.0] - 2026-06-21 ### 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.2.0.0 +version: 0.3.0.0 synopsis: Unified Haskell interface for multiple AI providers description: baikai provides a unified, provider-agnostic Haskell interface for working @@ -91,6 +91,7 @@ import: common-options hs-source-dirs: gen main-is: GenModels.hs + other-modules: GenModelsCore build-depends: , aeson , baikai @@ -120,8 +121,10 @@ , containers , directory , filepath + , generic-lens , http-client , http-client-tls + , lens , scientific , text ^>=2.1 , vector @@ -129,18 +132,25 @@ test-suite baikai-test import: common-options type: exitcode-stdio-1.0 - hs-source-dirs: test fetch + hs-source-dirs: test fetch gen main-is: Main.hs other-modules: AgentAssetsSpec CatalogSpec + CliInternalSpec + ContextSpec CostSpec EmbeddingSpec ErrorInfoSpec ErrorSpec FetchModelsCore FetchModelsSpec + GenModelsCore + GenModelsSpec + HelpersSpec InteractiveSpec + StreamSpec + SurfaceSpec TraceSpec UsageSpec @@ -153,13 +163,17 @@ , containers , directory , filepath + , generic-lens + , lens , openai , process , scientific , stm - , streamly-core >=0.3 && <0.5 + , streamly-core >=0.3 && <0.5 , tasty , tasty-hunit + , tasty-quickcheck , temporary , text + , time , vector diff --git a/fetch/FetchModels.hs b/fetch/FetchModels.hs --- a/fetch/FetchModels.hs +++ b/fetch/FetchModels.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Executable @baikai-fetch-models@: refresh baikai's catalog JSON -- from upstream sources (primarily @https:\/\/models.dev\/api.json@). -- @@ -33,12 +30,13 @@ -- writing). module FetchModels (main, fetchUpstream) where +import Baikai.Prelude import Control.Exception (catch) import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL +import Data.Generics.Labels () 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) @@ -47,6 +45,7 @@ import System.Environment (getArgs) import System.Exit (die) import System.FilePath (takeDirectory, ()) +import System.IO (hPutStrLn, stderr) -- | Which provider(s) to emit. data ProviderSel = SelOpenAI | SelAnthropic | SelAll @@ -54,21 +53,22 @@ -- | Parsed command-line options. data Options = Options - { optFromUrl :: !String, - optFromFile :: !(Maybe FilePath), - optOutDir :: !(Maybe FilePath), - optProvider :: !ProviderSel, - optStdout :: !Bool + { fromUrl :: !String, + fromFile :: !(Maybe FilePath), + outDir :: !(Maybe FilePath), + provider :: !ProviderSel, + stdout :: !Bool } + deriving stock (Generic) defaultOptions :: Options defaultOptions = Options - { optFromUrl = "https://models.dev/api.json", - optFromFile = Nothing, - optOutDir = Nothing, - optProvider = SelAll, - optStdout = False + { fromUrl = "https://models.dev/api.json", + fromFile = Nothing, + outDir = Nothing, + provider = SelAll, + stdout = False } main :: IO () @@ -79,26 +79,28 @@ 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 + let catalogs = + map (applyOverrides overrides . catalogFor upstream) (selectedSpecs (opts ^. #provider)) + mapM_ warnStale (staleOverrides overrides catalogs) + if opts ^. #stdout then mapM_ (BS.putStr . renderCatalog) catalogs else do - outDir <- resolveOutDir (optOutDir opts) - mapM_ (writeCatalog outDir) catalogs + dir <- resolveOutDir (opts ^. #outDir) + mapM_ (writeCatalog dir) 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 +loadUpstreamBytes opts = case opts ^. #fromFile of Just path -> BSL.readFile path Nothing -> - fetchUpstream (optFromUrl opts) + fetchUpstream (opts ^. #fromUrl) `catch` \e -> die $ "baikai-fetch-models: failed to fetch " - <> optFromUrl opts + <> opts ^. #fromUrl <> ": " <> show (e :: HttpException) @@ -111,21 +113,32 @@ req <- parseUrlThrow url responseBody <$> httpLbs req manager +-- | Warn (to stderr, without failing) about an override that matched +-- no fetched model, so stale corrections get noticed. +warnStale :: (Text, Text) -> IO () +warnStale (prov, mid) = + hPutStrLn stderr $ + "baikai-fetch-models: warning: override for (" + <> Text.unpack prov + <> ", " + <> Text.unpack mid + <> ") matched no fetched model (stale?)" + -- | 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) + normalizeProvider spec (Map.findWithDefault Map.empty (spec ^. #provider) 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") + let path = dir (Text.unpack (cat ^. #provider) <> ".json") BS.writeFile path (renderCatalog cat) putStrLn $ - "Wrote " <> path <> " (" <> show (length (cModels cat)) <> " models)" + "Wrote " <> path <> " (" <> show (length (cat ^. #models)) <> " models)" -- | The provider specs selected by @--provider@. selectedSpecs :: ProviderSel -> [ProviderSpec] @@ -172,13 +185,13 @@ 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 ("--from-url" : v : rest) = go (o & #fromUrl .~ v) rest + go o ("--from-file" : v : rest) = go (o & #fromFile ?~ v) rest + go o ("--out-dir" : v : rest) = go (o & #outDir ?~ 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 (o & #provider .~ sel) rest + go o ("--stdout" : rest) = go (o & #stdout .~ True) rest go _ (a : _) = die $ "baikai-fetch-models: unknown argument " <> show a parseProvider :: String -> IO ProviderSel diff --git a/fetch/FetchModelsCore.hs b/fetch/FetchModelsCore.hs --- a/fetch/FetchModelsCore.hs +++ b/fetch/FetchModelsCore.hs @@ -1,6 +1,3 @@ -{-# 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 @@ -20,6 +17,21 @@ -- @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. +-- +-- == Override philosophy +-- +-- models.dev is not fully trustworthy, so a small, explicit override +-- layer ('overrides') is applied after normalization. Each entry is a +-- per-@(provider, modelId)@ correction that overwrites only the fields +-- it sets, and each MUST carry a dated comment justifying why upstream +-- is wrong (mirroring pi-mono's @generate-models.ts@). Keep the table +-- minimal: prefer fixing upstream or curating ids out over piling on +-- overrides. Overrides that match no fetched model are warned about +-- ('staleOverrides') rather than silently kept. +-- +-- Records follow the project convention: no field prefixes; field +-- access and updates go through generic-lens @#label@ optics rather +-- than bare selectors or record-update syntax. module FetchModelsCore ( -- * Upstream shape (subset of models.dev fields we consume) UpstreamModel (..), @@ -38,16 +50,26 @@ anthropicInclude, normalizeProvider, + -- * Override layer + Override (..), + emptyOverride, + overrides, + applyOverrides, + staleOverrides, + -- * Rendering renderCatalog, ) where import Baikai.Model (InputModality (..)) -import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) -import Data.Aeson qualified as Aeson +import Baikai.Prelude +import Data.Aeson (Value (String), eitherDecode, encode, withObject, (.!=), (.:), (.:?)) +import Data.Aeson.Types (Parser) import Data.ByteString (ByteString) import Data.ByteString.Lazy qualified as BSL +import Data.ByteString.Lazy qualified as LBS +import Data.Generics.Labels () import Data.List (sortOn) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map @@ -55,9 +77,8 @@ 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) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) -- * Upstream shape ---------------------------------------------------- @@ -65,64 +86,66 @@ -- 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] + { modelId :: !Text, + name :: !(Maybe Text), + toolCall :: !Bool, + reasoning :: !Bool, + contextWindow :: !(Maybe Integer), + maxOutputTokens :: !(Maybe Integer), + inputCost :: !(Maybe Scientific), + outputCost :: !(Maybe Scientific), + cacheReadCost :: !(Maybe Scientific), + cacheWriteCost :: !(Maybe Scientific), + inputModalities :: ![Text] } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) 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" + parseJSON = withObject "UpstreamModel" $ \o -> do + mid <- o .: "id" + nm <- o .:? "name" + tc <- o .:? "tool_call" .!= False + rs <- o .:? "reasoning" .!= False + lim <- o .:? "limit" :: Parser (Maybe Limit) + cst <- o .:? "cost" :: Parser (Maybe Cost) + mods <- o .:? "modalities" :: Parser (Maybe 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 + { modelId = mid, + name = nm, + toolCall = tc, + reasoning = rs, + contextWindow = lim >>= (^. #context), + maxOutputTokens = lim >>= (^. #output), + inputCost = cst >>= (^. #input), + outputCost = cst >>= (^. #output), + cacheReadCost = cst >>= (^. #cacheRead), + cacheWriteCost = cst >>= (^. #cacheWrite), + inputModalities = maybe [] (^. #input) mods } -- | @limit@ sub-object. data Limit = Limit - { limitContext :: !(Maybe Integer), - limitOutput :: !(Maybe Integer) + { context :: !(Maybe Integer), + output :: !(Maybe Integer) } + deriving stock (Show, Generic) instance FromJSON Limit where - parseJSON = Aeson.withObject "limit" $ \o -> + parseJSON = 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) + { input :: !(Maybe Scientific), + output :: !(Maybe Scientific), + cacheRead :: !(Maybe Scientific), + cacheWrite :: !(Maybe Scientific) } + deriving stock (Show, Generic) instance FromJSON Cost where - parseJSON = Aeson.withObject "cost" $ \o -> + parseJSON = withObject "cost" $ \o -> Cost <$> o .:? "input" <*> o .:? "output" @@ -130,58 +153,62 @@ <*> o .:? "cache_write" -- | @modalities@ sub-object; we only read @input@. -newtype Modalities = Modalities {modalitiesInput :: [Text]} +newtype Modalities = Modalities {input :: [Text]} + deriving stock (Show, Generic) instance FromJSON Modalities where - parseJSON = Aeson.withObject "modalities" $ \o -> + parseJSON = 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} +newtype UpstreamProvider = UpstreamProvider {models :: Map Text UpstreamModel} + deriving stock (Generic) instance FromJSON UpstreamProvider where - parseJSON = Aeson.withObject "UpstreamProvider" $ \o -> + parseJSON = 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 +parseUpstream bs = + Map.map (^. #models) <$> (eitherDecode bs :: Either String (Map Text UpstreamProvider)) -- * Output catalog shape --------------------------------------------- --- | Per-million-token cost rates, in the catalog's field names. +-- | Per-million-token cost rates, named to mirror +-- 'Baikai.Model.ModelCost'. data CatalogCost = CatalogCost - { ccInput :: !Scientific, - ccOutput :: !Scientific, - ccCacheRead :: !Scientific, - ccCacheWrite :: !Scientific + { inputCost :: !Scientific, + outputCost :: !Scientific, + cacheReadCost :: !Scientific, + cacheWriteCost :: !Scientific } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) -- | 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 + { modelId :: !Text, + name :: !Text, + reasoning :: !Bool, + input :: ![InputModality], + cost :: !CatalogCost, + contextWindow :: !Integer, + maxOutputTokens :: !Integer } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) -- | A whole catalog file: one provider and its curated models. data Catalog = Catalog - { cProvider :: !Text, - cBaseUrl :: !Text, - cApi :: !Text, - cModels :: ![CatalogModel] + { provider :: !Text, + baseUrl :: !Text, + api :: !Text, + models :: ![CatalogModel] } - deriving stock (Eq, Show) + deriving stock (Eq, Show, Generic) -- * Provider specs and normalization --------------------------------- @@ -189,11 +216,12 @@ -- catalog and the curation predicate selecting which upstream model -- ids to keep. data ProviderSpec = ProviderSpec - { psProvider :: !Text, - psBaseUrl :: !Text, - psApi :: !Text, - psInclude :: !(Text -> Bool) + { provider :: !Text, + baseUrl :: !Text, + api :: !Text, + include :: !(Text -> Bool) } + deriving stock (Generic) -- | Curation include set for OpenAI: the chat-completions-compatible -- current line. Responses-API-only ids (@*-pro@, @*-codex@, @@ -239,20 +267,20 @@ openaiSpec :: ProviderSpec openaiSpec = ProviderSpec - { psProvider = "openai", - psBaseUrl = "https://api.openai.com", - psApi = "openai-chat-completions", - psInclude = (`Set.member` openaiInclude) + { provider = "openai", + baseUrl = "https://api.openai.com", + api = "openai-chat-completions", + include = (`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) + { provider = "anthropic", + baseUrl = "https://api.anthropic.com", + api = "anthropic-messages", + include = (`Set.member` anthropicInclude) } -- | Normalize one provider's upstream models into a 'Catalog'. Keeps @@ -263,38 +291,158 @@ 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) + { provider = spec ^. #provider, + baseUrl = spec ^. #baseUrl, + api = spec ^. #api, + models = sortOn (^. #modelId) (map toCatalogModel kept) } where kept = [ m | m <- Map.elems upstream, - uToolCall m, - psInclude spec (uId m) + m ^. #toolCall, + (spec ^. #include) (m ^. #modelId) ] toCatalogModel m = CatalogModel - { cmId = uId m, - cmName = fromMaybe (uId m) (uName m), - cmReasoning = uReasoning m, - cmInput = - if "image" `elem` uInputMods m + { modelId = m ^. #modelId, + name = normalizeName (fromMaybe (m ^. #modelId) (m ^. #name)), + reasoning = m ^. #reasoning, + input = + if "image" `elem` (m ^. #inputModalities) then [InputText, InputImage] else [InputText], - cmCost = + cost = CatalogCost - { ccInput = fromMaybe 0 (uCostIn m), - ccOutput = fromMaybe 0 (uCostOut m), - ccCacheRead = fromMaybe 0 (uCacheRead m), - ccCacheWrite = fromMaybe 0 (uCacheWrite m) + { inputCost = fromMaybe 0 (m ^. #inputCost), + outputCost = fromMaybe 0 (m ^. #outputCost), + cacheReadCost = fromMaybe 0 (m ^. #cacheReadCost), + cacheWriteCost = fromMaybe 0 (m ^. #cacheWriteCost) }, - cmContextWindow = fromMaybe 0 (uCtx m), - cmMaxOutputTokens = fromMaybe 0 (uMaxOut m) + contextWindow = fromMaybe 0 (m ^. #contextWindow), + maxOutputTokens = fromMaybe 0 (m ^. #maxOutputTokens) } +-- | Strip a trailing @" (latest)"@ display-name suffix that models.dev +-- attaches to the "latest" aliases (e.g. @"Claude Opus 4.5 (latest)"@). +-- This is a systematic upstream wart, so it is normalized for every +-- provider rather than via a per-model override. +normalizeName :: Text -> Text +normalizeName n = fromMaybe n (Text.stripSuffix " (latest)" n) + +-- * Override layer ---------------------------------------------------- + +-- | A hand-maintained correction for one @(provider, modelId)@ pair. +-- Every field except the key is a @Maybe@: 'Nothing' leaves the +-- normalized value untouched, 'Just' overwrites it. Build entries from +-- 'emptyOverride' and set only the fields that need correcting. +data Override = Override + { provider :: !Text, + modelId :: !Text, + name :: !(Maybe Text), + reasoning :: !(Maybe Bool), + inputCost :: !(Maybe Scientific), + outputCost :: !(Maybe Scientific), + cacheReadCost :: !(Maybe Scientific), + cacheWriteCost :: !(Maybe Scientific), + contextWindow :: !(Maybe Integer), + maxOutputTokens :: !(Maybe Integer) + } + deriving stock (Eq, Show, Generic) + +-- | An override that changes nothing, keyed by provider and model id. +emptyOverride :: Text -> Text -> Override +emptyOverride prov mid = + Override + { provider = prov, + modelId = mid, + name = Nothing, + reasoning = Nothing, + inputCost = Nothing, + outputCost = Nothing, + cacheReadCost = Nothing, + cacheWriteCost = Nothing, + contextWindow = Nothing, + maxOutputTokens = Nothing + } + +-- | The hand-maintained correction table, applied after normalization. +-- Each entry MUST carry a dated comment explaining why upstream is +-- wrong, exactly as pi-mono's @generate-models.ts@ documents its +-- corrections. Order does not matter; entries are keyed by +-- @(provider, modelId)@. +overrides :: [Override] +overrides = + [ -- 2026-06-21: models.dev has periodically reported Claude Opus + -- cache_read at 3x the published rate (1.5 instead of 0.5 /Mtok) — + -- the same wart pi-mono hard-corrects in generate-models.ts + -- ("models.dev has 3x the correct pricing"). Pin cache_read to + -- Anthropic's published 0.5 so an upstream regression cannot + -- silently inflate cached-input cost. + emptyOverride "anthropic" "claude-opus-4-5" & #cacheReadCost ?~ 0.5 + ] + +-- | Apply all overrides matching this catalog's provider to its +-- models. A model with no matching override is returned unchanged. +applyOverrides :: [Override] -> Catalog -> Catalog +applyOverrides ovs cat = cat & #models %~ map applyMatching + where + prov = cat ^. #provider + byKey = + Map.fromList + [((o ^. #provider, o ^. #modelId), o) | o <- ovs] + applyMatching m = + maybe m (`applyOne` m) (Map.lookup (prov, m ^. #modelId) byKey) + +-- | Overwrite each 'CatalogModel' field for which the override carries +-- a 'Just'. 'Nothing' fields are left as normalized. +applyOne :: Override -> CatalogModel -> CatalogModel +applyOne o m = + m + & #name + %~ overwrite (o ^. #name) + & #reasoning + %~ overwrite (o ^. #reasoning) + & #cost + . #inputCost + %~ overwrite (o ^. #inputCost) + & #cost + . #outputCost + %~ overwrite (o ^. #outputCost) + & #cost + . #cacheReadCost + %~ overwrite (o ^. #cacheReadCost) + & #cost + . #cacheWriteCost + %~ overwrite (o ^. #cacheWriteCost) + & #contextWindow + %~ overwrite (o ^. #contextWindow) + & #maxOutputTokens + %~ overwrite (o ^. #maxOutputTokens) + where + overwrite :: Maybe a -> a -> a + overwrite = maybe id const + +-- | Override keys @(provider, modelId)@ that match no model in any of +-- the given catalogs (restricted to providers actually present, so an +-- override for an unfetched provider is not falsely flagged). The tool +-- warns on these so stale overrides get noticed without failing. +staleOverrides :: [Override] -> [Catalog] -> [(Text, Text)] +staleOverrides ovs cats = + [ (o ^. #provider, o ^. #modelId) + | o <- ovs, + (o ^. #provider) `Set.member` provs, + (o ^. #provider, o ^. #modelId) `Set.notMember` present + ] + where + provs = Set.fromList (map (^. #provider) cats) + present = + Set.fromList + [ (cat ^. #provider, m ^. #modelId) + | cat <- cats, + m <- cat ^. #models + ] + -- * Rendering --------------------------------------------------------- -- | Render a 'Catalog' as catalog JSON, byte-for-byte in the style of @@ -307,12 +455,12 @@ renderLines :: Catalog -> [Text] renderLines cat = ["{"] - ++ [ " \"provider\": " <> jsonString (cProvider cat) <> ",", - " \"baseUrl\": " <> jsonString (cBaseUrl cat) <> ",", - " \"api\": " <> jsonString (cApi cat) <> ",", + ++ [ " \"provider\": " <> jsonString (cat ^. #provider) <> ",", + " \"baseUrl\": " <> jsonString (cat ^. #baseUrl) <> ",", + " \"api\": " <> jsonString (cat ^. #api) <> ",", " \"compat\": \"auto\"," ] - ++ modelsSection (cModels cat) + ++ modelsSection (cat ^. #models) ++ ["}"] modelsSection :: [CatalogModel] -> [Text] @@ -336,23 +484,23 @@ renderModel :: CatalogModel -> [Text] renderModel m = [ " {", - " \"id\": " <> jsonString (cmId m) <> ",", - " \"name\": " <> jsonString (cmName m) <> ",", - " \"reasoning\": " <> jsonBool (cmReasoning m) <> ",", - " \"input\": " <> renderInput (cmInput m) <> ",", + " \"id\": " <> jsonString (m ^. #modelId) <> ",", + " \"name\": " <> jsonString (m ^. #name) <> ",", + " \"reasoning\": " <> jsonBool (m ^. #reasoning) <> ",", + " \"input\": " <> renderInput (m ^. #input) <> ",", " \"cost\": {", - " \"input\": " <> renderNum (ccInput c) <> ",", - " \"output\": " <> renderNum (ccOutput c) <> ",", - " \"cacheRead\": " <> renderNum (ccCacheRead c) <> ",", - " \"cacheWrite\": " <> renderNum (ccCacheWrite c), + " \"input\": " <> renderNum (c ^. #inputCost) <> ",", + " \"output\": " <> renderNum (c ^. #outputCost) <> ",", + " \"cacheRead\": " <> renderNum (c ^. #cacheReadCost) <> ",", + " \"cacheWrite\": " <> renderNum (c ^. #cacheWriteCost), " },", - " \"contextWindow\": " <> Text.pack (show (cmContextWindow m)) <> ",", - " \"maxOutputTokens\": " <> Text.pack (show (cmMaxOutputTokens m)) <> ",", + " \"contextWindow\": " <> Text.pack (show (m ^. #contextWindow)) <> ",", + " \"maxOutputTokens\": " <> Text.pack (show (m ^. #maxOutputTokens)) <> ",", " \"enabled\": true", " }" ] where - c = cmCost m + c = m ^. #cost renderInput :: [InputModality] -> Text renderInput ms = "[" <> Text.intercalate ", " (map one ms) <> "]" @@ -370,8 +518,7 @@ 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). +-- | Render a 'Text' as a JSON string literal. Delegate escaping to aeson so +-- control characters, quotes, and backslashes follow the JSON encoder exactly. jsonString :: Text -> Text -jsonString t = - "\"" <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" t) <> "\"" +jsonString = decodeUtf8 . LBS.toStrict . encode . String diff --git a/gen/GenModels.hs b/gen/GenModels.hs --- a/gen/GenModels.hs +++ b/gen/GenModels.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedRecordDot #-} {-# LANGUAGE OverloadedStrings #-} -- | Generator executable that reads JSON catalog files from @@ -29,29 +27,17 @@ -- (enforced by @CatalogSpec@ in @baikai\/test\/@). module Main (main) where -import Baikai.Api (Api (..), parseApi) -import Baikai.Compat - ( AnthropicMessagesCompat (..), - CacheControlFormat (..), - MaxTokensField (..), - OpenAICompletionsCompat (..), - ThinkingFormat (..), - defaultAnthropicMessagesCompat, - defaultOpenAICompletionsCompat, - ) -import Baikai.Model (InputModality (..)) import Control.Monad (forM) -import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) import Data.Aeson qualified as Aeson -import Data.Aeson.Types (Parser, typeMismatch) import Data.ByteString.Lazy qualified as BSL import Data.List (sort, sortOn) -import Data.Ratio (denominator, numerator) -import Data.Scientific (Scientific) -import Data.Text (Text) import Data.Text qualified as Text import Data.Text.IO qualified as TIO -import Numeric.Natural (Natural) +import GenModelsCore + ( checkIdentifierCollisions, + flattenEntries, + renderModule, + ) import System.Directory (doesFileExist, getCurrentDirectory, listDirectory) import System.Environment (getArgs) import System.Exit (die) @@ -69,7 +55,10 @@ Left err -> die $ f <> ": " <> err Right c -> pure c let allEntries = concatMap flattenEntries catalogs - sorted = sortOn fst allEntries + case checkIdentifierCollisions allEntries of + Left err -> die (Text.unpack err) + Right () -> pure () + let sorted = sortOn fst allEntries rendered = renderModule sorted TIO.writeFile outputPath rendered putStrLn $ @@ -134,391 +123,3 @@ listCatalogFiles dir = do entries <- listDirectory dir pure $ sort [f | f <- entries, takeExtension f == ".json"] - --- * Catalog data types ----------------------------------------------- - --- | One catalog file, in source form. -data CatalogFile = CatalogFile - { provider :: !Text, - baseUrl :: !Text, - api :: !Api, - compat :: !CatalogCompat, - models :: ![ModelEntry] - } - -instance FromJSON CatalogFile where - parseJSON = Aeson.withObject "CatalogFile" $ \o -> - CatalogFile - <$> o .: "provider" - <*> o .: "baseUrl" - <*> (parseApi <$> o .: "api") - <*> o .: "compat" - <*> o .: "models" - --- | A compat directive in the catalog. @"auto"@ defers to EP-5's --- @baseUrl@-driven auto-detection (rendered as 'CompatNone'). The two --- structured constructors carry a full override record. -data CatalogCompat - = CatalogCompatAuto - | CatalogCompatOpenAI !OpenAICompletionsCompat - | CatalogCompatAnthropic !AnthropicMessagesCompat - deriving stock (Show) - -instance FromJSON CatalogCompat where - parseJSON = \case - Aeson.String "auto" -> pure CatalogCompatAuto - Aeson.Object o -> do - kind <- o .: "kind" :: Parser Text - case kind of - "openai-completions" -> - CatalogCompatOpenAI <$> parseOpenAICompat o - "anthropic-messages" -> - CatalogCompatAnthropic <$> parseAnthropicCompat o - _ -> - fail $ "CatalogCompat: unknown kind " <> show kind - v -> typeMismatch "CatalogCompat (expected \"auto\" or {\"kind\": ...})" v - -parseOpenAICompat :: Aeson.Object -> Parser OpenAICompletionsCompat -parseOpenAICompat o = do - let d = defaultOpenAICompletionsCompat - mtf <- optionalField o "maxTokensField" parseMaxTokensField (maxTokensField d) - sdr <- o .:? "supportsDeveloperRole" .!= supportsDeveloperRole d - sst <- o .:? "supportsStrictMode" .!= supportsStrictMode d - rtat <- o .:? "requiresThinkingAsText" .!= requiresThinkingAsText d - tf <- optionalField o "thinkingFormat" parseThinkingFormat (thinkingFormat d) - ccf <- optionalMaybeField o "cacheControlFormat" parseCacheControlFormat (cacheControlFormat d) - sus <- o .:? "supportsUsageInStreaming" .!= d.supportsUsageInStreaming - slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention - pure - OpenAICompletionsCompat - { maxTokensField = mtf, - supportsDeveloperRole = sdr, - supportsStrictMode = sst, - requiresThinkingAsText = rtat, - thinkingFormat = tf, - cacheControlFormat = ccf, - supportsUsageInStreaming = sus, - supportsLongCacheRetention = slcr - } - -parseAnthropicCompat :: Aeson.Object -> Parser AnthropicMessagesCompat -parseAnthropicCompat o = do - let d = defaultAnthropicMessagesCompat - slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention - scot <- o .:? "supportsCacheControlOnTools" .!= d.supportsCacheControlOnTools - seti <- o .:? "supportsEagerToolInputStreaming" .!= d.supportsEagerToolInputStreaming - ssah <- o .:? "sendSessionAffinityHeaders" .!= d.sendSessionAffinityHeaders - pure - AnthropicMessagesCompat - { supportsLongCacheRetention = slcr, - supportsCacheControlOnTools = scot, - supportsEagerToolInputStreaming = seti, - sendSessionAffinityHeaders = ssah - } - -parseMaxTokensField :: Text -> Parser MaxTokensField -parseMaxTokensField = \case - "max_tokens" -> pure MaxTokensField - "max_completion_tokens" -> pure MaxCompletionTokensField - t -> fail $ "unknown maxTokensField: " <> Text.unpack t - -parseThinkingFormat :: Text -> Parser ThinkingFormat -parseThinkingFormat = \case - "openai" -> pure ThinkingFormatOpenAI - "openrouter" -> pure ThinkingFormatOpenRouter - "deepseek" -> pure ThinkingFormatDeepseek - "together" -> pure ThinkingFormatTogether - "zai" -> pure ThinkingFormatZai - "qwen" -> pure ThinkingFormatQwen - "none" -> pure ThinkingFormatNone - t -> fail $ "unknown thinkingFormat: " <> Text.unpack t - -parseCacheControlFormat :: Text -> Parser CacheControlFormat -parseCacheControlFormat = \case - "anthropic" -> pure CacheControlFormatAnthropic - t -> fail $ "unknown cacheControlFormat: " <> Text.unpack t - --- | Look up an optional field; missing returns @def@. -optionalField :: Aeson.Object -> Aeson.Key -> (Text -> Parser a) -> a -> Parser a -optionalField o key parser def = do - mv <- o .:? key - case mv of - Nothing -> pure def - Just v -> parser v - --- | Look up an optional @Maybe@-typed field. JSON @null@ or absence --- yields @def@; otherwise the value is parsed through @parser@ and --- wrapped in 'Just'. -optionalMaybeField :: - Aeson.Object -> - Aeson.Key -> - (Text -> Parser a) -> - Maybe a -> - Parser (Maybe a) -optionalMaybeField o key parser def = do - mv <- o .:? key - case mv of - Nothing -> pure def - Just Aeson.Null -> pure Nothing - Just (Aeson.String t) -> Just <$> parser t - Just v -> typeMismatch "string or null" v - --- | One model row in a catalog file. -data ModelEntry = ModelEntry - { entryId :: !Text, - entryName :: !Text, - entryReasoning :: !Bool, - entryInput :: ![InputModality], - entryCost :: !CostEntry, - entryContextWindow :: !Natural, - entryMaxOutputTokens :: !Natural, - entryEnabled :: !Bool, - entryCompatOverride :: !(Maybe CatalogCompat) - } - -instance FromJSON ModelEntry where - parseJSON = Aeson.withObject "ModelEntry" $ \o -> - ModelEntry - <$> o .: "id" - <*> o .: "name" - <*> o .:? "reasoning" .!= False - <*> (o .: "input" >>= traverse parseInputModality) - <*> o .: "cost" - <*> o .: "contextWindow" - <*> o .: "maxOutputTokens" - <*> o .:? "enabled" .!= True - <*> o .:? "compat" - -parseInputModality :: Text -> Parser InputModality -parseInputModality = \case - "text" -> pure InputText - "image" -> pure InputImage - t -> fail $ "unknown input modality: " <> Text.unpack t - --- | Per-million-token cost rates. Parsed as 'Scientific' so the --- round-trip into 'Rational' produces a small, canonical fraction --- (@1.5@ → @3 % 2@) rather than an arbitrary IEEE-754 approximation. -data CostEntry = CostEntry - { costInput :: !Scientific, - costOutput :: !Scientific, - costCacheRead :: !Scientific, - costCacheWrite :: !Scientific - } - -instance FromJSON CostEntry where - parseJSON = Aeson.withObject "CostEntry" $ \o -> - CostEntry - <$> o .: "input" - <*> o .: "output" - <*> o .:? "cacheRead" .!= 0 - <*> o .:? "cacheWrite" .!= 0 - --- * Flattening --------------------------------------------------------- - --- | One generated Haskell identifier plus the 'Model'-shaped record --- it should be rendered as. Keeping these together lets the renderer --- stay a pure transformation over a flat list. -data GeneratedEntry = GeneratedEntry - { genIdent :: !Text, - genModelId :: !Text, - genName :: !Text, - genApi :: !Api, - genProvider :: !Text, - genBaseUrl :: !Text, - genReasoning :: !Bool, - genInput :: ![InputModality], - genCost :: !CostEntry, - genContextWindow :: !Natural, - genMaxOutputTokens :: !Natural, - genCompat :: !CatalogCompat - } - -flattenEntries :: CatalogFile -> [(Text, GeneratedEntry)] -flattenEntries c = - [ (genIdent g, g) - | m <- models c, - entryEnabled m, - let g = - GeneratedEntry - { genIdent = - sanitizeIdentifier (provider c <> "_" <> entryId m), - genModelId = entryId m, - genName = entryName m, - genApi = api c, - genProvider = provider c, - genBaseUrl = baseUrl c, - genReasoning = entryReasoning m, - genInput = entryInput m, - genCost = entryCost m, - genContextWindow = entryContextWindow m, - genMaxOutputTokens = entryMaxOutputTokens m, - genCompat = - case entryCompatOverride m of - Just c' -> c' - Nothing -> compat c - } - ] - --- | Replace any non-identifier character with @_@. Haskell allows --- letters, digits, underscore, and apostrophe; everything else --- (slash, dash, dot, colon, …) becomes an underscore. -sanitizeIdentifier :: Text -> Text -sanitizeIdentifier = Text.map replace - where - replace c - | (c >= 'a' && c <= 'z') - || (c >= 'A' && c <= 'Z') - || (c >= '0' && c <= '9') - || c == '_' - || c == '\'' = - c - | otherwise = '_' - --- * Source rendering -------------------------------------------------- - -renderModule :: [(Text, GeneratedEntry)] -> Text -renderModule entries = - Text.unlines - ( header - ++ concatMap (renderEntry . snd) entries - ) - where - header = - [ "-- AUTO-GENERATED by baikai-gen-models. Do not edit by hand.", - "-- Regenerate with: cabal run baikai-gen-models", - "{-# LANGUAGE OverloadedStrings #-}", - "{-# OPTIONS_GHC -Wno-missing-export-lists #-}", - "{-# OPTIONS_GHC -Wno-unused-imports #-}", - "", - "module Baikai.Models.Generated where", - "", - "import Baikai.Api (Api (..))", - "import Baikai.Compat", - " ( AnthropicMessagesCompat (..)", - " , CacheControlFormat (..)", - " , MaxTokensField (..)", - " , OpenAICompletionsCompat (..)", - " , ThinkingFormat (..)", - " )", - "import Baikai.Model", - " ( Compat (..)", - " , InputModality (..)", - " , Model (..)", - " , ModelCost (..)", - " )", - "import Data.Map.Strict qualified as Map", - "import Data.Ratio ((%))", - "" - ] - -renderEntry :: GeneratedEntry -> [Text] -renderEntry g = - [ genIdent g <> " :: Model", - genIdent g <> " =", - " Model", - " { modelId = " <> renderText (genModelId g), - " , name = " <> renderText (genName g), - " , api = " <> renderApiCtor (genApi g), - " , provider = " <> renderText (genProvider g), - " , baseUrl = " <> renderText (genBaseUrl g), - " , reasoning = " <> renderBool (genReasoning g), - " , input = " <> renderInputList (genInput g), - " , cost = " <> renderCost (genCost g), - " , contextWindow = " <> Text.pack (show (genContextWindow g)), - " , maxOutputTokens = " <> Text.pack (show (genMaxOutputTokens g)), - " , headers = Map.empty", - " , compat = " <> renderCompat (genCompat g), - " }", - "" - ] - -renderText :: Text -> Text -renderText t = - "\"" - <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" t) - <> "\"" - -renderBool :: Bool -> Text -renderBool True = "True" -renderBool False = "False" - -renderInputList :: [InputModality] -> Text -renderInputList ms = - "[" <> Text.intercalate ", " (map renderInput ms) <> "]" - where - renderInput InputText = "InputText" - renderInput InputImage = "InputImage" - -renderApiCtor :: Api -> Text -renderApiCtor = \case - OpenAIChatCompletions -> "OpenAIChatCompletions" - AnthropicMessages -> "AnthropicMessages" - OpenAICompletionsCli -> "OpenAICompletionsCli" - AnthropicMessagesCli -> "AnthropicMessagesCli" - Custom t -> "Custom " <> renderText t - -renderCost :: CostEntry -> Text -renderCost c = - Text.intercalate - "\n" - [ "ModelCost", - " { inputCost = " <> renderRational (toRational (costInput c)), - " , outputCost = " <> renderRational (toRational (costOutput c)), - " , cacheReadCost = " <> renderRational (toRational (costCacheRead c)), - " , cacheWriteCost = " <> renderRational (toRational (costCacheWrite c)), - " }" - ] - -renderRational :: Rational -> Text -renderRational r = - Text.pack (show (numerator r)) <> " % " <> Text.pack (show (denominator r)) - -renderCompat :: CatalogCompat -> Text -renderCompat = \case - CatalogCompatAuto -> "CompatNone" - CatalogCompatOpenAI c -> - Text.intercalate - "\n" - [ "CompatOpenAICompletions", - " OpenAICompletionsCompat", - " { maxTokensField = " <> renderMaxTokensField c.maxTokensField, - " , supportsDeveloperRole = " <> renderBool c.supportsDeveloperRole, - " , supportsStrictMode = " <> renderBool c.supportsStrictMode, - " , requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText, - " , thinkingFormat = " <> renderThinkingFormat c.thinkingFormat, - " , cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat, - " , supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming, - " , supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, - " }" - ] - CatalogCompatAnthropic c -> - Text.intercalate - "\n" - [ "CompatAnthropicMessages", - " AnthropicMessagesCompat", - " { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, - " , supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools, - " , supportsEagerToolInputStreaming = " <> renderBool c.supportsEagerToolInputStreaming, - " , sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders, - " }" - ] - -renderMaxTokensField :: MaxTokensField -> Text -renderMaxTokensField = \case - MaxCompletionTokensField -> "MaxCompletionTokensField" - MaxTokensField -> "MaxTokensField" - -renderThinkingFormat :: ThinkingFormat -> Text -renderThinkingFormat = \case - ThinkingFormatOpenAI -> "ThinkingFormatOpenAI" - ThinkingFormatOpenRouter -> "ThinkingFormatOpenRouter" - ThinkingFormatDeepseek -> "ThinkingFormatDeepseek" - ThinkingFormatTogether -> "ThinkingFormatTogether" - ThinkingFormatZai -> "ThinkingFormatZai" - ThinkingFormatQwen -> "ThinkingFormatQwen" - ThinkingFormatNone -> "ThinkingFormatNone" - -renderMaybeCacheControl :: Maybe CacheControlFormat -> Text -renderMaybeCacheControl = \case - Nothing -> "Nothing" - Just CacheControlFormatAnthropic -> "Just CacheControlFormatAnthropic" diff --git a/gen/GenModelsCore.hs b/gen/GenModelsCore.hs new file mode 100644 --- /dev/null +++ b/gen/GenModelsCore.hs @@ -0,0 +1,490 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Pure core for @baikai-gen-models@: parse catalog JSON, flatten enabled +-- entries, reject generated identifier collisions, and render the generated +-- Haskell module. The executable wrapper owns only argument parsing, file IO, +-- and default path resolution. +module GenModelsCore + ( CatalogFile (..), + CatalogCompat (..), + ModelEntry (..), + CostEntry (..), + GeneratedEntry (..), + flattenEntries, + checkIdentifierCollisions, + sanitizeIdentifier, + renderModule, + ) +where + +import Baikai.Api (Api (..), parseApi) +import Baikai.Compat + ( AnthropicMessagesCompat + ( sendSessionAffinityHeaders, + supportsCacheControlOnTools, + supportsLongCacheRetention, + thinkingStyle + ), + AnthropicThinkingStyle (..), + CacheControlFormat (..), + MaxTokensField (..), + OpenAICompletionsCompat + ( cacheControlFormat, + maxTokensField, + requiresThinkingAsText, + supportsLongCacheRetention, + supportsStrictMode, + supportsUsageInStreaming, + thinkingFormat + ), + ThinkingFormat (..), + defaultAnthropicMessagesCompat, + defaultOpenAICompletionsCompat, + ) +import Baikai.Model (InputModality (..)) +import Data.Aeson (FromJSON (..), (.!=), (.:), (.:?)) +import Data.Aeson qualified as Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import Data.Map.Strict qualified as Map +import Data.Ratio (denominator, numerator) +import Data.Scientific (Scientific) +import Data.Text (Text) +import Data.Text qualified as Text +import Numeric.Natural (Natural) + +-- * Catalog data types ----------------------------------------------- + +-- | One catalog file, in source form. +data CatalogFile = CatalogFile + { provider :: !Text, + baseUrl :: !Text, + api :: !Api, + compat :: !CatalogCompat, + models :: ![ModelEntry] + } + +instance FromJSON CatalogFile where + parseJSON = Aeson.withObject "CatalogFile" $ \o -> + CatalogFile + <$> o .: "provider" + <*> o .: "baseUrl" + <*> (parseApi <$> o .: "api") + <*> o .: "compat" + <*> o .: "models" + +-- | A compat directive in the catalog. @"auto"@ defers to EP-5's +-- @baseUrl@-driven auto-detection (rendered as 'CompatNone'). The two +-- structured constructors carry a full override record. +data CatalogCompat + = CatalogCompatAuto + | CatalogCompatOpenAI !OpenAICompletionsCompat + | CatalogCompatAnthropic !AnthropicMessagesCompat + deriving stock (Show) + +instance FromJSON CatalogCompat where + parseJSON = \case + Aeson.String "auto" -> pure CatalogCompatAuto + Aeson.Object o -> do + kind <- o .: "kind" :: Parser Text + case kind of + "openai-completions" -> + CatalogCompatOpenAI <$> parseOpenAICompat o + "anthropic-messages" -> + CatalogCompatAnthropic <$> parseAnthropicCompat o + _ -> + fail $ "CatalogCompat: unknown kind " <> show kind + v -> typeMismatch "CatalogCompat (expected \"auto\" or {\"kind\": ...})" v + +parseOpenAICompat :: Aeson.Object -> Parser OpenAICompletionsCompat +parseOpenAICompat o = do + let d = defaultOpenAICompletionsCompat + mtf <- optionalField o "maxTokensField" parseMaxTokensField (maxTokensField d) + sst <- o .:? "supportsStrictMode" .!= supportsStrictMode d + rtat <- o .:? "requiresThinkingAsText" .!= requiresThinkingAsText d + tf <- optionalField o "thinkingFormat" parseThinkingFormat (thinkingFormat d) + ccf <- optionalMaybeField o "cacheControlFormat" parseCacheControlFormat (cacheControlFormat d) + sus <- o .:? "supportsUsageInStreaming" .!= d.supportsUsageInStreaming + slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention + pure + d + { maxTokensField = mtf, + supportsStrictMode = sst, + requiresThinkingAsText = rtat, + thinkingFormat = tf, + cacheControlFormat = ccf, + supportsUsageInStreaming = sus, + supportsLongCacheRetention = slcr + } + +parseAnthropicCompat :: Aeson.Object -> Parser AnthropicMessagesCompat +parseAnthropicCompat o = do + let d = defaultAnthropicMessagesCompat + slcr <- o .:? "supportsLongCacheRetention" .!= d.supportsLongCacheRetention + scot <- o .:? "supportsCacheControlOnTools" .!= d.supportsCacheControlOnTools + ssah <- o .:? "sendSessionAffinityHeaders" .!= d.sendSessionAffinityHeaders + ts <- o .:? "thinkingStyle" .!= d.thinkingStyle + pure + d + { supportsLongCacheRetention = slcr, + supportsCacheControlOnTools = scot, + sendSessionAffinityHeaders = ssah, + thinkingStyle = ts + } + +parseMaxTokensField :: Text -> Parser MaxTokensField +parseMaxTokensField = \case + "max_tokens" -> pure MaxTokensField + "max_completion_tokens" -> pure MaxCompletionTokensField + t -> fail $ "unknown maxTokensField: " <> Text.unpack t + +parseThinkingFormat :: Text -> Parser ThinkingFormat +parseThinkingFormat = \case + "openai" -> pure ThinkingFormatOpenAI + "openrouter" -> pure ThinkingFormatOpenRouter + "deepseek" -> pure ThinkingFormatDeepseek + "together" -> pure ThinkingFormatTogether + "zai" -> pure ThinkingFormatZai + "qwen" -> pure ThinkingFormatQwen + "none" -> pure ThinkingFormatNone + t -> fail $ "unknown thinkingFormat: " <> Text.unpack t + +parseCacheControlFormat :: Text -> Parser CacheControlFormat +parseCacheControlFormat = \case + "anthropic" -> pure CacheControlFormatAnthropic + t -> fail $ "unknown cacheControlFormat: " <> Text.unpack t + +-- | Look up an optional field; missing returns @def@. +optionalField :: Aeson.Object -> Aeson.Key -> (Text -> Parser a) -> a -> Parser a +optionalField o key parser def = do + mv <- o .:? key + case mv of + Nothing -> pure def + Just v -> parser v + +-- | Look up an optional @Maybe@-typed field. JSON @null@ or absence +-- yields @def@; otherwise the value is parsed through @parser@ and +-- wrapped in 'Just'. +optionalMaybeField :: + Aeson.Object -> + Aeson.Key -> + (Text -> Parser a) -> + Maybe a -> + Parser (Maybe a) +optionalMaybeField o key parser def = do + mv <- o .:? key + case mv of + Nothing -> pure def + Just Aeson.Null -> pure Nothing + Just (Aeson.String t) -> Just <$> parser t + Just v -> typeMismatch "string or null" v + +-- | One model row in a catalog file. +data ModelEntry = ModelEntry + { entryId :: !Text, + entryName :: !Text, + entryReasoning :: !Bool, + entryInput :: ![InputModality], + entryCost :: !CostEntry, + entryContextWindow :: !Natural, + entryMaxOutputTokens :: !Natural, + entryEnabled :: !Bool, + entryCompatOverride :: !(Maybe CatalogCompat) + } + +instance FromJSON ModelEntry where + parseJSON = Aeson.withObject "ModelEntry" $ \o -> + ModelEntry + <$> o .: "id" + <*> o .: "name" + <*> o .:? "reasoning" .!= False + <*> (o .: "input" >>= traverse parseInputModality) + <*> o .: "cost" + <*> o .: "contextWindow" + <*> o .: "maxOutputTokens" + <*> o .:? "enabled" .!= True + <*> o .:? "compat" + +parseInputModality :: Text -> Parser InputModality +parseInputModality = \case + "text" -> pure InputText + "image" -> pure InputImage + t -> fail $ "unknown input modality: " <> Text.unpack t + +-- | Per-million-token cost rates. Parsed as 'Scientific' so the +-- round-trip into 'Rational' produces a small, canonical fraction +-- (@1.5@ -> @3 % 2@) rather than an arbitrary IEEE-754 approximation. +data CostEntry = CostEntry + { costInput :: !Scientific, + costOutput :: !Scientific, + costCacheRead :: !Scientific, + costCacheWrite :: !Scientific + } + +instance FromJSON CostEntry where + parseJSON = Aeson.withObject "CostEntry" $ \o -> + CostEntry + <$> o .: "input" + <*> o .: "output" + <*> o .:? "cacheRead" .!= 0 + <*> o .:? "cacheWrite" .!= 0 + +-- * Flattening --------------------------------------------------------- + +-- | One generated Haskell identifier plus the 'Model'-shaped record +-- it should be rendered as. Keeping these together lets the renderer +-- stay a pure transformation over a flat list. +data GeneratedEntry = GeneratedEntry + { ident :: !Text, + modelId :: !Text, + name :: !Text, + api :: !Api, + provider :: !Text, + baseUrl :: !Text, + reasoning :: !Bool, + input :: ![InputModality], + cost :: !CostEntry, + contextWindow :: !Natural, + maxOutputTokens :: !Natural, + compat :: !CatalogCompat + } + +flattenEntries :: CatalogFile -> [(Text, GeneratedEntry)] +flattenEntries c = + [ (g.ident, g) + | m <- models c, + entryEnabled m, + let g = + GeneratedEntry + { ident = + sanitizeIdentifier (c.provider <> "_" <> entryId m), + modelId = entryId m, + name = entryName m, + api = c.api, + provider = c.provider, + baseUrl = c.baseUrl, + reasoning = entryReasoning m, + input = entryInput m, + cost = entryCost m, + contextWindow = entryContextWindow m, + maxOutputTokens = entryMaxOutputTokens m, + compat = + case entryCompatOverride m of + Just c' -> c' + Nothing -> c.compat + } + ] + +-- | Reject catalogs whose sanitized generated Haskell binding names collide. +-- Without this check, two distinct upstream model ids such as @foo-bar@ and +-- @foo_bar@ would silently render duplicate top-level declarations. +checkIdentifierCollisions :: [(Text, GeneratedEntry)] -> Either Text () +checkIdentifierCollisions entries = + case Map.toList collisions of + [] -> Right () + dupes -> + Left $ + "duplicate generated model identifiers: " + <> Text.intercalate "; " (map renderCollision dupes) + where + grouped = + Map.fromListWith + (++) + [(i, [entry]) | (i, entry) <- entries] + collisions = Map.filter ((> 1) . length) grouped + renderCollision (i, es) = + i + <> " from " + <> Text.intercalate ", " (map origin (reverse es)) + origin e = e.provider <> "/" <> e.modelId + +-- | Replace any non-identifier character with @_@. Haskell allows +-- letters, digits, underscore, and apostrophe; everything else +-- (slash, dash, dot, colon, ...) becomes an underscore. +sanitizeIdentifier :: Text -> Text +sanitizeIdentifier = Text.map replace + where + replace c + | (c >= 'a' && c <= 'z') + || (c >= 'A' && c <= 'Z') + || (c >= '0' && c <= '9') + || c == '_' + || c == '\'' = + c + | otherwise = '_' + +-- * Source rendering -------------------------------------------------- + +renderModule :: [(Text, GeneratedEntry)] -> Text +renderModule entries = + Text.unlines $ + dropTrailingEmpty + ( header + ++ concatMap (renderEntry . snd) entries + ) + where + dropTrailingEmpty = \case + [] -> [] + xs + | last xs == "" -> init xs + | otherwise -> xs + + header = + [ "-- AUTO-GENERATED by baikai-gen-models. Do not edit by hand.", + "-- Regenerate with: cabal run baikai-gen-models", + "{-# LANGUAGE OverloadedStrings #-}", + "{-# OPTIONS_GHC -Wno-missing-export-lists #-}", + "{-# OPTIONS_GHC -Wno-unused-imports #-}", + "", + "module Baikai.Models.Generated where", + "", + "import Baikai.Api (Api (..))", + "import Baikai.Compat", + " ( AnthropicThinkingStyle (..),", + " CacheControlFormat (..),", + " MaxTokensField (..),", + " ThinkingFormat (..),", + " defaultAnthropicMessagesCompat,", + " defaultOpenAICompletionsCompat,", + " )", + "import Baikai.Model", + " ( Compat (..),", + " InputModality (..),", + " Model,", + " ModelCost (..),", + " api,", + " baseUrl,", + " compat,", + " contextWindow,", + " cost,", + " emptyModel,", + " headers,", + " input,", + " maxOutputTokens,", + " modelId,", + " name,", + " provider,", + " reasoning,", + " )", + "import Data.Map.Strict qualified as Map", + "import Data.Ratio ((%))", + "" + ] + +renderEntry :: GeneratedEntry -> [Text] +renderEntry g = + [ g.ident <> " :: Model", + g.ident <> " =", + " emptyModel", + " { modelId = " <> renderText g.modelId <> ",", + " name = " <> renderText g.name <> ",", + " api = " <> renderApiCtor g.api <> ",", + " provider = " <> renderText g.provider <> ",", + " baseUrl = " <> renderText g.baseUrl <> ",", + " reasoning = " <> renderBool g.reasoning <> ",", + " input = " <> renderInputList g.input <> ",", + " cost =", + renderCost g.cost <> ",", + " contextWindow = " <> Text.pack (show g.contextWindow) <> ",", + " maxOutputTokens = " <> Text.pack (show g.maxOutputTokens) <> ",", + " headers = Map.empty,", + " compat = " <> renderCompat g.compat, + " }", + "" + ] + +renderText :: Text -> Text +renderText t = + "\"" + <> Text.replace "\"" "\\\"" (Text.replace "\\" "\\\\" t) + <> "\"" + +renderBool :: Bool -> Text +renderBool True = "True" +renderBool False = "False" + +renderInputList :: [InputModality] -> Text +renderInputList ms = + "[" <> Text.intercalate ", " (map renderInput ms) <> "]" + where + renderInput InputText = "InputText" + renderInput InputImage = "InputImage" + +renderApiCtor :: Api -> Text +renderApiCtor = \case + OpenAIChatCompletions -> "OpenAIChatCompletions" + AnthropicMessages -> "AnthropicMessages" + OpenAICompletionsCli -> "OpenAICompletionsCli" + AnthropicMessagesCli -> "AnthropicMessagesCli" + Custom t -> "Custom " <> renderText t + +renderCost :: CostEntry -> Text +renderCost c = + Text.intercalate + "\n" + [ " ModelCost", + " { inputCost = " <> renderRational (toRational (costInput c)) <> ",", + " outputCost = " <> renderRational (toRational (costOutput c)) <> ",", + " cacheReadCost = " <> renderRational (toRational (costCacheRead c)) <> ",", + " cacheWriteCost = " <> renderRational (toRational (costCacheWrite c)), + " }" + ] + +renderRational :: Rational -> Text +renderRational r = + Text.pack (show (numerator r)) <> " % " <> Text.pack (show (denominator r)) + +renderCompat :: CatalogCompat -> Text +renderCompat = \case + CatalogCompatAuto -> "CompatNone" + CatalogCompatOpenAI c -> + Text.intercalate + "\n" + [ "CompatOpenAICompletions", + " defaultOpenAICompletionsCompat", + " { maxTokensField = " <> renderMaxTokensField c.maxTokensField <> ",", + " supportsStrictMode = " <> renderBool c.supportsStrictMode <> ",", + " requiresThinkingAsText = " <> renderBool c.requiresThinkingAsText <> ",", + " thinkingFormat = " <> renderThinkingFormat c.thinkingFormat <> ",", + " cacheControlFormat = " <> renderMaybeCacheControl c.cacheControlFormat <> ",", + " supportsUsageInStreaming = " <> renderBool c.supportsUsageInStreaming <> ",", + " supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention, + " }" + ] + CatalogCompatAnthropic c -> + Text.intercalate + "\n" + [ "CompatAnthropicMessages", + " defaultAnthropicMessagesCompat", + " { supportsLongCacheRetention = " <> renderBool c.supportsLongCacheRetention <> ",", + " supportsCacheControlOnTools = " <> renderBool c.supportsCacheControlOnTools <> ",", + " sendSessionAffinityHeaders = " <> renderBool c.sendSessionAffinityHeaders <> ",", + " thinkingStyle = " <> renderAnthropicThinkingStyle c.thinkingStyle, + " }" + ] + +renderMaxTokensField :: MaxTokensField -> Text +renderMaxTokensField = \case + MaxCompletionTokensField -> "MaxCompletionTokensField" + MaxTokensField -> "MaxTokensField" + +renderThinkingFormat :: ThinkingFormat -> Text +renderThinkingFormat = \case + ThinkingFormatOpenAI -> "ThinkingFormatOpenAI" + ThinkingFormatOpenRouter -> "ThinkingFormatOpenRouter" + ThinkingFormatDeepseek -> "ThinkingFormatDeepseek" + ThinkingFormatTogether -> "ThinkingFormatTogether" + ThinkingFormatZai -> "ThinkingFormatZai" + ThinkingFormatQwen -> "ThinkingFormatQwen" + ThinkingFormatNone -> "ThinkingFormatNone" + +renderAnthropicThinkingStyle :: AnthropicThinkingStyle -> Text +renderAnthropicThinkingStyle = \case + AnthropicThinkingBudget -> "AnthropicThinkingBudget" + AnthropicThinkingAdaptive -> "AnthropicThinkingAdaptive" + +renderMaybeCacheControl :: Maybe CacheControlFormat -> Text +renderMaybeCacheControl = \case + Nothing -> "Nothing" + Just CacheControlFormatAnthropic -> "Just CacheControlFormatAnthropic" diff --git a/src/Baikai.hs b/src/Baikai.hs --- a/src/Baikai.hs +++ b/src/Baikai.hs @@ -2,6 +2,18 @@ -- gives a downstream consumer everything needed to declare a -- 'Model', build a 'Context' and 'Options', and dispatch a call -- through the registered handler. +-- +-- This umbrella intentionally omits opt-in subsystems with their own +-- vocabularies: tracing, OpenTelemetry sinks, embeddings, call-log +-- plumbing, pricing lookup internals, the generated model catalog, and +-- "Baikai.Prelude". Import those modules directly when you need them. +-- +-- Evolvable configuration records expose their type, field selectors, +-- and an @empty*@ or @default*@ base value rather than their data +-- constructor. Build those records by record update so adding fields in +-- a later release does not force source changes. Closed sums and +-- provider-produced payload records remain constructible where callers +-- need to pattern match or build fixtures. module Baikai ( -- * Types module Baikai.AgentAssets, diff --git a/src/Baikai/Auth.hs b/src/Baikai/Auth.hs --- a/src/Baikai/Auth.hs +++ b/src/Baikai/Auth.hs @@ -8,11 +8,13 @@ -- value does not read the environment. module Baikai.Auth ( ApiKeySource (..), + defaultApiKeyEnvForBaseUrl, renderApiKeySourceForDebug, resolveApiKey, ) where +import Baikai.Compat (hostMatchesSuffix, urlHost) import Baikai.Error (authError) import Control.Exception (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO) @@ -24,6 +26,7 @@ data ApiKeySource = ApiKeyLiteral !Text | ApiKeyEnv !String + | ApiKeyEnvChain ![String] deriving stock (Eq) instance Show ApiKeySource where @@ -39,13 +42,43 @@ [ "source" .= ("env" :: Text), "name" .= name ] + toJSON (ApiKeyEnvChain names) = + object + [ "source" .= ("env-chain" :: Text), + "names" .= names + ] +-- | Conventional API-key environment variable for a known provider +-- host. Unknown hosts return 'Nothing' so callers can require an +-- explicit 'ApiKeySource' instead of leaking another provider's +-- credential. +defaultApiKeyEnvForBaseUrl :: Text -> Maybe String +defaultApiKeyEnvForBaseUrl baseUrl = do + host <- urlHost baseUrl + match host + where + match host + | hostMatchesSuffix host "api.openai.com" = Just "OPENAI_API_KEY" + | hostMatchesSuffix host "api.deepseek.com" = Just "DEEPSEEK_API_KEY" + | hostMatchesSuffix host "openrouter.ai" = Just "OPENROUTER_API_KEY" + | hostMatchesSuffix host "together.xyz" = Just "TOGETHER_API_KEY" + | hostMatchesSuffix host "together.ai" = Just "TOGETHER_API_KEY" + | hostMatchesSuffix host "z.ai" = Just "ZAI_API_KEY" + | hostMatchesSuffix host "dashscope.aliyuncs.com" = Just "DASHSCOPE_API_KEY" + | hostMatchesSuffix host "dashscope-intl.aliyuncs.com" = Just "DASHSCOPE_API_KEY" + | hostMatchesSuffix host "qwen.ai" = Just "DASHSCOPE_API_KEY" + | hostMatchesSuffix host "api.anthropic.com" = Just "ANTHROPIC_API_KEY" + | hostMatchesSuffix host "fireworks.ai" = Just "FIREWORKS_API_KEY" + | otherwise = Nothing + -- | Render a credential source for logs, test failures, and debugging without -- exposing literal secret material. renderApiKeySourceForDebug :: ApiKeySource -> Text renderApiKeySourceForDebug (ApiKeyLiteral _) = "ApiKeyLiteral " renderApiKeySourceForDebug (ApiKeyEnv name) = "ApiKeyEnv " <> Text.pack (show name) +renderApiKeySourceForDebug (ApiKeyEnvChain names) = + "ApiKeyEnvChain " <> Text.pack (show names) -- | 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 @@ -57,3 +90,16 @@ Environment.lookupEnv name >>= \case Just v -> pure (Text.pack v) Nothing -> throwIO (authError ("env var " <> Text.pack name <> " is not set")) +resolveApiKey (ApiKeyEnvChain names) = + liftIO (go names) + where + go [] = + throwIO + (authError ("none of the env vars " <> renderedNames <> " are set")) + go (name : rest) = + Environment.lookupEnv name >>= \case + Just v -> pure (Text.pack v) + Nothing -> go rest + renderedNames = case names of + [] -> "" + _ -> Text.intercalate ", " (Text.pack <$> names) diff --git a/src/Baikai/Compat.hs b/src/Baikai/Compat.hs --- a/src/Baikai/Compat.hs +++ b/src/Baikai/Compat.hs @@ -14,31 +14,44 @@ -- on a per-'Baikai.Model.Model' record means the same provider -- handler can serve both hosts without any per-host code branching. -- --- These record constructors are intentionally public in baikai 0.1. --- They are the supported escape hatch for hand-rolled models and --- generated catalog overrides when a host speaks a familiar protocol --- but rejects or requires a small request-shaping difference. New --- fields or enum constructors may be added in later minor versions as --- new provider quirks are discovered; callers that want fewer upgrade --- edits should start from the @default*@ values and use record updates --- rather than constructing every field from scratch. +-- The records export their field selectors but not their data +-- constructors. They are expected to grow as provider quirks are +-- discovered, so callers should start from the @default*@ values and +-- use record updates for the fields they need to override. -- -- Auto-detection from a 'Baikai.Model.Model' @baseUrl@ provides -- reasonable defaults so callers rarely need to spell out a full -- compat record. module Baikai.Compat ( -- * OpenAI Chat Completions compat - OpenAICompletionsCompat (..), + OpenAICompletionsCompat + ( maxTokensField, + supportsStrictMode, + requiresThinkingAsText, + thinkingFormat, + cacheControlFormat, + supportsUsageInStreaming, + supportsLongCacheRetention + ), defaultOpenAICompletionsCompat, MaxTokensField (..), ThinkingFormat (..), CacheControlFormat (..), -- * Anthropic Messages compat - AnthropicMessagesCompat (..), + AnthropicMessagesCompat + ( supportsLongCacheRetention, + supportsCacheControlOnTools, + sendSessionAffinityHeaders, + thinkingStyle + ), + AnthropicThinkingStyle (..), defaultAnthropicMessagesCompat, + defaultAnthropicThinkingStyle, -- * Auto-detection from baseUrl + urlHost, + hostMatchesSuffix, autoDetectOpenAICompletions, autoDetectAnthropicMessages, ) @@ -91,6 +104,16 @@ deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) +-- | Which request shape an Anthropic-compatible host/model accepts +-- for extended thinking. Budget-era models take +-- @{"type":"enabled","budget_tokens":N}@; adaptive-era models take +-- @{"type":"adaptive"}@ with depth guided by @output_config.effort@. +data AnthropicThinkingStyle + = AnthropicThinkingBudget + | AnthropicThinkingAdaptive + deriving stock (Eq, Show, Generic) + deriving anyclass (FromJSON, ToJSON) + -- | Feature flags for one OpenAI-compatible host. -- -- Every flag has a default that reproduces OpenAI's own behaviour — @@ -98,34 +121,45 @@ -- override the differing fields only. data OpenAICompletionsCompat = OpenAICompletionsCompat { -- | Where the max-output-tokens cap goes in the request body. + -- Consumed by @Baikai.Provider.OpenAI.Shape.renameMaxTokens@, + -- which rewrites @max_completion_tokens@ to @max_tokens@ + -- for hosts that require the legacy key. maxTokensField :: !MaxTokensField, - -- | Whether the host accepts the @developer@ message role - -- (OpenAI's o-series) or only @system@. - supportsDeveloperRole :: !Bool, -- | Whether the host accepts @strict: true@ on function tool - -- definitions. Set 'False' to drop the field on hosts that - -- reject it. + -- definitions. Consumed by + -- @Baikai.Provider.OpenAI.Api.mkOpenAIResponseFormat@ and + -- @Baikai.Provider.OpenAI.Shape.dropUnsupportedStrict@ to + -- omit JSON-schema @strict@ on hosts that reject it. supportsStrictMode :: !Bool, -- | Whether the host smuggles thinking into the assistant text as - -- @\...\@ markers. When 'True', the - -- provider's stream transformer extracts those markers into - -- typed thinking deltas on the way out. (The transformer itself - -- is wired in by EP-3; EP-5 only flips the switch.) + -- @\...\@ or + -- @\...\@ markers. Field-based reasoning + -- extraction (for @reasoning_content@ / @reasoning@ deltas) is + -- unconditional; this flag enables the incremental tag scanner + -- in @Baikai.Provider.OpenAI.Api.translateTextLikeDelta@ for + -- hosts that do not split reasoning into a separate field. requiresThinkingAsText :: !Bool, -- | The wire shape the host accepts for reasoning-effort - -- preferences. + -- preferences. Consumed by + -- @Baikai.Provider.OpenAI.Api.applyThinkingFormat@ for the + -- OpenAI-native field and by + -- @Baikai.Provider.OpenAI.Shape.injectThinkingShape@ for + -- OpenAI-compatible host-specific JSON keys. thinkingFormat :: !ThinkingFormat, -- | Whether the host accepts Anthropic-style @cache_control@ -- markers (some OpenRouter routes pass them through to an - -- Anthropic backend). + -- Anthropic backend). Consumed by + -- @Baikai.Provider.OpenAI.Shape.injectCacheControl@. cacheControlFormat :: !(Maybe CacheControlFormat), -- | Whether the host emits a final @usage@ chunk in streaming - -- responses. OpenAI does; older OpenAI-compatible servers may - -- not. Currently advisory. + -- responses. Consumed by + -- @Baikai.Provider.OpenAI.Shape.streamRequestBody@ to include + -- or omit @stream_options.include_usage@. supportsUsageInStreaming :: !Bool, -- | Whether the host honours long (1h) cache TTLs through the - -- Anthropic-style cache_control marker. Currently only relevant - -- when 'cacheControlFormat' is 'Just CacheControlFormatAnthropic'. + -- Anthropic-style cache_control marker. Consumed by + -- @Baikai.Provider.OpenAI.Shape.injectCacheControl@ when + -- 'cacheControlFormat' is 'Just CacheControlFormatAnthropic'. supportsLongCacheRetention :: !Bool } deriving stock (Eq, Show, Generic) @@ -136,7 +170,6 @@ defaultOpenAICompletionsCompat = OpenAICompletionsCompat { maxTokensField = MaxCompletionTokensField, - supportsDeveloperRole = True, supportsStrictMode = True, requiresThinkingAsText = False, thinkingFormat = ThinkingFormatOpenAI, @@ -150,17 +183,24 @@ { -- | Whether the host honours Anthropic's -- @cache_control.ttl: "1h"@ long-retention marker. When 'False', -- long-retention preferences silently downgrade to ephemeral. + -- Consumed by @Baikai.Provider.Claude.Api.computeCacheControl@ + -- for top-level cache markers and by + -- @Baikai.Provider.Claude.Shape.injectToolCacheControl@ for + -- tool cache markers. supportsLongCacheRetention :: !Bool, -- | Whether tool definitions accept @cache_control@ markers. + -- Consumed by + -- @Baikai.Provider.Claude.Shape.injectToolCacheControl@. -- Anthropic's own host does; some compatible hosts do not. supportsCacheControlOnTools :: !Bool, - -- | Whether the host supports per-tool eager input streaming - -- (Anthropic's @fine-grained-tool-streaming@ beta). Currently - -- advisory; the SDK does not expose the field directly. - supportsEagerToolInputStreaming :: !Bool, -- | Whether to add session-affinity headers on every request - -- (Fireworks-style routing). - sendSessionAffinityHeaders :: !Bool + -- (Fireworks-style routing). Consumed by + -- @Baikai.Provider.Claude.Transport.requestHeaders@. + sendSessionAffinityHeaders :: !Bool, + -- | Which extended-thinking request shape to send for the + -- selected model generation. Consumed by + -- @Baikai.Provider.Claude.Api.computeThinking@. + thinkingStyle :: !AnthropicThinkingStyle } deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) @@ -171,52 +211,64 @@ AnthropicMessagesCompat { supportsLongCacheRetention = True, supportsCacheControlOnTools = True, - supportsEagerToolInputStreaming = True, - sendSessionAffinityHeaders = False + sendSessionAffinityHeaders = False, + thinkingStyle = AnthropicThinkingBudget } +-- | The thinking style a first-party Anthropic model id defaults to +-- when the model carries no explicit compat record. Unknown ids +-- default to the budget style used by earlier model generations. +defaultAnthropicThinkingStyle :: Text -> AnthropicThinkingStyle +defaultAnthropicThinkingStyle modelId + | adaptive "claude-opus-4-6" = AnthropicThinkingAdaptive + | adaptive "claude-opus-4-7" = AnthropicThinkingAdaptive + | adaptive "claude-opus-4-8" = AnthropicThinkingAdaptive + | adaptive "claude-fable-5" = AnthropicThinkingAdaptive + | otherwise = AnthropicThinkingBudget + where + adaptive prefix = prefix `Text.isPrefixOf` modelId + -- | Pick a sensible compat record for an unknown OpenAI-compatible -- host based on its @baseUrl@. Falls back to -- 'defaultOpenAICompletionsCompat' for hosts the table does not -- recognise. autoDetectOpenAICompletions :: Text -> OpenAICompletionsCompat autoDetectOpenAICompletions url - | hasInfix "api.openai.com" = defaultOpenAICompletionsCompat - | hasInfix "api.deepseek.com" = + | matches "api.openai.com" = defaultOpenAICompletionsCompat + | matches "api.deepseek.com" = defaultOpenAICompletionsCompat { thinkingFormat = ThinkingFormatDeepseek, requiresThinkingAsText = True, maxTokensField = MaxTokensField, - supportsStrictMode = False, - supportsDeveloperRole = False + supportsStrictMode = False } - | hasInfix "openrouter.ai" = + | matches "openrouter.ai" = defaultOpenAICompletionsCompat { thinkingFormat = ThinkingFormatOpenRouter, supportsStrictMode = False, - supportsDeveloperRole = False, cacheControlFormat = Just CacheControlFormatAnthropic } - | hasInfix "together.xyz" || hasInfix "api.together.ai" = + | matches "together.xyz" || matches "together.ai" = defaultOpenAICompletionsCompat { thinkingFormat = ThinkingFormatTogether, - supportsStrictMode = False, - supportsDeveloperRole = False + supportsStrictMode = False } - | hasInfix "z.ai" = + | matches "z.ai" = defaultOpenAICompletionsCompat { thinkingFormat = ThinkingFormatZai, supportsStrictMode = False } - | hasInfix "dashscope" || hasInfix "qwen" = + | matches "dashscope.aliyuncs.com" + || matches "dashscope-intl.aliyuncs.com" + || matches "qwen.ai" = defaultOpenAICompletionsCompat { thinkingFormat = ThinkingFormatQwen, supportsStrictMode = False } | otherwise = defaultOpenAICompletionsCompat where - hasInfix :: Text -> Bool - hasInfix needle = needle `Text.isInfixOf` url + host = urlHost url + matches suffix = maybe False (`hostMatchesSuffix` suffix) host -- | Pick a sensible compat record for an unknown -- Anthropic-compatible host based on its @baseUrl@. Falls back to @@ -224,8 +276,8 @@ -- recognise. autoDetectAnthropicMessages :: Text -> AnthropicMessagesCompat autoDetectAnthropicMessages url - | hasInfix "api.anthropic.com" = defaultAnthropicMessagesCompat - | hasInfix "fireworks.ai" = + | matches "api.anthropic.com" = defaultAnthropicMessagesCompat + | matches "fireworks.ai" = defaultAnthropicMessagesCompat { supportsCacheControlOnTools = False, sendSessionAffinityHeaders = True, @@ -233,5 +285,29 @@ } | otherwise = defaultAnthropicMessagesCompat where - hasInfix :: Text -> Bool - hasInfix needle = needle `Text.isInfixOf` url + host = urlHost url + matches suffix = maybe False (`hostMatchesSuffix` suffix) host + +-- | Extract a hostname from a URL-ish value. This is intentionally +-- small and total rather than a validating URI parser: it drops an +-- optional scheme, optional userinfo, then stops at '/', ':', '?', or +-- '#'. Empty results return 'Nothing'. +urlHost :: Text -> Maybe Text +urlHost raw = + let noScheme = case Text.breakOn "://" raw of + (_, rest) | not (Text.null rest) -> Text.drop 3 rest + _ -> raw + noUser = last (Text.splitOn "@" noScheme) + host = Text.toLower (Text.strip (Text.takeWhile hostChar noUser)) + in if Text.null host then Nothing else Just host + where + hostChar c = c /= '/' && c /= ':' && c /= '?' && c /= '#' + +-- | Match a hostname against a suffix at a label boundary. +hostMatchesSuffix :: Text -> Text -> Bool +hostMatchesSuffix host suffix = + let h = Text.toLower (Text.strip host) + s = Text.toLower (Text.strip suffix) + in not (Text.null h) + && not (Text.null s) + && (h == s || ("." <> s) `Text.isSuffixOf` h) diff --git a/src/Baikai/Content.hs b/src/Baikai/Content.hs --- a/src/Baikai/Content.hs +++ b/src/Baikai/Content.hs @@ -28,6 +28,10 @@ ToolResultContent (..), -- * Smart defaults + emptyTextContent, + emptyThinkingContent, + emptyToolCall, + emptyImageContent, _TextContent, _ThinkingContent, _ToolCall, @@ -70,7 +74,9 @@ -- provider; it must be threaded back into the next request unchanged for -- the model to resume from the same state. @redacted@ is 'True' when the -- provider hid the underlying content (Anthropic flags this when its --- safety system removes a thinking block from the wire response). +-- safety system removes a thinking block from the wire response). When +-- @redacted@ is 'True', @thinking@ holds the provider's opaque encrypted +-- payload verbatim; callers must not display or edit it. data ThinkingContent = ThinkingContent { thinking :: !Text, signature :: !(Maybe Text), @@ -116,27 +122,27 @@ | ToolResultImage !ImageContent deriving stock (Eq, Show, Generic) -_TextContent :: TextContent -_TextContent = TextContent {text = Text.empty} +emptyTextContent :: TextContent +emptyTextContent = TextContent {text = Text.empty} -_ThinkingContent :: ThinkingContent -_ThinkingContent = +emptyThinkingContent :: ThinkingContent +emptyThinkingContent = ThinkingContent { thinking = Text.empty, signature = Nothing, redacted = False } -_ToolCall :: ToolCall -_ToolCall = +emptyToolCall :: ToolCall +emptyToolCall = ToolCall { id_ = Text.empty, name = Text.empty, arguments = Null } -_ImageContent :: ImageContent -_ImageContent = +emptyImageContent :: ImageContent +emptyImageContent = ImageContent { imageData = BS.empty, mimeType = Text.empty @@ -210,3 +216,19 @@ instance ToJSON ToolResultContent where toJSON = genericToJSON contentSumOptions + +{-# DEPRECATED _TextContent "Use emptyTextContent instead." #-} +_TextContent :: TextContent +_TextContent = emptyTextContent + +{-# DEPRECATED _ThinkingContent "Use emptyThinkingContent instead." #-} +_ThinkingContent :: ThinkingContent +_ThinkingContent = emptyThinkingContent + +{-# DEPRECATED _ToolCall "Use emptyToolCall instead." #-} +_ToolCall :: ToolCall +_ToolCall = emptyToolCall + +{-# DEPRECATED _ImageContent "Use emptyImageContent instead." #-} +_ImageContent :: ImageContent +_ImageContent = emptyImageContent diff --git a/src/Baikai/Context.hs b/src/Baikai/Context.hs --- a/src/Baikai/Context.hs +++ b/src/Baikai/Context.hs @@ -14,17 +14,27 @@ -- referenced by the @tools@ field, so 'Baikai.Tool' cannot itself -- depend on 'Context'). module Baikai.Context - ( Context (..), + ( Context, + systemPrompt, + messages, + tools, + emptyContext, _Context, + contextOf, + systemUser, + addUser, + addMessage, + addResponse, appendToolResult, appendToolResultText, ) where import Baikai.Content (AssistantContent (..), ToolCall (..)) -import Baikai.Message (Message (..), ToolResult, toolResultFromCallNow, toolResultText) +import Baikai.Message (Message (..), ToolResult, toolResultFromCallNow, toolResultText, user) import Baikai.Response (Response (..), responseMessage) import Baikai.Tool (Tool) +import Control.Applicative ((<|>)) import Control.Lens ((&), (.~), (^.)) import Data.Aeson (ToJSON) import Data.Generics.Labels () @@ -41,14 +51,51 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) -_Context :: Context -_Context = +emptyContext :: Context +emptyContext = Context { systemPrompt = Nothing, messages = V.empty, tools = V.empty } +instance Semigroup Context where + a <> b = + Context + { systemPrompt = systemPrompt a <|> systemPrompt b, + messages = messages a <> messages b, + tools = tools a <> tools b + } + +instance Monoid Context where + mempty = emptyContext + +-- | Build a context from an existing list of messages. +contextOf :: [Message] -> Context +contextOf msgs = + emptyContext {messages = V.fromList msgs} + +-- | Build a context with a system prompt and one user message. +systemUser :: Text -> Text -> Context +systemUser sys prompt = + emptyContext + { systemPrompt = Just sys, + messages = V.singleton (user prompt) + } + +-- | Append a one-text-block user message. +addUser :: Text -> Context -> Context +addUser t = addMessage (user t) + +-- | Append a message to the conversation. +addMessage :: Message -> Context -> Context +addMessage msg ctx = + ctx {messages = V.snoc (messages ctx) msg} + +-- | Append a provider response as an assistant message. +addResponse :: Response -> Context -> Context +addResponse resp = addMessage (responseMessage resp) + -- | Execute every 'AssistantToolCall' in @resp@'s message via the -- caller-supplied dispatcher, then append the assistant message and -- one 'Baikai.Message.ToolResultMessage' per call to @ctx@. The @@ -92,3 +139,7 @@ IO Context appendToolResultText ctx resp dispatcher = appendToolResult ctx resp (fmap toolResultText . dispatcher) + +{-# DEPRECATED _Context "Use emptyContext instead." #-} +_Context :: Context +_Context = emptyContext diff --git a/src/Baikai/Cost.hs b/src/Baikai/Cost.hs --- a/src/Baikai/Cost.hs +++ b/src/Baikai/Cost.hs @@ -1,6 +1,8 @@ module Baikai.Cost ( Cost (..), CostBreakdown (..), + zeroCost, + zeroCostBreakdown, _Cost, _CostBreakdown, usdAsScientific, @@ -25,8 +27,8 @@ } deriving stock (Eq, Show, Generic) -_CostBreakdown :: CostBreakdown -_CostBreakdown = +zeroCostBreakdown :: CostBreakdown +zeroCostBreakdown = CostBreakdown { inputUsd = 0, outputUsd = 0, @@ -34,8 +36,8 @@ cachedWriteUsd = 0 } -_Cost :: Cost -_Cost = Cost {usd = 0, breakdown = _CostBreakdown} +zeroCost :: Cost +zeroCost = Cost {usd = 0, breakdown = zeroCostBreakdown} -- Field-wise combination so callers can total per-call costs with -- '(<>)'/'mconcat'. 'mempty' reuses the existing zero value, so the @@ -51,13 +53,13 @@ } instance Monoid CostBreakdown where - mempty = _CostBreakdown + mempty = zeroCostBreakdown instance Semigroup Cost where a <> b = Cost {usd = usd a + usd b, breakdown = breakdown a <> breakdown b} instance Monoid Cost where - mempty = _Cost + mempty = zeroCost instance ToJSON CostBreakdown where toJSON cb = @@ -80,3 +82,11 @@ ratToSci :: Rational -> Scientific ratToSci = fst . fromRationalRepetendUnlimited + +{-# DEPRECATED _CostBreakdown "Use zeroCostBreakdown instead." #-} +_CostBreakdown :: CostBreakdown +_CostBreakdown = zeroCostBreakdown + +{-# DEPRECATED _Cost "Use zeroCost instead." #-} +_Cost :: Cost +_Cost = zeroCost diff --git a/src/Baikai/Cost/Log.hs b/src/Baikai/Cost/Log.hs --- a/src/Baikai/Cost/Log.hs +++ b/src/Baikai/Cost/Log.hs @@ -11,6 +11,10 @@ -- > withCallLog (CallLogConfig "/tmp/baikai.jsonl" True) $ \h -> do -- > _ <- runRequestWithLog h model context options -- > pure () +-- +-- If the worker cannot open or write the log file, the close path +-- reports one warning on stderr and returns. Logging failures do not +-- mask the request body or hang release actions. module Baikai.Cost.Log ( CallLogConfig (..), CallLogEntry (..), @@ -45,8 +49,9 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) -import Control.Exception (bracket) +import Control.Exception (SomeException, bracket, displayException, try) import Control.Lens ((^.)) +import Control.Monad (forM_) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Aeson (FromJSON, ToJSON) @@ -55,6 +60,7 @@ import Data.Foldable (find) import Data.Function ((&)) import Data.Generics.Labels () +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Scientific (Scientific) import Data.Text (Text) import Data.Text qualified as Text @@ -64,7 +70,7 @@ import Numeric.Natural (Natural) import Streamly.Data.Fold qualified as Fold import Streamly.Data.Stream qualified as Stream -import System.IO (BufferMode (LineBuffering), IOMode (AppendMode), hSetBuffering, withFile) +import System.IO (BufferMode (LineBuffering), IOMode (AppendMode), hPutStrLn, hSetBuffering, stderr, withFile) -- | Where (and whether) to write the call log. data CallLogConfig = CallLogConfig @@ -85,7 +91,7 @@ cachedInputTokens :: !(Maybe Natural), reasoningTokens :: !(Maybe Natural), usd :: !(Maybe Scientific), - latencyMs :: !Integer, + latencyMs :: !Int, promptSummary :: !Text } deriving stock (Eq, Show, Generic) @@ -95,7 +101,8 @@ data CallLogHandle = CallLogHandle { chan :: !(Chan (Maybe CallLogEntry)), done :: !(MVar ()), - cfg :: !CallLogConfig + cfg :: !CallLogConfig, + workerError :: !(IORef (Maybe SomeException)) } -- | Open a handle. When @enabled = True@, fork the worker thread @@ -104,12 +111,13 @@ openCallLog c = liftIO $ do ch <- newChan d <- newEmptyMVar + e <- newIORef Nothing case enabled c of False -> putMVar d () True -> do - _ <- forkIO (worker (path c) ch d) + _ <- forkIO (worker (path c) ch d e) pure () - pure CallLogHandle {chan = ch, done = d, cfg = c} + pure CallLogHandle {chan = ch, done = d, cfg = c, workerError = e} -- | Signal shutdown and block until the worker has drained every -- pending entry to disk. @@ -119,6 +127,11 @@ True -> writeChan (chan h) Nothing False -> pure () takeMVar (done h) + merr <- readIORef (workerError h) + forM_ merr $ \e -> + hPutStrLn + stderr + ("baikai: call log worker failed; pending entries were dropped: " <> displayException e) -- | Bracketed lifetime: open the handle, run the body, close -- exactly once on every path (including exceptions). @@ -185,20 +198,26 @@ -- | Worker loop: pull 'Maybe CallLogEntry' off the channel, drain -- through a streamly fold that writes each entry as one JSON line. -worker :: FilePath -> Chan (Maybe CallLogEntry) -> MVar () -> IO () -worker p ch d = - withFile p AppendMode $ \fh -> do - hSetBuffering fh LineBuffering - let step :: () -> IO (Maybe (CallLogEntry, ())) - step () = do - msg <- readChan ch - case msg of - Nothing -> pure Nothing - Just e -> pure (Just (e, ())) - Stream.unfoldrM step () - & Stream.fold (Fold.drainMapM (writeEntry fh)) - putMVar d () +worker :: FilePath -> Chan (Maybe CallLogEntry) -> MVar () -> IORef (Maybe SomeException) -> IO () +worker p ch d errRef = do + result <- try drainToFile :: IO (Either SomeException ()) + case result of + Left e -> writeIORef errRef (Just e) + Right () -> pure () + putMVar d () where + drainToFile = + withFile p AppendMode $ \fh -> do + hSetBuffering fh LineBuffering + let step :: () -> IO (Maybe (CallLogEntry, ())) + step () = do + msg <- readChan ch + case msg of + Nothing -> pure Nothing + Just e -> pure (Just (e, ())) + Stream.unfoldrM step () + & Stream.fold (Fold.drainMapM (writeEntry fh)) + writeEntry fh entry = BSL.hPut fh (Aeson.encode entry <> "\n") diff --git a/src/Baikai/Cost/Pricing.hs b/src/Baikai/Cost/Pricing.hs --- a/src/Baikai/Cost/Pricing.hs +++ b/src/Baikai/Cost/Pricing.hs @@ -4,7 +4,7 @@ -- Pricing rates live on 'Baikai.Model.Model.cost' directly, so the -- computation collapses to a record-field access. Models without -- published pricing carry a zero 'Baikai.Model.ModelCost' (the --- default in '_Model'), producing a zero 'Cost'. +-- default in 'emptyModel'), producing a zero 'Cost'. module Baikai.Cost.Pricing ( computeCost, attachCost, diff --git a/src/Baikai/Embedding.hs b/src/Baikai/Embedding.hs --- a/src/Baikai/Embedding.hs +++ b/src/Baikai/Embedding.hs @@ -16,15 +16,19 @@ -- for embeddings. module Baikai.Embedding ( EmbeddingModel (..), + emptyEmbeddingModel, _EmbeddingModel, openAIEmbeddingModel, mkEmbeddingRequest, + firstEmbedding, embed, embedOne, ) where import Baikai.Auth (ApiKeySource (..), resolveApiKey) +import Baikai.Error (BaikaiError, decodeError) +import Control.Exception (throwIO) import Data.Text (Text) import Data.Vector (Vector) import Data.Vector qualified as V @@ -48,8 +52,8 @@ -- | A blank embedding model; a record-update target for hand-built models. Keyed -- on @OPENAI_API_KEY@ by default. -_EmbeddingModel :: EmbeddingModel -_EmbeddingModel = +emptyEmbeddingModel :: EmbeddingModel +emptyEmbeddingModel = EmbeddingModel { modelId = "", baseUrl = "", @@ -61,7 +65,7 @@ -- dimensionality. openAIEmbeddingModel :: Text -> EmbeddingModel openAIEmbeddingModel mid = - _EmbeddingModel + emptyEmbeddingModel { modelId = mid, baseUrl = "https://api.openai.com", dimensions = Nothing, @@ -78,6 +82,18 @@ Emb.dimensions = dimensions m } +-- | Extract the first embedding vector from an SDK response. OpenAI's +-- embeddings endpoint normally returns one item per input, but a malformed or +-- compatible endpoint can return an empty @data@ array. Treat that as a typed +-- decode failure instead of indexing the empty vector. +firstEmbedding :: Vector Emb.EmbeddingObject -> Either BaikaiError (Vector Double) +firstEmbedding objs = + case V.uncons objs of + Nothing -> + Left (decodeError "embeddings response contained no data") + Just (obj, _) -> + Right (Emb.embedding obj) + -- | Embed a batch of texts: one vector per input text, in input order. The SDK's -- @CreateEmbeddings.input@ is a single 'Text', so this loops one call per text. The -- transport exception (a Servant client error) is let propagate — error remapping @@ -92,14 +108,22 @@ where embedText create t = do objs <- create (mkEmbeddingRequest m t) - pure (Emb.embedding (V.head objs)) + either throwIO pure (firstEmbedding objs) -- | Embed a single text. embedOne :: EmbeddingModel -> Text -> IO (Vector Double) -embedOne m t = V.head <$> embed m [t] +embedOne m t = do + vs <- embed m [t] + case V.uncons vs of + Just (v, _) -> pure v + Nothing -> throwIO (decodeError "embedding batch unexpectedly returned no vectors") -- | Substitute the OpenAI default for an empty base URL (as the chat provider does). urlOf :: EmbeddingModel -> Text urlOf m = case baseUrl m of "" -> "https://api.openai.com" u -> u + +{-# DEPRECATED _EmbeddingModel "Use emptyEmbeddingModel instead." #-} +_EmbeddingModel :: EmbeddingModel +_EmbeddingModel = emptyEmbeddingModel diff --git a/src/Baikai/Error.hs b/src/Baikai/Error.hs --- a/src/Baikai/Error.hs +++ b/src/Baikai/Error.hs @@ -15,6 +15,8 @@ isRetryable, -- * Pure classification helpers for provider packages + httpError, + parseRetryAfterSeconds, classifyHttpStatus, classifyHttpStatusWithBody, bodyIndicatesOverflow, @@ -34,6 +36,7 @@ import Data.Text (Text) import Data.Text qualified as Text import GHC.Generics (Generic) +import Text.Read (readMaybe) -- | A provider-neutral category for a failed call. Callers switch on -- this to decide policy (retry, surface to user, abort). The set is @@ -162,6 +165,28 @@ RateLimited -> True TransientError -> True _ -> False + +-- | Parse an integer-valued @Retry-After@ header as seconds. HTTP-date +-- values and malformed values yield 'Nothing'. +parseRetryAfterSeconds :: Text -> Maybe Int +parseRetryAfterSeconds raw = do + n <- readMaybe (Text.unpack (Text.strip raw)) + if n >= 0 then Just n else Nothing + +-- | Build a classified error from an HTTP failure's status, optional +-- parsed @Retry-After@ seconds, and response body text. +httpError :: Int -> Maybe Int -> Text -> BaikaiError +httpError status retryAfter body = + (baseError (classifyHttpStatusWithBody status retryAfter body) msg) + { httpStatus = Just status, + retryAfterSeconds = retryAfter + } + where + snippet = Text.take 300 body + msg = + "HTTP " + <> Text.pack (show status) + <> if Text.null snippet then "" else ": " <> snippet -- | Map an HTTP status code (and an optional already-parsed -- retry-after-seconds value) to a category. Pure and network-free so it diff --git a/src/Baikai/Interactive.hs b/src/Baikai/Interactive.hs --- a/src/Baikai/Interactive.hs +++ b/src/Baikai/Interactive.hs @@ -7,11 +7,20 @@ module Baikai.Interactive ( InteractiveProvider (..), InteractiveScope (..), - InteractiveLaunchRequest (..), + InteractiveLaunchRequest, + systemPrompt, + userPrompt, + modelId, + workingDir, + extraDirs, + safety, + extraArgs, InteractiveSafety (..), CodexSandboxMode (..), CodexApprovalPolicy (..), InteractiveLaunchResult (..), + interactiveLaunchRequest, + interactiveLaunchResult, _InteractiveLaunchRequest, _InteractiveLaunchResult, renderInteractiveProvider, @@ -43,7 +52,7 @@ data InteractiveLaunchRequest = InteractiveLaunchRequest { systemPrompt :: !(Maybe Text), userPrompt :: !Text, - model :: !(Maybe Text), + modelId :: !(Maybe Text), workingDir :: !(Maybe FilePath), extraDirs :: ![FilePath], safety :: !InteractiveSafety, @@ -80,24 +89,32 @@ } deriving stock (Eq, Show, Generic) -_InteractiveLaunchRequest :: Text -> InteractiveLaunchRequest -_InteractiveLaunchRequest prompt = +interactiveLaunchRequest :: Text -> InteractiveLaunchRequest +interactiveLaunchRequest prompt = InteractiveLaunchRequest { systemPrompt = Nothing, userPrompt = prompt, - model = Nothing, + modelId = Nothing, workingDir = Nothing, extraDirs = [], safety = DefaultSafety, extraArgs = [] } -_InteractiveLaunchResult :: InteractiveProvider -> ExitCode -> InteractiveLaunchResult -_InteractiveLaunchResult p code = +interactiveLaunchResult :: InteractiveProvider -> ExitCode -> InteractiveLaunchResult +interactiveLaunchResult p code = InteractiveLaunchResult { provider = p, exitCode = code } + +{-# DEPRECATED _InteractiveLaunchRequest "Use interactiveLaunchRequest instead." #-} +_InteractiveLaunchRequest :: Text -> InteractiveLaunchRequest +_InteractiveLaunchRequest = interactiveLaunchRequest + +{-# DEPRECATED _InteractiveLaunchResult "Use interactiveLaunchResult instead." #-} +_InteractiveLaunchResult :: InteractiveProvider -> ExitCode -> InteractiveLaunchResult +_InteractiveLaunchResult = interactiveLaunchResult renderInteractiveProvider :: InteractiveProvider -> Text renderInteractiveProvider InteractiveClaude = "claude" diff --git a/src/Baikai/Message.hs b/src/Baikai/Message.hs --- a/src/Baikai/Message.hs +++ b/src/Baikai/Message.hs @@ -3,17 +3,17 @@ -- A 'Message' is one of three constructors: -- -- * 'UserMessage' — caller input, carrying a 'UserPayload' (its --- 'content' is a vector of text and inline image blocks, plus a --- creation timestamp). +-- 'content' is a vector of text and inline image blocks, plus an +-- optional creation timestamp). -- * 'AssistantMessage' — model output, carrying an 'AssistantPayload' -- (its 'content' holds 'AssistantText', 'AssistantThinking', and -- 'AssistantToolCall' blocks, alongside the call's 'Usage' (which now -- embeds 'Cost' in-place), the 'StopReason' the model reported, an --- optional 'errorMessage', and a timestamp). +-- optional 'errorMessage', and an optional timestamp). -- * 'ToolResultMessage' — caller-supplied output for a model-issued -- tool call, carrying a 'ToolResultPayload' (the tool-call id it -- answers, the tool's name, the result 'content' (text or image), an --- 'isError' flag, and a timestamp). +-- 'isError' flag, and an optional timestamp). -- -- The 'system' constructor from prior versions is removed: system -- prompts live on 'Baikai.Request.Request.systemPrompt'. The 'Role' @@ -70,7 +70,7 @@ UserContent (..), ) import Baikai.StopReason (StopReason (..)) -import Baikai.Usage (Usage, _Usage) +import Baikai.Usage (Usage, zeroUsage) import Data.Aeson (ToJSON) import Data.Text (Text) import Data.Time (UTCTime, getCurrentTime) @@ -85,11 +85,11 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) --- | Caller input: a vector of text and inline image blocks plus a --- creation timestamp. +-- | Caller input: a vector of text and inline image blocks plus an +-- optional creation timestamp. data UserPayload = UserPayload { content :: !(Vector UserContent), - timestamp :: !UTCTime + timestamp :: !(Maybe UTCTime) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) @@ -97,26 +97,28 @@ -- | Model output: the assistant content blocks ('AssistantText', -- 'AssistantThinking', 'AssistantToolCall'), the call's 'Usage' (which -- embeds 'Cost' in-place), the reported 'StopReason', an optional --- 'errorMessage', and a creation timestamp. +-- 'errorMessage' (failure text or a non-fatal provider diagnostic; +-- use 'stopReason'/'Response.errorInfo' to detect failures), and a +-- optional creation timestamp. data AssistantPayload = AssistantPayload { content :: !(Vector AssistantContent), usage :: !Usage, stopReason :: !StopReason, errorMessage :: !(Maybe Text), - timestamp :: !UTCTime + timestamp :: !(Maybe UTCTime) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) -- | Caller-supplied output for a model-issued tool call: the tool-call -- id it answers, the tool's name, the result 'content' (text or --- image), an 'isError' flag, and a creation timestamp. +-- image), an 'isError' flag, and an optional creation timestamp. data ToolResultPayload = ToolResultPayload { toolCallId :: !Text, toolName :: !Text, content :: !(Vector ToolResultContent), isError :: !Bool, - timestamp :: !UTCTime + timestamp :: !(Maybe UTCTime) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) @@ -134,14 +136,16 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) -defaultTimestamp :: UTCTime -defaultTimestamp = read "2000-01-01 00:00:00 UTC" - --- | Build a one-text-block user message with a deterministic fixture --- timestamp. Prefer 'userAt' when the timestamp matters, or 'userNow' --- when the timestamp should be sampled in 'IO'. +-- | Build a one-text-block user message without recording a timestamp. +-- Prefer 'userAt' when the timestamp matters, or 'userNow' when the +-- timestamp should be sampled in 'IO'. user :: Text -> Message -user = userAt defaultTimestamp +user t = + UserMessage + UserPayload + { content = V.singleton (UserText (TextContent t)), + timestamp = Nothing + } -- | Build a one-text-block user message at an explicit timestamp. userAt :: UTCTime -> Text -> Message @@ -149,7 +153,7 @@ UserMessage UserPayload { content = V.singleton (UserText (TextContent t)), - timestamp = ts + timestamp = Just ts } -- | Build a one-text-block user message using the current time. @@ -159,9 +163,17 @@ pure (userAt now t) -- | Build a user message carrying one inline image alongside optional --- preceding text, using a deterministic fixture timestamp. +-- preceding text, without recording a timestamp. userImage :: ImageContent -> Maybe Text -> Message -userImage = userImageAt defaultTimestamp +userImage img mPrefix = + let prefix = case mPrefix of + Nothing -> V.empty + Just t -> V.singleton (UserText (TextContent t)) + in UserMessage + UserPayload + { content = prefix <> V.singleton (UserImage img), + timestamp = Nothing + } -- | Build a user image message at an explicit timestamp. Bytes are -- stored decoded; the JSON encoding base64-encodes them on the wire. @@ -173,7 +185,7 @@ in UserMessage UserPayload { content = prefix <> V.singleton (UserImage img), - timestamp = ts + timestamp = Just ts } -- | Build a user image message using the current time. @@ -182,10 +194,18 @@ now <- getCurrentTime pure (userImageAt now img mPrefix) --- | Build a one-text-block assistant message with zero usage and a --- @stop@ stop reason, using a deterministic fixture timestamp. +-- | Build a one-text-block assistant message with zero usage, a @stop@ +-- stop reason, and no recorded timestamp. assistant :: Text -> Message -assistant = assistantAt defaultTimestamp +assistant t = + AssistantMessage + AssistantPayload + { content = V.singleton (AssistantText (TextContent t)), + usage = zeroUsage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = Nothing + } -- | Build a one-text-block assistant message at an explicit timestamp. assistantAt :: UTCTime -> Text -> Message @@ -193,10 +213,10 @@ AssistantMessage AssistantPayload { content = V.singleton (AssistantText (TextContent t)), - usage = _Usage, + usage = zeroUsage, stopReason = Stop, errorMessage = Nothing, - timestamp = ts + timestamp = Just ts } -- | Build a one-text-block assistant message using the current time. @@ -206,10 +226,17 @@ pure (assistantAt now t) -- | Build a tool-result message answering a prior 'AssistantToolCall' --- using rich content blocks and a deterministic fixture timestamp. +-- using rich content blocks, without recording a timestamp. toolResultMessage :: Text -> Text -> ToolResult -> Message -toolResultMessage callId name = - toolResultMessageAt defaultTimestamp callId name +toolResultMessage callId name ToolResult {content = blocks, isError = err} = + ToolResultMessage + ToolResultPayload + { toolCallId = callId, + toolName = name, + content = blocks, + isError = err, + timestamp = Nothing + } -- | Build a tool-result message at an explicit timestamp. toolResultMessageAt :: UTCTime -> Text -> Text -> ToolResult -> Message @@ -220,7 +247,7 @@ toolName = name, content = blocks, isError = err, - timestamp = ts + timestamp = Just ts } -- | Build a tool-result message using the current time. @@ -251,7 +278,14 @@ -- when the result has multiple blocks or image content. toolResult :: Text -> Text -> Text -> Bool -> Message toolResult callId name body err = - toolResultAt defaultTimestamp callId name body err + toolResultMessage + callId + name + ( ToolResult + { content = V.singleton (ToolResultText (TextContent body)), + isError = err + } + ) -- | Build a one-text-block tool-result message at an explicit timestamp. toolResultAt :: UTCTime -> Text -> Text -> Text -> Bool -> Message diff --git a/src/Baikai/Model.hs b/src/Baikai/Model.hs --- a/src/Baikai/Model.hs +++ b/src/Baikai/Model.hs @@ -7,16 +7,30 @@ -- placeholder until EP-5 populates the real shims). -- -- The previous newtype @Model = Model Text@ — a thin tag for the --- model id — is retired. The 'unModel' accessor is preserved as a --- convenience until callers fully migrate to 'modelId'. +-- model id — is retired. Use 'modelId' to read the selected upstream +-- model identifier, or 'mkModel' to build a dispatchable record. module Baikai.Model ( -- * Model - Model (..), + Model, + modelId, + name, + api, + provider, + baseUrl, + reasoning, + input, + cost, + contextWindow, + maxOutputTokens, + headers, + compat, + emptyModel, _Model, - unModel, + mkModel, -- * Cost rates ModelCost (..), + zeroModelCost, _ModelCost, -- * Capabilities @@ -29,12 +43,13 @@ ) where -import Baikai.Api (Api (..)) +import Baikai.Api (Api (..), renderApi) import Baikai.Compat - ( AnthropicMessagesCompat, + ( AnthropicMessagesCompat (..), OpenAICompletionsCompat, autoDetectAnthropicMessages, autoDetectOpenAICompletions, + defaultAnthropicThinkingStyle, ) import Data.Aeson (FromJSON, ToJSON) import Data.Map.Strict (Map) @@ -90,7 +105,10 @@ anthropicMessagesCompatFor :: Model -> AnthropicMessagesCompat anthropicMessagesCompatFor m = case compat m of CompatAnthropicMessages c -> c - _ -> autoDetectAnthropicMessages (baseUrl m) + _ -> + (autoDetectAnthropicMessages (baseUrl m)) + { thinkingStyle = defaultAnthropicThinkingStyle (modelId m) + } -- | The data record baikai dispatches on. data Model = Model @@ -110,15 +128,10 @@ deriving stock (Eq, Show, Generic) deriving anyclass (FromJSON, ToJSON) --- | The model id as 'Text'. Kept for ergonomic access from call --- sites that previously held a newtype-wrapped 'Text'. -unModel :: Model -> Text -unModel = modelId - -- | A zero 'ModelCost' across all rates. Useful as a default for -- models without published pricing (CLI providers, custom hosts). -_ModelCost :: ModelCost -_ModelCost = +zeroModelCost :: ModelCost +zeroModelCost = ModelCost { inputCost = 0, outputCost = 0, @@ -128,8 +141,8 @@ -- | A blank 'Model'. Useful as a record-update base for hand-rolled -- 'Model' values in tests and one-shot scripts. -_Model :: Model -_Model = +emptyModel :: Model +emptyModel = Model { modelId = "", name = "", @@ -138,9 +151,31 @@ baseUrl = "", reasoning = False, input = [InputText], - cost = _ModelCost, + cost = zeroModelCost, contextWindow = 0, maxOutputTokens = 0, headers = Map.empty, compat = CompatNone } + +-- | Build a dispatchable 'Model' from its three discriminators: the +-- 'Api' tag used for handler lookup, the upstream model id, and the +-- base URL. 'name' defaults to the model id, 'provider' defaults to +-- 'renderApi' of the tag, and all other fields come from 'emptyModel'. +mkModel :: Api -> Text -> Text -> Model +mkModel apiTag modelId_ baseUrl_ = + emptyModel + { modelId = modelId_, + name = modelId_, + api = apiTag, + provider = renderApi apiTag, + baseUrl = baseUrl_ + } + +{-# DEPRECATED _ModelCost "Use zeroModelCost instead." #-} +_ModelCost :: ModelCost +_ModelCost = zeroModelCost + +{-# DEPRECATED _Model "Use emptyModel instead." #-} +_Model :: Model +_Model = emptyModel 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 @@ -8,678 +8,721 @@ import Baikai.Api (Api (..)) import Baikai.Compat - ( AnthropicMessagesCompat (..) - , CacheControlFormat (..) - , MaxTokensField (..) - , OpenAICompletionsCompat (..) - , ThinkingFormat (..) - ) -import Baikai.Model - ( Compat (..) - , InputModality (..) - , Model (..) - , ModelCost (..) - ) -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 - { modelId = "claude-haiku-4-5" - , name = "Claude Haiku 4.5" - , api = AnthropicMessages - , provider = "anthropic" - , baseUrl = "https://api.anthropic.com" - , reasoning = True - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 1 % 1 - , outputCost = 5 % 1 - , cacheReadCost = 1 % 10 - , cacheWriteCost = 5 % 4 - } - , contextWindow = 200000 - , maxOutputTokens = 64000 - , headers = Map.empty - , compat = CompatNone - } - -anthropic_claude_opus_4_5 :: Model -anthropic_claude_opus_4_5 = - Model - { modelId = "claude-opus-4-5" - , name = "Claude Opus 4.5" - , 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 = 200000 - , 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 - { modelId = "claude-opus-4-7" - , name = "Claude Opus 4.7" - , 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_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 = 64000 - , headers = Map.empty - , compat = CompatNone - } - -anthropic_claude_sonnet_4_6 :: Model -anthropic_claude_sonnet_4_6 = - Model - { modelId = "claude-sonnet-4-6" - , name = "Claude Sonnet 4.6" - , 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 = 1000000 - , maxOutputTokens = 64000 - , headers = Map.empty - , compat = CompatNone - } - -deepseek_deepseek_chat :: Model -deepseek_deepseek_chat = - Model - { modelId = "deepseek-chat" - , name = "DeepSeek Chat" - , api = OpenAIChatCompletions - , provider = "deepseek" - , baseUrl = "https://api.deepseek.com" - , reasoning = False - , input = [InputText] - , cost = ModelCost - { inputCost = 27 % 100 - , outputCost = 11 % 10 - , cacheReadCost = 7 % 100 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 64000 - , maxOutputTokens = 8192 - , headers = Map.empty - , compat = CompatNone - } - -deepseek_deepseek_reasoner :: Model -deepseek_deepseek_reasoner = - Model - { modelId = "deepseek-reasoner" - , name = "DeepSeek Reasoner" - , api = OpenAIChatCompletions - , provider = "deepseek" - , baseUrl = "https://api.deepseek.com" - , reasoning = True - , input = [InputText] - , cost = ModelCost - { inputCost = 11 % 20 - , outputCost = 219 % 100 - , cacheReadCost = 7 % 50 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 64000 - , maxOutputTokens = 8192 - , headers = Map.empty - , 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 - { modelId = "gpt-4o" - , name = "GPT-4o" - , api = OpenAIChatCompletions - , provider = "openai" - , baseUrl = "https://api.openai.com" - , reasoning = False - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 5 % 2 - , outputCost = 10 % 1 - , cacheReadCost = 5 % 4 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 128000 - , maxOutputTokens = 16384 - , headers = Map.empty - , compat = CompatNone - } - -openai_gpt_4o_mini :: Model -openai_gpt_4o_mini = - Model - { modelId = "gpt-4o-mini" - , name = "GPT-4o mini" - , api = OpenAIChatCompletions - , provider = "openai" - , baseUrl = "https://api.openai.com" - , reasoning = False - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 3 % 20 - , outputCost = 3 % 5 - , cacheReadCost = 3 % 40 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 128000 - , maxOutputTokens = 16384 - , headers = Map.empty - , 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 = "o1" - , api = OpenAIChatCompletions - , provider = "openai" - , baseUrl = "https://api.openai.com" - , reasoning = True - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 15 % 1 - , outputCost = 60 % 1 - , cacheReadCost = 15 % 2 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 200000 - , maxOutputTokens = 100000 - , headers = Map.empty - , compat = CompatNone - } - -openai_o3 :: Model -openai_o3 = - Model - { 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 = 11 % 10 - , outputCost = 22 % 5 - , cacheReadCost = 11 % 20 - , cacheWriteCost = 0 % 1 - } - , 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 - } - -openrouter_anthropic_claude_sonnet_4 :: Model -openrouter_anthropic_claude_sonnet_4 = - Model - { modelId = "anthropic/claude-sonnet-4" - , name = "Claude Sonnet 4 via OpenRouter" - , api = OpenAIChatCompletions - , provider = "openrouter" - , baseUrl = "https://openrouter.ai/api" - , reasoning = False - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 3 % 1 - , outputCost = 15 % 1 - , cacheReadCost = 3 % 10 - , cacheWriteCost = 15 % 4 - } - , contextWindow = 200000 - , maxOutputTokens = 8192 - , headers = Map.empty - , compat = CompatNone - } - -openrouter_openai_gpt_4o_mini :: Model -openrouter_openai_gpt_4o_mini = - Model - { modelId = "openai/gpt-4o-mini" - , name = "GPT-4o mini via OpenRouter" - , api = OpenAIChatCompletions - , provider = "openrouter" - , baseUrl = "https://openrouter.ai/api" - , reasoning = False - , input = [InputText, InputImage] - , cost = ModelCost - { inputCost = 3 % 20 - , outputCost = 3 % 5 - , cacheReadCost = 3 % 40 - , cacheWriteCost = 0 % 1 - } - , contextWindow = 128000 - , maxOutputTokens = 16384 - , headers = Map.empty - , compat = CompatNone - } - + ( AnthropicThinkingStyle (..), + CacheControlFormat (..), + MaxTokensField (..), + ThinkingFormat (..), + defaultAnthropicMessagesCompat, + defaultOpenAICompletionsCompat, + ) +import Baikai.Model + ( Compat (..), + InputModality (..), + Model, + ModelCost (..), + api, + baseUrl, + compat, + contextWindow, + cost, + emptyModel, + headers, + input, + maxOutputTokens, + modelId, + name, + provider, + reasoning, + ) +import Data.Map.Strict qualified as Map +import Data.Ratio ((%)) + +anthropic_claude_fable_5 :: Model +anthropic_claude_fable_5 = + emptyModel + { 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 = + emptyModel + { modelId = "claude-haiku-4-5", + name = "Claude Haiku 4.5", + api = AnthropicMessages, + provider = "anthropic", + baseUrl = "https://api.anthropic.com", + reasoning = True, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 1 % 1, + outputCost = 5 % 1, + cacheReadCost = 1 % 10, + cacheWriteCost = 5 % 4 + }, + contextWindow = 200000, + maxOutputTokens = 64000, + headers = Map.empty, + compat = CompatNone + } + +anthropic_claude_opus_4_5 :: Model +anthropic_claude_opus_4_5 = + emptyModel + { modelId = "claude-opus-4-5", + name = "Claude Opus 4.5", + 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 = 200000, + maxOutputTokens = 64000, + headers = Map.empty, + compat = CompatNone + } + +anthropic_claude_opus_4_6 :: Model +anthropic_claude_opus_4_6 = + emptyModel + { 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 = + emptyModel + { modelId = "claude-opus-4-7", + name = "Claude Opus 4.7", + 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_8 :: Model +anthropic_claude_opus_4_8 = + emptyModel + { 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 = + emptyModel + { 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 = 64000, + headers = Map.empty, + compat = CompatNone + } + +anthropic_claude_sonnet_4_6 :: Model +anthropic_claude_sonnet_4_6 = + emptyModel + { modelId = "claude-sonnet-4-6", + name = "Claude Sonnet 4.6", + 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 = 1000000, + maxOutputTokens = 64000, + headers = Map.empty, + compat = CompatNone + } + +deepseek_deepseek_chat :: Model +deepseek_deepseek_chat = + emptyModel + { modelId = "deepseek-chat", + name = "DeepSeek Chat", + api = OpenAIChatCompletions, + provider = "deepseek", + baseUrl = "https://api.deepseek.com", + reasoning = False, + input = [InputText], + cost = + ModelCost + { inputCost = 27 % 100, + outputCost = 11 % 10, + cacheReadCost = 7 % 100, + cacheWriteCost = 0 % 1 + }, + contextWindow = 64000, + maxOutputTokens = 8192, + headers = Map.empty, + compat = CompatNone + } + +deepseek_deepseek_reasoner :: Model +deepseek_deepseek_reasoner = + emptyModel + { modelId = "deepseek-reasoner", + name = "DeepSeek Reasoner", + api = OpenAIChatCompletions, + provider = "deepseek", + baseUrl = "https://api.deepseek.com", + reasoning = True, + input = [InputText], + cost = + ModelCost + { inputCost = 11 % 20, + outputCost = 219 % 100, + cacheReadCost = 7 % 50, + cacheWriteCost = 0 % 1 + }, + contextWindow = 64000, + maxOutputTokens = 8192, + headers = Map.empty, + compat = CompatNone + } + +openai_gpt_4_1 :: Model +openai_gpt_4_1 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { modelId = "gpt-4o", + name = "GPT-4o", + api = OpenAIChatCompletions, + provider = "openai", + baseUrl = "https://api.openai.com", + reasoning = False, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 5 % 2, + outputCost = 10 % 1, + cacheReadCost = 5 % 4, + cacheWriteCost = 0 % 1 + }, + contextWindow = 128000, + maxOutputTokens = 16384, + headers = Map.empty, + compat = CompatNone + } + +openai_gpt_4o_mini :: Model +openai_gpt_4o_mini = + emptyModel + { modelId = "gpt-4o-mini", + name = "GPT-4o mini", + api = OpenAIChatCompletions, + provider = "openai", + baseUrl = "https://api.openai.com", + reasoning = False, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 3 % 20, + outputCost = 3 % 5, + cacheReadCost = 3 % 40, + cacheWriteCost = 0 % 1 + }, + contextWindow = 128000, + maxOutputTokens = 16384, + headers = Map.empty, + compat = CompatNone + } + +openai_gpt_5 :: Model +openai_gpt_5 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { 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 = + emptyModel + { modelId = "o1", + name = "o1", + api = OpenAIChatCompletions, + provider = "openai", + baseUrl = "https://api.openai.com", + reasoning = True, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 15 % 1, + outputCost = 60 % 1, + cacheReadCost = 15 % 2, + cacheWriteCost = 0 % 1 + }, + contextWindow = 200000, + maxOutputTokens = 100000, + headers = Map.empty, + compat = CompatNone + } + +openai_o3 :: Model +openai_o3 = + emptyModel + { 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 = + emptyModel + { modelId = "o3-mini", + name = "o3-mini", + api = OpenAIChatCompletions, + provider = "openai", + baseUrl = "https://api.openai.com", + reasoning = True, + input = [InputText], + cost = + ModelCost + { inputCost = 11 % 10, + outputCost = 22 % 5, + cacheReadCost = 11 % 20, + cacheWriteCost = 0 % 1 + }, + contextWindow = 200000, + maxOutputTokens = 100000, + headers = Map.empty, + compat = CompatNone + } + +openai_o4_mini :: Model +openai_o4_mini = + emptyModel + { 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 + } + +openrouter_anthropic_claude_sonnet_4 :: Model +openrouter_anthropic_claude_sonnet_4 = + emptyModel + { modelId = "anthropic/claude-sonnet-4", + name = "Claude Sonnet 4 via OpenRouter", + api = OpenAIChatCompletions, + provider = "openrouter", + baseUrl = "https://openrouter.ai/api", + reasoning = False, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 3 % 1, + outputCost = 15 % 1, + cacheReadCost = 3 % 10, + cacheWriteCost = 15 % 4 + }, + contextWindow = 200000, + maxOutputTokens = 8192, + headers = Map.empty, + compat = CompatNone + } + +openrouter_openai_gpt_4o_mini :: Model +openrouter_openai_gpt_4o_mini = + emptyModel + { modelId = "openai/gpt-4o-mini", + name = "GPT-4o mini via OpenRouter", + api = OpenAIChatCompletions, + provider = "openrouter", + baseUrl = "https://openrouter.ai/api", + reasoning = False, + input = [InputText, InputImage], + cost = + ModelCost + { inputCost = 3 % 20, + outputCost = 3 % 5, + cacheReadCost = 3 % 40, + cacheWriteCost = 0 % 1 + }, + contextWindow = 128000, + maxOutputTokens = 16384, + headers = Map.empty, + compat = CompatNone + } diff --git a/src/Baikai/Options.hs b/src/Baikai/Options.hs --- a/src/Baikai/Options.hs +++ b/src/Baikai/Options.hs @@ -1,12 +1,31 @@ -- | The 'Options' record — the per-call knobs that vary between -- requests on the same conversation. -- --- 'apiKey' is 'Nothing' by default; the registered handler then --- consults a provider-specific env var --- (@ANTHROPIC_API_KEY@ for Anthropic, @OPENAI_API_KEY@ for OpenAI). +-- 'apiKey' is 'Nothing' by default; API providers then consult the +-- host-specific env var from 'Baikai.Auth.defaultApiKeyEnvForBaseUrl' +-- after substituting their default base URL. Unknown hosts require an +-- explicit key source instead of falling back to another provider's +-- credential. -- 'maxTokens' defaults to 'Nothing'; the handler falls back to the -- chosen model's 'Baikai.Model.maxOutputTokens'. +-- 'topP' and 'stopSequences' are honored by the Anthropic and +-- OpenAI-compatible API providers. 'seed', 'frequencyPenalty', and +-- 'presencePenalty' are honored by the OpenAI-compatible API +-- provider. Providers with no corresponding upstream parameter +-- silently omit the field, matching the existing drop policy for +-- unsupported per-call knobs on CLI providers. -- +-- 'timeoutMs' is a wall-clock bound on the entire API streaming call +-- in the OpenAI and Claude providers: connection setup, response +-- headers, and full stream drain. On expiry the stream terminates +-- in-band with a retryable transient 'Baikai.Error.BaikaiError'. +-- +-- 'headers' are per-call HTTP header overrides for API providers. +-- Provider defaults are built first, then 'Baikai.Model.headers', +-- then this field; later values replace earlier ones by +-- case-insensitive header name, including auth headers for callers +-- intentionally fronting a gateway. +-- -- EP-4 added @toolChoice@. EP-5 adds @cacheRetention@ and @thinking@ -- (provider-agnostic preferences that each provider maps to its own -- primitive — see 'Baikai.CacheRetention' and 'Baikai.ThinkingLevel' @@ -14,7 +33,23 @@ -- provider-agnostic structured-output preference — see -- 'Baikai.ResponseFormat'. module Baikai.Options - ( Options (..), + ( Options, + maxTokens, + temperature, + apiKey, + timeoutMs, + headers, + metadata, + toolChoice, + cacheRetention, + thinking, + responseFormat, + topP, + stopSequences, + seed, + frequencyPenalty, + presencePenalty, + emptyOptions, _Options, ) where @@ -28,6 +63,7 @@ import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map import Data.Text (Text) +import Data.Vector (Vector) import GHC.Generics (Generic) import Numeric.Natural (Natural) @@ -41,13 +77,18 @@ toolChoice :: !(Maybe ToolChoice), cacheRetention :: !(Maybe CacheRetention), thinking :: !(Maybe ThinkingLevel), - responseFormat :: !(Maybe ResponseFormat) + responseFormat :: !(Maybe ResponseFormat), + topP :: !(Maybe Double), + stopSequences :: !(Maybe (Vector Text)), + seed :: !(Maybe Integer), + frequencyPenalty :: !(Maybe Double), + presencePenalty :: !(Maybe Double) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) -_Options :: Options -_Options = +emptyOptions :: Options +emptyOptions = Options { maxTokens = Nothing, temperature = Nothing, @@ -58,5 +99,14 @@ toolChoice = Nothing, cacheRetention = Nothing, thinking = Nothing, - responseFormat = Nothing + responseFormat = Nothing, + topP = Nothing, + stopSequences = Nothing, + seed = Nothing, + frequencyPenalty = Nothing, + presencePenalty = Nothing } + +{-# DEPRECATED _Options "Use emptyOptions instead." #-} +_Options :: Options +_Options = emptyOptions diff --git a/src/Baikai/Prelude.hs b/src/Baikai/Prelude.hs --- a/src/Baikai/Prelude.hs +++ b/src/Baikai/Prelude.hs @@ -7,6 +7,12 @@ -- `Data.Generics.Labels` is imported for its orphan `IsLabel` instance -- only (no values are re-exported); the instance still propagates to -- anything that imports this Prelude. +-- +-- This module is a convenience prelude, not a PVP-stable public API +-- contract. Its re-export set follows baikai's internal needs and may +-- change when upstream prelude, lens, or generic-lens usage changes. +-- Application code that needs a stable import surface should import +-- the upstream modules it uses directly. module Baikai.Prelude ( -- * Lens vocabulary module Control.Lens, diff --git a/src/Baikai/Provider.hs b/src/Baikai/Provider.hs --- a/src/Baikai/Provider.hs +++ b/src/Baikai/Provider.hs @@ -13,25 +13,35 @@ ( ApiProvider (..), ProviderRegistry, newProviderRegistry, + newProviderRegistryFrom, globalProviderRegistry, registerApiProviderWith, registerApiProvider, + assertRegistered, lookupApiProviderWith, lookupApiProvider, completeRequestWith, completeRequest, + runToolLoopWith, + runToolLoop, + completeText, ) where import Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, + assertRegistered, completeRequest, completeRequestWith, + completeText, globalProviderRegistry, lookupApiProvider, lookupApiProviderWith, newProviderRegistry, + newProviderRegistryFrom, registerApiProvider, registerApiProviderWith, + runToolLoop, + runToolLoopWith, ) 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 @@ -2,11 +2,13 @@ -- and @baikai-openai@. -- -- Not re-exported from "Baikai"; vendor packages import this module --- directly. Anything exported here is considered part of the core --- library's interface to the CLI provider packages and should not be --- relied on by application code. +-- directly. This is an internal interface and is not covered by PVP +-- stability guarantees: names, types, and semantics may change in +-- minor releases. Application code should use the public provider +-- modules instead. module Baikai.Provider.Cli.Internal ( renderPrompt, + wrapSystemPrompt, maybeApply, decodeUtf8Lenient, extractAgentMessage, @@ -92,6 +94,23 @@ where pickT (ToolResultText (TextContent t)) = Just t pickT _ = Nothing + +-- | Wrap a rendered prompt with a system-instruction preamble for +-- CLIs that expose no native system-prompt flag. 'Nothing' and +-- blank system prompts return the body unchanged. The textual +-- format is shared by the codex batch provider and the codex +-- interactive launcher. +wrapSystemPrompt :: Maybe Text -> Text -> Text +wrapSystemPrompt msp body = case Text.strip <$> msp of + Nothing -> body + Just "" -> body + Just sp -> + Text.concat + [ "System instructions:\n", + sp, + "\n\nUser request:\n", + body + ] -- | @maybeApply ma f x@ applies @f a x@ when @ma = Just a@, -- otherwise returns @x@. Useful for threading optional configuration 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,34 +9,49 @@ -- 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 a 'Baikai.Error.BaikaiError' in the --- 'Baikai.Error.ProviderUnavailable' category when no handler is --- registered for that tag. +-- tag and dispatches; when no handler is registered it returns an +-- error-shaped 'Response' in the 'Baikai.Error.ProviderUnavailable' +-- category. module Baikai.Provider.Registry ( ApiProvider (..), ProviderRegistry, newProviderRegistry, + newProviderRegistryFrom, globalProviderRegistry, registerApiProviderWith, registerApiProvider, + assertRegistered, lookupApiProviderWith, lookupApiProvider, completeRequestWith, completeRequest, + runToolLoopWith, + runToolLoop, + completeText, ) where import Baikai.Api (Api, renderApi) -import Baikai.Context (Context) +import Baikai.Content (AssistantContent (..), ToolCall) +import Baikai.Context (Context, appendToolResult, contextOf) import Baikai.Error (providerUnavailable) -import Baikai.Model (Model (..)) -import Baikai.Options (Options) -import Baikai.Response (Response) +import Baikai.Message (AssistantPayload (..), ToolResult, toolResultErrorText, user) +import Baikai.Model (Model) +import Baikai.Model qualified as Model +import Baikai.Options (Options, emptyOptions) +import Baikai.Response (Response (..), errorResponse, flattenAssistantBlocks, flattenAssistantText, responseError) +import Baikai.StopReason (StopReason (..)) import Baikai.Stream.Event (AssistantMessageEvent) -import Control.Exception (throwIO) +import Control.Exception qualified as Exception +import Control.Monad (forM, unless) +import Data.Foldable (traverse_) import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map +import Data.Text (Text) +import Data.Text qualified as Text +import Data.Time (getCurrentTime) +import Data.Vector qualified as Vector import Streamly.Data.Stream (Stream) import System.IO.Unsafe (unsafePerformIO) @@ -59,6 +74,14 @@ newProviderRegistry :: IO ProviderRegistry newProviderRegistry = ProviderRegistry <$> newIORef Map.empty +-- | Construct a registry pre-populated with the given providers. Later entries +-- win on tag collisions, matching 'registerApiProviderWith'. +newProviderRegistryFrom :: [ApiProvider] -> IO ProviderRegistry +newProviderRegistryFrom providers = do + reg <- newProviderRegistry + traverse_ (registerApiProviderWith reg) providers + pure reg + -- | Process-global handler registry used by the legacy convenience functions. -- The 'unsafePerformIO' + 'NOINLINE' pattern mirrors 'Baikai.Trace'\'s -- @eventCounter@; this is a single shared handle for the lifetime of the @@ -78,6 +101,25 @@ registerApiProvider :: ApiProvider -> IO () registerApiProvider = registerApiProviderWith globalProviderRegistry +-- | Startup preflight: throw 'Baikai.Error.ProviderUnavailable' listing every +-- requested API tag that has no registered handler. +assertRegistered :: ProviderRegistry -> [Api] -> IO () +assertRegistered reg tags = do + missing <- + fmap concat $ + forM tags $ \tag -> do + found <- lookupApiProviderWith reg tag + pure $ case found of + Nothing -> [tag] + Just _ -> [] + unless (null missing) $ + Exception.throwIO + ( providerUnavailable + ( "no provider registered for: " + <> Text.intercalate ", " (renderApi <$> missing) + ) + ) + -- | Look up the handler registered for an 'Api' tag. lookupApiProviderWith :: ProviderRegistry -> Api -> IO (Maybe ApiProvider) lookupApiProviderWith reg tag = Map.lookup tag <$> readIORef (registryRef reg) @@ -88,17 +130,107 @@ lookupApiProvider = lookupApiProviderWith globalProviderRegistry -- | Dispatch a synchronous request through the registered handler --- for the model's 'Api' tag. Throws a 'ProviderUnavailable' error when no handler --- is registered for that tag. +-- for the model's 'Api' tag. Returns an error-shaped 'Response' when +-- no handler is registered for that tag. completeRequestWith :: ProviderRegistry -> Model -> Context -> Options -> IO Response completeRequestWith reg m ctx opts = do - mProvider <- lookupApiProviderWith reg (api m) + mProvider <- lookupApiProviderWith reg (Model.api m) case mProvider of Just p -> complete p m ctx opts - Nothing -> - throwIO $ - providerUnavailable ("No provider registered for API: " <> renderApi (api m)) + Nothing -> do + now <- getCurrentTime + pure $ + errorResponse + m + now + 0 + (providerUnavailable ("No provider registered for API: " <> renderApi (Model.api m))) -- | Dispatch a synchronous request through the process-global registry. completeRequest :: Model -> Context -> Options -> IO Response completeRequest = completeRequestWith globalProviderRegistry + +-- | Drive a tool-using conversation through the process-global registry. +-- +-- The returned 'Context' contains the input context plus only fully resolved +-- assistant/tool-result exchanges, so it is always valid to replay. The final +-- 'Response' is not appended; callers that want the full transcript can use +-- 'Baikai.Context.addResponse'. 'Options' is passed unchanged each turn, so +-- forcing tools in options can exhaust the budget; loops should usually let +-- the provider choose tools automatically. +runToolLoop :: + Int -> + (ToolCall -> IO ToolResult) -> + Model -> + Context -> + Options -> + IO (Context, Response) +runToolLoop = runToolLoopWith globalProviderRegistry + +-- | Drive a tool-using conversation through an explicit registry. +-- +-- The turn budget is clamped to at least one model call. Synchronous dispatcher +-- exceptions become error tool results so the model can recover; asynchronous +-- exceptions are rethrown. Dispatchers should return 'toolResultErrorText' for +-- unknown tool names rather than throwing. +runToolLoopWith :: + ProviderRegistry -> + Int -> + (ToolCall -> IO ToolResult) -> + Model -> + Context -> + Options -> + IO (Context, Response) +runToolLoopWith reg budget dispatcher model ctx0 opts = + go (max 1 budget) ctx0 + where + go remaining ctx = do + resp <- completeRequestWith reg model ctx opts + if shouldStop remaining resp + then pure (ctx, resp) + else do + ctx' <- appendToolResult ctx resp (safeDispatcher dispatcher) + go (remaining - 1) ctx' + + shouldStop remaining resp = + responseError resp /= Nothing + || responseStopReason resp /= ToolUse + || Vector.null (responseToolCalls resp) + || remaining <= 1 + +-- | One-shot text completion through the global registry. Throws the +-- 'Baikai.Error.BaikaiError' when the response is error-shaped. +completeText :: Model -> Text -> IO Text +completeText model prompt = do + resp <- completeRequest model (contextOf [user prompt]) emptyOptions + case responseError resp of + Just err -> Exception.throwIO err + Nothing -> pure (flattenAssistantText (flattenAssistantBlocks resp)) + +safeDispatcher :: (ToolCall -> IO ToolResult) -> ToolCall -> IO ToolResult +safeDispatcher dispatcher tc = do + result <- trySync (dispatcher tc) + case result of + Right ok -> pure ok + Left e -> pure (toolResultErrorText (Text.pack (Exception.displayException e))) + +trySync :: IO a -> IO (Either Exception.SomeException a) +trySync action = do + result <- Exception.try action + case result of + Left e + | Just (Exception.SomeAsyncException _) <- + (Exception.fromException e :: Maybe Exception.SomeAsyncException) -> + Exception.throwIO e + | otherwise -> pure (Left e) + Right a -> pure (Right a) + +responseStopReason :: Response -> StopReason +responseStopReason Response {message = AssistantPayload {stopReason = sr}} = sr + +responseToolCalls :: Response -> Vector.Vector ToolCall +responseToolCalls Response {message = AssistantPayload {content = blocks}} = + Vector.mapMaybe toolCallOf blocks + where + toolCallOf (AssistantToolCall tc) = Just tc + toolCallOf _ = Nothing diff --git a/src/Baikai/Response.hs b/src/Baikai/Response.hs --- a/src/Baikai/Response.hs +++ b/src/Baikai/Response.hs @@ -5,26 +5,34 @@ -- 'Baikai.Api'), the input 'Model' echoed back, the provider name, -- an optional 'responseId', and the measured 'latencyMs'. The -- 'message' carries only assistant content blocks, 'Usage' (with --- 'Cost' embedded), 'StopReason', optional error text, and timestamp. +-- 'Cost' embedded), 'StopReason', optional error text, and an optional +-- timestamp. -- --- 'flattenAssistantBlocks' is a convenience accessor that flattens --- the message's content blocks. +-- 'flattenAssistantBlocks' and 'flattenAssistantText' are convenience +-- accessors for the message's content blocks. module Baikai.Response ( Response (..), + emptyResponse, _Response, responseMessage, flattenAssistantBlocks, + flattenAssistantText, + responseError, + errorResponse, ) where import Baikai.Api (Api (..)) -import Baikai.Content (AssistantContent) -import Baikai.Error (BaikaiError) +import Baikai.Content (AssistantContent (..), TextContent (..)) +import Baikai.Error (BaikaiError, providerError) +import Baikai.Error qualified as Error import Baikai.Message (AssistantPayload (..), Message (..)) -import Baikai.Model (Model, _Model) +import Baikai.Model (Model, emptyModel) +import Baikai.Model qualified as Model import Baikai.StopReason (StopReason (..)) -import Baikai.Usage (_Usage) +import Baikai.Usage (zeroUsage) import Data.Text (Text) +import Data.Text qualified as Text import Data.Time (UTCTime) import Data.Vector (Vector) import Data.Vector qualified as V @@ -37,13 +45,13 @@ api :: !Api, provider :: !Text, responseId :: !(Maybe Text), - latencyMs :: !Integer, + latencyMs :: !Int, -- | 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. + -- retry-after hint. Conforming providers set this to 'Just' for + -- error-shaped responses and 'Nothing' on success. Use + -- 'responseError' for the normalized failure view; it synthesizes + -- an 'OtherError' if a nonconforming provider omits this field. errorInfo :: !(Maybe BaikaiError) } deriving stock (Eq, Show, Generic) @@ -51,18 +59,18 @@ -- | A blank assistant turn at epoch start. Useful as a fixture base -- for tests and as the default in error paths where no message was -- received. -_Response :: Response -_Response = +emptyResponse :: Response +emptyResponse = Response { message = AssistantPayload { content = V.empty, - usage = _Usage, + usage = zeroUsage, stopReason = Stop, errorMessage = Nothing, - timestamp = read "2000-01-01 00:00:00 UTC" :: UTCTime + timestamp = Nothing }, - model = _Model, + model = emptyModel, api = Custom "", provider = "", responseId = Nothing, @@ -77,3 +85,48 @@ -- | Pull the response's assistant content blocks out. flattenAssistantBlocks :: Response -> Vector AssistantContent flattenAssistantBlocks Response {message = AssistantPayload {content = c}} = c + +-- | Concatenate all assistant text blocks, ignoring thinking and tool +-- call blocks. +flattenAssistantText :: Vector AssistantContent -> Text +flattenAssistantText = + Text.concat . V.toList . V.mapMaybe textOf + where + textOf (AssistantText (TextContent t)) = Just t + textOf _ = Nothing + +-- | The single question callers ask about failure. Returns 'Just' +-- exactly when the response is error-shaped (@stopReason = +-- ErrorReason@): the provider's classified 'errorInfo' when present, +-- otherwise a synthesized 'OtherError' carrying the response's +-- 'errorMessage' text. +responseError :: Response -> Maybe BaikaiError +responseError Response {message = AssistantPayload {stopReason = sr, errorMessage = em}, errorInfo = ei} + | sr == ErrorReason = Just (maybe (providerError fallback) id ei) + | otherwise = Nothing + where + fallback = maybe "call failed with no error detail" id em + +-- | Build a conformant error-shaped 'Response' for a failed call. +errorResponse :: Model -> UTCTime -> Int -> BaikaiError -> Response +errorResponse m ts latency err = + Response + { message = + AssistantPayload + { content = V.empty, + usage = zeroUsage, + stopReason = ErrorReason, + errorMessage = Just (Error.message err), + timestamp = Just ts + }, + model = m, + api = Model.api m, + provider = Model.provider m, + responseId = Nothing, + latencyMs = latency, + errorInfo = Just err + } + +{-# DEPRECATED _Response "Use emptyResponse instead." #-} +_Response :: Response +_Response = emptyResponse diff --git a/src/Baikai/Stream.hs b/src/Baikai/Stream.hs --- a/src/Baikai/Stream.hs +++ b/src/Baikai/Stream.hs @@ -4,9 +4,9 @@ -- -- 'streamRequest' looks up the per-API handler registered for a -- model's 'Api' tag and returns its event stream. When no handler is --- registered the function returns a one-event error stream (a single --- 'EventError' with @stopReason = ErrorReason@) so a caller iterating --- the stream always gets at least one terminal event. +-- registered the function returns a synthetic 'EventStart' followed by +-- a terminal 'EventError' with @stopReason = ErrorReason@, preserving +-- the protocol that every core-owned stream starts with 'EventStart'. -- -- 'streamingComplete' folds an event stream into the synchronous -- 'Response' shape. Vendor providers register both the @stream@ @@ -17,6 +17,10 @@ module Baikai.Stream ( streamRequest, streamRequestWith, + streamRequestEach, + streamRequestEachWith, + streamRequestList, + streamRequestListWith, streamingComplete, reassembleResponse, liftCompleteToStream, @@ -31,7 +35,7 @@ ) import Baikai.Content qualified as Content import Baikai.Context (Context) -import Baikai.Error (BaikaiError, providerUnavailable) +import Baikai.Error (BaikaiError, providerError, providerUnavailable) import Baikai.Message (AssistantPayload (..), Message (AssistantMessage)) import Baikai.Message qualified as Msg import Baikai.Model (Model) @@ -42,7 +46,7 @@ globalProviderRegistry, lookupApiProviderWith, ) -import Baikai.Response (Response (..), responseMessage) +import Baikai.Response (Response (..), responseError, responseMessage) import Baikai.StopReason (StopReason (..)) import Baikai.Stream.Event ( AssistantMessageEvent (..), @@ -51,11 +55,13 @@ IndexPayload (..), StartPayload (..), TerminalPayload (..), + ThinkingEndPayload (..), ToolCallEndPayload (..), doneTerminal, errorTerminal, ) -import Baikai.Usage (_Usage) +import Baikai.Usage (zeroUsage) +import Control.Applicative ((<|>)) import Control.Exception (fromException) import Control.Exception qualified import Control.Lens ((%~), (&), (.~), (^.)) @@ -78,9 +84,8 @@ import Streamly.Data.Stream qualified as Stream -- | Dispatch a streaming call through the registered handler for the --- model's 'Api' tag. Returns a one-event error stream when no handler --- is registered for that tag — the caller always sees at least one --- terminal event. +-- model's 'Api' tag. Returns an 'EventStart' then 'EventError' stream +-- when no handler is registered for that tag. streamRequest :: Model -> Context -> Options -> Stream IO AssistantMessageEvent streamRequest = streamRequestWith globalProviderRegistry @@ -97,8 +102,54 @@ mProvider <- lookupApiProviderWith reg (m ^. #api) case mProvider of Just p -> pure (stream p m ctx opts) - Nothing -> pure (Stream.fromEffect (noProviderEvent m)) + Nothing -> Stream.fromList <$> noProviderEvents m +-- | Stream a request through the process-global registry, invoking the +-- callback once per event, then return the same reassembled 'Response' +-- that 'streamingComplete' would produce. Callback exceptions propagate. +streamRequestEach :: + (AssistantMessageEvent -> IO ()) -> + Model -> + Context -> + Options -> + IO Response +streamRequestEach = streamRequestEachWith globalProviderRegistry + +-- | Stream a request through an explicit registry, invoking the callback once +-- per event. The underlying event protocol is the same as 'streamRequest': +-- provider streams emit exactly one terminal event. +streamRequestEachWith :: + ProviderRegistry -> + (AssistantMessageEvent -> IO ()) -> + Model -> + Context -> + Options -> + IO Response +streamRequestEachWith reg callback m ctx opts = + Stream.fold + (reassembleResponse m) + ( Stream.mapM + ( \event -> do + callback event + pure event + ) + (streamRequestWith reg m ctx opts) + ) + +-- | Collect the event stream from the process-global registry into a list. +streamRequestList :: Model -> Context -> Options -> IO [AssistantMessageEvent] +streamRequestList = streamRequestListWith globalProviderRegistry + +-- | Collect the event stream from an explicit registry into a list. +streamRequestListWith :: + ProviderRegistry -> + Model -> + Context -> + Options -> + IO [AssistantMessageEvent] +streamRequestListWith reg m ctx opts = + Stream.toList (streamRequestWith reg m ctx opts) + -- | Drain an event stream into a 'Response' by folding events into -- the assembled message. streamingComplete :: @@ -115,34 +166,46 @@ -- reassembly logic. reassembleResponse :: Model -> Fold IO AssistantMessageEvent Response reassembleResponse m = - Fold.rmapM finalizeState (Fold.foldl' step (initialState m)) + Fold.rmapM + finalizeState + (Fold.foldlM' (\s e -> pure (step s e)) (initialState m <$> getCurrentTime)) -- | One frozen-in-time view of the partial assembly. data ReassemblyState = ReassemblyState { model :: !Model, -- | 'Just' once 'EventStart' has been observed. skeleton :: !(Maybe Message), - -- | Captured from the EventStart message's timestamp. - startTime :: !(Maybe UTCTime), + -- | Captured by the reassembler when the fold starts driving the stream. + wallStart :: !UTCTime, + -- | Provider message id, preferring the terminal payload over the start payload. + responseId :: !(Maybe Text), -- | Content blocks closed so far, keyed by @contentIndex@. blocks :: !(IntMap AssistantContent), -- | Open text accumulators, indexed by @contentIndex@. textBuf :: !(IntMap Text), thinkBuf :: !(IntMap Text), toolArgsBuf :: !(IntMap Text), - -- | '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)) + -- | 'Just' once 'EventDone' or 'EventError' fires. + terminal :: !(Maybe TerminalSeen) } deriving stock (Show, Generic) -initialState :: Model -> ReassemblyState -initialState m = +-- | What the terminal event told us, plus which terminal it was. +data TerminalSeen = TerminalSeen + { reason :: !StopReason, + message :: !Message, + errorInfo :: !(Maybe BaikaiError), + failed :: !Bool + } + deriving stock (Show, Generic) + +initialState :: Model -> UTCTime -> ReassemblyState +initialState m start = ReassemblyState { model = m, skeleton = Nothing, - startTime = Nothing, + wallStart = start, + responseId = Nothing, blocks = IntMap.empty, textBuf = IntMap.empty, thinkBuf = IntMap.empty, @@ -152,11 +215,8 @@ step :: ReassemblyState -> AssistantMessageEvent -> ReassemblyState step s = \case - EventStart StartPayload {partial = sk} -> - let t = case sk of - AssistantMessage AssistantPayload {Msg.timestamp = ts} -> Just ts - _ -> Nothing - in s & #skeleton .~ Just sk & #startTime .~ t + EventStart StartPayload {partial = sk, responseId = rid} -> + s & #skeleton .~ Just sk & #responseId .~ rid TextStart IndexPayload {contentIndex = i} -> s & #textBuf %~ IntMap.insert i Text.empty TextDelta DeltaPayload {contentIndex = i, delta = d} -> @@ -169,14 +229,12 @@ s & #thinkBuf %~ IntMap.insert i Text.empty ThinkingDelta DeltaPayload {contentIndex = i, delta = d} -> s & #thinkBuf %~ IntMap.insertWith (\new old -> old <> new) i d - ThinkingEnd BlockEndPayload {contentIndex = i, content = body} -> + ThinkingEnd ThinkingEndPayload {contentIndex = i, content = tc} -> s & #blocks %~ IntMap.insert i - ( AssistantThinking - ThinkingContent {thinking = body, signature = Nothing, redacted = False} - ) + (AssistantThinking tc) & #thinkBuf %~ IntMap.delete i ToolCallStart IndexPayload {contentIndex = i} -> s & #toolArgsBuf %~ IntMap.insert i Text.empty @@ -186,55 +244,116 @@ s & #blocks %~ IntMap.insert i (AssistantToolCall tc) & #toolArgsBuf %~ IntMap.delete i - EventDone TerminalPayload {reason = r, message = msg} -> - s & #terminal .~ Just (r, msg, Nothing) - EventError TerminalPayload {reason = r, message = msg, errorInfo = ei} -> - s & #terminal .~ Just (r, msg, ei) + EventDone TerminalPayload {reason = r, message = msg, responseId = rid} -> + s + & #terminal + .~ Just TerminalSeen {reason = r, message = msg, errorInfo = Nothing, failed = False} + & #responseId %~ (\old -> rid <|> old) + EventError TerminalPayload {reason = r, message = msg, responseId = rid, errorInfo = ei} -> + s + & #terminal + .~ Just TerminalSeen {reason = r, message = msg, errorInfo = ei, failed = True} + & #responseId %~ (\old -> rid <|> old) finalizeState :: ReassemblyState -> IO Response finalizeState s = do now <- getCurrentTime let m = s ^. #model - assembled = assembleBlocks s - (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 - Just startTs -> - round (realToFrac (Data.Time.Clock.diffUTCTime endTs startTs) * (1000 :: Double)) - Nothing -> 0 + assembled = assembledBlocks s + dangling = danglingBlocks s + (terminalMsg, terminalReason, terminalError, terminalFailed, sawTerminal) = + case s ^. #terminal of + Just TerminalSeen {reason = r, message = msg, errorInfo = ei, failed = failed'} -> + (msg, r, ei, failed', True) + Nothing -> (synthesizeTerminal now assembled, Stop, Nothing, False, False) + terminalContent = messageContent terminalMsg + normalizedError = case (terminalReason, terminalError) of + (ErrorReason, Nothing) -> Just (providerError (messageErrorText terminalMsg)) + _ -> terminalError + finalContent + | not sawTerminal = assembled + | Vector.null terminalContent = assembled + | terminalFailed = terminalContent <> Vector.fromList (IntMap.elems dangling) + | otherwise = terminalContent + message' = overrideBlocksAndReason terminalReason terminalMsg finalContent now + latency = case (s ^. #skeleton >>= messageTimestamp, assistantPayloadTimestamp message') of + (Just startTs, Just endTs) -> millisBetween startTs endTs + _ -> 0 pure Response { message = message', model = m, api = m ^. #api, provider = m ^. #provider, - responseId = Nothing, + responseId = s ^. #responseId, latencyMs = latency, - errorInfo = terminalError + errorInfo = normalizedError } --- | Project the closed content blocks in 'contentIndex' order, plus --- any still-open text/thinking accumulators flushed as best-effort --- content (recovery path; providers should not exercise this). -assembleBlocks :: ReassemblyState -> Vector AssistantContent -assembleBlocks s = - let closed = IntMap.elems (s ^. #blocks) - danglingText = - [ AssistantText (TextContent t) - | (_, t) <- IntMap.toAscList (s ^. #textBuf), - not (Text.null t) - ] - danglingThink = - [ AssistantThinking - ThinkingContent {thinking = t, signature = Nothing, redacted = False} - | (_, t) <- IntMap.toAscList (s ^. #thinkBuf), - not (Text.null t) - ] - in Vector.fromList (closed <> danglingText <> danglingThink) +-- | Project the event-assembled content in 'contentIndex' order, +-- including still-open buffers as best-effort recovery content. +assembledBlocks :: ReassemblyState -> Vector AssistantContent +assembledBlocks s = + Vector.fromList (IntMap.elems (IntMap.union (s ^. #blocks) (danglingBlocks s))) +-- | Convert any still-open buffers into inspectable content. This is +-- the recovery path for streams that die before an @_End@ event. Partial +-- tool arguments are preserved as decoded JSON when possible, otherwise +-- as an 'Aeson.String' carrying the raw accumulated text. +danglingBlocks :: ReassemblyState -> IntMap AssistantContent +danglingBlocks s = + IntMap.unions + [ IntMap.mapMaybe textBlock (s ^. #textBuf), + IntMap.mapMaybe thinkingBlock (s ^. #thinkBuf), + IntMap.mapMaybe toolBlock (s ^. #toolArgsBuf) + ] + where + textBlock t + | Text.null t = Nothing + | otherwise = Just (AssistantText (TextContent t)) + + thinkingBlock t + | Text.null t = Nothing + | otherwise = + Just (AssistantThinking ThinkingContent {thinking = t, signature = Nothing, redacted = False}) + + toolBlock raw + | Text.null raw = Nothing + | otherwise = + let decoded = case Aeson.eitherDecodeStrict (Text.encodeUtf8 raw) of + Right v -> v + Left _ -> Aeson.String raw + in Just + ( AssistantToolCall + Content.ToolCall + { Content.id_ = "", + Content.name = "", + Content.arguments = decoded + } + ) + +messageContent :: Message -> Vector AssistantContent +messageContent = \case + AssistantMessage AssistantPayload {Msg.content = c} -> c + _ -> Vector.empty + +messageErrorText :: Message -> Text +messageErrorText = \case + AssistantMessage AssistantPayload {Msg.errorMessage = Just em} -> em + _ -> "call failed with no error detail" + +messageTimestamp :: Message -> Maybe UTCTime +messageTimestamp = \case + AssistantMessage AssistantPayload {Msg.timestamp = ts} -> ts + _ -> Nothing + +assistantPayloadTimestamp :: AssistantPayload -> Maybe UTCTime +assistantPayloadTimestamp AssistantPayload {Msg.timestamp = ts} = ts + +millisBetween :: UTCTime -> UTCTime -> Int +millisBetween start end = + max 0 (round (realToFrac (Data.Time.Clock.diffUTCTime end start) * (1000 :: Double))) + -- | Replace the content vector and stop reason of an assistant -- message, preserving usage, errorMessage, and timestamp. overrideBlocksAndReason :: @@ -251,10 +370,10 @@ _ -> AssistantPayload { Msg.content = blocks, - Msg.usage = _Usage, + Msg.usage = zeroUsage, Msg.stopReason = sr, Msg.errorMessage = Just "stream terminated with a non-assistant message", - Msg.timestamp = fallbackTs + Msg.timestamp = Just fallbackTs } -- | Build a placeholder 'AssistantMessage' for streams that ended @@ -264,10 +383,10 @@ AssistantMessage AssistantPayload { Msg.content = blocks, - Msg.usage = _Usage, + Msg.usage = zeroUsage, Msg.stopReason = Stop, Msg.errorMessage = Just "stream ended without terminal event", - Msg.timestamp = now + Msg.timestamp = Just now } -- | Wrap a synchronous @complete@ handler in a one-shot event @@ -283,11 +402,14 @@ -- matching @_Start@ / @_Delta@ / @_End@ trio. Text blocks emit -- one 'TextDelta' with the whole text; tool calls emit one -- 'ToolCallDelta' with the JSON-encoded arguments. --- * 'EventDone' carrying the fully assembled assistant message. +-- * 'EventDone' carrying the fully assembled assistant message, or +-- 'EventError' when the response is error-shaped according to +-- 'responseError'. -- --- An exception from @complete@ becomes a single-'EventError' stream --- with @stopReason = ErrorReason@ and 'errorMessage' set from the --- exception's display. +-- A synchronous exception from @complete@ becomes a synthetic +-- 'EventStart' followed by 'EventError' with @stopReason = ErrorReason@ +-- and 'errorMessage' set from the exception's display. Asynchronous +-- exceptions are rethrown so cancellation works. liftCompleteToStream :: (Model -> Context -> Options -> IO Response) -> Model -> @@ -297,14 +419,26 @@ liftCompleteToStream f m ctx opts = Stream.concatEffect $ do startTs <- getCurrentTime - er <- tryAny (f m ctx opts) + er <- trySync (f m ctx opts) case er of Right resp -> pure (Stream.fromList (eventsFor startTs resp)) - Left e -> pure (Stream.fromEffect (errorEvent e)) + Left e -> Stream.fromList <$> errorEvents e --- | A typed 'try' over any synchronous exception. -tryAny :: IO a -> IO (Either Control.Exception.SomeException a) -tryAny = Control.Exception.try +-- | 'try' for synchronous exceptions only. Anything delivered +-- asynchronously (wrapped in 'Control.Exception.SomeAsyncException' by +-- 'Control.Exception.throwTo', 'System.Timeout.timeout', Ctrl-C) is +-- rethrown so cancellation works; converting it into an 'EventError' +-- would defeat it. +trySync :: IO a -> IO (Either Control.Exception.SomeException a) +trySync action = do + r <- Control.Exception.try action + case r of + Left e + | Just (Control.Exception.SomeAsyncException _) <- + (fromException e :: Maybe Control.Exception.SomeAsyncException) -> + Control.Exception.throwIO e + | otherwise -> pure (Left e) + Right a -> pure (Right a) -- | Build the synthetic event list for a fully resolved 'Response'. -- The 'EventStart' carries the supplied @startTs@ on its message @@ -321,7 +455,7 @@ Msg.usage = payload ^. #usage, Msg.stopReason = payload ^. #stopReason, Msg.errorMessage = payload ^. #errorMessage, - Msg.timestamp = startTs + Msg.timestamp = Just startTs } blocks = Vector.toList (payload ^. #content) blockEvents = @@ -330,9 +464,13 @@ | (i, b) <- zip [0 ..] blocks ] reason = payload ^. #stopReason - in [EventStart StartPayload {partial = skeleton}] + rid = resp ^. #responseId + terminalEvent = case responseError resp of + Just be -> EventError (errorTerminal rid reason msg be) + Nothing -> EventDone (doneTerminal rid reason msg) + in [EventStart StartPayload {partial = skeleton, responseId = rid}] <> blockEvents - <> [EventDone (doneTerminal reason msg)] + <> [terminalEvent] blockEvent :: Int -> AssistantContent -> [AssistantMessageEvent] blockEvent i = \case @@ -341,10 +479,10 @@ TextDelta DeltaPayload {contentIndex = i, delta = t}, TextEnd BlockEndPayload {contentIndex = i, content = t} ] - AssistantThinking ThinkingContent {thinking = t} -> + AssistantThinking th@ThinkingContent {thinking = t} -> [ ThinkingStart IndexPayload {contentIndex = i}, ThinkingDelta DeltaPayload {contentIndex = i, delta = t}, - ThinkingEnd BlockEndPayload {contentIndex = i, content = t} + ThinkingEnd ThinkingEndPayload {contentIndex = i, content = th} ] AssistantToolCall tc -> let argsText = @@ -354,8 +492,8 @@ ToolCallEnd ToolCallEndPayload {contentIndex = i, toolCall = tc} ] -errorEvent :: Control.Exception.SomeException -> IO AssistantMessageEvent -errorEvent e = do +errorEvents :: Control.Exception.SomeException -> IO [AssistantMessageEvent] +errorEvents e = do now <- getCurrentTime -- When a @complete@ handler threw a typed 'BaikaiError' (the CLI, -- 'Baikai.Auth', and registry paths do), preserve it structurally so a @@ -369,17 +507,21 @@ AssistantMessage AssistantPayload { Msg.content = Vector.empty, - Msg.usage = _Usage, + Msg.usage = zeroUsage, Msg.stopReason = ErrorReason, Msg.errorMessage = Just errText, - Msg.timestamp = now + Msg.timestamp = Just now } - pure (EventError (errorTerminal ErrorReason msg mErr)) + err = maybe (providerError errText) id mErr + pure + [ EventStart StartPayload {partial = msg, responseId = Nothing}, + EventError (errorTerminal Nothing ErrorReason msg err) + ] --- | The single 'EventError' value used when no provider is --- registered for the model's API tag. -noProviderEvent :: Model -> IO AssistantMessageEvent -noProviderEvent m = do +-- | The synthetic error stream used when no provider is registered for +-- the model's API tag. +noProviderEvents :: Model -> IO [AssistantMessageEvent] +noProviderEvents m = do now <- getCurrentTime let detail = "No provider registered for API: " <> renderApi (m ^. #api) be = providerUnavailable detail @@ -387,9 +529,12 @@ AssistantMessage AssistantPayload { Msg.content = Vector.empty, - Msg.usage = _Usage, + Msg.usage = zeroUsage, Msg.stopReason = ErrorReason, Msg.errorMessage = Just detail, - Msg.timestamp = now + Msg.timestamp = Just now } - pure (EventError (errorTerminal ErrorReason msg (Just be))) + pure + [ EventStart StartPayload {partial = msg, responseId = Nothing}, + EventError (errorTerminal Nothing ErrorReason msg 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 @@ -8,27 +8,32 @@ -- provider, model id), interleaves per-content-block lifecycle events -- (@_Start@ / @_Delta@ / @_End@) keyed by 'contentIndex', and -- terminates with exactly one 'EventDone' (success) or 'EventError' --- (any failure that bubbled out of the producer). The terminal event --- carries the fully assembled 'AssistantMessage' so a consumer that --- only pattern-matches on the terminal event still gets a correct --- response without folding deltas. +-- (any failure that bubbled out of the producer). This EventStart-first +-- invariant includes error-only streams produced by core dispatch and +-- request-preparation failures; they emit a synthetic skeleton before +-- the terminal error. One temporary provider-side gap remains: a Claude +-- mid-call failure before @message_start@ can still terminate without a +-- start event until the EP-7 Claude streaming rewrite pre-seeds its +-- skeleton. The terminal event carries the fully assembled +-- 'AssistantMessage' so a consumer that only pattern-matches on the +-- terminal event still gets a correct response without folding deltas. -- --- The algebra is closed and shared by every provider in baikai 0.1. --- Adding a new variant is a breaking change to baikai's public --- surface. Consumers that prefer source resilience over exhaustiveness --- can include a final wildcard branch in their pattern match, but --- providers MUST NOT emit untyped provider-specific events through --- this algebra. Providers MUST emit @_Start@, then zero or more --- @_Delta@, then @_End@ for each content block in increasing --- @contentIndex@ order; the reassembler defends against missing --- @_End@ events but no built-in provider should rely on the recovery --- path. +-- The algebra is closed and shared by every provider. Adding a new +-- variant is a breaking change to baikai's public surface. Consumers +-- that prefer source resilience over exhaustiveness can include a +-- final wildcard branch in their pattern match, but providers MUST NOT +-- emit untyped provider-specific events through this algebra. Providers +-- MUST emit @_Start@, then zero or more @_Delta@, then @_End@ for each +-- content block in increasing @contentIndex@ order; the reassembler +-- defends against missing @_End@ events but no built-in provider should +-- rely on the recovery path. module Baikai.Stream.Event ( AssistantMessageEvent (..), StartPayload (..), IndexPayload (..), DeltaPayload (..), BlockEndPayload (..), + ThinkingEndPayload (..), ToolCallEndPayload (..), TerminalPayload (..), doneTerminal, @@ -37,7 +42,7 @@ ) where -import Baikai.Content (ToolCall) +import Baikai.Content (ThinkingContent, ToolCall) import Baikai.Error (BaikaiError) import Baikai.Message (Message) import Baikai.StopReason (StopReason) @@ -59,8 +64,9 @@ -- partial (e.g. a @delta@ that throws on 'EventStart'); @-Wpartial-fields@ -- flags that latent runtime hazard. Same-shaped constructors share one -- payload type ('IndexPayload', 'DeltaPayload', 'BlockEndPayload', --- 'TerminalPayload'), so the payloads also collapse the repetition the --- flat encoding spread across twelve constructors. +-- 'ThinkingEndPayload', 'TerminalPayload'), so the payloads also +-- collapse the repetition the flat encoding spread across twelve +-- constructors. data AssistantMessageEvent = -- | The first event in every stream. The payload's 'partial' is an -- 'AssistantMessage' with empty content; downstream consumers that @@ -79,8 +85,10 @@ ThinkingStart IndexPayload | -- | A chunk of reasoning text appended to the thinking block. ThinkingDelta DeltaPayload - | -- | The thinking block at @contentIndex@ is closed. - ThinkingEnd BlockEndPayload + | -- | The thinking block at @contentIndex@ is closed. The payload + -- carries the full 'ThinkingContent', including provider + -- signature and redacted flag when available. + ThinkingEnd ThinkingEndPayload | -- | A tool-call content block is about to receive argument-JSON -- chunks. The tool's @id_@ and @name@ become known on this event -- when the upstream API delivers them up front (Anthropic), or on @@ -107,9 +115,12 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) --- | Payload of 'EventStart': the message skeleton observed up front. -newtype StartPayload = StartPayload - { partial :: Message +-- | Payload of 'EventStart': the message skeleton observed up front, +-- plus the provider's message id when the provider learns it this +-- early (Anthropic's @message_start.id@). 'Nothing' otherwise. +data StartPayload = StartPayload + { partial :: !Message, + responseId :: !(Maybe Text) } deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) @@ -130,8 +141,8 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) --- | Payload of the text/thinking @_End@ events: the closed block's --- fully concatenated 'content'. +-- | Payload of the text @_End@ event: the closed block's fully +-- concatenated 'content'. data BlockEndPayload = BlockEndPayload { contentIndex :: !Int, content :: !Text @@ -139,6 +150,17 @@ deriving stock (Eq, Show, Generic) deriving anyclass (ToJSON) +-- | Payload of 'ThinkingEnd': the closed thinking block in full — +-- concatenated reasoning text plus the provider 'signature' and +-- 'redacted' flag. The concatenation of the preceding +-- 'ThinkingDelta's equals the payload's @content.thinking@. +data ThinkingEndPayload = ThinkingEndPayload + { contentIndex :: !Int, + content :: !ThinkingContent + } + deriving stock (Eq, Show, Generic) + deriving anyclass (ToJSON) + -- | Payload of 'ToolCallEnd': the fully parsed 'toolCall'. data ToolCallEndPayload = ToolCallEndPayload { contentIndex :: !Int, @@ -152,10 +174,12 @@ data TerminalPayload = TerminalPayload { reason :: !StopReason, 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. + -- | The provider's message id when known by stream end. Consumers + -- should prefer this over 'StartPayload.responseId'. + responseId :: !(Maybe Text), + -- | Structured error detail. Always 'Nothing' on 'EventDone' and + -- always 'Just' on 'EventError'; use 'errorTerminal' to enforce the + -- error-side invariant at construction sites. errorInfo :: !(Maybe BaikaiError) } deriving stock (Eq, Show, Generic) @@ -164,13 +188,16 @@ -- | 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} +doneTerminal :: Maybe Text -> StopReason -> Message -> TerminalPayload +doneTerminal rid r m = + TerminalPayload {reason = r, message = m, responseId = rid, 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} +-- | Build an error terminal payload carrying structured error detail. +-- Prefer this over the raw 'TerminalPayload' constructor so an +-- 'EventError' cannot be constructed without 'errorInfo'. +errorTerminal :: Maybe Text -> StopReason -> Message -> BaikaiError -> TerminalPayload +errorTerminal rid r m e = + TerminalPayload {reason = r, message = m, responseId = rid, errorInfo = Just e} -- | 'True' when the event terminates the stream — exactly one -- 'EventDone' or 'EventError' is emitted per call. diff --git a/src/Baikai/Tool.hs b/src/Baikai/Tool.hs --- a/src/Baikai/Tool.hs +++ b/src/Baikai/Tool.hs @@ -20,6 +20,7 @@ module Baikai.Tool ( Tool (..), ToolChoice (..), + emptyTool, _Tool, ) where @@ -76,10 +77,14 @@ toJSON = genericToJSON toolChoiceOptions -- | An empty tool — useful as a base for record updates. -_Tool :: Tool -_Tool = +emptyTool :: Tool +emptyTool = Tool { name = Text.empty, description = Text.empty, parameters = Null } + +{-# DEPRECATED _Tool "Use emptyTool instead." #-} +_Tool :: Tool +_Tool = emptyTool diff --git a/src/Baikai/Trace.hs b/src/Baikai/Trace.hs --- a/src/Baikai/Trace.hs +++ b/src/Baikai/Trace.hs @@ -18,8 +18,10 @@ -- matching 'CallFinished' / 'CallFailed' before yielding the -- terminal event to the consumer. Cleanup ('Nothing' sentinel on -- the channel + 'takeMVar' on the worker) is idempotent and runs --- through 'Stream.finallyIO' so an early-aborting consumer never --- leaks the worker. +-- through 'Stream.finallyIO' so an early-aborting consumer eventually +-- records a synthetic 'CallFailed' and never leaks the worker. Sink +-- exceptions are captured by the worker and reported once on stderr +-- during cleanup; they do not propagate into the provider call. module Baikai.Trace ( -- * Re-exports TraceEvent (..), @@ -63,19 +65,21 @@ import Control.Concurrent (forkIO) import Control.Concurrent.Chan (Chan, newChan, readChan, writeChan) import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar) --- Control.Exception no longer needed; producer errors flow through --- the stream as 'EventError'. -import Control.Monad (unless) +import Control.Exception (SomeException, displayException, try) +import Control.Monad (forM_, unless) import Control.Monad.IO.Unlift (MonadUnliftIO, withRunInIO) import Data.Bits (unsafeShiftL, (.&.), (.|.)) -import Data.IORef (IORef, atomicModifyIORef', newIORef) +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Text qualified as Text import Data.Time (UTCTime, diffUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (getPOSIXTime) +import Data.Word (Word64) +import Foreign.StablePtr (StablePtr, freeStablePtr, newStablePtr) import Numeric (showHex) import Streamly.Data.Stream (Stream) import Streamly.Data.Stream qualified as Stream +import System.IO (hPutStrLn, stderr) import System.IO.Unsafe (unsafePerformIO) -- ============================================================ @@ -119,8 +123,15 @@ let stepDrain () = do msg <- readChan c pure (fmap (\e -> (e, ())) msg) - Stream.unfoldrM stepDrain () - & Stream.fold sinkFold + result <- + try + ( Stream.unfoldrM stepDrain () + & Stream.fold sinkFold + ) :: + IO (Either SomeException ()) + case result of + Left e -> writeIORef (state ^. #sinkError) (Just e) + Right () -> pure () putMVar d () eid <- newEventId start <- getCurrentTime @@ -136,7 +147,7 @@ } pure $ Stream.finallyIO - (cleanupTrace state) + (finalizeTrace state eid start m) (Stream.mapM (traceEvent state eid start m) (streamRequestWith reg m ctx opts)) -- | Synchronous trace wrapper. Drains 'withTraceStream' into a @@ -180,7 +191,10 @@ data TraceState = TraceState { chan :: !(Chan (Maybe TraceEvent)), done :: !(MVar ()), - closed :: !(IORef Bool) + closed :: !(IORef Bool), + sinkError :: !(IORef (Maybe SomeException)), + terminalSent :: !(IORef Bool), + stableRoot :: !(IORef (Maybe (StablePtr TraceState))) } deriving stock (Generic) @@ -189,16 +203,50 @@ c <- newChan d <- newEmptyMVar r <- newIORef False - pure TraceState {chan = c, done = d, closed = r} + e <- newIORef Nothing + t <- newIORef False + root <- newIORef Nothing + let state = TraceState {chan = c, done = d, closed = r, sinkError = e, terminalSent = t, stableRoot = root} + sp <- newStablePtr state + writeIORef root (Just sp) + pure state -cleanupTrace :: TraceState -> IO () -cleanupTrace s = do +finalizeTrace :: TraceState -> Text -> UTCTime -> Model -> IO () +finalizeTrace s eid start m = do alreadyClosed <- atomicModifyIORef' (s ^. #closed) (\b -> (True, b)) unless alreadyClosed $ do + sent <- readIORef (s ^. #terminalSent) + unless sent $ do + now <- getCurrentTime + writeChan (s ^. #chan) $ + Just + CallFailed + { eventId = eid, + timestamp = now, + provider = m ^. #provider, + model = m ^. #modelId, + latencyMs = millisBetween start now, + errorMessage = "aborted: stream consumer stopped before the terminal event" + } writeChan (s ^. #chan) Nothing takeMVar (s ^. #done) + reportSinkError s + releaseStableRoot s +releaseStableRoot :: TraceState -> IO () +releaseStableRoot s = do + msp <- atomicModifyIORef' (s ^. #stableRoot) (\sp -> (Nothing, sp)) + forM_ msp freeStablePtr + +reportSinkError :: TraceState -> IO () +reportSinkError s = do + merr <- readIORef (s ^. #sinkError) + forM_ merr $ \e -> + hPutStrLn + stderr + ("baikai: trace sink failed; trace events for this call were dropped: " <> displayException e) + traceEvent :: TraceState -> Text -> @@ -228,7 +276,8 @@ else Nothing } writeChan (state ^. #chan) (Just finished) - cleanupTrace state + writeIORef (state ^. #terminalSent) True + finalizeTrace state eid start m EventError TerminalPayload {message = msg} -> do now <- getCurrentTime let latency = millisBetween start now @@ -245,7 +294,8 @@ errorMessage = errMsg } writeChan (state ^. #chan) (Just failed) - cleanupTrace state + writeIORef (state ^. #terminalSent) True + finalizeTrace state eid start m _ -> pure () pure ev @@ -324,20 +374,26 @@ resolvedMaxTokens :: Model -> Options -> Natural resolvedMaxTokens m opts = fromMaybe (m ^. #maxOutputTokens) (opts ^. #maxTokens) -millisBetween :: UTCTime -> UTCTime -> Integer +millisBetween :: UTCTime -> UTCTime -> Int millisBetween a b = round (realToFrac (diffUTCTime b a) * (1000 :: Double)) -- ============================================================ -- Event id -- ============================================================ +-- | Generate a 16-character lowercase hexadecimal event id. The high +-- 32 bits are derived from process-start POSIX seconds and the low +-- 32 bits are a process-local counter, so ids are unique within a +-- process for 2^32 calls. newEventId :: IO Text newEventId = do n <- atomicModifyIORef' eventCounter (\k -> (k + 1, k)) - let raw :: Word - raw = (eventBase .&. 0xFFFF) `unsafeShiftL` 16 .|. (n .&. 0xFFFF) + let raw :: Word64 + raw = + (fromIntegral eventBase .&. 0xFFFFFFFF) `unsafeShiftL` 32 + .|. (fromIntegral n .&. 0xFFFFFFFF) hex = showHex raw "" - padded = replicate (8 - length hex) '0' <> hex + padded = replicate (16 - length hex) '0' <> hex pure (Text.pack padded) eventCounter :: IORef Word diff --git a/src/Baikai/Trace/Event.hs b/src/Baikai/Trace/Event.hs --- a/src/Baikai/Trace/Event.hs +++ b/src/Baikai/Trace/Event.hs @@ -51,7 +51,7 @@ timestamp :: !UTCTime, provider :: !Text, model :: !Text, - latencyMs :: !Integer, + latencyMs :: !Int, inputTokens :: !(Maybe Natural), outputTokens :: !(Maybe Natural), usd :: !(Maybe Scientific) @@ -61,7 +61,7 @@ timestamp :: !UTCTime, provider :: !Text, model :: !Text, - latencyMs :: !Integer, + latencyMs :: !Int, errorMessage :: !Text } deriving stock (Eq, Show, Generic) diff --git a/src/Baikai/Usage.hs b/src/Baikai/Usage.hs --- a/src/Baikai/Usage.hs +++ b/src/Baikai/Usage.hs @@ -1,14 +1,30 @@ -- | Token-usage accounting for a single provider call. -- --- The shape splits cache-read tokens (the prompt fragment served from a --- prior cache write) from cache-write tokens (the prompt fragment the --- provider stored for future calls), so callers can reason about both --- 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, sumUsage) where +-- The prompt-side fields are provider-normalized into disjoint token +-- classes. 'inputTokens' counts only non-cached prompt tokens and +-- excludes both cache counters. 'cacheReadTokens' counts prompt tokens +-- served from a provider-side cache; 'cacheWriteTokens' counts prompt +-- tokens stored for future cache reads. Providers whose wire format is +-- inclusive, such as OpenAI Chat Completions where @prompt_tokens@ +-- includes @prompt_tokens_details.cached_tokens@, must normalize by +-- subtraction when constructing 'Usage'. +-- +-- 'totalTokens' is the sum of the billed token classes: +-- 'inputTokens' + 'outputTokens' + 'cacheReadTokens' + +-- 'cacheWriteTokens'. Provider mappings compute it from the normalized +-- parts rather than trusting a wire total. 'reasoningTokens', when +-- present, is an informational subset of 'outputTokens'; it is already +-- counted in 'outputTokens' and 'totalTokens' and is not billed +-- separately. +-- +-- 'cost' is always populated — providers without pricing data fill it +-- with 'zeroCost' (zero across all rates) rather than a 'Nothing' that +-- every cost-reading caller would have to handle. 'Baikai.Cost.Pricing.computeCost' +-- depends on the token classes being disjoint so each class is billed +-- exactly once. +module Baikai.Usage (Usage (..), zeroUsage, _Usage, sumUsage) where -import Baikai.Cost (Cost, _Cost) +import Baikai.Cost (Cost, zeroCost) import Data.Aeson ( Options (fieldLabelModifier), ToJSON (toJSON), @@ -20,13 +36,34 @@ import GHC.Generics (Generic) import Numeric.Natural (Natural) +-- | Provider-normalized token usage for one model call. +-- +-- The prompt-side classes are disjoint: 'inputTokens' excludes +-- 'cacheReadTokens' and 'cacheWriteTokens'. 'totalTokens' is the sum +-- of all billed token classes, and 'reasoningTokens' is an optional +-- breakdown already included in 'outputTokens'. data Usage = Usage - { inputTokens :: !Natural, + { -- | Non-cached prompt tokens. Excludes 'cacheReadTokens' and + -- 'cacheWriteTokens'. + inputTokens :: !Natural, + -- | Output tokens billed at the model's output rate. Any + -- 'reasoningTokens' are already included here. outputTokens :: !Natural, + -- | Prompt tokens served from a provider-side cache. cacheReadTokens :: !Natural, + -- | Prompt tokens written into a provider-side cache for future + -- reads. cacheWriteTokens :: !Natural, + -- | Optional reasoning/thinking-token breakdown. These tokens are + -- an informational subset of 'outputTokens', not an additional + -- billed class. reasoningTokens :: !(Maybe Natural), + -- | Sum of the billed token classes: + -- 'inputTokens' + 'outputTokens' + 'cacheReadTokens' + + -- 'cacheWriteTokens'. totalTokens :: !Natural, + -- | Computed cost for this usage. Providers without pricing data + -- use 'zeroCost'. cost :: !Cost } deriving stock (Eq, Show, Generic) @@ -36,8 +73,9 @@ instance ToJSON Usage where toJSON = genericToJSON usageOptions -_Usage :: Usage -_Usage = +-- | Empty usage with every count and cost set to zero. +zeroUsage :: Usage +zeroUsage = Usage { inputTokens = 0, outputTokens = 0, @@ -45,7 +83,7 @@ cacheWriteTokens = 0, reasoningTokens = Nothing, totalTokens = 0, - cost = _Cost + cost = zeroCost } -- | Combine two optional reasoning-token counts. Presence wins: an @@ -69,8 +107,12 @@ } instance Monoid Usage where - mempty = _Usage + mempty = zeroUsage -- | Total a collection of per-call usages into one. sumUsage :: (Foldable f) => f Usage -> Usage sumUsage = foldl' (<>) mempty + +{-# DEPRECATED _Usage "Use zeroUsage instead." #-} +_Usage :: Usage +_Usage = zeroUsage diff --git a/test/CliInternalSpec.hs b/test/CliInternalSpec.hs new file mode 100644 --- /dev/null +++ b/test/CliInternalSpec.hs @@ -0,0 +1,32 @@ +module CliInternalSpec (tests) where + +import Baikai +import Baikai.Provider.Cli.Internal +import Control.Lens ((&), (.~)) +import Data.Vector qualified as Vector +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "CLI internal helpers" + [ testCase "renderPrompt returns a single user text message verbatim" $ do + let ctx = emptyContext & #messages .~ Vector.singleton (user "hello") + renderPrompt ctx @?= "hello", + testCase "renderPrompt tags multi-message contexts" $ do + let ctx = + emptyContext + & #messages + .~ Vector.fromList + [ user "hello", + assistant "hi" + ] + renderPrompt ctx @?= "[user]: hello\n[assistant]: hi", + testCase "wrapSystemPrompt leaves missing and blank prompts alone" $ do + wrapSystemPrompt Nothing "hello" @?= "hello" + wrapSystemPrompt (Just " ") "hello" @?= "hello", + testCase "wrapSystemPrompt prefixes nonblank system instructions" $ + wrapSystemPrompt (Just "Be terse.") "hi" + @?= "System instructions:\nBe terse.\n\nUser request:\nhi" + ] diff --git a/test/ContextSpec.hs b/test/ContextSpec.hs new file mode 100644 --- /dev/null +++ b/test/ContextSpec.hs @@ -0,0 +1,133 @@ +module ContextSpec (tests) where + +import Baikai +import Control.Lens ((&), (.~), (^.)) +import Data.Aeson qualified as Aeson +import Data.Time (UTCTime) +import Data.Vector qualified as V +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "Context helpers" + [ monoidTests, + constructorTests, + timestampTests, + flattenTextTests + ] + +monoidTests :: TestTree +monoidTests = + testGroup + "Monoid" + [ testCase "has left and right identity" $ do + let ctx = + emptyContext + { systemPrompt = Just "sys", + messages = V.fromList [user "one"], + tools = V.singleton sampleTool + } + mempty <> ctx @?= ctx + ctx <> mempty @?= ctx, + testCase "is associative and keeps the first system prompt" $ do + let a = systemUser "a-system" "a" + b = addUser "b" emptyContext + c = + emptyContext + { systemPrompt = Just "c-system", + messages = V.fromList [assistant "c"], + tools = V.singleton sampleTool + } + (a <> b) <> c @?= a <> (b <> c) + (a <> b <> c) ^. #systemPrompt @?= Just "a-system" + (b <> c) ^. #systemPrompt @?= Just "c-system" + ] + +constructorTests :: TestTree +constructorTests = + testGroup + "constructors" + [ testCase "contextOf preserves message order" $ do + contextOf [user "one", assistant "two"] ^. #messages + @?= V.fromList [user "one", assistant "two"], + testCase "systemUser creates a system prompt and one user message" $ do + let ctx = systemUser "system" "prompt" + ctx ^. #systemPrompt @?= Just "system" + ctx ^. #messages @?= V.singleton (user "prompt"), + testCase "addMessage, addUser, and addResponse append in order" $ do + let resp = + emptyResponse + & #message + .~ AssistantPayload + { content = V.singleton (AssistantText (TextContent "response")), + usage = zeroUsage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = Nothing + } + ctx = + emptyContext + |> addUser "first" + |> addMessage (assistant "second") + |> addResponse resp + ctx ^. #messages + @?= V.fromList + [ user "first", + assistant "second", + responseMessage resp + ] + ] + +timestampTests :: TestTree +timestampTests = + testGroup + "timestamps" + [ testCase "pure constructors do not invent timestamps" $ do + payloadTimestamp (user "plain") @?= Nothing + payloadTimestamp (assistant "plain") @?= Nothing + payloadTimestamp (toolResult "call" "tool" "ok" False) @?= Nothing, + testCase "explicit constructors preserve timestamps" $ do + let ts = read "2026-06-05 01:02:03 UTC" + payloadTimestamp (userAt ts "plain") @?= Just ts + payloadTimestamp (assistantAt ts "plain") @?= Just ts + payloadTimestamp (toolResultAt ts "call" "tool" "ok" False) @?= Just ts + ] + +flattenTextTests :: TestTree +flattenTextTests = + testGroup + "flattenAssistantText" + [ testCase "concatenates only text blocks" $ do + flattenAssistantText + ( V.fromList + [ AssistantText (TextContent "hello"), + AssistantThinking + ThinkingContent + { thinking = "hidden", + signature = Nothing, + redacted = False + }, + AssistantToolCall emptyToolCall {name = "lookup", arguments = Aeson.object []}, + AssistantText (TextContent " world") + ] + ) + @?= "hello world" + ] + +sampleTool :: Tool +sampleTool = + emptyTool + { name = "lookup", + description = "Lookup a value", + parameters = Aeson.object [] + } + +payloadTimestamp :: Message -> Maybe UTCTime +payloadTimestamp (UserMessage UserPayload {timestamp = ts}) = ts +payloadTimestamp (AssistantMessage AssistantPayload {timestamp = ts}) = ts +payloadTimestamp (ToolResultMessage ToolResultPayload {timestamp = ts}) = ts + +(|>) :: a -> (a -> b) -> b +(|>) x f = f x diff --git a/test/CostSpec.hs b/test/CostSpec.hs --- a/test/CostSpec.hs +++ b/test/CostSpec.hs @@ -2,18 +2,19 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) -import Baikai.Context (Context (..), _Context) +import Baikai.Context (Context (..), emptyContext) import Baikai.Cost qualified as Cost import Baikai.Cost.Log ( CallLogConfig (..), - CallLogEntry, + CallLogEntry (..), + appendEntry, runRequestWithLog, withCallLog, ) import Baikai.Cost.Pricing (attachCost, computeCost) import Baikai.Message (AssistantPayload (..), user) -import Baikai.Model (Model (..), ModelCost (..), _Model) -import Baikai.Options (Options, _Options) +import Baikai.Model (Model (..), ModelCost (..), emptyModel) +import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider ( ApiProvider (..), @@ -22,14 +23,16 @@ import Baikai.Response (Response (..), flattenAssistantBlocks) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) -import Baikai.Usage (Usage, _Usage) +import Baikai.Usage (Usage, zeroUsage) import Data.Aeson qualified as Aeson import Data.ByteString.Lazy.Char8 qualified as BSL import Data.List.NonEmpty (NonEmpty ((:|)), nonEmpty) import Data.Maybe (fromJust, isJust) +import Data.Time (getCurrentTime) import Data.Vector qualified as V import System.Directory (getTemporaryDirectory, removeFile) import System.FilePath (()) +import System.Timeout (timeout) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -47,7 +50,7 @@ -- 1000*(1/1_000_000) + 500*(5/1_000_000) = 7/2000 USD. sampleUsage :: Usage sampleUsage = - _Usage + zeroUsage & #inputTokens .~ 1000 & #outputTokens @@ -58,7 +61,7 @@ -- cache-read $0.10/M, cache-write $1.25/M. knownModel :: Model knownModel = - _Model + emptyModel & #modelId .~ "claude-haiku-4-5-20251001" & #api @@ -75,7 +78,7 @@ unknownModel :: Model unknownModel = - _Model + emptyModel & #modelId .~ "totally-fake-model" & #api @@ -94,14 +97,14 @@ testCase "cacheReadTokens contribute when present" $ do let u :: Usage u = - _Usage + zeroUsage & #cacheReadTokens .~ 1000 Cost.usd (computeCost knownModel u) @?= 1 / 10000, testCase "cacheWriteTokens contribute against the known model" $ do let u :: Usage u = - _Usage + zeroUsage & #cacheWriteTokens .~ 1000 Cost.usd (computeCost knownModel u) @?= 1 / 800 @@ -132,7 +135,7 @@ usage = sampleUsage, stopReason = Stop, errorMessage = Nothing, - timestamp = read "2026-05-14 00:00:00 UTC" + timestamp = Just (read "2026-05-14 00:00:00 UTC") }, model = m, api = Custom "test", @@ -157,7 +160,7 @@ usage = u, stopReason = Stop, errorMessage = Nothing, - timestamp = read "2026-05-14 00:00:00 UTC" + timestamp = Just (read "2026-05-14 00:00:00 UTC") }, model = knownModel & #api .~ cannedApi, api = cannedApi, @@ -181,10 +184,10 @@ cannedModel = knownModel & #api .~ cannedApi ctxHello :: Context -ctxHello = _Context & #messages .~ V.fromList [user "Hello world"] +ctxHello = emptyContext & #messages .~ V.fromList [user "Hello world"] optsZero :: Options -optsZero = _Options +optsZero = emptyOptions callLogTests :: TestTree callLogTests = @@ -223,5 +226,25 @@ entry ^. #latencyMs @?= 7 entry ^. #promptSummary @?= "Hello world" isJust (entry ^. #usd) @?= True - removeFile path' + removeFile path', + testCase "closeCallLog returns even when the log path is unwritable" $ do + tmp <- getTemporaryDirectory + let missing = tmp "baikai-costspec-no-such-dir" "entries.jsonl" + cfg = CallLogConfig {path = missing, enabled = True} + now <- getCurrentTime + let entry = + CallLogEntry + { timestamp = now, + provider = "test", + model = "m", + inputTokens = Nothing, + outputTokens = Nothing, + cachedInputTokens = Nothing, + reasoningTokens = Nothing, + usd = Nothing, + latencyMs = 0, + promptSummary = "" + } + result <- timeout 5000000 (withCallLog cfg (\h -> appendEntry h entry)) + result @?= Just () ] diff --git a/test/EmbeddingSpec.hs b/test/EmbeddingSpec.hs --- a/test/EmbeddingSpec.hs +++ b/test/EmbeddingSpec.hs @@ -7,7 +7,8 @@ -- default run stays offline. module EmbeddingSpec (tests) where -import Baikai.Embedding (embedOne, mkEmbeddingRequest, openAIEmbeddingModel) +import Baikai.Embedding (embedOne, firstEmbedding, mkEmbeddingRequest, openAIEmbeddingModel) +import Baikai.Error (decodeError) import Data.Vector qualified as V import OpenAI.V1.Embeddings qualified as Emb import OpenAI.V1.Models qualified as OpenAIModels @@ -24,6 +25,17 @@ Emb.input req @?= "hello" OpenAIModels.text (Emb.model req) @?= "text-embedding-3-small" Emb.dimensions req @?= Nothing, + testCase "firstEmbedding reports an empty data array as a typed decode error" $ do + firstEmbedding V.empty @?= Left (decodeError "embeddings response contained no data"), + testCase "firstEmbedding extracts the first vector" $ do + let vec = V.fromList [0.1, 0.2, 0.3] + obj = + Emb.EmbbeddingObject + { Emb.index = 0, + Emb.embedding = vec, + Emb.object = "embedding" + } + firstEmbedding (V.singleton obj) @?= Right vec, testCase "live embedding returns a 1536-length vector" $ do live <- lookupEnv "BAIKAI_EMBEDDING_LIVE" case live of diff --git a/test/ErrorInfoSpec.hs b/test/ErrorInfoSpec.hs --- a/test/ErrorInfoSpec.hs +++ b/test/ErrorInfoSpec.hs @@ -9,14 +9,14 @@ import Baikai.Prelude import Streamly.Data.Stream qualified as Stream import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertFailure, testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) errApi :: Api errApi = Custom "baikai-errinfo" errModel :: Model errModel = - _Model + emptyModel & #modelId .~ "err-model" & #api @@ -29,18 +29,24 @@ errStream :: Model -> Context -> Options -> Stream.Stream IO AssistantMessageEvent errStream _ _ _ = let payload = - (_Response ^. #message) + (emptyResponse ^. #message) & #stopReason .~ ErrorReason & #errorMessage .~ Just "rate limited, slow down" term = errorTerminal + Nothing ErrorReason (AssistantMessage payload) - (Just (rateLimited (Just 5) "rate limited, slow down")) - in Stream.fromList [EventError term] + (rateLimited (Just 5) "rate limited, slow down") + start = EventStart StartPayload {partial = AssistantMessage payload, responseId = Nothing} + in Stream.fromList [start, EventError term] +errResponse :: Model -> Context -> Options -> IO Response +errResponse m _ _ = + pure (errorResponse m (read "2026-06-05 00:00:00 UTC") 0 (rateLimited (Just 5) "rate limited, slow down")) + registerErr :: IO () registerErr = registerApiProvider @@ -56,10 +62,47 @@ "Response.errorInfo threading" [ testCase "completeRequest surfaces structured errorInfo" $ do registerErr - resp <- completeRequest errModel _Context _Options - case resp ^. #errorInfo of + resp <- completeRequest errModel emptyContext emptyOptions + case responseError resp of Just be -> do be ^. #category @?= RateLimited be ^. #retryAfterSeconds @?= Just 5 - Nothing -> assertFailure "expected Response.errorInfo to be populated" + Nothing -> assertFailure "expected Response.errorInfo to be populated", + testCase "completeRequestWith reports missing provider in-band" $ do + reg <- newProviderRegistry + resp <- completeRequestWith reg errModel emptyContext emptyOptions + case responseError resp of + Just be -> be ^. #category @?= ProviderUnavailable + Nothing -> assertFailure "expected ProviderUnavailable response", + testCase "liftCompleteToStream preserves error-shaped responses as EventError" $ do + let stream = liftCompleteToStream errResponse + events <- Stream.toList (stream errModel emptyContext emptyOptions) + assertBool "expected exactly one terminal" (length (filter isTerminal events) == 1) + case last events of + EventError TerminalPayload {errorInfo = Just be} -> do + be ^. #category @?= RateLimited + be ^. #retryAfterSeconds @?= Just 5 + other -> assertFailure ("expected terminal EventError, got: " <> show other), + testCase "reassembly normalizes ErrorReason terminals without errorInfo" $ do + let payload = + (emptyResponse ^. #message) + & #stopReason + .~ ErrorReason + & #errorMessage + .~ Just "legacy unclassified failure" + terminal = + doneTerminal + Nothing + ErrorReason + (AssistantMessage payload) + events = + [ EventStart StartPayload {partial = AssistantMessage payload, responseId = Nothing}, + EventDone terminal + ] + resp <- Stream.fold (reassembleResponse errModel) (Stream.fromList events) + case responseError resp of + Just be -> do + be ^. #category @?= OtherError + be ^. #message @?= "legacy unclassified failure" + Nothing -> assertFailure "expected synthesized errorInfo" ] diff --git a/test/ErrorSpec.hs b/test/ErrorSpec.hs --- a/test/ErrorSpec.hs +++ b/test/ErrorSpec.hs @@ -6,8 +6,10 @@ classifyHttpStatus, classifyHttpStatusWithBody, decodeError, + httpError, invalidRequest, isRetryable, + parseRetryAfterSeconds, processError, rateLimited, ) @@ -20,8 +22,27 @@ "Baikai.Error" [ classifyTests, bodyClassifyTests, + httpHelperTests, retryTests, constructorTests + ] + +httpHelperTests :: TestTree +httpHelperTests = + testGroup + "httpError / parseRetryAfterSeconds" + [ testCase "429 + retry-after -> RateLimited with hint" $ do + let e = httpError 429 (Just 12) "slow down" + category e @?= RateLimited + httpStatus e @?= Just 429 + retryAfterSeconds e @?= Just 12, + testCase "400 + overflow body -> ContextOverflow" $ + category (httpError 400 Nothing "maximum context length exceeded") + @?= ContextOverflow, + testCase "integer Retry-After parses as seconds" $ + parseRetryAfterSeconds "12" @?= Just 12, + testCase "HTTP-date Retry-After is ignored" $ + parseRetryAfterSeconds "Wed, 21 Oct 2026 07:28:00 GMT" @?= Nothing ] bodyClassifyTests :: TestTree diff --git a/test/FetchModelsSpec.hs b/test/FetchModelsSpec.hs --- a/test/FetchModelsSpec.hs +++ b/test/FetchModelsSpec.hs @@ -1,5 +1,3 @@ -{-# 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 @@ -7,15 +5,21 @@ module FetchModelsSpec (tests) where import Baikai.Model (InputModality (..)) +import Baikai.Prelude +import Data.Aeson qualified as Aeson +import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Lazy qualified as BSL +import Data.Generics.Labels () import Data.Map.Strict (Map) import Data.Map.Strict qualified as Map -import Data.Text (Text) +import Data.Maybe (listToMaybe) +import Data.Scientific (Scientific) import Data.Text qualified as Text import Data.Text.Encoding (decodeUtf8) +import Data.Vector qualified as V import FetchModelsCore import Test.Tasty (TestTree, testGroup) -import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) -- | Path to the fixture, relative to the @baikai@ package directory -- (tests run with that as the working directory, as 'CatalogSpec' @@ -33,7 +37,7 @@ -- | 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) + normalizeProvider spec (Map.findWithDefault Map.empty (spec ^. #provider) upstream) -- | Expected OpenAI catalog after normalization. @gpt-5-pro@ is -- excluded by curation (Responses-API-only) and @gpt-legacy-nontool@ @@ -42,27 +46,27 @@ expectedOpenAI :: Catalog expectedOpenAI = Catalog - { cProvider = "openai", - cBaseUrl = "https://api.openai.com", - cApi = "openai-chat-completions", - cModels = + { provider = "openai", + baseUrl = "https://api.openai.com", + api = "openai-chat-completions", + models = [ 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 + { modelId = "gpt-5-nano", + name = "GPT-5 Nano", + reasoning = True, + input = [InputText, InputImage], + cost = CatalogCost 0.05 0.4 0 0, + contextWindow = 400000, + maxOutputTokens = 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 + { modelId = "gpt-5.4", + name = "GPT-5.4", + reasoning = True, + input = [InputText, InputImage], + cost = CatalogCost 2.5 15 0.25 0, + contextWindow = 1050000, + maxOutputTokens = 128000 } ] } @@ -76,11 +80,11 @@ catalogFor upstream openaiSpec @?= expectedOpenAI, testCase "tool_call: false model is excluded" $ do upstream <- loadUpstream - let ids = map cmId (cModels (catalogFor upstream openaiSpec)) + let ids = map (^. #modelId) (catalogFor upstream openaiSpec ^. #models) 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)) + let ids = map (^. #modelId) (catalogFor upstream openaiSpec ^. #models) assertBool "gpt-5-pro must be excluded" ("gpt-5-pro" `notElem` ids), testCase "pdf modality is dropped" $ do upstream <- loadUpstream @@ -104,10 +108,67 @@ assertBool "output 15 renders as 15.0" ("\"output\": 15.0" `Text.isInfixOf` rendered), + testCase "renderCatalog escapes control characters as valid JSON strings" $ do + let modelIdWithControls = "model-\n-tab\t-quote\"-slash\\" + nameWithControls = "Name with \r carriage return" + catalog = + Catalog + { provider = "openai", + baseUrl = "https://api.openai.com", + api = "openai-chat-completions", + models = + [ CatalogModel + { modelId = modelIdWithControls, + name = nameWithControls, + reasoning = False, + input = [InputText], + cost = CatalogCost 0 0 0 0, + contextWindow = 1, + maxOutputTokens = 1 + } + ] + } + rendered = renderText catalog + raw = BSL.fromStrict (renderCatalog catalog) + decoded = Aeson.eitherDecode raw :: Either String Aeson.Value + case decoded of + Left err -> assertFailure ("decode failed: " <> err) + Right (Aeson.Object root) -> + case KeyMap.lookup "models" root of + Just (Aeson.Array models) + | Just (Aeson.Object model) <- models V.!? 0 -> do + KeyMap.lookup "id" model @?= Just (Aeson.String modelIdWithControls) + KeyMap.lookup "name" model @?= Just (Aeson.String nameWithControls) + _ -> assertFailure "decoded catalog did not contain a model object" + Right other -> assertFailure ("decoded catalog was not an object: " <> show other) + assertBool "newline escaped" ("\\n" `Text.isInfixOf` rendered) + assertBool "tab escaped" ("\\t" `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"] + let ids = map (^. #modelId) (catalogFor upstream anthropicSpec ^. #models) + ids @?= ["claude-opus-4-5"], + testCase "\" (latest)\" suffix is stripped from display names" $ do + upstream <- loadUpstream + let cat = catalogFor upstream anthropicSpec + map (^. #name) (cat ^. #models) @?= ["Claude Opus 4.5"], + testCase "override corrects a deliberately-wrong upstream cache price" $ do + upstream <- loadUpstream + -- Fixture upstream reports cache_read 1.5 for claude-opus-4-5 + -- (the 3x wart); normalization alone preserves it, the override + -- pins it to the published 0.5. + let normalized = catalogFor upstream anthropicSpec + corrected = applyOverrides overrides normalized + opusCacheRead normalized @?= Just 1.5 + opusCacheRead corrected @?= Just 0.5 + ] + +-- | The @claude-opus-4-5@ cacheRead cost in an Anthropic catalog. +opusCacheRead :: Catalog -> Maybe Scientific +opusCacheRead cat = + listToMaybe + [ m ^. #cost . #cacheReadCost + | m <- cat ^. #models, + m ^. #modelId == "claude-opus-4-5" ] renderText :: Catalog -> Text diff --git a/test/GenModelsSpec.hs b/test/GenModelsSpec.hs new file mode 100644 --- /dev/null +++ b/test/GenModelsSpec.hs @@ -0,0 +1,56 @@ +module GenModelsSpec (tests) where + +import Baikai.Api (Api (OpenAIChatCompletions)) +import Baikai.Model (InputModality (InputText)) +import Data.Text (Text) +import Data.Text qualified as Text +import GenModelsCore +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase) + +tests :: TestTree +tests = + testGroup + "Baikai.GenModels" + [ testCase "checkIdentifierCollisions rejects sanitized binding duplicates" $ do + let entries = flattenEntries collisionCatalog + case checkIdentifierCollisions entries of + Right () -> assertFailure "expected duplicate generated identifier to be rejected" + Left err -> do + assertBool "mentions duplicate identifier" ("openai_a_b" `Text.isInfixOf` err) + assertBool "mentions first origin" ("openai/a-b" `Text.isInfixOf` err) + assertBool "mentions second origin" ("openai/a_b" `Text.isInfixOf` err) + ] + +collisionCatalog :: CatalogFile +collisionCatalog = + CatalogFile + { provider = "openai", + baseUrl = "https://api.openai.com", + api = OpenAIChatCompletions, + compat = CatalogCompatAuto, + models = + [ model "a-b", + model "a_b" + ] + } + +model :: Text -> ModelEntry +model mid = + ModelEntry + { entryId = mid, + entryName = mid, + entryReasoning = False, + entryInput = [InputText], + entryCost = + CostEntry + { costInput = 0, + costOutput = 0, + costCacheRead = 0, + costCacheWrite = 0 + }, + entryContextWindow = 1, + entryMaxOutputTokens = 1, + entryEnabled = True, + entryCompatOverride = Nothing + } diff --git a/test/HelpersSpec.hs b/test/HelpersSpec.hs new file mode 100644 --- /dev/null +++ b/test/HelpersSpec.hs @@ -0,0 +1,339 @@ +module HelpersSpec (tests) where + +import Baikai +import Baikai.Prelude +import Control.Exception qualified as Exception +import Data.Aeson qualified as Aeson +import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef) +import Data.Text qualified as Text +import Data.Time (UTCTime) +import Data.Vector qualified as Vector +import Streamly.Data.Stream qualified as Stream +import System.Environment qualified as Environment +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +helpersApi :: Api +helpersApi = Custom "baikai-helpers-test" + +helpersModel :: Model +helpersModel = + emptyModel + & #modelId + .~ "helpers-model" + & #api + .~ helpersApi + & #provider + .~ "helpers" + +epoch :: UTCTime +epoch = read "2026-06-05 00:00:00 UTC" + +tests :: TestTree +tests = + testGroup + "Baikai helpers" + [ testCase "runToolLoop resolves repeated tool turns and leaves final response separate" $ do + scripted <- newScripted [toolUseResponse "call_1" "get_time", toolUseResponse "call_2" "get_time", textResponse "done"] [] + let ctx0 = addUser "start" emptyContext + dispatcher _ = pure (toolResultText "2026-06-05T00:00:00Z") + (ctx1, resp) <- runToolLoopWith (scriptRegistry scripted) 5 dispatcher helpersModel ctx0 emptyOptions + calls <- scriptCalls scripted + calls @?= 3 + responseStop resp @?= Stop + Vector.length (ctx1 ^. #messages) @?= 5 + assertResolvedExchange "call_1" "2026-06-05T00:00:00Z" (Vector.toList (ctx1 ^. #messages) !! 1) (Vector.toList (ctx1 ^. #messages) !! 2) + assertResolvedExchange "call_2" "2026-06-05T00:00:00Z" (Vector.toList (ctx1 ^. #messages) !! 3) (Vector.toList (ctx1 ^. #messages) !! 4), + testCase "runToolLoop returns a replay-valid context on budget exhaustion" $ do + scripted <- newScripted [toolUseResponse "call_1" "get_time", toolUseResponse "call_2" "get_time", textResponse "done"] [] + (ctx1, resp) <- runToolLoopWith (scriptRegistry scripted) 2 (const (pure (toolResultText "ok"))) helpersModel (addUser "start" emptyContext) emptyOptions + calls <- scriptCalls scripted + calls @?= 2 + responseStop resp @?= ToolUse + Vector.length (ctx1 ^. #messages) @?= 3 + assertResolvedExchange "call_1" "ok" (Vector.toList (ctx1 ^. #messages) !! 1) (Vector.toList (ctx1 ^. #messages) !! 2), + testCase "runToolLoop returns an error response without appending it" $ do + scripted <- newScripted [errorResponse helpersModel epoch 0 (providerError "broken")] [] + let ctx0 = addUser "start" emptyContext + (ctx1, resp) <- runToolLoopWith (scriptRegistry scripted) 3 (const (pure (toolResultText "unused"))) helpersModel ctx0 emptyOptions + calls <- scriptCalls scripted + calls @?= 1 + ctx1 @?= ctx0 + case responseError resp of + Just err -> err ^. #message @?= "broken" + Nothing -> assertFailure "expected error response", + testCase "runToolLoop converts synchronous dispatcher exceptions into error tool results" $ do + scripted <- newScripted [toolUseResponse "call_1" "explode", textResponse "recovered"] [] + (ctx1, resp) <- + runToolLoopWith + (scriptRegistry scripted) + 3 + (\_ -> Exception.throwIO (userError "boom")) + helpersModel + (addUser "start" emptyContext) + emptyOptions + responseStop resp @?= Stop + case Vector.toList (ctx1 ^. #messages) of + [_, _, ToolResultMessage ToolResultPayload {content = blocks, isError = err}] -> do + err @?= True + assertBool "tool error should include exception text" ("boom" `Text.isInfixOf` toolText blocks) + msgs -> assertFailure ("unexpected messages: " <> show msgs), + testCase "runToolLoop terminates a ToolUse response with no tool calls" $ do + scripted <- newScripted [toolUseNoCallsResponse] [] + let ctx0 = addUser "start" emptyContext + (ctx1, resp) <- runToolLoopWith (scriptRegistry scripted) 3 (const (pure (toolResultText "unused"))) helpersModel ctx0 emptyOptions + calls <- scriptCalls scripted + calls @?= 1 + responseStop resp @?= ToolUse + ctx1 @?= ctx0, + testCase "completeText returns text and throws BaikaiError on failures" $ do + registerOneShot (Custom "baikai-helpers-text-ok") (textResponse "plain text") + ok <- + completeText + (helpersModel & #api .~ Custom "baikai-helpers-text-ok") + "prompt" + ok @?= "plain text" + registerApiProvider + (errorProvider (Custom "baikai-helpers-text-error") (providerError "text failed")) + thrown <- + Exception.try + ( completeText + (helpersModel & #api .~ Custom "baikai-helpers-text-error") + "prompt" + ) :: + IO (Either BaikaiError Text) + case thrown of + Left err -> err ^. #message @?= "text failed" + Right txt -> assertFailure ("expected BaikaiError, got text: " <> Text.unpack txt), + testCase "streamRequestEachWith and streamRequestListWith expose streamRequest without streamly imports" $ do + let events = textEvents "stream-id" "streamed" + scripted <- newScripted [] events + seenRef <- newIORef [] + resp <- streamRequestEachWith (scriptRegistry scripted) (\event -> atomicModifyIORef' seenRef (\xs -> (xs <> [event], ()))) helpersModel emptyContext emptyOptions + seen <- readIORef seenRef + expected <- streamingComplete (\_ _ _ -> Stream.fromList events) helpersModel emptyContext emptyOptions + listed <- streamRequestListWith (scriptRegistry scripted) helpersModel emptyContext emptyOptions + seen @?= events + listed @?= events + resp @?= expected, + testCase "ApiKeyEnvChain resolves the first set environment variable" $ do + let first = "BAIKAI_HELPERS_CHAIN_FIRST" + second = "BAIKAI_HELPERS_CHAIN_SECOND" + withUnsetEnv first $ + withUnsetEnv second $ do + Environment.setEnv second "second-key" + resolved <- resolveApiKey (ApiKeyEnvChain [first, second]) + resolved @?= "second-key" + Environment.setEnv first "first-key" + resolvedFirst <- resolveApiKey (ApiKeyEnvChain [first, second]) + resolvedFirst @?= "first-key", + testCase "ApiKeyEnvChain reports all probed names when unset" $ do + let first = "BAIKAI_HELPERS_CHAIN_MISSING_A" + second = "BAIKAI_HELPERS_CHAIN_MISSING_B" + withUnsetEnv first $ + withUnsetEnv second $ do + thrown <- Exception.try (resolveApiKey (ApiKeyEnvChain [first, second])) :: IO (Either BaikaiError Text) + case thrown of + Left err -> do + err ^. #category @?= AuthError + assertBool "message should include first name" (Text.pack first `Text.isInfixOf` (err ^. #message)) + assertBool "message should include second name" (Text.pack second `Text.isInfixOf` (err ^. #message)) + Right key -> assertFailure ("expected auth error, got key: " <> Text.unpack key), + testCase "mkModel fills dispatch discriminators and defaults" $ do + let model = mkModel OpenAIChatCompletions "gpt-test" "https://example.test" + model ^. #api @?= OpenAIChatCompletions + model ^. #modelId @?= "gpt-test" + model ^. #baseUrl @?= "https://example.test" + model ^. #name @?= "gpt-test" + model ^. #provider @?= renderApi OpenAIChatCompletions, + testCase "newProviderRegistryFrom uses last provider for duplicate tags" $ do + reg <- + newProviderRegistryFrom + [oneShotProvider helpersApi "first", oneShotProvider helpersApi "second"] + resp <- completeRequestWith reg helpersModel emptyContext emptyOptions + flattenAssistantText (flattenAssistantBlocks resp) @?= "second", + testCase "assertRegistered passes when all tags exist and throws for missing tags" $ do + reg <- newProviderRegistryFrom [oneShotProvider helpersApi "ok"] + assertRegistered reg [helpersApi] + thrown <- + Exception.try (assertRegistered reg [helpersApi, Custom "missing-one", Custom "missing-two"]) :: + IO (Either BaikaiError ()) + case thrown of + Left err -> do + err ^. #category @?= ProviderUnavailable + assertBool "message should include first missing tag" ("missing-one" `Text.isInfixOf` (err ^. #message)) + assertBool "message should include second missing tag" ("missing-two" `Text.isInfixOf` (err ^. #message)) + Right () -> assertFailure "expected ProviderUnavailable" + ] + +data Scripted = Scripted + { scriptRegistry :: !ProviderRegistry, + scriptCallRef :: !(IORef Int) + } + +newScripted :: [Response] -> [AssistantMessageEvent] -> IO Scripted +newScripted responses events = do + reg <- newProviderRegistry + responsesRef <- newIORef responses + callsRef <- newIORef 0 + registerApiProviderWith reg $ + ApiProvider + { apiTag = helpersApi, + complete = scriptedComplete responsesRef callsRef, + stream = \_ _ _ -> Stream.fromList events + } + pure Scripted {scriptRegistry = reg, scriptCallRef = callsRef} + +scriptedComplete :: IORef [Response] -> IORef Int -> Model -> Context -> Options -> IO Response +scriptedComplete responsesRef callsRef model _ctx _opts = do + atomicModifyIORef' callsRef (\n -> (n + 1, ())) + mResp <- + atomicModifyIORef' responsesRef $ \case + [] -> ([], Nothing) + r : rs -> (rs, Just r) + pure $ + maybe + (errorResponse model epoch 0 (providerError "script exhausted")) + (stampModel model) + mResp + +scriptCalls :: Scripted -> IO Int +scriptCalls scripted = readIORef (scriptCallRef scripted) + +registerOneShot :: Api -> Response -> IO () +registerOneShot apiTag resp = + registerApiProvider + ApiProvider + { apiTag, + complete = \model _ctx _opts -> pure (stampModel model resp), + stream = \_ _ _ -> Stream.fromList [] + } + +oneShotProvider :: Api -> Text -> ApiProvider +oneShotProvider apiTag body = + ApiProvider + { apiTag, + complete = \model _ctx _opts -> pure (stampModel model (textResponse body)), + stream = \_ _ _ -> Stream.fromList [] + } + +errorProvider :: Api -> BaikaiError -> ApiProvider +errorProvider apiTag err = + ApiProvider + { apiTag, + complete = \model _ctx _opts -> pure (errorResponse model epoch 0 err), + stream = \_ _ _ -> Stream.fromList [] + } + +stampModel :: Model -> Response -> Response +stampModel model resp = + resp + & #model + .~ model + & #api + .~ (model ^. #api) + & #provider + .~ (model ^. #provider) + +toolUseResponse :: Text -> Text -> Response +toolUseResponse callId toolName = + responseWith + ToolUse + (Vector.singleton (AssistantToolCall (emptyToolCall {id_ = callId, name = toolName, arguments = Aeson.object []}))) + Nothing + +toolUseNoCallsResponse :: Response +toolUseNoCallsResponse = + responseWith ToolUse (Vector.singleton (AssistantText (TextContent "no calls"))) Nothing + +textResponse :: Text -> Response +textResponse body = + responseWith Stop (Vector.singleton (AssistantText (TextContent body))) Nothing + +responseWith :: StopReason -> Vector AssistantContent -> Maybe Text -> Response +responseWith sr blocks err = + emptyResponse + & #message + .~ AssistantPayload + { content = blocks, + usage = zeroUsage, + stopReason = sr, + errorMessage = err, + timestamp = Just epoch + } + & #model + .~ helpersModel + & #api + .~ helpersApi + & #provider + .~ "helpers" + +responseStop :: Response -> StopReason +responseStop Response {message = AssistantPayload {stopReason = sr}} = sr + +assertResolvedExchange :: Text -> Text -> Message -> Message -> IO () +assertResolvedExchange callId expectedText assistantMsg resultMsg = do + case assistantMsg of + AssistantMessage AssistantPayload {content = blocks, stopReason = sr} -> do + sr @?= ToolUse + case [tc | AssistantToolCall tc <- Vector.toList blocks] of + [tc] -> tc ^. #id_ @?= callId + calls -> assertFailure ("expected one tool call, got: " <> show calls) + _ -> assertFailure ("expected assistant tool-use message, got: " <> show assistantMsg) + case resultMsg of + ToolResultMessage ToolResultPayload {toolCallId = actual, content = blocks, isError = err} -> do + actual @?= callId + err @?= False + toolText blocks @?= expectedText + _ -> assertFailure ("expected tool result message, got: " <> show resultMsg) + +toolText :: Vector ToolResultContent -> Text +toolText = + Text.concat + . Vector.toList + . Vector.mapMaybe + ( \case + ToolResultText (TextContent t) -> Just t + _ -> Nothing + ) + +textEvents :: Text -> Text -> [AssistantMessageEvent] +textEvents rid body = + let msg = + AssistantMessage + AssistantPayload + { content = Vector.singleton (AssistantText (TextContent body)), + usage = zeroUsage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = Just epoch + } + start = + AssistantMessage + AssistantPayload + { content = Vector.empty, + usage = zeroUsage, + stopReason = Stop, + errorMessage = Nothing, + timestamp = Just epoch + } + in [ EventStart StartPayload {partial = start, responseId = Just rid}, + TextStart IndexPayload {contentIndex = 0}, + TextDelta DeltaPayload {contentIndex = 0, delta = body}, + TextEnd BlockEndPayload {contentIndex = 0, content = body}, + EventDone (doneTerminal (Just rid) Stop msg) + ] + +withUnsetEnv :: String -> IO a -> IO a +withUnsetEnv name action = + Exception.bracket + ( do + old <- Environment.lookupEnv name + Environment.unsetEnv name + pure old + ) + restore + (const action) + where + restore Nothing = Environment.unsetEnv name + restore (Just value) = Environment.setEnv name value diff --git a/test/InteractiveSpec.hs b/test/InteractiveSpec.hs --- a/test/InteractiveSpec.hs +++ b/test/InteractiveSpec.hs @@ -18,11 +18,11 @@ requestDefaultTest :: TestTree requestDefaultTest = - testCase "_InteractiveLaunchRequest keeps optional launch settings empty" $ do - let req = _InteractiveLaunchRequest "start here" + testCase "interactiveLaunchRequest keeps optional launch settings empty" $ do + let req = interactiveLaunchRequest "start here" req ^. #systemPrompt @?= Nothing req ^. #userPrompt @?= "start here" - req ^. #model @?= Nothing + req ^. #modelId @?= Nothing req ^. #workingDir @?= Nothing req ^. #extraDirs @?= [] req ^. #safety @?= DefaultSafety @@ -49,7 +49,7 @@ resultConstructorTest :: TestTree resultConstructorTest = - testCase "_InteractiveLaunchResult records provider identity and process status" $ do - let result = _InteractiveLaunchResult InteractiveCodex ExitSuccess + testCase "interactiveLaunchResult records provider identity and process status" $ do + let result = interactiveLaunchResult InteractiveCodex ExitSuccess result ^. #provider @?= InteractiveCodex result ^. #exitCode @?= ExitSuccess diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,8 +2,11 @@ import AgentAssetsSpec qualified import Baikai +import Baikai.Models.Generated import Baikai.Prelude import CatalogSpec qualified +import CliInternalSpec qualified +import ContextSpec qualified import CostSpec qualified import Data.Aeson qualified as Aeson import Data.ByteString.Char8 qualified as BS8 @@ -14,10 +17,16 @@ import ErrorInfoSpec qualified import ErrorSpec qualified import FetchModelsSpec qualified +import GenModelsSpec qualified +import HelpersSpec qualified import InteractiveSpec qualified +import StreamSpec qualified import Streamly.Data.Stream qualified as Stream +import SurfaceSpec qualified import Test.Tasty (TestTree, defaultMain, testGroup) import Test.Tasty.HUnit (assertBool, testCase, (@?=)) +import Test.Tasty.QuickCheck (Gen) +import Test.Tasty.QuickCheck qualified as QC import TraceSpec qualified import UsageSpec qualified @@ -29,7 +38,7 @@ testModel :: Model testModel = - _Model + emptyModel & #modelId .~ "test-model" & #name @@ -50,14 +59,14 @@ testProvider providerName canned = let handler m _ctx _opts = pure $ - _Response + emptyResponse & #message .~ AssistantPayload { content = V.singleton (AssistantText (TextContent canned)), - usage = _Usage, + usage = zeroUsage, stopReason = Stop, errorMessage = Nothing, - timestamp = read "2026-06-05 00:00:00 UTC" + timestamp = Just (read "2026-06-05 00:00:00 UTC") } & #model .~ m @@ -80,12 +89,18 @@ [ tests, AgentAssetsSpec.tests, CatalogSpec.tests, + CliInternalSpec.tests, + ContextSpec.tests, CostSpec.tests, EmbeddingSpec.tests, ErrorInfoSpec.tests, ErrorSpec.tests, FetchModelsSpec.tests, + GenModelsSpec.tests, + HelpersSpec.tests, InteractiveSpec.tests, + StreamSpec.tests, + SurfaceSpec.tests, TraceSpec.tests, UsageSpec.tests ] @@ -94,39 +109,39 @@ tests = testGroup "baikai EP-2" - [ testCase "_Context defaults are zero-y" $ do - _Context ^. #systemPrompt @?= Nothing - V.length (_Context ^. #messages) @?= 0, - testCase "_Options defaults are zero-y" $ do - _Options ^. #maxTokens @?= Nothing - _Options ^. #temperature @?= Nothing - _Options ^. #apiKey @?= Nothing - _Options ^. #responseFormat @?= Nothing, + [ testCase "emptyContext defaults are zero-y" $ do + emptyContext ^. #systemPrompt @?= Nothing + V.length (emptyContext ^. #messages) @?= 0, + testCase "emptyOptions defaults are zero-y" $ do + emptyOptions ^. #maxTokens @?= Nothing + emptyOptions ^. #temperature @?= Nothing + emptyOptions ^. #apiKey @?= Nothing + emptyOptions ^. #responseFormat @?= Nothing, testCase "responseFormat round-trips through Options" $ do - responseFormat (_Options & #responseFormat .~ Just JsonObject) + responseFormat (emptyOptions & #responseFormat .~ Just JsonObject) @?= Just JsonObject let person = Aeson.object [ "type" Aeson..= ("object" :: Text) ] schemaFmt = JsonSchema {name = "person", schema = person, strict = True} - responseFormat (_Options & #responseFormat .~ Just schemaFmt) + responseFormat (emptyOptions & #responseFormat .~ Just schemaFmt) @?= Just schemaFmt, testCase "Options Show redacts literal API keys" $ do let secret = "sk-baikai-secret-never-print" - opts = _Options & #apiKey .~ Just (ApiKeyLiteral secret) + opts = emptyOptions & #apiKey .~ Just (ApiKeyLiteral secret) assertBool "show opts must not contain the raw API key" (not (secret `Text.isInfixOf` Text.pack (show opts))), testCase "Options JSON redacts literal API keys" $ do let secret = "sk-baikai-secret-never-print" - opts = _Options & #apiKey .~ Just (ApiKeyLiteral secret) + opts = emptyOptions & #apiKey .~ Just (ApiKeyLiteral secret) assertBool "Aeson.encode opts must not contain the raw API key" (not (secret `Text.isInfixOf` Text.pack (LBS8.unpack (Aeson.encode opts)))), testCase "completeRequest dispatches through the registered handler" $ do - let ctx = _Context & #messages .~ V.fromList [user "ping"] - resp <- completeRequest testModel ctx _Options + let ctx = emptyContext & #messages .~ V.fromList [user "ping"] + resp <- completeRequest testModel ctx emptyOptions flattenAssistantBlocks resp @?= V.singleton (AssistantText (TextContent "hello from the test provider")) (resp ^. #model) ^. #modelId @?= "test-model" @@ -136,9 +151,9 @@ regB <- newProviderRegistry registerApiProviderWith regA (testProvider "provider-a" "hello from A") registerApiProviderWith regB (testProvider "provider-b" "hello from B") - let ctx = _Context & #messages .~ V.fromList [user "ping"] - respA <- completeRequestWith regA testModel ctx _Options - respB <- completeRequestWith regB testModel ctx _Options + let ctx = emptyContext & #messages .~ V.fromList [user "ping"] + respA <- completeRequestWith regA testModel ctx emptyOptions + respB <- completeRequestWith regB testModel ctx emptyOptions flattenAssistantBlocks respA @?= V.singleton (AssistantText (TextContent "hello from A")) flattenAssistantBlocks respB @@ -148,14 +163,14 @@ testCase "streamRequestWith dispatches through an explicit registry" $ do reg <- newProviderRegistry registerApiProviderWith reg (testProvider "stream-provider" "hello from stream") - let ctx = _Context & #messages .~ V.fromList [user "ping"] - events <- Stream.toList (streamRequestWith reg testModel ctx _Options) + let ctx = emptyContext & #messages .~ V.fromList [user "ping"] + events <- Stream.toList (streamRequestWith reg testModel ctx emptyOptions) resp <- Stream.fold (reassembleResponse testModel) (Stream.fromList events) flattenAssistantBlocks resp @?= V.singleton (AssistantText (TextContent "hello from stream")), testCase "OpenAI compat auto-detection drives provider request policy" $ do let deepseek = - _Model + emptyModel & #api .~ OpenAIChatCompletions & #baseUrl @@ -163,8 +178,40 @@ compat = openaiCompletionsCompatFor deepseek compat ^. #thinkingFormat @?= ThinkingFormatDeepseek compat ^. #maxTokensField @?= MaxTokensField - compat ^. #supportsStrictMode @?= False - compat ^. #supportsDeveloperRole @?= False, + compat ^. #supportsStrictMode @?= False, + testCase "host auto-detection is suffix-bounded" $ do + urlHost "http://user@openrouter.ai:8443/api" @?= Just "openrouter.ai" + autoDetectOpenAICompletions "https://api.xyz.ai" + @?= defaultOpenAICompletionsCompat + autoDetectOpenAICompletions "https://evil-z.ai.example.com" + @?= defaultOpenAICompletionsCompat + autoDetectOpenAICompletions "https://api.z.ai/v1" + ^. #thinkingFormat + @?= ThinkingFormatZai + autoDetectOpenAICompletions "https://API.DEEPSEEK.COM" + ^. #thinkingFormat + @?= ThinkingFormatDeepseek + autoDetectOpenAICompletions "http://user@openrouter.ai:8443/api" + ^. #thinkingFormat + @?= ThinkingFormatOpenRouter + autoDetectOpenAICompletions "" + @?= defaultOpenAICompletionsCompat, + QC.testProperty "unknown OpenAI host suffixes use defaults" $ + QC.forAll unknownHostGen $ \host -> + QC.property $ + autoDetectOpenAICompletions ("https://" <> Text.pack host) + == defaultOpenAICompletionsCompat, + testCase "default API-key env table matches known hosts" $ do + defaultApiKeyEnvForBaseUrl "https://api.deepseek.com/v1" + @?= Just "DEEPSEEK_API_KEY" + defaultApiKeyEnvForBaseUrl "http://user@openrouter.ai:8443/api" + @?= Just "OPENROUTER_API_KEY" + defaultApiKeyEnvForBaseUrl "https://dashscope-intl.aliyuncs.com/compatible-mode/v1" + @?= Just "DASHSCOPE_API_KEY" + defaultApiKeyEnvForBaseUrl "https://api.xyz.ai" + @?= Nothing + defaultApiKeyEnvForBaseUrl "" + @?= Nothing, testCase "explicit OpenAI compat overrides baseUrl auto-detection" $ do let explicit = defaultOpenAICompletionsCompat @@ -172,7 +219,7 @@ thinkingFormat = ThinkingFormatNone } model = - _Model + emptyModel & #api .~ OpenAIChatCompletions & #baseUrl @@ -184,7 +231,7 @@ compat ^. #thinkingFormat @?= ThinkingFormatNone, testCase "Anthropic compat auto-detection drives cache request policy" $ do let fireworks = - _Model + emptyModel & #api .~ AnthropicMessages & #baseUrl @@ -192,13 +239,39 @@ compat = anthropicMessagesCompatFor fireworks compat ^. #supportsCacheControlOnTools @?= False compat ^. #sendSessionAffinityHeaders @?= True - compat ^. #supportsLongCacheRetention @?= False, + compat ^. #supportsLongCacheRetention @?= False + compat ^. #thinkingStyle @?= AnthropicThinkingBudget, + testCase "Anthropic compat defaults thinking style by model generation" $ do + anthropicMessagesCompatFor anthropic_claude_opus_4_6 + ^. #thinkingStyle + @?= AnthropicThinkingAdaptive + anthropicMessagesCompatFor anthropic_claude_opus_4_7 + ^. #thinkingStyle + @?= AnthropicThinkingAdaptive + anthropicMessagesCompatFor anthropic_claude_opus_4_8 + ^. #thinkingStyle + @?= AnthropicThinkingAdaptive + anthropicMessagesCompatFor anthropic_claude_fable_5 + ^. #thinkingStyle + @?= AnthropicThinkingAdaptive + anthropicMessagesCompatFor anthropic_claude_haiku_4_5 + ^. #thinkingStyle + @?= AnthropicThinkingBudget + anthropicMessagesCompatFor anthropic_claude_opus_4_5 + ^. #thinkingStyle + @?= AnthropicThinkingBudget + anthropicMessagesCompatFor anthropic_claude_sonnet_4_5 + ^. #thinkingStyle + @?= AnthropicThinkingBudget + anthropicMessagesCompatFor anthropic_claude_sonnet_4_6 + ^. #thinkingStyle + @?= AnthropicThinkingBudget, testCase "user smart constructor produces a UserMessage" $ do let ts = read "2026-06-05 01:02:03 UTC" case userAt ts "hello" of UserMessage UserPayload {content = uc, timestamp = actualTs} -> do uc @?= V.singleton (UserText (TextContent "hello")) - actualTs @?= ts + actualTs @?= Just ts _ -> error "expected UserMessage", testCase "assistant smart constructor produces an AssistantMessage" $ do let ts = read "2026-06-05 01:02:03 UTC" @@ -206,7 +279,7 @@ AssistantMessage AssistantPayload {content = ac, stopReason = sr, timestamp = actualTs} -> do ac @?= V.singleton (AssistantText (TextContent "world")) sr @?= Stop - actualTs @?= ts + actualTs @?= Just ts _ -> error "expected AssistantMessage", testCase "effectful user constructor produces a UserMessage in IO" $ do msg <- userNow "hello now" @@ -216,19 +289,19 @@ _ -> error "expected UserMessage", testCase "appendToolResult carries text, image, and error payloads" $ do let textCall = - _ToolCall + emptyToolCall { id_ = "call_text", name = "text_tool", arguments = Aeson.object [] } imageCall = - _ToolCall + emptyToolCall { id_ = "call_image", name = "image_tool", arguments = Aeson.object [] } errorCall = - _ToolCall + emptyToolCall { id_ = "call_error", name = "error_tool", arguments = Aeson.object [] @@ -242,16 +315,16 @@ AssistantToolCall imageCall, AssistantToolCall errorCall ], - usage = _Usage, + usage = zeroUsage, stopReason = ToolUse, errorMessage = Nothing, - timestamp = read "2026-06-05 00:00:00 UTC" + timestamp = Just (read "2026-06-05 00:00:00 UTC") } - resp = _Response & #message .~ assistantPayload + resp = emptyResponse & #message .~ assistantPayload assistantPayload = case assistantTurn of AssistantMessage p -> p _ -> error "expected assistant fixture" - ctx0 = _Context & #messages .~ V.singleton (user "use tools") + ctx0 = emptyContext & #messages .~ V.singleton (user "use tools") image = ImageContent {imageData = BS8.pack "png-bytes", mimeType = "image/png"} dispatcher tc = case tc ^. #name of "text_tool" -> pure (toolResultText "text result") @@ -279,3 +352,8 @@ err @?= True msgs -> error ("unexpected context messages: " <> show msgs) ] + +unknownHostGen :: Gen String +unknownHostGen = do + label <- QC.listOf1 (QC.elements (['a' .. 'z'] <> ['0' .. '9'])) + pure (label <> ".example.invalid") diff --git a/test/StreamSpec.hs b/test/StreamSpec.hs new file mode 100644 --- /dev/null +++ b/test/StreamSpec.hs @@ -0,0 +1,186 @@ +module StreamSpec (tests) where + +import Baikai +import Baikai.Prelude +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay, throwTo) +import Control.Exception qualified as Exception +import Data.Aeson qualified as Aeson +import Data.Time (UTCTime) +import Data.Vector qualified as Vector +import Streamly.Data.Stream qualified as Stream +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) + +streamApi :: Api +streamApi = Custom "baikai-stream-spec" + +streamModel :: Model +streamModel = + emptyModel + & #modelId + .~ "stream-spec-model" + & #api + .~ streamApi + & #provider + .~ "stream-spec" + +streamContext :: Context +streamContext = emptyContext + +streamOptions :: Options +streamOptions = emptyOptions + +epoch :: UTCTime +epoch = read "2000-01-01 00:00:00 UTC" + +assistantPayload :: Vector AssistantContent -> StopReason -> Maybe Text -> UTCTime -> AssistantPayload +assistantPayload blocks sr err ts = + AssistantPayload + { content = blocks, + usage = zeroUsage, + stopReason = sr, + errorMessage = err, + timestamp = Just ts + } + +assistantMessage :: [AssistantContent] -> Message +assistantMessage blocks = + AssistantMessage (assistantPayload (Vector.fromList blocks) Stop Nothing epoch) + +responseWith :: Maybe Text -> [AssistantContent] -> Response +responseWith rid blocks = + emptyResponse + & #message + .~ assistantPayload (Vector.fromList blocks) Stop Nothing epoch + & #model + .~ streamModel + & #api + .~ streamApi + & #provider + .~ "stream-spec" + & #responseId + .~ rid + +runEvents :: [AssistantMessageEvent] -> IO Response +runEvents events = + Stream.fold (reassembleResponse streamModel) (Stream.fromList events) + +startEvent :: Maybe Text -> AssistantMessageEvent +startEvent rid = + EventStart StartPayload {partial = assistantMessage [], responseId = rid} + +doneEvent :: Maybe Text -> [AssistantContent] -> AssistantMessageEvent +doneEvent rid blocks = + EventDone (doneTerminal rid Stop (assistantMessage blocks)) + +signedThinking :: ThinkingContent +signedThinking = + ThinkingContent {thinking = "t", signature = Just "sig-abc", redacted = True} + +tests :: TestTree +tests = + testGroup + "Baikai.Stream reassembly" + [ testCase "thinking signature and redacted flag survive lift + reassembly" $ do + let blocks = + [ AssistantThinking signedThinking, + AssistantText (TextContent "answer") + ] + handler _ _ _ = pure (responseWith (Just "lifted-id") blocks) + resp <- streamingComplete (liftCompleteToStream handler) streamModel streamContext streamOptions + resp ^. #message ^. #content @?= Vector.fromList blocks, + testCase "ThinkingEnd carries the full ThinkingContent" $ do + resp <- + runEvents + [ startEvent Nothing, + ThinkingStart IndexPayload {contentIndex = 0}, + ThinkingDelta DeltaPayload {contentIndex = 0, delta = "t"}, + ThinkingEnd ThinkingEndPayload {contentIndex = 0, content = signedThinking}, + doneEvent Nothing [] + ] + resp ^. #message ^. #content @?= Vector.singleton (AssistantThinking signedThinking), + testCase "terminal message content is authoritative" $ do + resp <- + runEvents + [ startEvent Nothing, + TextStart IndexPayload {contentIndex = 0}, + TextDelta DeltaPayload {contentIndex = 0, delta = "partial"}, + TextEnd BlockEndPayload {contentIndex = 0, content = "partial"}, + doneEvent Nothing [AssistantText (TextContent "the real full text")] + ] + resp ^. #message ^. #content @?= Vector.singleton (AssistantText (TextContent "the real full text")), + testCase "responseId flows from events to Response" $ do + fromStart <- runEvents [startEvent (Just "msg_123"), doneEvent Nothing []] + fromStart ^. #responseId @?= Just "msg_123" + fromTerminal <- runEvents [startEvent (Just "msg_123"), doneEvent (Just "msg_456") []] + fromTerminal ^. #responseId @?= Just "msg_456", + testCase "dangling buffers keep contentIndex order; tool args flushed" $ do + resp <- + runEvents + [ startEvent Nothing, + TextStart IndexPayload {contentIndex = 0}, + TextDelta DeltaPayload {contentIndex = 0, delta = "first"}, + TextEnd BlockEndPayload {contentIndex = 0, content = "first"}, + ThinkingStart IndexPayload {contentIndex = 1}, + ThinkingDelta DeltaPayload {contentIndex = 1, delta = "partial-think"}, + TextStart IndexPayload {contentIndex = 2}, + TextDelta DeltaPayload {contentIndex = 2, delta = "last"}, + TextEnd BlockEndPayload {contentIndex = 2, content = "last"}, + ToolCallStart IndexPayload {contentIndex = 3}, + ToolCallDelta DeltaPayload {contentIndex = 3, delta = "{\"a\":1"} + ] + let expected = + Vector.fromList + [ AssistantText (TextContent "first"), + AssistantThinking ThinkingContent {thinking = "partial-think", signature = Nothing, redacted = False}, + AssistantText (TextContent "last"), + AssistantToolCall ToolCall {id_ = "", name = "", arguments = Aeson.String "{\"a\":1"} + ] + resp ^. #message ^. #content @?= expected + resp ^. #message ^. #stopReason @?= Stop + resp ^. #message ^. #errorMessage @?= Just "stream ended without terminal event", + testCase "latencyMs is clamped at zero" $ do + let oldResponse = + responseWith Nothing [AssistantText (TextContent "old")] + & #message + %~ (#timestamp .~ Just epoch) + handler _ _ _ = pure oldResponse + resp <- streamingComplete (liftCompleteToStream handler) streamModel streamContext streamOptions + assertBool "latencyMs should be non-negative" (resp ^. #latencyMs >= 0), + testCase "async exceptions pass through liftCompleteToStream" $ do + done <- newEmptyMVar + let blocked _ _ _ = threadDelay (10 * 1000 * 1000) *> pure (responseWith Nothing []) + tid <- + forkIO $ do + outcome <- Exception.try (Stream.toList (liftCompleteToStream blocked streamModel streamContext streamOptions)) + putMVar done (outcome :: Either Exception.SomeException [AssistantMessageEvent]) + threadDelay 100000 + throwTo tid Exception.ThreadKilled + outcome <- takeMVar done + case outcome of + Left e -> + (Exception.fromException e :: Maybe Exception.AsyncException) + @?= Just Exception.ThreadKilled + Right events -> assertFailure ("expected ThreadKilled, got events: " <> show events), + testCase "error-only streams begin with EventStart" $ do + reg <- newProviderRegistry + noProviderEvents <- Stream.toList (streamRequestWith reg streamModel streamContext streamOptions) + case noProviderEvents of + [ EventStart StartPayload {}, + EventError TerminalPayload {errorInfo = Just be} + ] -> + be ^. #category @?= ProviderUnavailable + other -> assertFailure ("expected EventStart then provider-unavailable EventError, got: " <> show other) + + let throwing _ _ _ = Exception.throwIO (rateLimited (Just 5) "slow down") + liftedEvents <- Stream.toList (liftCompleteToStream throwing streamModel streamContext streamOptions) + case liftedEvents of + [EventStart StartPayload {}, EventError {}] -> pure () + other -> assertFailure ("expected EventStart then EventError, got: " <> show other) + resp <- runEvents liftedEvents + case resp ^. #errorInfo of + Just be -> do + be ^. #category @?= RateLimited + be ^. #retryAfterSeconds @?= Just 5 + Nothing -> assertFailure "expected lifted BaikaiError to survive reassembly" + ] diff --git a/test/SurfaceSpec.hs b/test/SurfaceSpec.hs new file mode 100644 --- /dev/null +++ b/test/SurfaceSpec.hs @@ -0,0 +1,53 @@ +module SurfaceSpec (tests) where + +import Baikai +import Baikai.Embedding qualified as Embedding +import Baikai.Prelude +import Data.Aeson qualified as Aeson +import Data.Map.Strict qualified as Map +import Data.Vector qualified as V +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit (testCase, (@?=)) + +tests :: TestTree +tests = + testGroup + "surface" + [ testCase "abstract records build from public bases and selectors" $ do + let opts = + emptyOptions + & #maxTokens + .~ Just 32 + & #topP + .~ Just 0.9 + ctx = + emptyContext + & #systemPrompt + .~ Just "Be brief." + & #messages + .~ V.singleton (user "hello") + model = + mkModel OpenAIChatCompletions "gpt-test" "https://api.example.test" + & #headers + .~ Map.singleton "x-test" "1" + response = + emptyResponse + & #model + .~ model + & #message + . #content + .~ V.singleton (AssistantText emptyTextContent {text = "ok"}) + req = interactiveLaunchRequest "inspect" & #modelId .~ Just "gpt-test" + opts ^. #maxTokens @?= Just 32 + ctx ^. #systemPrompt @?= Just "Be brief." + (response ^. #model) ^. #modelId @?= "gpt-test" + req ^. #modelId @?= Just "gpt-test", + testCase "zero and empty bases cover the public rename map" $ do + zeroUsage ^. #totalTokens @?= 0 + zeroCost ^. #usd @?= 0 + zeroCostBreakdown ^. #inputUsd @?= 0 + zeroModelCost ^. #inputCost @?= 0 + emptyTool ^. #parameters @?= Aeson.Null + emptyToolCall ^. #arguments @?= Aeson.Null + Embedding.modelId Embedding.emptyEmbeddingModel @?= "" + ] diff --git a/test/TraceSpec.hs b/test/TraceSpec.hs --- a/test/TraceSpec.hs +++ b/test/TraceSpec.hs @@ -2,25 +2,31 @@ import Baikai.Api (Api (..)) import Baikai.Content (AssistantContent (..), TextContent (..)) -import Baikai.Context (Context (..), _Context) +import Baikai.Context (Context (..), emptyContext) import Baikai.Error (BaikaiError, providerError) import Baikai.Message (AssistantPayload (..), user) -import Baikai.Model (Model (..), _Model) -import Baikai.Options (Options, _Options) +import Baikai.Model (Model (..), emptyModel) +import Baikai.Options (Options, emptyOptions) import Baikai.Prelude import Baikai.Provider (ApiProvider (..), registerApiProvider) import Baikai.Response (Response (..)) import Baikai.StopReason (StopReason (..)) import Baikai.Stream (liftCompleteToStream) -import Baikai.Trace (withTrace) +import Baikai.Trace (newEventId, withTrace, withTraceStream) import Baikai.Trace.Event (TraceEvent (..)) import Baikai.Trace.Sink (TraceSink (..), silent) -import Baikai.Usage (_Usage) +import Baikai.Usage (zeroUsage) +import Control.Concurrent (threadDelay) import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVarIO) import Control.Exception (throwIO) +import Control.Monad (replicateM) +import Data.Set qualified as Set import Data.Text qualified as Text import Data.Vector qualified as V import Streamly.Data.Fold qualified as Fold +import Streamly.Data.Stream qualified as Stream +import System.Mem (performMajorGC) +import System.Timeout (timeout) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (assertBool, assertFailure, testCase, (@?=)) @@ -30,7 +36,10 @@ "Baikai.Trace" [ silentTest, memoryFinishTest, - memoryFailTest + memoryFailTest, + throwingSinkTest, + eventIdUniquenessTest, + earlyAbortTest ] -- | Each test uses its own private 'Api' tag so tasty's parallel @@ -38,7 +47,7 @@ -- tests. stubModel :: Api -> Model stubModel a = - _Model + emptyModel & #modelId .~ "stub-1" & #api @@ -49,10 +58,10 @@ .~ 16 stubContext :: Context -stubContext = _Context & #messages .~ V.fromList [user "hello"] +stubContext = emptyContext & #messages .~ V.fromList [user "hello"] stubOptions :: Options -stubOptions = _Options & #maxTokens .~ Just 16 +stubOptions = emptyOptions & #maxTokens .~ Just 16 stubResponse :: Api -> Response stubResponse a = @@ -60,10 +69,10 @@ { message = AssistantPayload { content = V.singleton (AssistantText (TextContent "hi")), - usage = _Usage, + usage = zeroUsage, stopReason = Stop, errorMessage = Nothing, - timestamp = read "2026-05-14 00:00:00 UTC" + timestamp = Just (read "2026-05-14 00:00:00 UTC") }, model = stubModel a, api = a, @@ -160,3 +169,59 @@ ("expected error to mention stub-failure, got: " <> show msg) ("stub-failure" `Text.isInfixOf` msg) _ -> assertFailure ("unexpected event sequence: " <> show events) + +throwingSink :: TraceSink +throwingSink = + TraceSink (Fold.drainMapM (\_ -> throwIO (providerError "sink exploded"))) + +throwingSinkTest :: TestTree +throwingSinkTest = + testCase "a throwing sink cannot hang withTrace" $ do + let a = Custom "baikai-trace-throwing-sink" + registerOk a + result <- timeout 5000000 (withTrace throwingSink (stubModel a) stubContext stubOptions) + case result of + Nothing -> assertFailure "withTrace hung on a throwing sink" + Just resp -> do + let AssistantPayload {stopReason = sr} = resp ^. #message + sr @?= Stop + +eventIdUniquenessTest :: TestTree +eventIdUniquenessTest = + testCase "newEventId yields 70000 distinct 16-char ids" $ do + ids <- replicateM 70000 newEventId + Set.size (Set.fromList ids) @?= 70000 + assertBool "every id is 16 chars" (all ((== 16) . Text.length) ids) + +earlyAbortTest :: TestTree +earlyAbortTest = + testCase "early abort pushes a synthetic CallFailed" $ do + let a = Custom "baikai-trace-abort" + registerOk a + (ref, sink) <- memorySink + emitted <- + Stream.toList + (Stream.take 1 (withTraceStream sink (stubModel a) stubContext stubOptions)) + length emitted @?= 1 + events <- awaitEvents ref 2 + case events of + [s@CallStarted {}, f@CallFailed {errorMessage = msg}] -> do + (s ^. #eventId :: Text) @?= (f ^. #eventId :: Text) + assertBool + ("expected abort message, got: " <> show msg) + ("aborted" `Text.isInfixOf` msg) + _ -> assertFailure ("unexpected event sequence: " <> show events) + +-- The trace finalizer on an abandoned stream runs from streamly's GC hook. +awaitEvents :: TVar [TraceEvent] -> Int -> IO [TraceEvent] +awaitEvents ref n = go (100 :: Int) + where + go 0 = do + evs <- readTVarIO ref + assertFailure ("timed out waiting for trace events; got: " <> show (reverse evs)) + go k = do + performMajorGC + evs <- readTVarIO ref + if length evs >= n + then pure (reverse evs) + else threadDelay 50000 >> go (k - 1) diff --git a/test/UsageSpec.hs b/test/UsageSpec.hs --- a/test/UsageSpec.hs +++ b/test/UsageSpec.hs @@ -1,7 +1,7 @@ module UsageSpec (tests) where -import Baikai.Cost (Cost (..), CostBreakdown (..), _Cost, _CostBreakdown) -import Baikai.Usage (Usage (..), sumUsage, _Usage) +import Baikai.Cost (Cost (..), CostBreakdown (..), zeroCost, zeroCostBreakdown) +import Baikai.Usage (Usage (..), sumUsage, zeroUsage) import Test.Tasty (TestTree, testGroup) import Test.Tasty.HUnit (testCase, (@?=)) @@ -12,6 +12,7 @@ [ identityTests, additionTests, reasoningTests, + documentedSemanticsTests, costTests, sumUsageTests ] @@ -19,7 +20,7 @@ -- | A non-trivial usage value for identity checks. u0 :: Usage u0 = - _Usage + zeroUsage { inputTokens = 10, outputTokens = 5, cacheReadTokens = 2, @@ -50,7 +51,7 @@ "monoid identity" [ testCase "mempty <> u == u" $ (mempty <> u0) @?= u0, testCase "u <> mempty == u" $ (u0 <> mempty) @?= u0, - testCase "mempty == _Usage" $ (mempty :: Usage) @?= _Usage + testCase "mempty == zeroUsage" $ (mempty :: Usage) @?= zeroUsage ] additionTests :: TestTree @@ -58,8 +59,8 @@ 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} + let a = zeroUsage {inputTokens = 10, outputTokens = 5, cacheReadTokens = 2, cacheWriteTokens = 1, totalTokens = 15} + b = zeroUsage {inputTokens = 3, outputTokens = 1, cacheReadTokens = 4, cacheWriteTokens = 5, totalTokens = 4} s = a <> b inputTokens s @?= 13 outputTokens s @?= 6 @@ -82,16 +83,37 @@ reasoningTokens (rJust 2 <> rJust 3) @?= Just 5 ] where - rJust n = _Usage {reasoningTokens = Just n} - rNothing = _Usage {reasoningTokens = Nothing} + rJust n = zeroUsage {reasoningTokens = Just n} + rNothing = zeroUsage {reasoningTokens = Nothing} +-- Provider mappings must uphold the documented field semantics: +-- 'anthroUsageToBaikai' in baikai-claude/src/Baikai/Provider/Claude/Api.hs +-- and 'rawUsageToUsage' in baikai-openai/src/Baikai/Provider/OpenAI/Api.hs. +documentedSemanticsTests :: TestTree +documentedSemanticsTests = + testGroup + "documented field semantics" + [ testCase "totalTokens sums disjoint billed classes and excludes reasoning double-count" $ do + let u = + zeroUsage + { inputTokens = 20, + outputTokens = 50, + cacheReadTokens = 80, + cacheWriteTokens = 7, + reasoningTokens = Just 20, + totalTokens = 157 + } + totalTokens u + @?= inputTokens u + outputTokens u + cacheReadTokens u + cacheWriteTokens u + ] + 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} + let a = zeroUsage {cost = costOf 1 0 0 0} + b = zeroUsage {cost = costOf 2 0 0 0} c = cost (a <> b) usd c @?= 3 / 100 inputUsd (breakdown c) @?= 3 / 100, @@ -102,8 +124,8 @@ cachedInputUsd s @?= 10 / 100 cachedWriteUsd s @?= 12 / 100, testCase "mempty cost is zero" $ do - (mempty :: Cost) @?= _Cost - (mempty :: CostBreakdown) @?= _CostBreakdown + (mempty :: Cost) @?= zeroCost + (mempty :: CostBreakdown) @?= zeroCostBreakdown ] sumUsageTests :: TestTree @@ -111,9 +133,9 @@ 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} + let u1 = zeroUsage {inputTokens = 1, totalTokens = 1} + u2 = zeroUsage {inputTokens = 2, totalTokens = 2} + u3 = zeroUsage {inputTokens = 3, totalTokens = 3} sumUsage [u1, u2, u3] @?= (u1 <> u2 <> u3), testCase "sumUsage [] == mempty" $ sumUsage [] @?= (mempty :: Usage)