llm-simple 0.2.0.0 → 0.3.0.0

raw patch · 41 files changed

+2063/−394 lines, 41 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• CHANGELOG.md +123/−2
• Readme.md +2/−2
• app/RecordConversation.hs +17/−16
• llm-simple.cabal +2/−1
• model-catalog.json +1/−1
• src/LLM/Agent/Events.hs +4/−3
• src/LLM/Agent/Generate.hs +16/−11
• src/LLM/Agent/ToolUtils.hs +3/−3
• src/LLM/Core.hs +1/−0
• src/LLM/Core/LLMProvider.hs +15/−4
• src/LLM/Core/ProviderUtils.hs +66/−9
• src/LLM/Core/Types.hs +31/−10
• src/LLM/Core/Utils.hs +69/−2
• src/LLM/Generate/Generate.hs +60/−10
• src/LLM/Generate/GenerateUtils.hs +121/−14
• src/LLM/Generate/Logger.hs +10/−9
• src/LLM/Generate/ModelConfig.hs +3/−1
• src/LLM/Generate/Types.hs +5/−0
• src/LLM/Providers/Claude.hs +119/−23
• src/LLM/Providers/DeepSeek.hs +14/−4
• src/LLM/Providers/Gemini.hs +22/−8
• src/LLM/Providers/Ollama.hs +9/−3
• src/LLM/Providers/OpenAI.hs +138/−76
• src/LLM/Tools/FsConfig.hs +10/−0
• src/LLM/Tools/MoveFile.hs +19/−16
• src/LLM/Tools/RemoveDirectory.hs +6/−3
• src/LLM/Tools/RemoveFile.hs +11/−4
• test/LLM/ChatSpec.hs +166/−10
• test/LLM/ClaudeSpec.hs +85/−38
• test/LLM/CrossProviderSpec.hs +262/−0
• test/LLM/DeepSeekSpec.hs +32/−0
• test/LLM/FsToolsSpec.hs +45/−0
• test/LLM/GeminiSpec.hs +140/−18
• test/LLM/GenerateObjectSpec.hs +5/−1
• test/LLM/GenericConversationTest.hs +7/−2
• test/LLM/LoadSpec.hs +0/−6
• test/LLM/OpenAISpec.hs +115/−11
• test/LLM/StreamingSpec.hs +147/−27
• test/LLM/TestKit.hs +88/−24
• test/LLM/ToolUtilsSpec.hs +71/−3
• test/LLM/TypesSpec.hs +3/−19

@@ -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

@@ -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                                     |

@@ -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

@@ -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

@@ -92,7 +92,7 @@             "pricePerMillionInput": 1,             "pricePerMillionOutput": 5         },-        "maxTokens": 4096,+        "maxTokens": 16000,         "requestTimeout": 30000,         "throttleDelay": 5000,         "retryCount": 3,

@@ -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 ()

@@ -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)

@@ -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

@@ -25,6 +25,7 @@     cacheEphemeral,     mkImageBase64,     supportedImageMediaTypes,+    commonImageMediaTypes,     projectText,     projectReasoning,     turnToolCalls,

@@ -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

@@ -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"+  ]

@@ -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

@@ -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 _ = "<<first event timeout>>"++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.

@@ -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)

@@ -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

@@ -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

@@ -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,

@@ -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.

@@ -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

@@ -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 =

@@ -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 =

@@ -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 $

@@ -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

@@ -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@,

@@ -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

@@ -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

@@ -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

@@ -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"]}

@@ -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}+    }

@@ -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)

@@ -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) =

@@ -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"

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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

@@ -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+            }+      }

@@ -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