diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -5,8 +5,128 @@ The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.1.0/), and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0.html). -## [Unreleased] +## [0.3.0.0] - 2026-10-13 +### Added + +- Cross-provider history regression test (`test/LLM/CrossProviderSpec.hs`). + One mixed history (Claude → Gemini → OpenAI → Claude turns, a base64 + image, a redacted-thinking-only turn) is encoded by every provider and + checked against rules the live APIs enforce: Gemini thought signatures on + every function call, DeepSeek `reasoning_content` in thinking mode, no empty + assistant messages on the OpenAI protocol, only Claude thinking blocks and + paired tool ids for Claude, and no provider's opaque payload in another + provider's request. + +### Changed + +- **Breaking:** `LLMProvider.sendStreamRequest` is split into `openStream` + (HTTP transport; hands the raw body reader to a continuation) and + `parseStream` (turns raw body bytes into a response). Custom providers must + implement both. Streaming behaviour is unchanged; the split lets recorded + conversation fixtures capture the raw SSE body and replay it through the + real stream parsers. +- Agent runs (`generateText` / `streamText`) stay on a fallback model once it + has answered. Each tool round used to start again at `mwfModel`, so while + the primary was down every round paid its full retry/backoff/timeout cost + and the history alternated between providers. Now each round uses the chain + rotated so the model that answered comes first; models that failed move to + the end and remain a last resort. This lasts for one `generateText` / + `streamText` call; the next call starts from the caller's chain again. A + switch is logged once at `Info` ("Continuing run on …"). New + `withModelFallbacksRotated` (`LLM.Generate.GenerateUtils`), + `generateTextWithFallbacksRotated` and `streamTextWithFallbacksRotated` + (`LLM.Generate.Generate`). + +### Fixed + +- `remove_directory` no longer deletes the whole workspace when given a path + that resolves to the workspace root (`"."`, `""`, `"./"`, `"sub/.."`); it + returns an error message instead. `remove_file` and `move_file` (source) + refuse the root too, and `remove_file` on a directory returns a clear error + instead of throwing. New helper `isSandboxRoot` in `LLM.Tools.FsConfig`. +- `mcRequestTimeout` now applies to each attempt instead of covering all + retries and backoff sleeps, and `TimeoutError` is now retryable + (`isRetryable`). For streaming, the timeout only covers the time until the + first stream event, so long answers are no longer cut off. New + `withFirstEventTimeout` (`LLM.Core.Utils`) and `callWithRetry` + (`LLM.Generate.GenerateUtils`). +- **Breaking:** `StreamChunk` gains `StreamAttemptReset`. Streaming consumers + used to see duplicated output when an attempt failed after streaming some + chunks and a retry or fallback model started over. The reset is emitted + before the next attempt (only if the failed attempt streamed something); + consumers should discard the chunks of the current round when they get it. + Exhaustive pattern matches on `StreamChunk` need a new case. +- Claude thinking: `budget_tokens` is capped at `max_tokens - 1`; Anthropic + rejects a budget that is not below `max_tokens`, so medium effort or above + with `maxTokens: 4096` failed with HTTP 400 on every call. If `max_tokens` + leaves no room for the 1024-token minimum budget, the Claude gateway returns + `UnsupportedCapability` without sending the request (new + `checkClaudeThinkingBudget`). Example catalog: `haiku_4_5` uses + `maxTokens: 16000` so thinking leaves room for the answer. +- Mid-stream errors are no longer ignored. A Claude `event: error` or an + OpenAI-compatible `data: {"error": ...}` chunk (OpenAI, DeepSeek, Ollama) + now yields `HttpError status body` instead of partial content or + `EmptyResponse`. Claude error types map to Anthropic's HTTP statuses + (`overloaded_error` → 529, `rate_limit_error` → 429, `api_error` → 500, …), + so overload and rate limits are retried. OpenAI-style errors use their numeric + code if present, otherwise 429 / 503 / 500. +- Tool calls whose arguments are not valid JSON (e.g. cut off by `max_tokens` / + `finish_reason: "length"`) now yield `ParseError` instead of a tool call with + `String` arguments, in both streaming and non-streaming parsers. Empty + argument strings decode as `{}`. A non-streaming Claude response that stops + at `max_tokens` inside a `tool_use` block is also a `ParseError`. +- Tool execution, `safeHooks` and `emitEvent` no longer catch asynchronous + exceptions. A `timeout`, `killThread` or `cancel` during a tool call used to + become a "Tool error" result and the agent loop kept going. New `trySync` + in `LLM.Core.Utils`. +- `stripBoundsAndComments` is schema-aware: it removes `minimum` / `maximum` / + `$comment` keywords but keeps properties with those names and leaves + literal values (`enum`, `const`, `default`, `examples`) alone. Gemini applies + it only to tool `parameters` and `responseSchema` at body-build time, not to + the whole request (which could strip keys from tool-call arguments). +- OpenAI-compatible stream parser (OpenAI, DeepSeek, Ollama) keeps every tool + call in a chunk, not just the first. Ollama often sends all calls complete in + one chunk, sometimes without `index`; the array position is used then. Tool + calls are emitted in index order. +- Gemini: a `functionCall` part without a matching thought signature (a call + from another provider, or from a different Gemini model) now carries + Google's placeholder `"skip_thought_signature_validator"` (new + `skipThoughtSignatureValidator`). Gemini 3 rejected such history with + `400 "Function call is missing a thought_signature"`, so a fallback into + Gemini 3, or between two Gemini models, failed partway through a tool loop. +- DeepSeek with thinking enabled: every assistant message now carries + `reasoning_content`, `""` when the turn has no thinking text (turns from + OpenAI, Ollama, or Claude without thinking). DeepSeek rejected such history + with `400 "The reasoning_content in the thinking mode must be passed back"`. + Requests with thinking off are unchanged. **Breaking:** + `MessageEncodeOptions` is now a two-field record with the new + `meoRequireReasoning`; code that constructs it directly must set it. The + streamed DeepSeek fixture's requests gained the empty field. +- OpenAI-protocol providers (OpenAI, OpenRouter, Ollama, DeepSeek) no longer + send an assistant message with neither `content` nor `tool_calls`, e.g. a + Claude turn that held only (redacted) thinking. OpenAI rejected + `{"role":"assistant"}` with "expected a string, got null"; such turns now + send `"content": ""`. Tool-call-only turns still omit `content`. +- Image media types are checked per provider. `mkImageBase64` accepts HEIC + and HEIF, but only Gemini does; Claude, OpenAI, Ollama and DeepSeek return + 400 for anything but jpeg, png, gif and webp. A HEIC image in a Gemini + conversation broke the fallback to those providers, because the vision + check passed. `validateModelCapabilities` now skips a model whose gateway + does not accept every inline image's media type (`UnsupportedCapability`, + like a model without vision). URL images have no known type and are not + checked. New `commonImageMediaTypes` (`LLM.Core.Types`). **Breaking:** + `LLMGateway` gained `gwImageMediaTypes` and `LLMProvider` gained + `providerImageMediaTypes` (copied by `toGateway`); code that constructs + either directly must set it. +- Ollama models are skipped for conversations with URL images. Ollama's + OpenAI-compatible endpoint answers an `image_url` with an https URL with + `400 "image URLs are not currently supported, please use base64 encoded + data instead"` (checked against Ollama with `moondream`; base64 data URLs + work). **Breaking:** `LLMGateway` gained `gwImageUrlSupport` and + `LLMProvider` gained `providerImageUrlSupport` (`False` only for Ollama); + code that constructs either directly must set it. + ## [0.2.0.0] - 2026-10-06 ### Changed @@ -154,8 +274,9 @@ DeepSeek), single-shot generation with fallbacks, agent tool loops, structured output, JSON model catalog loading, and workspace-scoped filesystem tools. +[0.3.0.0]: https://github.com/aische/llm-simple/compare/v0.2.0.0...v0.3.0.0 +[0.2.0.0]: https://github.com/aische/llm-simple/compare/v0.1.1.0...v0.2.0.0 [0.1.1.0]: https://github.com/aische/llm-simple/compare/v0.1.0.2...v0.1.1.0 [0.1.0.2]: https://github.com/aische/llm-simple/compare/v0.1.0.1...v0.1.0.2 [0.1.0.1]: https://github.com/aische/llm-simple/compare/v0.1.0.0...v0.1.0.1 [0.1.0.0]: https://github.com/aische/llm-simple/releases/tag/v0.1.0.0 -[0.2.0.0]: https://github.com/aische/llm-simple/compare/v0.1.1.0...v0.2.0.0 diff --git a/Readme.md b/Readme.md --- a/Readme.md +++ b/Readme.md @@ -4,7 +4,7 @@ The API stays small on purpose: JSON model and provider catalogs, bundled filesystem tools, and a straight line from `loadModelOrThrow` to `generateText`. Under that surface you still get multi-provider gateways, fallbacks, streaming, structured output, and sandboxed workspace tools — enough to prototype and compare ideas without assembling the pieces yourself. -**Status:** early 0.2.x release. APIs may change. +**Status:** early 0.3.x release. APIs may change. ## Features @@ -64,7 +64,7 @@ | `pricing` | `pricePerMillionInput` / `pricePerMillionOutput` for usage cost tracking; optional `pricePerMillionCacheRead` / `pricePerMillionCacheWrite` (fall back to input rate) | | `maxTokens` | Max tokens per request | | `temperature` | Sampling temperature (optional) | -| `requestTimeout` | Request timeout in ms (optional) | +| `requestTimeout` | Timeout in ms per attempt (optional); for streaming, time until the first event; timeouts are retried | | `throttleDelay` | Delay between requests in ms (optional) | | `retryCount` | Number of retries on failure | | `jitterBackoff` | Backoff jitter in ms between retries | diff --git a/app/RecordConversation.hs b/app/RecordConversation.hs --- a/app/RecordConversation.hs +++ b/app/RecordConversation.hs @@ -6,12 +6,13 @@ import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T -import LLM.Core.Types (LLMGateway, ThinkingMode (..)) -import LLM.Providers.Claude (claudeGateway) -import LLM.Providers.DeepSeek (deepSeekGateway) -import LLM.Providers.Gemini (geminiGateway) -import LLM.Providers.Ollama (ollamaGateway) -import LLM.Providers.OpenAI (openAIGateway) +import LLM.Core.LLMProvider (LLMProvider) +import LLM.Core.Types (ThinkingMode (..)) +import LLM.Providers.Claude (claudeProvider) +import LLM.Providers.DeepSeek (deepSeekProvider) +import LLM.Providers.Gemini (geminiProvider) +import LLM.Providers.Ollama (ollamaProvider) +import LLM.Providers.OpenAI (openAIProvider) import LLM.TestKit (recordConversation, recordedConversationPrompts) import Options.Applicative ( Parser, @@ -130,7 +131,7 @@ die "--generated-only and --streamed-only are mutually exclusive" when (opts.optThinking && opts.optNoThinking) $ die "--thinking and --no-thinking are mutually exclusive" - gateway <- loadGateway opts.optProvider + provider <- loadProvider opts.optProvider let modelName = fromMaybe (defaultModel opts.optProvider) opts.optModel thinking = resolveThinking opts putStrLn $ @@ -142,9 +143,9 @@ " prompts: " <> show (map T.unpack recordedConversationPrompts) ] unless opts.optStreamedOnly $ - void $ recordConversation False gateway modelName thinking opts.optGeneratedOut + void $ recordConversation False provider modelName thinking opts.optGeneratedOut unless opts.optGeneratedOnly $ - void $ recordConversation True gateway modelName thinking opts.optStreamedOut + void $ recordConversation True provider modelName thinking opts.optStreamedOut putStrLn "Done." optionsInfo :: ParserInfo Options @@ -158,13 +159,13 @@ ] ) -loadGateway :: ProviderName -> IO LLMGateway -loadGateway = \case - Ollama -> pure ollamaGateway - OpenAI -> requireEnv "OPENAI_API_KEY" >>= pure . openAIGateway . T.pack - Claude -> requireEnv "CLAUDE_API_KEY" >>= pure . claudeGateway . T.pack - Gemini -> requireEnv "GEMINI_API_KEY" >>= pure . geminiGateway . T.pack - DeepSeek -> requireEnv "DEEPSEEK_API_KEY" >>= pure . deepSeekGateway . T.pack +loadProvider :: ProviderName -> IO LLMProvider +loadProvider = \case + Ollama -> pure ollamaProvider + OpenAI -> requireEnv "OPENAI_API_KEY" >>= pure . openAIProvider . T.pack + Claude -> requireEnv "CLAUDE_API_KEY" >>= pure . claudeProvider . T.pack + Gemini -> requireEnv "GEMINI_API_KEY" >>= pure . geminiProvider . T.pack + DeepSeek -> requireEnv "DEEPSEEK_API_KEY" >>= pure . deepSeekProvider . T.pack requireEnv :: String -> IO String requireEnv name = do diff --git a/llm-simple.cabal b/llm-simple.cabal --- a/llm-simple.cabal +++ b/llm-simple.cabal @@ -2,7 +2,7 @@ name: llm-simple -version: 0.2.0.0 +version: 0.3.0.0 synopsis: Multi-provider LLM library with agent tool loops and filesystem tools @@ -228,6 +228,7 @@ LLM.HistoryToolSpec LLM.GenerateObjectSpec LLM.ToolUtilsSpec + LLM.CrossProviderSpec LLM.TestKit LLM.WeatherTool hs-source-dirs: test diff --git a/model-catalog.json b/model-catalog.json --- a/model-catalog.json +++ b/model-catalog.json @@ -92,7 +92,7 @@ "pricePerMillionInput": 1, "pricePerMillionOutput": 5 }, - "maxTokens": 4096, + "maxTokens": 16000, "requestTimeout": 30000, "throttleDelay": 5000, "retryCount": 3, diff --git a/src/LLM/Agent/Events.hs b/src/LLM/Agent/Events.hs --- a/src/LLM/Agent/Events.hs +++ b/src/LLM/Agent/Events.hs @@ -4,7 +4,6 @@ ) where -import Control.Exception (SomeException, try) import Control.Monad (void) import LLM.Agent.Types ( EventObserver, @@ -12,12 +11,14 @@ GenerateEventDetail, RuntimeArgs (..), ) +import LLM.Core.Utils (trySync) -- | Emit a lifecycle event, attaching 'rtGenerationId' from runtime. --- Observer exceptions are swallowed so observers cannot abort the loop. +-- Synchronous observer exceptions are swallowed so observers cannot abort +-- the loop; asynchronous ones (timeout, cancellation) propagate. emitEvent :: RuntimeArgs -> GenerateEventDetail -> IO () emitEvent rt detail = - void (try (rt.rtOnEvent (GenerateEvent rt.rtGenerationId detail)) :: IO (Either SomeException ())) + void (trySync (rt.rtOnEvent (GenerateEvent rt.rtGenerationId detail))) noEventObserver :: EventObserver noEventObserver _ = pure () diff --git a/src/LLM/Agent/Generate.hs b/src/LLM/Agent/Generate.hs --- a/src/LLM/Agent/Generate.hs +++ b/src/LLM/Agent/Generate.hs @@ -28,8 +28,8 @@ import LLM.Core.Usage (Usage (..), emptyUsage) import LLM.Core.Utils (getToolCalls) import LLM.Generate.Generate - ( generateTextWithFallbacks, - streamTextWithFallbacks, + ( generateTextWithFallbacksRotated, + streamTextWithFallbacksRotated, ) import LLM.Generate.ModelConfig ( ModelWithFallbacks (..), @@ -57,7 +57,7 @@ IO (Either GenerateErrorResult GenerateTextResult) generateText agent models toolMap rt initialTurns = agentLoop - (\a m r t -> generateTextWithFallbacks (createGenRequest id a toolMap r t) m) + (\a m r t -> generateTextWithFallbacksRotated (createGenRequest id a toolMap r t) m) agent models toolMap @@ -79,15 +79,20 @@ IO (Either GenerateErrorResult GenerateTextResult) streamText onChunk agent models toolMap rt initialTurns = agentLoop - (\a m r t -> streamTextWithFallbacks onChunk (createGenRequest id a toolMap r t) m) + (\a m r t -> streamTextWithFallbacksRotated onChunk (createGenRequest id a toolMap r t) m) agent models toolMap rt initialTurns +-- | The tool loop. @call@ returns the model chain rotated so the model that +-- answered comes first; the next round starts with that chain, so a run that +-- fell back stays on the fallback instead of retrying a failing primary every +-- round. The next 'generateText' / 'streamText' call starts from the caller's +-- chain again. agentLoop :: - (Agent -> ModelWithFallbacks -> RuntimeArgs -> [Turn] -> IO (GenerateResult ChatResponse)) -> + (Agent -> ModelWithFallbacks -> RuntimeArgs -> [Turn] -> IO (GenerateResult (ModelWithFallbacks, ChatResponse))) -> Agent -> ModelWithFallbacks -> ToolMap Text -> @@ -96,10 +101,10 @@ IO (Either GenerateErrorResult GenerateTextResult) agentLoop call agent models toolMap rt initialTurns = do emitEvent rt GenerationStarted - go initialTurns [] emptyUsage 0 + go models initialTurns [] emptyUsage 0 where - go :: [Turn] -> [Turn] -> Usage -> Int -> IO (Either GenerateErrorResult GenerateTextResult) - go currentTurns newTurnsAcc currentUsage loopCount = do + go :: ModelWithFallbacks -> [Turn] -> [Turn] -> Usage -> Int -> IO (Either GenerateErrorResult GenerateTextResult) + go chain currentTurns newTurnsAcc currentUsage loopCount = do aborted <- isAbortedMaybe rt.rtAbortSignal if aborted then do @@ -113,13 +118,13 @@ emitEvent rt (GenerationFailed GErrToolExceeded errResult) pure $ Left errResult else do - result <- call agent models rt currentTurns + result <- call agent chain rt currentTurns case result of Left err -> do let errResult = GenerateErrorResult err newTurnsAcc currentUsage emitEvent rt (GenerationFailed err errResult) pure $ Left errResult - Right resp -> do + Right (nextChain, resp) -> do let txt = resp.respText toolCalls = getToolCalls resp roundUsage = fromMaybe emptyUsage resp.respUsage @@ -152,4 +157,4 @@ emitEvent rt (MessageCreated toolTurn) emitEvent rt (ToolRoundFinished loopCount) let turnsToAdd = [assistantMsg, toolTurn] - go (currentTurns ++ turnsToAdd) (newTurnsAcc ++ turnsToAdd) newUsage (loopCount + 1) + go nextChain (currentTurns ++ turnsToAdd) (newTurnsAcc ++ turnsToAdd) newUsage (loopCount + 1) diff --git a/src/LLM/Agent/ToolUtils.hs b/src/LLM/Agent/ToolUtils.hs --- a/src/LLM/Agent/ToolUtils.hs +++ b/src/LLM/Agent/ToolUtils.hs @@ -16,7 +16,7 @@ import Autodocodec qualified as AC import Autodocodec.Schema (jsonSchemaVia) -import Control.Exception (SomeException, fromException, try) +import Control.Exception (SomeException, fromException) import Data.Aeson (FromJSON) import Data.Aeson qualified as AE import Data.Map qualified as Map @@ -39,7 +39,7 @@ TypedTool (TypedTool), ) import LLM.Core.Usage (Usage) -import LLM.Core.Utils (toolResult) +import LLM.Core.Utils (toolResult, trySync) import LLM.Generate.Logger (Hooks (..)) import LLM.Generate.Types ( GenRequest (..), @@ -60,7 +60,7 @@ pure $ toolResult tc msg else do hooks.onToolCall tc.tcName (AE.toJSON tc.tcArguments) - result <- try (tool.toolExecute ctx tc.tcArguments) + result <- trySync (tool.toolExecute ctx tc.tcArguments) case result of Right text -> do hooks.onToolResult tc.tcName text diff --git a/src/LLM/Core.hs b/src/LLM/Core.hs --- a/src/LLM/Core.hs +++ b/src/LLM/Core.hs @@ -25,6 +25,7 @@ cacheEphemeral, mkImageBase64, supportedImageMediaTypes, + commonImageMediaTypes, projectText, projectReasoning, turnToolCalls, diff --git a/src/LLM/Core/LLMProvider.hs b/src/LLM/Core/LLMProvider.hs --- a/src/LLM/Core/LLMProvider.hs +++ b/src/LLM/Core/LLMProvider.hs @@ -8,6 +8,7 @@ import Control.Exception (try) import Data.Aeson (Value) +import Data.ByteString (ByteString) import Data.Text (Text) import Data.Text qualified as T import LLM.Core.Types @@ -25,13 +26,21 @@ data LLMProvider = LLMProvider { -- | Provider name for logging/hooks (e.g. "claude", "gemini", "openai") providerName :: Text, + -- | MIME types of inline images the provider accepts (see 'gwImageMediaTypes'). + providerImageMediaTypes :: [Text], + -- | Whether the provider accepts URL images (see 'gwImageUrlSupport'). + providerImageUrlSupport :: Bool, -- | Build the JSON request body. Bool indicates whether streaming is requested. buildBody :: Bool -> ChatRequest -> Value, -- | Make a non-streaming HTTP call, returning (status code, response JSON). sendRequest :: Value -> IO (Int, Value), - -- | Make a streaming HTTP call. The handler receives the raw response - -- and should parse it (checking status, reading body, etc.). - sendStreamRequest :: Value -> (StreamEvent -> IO ()) -> IO LLMTextResult, + -- | Make a streaming HTTP call. On a 200 response the continuation receives + -- a reader over the raw body (empty chunk = EOF); other statuses become an + -- 'HttpError' without calling it. + openStream :: Value -> (IO ByteString -> IO LLMTextResult) -> IO LLMTextResult, + -- | Parse a raw streaming body. Receives the request body (e.g. for the + -- model name), the body reader and the stream event callback. + parseStream :: Value -> IO ByteString -> (StreamEvent -> IO ()) -> IO LLMTextResult, -- | Parse a complete (non-streaming) JSON response body. parseResponse :: Value -> IO LLMTextResult, -- | Build the JSON request body for object generation. @@ -47,7 +56,7 @@ genericStreamText p hooks r callback = do let body = p.buildBody True r hooks.onLLMRequest p.providerName body - result <- try (p.sendStreamRequest body callback) + result <- try (p.openStream body (\readChunk -> p.parseStream body readChunk callback)) case result of Left e -> do hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException))) @@ -103,6 +112,8 @@ toGateway p = LLMGateway { gwName = p.providerName, + gwImageMediaTypes = p.providerImageMediaTypes, + gwImageUrlSupport = p.providerImageUrlSupport, gwGenerateText = genericGenerateText p, gwStreamText = genericStreamText p, gwGenerateObject = genericGenerateObject p diff --git a/src/LLM/Core/ProviderUtils.hs b/src/LLM/Core/ProviderUtils.hs --- a/src/LLM/Core/ProviderUtils.hs +++ b/src/LLM/Core/ProviderUtils.hs @@ -5,16 +5,18 @@ normalizeSchemaOpenAI, stripJsonFences, stripBoundsAndComments, + decodeToolArguments, + invalidToolArgumentsError, ) where -import Data.Aeson (ToJSON (toJSON), Value (..)) +import Data.Aeson (ToJSON (toJSON), Value (..), decodeStrict', object) import Data.Aeson.KeyMap qualified as KM import Data.ByteString qualified as BS import Data.Text (Text) import Data.Text qualified as T -import Data.Text.Encoding (decodeUtf8) -import LLM.Core.Types (LLMError (HttpError), LLMTextResult) +import Data.Text.Encoding (decodeUtf8, encodeUtf8) +import LLM.Core.Types (LLMError (HttpError, ParseError), LLMTextResult) import Network.HTTP.Client qualified as HC import Network.HTTP.Req (HttpConfig, defaultHttpConfig, httpConfigCheckResponse) import Network.HTTP.Types.Status (statusCode) @@ -32,6 +34,26 @@ chunk <- HC.brRead br if BS.null chunk then pure [] else (chunk :) <$> readAll br +-- | Decode tool-call arguments sent as a JSON string. Empty input means the +-- tool takes no arguments. 'Nothing' if the text is not valid JSON (for +-- example because the response was cut off by the token limit). +decodeToolArguments :: Text -> Maybe Value +decodeToolArguments t + | T.null (T.strip t) = Just (object []) + | otherwise = decodeStrict' (encodeUtf8 t) + +-- | Error for a tool call whose arguments are unusable. Pass the provider's +-- stop reason when it says the response hit the token limit +-- (@max_tokens@ / @length@), so the message names the cause. +invalidToolArgumentsError :: Text -> Maybe Text -> LLMError +invalidToolArgumentsError name mTruncated = + ParseError $ + "tool call " + <> name + <> case mTruncated of + Just reason -> " was cut off (stop reason: " <> reason <> "); increase max tokens" + Nothing -> ": arguments are not valid JSON" + -- | Handle streaming response: check status, read error body or delegate -- to the provider-specific stream parser. handleStreamResponse :: HC.Response HC.BodyReader -> (HC.BodyReader -> IO LLMTextResult) -> IO LLMTextResult @@ -74,16 +96,51 @@ else t'' in t''' --- | Recursively removes "minimum" and "maximum" keys from a JSON Value, also $comment fields +-- | Remove @minimum@, @maximum@ and @$comment@ keywords from a JSON Schema. +-- +-- Only schema keywords are removed: the walk follows sub-schema positions +-- (@properties@, @items@, @anyOf@, @$defs@, ...). Property names and +-- literal values (@enum@, @const@, @default@, @examples@) are kept, so a +-- property called @minimum@ survives. stripBoundsAndComments :: Value -> Value stripBoundsAndComments (Object obj) = Object $ KM.fromList - [ (k, stripBoundsAndComments v) + [ (k, stripKeyword k v) | (k, v) <- KM.toList obj, - k /= "minimum", - k /= "maximum", - k /= "$comment" + k `notElem` ["minimum", "maximum", "$comment"] ] -stripBoundsAndComments (Array arr) = Array (fmap stripBoundsAndComments arr) + where + stripKeyword k v + | k `elem` schemaMapKeywords = mapObject stripBoundsAndComments v + | k `elem` schemaKeywords = stripSchemaOrList v + | otherwise = v + mapObject f (Object o) = Object (fmap f o) + mapObject _ v = v + stripSchemaOrList (Array a) = Array (fmap stripBoundsAndComments a) + stripSchemaOrList v = stripBoundsAndComments v stripBoundsAndComments other = other + +-- | Keywords whose value maps names to sub-schemas. +schemaMapKeywords :: [KM.Key] +schemaMapKeywords = ["properties", "patternProperties", "$defs", "definitions", "dependentSchemas"] + +-- | Keywords whose value is a sub-schema or a list of sub-schemas. +schemaKeywords :: [KM.Key] +schemaKeywords = + [ "items", + "prefixItems", + "additionalItems", + "additionalProperties", + "unevaluatedProperties", + "unevaluatedItems", + "propertyNames", + "contains", + "anyOf", + "oneOf", + "allOf", + "not", + "if", + "then", + "else" + ] diff --git a/src/LLM/Core/Types.hs b/src/LLM/Core/Types.hs --- a/src/LLM/Core/Types.hs +++ b/src/LLM/Core/Types.hs @@ -20,6 +20,7 @@ cacheEphemeral, mkImageBase64, supportedImageMediaTypes, + commonImageMediaTypes, projectText, projectReasoning, turnToolCalls, @@ -82,6 +83,12 @@ data LLMGateway = LLMGateway { -- | Short name used in logs and hooks (e.g. @openai@). gwName :: Text, + -- | MIME types of inline ('ImageBase64') images the provider accepts. + -- Models on this gateway are skipped for conversations with other types. + gwImageMediaTypes :: [Text], + -- | Whether the provider accepts URL ('ImageUrl') images. Models on a + -- gateway without it are skipped for conversations with URL images. + gwImageUrlSupport :: Bool, -- | Non-streaming chat completion. gwGenerateText :: LLMHooks -> ChatRequest -> IO LLMTextResult, -- | Streaming chat; invoke the callback for each 'StreamEvent'. @@ -115,16 +122,25 @@ deriving (Show, Eq) -- | Controls how conversation turns are encoded for provider APIs. -newtype MessageEncodeOptions = MessageEncodeOptions - { meoIncludeReasoning :: Bool +data MessageEncodeOptions = MessageEncodeOptions + { -- | Send assistant thinking text as @reasoning_content@. + meoIncludeReasoning :: Bool, + -- | Send @reasoning_content@ on every assistant message, @""@ when the + -- turn has no thinking text (DeepSeek thinking mode rejects assistant + -- messages without it). Only takes effect with 'meoIncludeReasoning'. + meoRequireReasoning :: Bool } deriving (Show, Eq) defaultMessageEncodeOptions :: MessageEncodeOptions -defaultMessageEncodeOptions = MessageEncodeOptions {meoIncludeReasoning = False} +defaultMessageEncodeOptions = + MessageEncodeOptions {meoIncludeReasoning = False, meoRequireReasoning = False} +-- | DeepSeek encoding with thinking off. 'deepSeekBuildBodyPairs' sets +-- 'meoRequireReasoning' when the request enables thinking. deepSeekMessageEncodeOptions :: MessageEncodeOptions -deepSeekMessageEncodeOptions = MessageEncodeOptions {meoIncludeReasoning = True} +deepSeekMessageEncodeOptions = + MessageEncodeOptions {meoIncludeReasoning = True, meoRequireReasoning = False} -- | Opaque, provider-owned payload that must round-trip for replay. -- @@ -186,16 +202,21 @@ <*> o .: "data" _ -> fail $ "Unknown image source type: " <> T.unpack typ --- | MIME types accepted by 'mkImageBase64' / 'imageBase64Part'. -supportedImageMediaTypes :: [Text] -supportedImageMediaTypes = +-- | Image MIME types every provider with vision accepts (Claude, OpenAI, +-- Ollama, DeepSeek). Gemini also accepts HEIC / HEIF. +commonImageMediaTypes :: [Text] +commonImageMediaTypes = [ "image/jpeg", "image/png", "image/gif", - "image/webp", - "image/heic", - "image/heif" + "image/webp" ] + +-- | MIME types accepted by 'mkImageBase64' / 'imageBase64Part'. Not every +-- provider accepts all of them; see 'gwImageMediaTypes'. +supportedImageMediaTypes :: [Text] +supportedImageMediaTypes = + commonImageMediaTypes ++ ["image/heic", "image/heif"] -- | Validate MIME type and base64 payload for an inline image. mkImageBase64 :: Text -> Text -> Either Text ImageSource diff --git a/src/LLM/Core/Utils.hs b/src/LLM/Core/Utils.hs --- a/src/LLM/Core/Utils.hs +++ b/src/LLM/Core/Utils.hs @@ -5,20 +5,38 @@ isRetryable, withRetry, withTimeout, + withFirstEventTimeout, + trySync, streamResponseJson, printValue, parseChatResponse, ) where +import Control.Concurrent (forkIOWithUnmask, killThread, myThreadId, threadDelay, throwTo) +import Control.Exception + ( Exception (..), + SomeAsyncException, + SomeException, + asyncExceptionFromException, + asyncExceptionToException, + bracket, + handleJust, + throwIO, + try, + uninterruptibleMask_, + ) +import Control.Monad (guard, unless) import Control.Retry (RetryPolicyM, RetryStatus (rsIterNumber), retrying) import Data.Aeson (Value, encode, object, (.=)) import Data.Aeson qualified as AE import Data.Aeson.Types (Parser) import Data.ByteString.Lazy.Char8 qualified as L8 +import Data.IORef (newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T +import Data.Unique (Unique, newUnique) import LLM.Core.Types ( ChatResponse (..), ContentPart (..), @@ -54,14 +72,63 @@ isRetryable :: LLMError -> Bool isRetryable (HttpError status _) = status `elem` [429, 503, 529] isRetryable (NetworkError _) = True +isRetryable TimeoutError = True isRetryable _ = False -- | Wrap an action with a timeout (ms). Returns 'TimeoutError' on expiry. withTimeout :: Maybe Int -> IO (LLMResult a) -> IO (LLMResult a) withTimeout Nothing action = action -withTimeout (Just us) action = do - result <- timeout (us * 1000) action +withTimeout (Just ms) action = do + result <- timeout (ms * 1000) action pure $ fromMaybe (Left TimeoutError) result + +-- | Like 'withTimeout', but for streaming: the timeout (ms) only covers the +-- time until the first event reaches the callback. Once an event has +-- arrived, the stream may run as long as it needs. Returns 'TimeoutError' +-- if no event arrives in time. +-- +-- @run@ receives the wrapped callback and must pass every event through it. +withFirstEventTimeout :: + Maybe Int -> + ((e -> IO ()) -> IO (LLMResult a)) -> + (e -> IO ()) -> + IO (LLMResult a) +withFirstEventTimeout Nothing run onEvent = run onEvent +withFirstEventTimeout (Just ms) run onEvent = do + startedRef <- newIORef False + caller <- myThreadId + ex <- FirstEventTimeout <$> newUnique + -- Same structure as 'System.Timeout.timeout': a watchdog thread throws a + -- unique async exception at the caller unless the first event came in. + let watchdog = forkIOWithUnmask $ \unmask -> unmask $ do + threadDelay (ms * 1000) + started <- readIORef startedRef + unless started $ throwTo caller ex + onEvent' e = writeIORef startedRef True >> onEvent e + handleJust + (guard . (== ex)) + (\_ -> pure (Left TimeoutError)) + (bracket watchdog (uninterruptibleMask_ . killThread) (\_ -> run onEvent')) + +-- | Like @try \@SomeException@, but re-throws asynchronous exceptions +-- ('System.Timeout.timeout', 'Control.Concurrent.killThread', @cancel@), so +-- a caller that interrupts the thread is not turned into an ordinary error. +trySync :: IO a -> IO (Either SomeException a) +trySync act = do + r <- try act + case r of + Left e | Just (_ :: SomeAsyncException) <- fromException e -> throwIO e + _ -> pure r + +newtype FirstEventTimeout = FirstEventTimeout Unique + deriving (Eq) + +instance Show FirstEventTimeout where + show _ = "<>" + +instance Exception FirstEventTimeout where + toException = asyncExceptionToException + fromException = asyncExceptionFromException -- | Retry an action using the retry package's policy (exponential backoff + jitter). -- The policy controls max attempts, delays, and jitter. diff --git a/src/LLM/Generate/Generate.hs b/src/LLM/Generate/Generate.hs --- a/src/LLM/Generate/Generate.hs +++ b/src/LLM/Generate/Generate.hs @@ -4,11 +4,13 @@ streamTextLLM, generateTextWithFallbacks, streamTextWithFallbacks, + generateTextWithFallbacksRotated, + streamTextWithFallbacksRotated, ) where import Control.Monad (unless, when) -import Data.IORef (newIORef, readIORef, writeIORef) +import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Maybe (fromMaybe) import LLM.Core.Types ( ChatResponse (..), @@ -18,11 +20,13 @@ Turn (..), ) import LLM.Core.Usage (emptyUsage) +import LLM.Core.Utils (withFirstEventTimeout) import LLM.Generate.GenerateUtils - ( callWithRetryTimeout, + ( callWithRetry, + callWithRetryTimeout, mkRequest, usageWithModelCost, - withModelFallbacks, + withModelFallbacksRotated, ) import LLM.Generate.ModelConfig ( ModelConfig (..), @@ -44,7 +48,16 @@ ModelWithFallbacks -> IO (GenerateResult ChatResponse) generateTextWithFallbacks gr models = - withModelFallbacks gr models $ \mc -> do + fmap snd <$> generateTextWithFallbacksRotated gr models + +-- | Like 'generateTextWithFallbacks', but also returns the chain rotated so +-- the model that answered comes first (see 'withModelFallbacksRotated'). +generateTextWithFallbacksRotated :: + GenRequest -> + ModelWithFallbacks -> + IO (GenerateResult (ModelWithFallbacks, ChatResponse)) +generateTextWithFallbacksRotated gr models = + withModelFallbacksRotated gr models $ \mc -> do r <- generateTextLLM gr mc case r of Left err -> pure $ Left err @@ -60,8 +73,19 @@ ModelWithFallbacks -> IO (GenerateResult ChatResponse) streamTextWithFallbacks onChunk gr models = - withModelFallbacks gr models $ \mc -> do - r <- streamTextLLM onChunk gr mc + fmap snd <$> streamTextWithFallbacksRotated onChunk gr models + +-- | Like 'streamTextWithFallbacks', but also returns the rotated chain +-- (see 'withModelFallbacksRotated'). +streamTextWithFallbacksRotated :: + (StreamChunk -> IO ()) -> + GenRequest -> + ModelWithFallbacks -> + IO (GenerateResult (ModelWithFallbacks, ChatResponse)) +streamTextWithFallbacksRotated onChunk gr models = do + emittedRef <- newIORef False + withModelFallbacksRotated gr models $ \mc -> do + r <- streamTextAttempts emittedRef onChunk gr mc case r of Left err -> pure $ Left err Right resp -> @@ -74,14 +98,40 @@ let request = mkRequest gr mc in mc.mcGateway.gwGenerateText gr.grLLMHooks request +-- | Stream one model call with retries. 'mcRequestTimeout' bounds the time +-- until the first stream event of each attempt, not the whole stream. +-- +-- If an attempt fails after streaming chunks, the next attempt first emits +-- 'StreamAttemptReset'. streamTextLLM :: (StreamChunk -> IO ()) -> GenRequest -> ModelConfig -> IO LLMTextResult -streamTextLLM onChunk gr mc = - callWithRetryTimeout gr mc $ +streamTextLLM onChunk gr mc = do + emittedRef <- newIORef False + streamTextAttempts emittedRef onChunk gr mc + +-- | 'streamTextLLM' with the \"chunks emitted\" flag supplied by the caller, +-- so it is shared across retries and model fallbacks of one model call. +streamTextAttempts :: + IORef Bool -> + (StreamChunk -> IO ()) -> + GenRequest -> + ModelConfig -> + IO LLMTextResult +streamTextAttempts emittedRef onChunk gr mc = + callWithRetry gr mc $ let request = mkRequest gr mc + onChunk' c = writeIORef emittedRef True >> onChunk c in do + emitted <- readIORef emittedRef + when emitted $ do + onChunk StreamAttemptReset + writeIORef emittedRef False ProviderStreamCallback {pscOnEvent, pscFinalize} <- - mkProviderStreamCallback gr onChunk - result <- mc.mcGateway.gwStreamText gr.grLLMHooks request pscOnEvent + mkProviderStreamCallback gr onChunk' + result <- + withFirstEventTimeout + mc.mcRequestTimeout + (mc.mcGateway.gwStreamText gr.grLLMHooks request) + pscOnEvent case result of Right _ -> pscFinalize >> pure result Left err -> pure (Left err) diff --git a/src/LLM/Generate/GenerateUtils.hs b/src/LLM/Generate/GenerateUtils.hs --- a/src/LLM/Generate/GenerateUtils.hs +++ b/src/LLM/Generate/GenerateUtils.hs @@ -2,23 +2,30 @@ ( maybeThrottle, mkRequest, usageWithModelCost, + callWithRetry, callWithRetryTimeout, withModelFallbacks, + withModelFallbacksRotated, validateModelCapabilities, llmHooks, ) where import Control.Concurrent (threadDelay) +import Control.Monad (when) import Data.Text (Text) import Data.Text qualified as T +import Data.List (nub) import LLM.Core.Types ( ChatRequest (..), + ContentPart (..), + ImageSource (..), LLMError (..), - LLMGateway (gwName), + LLMGateway (gwImageMediaTypes, gwImageUrlSupport, gwName), + PartBody (..), LLMHooks (..), ThinkingMode (..), - Turn, + Turn (..), conversationHasImages, ) import LLM.Core.Usage (Usage (..), estimateCost) @@ -54,12 +61,18 @@ -- | Check that a candidate model declares every capability the request needs. -- --- Unsupported vision is a candidate failure (do not drop images). Thinking --- configuration requires a declared thinking capability. Cache hints are not --- validated here; unsupported providers ignore them. +-- Unsupported vision is a candidate failure (do not drop images), and so is +-- an inline image whose media type the gateway does not accept +-- ('gwImageMediaTypes') or a URL image on a gateway without +-- 'gwImageUrlSupport'. URL images have no known media type, so their type +-- is not checked. +-- Thinking configuration requires a declared thinking capability. Cache +-- hints are not validated here; unsupported providers ignore them. validateModelCapabilities :: ModelConfig -> [Turn] -> Either LLMError () validateModelCapabilities mc turns = do whenNeedsVision + whenNeedsMediaTypes + whenNeedsImageUrls whenNeedsThinking where caps = mc.mcCapabilities @@ -72,6 +85,29 @@ <> mc.mcModel <> " does not support vision" | otherwise = Right () + whenNeedsMediaTypes = + case filter (`notElem` mc.mcGateway.gwImageMediaTypes) (inlineImageMediaTypes turns) of + [] -> Right () + unsupported -> + Left $ + UnsupportedCapability $ + "model " + <> mc.mcModel + <> " via " + <> mc.mcGateway.gwName + <> " does not accept image media type " + <> T.intercalate ", " unsupported + whenNeedsImageUrls + | conversationHasImageUrls turns, + not mc.mcGateway.gwImageUrlSupport = + Left $ + UnsupportedCapability $ + "model " + <> mc.mcModel + <> " via " + <> mc.mcGateway.gwName + <> " does not accept image URLs" + | otherwise = Right () whenNeedsThinking = case mc.mcThinking of Just ThinkingMode {tmEnabled = True} @@ -83,15 +119,47 @@ <> " does not support thinking" _ -> Right () +-- | Distinct media types of the inline ('ImageBase64') images in a conversation. +inlineImageMediaTypes :: [Turn] -> [Text] +inlineImageMediaTypes turns = + nub [mt | ImageBase64 mt _ <- imageSources turns] + +conversationHasImageUrls :: [Turn] -> Bool +conversationHasImageUrls turns = + not (null [() | ImageUrl _ <- imageSources turns]) + +imageSources :: [Turn] -> [ImageSource] +imageSources turns = + [src | parts <- map turnParts turns, ContentPart (ImagePart src) _ <- parts] + where + turnParts (UserMessage parts) = parts + turnParts (AssistantMessage parts) = parts + turnParts (ToolTurn _) = [] + +-- | Run one model call with the model's throttle delay and retry policy. +-- @attempt@ is run once per try; any per-attempt timeout must be inside it. +callWithRetry :: + GenRequest -> + ModelConfig -> + IO (Either LLMError a) -> + IO (Either LLMError a) +callWithRetry gr mc attempt = + maybeThrottle mc.mcThrottleDelay $ + withRetry (modelRetryPolicy mc) (gr.grHooks.onLog Warn) attempt + +-- | 'callWithRetry' where each attempt is limited by 'mcRequestTimeout'. +-- +-- The timeout applies to each attempt separately, not to the whole +-- sequence of retries and backoff sleeps. A timed-out attempt yields +-- 'TimeoutError', which is retryable. For streaming, see +-- 'LLM.Core.Utils.withFirstEventTimeout' (used by 'streamTextLLM'). callWithRetryTimeout :: GenRequest -> ModelConfig -> IO (Either LLMError a) -> IO (Either LLMError a) callWithRetryTimeout gr mc invoke = - maybeThrottle mc.mcThrottleDelay $ - withTimeout mc.mcRequestTimeout $ - withRetry (modelRetryPolicy mc) (gr.grHooks.onLog Warn) invoke + callWithRetry gr mc (withTimeout mc.mcRequestTimeout invoke) withModelFallbacks :: GenRequest -> @@ -99,15 +167,47 @@ (ModelConfig -> IO (Either LLMError a)) -> IO (GenerateResult a) withModelFallbacks gr models invokePerModel = + fmap (\(_, _, a) -> a) <$> runModelFallbacks gr models invokePerModel + +-- | Like 'withModelFallbacks', but also returns the chain rotated so that the +-- model that answered comes first. The models before it (the ones that +-- failed) move to the end, so they stay a last resort: +-- @xs ++ [m] ++ ys@ becomes @ModelWithFallbacks m (ys ++ xs)@. +-- +-- Used to keep an agent run on the model that answered. Logs at 'Info' when +-- the chain changes. +withModelFallbacksRotated :: + GenRequest -> + ModelWithFallbacks -> + (ModelConfig -> IO (Either LLMError a)) -> + IO (GenerateResult (ModelWithFallbacks, a)) +withModelFallbacksRotated gr models invokePerModel = do + r <- runModelFallbacks gr models invokePerModel + case r of + Left err -> pure $ Left err + Right (rotated, chain, a) -> do + when rotated $ + gr.grHooks.onLog Info (formatContinuingOn chain.mwfModel) + pure $ Right (chain, a) + +-- | Shared loop of 'withModelFallbacks' and 'withModelFallbacksRotated'. +-- On success, returns whether the chain was rotated, the rotated chain and +-- the result. +runModelFallbacks :: + GenRequest -> + ModelWithFallbacks -> + (ModelConfig -> IO (Either LLMError a)) -> + IO (GenerateResult (Bool, ModelWithFallbacks, a)) +runModelFallbacks gr models invokePerModel = case mfwToModelConfigs models of [] -> pure $ Left GErrAllModelsFailed - modelConfigs -> loop modelConfigs Nothing + modelConfigs -> loop [] modelConfigs Nothing where - loop [] mLast = + loop _ [] mLast = pure $ Left $ maybe GErrAllModelsFailed GErrLLM mLast - loop (mc : rest) _ = do + loop failed (mc : rest) _ = do gr.grHooks.onLog Info (formatTryingModel mc) case validateModelCapabilities mc gr.grMessages of Left err -> @@ -115,7 +215,7 @@ [] -> pure $ Left (GErrLLM err) _ -> do gr.grHooks.onLog Warn (formatModelFallback mc err) - loop rest (Just err) + loop (failed ++ [mc]) rest (Just err) Right () -> do r <- invokePerModel mc case r of @@ -125,12 +225,19 @@ [] -> pure $ Left (GErrLLM err) _ -> do gr.grHooks.onLog Warn (formatModelFallback mc err) - loop rest (Just err) - Right a -> pure $ Right a + loop (failed ++ [mc]) rest (Just err) + Right a -> pure $ Right (not (null failed), ModelWithFallbacks mc (rest ++ failed), a) formatTryingModel :: ModelConfig -> Text formatTryingModel mc = "Trying model: " + <> mc.mcModel + <> " via " + <> mc.mcGateway.gwName + +formatContinuingOn :: ModelConfig -> Text +formatContinuingOn mc = + "Continuing run on " <> mc.mcModel <> " via " <> mc.mcGateway.gwName diff --git a/src/LLM/Generate/Logger.hs b/src/LLM/Generate/Logger.hs --- a/src/LLM/Generate/Logger.hs +++ b/src/LLM/Generate/Logger.hs @@ -13,7 +13,6 @@ ) where -import Control.Exception (SomeException, try) import Control.Monad (void) import Data.Aeson (Value) import Data.Aeson.Encode.Pretty (encodePretty) @@ -22,6 +21,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time.Clock.POSIX (getPOSIXTime) +import LLM.Core.Utils (trySync) import System.Directory (createDirectoryIfMissing) import System.FilePath (()) import System.IO (stderr) @@ -98,18 +98,19 @@ name = T.unpack provider <> "-" <> T.unpack label <> "-" <> tsStr <> ".json" BSL.writeFile (dir name) (encodePretty val) --- | Wrap all hook callbacks so exceptions are silently caught. +-- | Wrap all hook callbacks so synchronous exceptions are silently caught. -- Hooks are observability-only and should never abort control flow. +-- Asynchronous exceptions (timeout, cancellation) still propagate. safeHooks :: Hooks -> Hooks safeHooks h = Hooks - { onLog = \level msg -> void (try (h.onLog level msg) :: IO (Either SomeException ())), - onRequest = \p v -> void (try (h.onRequest p v) :: IO (Either SomeException ())), - onResponse = \p v -> void (try (h.onResponse p v) :: IO (Either SomeException ())), - onResponseError = \p v -> void (try (h.onResponseError p v) :: IO (Either SomeException ())), - onToolCall = \p v -> void (try (h.onToolCall p v) :: IO (Either SomeException ())), - onToolResult = \p v -> void (try (h.onToolResult p v) :: IO (Either SomeException ())), - onToolError = \p v -> void (try (h.onToolError p v) :: IO (Either SomeException ())) + { onLog = \level msg -> void (trySync (h.onLog level msg)), + onRequest = \p v -> void (trySync (h.onRequest p v)), + onResponse = \p v -> void (trySync (h.onResponse p v)), + onResponseError = \p v -> void (trySync (h.onResponseError p v)), + onToolCall = \p v -> void (trySync (h.onToolCall p v)), + onToolResult = \p v -> void (trySync (h.onToolResult p v)), + onToolError = \p v -> void (trySync (h.onToolError p v)) } debugHooks :: FilePath -> Hooks diff --git a/src/LLM/Generate/ModelConfig.hs b/src/LLM/Generate/ModelConfig.hs --- a/src/LLM/Generate/ModelConfig.hs +++ b/src/LLM/Generate/ModelConfig.hs @@ -68,7 +68,9 @@ mcThinking :: Maybe ThinkingMode, -- | Declared capabilities (vision, thinking, prompt caching). mcCapabilities :: ModelCapabilities, - -- | Whole-request timeout in milliseconds ('Nothing' = no timeout). + -- | Per-attempt timeout in milliseconds ('Nothing' = no timeout). Each + -- retry gets the full timeout; a timeout is retryable. For streaming it + -- bounds only the time until the first stream event. mcRequestTimeout :: Maybe Int, -- | Delay in milliseconds before each API call (rate limiting). mcThrottleDelay :: Maybe Int, diff --git a/src/LLM/Generate/Types.hs b/src/LLM/Generate/Types.hs --- a/src/LLM/Generate/Types.hs +++ b/src/LLM/Generate/Types.hs @@ -100,6 +100,11 @@ RoundTextRoleCommitted RoundTextRole | -- | A complete tool call from the provider stream. StreamToolCallChunk ToolCall + | -- | The previous attempt of this model call failed after streaming some + -- chunks, and a retry or fallback model starts over. Discard every chunk + -- received since the start of this model call (round). Only sent when + -- the failed attempt emitted at least one chunk. + StreamAttemptReset deriving (Show, Eq) -- | Constraint for typed structured output via Autodocodec. diff --git a/src/LLM/Providers/Claude.hs b/src/LLM/Providers/Claude.hs --- a/src/LLM/Providers/Claude.hs +++ b/src/LLM/Providers/Claude.hs @@ -7,11 +7,13 @@ parseClaudeStream, parseClaudeUsage, claudeBuildBody, + checkClaudeThinkingBudget, encodeTurn, effortToBudgetTokens, ) where +import Control.Applicative ((<|>)) import Data.Aeson ( KeyValue ((.=)), Value (Object, String), @@ -36,10 +38,11 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway) -import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, stripJsonFences) +import LLM.Core.ProviderUtils (decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, stripJsonFences) import LLM.Core.SSE (SSEEvent (sseData, sseEvent), readSSEEvents) import LLM.Core.Types - ( CacheHint (..), + ( commonImageMediaTypes, + CacheHint (..), ChatRequest ( reqConversation, reqMaxTokens, @@ -51,8 +54,8 @@ ), ContentPart (..), ImageSource (..), - LLMError (EmptyResponse), - LLMGateway, + LLMError (EmptyResponse, HttpError, UnsupportedCapability), + LLMGateway (..), LLMResult, LLMTextResult, PartBody (..), @@ -95,13 +98,28 @@ -- | Create a LLMGateway for the Claude provider at api.anthropic.com. claudeGateway :: Text -> LLMGateway -claudeGateway apiKey = toGateway $ claudeProvider apiKey +claudeGateway apiKey = guardThinkingBudget $ toGateway $ claudeProvider apiKey -- | Create a Claude-compatible client with a custom base URL (origin). -- The library appends @/v1/messages@. claudeGatewayWith :: Url scheme -> Option scheme -> Text -> LLMGateway -claudeGatewayWith baseUrl baseOpts apiKey = toGateway (claudeProviderWith baseUrl baseOpts apiKey) +claudeGatewayWith baseUrl baseOpts apiKey = + guardThinkingBudget $ toGateway (claudeProviderWith baseUrl baseOpts apiKey) +-- | Refuse requests that Anthropic would reject because @max_tokens@ leaves +-- no room for the minimum thinking budget (see 'checkClaudeThinkingBudget'), +-- instead of sending them. +guardThinkingBudget :: LLMGateway -> LLMGateway +guardThinkingBudget gw = + gw + { gwGenerateText = \hooks r -> + either (pure . Left) (const (gw.gwGenerateText hooks r)) (checkClaudeThinkingBudget r), + gwStreamText = \hooks r cb -> + either (pure . Left) (const (gw.gwStreamText hooks r cb)) (checkClaudeThinkingBudget r), + gwGenerateObject = \hooks schema r -> + either (pure . Left) (const (gw.gwGenerateObject hooks schema r)) (checkClaudeThinkingBudget r) + } + -- | Create a LLMProvider for the Claude provider at api.anthropic.com. claudeProvider :: Text -> LLMProvider claudeProvider = claudeProviderWith (https "api.anthropic.com") mempty @@ -112,15 +130,19 @@ claudeProviderWith baseUrl baseOpts apiKey = LLMProvider { providerName = claudeProviderName, + providerImageMediaTypes = commonImageMediaTypes, + providerImageUrlSupport = True, buildBody = claudeBuildBody, sendRequest = sendRequest, - sendStreamRequest = \body callback -> + openStream = \body k -> runReq lenientConfig $ do let url = baseUrl /: "v1" /: "messages" opts = baseOpts <> claudeAuthOpts apiKey - modelHint = fromMaybe "" (parseMaybe (withObject "body" (.: "model")) body) reqBr POST url (ReqBodyJson body) opts $ \resp -> - handleStreamResponse resp (\br -> parseClaudeStream modelHint (HC.brRead br) callback), + handleStreamResponse resp (k . HC.brRead), + parseStream = \body readChunk callback -> + let modelHint = fromMaybe "" (parseMaybe (withObject "body" (.: "model")) body) + in parseClaudeStream modelHint readChunk callback, parseResponse = pure . parseClaudeResponse, buildObjectBody = \r schema -> let schemaText = TL.toStrict . decodeUtf8 $ encode schema @@ -155,6 +177,36 @@ [(n, "")] | n >= 1024 -> n _ -> 10000 +-- | Anthropic's minimum extended-thinking @budget_tokens@. +minThinkingBudget :: Int +minThinkingBudget = 1024 + +-- | The @budget_tokens@ sent for a request: the effort budget, capped below +-- @max_tokens@ (Anthropic requires @budget_tokens < max_tokens@). +thinkingBudget :: ChatRequest -> ThinkingMode -> Int +thinkingBudget r tm = + min (maybe 10000 effortToBudgetTokens tm.tmEffort) (r.reqMaxTokens - 1) + +-- | Thinking needs @max_tokens > 1024@, because the budget must be at least +-- 1024 and below @max_tokens@. Returns 'UnsupportedCapability' otherwise, so +-- the call fails before any I/O and the next fallback model is tried. +checkClaudeThinkingBudget :: ChatRequest -> Either LLMError () +checkClaudeThinkingBudget r = + case r.reqThinking of + Just tm + | tm.tmEnabled, + thinkingBudget r tm < minThinkingBudget -> + Left $ + UnsupportedCapability $ + "thinking needs max_tokens > " + <> T.pack (show minThinkingBudget) + <> " for model " + <> r.reqModel + <> " (max_tokens is " + <> T.pack (show r.reqMaxTokens) + <> ")" + _ -> Right () + claudeBuildBody :: Bool -> ChatRequest -> Value claudeBuildBody stream r = object $ @@ -181,7 +233,7 @@ case r.reqThinking of Just tm | tm.tmEnabled -> - let budget = maybe 10000 effortToBudgetTokens tm.tmEffort + let budget = thinkingBudget r tm in [ "thinking" .= object [ "type" .= ("enabled" :: Text), @@ -304,9 +356,15 @@ Just parts -> case parts of [] -> Left EmptyResponse - _ -> Right (mkChatResponse parts (parseClaudeUsage v)) + _ + -- A tool_use block that hit max_tokens may have incomplete input. + | stopReason == Just "max_tokens", + ContentPart (ToolCallPart tc) _ <- last parts -> + Left (invalidToolArgumentsError tc.tcName (Just "max_tokens")) + | otherwise -> Right (mkChatResponse parts (parseClaudeUsage v)) where modelVer = parseMaybe (withObject "ClaudeResponse" (.: "model")) v + stopReason = parseMaybe (withObject "ClaudeResponse" (.: "stop_reason")) v :: Maybe Text go :: Maybe Text -> Value -> Parser [ContentPart] go mv = withObject "ClaudeResponse" $ \o -> do @@ -415,8 +473,14 @@ thinkingAccRef <- newIORef (Nothing :: Maybe (Text, Maybe Text)) -- text, signature redactedRef <- newIORef (Nothing :: Maybe Text) modelRef <- newIORef modelHint + errorRef <- newIORef (Nothing :: Maybe LLMError) + stopReasonRef <- newIORef (Nothing :: Maybe Text) + badToolRef <- newIORef (Nothing :: Maybe Text) -- first tool with invalid JSON args readSSEEvents readChunk $ \sse -> do case sse.sseEvent of + Just "error" -> do + let status = maybe 500 claudeErrorStatus (parseMaybe parseErrorType =<< decodeStrict' (encodeUtf8 sse.sseData)) + modifyIORef' errorRef (<|> Just (HttpError status sse.sseData)) Just "message_start" -> case decodeStrict' (encodeUtf8 sse.sseData) of Just v -> do @@ -479,28 +543,60 @@ mTool <- readIORef toolAccRef case mTool of Just (cid, name, jsonStr) -> do - let args = case decodeStrict' (encodeUtf8 jsonStr) of - Just a -> a - Nothing -> String jsonStr - tc = mkToolCall cid name args - modifyIORef' blocksRef (StreamTool cid name args :) - callback (StreamToolCall tc) + case decodeToolArguments jsonStr of + Just args -> do + modifyIORef' blocksRef (StreamTool cid name args :) + callback (StreamToolCall (mkToolCall cid name args)) + Nothing -> modifyIORef' badToolRef (<|> Just name) writeIORef toolAccRef Nothing Nothing -> pure () Just "message_delta" -> case decodeStrict' (encodeUtf8 sse.sseData) of - Just v -> case parseMaybe parseMessageDeltaUsage v of - Just outputToks -> modifyIORef' usageRef $ \u -> u {usageOutputTokens = outputToks} - Nothing -> pure () + Just v -> do + case parseMaybe parseMessageDeltaUsage v of + Just outputToks -> modifyIORef' usageRef $ \u -> u {usageOutputTokens = outputToks} + Nothing -> pure () + for_ (parseMaybe parseMessageDeltaStopReason v) (writeIORef stopReasonRef . Just) Nothing -> pure () _ -> pure () rawBlocks <- reverse <$> readIORef blocksRef usage <- readIORef usageRef model <- readIORef modelRef + mError <- readIORef errorRef + mBadTool <- readIORef badToolRef + stopReason <- readIORef stopReasonRef let parts = map (streamBlockToPart model) rawBlocks - if null parts - then pure $ Left EmptyResponse - else pure $ Right (mkChatResponse parts (Just usage)) + truncated = if stopReason == Just "max_tokens" then stopReason else Nothing + pure $ case (mError, mBadTool) of + (Just err, _) -> Left err + (Nothing, Just name) -> Left (invalidToolArgumentsError name truncated) + _ + | null parts -> Left EmptyResponse + | otherwise -> Right (mkChatResponse parts (Just usage)) + +-- | HTTP status Anthropic uses for each error type, so mid-stream errors are +-- classified like the same error returned before streaming started. +claudeErrorStatus :: Text -> Int +claudeErrorStatus = \case + "invalid_request_error" -> 400 + "authentication_error" -> 401 + "permission_error" -> 403 + "not_found_error" -> 404 + "request_too_large" -> 413 + "rate_limit_error" -> 429 + "api_error" -> 500 + "overloaded_error" -> 529 + _ -> 500 + +parseErrorType :: Value -> Parser Text +parseErrorType = withObject "error_event" $ \o -> do + e <- o .: "error" + withObject "error" (.: "type") e + +parseMessageDeltaStopReason :: Value -> Parser Text +parseMessageDeltaStopReason = withObject "message_delta" $ \o -> do + d <- o .: "delta" + withObject "delta" (.: "stop_reason") d streamBlockToPart :: Text -> StreamBlock -> ContentPart streamBlockToPart _ (StreamText t) = textPart t diff --git a/src/LLM/Providers/DeepSeek.hs b/src/LLM/Providers/DeepSeek.hs --- a/src/LLM/Providers/DeepSeek.hs +++ b/src/LLM/Providers/DeepSeek.hs @@ -24,7 +24,8 @@ import LLM.Core.LLMProvider (LLMProvider (..), toGateway) import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, stripJsonFences) import LLM.Core.Types - ( ChatRequest + ( commonImageMediaTypes, + ChatRequest ( reqConversation, reqMaxTokens, reqModel, @@ -34,6 +35,7 @@ ), LLMError (EmptyResponse), LLMGateway, + MessageEncodeOptions (..), ThinkingMode (..), deepSeekMessageEncodeOptions, pattern UserTurn, @@ -78,14 +80,17 @@ deepSeekProviderWith baseUrl baseOpts apiKey = LLMProvider { providerName = "deepseek", + providerImageMediaTypes = commonImageMediaTypes, + providerImageUrlSupport = True, buildBody = deepSeekBuildBody, sendRequest = sendRequest, - sendStreamRequest = \body callback -> + openStream = \body k -> runReq lenientConfig $ do let url = baseUrl /: "v1" /: "chat" /: "completions" opts = baseOpts <> authHeader apiKey reqBr POST url (ReqBodyJson body) opts $ \resp -> - handleStreamResponse resp (`parseOpenAIStream` callback), + handleStreamResponse resp k, + parseStream = const parseOpenAIStream, parseResponse = pure . parseOpenAIResponse, buildObjectBody = \r schema -> let schemaText = TL.toStrict . TLE.decodeUtf8 $ encode schema @@ -124,13 +129,18 @@ deepSeekBuildBodyPairs stream r = [ "model" .= r.reqModel, "max_tokens" .= r.reqMaxTokens, - "messages" .= buildMessages deepSeekMessageEncodeOptions r + "messages" .= buildMessages encodeOpts r ] ++ thinkingPairs r ++ ["temperature" .= t | Just t <- [r.reqTemperature]] ++ ["tools" .= map encodeToolDef r.reqTools | not (null r.reqTools)] ++ ["stream" .= True | stream] ++ ["stream_options" .= object ["include_usage" .= True] | stream] + where + encodeOpts = + deepSeekMessageEncodeOptions + { meoRequireReasoning = maybe False (.tmEnabled) r.reqThinking + } thinkingPairs :: ChatRequest -> [Pair] thinkingPairs r = diff --git a/src/LLM/Providers/Gemini.hs b/src/LLM/Providers/Gemini.hs --- a/src/LLM/Providers/Gemini.hs +++ b/src/LLM/Providers/Gemini.hs @@ -7,6 +7,7 @@ parseGeminiUsage, encodeTurn, signatureForModel, + skipThoughtSignatureValidator, ) where @@ -34,7 +35,8 @@ import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, stripBoundsAndComments, stripJsonFences) import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents) import LLM.Core.Types - ( ChatRequest + ( supportedImageMediaTypes, + ChatRequest ( reqConversation, reqMaxTokens, reqModel, @@ -106,9 +108,11 @@ geminiProviderWith baseUrl baseOpts apiKey = LLMProvider { providerName = geminiProviderName, + providerImageMediaTypes = supportedImageMediaTypes, + providerImageUrlSupport = True, buildBody = const geminiBuildBody, sendRequest = sendRequest, - sendStreamRequest = \body callback -> + openStream = \body k -> runReq lenientConfig $ do let model = extractModel body url = @@ -117,8 +121,9 @@ /: "models" /: (model <> ":streamGenerateContent") opts = baseOpts <> geminiAuthOpts apiKey <> "alt" =: ("sse" :: Text) - reqBr POST url (ReqBodyJson (stripBoundsAndComments $ stripModel body)) opts $ \resp -> - handleStreamResponse resp (`parseGeminiStream` callback), + reqBr POST url (ReqBodyJson (stripModel body)) opts $ \resp -> + handleStreamResponse resp k, + parseStream = const parseGeminiStream, parseResponse = parseGeminiResponse, buildObjectBody = \r schema -> object $ @@ -128,7 +133,7 @@ .= object ( [ "maxOutputTokens" .= r.reqMaxTokens, "responseMimeType" .= ("application/json" :: Text), - "responseSchema" .= schema + "responseSchema" .= stripBoundsAndComments schema ] ++ ["temperature" .= t | Just t <- [r.reqTemperature]] ++ thinkingConfigPairs r @@ -153,7 +158,7 @@ /: "models" /: (model <> ":generateContent") opts = baseOpts <> geminiAuthOpts apiKey - resp <- req POST url (ReqBodyJson (stripBoundsAndComments $ stripModel body)) jsonResponse opts + resp <- req POST url (ReqBodyJson (stripModel body)) jsonResponse opts pure (responseStatusCode resp, responseBody resp) geminiAuthOpts :: Text -> Option scheme @@ -326,9 +331,16 @@ object [ "name" .= td.toolName, "description" .= td.toolDescription, - "parameters" .= td.toolParameters + "parameters" .= stripBoundsAndComments td.toolParameters ] +-- | Google's documented placeholder for a @functionCall@ part that has no +-- thought signature of its own (a call from another provider or another +-- Gemini model). Gemini 3 rejects history whose function calls have no +-- signature. +skipThoughtSignatureValidator :: Text +skipThoughtSignatureValidator = "skip_thought_signature_validator" + encodeFunctionCall :: Text -> ToolCall -> Value encodeFunctionCall currentModel tc = object $ @@ -338,7 +350,9 @@ "args" .= tc.tcArguments ] ) - : ["thoughtSignature" .= s | Just s <- [signatureForModel currentModel tc.tcProviderMeta]] + : [ "thoughtSignature" + .= fromMaybe skipThoughtSignatureValidator (signatureForModel currentModel tc.tcProviderMeta) + ] encodeFunctionResponse :: ToolResult -> Value encodeFunctionResponse tr = diff --git a/src/LLM/Providers/Ollama.hs b/src/LLM/Providers/Ollama.hs --- a/src/LLM/Providers/Ollama.hs +++ b/src/LLM/Providers/Ollama.hs @@ -20,7 +20,8 @@ import LLM.Core.LLMProvider (LLMProvider (..), toGateway) import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI, stripJsonFences) import LLM.Core.Types - ( ChatRequest + ( commonImageMediaTypes, + ChatRequest ( reqMaxTokens, reqModel, reqTemperature, @@ -63,15 +64,20 @@ ollamaProviderWith baseUrl baseOpts = LLMProvider { providerName = "ollama", + providerImageMediaTypes = commonImageMediaTypes, + -- Ollama rejects image URLs ("not currently supported, please use + -- base64 encoded data instead"); only data URLs work. + providerImageUrlSupport = False, -- Ollama uses the same request format as OpenAI, but without stream_options -- (Ollama doesn't support include_usage in streaming). buildBody = ollamaBuildBody, sendRequest = sendRequest, - sendStreamRequest = \body callback -> + openStream = \body k -> runReq lenientConfig $ do let url = baseUrl /: "v1" /: "chat" /: "completions" reqBr POST url (ReqBodyJson body) baseOpts $ \resp -> - handleStreamResponse resp (`parseOpenAIStream` callback), + handleStreamResponse resp k, + parseStream = const parseOpenAIStream, parseResponse = pure . parseOpenAIResponse, buildObjectBody = \r schema -> object $ diff --git a/src/LLM/Providers/OpenAI.hs b/src/LLM/Providers/OpenAI.hs --- a/src/LLM/Providers/OpenAI.hs +++ b/src/LLM/Providers/OpenAI.hs @@ -20,7 +20,7 @@ import Data.Aeson ( KeyValue ((.=)), Object, - Value (String), + Value (Object, String), decodeStrict', encode, object, @@ -32,18 +32,22 @@ ) import Data.Aeson.Types (Pair, Parser, parseMaybe) import Data.ByteString.Lazy qualified as BSL -import Data.Foldable (forM_) +import Control.Monad (when, zipWithM) +import Data.Either (lefts, rights) +import Data.Foldable (foldl', for_, forM_) import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Map.Strict qualified as Map +import Data.Maybe (catMaybes, fromMaybe, listToMaybe, mapMaybe) import Control.Applicative ((<|>)) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway) -import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI, stripJsonFences) +import LLM.Core.ProviderUtils (decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, normalizeSchemaOpenAI, stripJsonFences) import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents) import LLM.Core.Types - ( ChatRequest + ( commonImageMediaTypes, + ChatRequest ( reqConversation, reqMaxTokens, reqModel, @@ -53,7 +57,7 @@ reqTools ), ContentPart (..), - LLMError (EmptyResponse), + LLMError (EmptyResponse, HttpError), LLMGateway, LLMTextResult, MessageEncodeOptions (..), @@ -118,14 +122,17 @@ openAIProviderWithName name baseUrl baseOpts apiKey = LLMProvider { providerName = name, + providerImageMediaTypes = commonImageMediaTypes, + providerImageUrlSupport = True, buildBody = openAIBuildBody, sendRequest = sendRequest, - sendStreamRequest = \body callback -> + openStream = \body k -> runReq lenientConfig $ do let url = baseUrl /: "v1" /: "chat" /: "completions" opts = baseOpts <> authHeader apiKey reqBr POST url (ReqBodyJson body) opts $ \resp -> - handleStreamResponse resp (`parseOpenAIStream` callback), + handleStreamResponse resp k, + parseStream = const parseOpenAIStream, parseResponse = pure . parseOpenAIResponse, buildObjectBody = \r schema -> object $ @@ -217,12 +224,18 @@ not (T.null t) ] calls = [tc | ContentPart (ToolCallPart tc) _ <- cleaned] + requireReasoning + | opts.meoRequireReasoning = Just . fromMaybe "" + | otherwise = id in [ object $ ["role" .= ("assistant" :: Text)] - ++ ["content" .= text | not (T.null text)] + -- Without tool calls, send content even when empty: OpenAI + -- rejects an assistant message with neither (e.g. a Claude turn + -- that held only thinking). + ++ ["content" .= text | not (T.null text) || null calls] ++ [ "reasoning_content" .= rc | opts.meoIncludeReasoning, - Just rc <- [mReasoning] + Just rc <- [requireReasoning mReasoning] ] ++ ["tool_calls" .= map encodeToolCall calls | not (null calls)] ] @@ -294,23 +307,28 @@ parseOpenAIResponse :: Value -> LLMTextResult parseOpenAIResponse v = case parseMaybe go v of Nothing -> Left EmptyResponse - Just parts -> - if null parts - then Left EmptyResponse - else Right (mkChatResponse parts (parseOpenAIUsage v)) + Just (finishReason, parts) -> + case lefts parts of + name : _ -> Left (invalidToolArgumentsError name (truncationReason finishReason)) + [] + | null parts -> Left EmptyResponse + | otherwise -> Right (mkChatResponse (rights parts) (parseOpenAIUsage v)) where - go :: Value -> Parser [ContentPart] + go :: Value -> Parser (Maybe Text, [Either Text ContentPart]) go = withObject "OpenAIResponse" $ \o -> do (choice : _) <- o .: "choices" :: Parser [Value] withObject "choice" ( \co -> do + finishReason <- co .:? "finish_reason" msg <- co .: "message" - withObject "message" parseMessage msg + parts <- withObject "message" parseMessage msg + pure (finishReason, parts) ) choice - parseMessage :: Object -> Parser [ContentPart] + -- Tool calls with invalid JSON arguments come back as 'Left' tool name. + parseMessage :: Object -> Parser [Either Text ContentPart] parseMessage mo = do mReasoning <- mo .:? "reasoning_content" :: Parser (Maybe Text) contentBlocks <- do @@ -324,9 +342,9 @@ | Just rc <- [mReasoning], not (T.null rc) ] - pure (thinkingBlocks ++ contentBlocks ++ toolBlocks) + pure (map Right (thinkingBlocks ++ contentBlocks) ++ toolBlocks) - parseToolCall :: Value -> Parser ContentPart + parseToolCall :: Value -> Parser (Either Text ContentPart) parseToolCall = withObject "tool_call" $ \tc -> do cid <- tc .: "id" fn <- tc .: "function" @@ -335,13 +353,16 @@ ( \f -> do name <- f .: "name" argsStr <- f .: "arguments" :: Parser Text - let args = case decodeStrict' (encodeUtf8 argsStr) of - Just v' -> v' - Nothing -> String argsStr - pure $ toolCallPart (mkToolCall cid name args) + pure $ case decodeToolArguments argsStr of + Just args -> Right (toolCallPart (mkToolCall cid name args)) + Nothing -> Left name ) fn +-- | The finish reason, if it says the response hit the token limit. +truncationReason :: Maybe Text -> Maybe Text +truncationReason r = if r == Just "length" then r else Nothing + parseOpenAIUsage :: Value -> Maybe Usage parseOpenAIUsage = parseMaybe $ withObject "OpenAIResponse" $ \o -> do u <- o .: "usage" @@ -388,7 +409,21 @@ blocksRef <- newIORef ([] :: [ContentPart]) reasoningRef <- newIORef Nothing usageRef <- newIORef Nothing - toolAccRef <- newIORef ([] :: [(Int, Text, Text, Text)]) + -- Tool calls being assembled, keyed by index: (id, name, argument text). + toolAccRef <- newIORef (Map.empty :: Map.Map Int (Text, Text, Text)) + errorRef <- newIORef (Nothing :: Maybe LLMError) + finishReasonRef <- newIORef (Nothing :: Maybe Text) + badToolRef <- newIORef (Nothing :: Maybe Text) -- first tool with invalid JSON args + let flushTools = do + tools <- readIORef toolAccRef + forM_ (Map.elems tools) $ \(cid, name, argsStr) -> + case decodeToolArguments argsStr of + Just args -> do + let tc = mkToolCall cid name args + modifyIORef' blocksRef (toolCallPart tc :) + callback (StreamToolCall tc) + Nothing -> modifyIORef' badToolRef (<|> Just name) + writeIORef toolAccRef Map.empty readSSEEvents (HC.brRead reader) $ \sse -> do let raw = sse.sseData if raw == "[DONE]" @@ -396,6 +431,8 @@ else case decodeStrict' (encodeUtf8 raw) of Nothing -> pure () Just v -> do + for_ (parseMaybe parseStreamError v) $ \status -> + modifyIORef' errorRef (<|> Just (HttpError status raw)) case parseMaybe parseStreamReasoningDelta v of Just (Just txt) | not (T.null txt) -> do modifyIORef' reasoningRef (Just . maybe txt (<> txt)) @@ -406,40 +443,17 @@ modifyIORef' blocksRef (textPart txt :) callback (StreamDelta txt) _ -> pure () - case parseMaybe parseStreamToolDelta v of - Just (idx, mId, mName, argChunk) -> do - modifyIORef' toolAccRef $ \acc -> - case lookup idx [(i, (i, cid, n, a)) | (i, cid, n, a) <- acc] of - Nothing -> - let cid = fromMaybe "" mId - n = fromMaybe "" mName - in acc ++ [(idx, cid, n, argChunk)] - Just (_, cid, n, a) -> - [(if i == idx then (i, cid, n, a <> argChunk) else entry) | entry@(i, _, _, _) <- acc] - Nothing -> pure () + for_ (parseMaybe parseStreamToolDeltas v) $ \deltas -> + modifyIORef' toolAccRef (\acc -> foldl' addToolDelta acc deltas) case parseMaybe parseFinishReason v of - Just "tool_calls" -> do - tools <- readIORef toolAccRef - forM_ tools $ \(_, cid, name, argsStr) -> do - let args = case decodeStrict' (encodeUtf8 argsStr) of - Just a -> a - Nothing -> String argsStr - tc = mkToolCall cid name args - modifyIORef' blocksRef (toolCallPart tc :) - callback (StreamToolCall tc) - writeIORef toolAccRef [] - _ -> pure () + Just reason -> do + writeIORef finishReasonRef (Just reason) + when (reason == "tool_calls") flushTools + Nothing -> pure () case parseMaybe parseStreamUsage v of Just u -> writeIORef usageRef (Just u) Nothing -> pure () - tools <- readIORef toolAccRef - forM_ tools $ \(_, cid, name, argsStr) -> do - let args = case decodeStrict' (encodeUtf8 argsStr) of - Just a -> a - Nothing -> String argsStr - tc = mkToolCall cid name args - modifyIORef' blocksRef (toolCallPart tc :) - callback (StreamToolCall tc) + flushTools textBlocks <- reverse <$> readIORef blocksRef mReasoning <- readIORef reasoningRef usage <- readIORef usageRef @@ -449,10 +463,40 @@ not (T.null rc) ] parts = thinkingBlocks ++ textBlocks - if null parts - then pure $ Left EmptyResponse - else pure $ Right (mkChatResponse parts usage) + mError <- readIORef errorRef + mBadTool <- readIORef badToolRef + finishReason <- readIORef finishReasonRef + pure $ case (mError, mBadTool) of + (Just err, _) -> Left err + (Nothing, Just name) -> Left (invalidToolArgumentsError name (truncationReason finishReason)) + _ + | null parts -> Left EmptyResponse + | otherwise -> Right (mkChatResponse parts usage) +-- | A mid-stream @{"error": ...}@ chunk, mapped to an HTTP status so +-- 'LLM.Core.Utils.isRetryable' treats it like the same error sent before +-- streaming started. Uses a numeric @code@/@status@ when the server sends +-- one; otherwise 429 for rate limits, 503 for overload, else 500. +parseStreamError :: Value -> Parser Int +parseStreamError = withObject "chunk" $ \o -> do + e <- o .: "error" + case e of + String msg -> pure (classify [msg]) + Object eo -> do + mCode <- eo .:? "code" <|> pure Nothing + mStatus <- eo .:? "status" <|> pure Nothing + texts <- mapM (\k -> eo .:? k <|> pure Nothing) ["type", "code", "message"] + pure $ case filter (\c -> c >= 400 && c < 600) (catMaybes [mCode, mStatus]) of + c : _ -> c + [] -> classify (catMaybes texts) + _ -> fail "not an error" + where + classify ts + | any (hasWord "rate") ts = 429 + | any (hasWord "overload") ts = 503 + | otherwise = 500 + hasWord w t = w `T.isInfixOf` T.toLower t + parseStreamReasoningDelta :: Value -> Parser (Maybe Text) parseStreamReasoningDelta = withObject "chunk" $ \o -> do (c : _) <- o .: "choices" :: Parser [Value] @@ -463,8 +507,28 @@ (c : _) <- o .: "choices" :: Parser [Value] withObject "choice" (\co -> do d <- co .: "delta"; withObject "delta" (.: "content") d) c -parseStreamToolDelta :: Value -> Parser (Int, Maybe Text, Maybe Text, Text) -parseStreamToolDelta = withObject "chunk" $ \o -> do +-- | One streamed tool-call fragment: index, id, name, argument text. +type ToolDelta = (Int, Maybe Text, Maybe Text, Text) + +-- | Merge a fragment into the accumulated tool calls. A fragment whose id +-- differs from the call already at its index starts a new call (servers +-- that omit @index@ would otherwise merge distinct calls). +addToolDelta :: Map.Map Int (Text, Text, Text) -> ToolDelta -> Map.Map Int (Text, Text, Text) +addToolDelta acc (idx, mId, mName, argChunk) = + case Map.lookup idx acc of + Just (cid, n, a) + | maybe True (== cid) mId || T.null cid -> + Map.insert idx (fromMaybe cid mId, fromMaybe n mName, a <> argChunk) acc + | otherwise -> Map.insert (nextIndex acc) new acc + Nothing -> Map.insert idx new acc + where + new = (fromMaybe "" mId, fromMaybe "" mName, argChunk) + nextIndex m = maybe 0 ((+ 1) . fst) (Map.lookupMax m) + +-- | All tool-call fragments in a chunk. Ollama may send several complete +-- calls in one chunk and may omit @index@; the position is used then. +parseStreamToolDeltas :: Value -> Parser [ToolDelta] +parseStreamToolDeltas = withObject "chunk" $ \o -> do (c : _) <- o .: "choices" :: Parser [Value] withObject "choice" @@ -473,27 +537,25 @@ withObject "delta" ( \d' -> do - (tc : _) <- d' .: "tool_calls" :: Parser [Value] - withObject - "tool_call" - ( \tco -> do - idx <- tco .: "index" - mId <- tco .:? "id" - fn <- tco .:? "function" .!= object [] - withObject - "function" - ( \f -> do - mName <- f .:? "name" - args <- f .:? "arguments" .!= "" - pure (idx, mId, mName, args) - ) - fn - ) - tc + tcs <- d' .: "tool_calls" :: Parser [Value] + zipWithM parseOne [0 ..] tcs ) d ) c + where + parseOne pos = withObject "tool_call" $ \tco -> do + idx <- tco .:? "index" .!= pos + mId <- tco .:? "id" + fn <- tco .:? "function" .!= object [] + withObject + "function" + ( \f -> do + mName <- f .:? "name" + args <- f .:? "arguments" .!= "" + pure (idx, mId, mName, args) + ) + fn parseFinishReason :: Value -> Parser Text parseFinishReason = withObject "chunk" $ \o -> do diff --git a/src/LLM/Tools/FsConfig.hs b/src/LLM/Tools/FsConfig.hs --- a/src/LLM/Tools/FsConfig.hs +++ b/src/LLM/Tools/FsConfig.hs @@ -5,6 +5,7 @@ mkFsConfig, sandboxPath, sandboxWritePath, + isSandboxRoot, isFileHidden, isSymlink, ) @@ -82,6 +83,15 @@ -- 'directory' package. verifyNoSymlinksInChain base (joinPath baseComps) tailComps pure canonical + +-- | True when a path already resolved by 'sandboxPath' is the workspace +-- root itself (e.g. the model passed @\".\"@, @\"\"@ or @\"sub\/..\"@). +-- Destructive tools use this to refuse operating on the whole workspace. +isSandboxRoot :: FsConfig -> FilePath -> Bool +isSandboxRoot cfg resolved = + equalFilePath + (dropTrailingPathSeparator cfg.fsBasePath) + (dropTrailingPathSeparator resolved) -- | Element-wise path-prefix comparison. -- Returns the trailing components of @full@ after stripping @prefix@, diff --git a/src/LLM/Tools/MoveFile.hs b/src/LLM/Tools/MoveFile.hs --- a/src/LLM/Tools/MoveFile.hs +++ b/src/LLM/Tools/MoveFile.hs @@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) -import LLM.Tools.FsConfig (FsConfig, isSymlink, sandboxPath, sandboxWritePath) +import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, isSymlink, sandboxPath, sandboxWritePath) import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, renameFile) data MoveFileToolArgs = MoveFileToolArgs @@ -43,19 +43,22 @@ -- the link itself (surprising) or, after `sandboxPath` resolution, -- potentially target a file outside the sandbox. srcIsLink <- isSymlink srcResolved - if srcIsLink - then pure $ "Error: refusing to move symbolic link source: " <> src - else do - srcExists <- doesPathExist srcResolved - if not srcExists - then pure $ "Error: source does not exist: " <> src + if isSandboxRoot cfg srcResolved + then pure $ "Error: refusing to move the workspace root: " <> src + else + if srcIsLink + then pure $ "Error: refusing to move symbolic link source: " <> src else do - srcIsFile <- doesFileExist srcResolved - srcIsDir <- doesDirectoryExist srcResolved - case (srcIsFile, srcIsDir) of - (False, True) -> pure $ "Error: source is a directory, not a regular file: " <> src - (False, False) -> pure $ "Error: source is not a regular file: " <> src - _ -> do - dstResolved <- sandboxWritePath cfg (T.unpack dst) - renameFile srcResolved dstResolved - pure $ "Successfully moved " <> src <> " to " <> dst + srcExists <- doesPathExist srcResolved + if not srcExists + then pure $ "Error: source does not exist: " <> src + else do + srcIsFile <- doesFileExist srcResolved + srcIsDir <- doesDirectoryExist srcResolved + case (srcIsFile, srcIsDir) of + (False, True) -> pure $ "Error: source is a directory, not a regular file: " <> src + (False, False) -> pure $ "Error: source is not a regular file: " <> src + _ -> do + dstResolved <- sandboxWritePath cfg (T.unpack dst) + renameFile srcResolved dstResolved + pure $ "Successfully moved " <> src <> " to " <> dst diff --git a/src/LLM/Tools/RemoveDirectory.hs b/src/LLM/Tools/RemoveDirectory.hs --- a/src/LLM/Tools/RemoveDirectory.hs +++ b/src/LLM/Tools/RemoveDirectory.hs @@ -7,7 +7,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) -import LLM.Tools.FsConfig (FsConfig, isSymlink, sandboxPath) +import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, isSymlink, sandboxPath) import System.Directory ( doesDirectoryExist, listDirectory, @@ -43,8 +43,11 @@ removeDirectoryExecTyped cfg args = do let p = args._rdPath resolved <- sandboxPath cfg (T.unpack p) - safeRemoveDirectoryRecursive resolved - pure $ "Successfully removed directory " <> p + if isSandboxRoot cfg resolved + then pure $ "Error: refusing to remove the workspace root: " <> p + else do + safeRemoveDirectoryRecursive resolved + pure $ "Successfully removed directory " <> p -- | Like 'System.Directory.removeDirectoryRecursive', but refuses to -- follow directory symlinks. A symbolic link encountered during the diff --git a/src/LLM/Tools/RemoveFile.hs b/src/LLM/Tools/RemoveFile.hs --- a/src/LLM/Tools/RemoveFile.hs +++ b/src/LLM/Tools/RemoveFile.hs @@ -6,8 +6,8 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) -import LLM.Tools.FsConfig (FsConfig, sandboxPath) -import System.Directory (removeFile) +import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, sandboxPath) +import System.Directory (doesDirectoryExist, removeFile) newtype RemoveFileToolArgs = RemoveFileToolArgs { _rftPath :: Text @@ -35,5 +35,12 @@ removeFileExecTyped cfg args = do let p = args._rftPath resolved <- sandboxPath cfg (T.unpack p) - removeFile resolved - pure $ "Successfully removed " <> p + isDir <- doesDirectoryExist resolved + if isSandboxRoot cfg resolved + then pure $ "Error: refusing to remove the workspace root: " <> p + else + if isDir + then pure $ "Error: path is a directory, not a file (use remove_directory): " <> p + else do + removeFile resolved + pure $ "Successfully removed " <> p diff --git a/test/LLM/ChatSpec.hs b/test/LLM/ChatSpec.hs --- a/test/LLM/ChatSpec.hs +++ b/test/LLM/ChatSpec.hs @@ -25,7 +25,10 @@ textPart, toolCallPart, pattern UserTurn, Turn (..), cacheEphemeral, + commonImageMediaTypes, + imageBase64Part, imageUrlPart, + supportedImageMediaTypes, LLMError (..), LLMGateway (..), LLMHooks (..), @@ -59,6 +62,8 @@ mockGateway resp = LLMGateway { gwName = "mock", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Right resp), gwStreamText = \_ _ _ -> pure (Right resp), gwGenerateObject = \_ _ _ -> pure (Right (object [], Nothing)) @@ -69,6 +74,8 @@ mockErrorGateway err = LLMGateway { gwName = "mock-error", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Left err), gwStreamText = \_ _ _ -> pure (Left err), gwGenerateObject = \_ _ _ -> pure (Left err) @@ -79,6 +86,8 @@ mockToolGateway = LLMGateway { gwName = "mock-tool", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ req -> if any isToolTurn req.reqConversation then pure $ Right (ChatResponse "The weather is sunny." [textPart "The weather is sunny."] (Just (mkUsage 80 15)) Nothing) @@ -187,6 +196,8 @@ in pure $ Right (ChatResponse "" [toolCallPart tc] (Just (mkUsage 50 10)) Nothing) in LLMGateway { gwName = "mock-tool-capture", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ -> respond, gwStreamText = \_ req _onEvent -> respond req, gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing) @@ -195,6 +206,91 @@ isToolTurn (ToolTurn _) = True isToolTurn _ = False +-- | Gateway that appends its label to @calls@ on every request, then answers +-- with @respond@ (given the request). +loggingGateway :: IORef [Text] -> Text -> (ChatRequest -> IO (Either LLMError ChatResponse)) -> LLMGateway +loggingGateway calls label respond = + let call req = modifyIORef' calls (++ [label]) >> respond req + in LLMGateway + { gwName = label, + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, + gwGenerateText = \_ -> call, + gwStreamText = \_ req _onEvent -> call req, + gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing) + } + +-- | Tool call when the conversation has no tool turn yet, text afterwards +-- (like 'mockToolGateway'). +toolThenText :: ChatRequest -> IO (Either LLMError ChatResponse) +toolThenText req + | any isToolTurn req.reqConversation = + pure $ Right (ChatResponse "The weather is sunny." [textPart "The weather is sunny."] (Just (mkUsage 80 15)) Nothing) + | otherwise = + let tc = mkToolCall "call_1" "get_weather" (object ["location" .= ("London" :: Text)]) + in pure $ Right (ChatResponse "" [toolCallPart tc] (Just (mkUsage 50 10)) Nothing) + where + isToolTurn (ToolTurn _) = True + isToolTurn _ = False + +-- | Fail while the conversation has no tool turn, then behave like 'toolThenText'. +failFirstRound :: ChatRequest -> IO (Either LLMError ChatResponse) +failFirstRound req + | any isToolTurn req.reqConversation = toolThenText req + | otherwise = pure $ Left (HttpError 503 "down") + where + isToolTurn (ToolTurn _) = True + isToolTurn _ = False + +-- | Tool call in the first round, failure afterwards. +toolThenFail :: ChatRequest -> IO (Either LLMError ChatResponse) +toolThenFail req + | any isToolTurn req.reqConversation = pure $ Left (HttpError 503 "down") + | otherwise = toolThenText req + where + isToolTurn (ToolTurn _) = True + isToolTurn _ = False + +alwaysFail :: ChatRequest -> IO (Either LLMError ChatResponse) +alwaysFail _ = pure $ Left (HttpError 503 "down") + +-- | Shared sticky-fallback checks, run for both 'runGenerate' and 'runStreamGenerate'. +stickyFallbackSpec :: + (Agent -> ModelWithFallbacks -> ToolMap Text -> Maybe AbortSignal -> [Turn] -> IO (Either GenerateErrorResult GenerateTextResult)) -> + ToolMap Text -> + Spec +stickyFallbackSpec run toolMap = do + let agent = defaultAgent {agTools = ["get_weather"]} + it "keeps using the fallback that answered for the rest of the run" $ do + calls <- newIORef [] + let primary = mockModel (loggingGateway calls "primary" alwaysFail) + fallback = mockModel (loggingGateway calls "fallback" toolThenText) + result <- run agent (ModelWithFallbacks primary [fallback]) toolMap Nothing [UserTurn "weather?"] + case result of + Right r -> r.gtrText `shouldBe` "The weather is sunny." + Left err -> expectationFailure $ show err + readIORef calls >>= (`shouldBe` ["primary", "fallback", "fallback"]) + + it "tries the remaining models, the earlier-failed one last, when the sticky model fails" $ do + calls <- newIORef [] + let a = mockModel (loggingGateway calls "a" failFirstRound) + b = mockModel (loggingGateway calls "b" toolThenFail) + c = mockModel (loggingGateway calls "c" alwaysFail) + result <- run agent (ModelWithFallbacks a [b, c]) toolMap Nothing [UserTurn "weather?"] + case result of + Right r -> r.gtrText `shouldBe` "The weather is sunny." + Left err -> expectationFailure $ show err + readIORef calls >>= (`shouldBe` ["a", "b", "b", "c", "a"]) + + it "starts from the caller's chain again on the next call" $ do + calls <- newIORef [] + let primary = mockModel (loggingGateway calls "primary" alwaysFail) + fallback = mockModel (loggingGateway calls "fallback" toolThenText) + models = ModelWithFallbacks primary [fallback] + _ <- run agent models toolMap Nothing [UserTurn "weather?"] + _ <- run agent models toolMap Nothing [UserTurn "weather again?"] + readIORef calls >>= (`shouldBe` ["primary", "fallback", "fallback", "primary", "fallback", "fallback"]) + hasCachedUserPrefix :: [Turn] -> Bool hasCachedUserPrefix = any @@ -267,6 +363,8 @@ let infiniteToolGateway = LLMGateway { gwName = "mock-infinite", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> let tc = mkToolCall "call_1" "get_weather" (object []) in pure $ Right (ChatResponse "" [toolCallPart tc] Nothing Nothing), @@ -302,6 +400,8 @@ let boomGw = LLMGateway { gwName = "should-not-run", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Left (HttpError 500 "should not be called")), gwStreamText = \_ _ _ -> pure (Left (HttpError 500 "should not be called")), gwGenerateObject = \_ _ _ -> pure (Left (HttpError 500 "should not be called")) @@ -329,6 +429,67 @@ Left GenerateErrorResult {gerError = GErrLLM (UnsupportedCapability _)} -> pure () other -> expectationFailure $ "Expected UnsupportedCapability, got: " <> show other + it "skips a model whose gateway does not accept the image media type" $ do + calls <- newIORef [] + Right heic <- pure $ imageBase64Part "image/heic" "aGVsbG8=" + let vision = defaultModelCapabilities {capVision = True} + claudeLike = + (mockModel ((loggingGateway calls "claude-like" toolThenText) {gwImageMediaTypes = commonImageMediaTypes})) + { mcCapabilities = vision + } + geminiLike = + (mockModel ((loggingGateway calls "gemini-like" toolThenText) {gwImageMediaTypes = supportedImageMediaTypes})) + { mcCapabilities = vision + } + msgs = [UserMessage [heic, textPart "what is this?"]] + result <- runGenerate defaultAgent (ModelWithFallbacks claudeLike [geminiLike]) toolMap Nothing msgs + case result of + Right r -> r.gtrText `shouldBe` "The weather is sunny." + Left err -> expectationFailure $ "Expected media-type fallback success, got: " <> show err + readIORef calls >>= (`shouldBe` ["gemini-like", "gemini-like"]) + + it "returns UnsupportedCapability when no model accepts the image media type" $ do + calls <- newIORef [] + Right heic <- pure $ imageBase64Part "image/heic" "aGVsbG8=" + let claudeLike name = + (mockModel ((loggingGateway calls name toolThenText) {gwImageMediaTypes = commonImageMediaTypes})) + { mcCapabilities = defaultModelCapabilities {capVision = True} + } + msgs = [UserMessage [heic, textPart "what is this?"]] + result <- runGenerate defaultAgent (ModelWithFallbacks (claudeLike "a") [claudeLike "b"]) toolMap Nothing msgs + case result of + Left GenerateErrorResult {gerError = GErrLLM (UnsupportedCapability _)} -> pure () + other -> expectationFailure $ "Expected UnsupportedCapability, got: " <> show other + readIORef calls >>= (`shouldBe` []) + + it "skips a model whose gateway does not accept image URLs" $ do + calls <- newIORef [] + let vision = defaultModelCapabilities {capVision = True} + ollamaLike = + (mockModel ((loggingGateway calls "ollama-like" toolThenText) {gwImageUrlSupport = False})) + { mcCapabilities = vision + } + urlOk = (mockModel (loggingGateway calls "url-ok" toolThenText)) {mcCapabilities = vision} + msgs = [UserMessage [imageUrlPart "https://example.com/cat.png", textPart "what is this?"]] + result <- runGenerate defaultAgent (ModelWithFallbacks ollamaLike [urlOk]) toolMap Nothing msgs + case result of + Right r -> r.gtrText `shouldBe` "The weather is sunny." + Left err -> expectationFailure $ "Expected URL-image fallback success, got: " <> show err + readIORef calls >>= (`shouldBe` ["url-ok", "url-ok"]) + + it "accepts base64 images on a gateway without image URL support" $ do + calls <- newIORef [] + Right png <- pure $ imageBase64Part "image/png" "aGVsbG8=" + let ollamaLike = + (mockModel ((loggingGateway calls "ollama-like" toolThenText) {gwImageUrlSupport = False})) + { mcCapabilities = defaultModelCapabilities {capVision = True} + } + msgs = [UserMessage [png, textPart "what is this?"]] + result <- runGenerate defaultAgent (ModelWithFallbacks ollamaLike []) toolMap Nothing msgs + case result of + Right r -> r.gtrText `shouldBe` "The weather is sunny." + Left err -> expectationFailure $ show err + it "returns error from last model when all fail" $ do let failGw1 = mockErrorGateway (HttpError 503 "service unavailable") failGw2 = mockErrorGateway (HttpError 400 "bad request") @@ -366,6 +527,8 @@ twoCallGw = LLMGateway { gwName = "mock-two", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> let tc1 = mkToolCall "c1" "slow" (object []) tc2 = mkToolCall "c2" "slow" (object []) @@ -381,18 +544,11 @@ Left GenerateErrorResult {gerError = GErrAborted} -> pure () other -> expectationFailure $ "Expected GErrAborted during tools, got: " <> show other - it "does not fall back on Aborted" $ do - let gw = mockGateway (ChatResponse "Hi!" [textPart "Hi!"] Nothing Nothing) - okGw = mockGateway (ChatResponse "Fallback" [textPart "Fallback"] Nothing Nothing) - models = ModelWithFallbacks (mockModel gw) [mockModel okGw] - sig <- newAbortSignal - abort sig - result <- runGenerate defaultAgent models Map.empty (Just sig) [UserTurn "hello"] - case result of - Left GenerateErrorResult {gerError = GErrAborted} -> pure () - other -> expectationFailure $ "Expected GErrAborted (no fallback), got: " <> show other + describe "sticky fallback" $ stickyFallbackSpec runGenerate toolMap describe "streamText" $ do + describe "sticky fallback" $ stickyFallbackSpec runStreamGenerate toolMap + it "preserves cache hints on user parts across streaming tool rounds" $ do ref <- newIORef [] let agent = defaultAgent {agTools = ["get_weather"]} diff --git a/test/LLM/ClaudeSpec.hs b/test/LLM/ClaudeSpec.hs --- a/test/LLM/ClaudeSpec.hs +++ b/test/LLM/ClaudeSpec.hs @@ -15,11 +15,14 @@ import Data.Maybe (mapMaybe) import Data.Scientific (toBoundedInteger, toRealFloat) import Data.Text (Text) +import Data.Text qualified as T import Data.Vector qualified as V import LLM.Core.Types ( ChatRequest (..), ChatResponse (respContent, respReasoning, respText), ContentPart (..), + LLMError (..), + LLMGateway (..), PartBody (..), ProviderOpaque (..), StreamEvent (..), @@ -38,9 +41,13 @@ pattern UserTurn, ) import LLM.Core.Usage (Usage (..), mkUsage) -import LLM.Core.Utils (getToolCalls, hasToolCalls) +import LLM.Core.Utils (getToolCalls, hasToolCalls, isRetryable) +import LLM.Generate.GenerateUtils (llmHooks) +import LLM.Generate.Logger (noHooks) import LLM.Providers.Claude ( claudeBuildBody, + claudeGateway, + checkClaudeThinkingBudget, encodeTurn, effortToBudgetTokens, parseClaudeResponse, @@ -125,28 +132,6 @@ Nothing -> expectationFailure "expected thinking opaque" tool.tcId `shouldBe` "toolu_weather_1" tool.tcName `shouldBe` "get_weather" - let encoded = - encodeTurn - "claude-haiku-4-5-20251001" - (AssistantMessage resp.respContent) - content = messageContent (head encoded) - contentTypes content `shouldBe` ["thinking", "text", "tool_use"] - case content of - (Object o : _) -> - lookupText "signature" (Object o) `shouldBe` Just "sig_thinking_abc123" - _ -> expectationFailure "expected thinking object" - let withResult = - encodeTurn - "claude-haiku-4-5-20251001" - ( ToolTurn - [ ToolResult - { trCallId = "toolu_weather_1", - trName = "get_weather", - trContent = "sunny" - } - ] - ) - length withResult `shouldBe` 1 other -> expectationFailure $ "unexpected parts: " <> show other events <- reverse <$> readIORef eventsRef events @@ -158,6 +143,48 @@ other -> expectationFailure $ "expected one StreamToolCall, got: " <> show other Left err -> expectationFailure $ "Stream parse failed: " <> show err + describe "parseClaudeStream errors and truncation" $ do + it "returns a retryable 529 for a mid-stream overloaded_error" $ do + sse <- BS.readFile "test/fixtures/claude-midstream-error.sse" + reader <- mkBodyReader sse + result <- parseClaudeStream "claude-haiku-4-5-20251001" reader (\_ -> pure ()) + case result of + Left err@(HttpError 529 body) -> do + T.unpack body `shouldContain` "overloaded_error" + isRetryable err `shouldBe` True + other -> expectationFailure ("expected HttpError 529, got " <> show other) + + it "returns a ParseError instead of String args when a tool call is cut off by max_tokens" $ do + sse <- BS.readFile "test/fixtures/claude-max-tokens-tool.sse" + eventsRef <- newIORef ([] :: [StreamEvent]) + reader <- mkBodyReader sse + result <- parseClaudeStream "claude-haiku-4-5-20251001" reader (\ev -> modifyIORef' eventsRef (ev :)) + case result of + Left (ParseError msg) -> T.unpack msg `shouldContain` "max_tokens" + other -> expectationFailure ("expected ParseError, got " <> show other) + events <- readIORef eventsRef + [tc | StreamToolCall tc <- events] `shouldBe` [] + + describe "parseClaudeResponse truncation" $ do + it "returns a ParseError when max_tokens cut off a tool_use block" $ do + let resp = + object + [ "model" .= ("claude-haiku-4-5-20251001" :: Text), + "stop_reason" .= ("max_tokens" :: Text), + "content" + .= [ object + [ "type" .= ("tool_use" :: Text), + "id" .= ("toolu_1" :: Text), + "name" .= ("get_weather" :: Text), + "input" .= object [] + ] + ], + "usage" .= object ["input_tokens" .= (1 :: Int), "output_tokens" .= (1 :: Int)] + ] + case parseClaudeResponse resp of + Left (ParseError msg) -> T.unpack msg `shouldContain` "max_tokens" + other -> expectationFailure ("expected ParseError, got " <> show other) + describe "encodeTurn replay" $ do it "replays signed thinking blocks before tool_use for the same model" $ do Right val <- eitherDecodeFileStrict' "test/fixtures/claude-thinking-tool-use.json" @@ -238,9 +265,31 @@ } body = claudeBuildBody False req nestedText ["thinking", "type"] body `shouldBe` Just "enabled" - nestedInt ["thinking", "budget_tokens"] body `shouldBe` Just (effortToBudgetTokens "high") + -- "high" is 10000, but budget_tokens must stay below max_tokens. + nestedInt ["thinking", "budget_tokens"] body `shouldBe` Just 4095 lookupKey "temperature" body `shouldBe` Nothing + it "uses the effort budget unchanged when max_tokens is large enough" $ do + let body = claudeBuildBody False (thinkingReq 16000 "high") + nestedInt ["thinking", "budget_tokens"] body `shouldBe` Just (effortToBudgetTokens "high") + + it "accepts the smallest max_tokens that leaves room for the minimum budget" $ do + checkClaudeThinkingBudget (thinkingReq 1025 "low") `shouldBe` Right () + nestedInt ["thinking", "budget_tokens"] (claudeBuildBody False (thinkingReq 1025 "high")) + `shouldBe` Just 1024 + + it "rejects thinking when max_tokens leaves no room for the minimum budget" $ do + case checkClaudeThinkingBudget (thinkingReq 1024 "low") of + Left (UnsupportedCapability _) -> pure () + other -> expectationFailure ("expected UnsupportedCapability, got " <> show other) + checkClaudeThinkingBudget (thinkingReq 1024 "low") {reqThinking = Nothing} `shouldBe` Right () + + it "the gateway returns the budget error without sending a request" $ do + r <- (claudeGateway "").gwGenerateText (llmHooks noHooks) (thinkingReq 512 "low") + case r of + Left (UnsupportedCapability _) -> pure () + other -> expectationFailure ("expected UnsupportedCapability, got " <> show other) + it "keeps temperature when thinking is off" $ do let req = ChatRequest @@ -339,20 +388,6 @@ usageTotalCost = 0 } - it "treats missing or zero cache fields as zero on recorded fixtures" $ do - Right val <- eitherDecodeFileStrict' "test/fixtures/claude-conversation-generated.json" - case val of - Array arr -> - case V.toList arr of - (Object first : _) -> - case KM.lookup "response" first of - Just resp -> - parseClaudeUsage resp - `shouldBe` Just (mkUsage 623 54) - _ -> expectationFailure "missing response" - _ -> expectationFailure "empty conversation array" - _ -> expectationFailure "expected conversation array" - -- | Yield the full SSE payload once, then empty chunks (EOF). mkBodyReader :: BS.ByteString -> IO (IO BS.ByteString) mkBodyReader bs = do @@ -412,3 +447,15 @@ nestedInt (key : rest) (Object o) = KM.lookup (K.fromText key) o >>= nestedInt rest nestedInt _ _ = Nothing + +thinkingReq :: Int -> Text -> ChatRequest +thinkingReq maxTokens effort = + ChatRequest + { reqModel = "claude-haiku-4-5-20251001", + reqConversation = [UserTurn "hi"], + reqSystem = Nothing, + reqMaxTokens = maxTokens, + reqTemperature = Nothing, + reqTools = [], + reqThinking = Just ThinkingMode {tmEnabled = True, tmEffort = Just effort} + } diff --git a/test/LLM/CrossProviderSpec.hs b/test/LLM/CrossProviderSpec.hs new file mode 100644 --- /dev/null +++ b/test/LLM/CrossProviderSpec.hs @@ -0,0 +1,262 @@ +-- | Mixed-provider history regression test. +-- +-- Fallback happens per model call, so one agent run can contain assistant +-- turns from several providers. This feeds one realistic mixed history +-- through every provider's 'buildBody' and checks the rules the live APIs +-- enforce (see .notes/fallback-fix-plan.md, items 2–4). +module LLM.CrossProviderSpec (spec) where + +import Data.Aeson (Value (Array, Object, String), encode, object, (.=)) +import Data.Aeson.Key qualified as K +import Data.Aeson.KeyMap qualified as KM +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BSL +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text.Encoding (encodeUtf8) +import Data.Vector qualified as V +import LLM.Core.LLMProvider (LLMProvider (..)) +import LLM.Core.Types + ( ChatRequest (..), + ProviderOpaque (..), + ThinkingContent (..), + ThinkingMode (..), + ToolCall (..), + ToolResult (..), + Turn (..), + imageBase64Part, + mkToolCall, + textPart, + thinkingPart, + toolCallPart, + pattern UserTurn, + ) +import LLM.Providers.Claude (claudeProvider) +import LLM.Providers.DeepSeek (deepSeekProvider) +import LLM.Providers.Gemini (geminiProvider) +import LLM.Providers.Ollama (ollamaProvider) +import LLM.Providers.OpenAI (openAIProvider) +import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy) + +-- Fake opaque payloads; none may reach another provider's request. + +claudeSig, claudeRedacted, geminiThoughtSig, geminiCallSig :: Text +claudeSig = "FAKE_CLAUDE_THINKING_SIGNATURE" +claudeRedacted = "FAKE_CLAUDE_REDACTED_DATA" +geminiThoughtSig = "FAKE_GEMINI_THOUGHT_SIGNATURE" +geminiCallSig = "FAKE_GEMINI_CALL_SIGNATURE" + +-- | One run: Claude → Gemini → OpenAI → Claude, then the next user turn. +-- Each assistant turn has the shape that provider's parser produces. +mixedHistory :: [Turn] +mixedHistory = + [ -- 1. user text + base64 png + UserMessage [textPart "What's in this picture, and what's the weather?", png], + -- 2. Claude: thinking + text + tool call + AssistantMessage + [ thinkingPart + ThinkingContent + { thinkingText = Just "claude thoughts", + thinkingOpaque = + Just + ProviderOpaque + { poProvider = "claude", + poModel = Just "claude-haiku-4-5-20251001", + poPayload = + object + [ "type" .= ("thinking" :: Text), + "thinking" .= ("claude thoughts" :: Text), + "signature" .= claudeSig + ] + } + }, + textPart "Let me check the weather.", + toolCallPart (mkToolCall "toolu_01AbCdEf" "get_weather" (object ["location" .= ("London" :: Text)])) + ], + -- 3. + ToolTurn [ToolResult "toolu_01AbCdEf" "get_weather" "Sunny, 22°C"], + -- 4. Gemini: thought part + function call with Gemini metadata + -- (the Gemini parser uses the function name as the call id). + AssistantMessage + [ thinkingPart + ThinkingContent + { thinkingText = Just "gemini thoughts", + thinkingOpaque = + Just + ProviderOpaque + { poProvider = "gemini", + poModel = Just "gemini-2.5-flash", + poPayload = + object + [ "text" .= ("gemini thoughts" :: Text), + "thought" .= True, + "thoughtSignature" .= geminiThoughtSig + ] + } + }, + toolCallPart + (mkToolCall "get_weather" "get_weather" (object ["location" .= ("Paris" :: Text)])) + { tcProviderMeta = + Just + ProviderOpaque + { poProvider = "gemini", + poModel = Just "gemini-2.5-flash", + poPayload = object ["thoughtSignature" .= geminiCallSig] + } + } + ], + -- 5. + ToolTurn [ToolResult "get_weather" "get_weather" "Rainy, 14°C"], + -- 6. OpenAI: tool call only + AssistantMessage [toolCallPart (mkToolCall "call_aBc123" "get_time" (object []))], + -- 7. + ToolTurn [ToolResult "call_aBc123" "get_time" "12:00"], + -- 8. Claude: only redacted thinking + AssistantMessage + [ thinkingPart + ThinkingContent + { thinkingText = Nothing, + thinkingOpaque = + Just + ProviderOpaque + { poProvider = "claude", + poModel = Just "claude-haiku-4-5-20251001", + poPayload = + object + [ "type" .= ("redacted_thinking" :: Text), + "data" .= claudeRedacted + ] + } + } + ], + UserTurn "Thanks. Anything else?" + ] + where + png = either (error . show) id (imageBase64Part "image/png" "iVBORw0KGgo=") + +mkReq :: Text -> Maybe ThinkingMode -> ChatRequest +mkReq model thinking = + ChatRequest + { reqModel = model, + reqConversation = mixedHistory, + reqSystem = Just "You are helpful.", + reqMaxTokens = 4096, + reqTemperature = Nothing, + reqTools = [], + reqThinking = thinking + } + +thinkingOn, thinkingOff :: Maybe ThinkingMode +thinkingOn = Just ThinkingMode {tmEnabled = True, tmEffort = Nothing} +thinkingOff = Just ThinkingMode {tmEnabled = False, tmEffort = Nothing} + +claudeBody, geminiBody, openAIBody, ollamaBody, deepSeekThinkingBody, deepSeekPlainBody :: Value +claudeBody = (claudeProvider "").buildBody False (mkReq "claude-haiku-4-5" Nothing) +geminiBody = (geminiProvider "").buildBody False (mkReq "gemini-3.1-flash-lite" Nothing) +openAIBody = (openAIProvider "").buildBody False (mkReq "gpt-4.1" Nothing) +ollamaBody = ollamaProvider.buildBody False (mkReq "qwen2.5vl" Nothing) +deepSeekThinkingBody = (deepSeekProvider "").buildBody False (mkReq "deepseek-v4-flash" thinkingOn) +deepSeekPlainBody = (deepSeekProvider "").buildBody False (mkReq "deepseek-v4-flash" thinkingOff) + +openAIProtocolBodies :: [(String, Value)] +openAIProtocolBodies = + [ ("OpenAI", openAIBody), + ("Ollama", ollamaBody), + ("DeepSeek (thinking)", deepSeekThinkingBody), + ("DeepSeek (no thinking)", deepSeekPlainBody) + ] + +spec :: Spec +spec = describe "Cross-provider history" $ do + describe "Gemini" $ do + it "sends a thoughtSignature on every functionCall part" $ do + let parts = concatMap (arrayAt "parts") (arrayAt "contents" geminiBody) + calls = filter (isJust . key "functionCall") parts + length calls `shouldBe` 3 + mapM_ (\p -> key "thoughtSignature" p `shouldSatisfy` isJust) calls + + describe "DeepSeek with thinking" $ do + it "sends reasoning_content on every assistant message" $ do + let msgs = assistantMessages deepSeekThinkingBody + length msgs `shouldBe` 4 + mapM_ (\m -> key "reasoning_content" m `shouldSatisfy` isJust) msgs + + describe "OpenAI-protocol providers" $ + mapM_ + ( \(name, body) -> + it (name <> ": every assistant message has content or tool_calls") $ do + let msgs = assistantMessages body + length msgs `shouldBe` 4 + mapM_ (\m -> m `shouldSatisfy` \v -> isJust (key "content" v) || isJust (key "tool_calls" v)) msgs + ) + openAIProtocolBodies + + describe "Claude" $ do + it "sends only Claude thinking blocks" $ do + let blocks = concatMap (arrayAt "content") (assistantMessages' "messages" claudeBody) + thinking = filter (\b -> textAt "type" b `elem` [Just "thinking", Just "redacted_thinking"]) blocks + map (\b -> (textAt "type" b, textAt "signature" b, textAt "data" b)) thinking + `shouldBe` [ (Just "thinking", Just claudeSig, Nothing), + (Just "redacted_thinking", Nothing, Just claudeRedacted) + ] + + it "pairs every tool_use with a tool_result in the next message" $ do + let msgs = arrayAt "messages" claudeBody + blockIds ty field m = [i | b <- arrayAt "content" m, textAt "type" b == Just ty, Just i <- [textAt field b]] + pairs = zip msgs (drop 1 msgs) + checked = + [ (useIds, blockIds "tool_result" "tool_use_id" next) + | (m, next) <- pairs, + textAt "role" m == Just "assistant", + let useIds = blockIds "tool_use" "id" m, + not (null useIds) + ] + length checked `shouldBe` 3 + mapM_ (\(useIds, resultIds) -> resultIds `shouldBe` useIds) checked + + describe "opaque payloads" $ do + let claudeSecrets = [claudeSig, claudeRedacted] + geminiSecrets = [geminiThoughtSig, geminiCallSig] + others = [("Claude", claudeBody), ("Gemini", geminiBody)] ++ openAIProtocolBodies + mapM_ + ( \(name, body) -> + it (name <> ": contains no other provider's opaque payload") $ do + let foreignSecrets = case name of + "Claude" -> geminiSecrets + "Gemini" -> claudeSecrets + _ -> claudeSecrets ++ geminiSecrets + leaked = filter (`containedIn` body) foreignSecrets + leaked `shouldBe` [] + ) + others + + it "Claude still replays its own signatures (sanity check of the search)" $ + if all (`containedIn` claudeBody) claudeSecrets + then pure () + else expectationFailure "Claude signatures missing from Claude request" + +-- JSON helpers + +containedIn :: Text -> Value -> Bool +containedIn needle v = encodeUtf8 needle `BS.isInfixOf` BSL.toStrict (encode v) + +key :: Text -> Value -> Maybe Value +key k (Object o) = KM.lookup (K.fromText k) o +key _ _ = Nothing + +textAt :: Text -> Value -> Maybe Text +textAt k v = case key k v of + Just (String t) -> Just t + _ -> Nothing + +arrayAt :: Text -> Value -> [Value] +arrayAt k v = case key k v of + Just (Array a) -> V.toList a + _ -> [] + +assistantMessages :: Value -> [Value] +assistantMessages = assistantMessages' "messages" + +assistantMessages' :: Text -> Value -> [Value] +assistantMessages' field body = + filter (\m -> textAt "role" m == Just "assistant") (arrayAt field body) diff --git a/test/LLM/DeepSeekSpec.hs b/test/LLM/DeepSeekSpec.hs --- a/test/LLM/DeepSeekSpec.hs +++ b/test/LLM/DeepSeekSpec.hs @@ -19,6 +19,8 @@ defaultMessageEncodeOptions, mkToolCall, textPart, + toolCallPart, + pattern UserTurn, ) import LLM.Core.Usage (Usage (..)) import LLM.Providers.DeepSeek (deepSeekBuildBodyPairs) @@ -72,6 +74,31 @@ body = object (deepSeekBuildBodyPairs False req) nestedText ["thinking", "type"] body `shouldBe` Just "disabled" + describe "reasoning_content on assistant turns without thinking" $ do + let foreignToolTurn = AssistantMessage [toolCallPart (mkToolCall "c1" "get_date" (object []))] + withThinking enabled conv = + sampleRequest + { reqConversation = conv, + reqThinking = Just ThinkingMode {tmEnabled = enabled, tmEffort = Nothing} + } + assistantMsgs r = + [m | m@(Object o) <- bodyMessages (object (deepSeekBuildBodyPairs False r)), KM.lookup "role" o == Just (String "assistant")] + + it "sends an empty reasoning_content when thinking is enabled" $ do + let msgs = assistantMsgs (withThinking True [UserTurn "date?", foreignToolTurn]) + map (lookupText "reasoning_content") msgs `shouldBe` [Just ""] + + it "omits reasoning_content when thinking is disabled" $ do + let msgs = assistantMsgs (withThinking False [UserTurn "date?", foreignToolTurn]) + map (lookupText "reasoning_content") msgs `shouldBe` [Nothing] + let msgsDefault = assistantMsgs sampleRequest {reqConversation = [UserTurn "date?", foreignToolTurn]} + map (lookupText "reasoning_content") msgsDefault `shouldBe` [Nothing] + + it "sends an existing thinking text unchanged" $ do + let turn = assistantTurn "" (Just "CoT") [mkToolCall "c1" "get_date" (object [])] + msgs = assistantMsgs (withThinking True [UserTurn "date?", turn]) + map (lookupText "reasoning_content") msgs `shouldBe` [Just "CoT"] + describe "response parsing" $ do it "extracts reasoning_content from provider responses" $ do let response = @@ -134,6 +161,11 @@ reqTools = [], reqThinking = Nothing } + +bodyMessages :: Value -> [Value] +bodyMessages (Object o) + | Just (Array arr) <- KM.lookup "messages" o = V.toList arr +bodyMessages _ = [] lookupText :: Text -> Value -> Maybe Text lookupText key (Object o) = diff --git a/test/LLM/FsToolsSpec.hs b/test/LLM/FsToolsSpec.hs --- a/test/LLM/FsToolsSpec.hs +++ b/test/LLM/FsToolsSpec.hs @@ -164,6 +164,51 @@ runTool_ tm "remove_directory" (object ["path" .= ("tmp" :: Text)]) doesDirectoryExist (sb "tmp") `shouldReturn` False + describe "workspace root guard" $ do + let rootPaths = [".", "", "./", "sub/.."] :: [Text] + it "remove_directory refuses the workspace root" $ withSandbox $ \sb -> do + tm <- fsTools sb + runTool_ tm "create_directory" (object ["path" .= ("sub" :: Text)]) + runTool_ tm "writefile" (object ["path" .= ("keep.txt" :: Text), "content" .= ("k" :: Text)]) + mapM_ + ( \p -> do + result <- runTool tm "remove_directory" (object ["path" .= p]) + T.unpack result `shouldContain` "Error" + T.unpack result `shouldContain` "workspace root" + ) + rootPaths + doesFileExist (sb "keep.txt") `shouldReturn` True + doesDirectoryExist (sb "sub") `shouldReturn` True + + it "remove_file refuses the workspace root" $ withSandbox $ \sb -> do + tm <- fsTools sb + runTool_ tm "create_directory" (object ["path" .= ("sub" :: Text)]) + mapM_ + ( \p -> do + result <- runTool tm "remove_file" (object ["path" .= p]) + T.unpack result `shouldContain` "workspace root" + ) + rootPaths + doesDirectoryExist sb `shouldReturn` True + + it "move_file refuses the workspace root as source" $ withSandbox $ \sb -> do + tm <- fsTools sb + runTool_ tm "create_directory" (object ["path" .= ("sub" :: Text)]) + mapM_ + ( \p -> do + result <- runTool tm "move_file" (object ["source" .= p, "destination" .= ("sub/moved" :: Text)]) + T.unpack result `shouldContain` "workspace root" + ) + rootPaths + doesDirectoryExist (sb "sub") `shouldReturn` True + + it "remove_file reports a clear error for a directory" $ withSandbox $ \sb -> do + tm <- fsTools sb + runTool_ tm "create_directory" (object ["path" .= ("sub" :: Text)]) + result <- runTool tm "remove_file" (object ["path" .= ("sub" :: Text)]) + T.unpack result `shouldContain` "is a directory" + doesDirectoryExist (sb "sub") `shouldReturn` True + withSandbox :: (FilePath -> IO a) -> IO a withSandbox act = withSystemTempDirectory "llm-simple-fstools" $ \root -> do let sb = root "sandbox" diff --git a/test/LLM/GeminiSpec.hs b/test/LLM/GeminiSpec.hs --- a/test/LLM/GeminiSpec.hs +++ b/test/LLM/GeminiSpec.hs @@ -3,11 +3,17 @@ module LLM.GeminiSpec (spec) where import Data.Aeson (Value (Array, Object, String), eitherDecodeFileStrict', object, (.=)) +import Data.Aeson.Key qualified as K import Data.Aeson.KeyMap qualified as KM import Data.Text (Text) +import Data.Text qualified as T import Data.Vector qualified as V +import LLM.Core.LLMProvider (LLMProvider (..)) +import LLM.Core.ProviderUtils (normalizeSchemaOpenAI, stripBoundsAndComments) import LLM.Core.Types - ( ChatResponse (respText), + ( ChatRequest (..), + ChatResponse (respText), + ToolDef (..), ProviderOpaque (..), ThinkingContent (..), ToolCall (..), @@ -22,7 +28,7 @@ ) import LLM.Core.Usage (Usage (..), mkUsage) import LLM.Core.Utils (getToolCalls, hasToolCalls) -import LLM.Providers.Gemini (encodeTurn, parseGeminiResponse, parseGeminiUsage, signatureForModel) +import LLM.Providers.Gemini (encodeTurn, geminiProvider, parseGeminiResponse, parseGeminiUsage, signatureForModel, skipThoughtSignatureValidator) import Test.Hspec ( Spec, describe, @@ -33,6 +39,111 @@ spec :: Spec spec = describe "Gemini" $ do + describe "stripBoundsAndComments" $ do + it "keeps properties named minimum/maximum and strips their constraints" $ do + let schema = + object + [ "type" .= ("object" :: Text), + "properties" + .= object + [ "minimum" .= object ["type" .= ("number" :: Text), "minimum" .= (0 :: Int), "$comment" .= ("c" :: Text)], + "maximum" .= object ["type" .= ("string" :: Text)] + ] + ] + stripBoundsAndComments schema + `shouldBe` object + [ "type" .= ("object" :: Text), + "properties" + .= object + [ "minimum" .= object ["type" .= ("number" :: Text)], + "maximum" .= object ["type" .= ("string" :: Text)] + ] + ] + + it "recurses into items and anyOf but leaves default values alone" $ do + let schema = + object + [ "type" .= ("array" :: Text), + "items" + .= object + [ "anyOf" + .= [ object ["type" .= ("integer" :: Text), "maximum" .= (9 :: Int)], + object ["type" .= ("null" :: Text)] + ] + ], + "default" .= [object ["minimum" .= (1 :: Int)]] + ] + stripBoundsAndComments schema + `shouldBe` object + [ "type" .= ("array" :: Text), + "items" + .= object + [ "anyOf" + .= [ object ["type" .= ("integer" :: Text)], + object ["type" .= ("null" :: Text)] + ] + ], + "default" .= [object ["minimum" .= (1 :: Int)]] + ] + + describe "normalizeSchemaOpenAI" $ do + it "does not treat a property named type as an object schema" $ do + let schema = + object + [ "type" .= ("object" :: Text), + "properties" .= object ["type" .= object ["type" .= ("string" :: Text)]] + ] + normalizeSchemaOpenAI schema + `shouldBe` object + [ "type" .= ("object" :: Text), + "properties" .= object ["type" .= object ["type" .= ("string" :: Text)]], + "additionalProperties" .= False, + "required" .= (["type"] :: [Text]) + ] + + describe "request body schema stripping" $ do + it "strips bounds from tool parameters but not from conversation content" $ do + let params = + object + [ "type" .= ("object" :: Text), + "properties" .= object ["minimum" .= object ["type" .= ("number" :: Text), "minimum" .= (0 :: Int)]] + ] + args = object ["minimum" .= (5 :: Int)] + req = + ChatRequest + { reqModel = "gemini-2.5-flash", + reqConversation = [AssistantMessage [toolCallPart (mkToolCall "c1" "f" args)]], + reqSystem = Nothing, + reqMaxTokens = 100, + reqTemperature = Nothing, + reqTools = [ToolDef {toolName = "f", toolDescription = "d", toolReadonly = True, toolParameters = params}], + reqThinking = Nothing + } + body = (geminiProvider "").buildBody False req + strippedParams = + object + [ "type" .= ("object" :: Text), + "properties" .= object ["minimum" .= object ["type" .= ("number" :: Text)]] + ] + lookupPath ["tools", "0", "function_declarations", "0", "parameters"] body `shouldBe` Just strippedParams + lookupPath ["contents", "0", "parts", "0", "functionCall", "args"] body `shouldBe` Just args + + it "strips bounds from the object responseSchema" $ do + let schema = object ["type" .= ("integer" :: Text), "maximum" .= (3 :: Int)] + req = + ChatRequest + { reqModel = "gemini-2.5-flash", + reqConversation = [], + reqSystem = Nothing, + reqMaxTokens = 100, + reqTemperature = Nothing, + reqTools = [], + reqThinking = Nothing + } + body = (geminiProvider "").buildObjectBody req schema + lookupPath ["generationConfig", "responseSchema"] body + `shouldBe` Just (object ["type" .= ("integer" :: Text)]) + describe "parseGeminiResponse" $ do it "parses a text response" $ do Right val <- eitherDecodeFileStrict' "test/fixtures/gemini-text.json" @@ -54,7 +165,7 @@ Left err -> expectationFailure $ "Parse failed: " <> show err describe "thought signature round-trip" $ do - it "replays signature only for a matching model" $ do + it "replays signature only for a matching model, else sends the placeholder" $ do let tc = (mkToolCall "call_1" "get_weather" (object ["location" .= ("London" :: Text)])) { tcProviderMeta = @@ -68,8 +179,8 @@ turn = AssistantMessage [toolCallPart tc] matching = head (encodeTurn "gemini-2.5-pro" turn) mismatch = head (encodeTurn "gemini-2.5-flash" turn) - hasThoughtSignature matching `shouldBe` True - hasThoughtSignature mismatch `shouldBe` False + thoughtSignatures matching `shouldBe` ["sig-xyz"] + thoughtSignatures mismatch `shouldBe` [skipThoughtSignatureValidator] signatureForModel "gemini-2.5-pro" tc.tcProviderMeta `shouldBe` Just "sig-xyz" signatureForModel "gemini-2.5-flash" tc.tcProviderMeta `shouldBe` Nothing @@ -100,8 +211,18 @@ -- plus text and functionCall => at least text + functionCall. length parts `shouldBe` 3 hasFunctionCall encoded `shouldBe` True - hasThoughtSignature encoded `shouldBe` False + -- The Claude signature must not leak; the call gets the placeholder. + thoughtSignatures encoded `shouldBe` [skipThoughtSignatureValidator] + it "sends the placeholder signature on every call without metadata" $ do + let turn = + AssistantMessage + [ toolCallPart (mkToolCall "c1" "get_weather" (object [])), + toolCallPart (mkToolCall "c2" "get_time" (object [])) + ] + encoded = head (encodeTurn "gemini-3.1-flash-lite" turn) + thoughtSignatures encoded `shouldBe` [skipThoughtSignatureValidator, skipThoughtSignatureValidator] + describe "image request encoding" $ do it "encodes URL fileData and base64 inlineData parts" $ do Right b64 <- pure $ imageBase64Part "image/jpeg" "aGVsbG8=" @@ -175,18 +296,10 @@ usageTotalCost = 0 } -hasThoughtSignature :: Value -> Bool -hasThoughtSignature (Object o) = - case KM.lookup "parts" o of - Just (Array arr) -> - any - ( \case - Object p -> KM.member "thoughtSignature" p - _ -> False - ) - arr - _ -> False -hasThoughtSignature _ = False +-- | The @thoughtSignature@ values of an encoded turn's parts, in order. +thoughtSignatures :: Value -> [Text] +thoughtSignatures v = + [sig | Object p <- assistantParts v, Just (String sig) <- [KM.lookup "thoughtSignature" p]] hasFunctionCall :: Value -> Bool hasFunctionCall (Object o) = @@ -207,3 +320,12 @@ Just (Array arr) -> V.toList arr _ -> [] assistantParts _ = [] + +-- | Follow object keys / array indices (as decimal strings). +lookupPath :: [Text] -> Value -> Maybe Value +lookupPath [] v = Just v +lookupPath (k : ks) (Object o) = KM.lookup (K.fromText k) o >>= lookupPath ks +lookupPath (k : ks) (Array a) = case reads (T.unpack k) of + [(i, "")] -> a V.!? i >>= lookupPath ks + _ -> Nothing +lookupPath _ _ = Nothing diff --git a/test/LLM/GenerateObjectSpec.hs b/test/LLM/GenerateObjectSpec.hs --- a/test/LLM/GenerateObjectSpec.hs +++ b/test/LLM/GenerateObjectSpec.hs @@ -10,7 +10,7 @@ import LLM.Agent.GenerateObject (generateObject, generateObjectUntyped) import LLM.Agent.Types (Agent (..), RuntimeArgs (..)) import LLM.Core.Abort (AbortSignal, abort, newAbortSignal) -import LLM.Core.Types (ChatRequest (..), ChatResponse (..), LLMError (..), LLMGateway (..), LLMHooks (..), assistantTurn, pattern UserTurn) +import LLM.Core.Types (ChatRequest (..), ChatResponse (..), LLMError (..), LLMGateway (..), LLMHooks (..), assistantTurn, supportedImageMediaTypes, pattern UserTurn) import LLM.Core.Usage (PricingInfo (..), Usage (..), defaultPricingInfo, mkUsage) import LLM.Generate.Logger (noHooks) import LLM.Generate.ModelConfig @@ -114,6 +114,8 @@ objectGateway value usage = LLMGateway { gwName = "object-mock", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Right (ChatResponse "" [] Nothing Nothing)), gwStreamText = \_ _ _ -> pure (Right (ChatResponse "" [] Nothing Nothing)), gwGenerateObject = \_ _ _ -> pure (Right (value, Just usage)) @@ -132,6 +134,8 @@ errorObjectGateway err = LLMGateway { gwName = "object-error", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Left err), gwStreamText = \_ _ _ -> pure (Left err), gwGenerateObject = \_ _ _ -> pure (Left err) diff --git a/test/LLM/GenericConversationTest.hs b/test/LLM/GenericConversationTest.hs --- a/test/LLM/GenericConversationTest.hs +++ b/test/LLM/GenericConversationTest.hs @@ -1,6 +1,8 @@ module LLM.GenericConversationTest (createSpec, GenericConversationTextOps (..)) where +import Control.Monad (when) import Data.Map qualified as Map +import Data.Maybe (isNothing) import Data.Text qualified as T import Heptapod (generate) import LLM (LLMHooks (..)) @@ -18,13 +20,14 @@ defaultModelCapabilities, ) import LLM.TestKit - ( loadRecordedConversation, + ( MockRequestResponse (..), + loadRecordedConversation, mockProvider, recordedConversationSystemPrompt, streamChatLoop, ) import LLM.WeatherTool (weatherToolTyped) -import Test.Hspec (Spec, describe, it, shouldBe) +import Test.Hspec (Spec, describe, it, pendingWith, shouldBe) data GenericConversationTextOps = GenericConversationTextOps { specTitle :: String, @@ -89,6 +92,8 @@ it "streamText" $ do (m, p) <- loadRecordedConversation opts.filePathStreamed + when (any (isNothing . (.sse)) (Map.elems m)) $ + pendingWith ("fixture has no raw SSE bodies; re-record " <> opts.filePathStreamed) uuid1 <- generate let provider = toGateway $ mockProvider m opts.specProvider modelConf = mkModelConfig opts provider diff --git a/test/LLM/LoadSpec.hs b/test/LLM/LoadSpec.hs --- a/test/LLM/LoadSpec.hs +++ b/test/LLM/LoadSpec.hs @@ -45,12 +45,6 @@ spec :: Spec spec = describe "Load" $ do describe "model catalog JSON" $ do - it "parses the bundled model catalog" $ do - result <- eitherDecodeFileStrict' "./model-catalog.json" - case result of - Right (Array xs) -> length xs `shouldSatisfy` (> 0) - _ -> expectationFailure "expected a JSON array" - it "fails on missing catalog file" $ do result <- try @SomeException (loadModelOrThrow "./no-such-catalog.json" "llama_3_2") case result of diff --git a/test/LLM/OpenAISpec.hs b/test/LLM/OpenAISpec.hs --- a/test/LLM/OpenAISpec.hs +++ b/test/LLM/OpenAISpec.hs @@ -10,28 +10,38 @@ ) import Data.Aeson.Key qualified as K import Data.Aeson.KeyMap qualified as KM -import Data.Maybe (mapMaybe) +import Data.Maybe (fromMaybe, mapMaybe) import Data.Text (Text) import Data.Vector qualified as V +import Data.ByteString qualified as BS +import Data.IORef (newIORef, readIORef, writeIORef) +import Data.Text qualified as T import LLM.Core.Types ( ChatResponse (respText), - ToolCall (tcId, tcName), + LLMError (..), + ProviderOpaque (..), + ThinkingContent (..), + ToolCall (tcArguments, tcId, tcName), Turn (..), cacheEphemeral, defaultMessageEncodeOptions, imageBase64Part, imageUrlPart, + mkToolCall, textPart, + thinkingPart, + toolCallPart, ) import LLM.Core.Usage (Usage (..), mkUsage) -import LLM.Core.Utils (getToolCalls, hasToolCalls) -import LLM.Providers.OpenAI (encodeTurn, parseOpenAIResponse, parseOpenAIUsage) +import LLM.Core.Utils (getToolCalls, hasToolCalls, isRetryable) +import LLM.Providers.OpenAI (encodeTurn, parseOpenAIResponse, parseOpenAIStream, parseOpenAIUsage) import Test.Hspec ( Spec, describe, expectationFailure, it, shouldBe, + shouldContain, shouldSatisfy, ) @@ -56,6 +66,97 @@ tc.tcId `shouldBe` "call_abc123" Left err -> expectationFailure $ "Parse failed: " <> show err + it "returns a ParseError when finish_reason is length and tool arguments are cut off" $ do + let resp = + object + [ "choices" + .= [ object + [ "finish_reason" .= ("length" :: Text), + "message" + .= object + [ "role" .= ("assistant" :: Text), + "tool_calls" + .= [ object + [ "id" .= ("call_1" :: Text), + "type" .= ("function" :: Text), + "function" + .= object + [ "name" .= ("get_weather" :: Text), + "arguments" .= ("{\"location\": \"Lon" :: Text) + ] + ] + ] + ] + ] + ] + ] + case parseOpenAIResponse resp of + Left (ParseError msg) -> T.unpack msg `shouldContain` "length" + other -> expectationFailure ("expected ParseError, got " <> show other) + + describe "parseOpenAIStream errors and truncation" $ do + it "returns a retryable 429 for a mid-stream rate limit error" $ do + reader <- fixtureReader "test/fixtures/openai-midstream-error.sse" + result <- parseOpenAIStream reader (\_ -> pure ()) + case result of + Left err@(HttpError 429 body) -> do + T.unpack body `shouldContain` "Rate limit" + isRetryable err `shouldBe` True + other -> expectationFailure ("expected HttpError 429, got " <> show other) + + it "returns a ParseError instead of String args when finish_reason is length" $ do + reader <- fixtureReader "test/fixtures/openai-length-tool.sse" + result <- parseOpenAIStream reader (\_ -> pure ()) + case result of + Left (ParseError msg) -> T.unpack msg `shouldContain` "length" + other -> expectationFailure ("expected ParseError, got " <> show other) + + describe "parseOpenAIStream multiple tool calls" $ do + it "parses every tool call in a chunk, in index order" $ do + reader <- fixtureReader "test/fixtures/openai-multi-tool-chunk.sse" + result <- parseOpenAIStream reader (\_ -> pure ()) + case result of + Right resp -> + [(tc.tcId, tc.tcName, tc.tcArguments) | tc <- getToolCalls resp] + `shouldBe` [ ("call_a", "get_weather", object ["location" .= ("London" :: Text)]), + ("call_b", "get_time", object ["zone" .= ("CET" :: Text)]) + ] + Left err -> expectationFailure ("unexpected error: " <> show err) + + it "parses Ollama-style complete tool calls without index fields" $ do + reader <- fixtureReader "test/fixtures/ollama-multi-tool-chunk.sse" + result <- parseOpenAIStream reader (\_ -> pure ()) + case result of + Right resp -> + [(tc.tcId, tc.tcArguments) | tc <- getToolCalls resp] + `shouldBe` [ ("call_x", object ["location" .= ("London" :: Text)]), + ("call_y", object ["location" .= ("Paris" :: Text)]) + ] + Left err -> expectationFailure ("unexpected error: " <> show err) + + describe "assistant message encoding" $ do + it "sends empty content for a turn with only foreign thinking" $ do + let redacted = + ThinkingContent + { thinkingText = Nothing, + thinkingOpaque = + Just + ProviderOpaque + { poProvider = "claude", + poModel = Just "claude-haiku-4-5", + poPayload = object ["type" .= ("redacted_thinking" :: Text), "data" .= ("xyz" :: Text)] + } + } + msg = head (encodeTurn defaultMessageEncodeOptions (AssistantMessage [thinkingPart redacted])) + lookupText "content" msg `shouldBe` Just "" + lookupKey "tool_calls" msg `shouldBe` Nothing + + it "omits content for a tool-call-only turn" $ do + let turn = AssistantMessage [toolCallPart (mkToolCall "c1" "get_weather" (object []))] + msg = head (encodeTurn defaultMessageEncodeOptions turn) + lookupKey "content" msg `shouldBe` Nothing + lookupKey "tool_calls" msg `shouldSatisfy` (/= Nothing) + describe "image request encoding" $ do it "encodes URL and base64 data-URL image parts" $ do Right b64 <- pure $ imageBase64Part "image/png" "aGVsbG8=" @@ -99,13 +200,6 @@ contentTypes parts `shouldBe` ["text", "image_url", "image_url"] mapM_ (\p -> lookupKey "cache_control" p `shouldBe` Nothing) parts - it "Ollama (shared OpenAI encoder) also omits cache hints" $ do - -- Ollama requests use the same encodeTurn + defaultMessageEncodeOptions path. - let plain = UserMessage [textPart "hello"] - hinted = UserMessage [cacheEphemeral (textPart "hello")] - head (encodeTurn defaultMessageEncodeOptions hinted) - `shouldBe` head (encodeTurn defaultMessageEncodeOptions plain) - describe "parseOpenAIUsage" $ do it "extracts token counts" $ do Right val <- eitherDecodeFileStrict' "test/fixtures/openai-text.json" @@ -183,3 +277,13 @@ nestedText (key : rest) (Object o) = KM.lookup (K.fromText key) o >>= nestedText rest nestedText _ _ = Nothing + +-- | Yield the whole fixture once, then EOF. +fixtureReader :: FilePath -> IO (IO BS.ByteString) +fixtureReader path = do + bs <- BS.readFile path + ref <- newIORef (Just bs) + pure $ do + m <- readIORef ref + writeIORef ref Nothing + pure (fromMaybe BS.empty m) diff --git a/test/LLM/StreamingSpec.hs b/test/LLM/StreamingSpec.hs --- a/test/LLM/StreamingSpec.hs +++ b/test/LLM/StreamingSpec.hs @@ -2,12 +2,16 @@ module LLM.StreamingSpec (spec) where +import Control.Concurrent (threadDelay) +import Control.Monad (when) import Data.Aeson (object, (.=)) -import Data.IORef (modifyIORef', newIORef, readIORef) +import Data.IORef (atomicModifyIORef', modifyIORef', newIORef, readIORef) import Data.Text (Text) import LLM.Core.Types ( ChatResponse (..), + LLMError (..), LLMGateway (..), + supportedImageMediaTypes, StreamEvent (..), Turn (..), assistantTurn, @@ -17,10 +21,10 @@ toolCallPart, ) import LLM.Core.Usage (PricingInfo (..), defaultPricingInfo, mkUsage) -import LLM.Generate.Generate (streamTextLLM) +import LLM.Generate.Generate (generateTextLLM, streamTextLLM, streamTextWithFallbacks) import LLM.Generate.GenerateUtils (llmHooks) import LLM.Generate.Logger (noHooks) -import LLM.Generate.ModelConfig (ModelConfig (..), defaultModelCapabilities) +import LLM.Generate.ModelConfig (ModelConfig (..), ModelWithFallbacks (..), defaultModelCapabilities) import LLM.Generate.Types ( GenRequest (..), RoundTextRole (..), @@ -72,10 +76,122 @@ chunks <- runStream gw [] reverse chunks `shouldBe` [ReasoningDelta "think", RoundTextRoleCommitted AnswerRole] + describe "request timeout" $ do + it "applies the timeout per attempt, so a retry can succeed" $ do + attempts <- newIORef (0 :: Int) + let resp = ChatResponse "ok" [textPart "ok"] Nothing Nothing + gw = + (streamGateway [] resp) + { gwGenerateText = \_ _ -> do + n <- atomicModifyIORef' attempts (\k -> (k + 1, k)) + when (n == 0) $ threadDelay 1_000_000 + pure (Right resp) + } + mc = (testModelConfig gw) {mcRequestTimeout = Just 100, mcRetryCount = 1} + r <- generateTextLLM (testGenRequest []) mc + fmap (.respText) r `shouldBe` Right "ok" + readIORef attempts >>= (`shouldBe` 2) + + it "streaming: does not cut off a stream that started within the timeout" $ do + let resp = ChatResponse "abc" [textPart "abc"] Nothing Nothing + gw = + (streamGateway [] resp) + { gwStreamText = \_ _ onEvent -> do + onEvent (StreamDelta "a") + threadDelay 150_000 + onEvent (StreamDelta "b") + threadDelay 150_000 + onEvent (StreamDelta "c") + pure (Right resp) + } + mc = (testModelConfig gw) {mcRequestTimeout = Just 100} + ref <- newIORef [] + r <- streamTextLLM (\c -> modifyIORef' ref (c :)) (testGenRequest []) mc + fmap (.respText) r `shouldBe` Right "abc" + chunks <- reverse <$> readIORef ref + take 3 chunks `shouldBe` [TextDelta "a", TextDelta "b", TextDelta "c"] + + it "streaming: times out when no event arrives in time" $ do + let resp = ChatResponse "late" [textPart "late"] Nothing Nothing + gw = + (streamGateway [] resp) + { gwStreamText = \_ _ onEvent -> do + threadDelay 1_000_000 + onEvent (StreamDelta "late") + pure (Right resp) + } + mc = (testModelConfig gw) {mcRequestTimeout = Just 100} + r <- streamTextLLM (\_ -> pure ()) (testGenRequest []) mc + fmap (.respText) r `shouldBe` Left TimeoutError + + describe "stream reset between attempts" $ do + it "emits StreamAttemptReset before a retry when the failed attempt streamed" $ do + gw <- flakyGateway "abc" "xyz" + let mc = (testModelConfig gw) {mcRetryCount = 1} + ref <- newIORef [] + r <- streamTextLLM (\c -> modifyIORef' ref (c :)) (testGenRequest []) mc + fmap (.respText) r `shouldBe` Right "xyz" + chunks <- reverse <$> readIORef ref + chunks + `shouldBe` [ TextDelta "abc", + StreamAttemptReset, + TextDelta "xyz", + RoundTextRoleCommitted AnswerRole + ] + + it "does not emit StreamAttemptReset when the failed attempt streamed nothing" $ do + gw <- flakyGateway "" "xyz" + let mc = (testModelConfig gw) {mcRetryCount = 1} + ref <- newIORef [] + _ <- streamTextLLM (\c -> modifyIORef' ref (c :)) (testGenRequest []) mc + chunks <- reverse <$> readIORef ref + chunks `shouldBe` [TextDelta "xyz", RoundTextRoleCommitted AnswerRole] + + it "emits StreamAttemptReset before falling back to the next model" $ do + let failing = + (streamGateway [] (ChatResponse "" [] Nothing Nothing)) + { gwStreamText = \_ _ onEvent -> do + onEvent (StreamDelta "abc") + pure (Left (HttpError 400 "bad")) + } + ok = streamGateway [StreamDelta "xyz"] (ChatResponse "xyz" [textPart "xyz"] Nothing Nothing) + models = ModelWithFallbacks (testModelConfig failing) [testModelConfig ok] + ref <- newIORef [] + r <- streamTextWithFallbacks (\c -> modifyIORef' ref (c :)) (testGenRequest []) models + fmap (.respText) r `shouldBe` Right "xyz" + chunks <- reverse <$> readIORef ref + chunks + `shouldBe` [ TextDelta "abc", + StreamAttemptReset, + TextDelta "xyz", + RoundTextRoleCommitted AnswerRole + ] + +-- | First call streams @first@ (if non-empty) then fails with a retryable +-- 503; later calls stream @second@ and succeed. +flakyGateway :: Text -> Text -> IO LLMGateway +flakyGateway first second = do + attempts <- newIORef (0 :: Int) + let resp = ChatResponse second [textPart second] Nothing Nothing + pure + (streamGateway [] resp) + { gwStreamText = \_ _ onEvent -> do + n <- atomicModifyIORef' attempts (\k -> (k + 1, k)) + if n == 0 + then do + when (first /= "") $ onEvent (StreamDelta first) + pure (Left (HttpError 503 "overloaded")) + else do + onEvent (StreamDelta second) + pure (Right resp) + } + streamGateway :: [StreamEvent] -> ChatResponse -> LLMGateway streamGateway events resp = LLMGateway { gwName = "stream-mock", + gwImageMediaTypes = supportedImageMediaTypes, + gwImageUrlSupport = True, gwGenerateText = \_ _ -> pure (Right resp), gwStreamText = \_ _ onEvent -> mapM_ onEvent events >> pure (Right resp), gwGenerateObject = \_ _ _ -> pure (Right (object [], Nothing)) @@ -85,31 +201,35 @@ runStream gw turns = do ref <- newIORef [] let onChunk c = modifyIORef' ref (c :) - gr = - GenRequest - { grSystemPrompt = Nothing, - grMessages = turns, - grTools = [], - grAbortSignal = Nothing, - grLLMHooks = llmHooks noHooks, - grHooks = noHooks - } - mc = - ModelConfig - { mcGateway = gw, - mcModel = "test", - mcPricing = zeroPricing, - mcMaxTokens = 256, - mcTemperature = Nothing, - mcThinking = Nothing, - mcCapabilities = defaultModelCapabilities, - mcRequestTimeout = Nothing, - mcThrottleDelay = Nothing, - mcRetryCount = 0, - mcJitterBackoff = 0 - } - _ <- streamTextLLM onChunk gr mc + _ <- streamTextLLM onChunk (testGenRequest turns) (testModelConfig gw) readIORef ref + +testGenRequest :: [Turn] -> GenRequest +testGenRequest turns = + GenRequest + { grSystemPrompt = Nothing, + grMessages = turns, + grTools = [], + grAbortSignal = Nothing, + grLLMHooks = llmHooks noHooks, + grHooks = noHooks + } + +testModelConfig :: LLMGateway -> ModelConfig +testModelConfig gw = + ModelConfig + { mcGateway = gw, + mcModel = "test", + mcPricing = zeroPricing, + mcMaxTokens = 256, + mcTemperature = Nothing, + mcThinking = Nothing, + mcCapabilities = defaultModelCapabilities, + mcRequestTimeout = Nothing, + mcThrottleDelay = Nothing, + mcRetryCount = 0, + mcJitterBackoff = 0 + } zeroPricing :: PricingInfo zeroPricing = defaultPricingInfo 0 0 diff --git a/test/LLM/TestKit.hs b/test/LLM/TestKit.hs --- a/test/LLM/TestKit.hs +++ b/test/LLM/TestKit.hs @@ -16,14 +16,16 @@ ) where -import Data.Aeson (FromJSON, ToJSON, Value, decodeFileStrict) +import Data.Aeson (FromJSON, ToJSON, Value (Array, Object, String), decodeFileStrict) +import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Encode.Pretty (encodePretty) -import Data.Aeson.Types (parseMaybe) +import Data.ByteString qualified as BS import Data.ByteString.Lazy qualified as BSL import Data.IORef (IORef, newIORef, readIORef, writeIORef) import Data.Map qualified as M -import Data.Maybe (isJust) +import Data.Maybe (fromMaybe, isJust) import Data.Text (Text) +import Data.Text.Encoding qualified as TE import Data.Text.IO qualified as TIO import GHC.Generics (Generic) import Heptapod (generate) @@ -31,10 +33,10 @@ import LLM.Agent.Generate (generateText, streamText) import LLM.Agent.ToolUtils (toTool) import LLM.Agent.Types (Agent (..), RuntimeArgs (..), ToolMap) -import LLM.Core.LLMProvider (LLMProvider (..)) +import LLM.Core.LLMProvider (LLMProvider (..), toGateway) import LLM.Core.Types (LLMGateway, ThinkingMode (..), Turn (..), pattern UserTurn) import LLM.Core.Usage (addUsage, defaultPricingInfo, emptyUsage) -import LLM.Core.Utils (parseChatResponse) +import LLM.Core.Utils (streamResponseJson) import LLM.Generate.GenerateUtils (llmHooks) import LLM.Generate.Logger (Hooks (..), noHooks) import LLM.Generate.ModelConfig @@ -51,14 +53,18 @@ data MockRequestResponse = MockRequestResponse { prompt :: Maybe Text, request :: Value, - response :: Value + -- | Raw provider JSON for non-streaming calls; for streaming calls the + -- library's own encoding of the parsed response ('streamResponseJson'). + response :: Value, + -- | Raw streaming body as received from the provider (streaming calls only). + sse :: Maybe Text } deriving (Show, Generic) deriving anyclass (FromJSON, ToJSON) type MockConversation = [MockRequestResponse] -type MockConversationMap = M.Map Value Value +type MockConversationMap = M.Map Value MockRequestResponse recordedConversationPrompts :: [Text] recordedConversationPrompts = @@ -82,7 +88,7 @@ case s of Nothing -> error "can't read conversation" Just rrs -> - let pairs = map (\rr -> (rr.request, rr.response)) rrs + let pairs = map (\rr -> (rr.request, rr)) rrs rrMap = M.fromList pairs prompts = rrs >>= \rsp -> case rsp.prompt of Nothing -> []; Just p -> [p] in pure (rrMap, prompts) @@ -92,6 +98,10 @@ createDirectoryIfMissing True (takeDirectory filePath) BSL.writeFile filePath (encodePretty conversation) +-- | Replay a recorded conversation. Requests must match a recording exactly. +-- Streaming bodies are fed through the provider's real 'parseStream', and the +-- parsed result must match the response recorded alongside them (ignoring +-- tool-call ids; see 'withoutToolCallIds'). mockProvider :: MockConversationMap -> LLMProvider -> LLMProvider mockProvider mp adapter = adapter @@ -99,15 +109,60 @@ case M.lookup val mp of Nothing -> error (show val <> "\n" <> show (fst $ head $ M.toList mp)) - Just r -> pure (200, r), - sendStreamRequest = \body _callback -> do + Just rr -> pure (200, rr.response), + openStream = \body k -> do case M.lookup body mp of Nothing -> error ("value not found for:" <> show body) - Just r -> case parseMaybe parseChatResponse r of - Nothing -> error "can't parse recorded ChatResponse json" - Just chatResponse -> pure $ Right chatResponse + Just rr -> case rr.sse of + Nothing -> error "recorded streaming call has no raw SSE body; re-record the fixture" + Just raw -> do + result <- k =<< bytesReader (TE.encodeUtf8 raw) + case result of + Right resp + | withoutToolCallIds (streamResponseJson resp) /= withoutToolCallIds rr.response -> + error $ + "replayed stream parsed differently than recorded:\n" + <> show (streamResponseJson resp) + <> "\nexpected:\n" + <> show rr.response + _ -> pure result } +-- | Gemini has no wire-level tool-call ids; the library mints them from a +-- process-global counter, so they differ between recording and replay. Where +-- ids do come from the wire, the next request's tool results still pin them. +withoutToolCallIds :: Value -> Value +withoutToolCallIds = \case + Object o -> Object (fmap stripParts (KM.filterWithKey (\k _ -> k == "content") o) <> o) + v -> v + where + stripParts (Array parts) = Array (fmap stripId parts) + stripParts v = v + stripId (Object p) + | KM.lookup "type" p == Just (String "tool_call") = Object (KM.delete "id" p) + stripId v = v + +-- | Yield the whole payload once, then EOF. +bytesReader :: BS.ByteString -> IO (IO BS.ByteString) +bytesReader bs = do + ref <- newIORef (Just bs) + pure $ do + m <- readIORef ref + writeIORef ref Nothing + pure (fromMaybe BS.empty m) + +-- | Wrap a provider so every streaming body it reads is appended to @ref@. +teeStream :: IORef [BS.ByteString] -> LLMProvider -> LLMProvider +teeStream ref p = + p + { openStream = \body k -> + p.openStream body $ \readChunk -> + k $ do + chunk <- readChunk + modifyIORef' ref (chunk :) + pure chunk + } + streamChatLoopMain :: Bool -> (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs) -> [Text] -> IO () streamChatLoopMain stream env prompts = do putStrLn "\n=== recorded conversation replay ===" @@ -138,11 +193,12 @@ Maybe ThinkingMode -> IORef (Maybe Text) -> IORef (Maybe Value) -> + IORef [BS.ByteString] -> IORef [MockRequestResponse] -> IO (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs) -mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef entriesRef = do +mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef sseRef entriesRef = do genId <- generate - let hooks = recordingHooks promptRef pendingRef entriesRef + let hooks = recordingHooks promptRef pendingRef sseRef entriesRef agent = Agent { agName = "test", @@ -181,12 +237,14 @@ } pure (agent, models, toolMap, rt) -recordConversation :: Bool -> LLMGateway -> Text -> Maybe ThinkingMode -> FilePath -> IO MockConversation -recordConversation stream gateway modelName thinking outPath = do +recordConversation :: Bool -> LLMProvider -> Text -> Maybe ThinkingMode -> FilePath -> IO MockConversation +recordConversation stream provider modelName thinking outPath = do promptRef <- newIORef Nothing pendingRef <- newIORef Nothing + sseRef <- newIORef [] entriesRef <- newIORef [] - env <- mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef entriesRef + let gateway = toGateway (teeStream sseRef provider) + env <- mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef sseRef entriesRef turns <- recordStreamChatLoop stream promptRef env recordedConversationPrompts entries <- readIORef entriesRef let conversation = reverse entries @@ -217,9 +275,9 @@ then streamText (const (pure ())) agent models toolMap rt conv' else generateText agent models toolMap rt conv' case result of - Left (GenerateErrorResult {gerError = err}) -> do - print err - pure conv + -- Fail before anything is written, so a broken run never replaces a good fixture. + Left (GenerateErrorResult {gerError = err}) -> + fail ("recording failed, fixture not written: " <> show err) Right (GenerateTextResult {gtrUsage = usage, gtrNewMessages = newMessages}) -> do let conv'' = conv' ++ newMessages aux (addUsage totalUsage usage) conv'' rest @@ -227,18 +285,24 @@ recordingHooks :: IORef (Maybe Text) -> IORef (Maybe Value) -> + IORef [BS.ByteString] -> IORef [MockRequestResponse] -> Hooks -recordingHooks promptRef pendingRef entriesRef = +recordingHooks promptRef pendingRef sseRef entriesRef = noHooks - { onRequest = \_ req -> writeIORef pendingRef (Just req), + { onRequest = \_ req -> do + writeIORef pendingRef (Just req) + writeIORef sseRef [], onResponse = \_ resp -> do mReq <- readIORef pendingRef mPrompt <- readIORef promptRef + chunks <- readIORef sseRef case mReq of Nothing -> pure () Just req -> do - let entry = MockRequestResponse mPrompt req resp + let raw = BS.concat (reverse chunks) + mSse = if BS.null raw then Nothing else Just (TE.decodeUtf8 raw) + entry = MockRequestResponse mPrompt req resp mSse entriesRef `modifyIORef'` (entry :) writeIORef pendingRef Nothing whenJustPrompt mPrompt $ writeIORef promptRef Nothing diff --git a/test/LLM/ToolUtilsSpec.hs b/test/LLM/ToolUtilsSpec.hs --- a/test/LLM/ToolUtilsSpec.hs +++ b/test/LLM/ToolUtilsSpec.hs @@ -1,15 +1,19 @@ module LLM.ToolUtilsSpec (spec) where +import Control.Concurrent (threadDelay) +import Control.Exception (throwIO) import Data.Aeson (Value (Null), object, (.=)) import Data.Text (Text) import Data.Text qualified as T import Heptapod (generate) +import LLM.Agent.Events (emitEvent) import LLM.Agent.ToolUtils (executeTool) -import LLM.Agent.Types (RuntimeArgs (..), Tool (..), ToolContext (..)) +import LLM.Agent.Types (EventObserver, GenerateEventDetail (..), RuntimeArgs (..), Tool (..), ToolContext (..)) import LLM.Core.Types (ToolCall (..), ToolDef (..), ToolResult (..)) import LLM.Generate.GenerateUtils (llmHooks) -import LLM.Generate.Logger (noHooks) -import Test.Hspec (Spec, describe, it, shouldContain) +import LLM.Generate.Logger (Hooks (..), LogLevel (..), noHooks, safeHooks) +import System.Timeout (timeout) +import Test.Hspec (Spec, describe, it, shouldBe, shouldContain) spec :: Spec spec = describe "ToolUtils" $ do @@ -72,3 +76,67 @@ readResult <- executeTool noHooks ctx [readonlyTool] readCall T.unpack writeResult.trContent `shouldContain` "readonly mode" T.unpack readResult.trContent `shouldContain` "found" + + describe "async exceptions" $ do + it "executeTool does not turn a timeout into a tool result" $ do + ctx <- mkContext (\_ -> pure ()) + let slow = mkTool "slow" (threadDelay 1_000_000 >> pure "done") + r <- timeout 50_000 (executeTool noHooks ctx [slow] (mkCall "slow")) + fmap (.trContent) r `shouldBe` Nothing + + it "executeTool still reports synchronous exceptions as tool errors" $ do + ctx <- mkContext (\_ -> pure ()) + let failing = mkTool "boom" (throwIO (userError "kaput")) + r <- executeTool noHooks ctx [failing] (mkCall "boom") + T.unpack r.trContent `shouldContain` "Tool error" + + it "emitEvent does not swallow a timeout in the observer" $ do + ctx <- mkContext (\_ -> threadDelay 1_000_000) + r <- timeout 50_000 (emitEvent ctx.tcRuntimeArgs GenerationStarted) + r `shouldBe` Nothing + + it "safeHooks does not swallow a timeout in a hook" $ do + let hooks = safeHooks noHooks {onLog = \_ _ -> threadDelay 1_000_000} + r <- timeout 50_000 (hooks.onLog Info "x") + r `shouldBe` Nothing + +mkTool :: Text -> IO Text -> Tool Text +mkTool name act = + Tool + { toolDef = + ToolDef + { toolName = name, + toolDescription = "test", + toolReadonly = True, + toolParameters = Null + }, + toolExecute = \_ _ -> act + } + +mkCall :: Text -> ToolCall +mkCall name = + ToolCall + { tcId = "1", + tcName = name, + tcArguments = object [], + tcProviderMeta = Nothing + } + +mkContext :: EventObserver -> IO ToolContext +mkContext onEvent = do + genId <- generate + pure + ToolContext + { tcConversation = [], + tcUsage = mempty, + tcWindowOffset = 0, + tcRuntimeArgs = + RuntimeArgs + { rtGenerationId = genId, + rtAbortSignal = Nothing, + rtLLMHooks = llmHooks noHooks, + rtHooks = noHooks, + rtOnEvent = onEvent, + rtReadonly = False + } + } diff --git a/test/LLM/TypesSpec.hs b/test/LLM/TypesSpec.hs --- a/test/LLM/TypesSpec.hs +++ b/test/LLM/TypesSpec.hs @@ -6,7 +6,7 @@ ( CacheHint (..), ChatResponse (ChatResponse), ContentPart (..), - LLMError (EmptyResponse, HttpError, NetworkError), + LLMError (EmptyResponse, HttpError, NetworkError, TimeoutError), PartBody (..), ThinkingContent (..), Turn (..), @@ -47,12 +47,6 @@ spec :: Spec spec = describe "Types" $ do describe "Usage" $ do - it "emptyUsage has zero tokens" $ do - emptyUsage.usageInputTokens `shouldBe` 0 - emptyUsage.usageOutputTokens `shouldBe` 0 - emptyUsage.usageCacheReadTokens `shouldBe` 0 - emptyUsage.usageCacheCreationTokens `shouldBe` 0 - it "addUsage sums token counts including cache counters" $ do let u1 = Usage @@ -79,18 +73,6 @@ usageTotalCost = 0.75 } - it "addUsage is associative" $ do - let u1 = mkUsage 1 2 - u2 = mkUsage 3 4 - u3 = mkUsage 5 6 - addUsage (addUsage u1 u2) u3 `shouldBe` addUsage u1 (addUsage u2 u3) - - it "Semigroup matches addUsage and Monoid uses emptyUsage" $ do - let u1 = mkUsage 10 1 - u2 = mkUsage 5 2 - (u1 <> u2) `shouldBe` addUsage u1 u2 - (mempty :: Usage) `shouldBe` emptyUsage - it "JSON round-trips with cache fields" $ do let u = Usage @@ -236,6 +218,8 @@ isRetryable (HttpError 503 "overloaded") `shouldBe` True it "retries on network errors" $ do isRetryable (NetworkError "connection refused") `shouldBe` True + it "retries on timeouts" $ do + isRetryable TimeoutError `shouldBe` True it "does not retry on 400" $ do isRetryable (HttpError 400 "bad request") `shouldBe` False it "does not retry on empty response" $ do