llm-simple 0.4.1.0 → 0.4.2.0

raw patch · 62 files changed

+2708/−572 lines, 62 filesdep +unixPVP ok

version bump matches the API change (PVP)

Dependencies added: unix

API changes (from Hackage documentation)

Files

• CHANGELOG.md +200/−0
• Readme.md +26/−11
• app/Main.hs +7/−13
• llm-simple.cabal +8/−1
• src/LLM/Agent.hs +2/−0
• src/LLM/Agent/Generate.hs +66/−40
• src/LLM/Agent/GenerateObject.hs +8/−4
• src/LLM/Agent/ToolUtils.hs +99/−20
• src/LLM/Agent/Tools/HistoryTool.hs +33/−15
• src/LLM/Agent/Types.hs +20/−7
• src/LLM/Core.hs +1/−0
• src/LLM/Core/Internal/Body.hs +69/−0
• src/LLM/Core/LLMProvider.hs +76/−18
• src/LLM/Core/ProviderUtils.hs +33/−4
• src/LLM/Core/SSE.hs +44/−15
• src/LLM/Core/Types.hs +17/−5
• src/LLM/Generate.hs +1/−0
• src/LLM/Generate/Generate.hs +12/−6
• src/LLM/Generate/GenerateObject.hs +6/−3
• src/LLM/Generate/GenerateUtils.hs +21/−2
• src/LLM/Generate/Logger.hs +11/−0
• src/LLM/Generate/Types.hs +4/−3
• src/LLM/Load/FsTools.hs +5/−4
• src/LLM/Load/LoadGateways.hs +11/−3
• src/LLM/Load/ModelCatalog.hs +42/−6
• src/LLM/Load/ProviderCatalog.hs +11/−4
• src/LLM/Load/Types.hs +9/−3
• src/LLM/Load/Utils.hs +12/−1
• src/LLM/Providers/Claude.hs +13/−17
• src/LLM/Providers/DeepSeek.hs +2/−7
• src/LLM/Providers/Gemini.hs +7/−16
• src/LLM/Providers/Ollama.hs +2/−7
• src/LLM/Providers/OpenAI.hs +16/−20
• src/LLM/Tools.hs +2/−0
• src/LLM/Tools/DirectoryTree.hs +29/−16
• src/LLM/Tools/FileInfo.hs +55/−34
• src/LLM/Tools/FindFiles.hs +42/−21
• src/LLM/Tools/FsConfig.hs +47/−16
• src/LLM/Tools/FsLimits.hs +68/−4
• src/LLM/Tools/Grep.hs +100/−73
• src/LLM/Tools/Internal/PathLock.hs +34/−0
• src/LLM/Tools/Internal/TextEdit.hs +26/−0
• src/LLM/Tools/Internal/WalkBudget.hs +62/−0
• src/LLM/Tools/MoveFile.hs +19/−4
• src/LLM/Tools/MultiReplaceInFile.hs +18/−31
• src/LLM/Tools/ReadFilePaginated.hs +107/−39
• src/LLM/Tools/Readdir.hs +21/−4
• src/LLM/Tools/Readfile.hs +5/−0
• src/LLM/Tools/ReplaceInFile.hs +20/−34
• src/LLM/Tools/Writefile.hs +4/−2
• test/LLM/ChatSpec.hs +318/−26
• test/LLM/FsLimitsSpec.hs +58/−2
• test/LLM/FsToolsSpec.hs +201/−0
• test/LLM/GeminiSpec.hs +29/−2
• test/LLM/HistoryToolSpec.hs +4/−0
• test/LLM/HttpConfigSpec.hs +80/−1
• test/LLM/LoadSpec.hs +110/−1
• test/LLM/RecordedConversationSpec.hs +97/−2
• test/LLM/ScaleSpec.hs +200/−0
• test/LLM/StreamingSpec.hs +45/−1
• test/LLM/TestKit.hs +6/−4
• test/LLM/TypesSpec.hs +7/−0

@@ -5,6 +5,205 @@ 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). +## [0.4.2.0] - 2026-11-03++### Added++- `LLM.Core.Types.validateTurns` (also in `LLM.Core`): the invalid turns+  of a conversation, by index, with `validateTurn`'s reason.+- `LLM.Core.LLMProvider.withoutRoutingFields` removes the `_model`+  routing key from a request body (see below).+- `LLM.Core.ProviderUtils.readResponseBody` reads a non-streaming response+  with the size limits below, for `sendRequest` in custom providers+  (`reqBr POST url body opts readResponseBody`).+- `LLM.Generate.Logger.safeLLMHooks` (also in `LLM.Generate`): `safeHooks`+  for `LLMHooks`. `LLM.Generate.GenerateUtils.safeGenRequest` and+  `LLM.Agent.ToolUtils.safeRuntimeArgs` apply both to a request.+- `LLM.Agent.Generate.toolBudgetUsedUpPrompt` (also in `LLM.Agent`): the+  system-prompt line of the agent's final call after the last tool round.+- `LLM.Agent.ToolUtils.validateAgent` (also in `LLM.Agent`) lists the+  warnings the agent loop logs about an agent configuration.+- `LLM.Agent.ToolUtils.agentRuntimeArgs`: the runtime arguments the agent+  entry points use (`safeRuntimeArgs` plus the `agName` log prefix).+- `LLM.Tools` exports `readFilePaginatedToolTyped`, the file reader that+  `fsTools` registers (`read_file_paginated`).+- `LLM.Tools.FsLimits.atomicWriteWith` replaces a file by writing a+  temporary file in the same directory and renaming it over the target.+- `LLM.Tools.FsLimits.maxVisitedEntries` (20,000) and `maxOutputBytes`+  (100 KiB): the work and output bounds of the filesystem tools.++### Changed++- `agName` is now used: the agent entry points (`generateText`,+  `streamText`, `generateObject`, `generateObjectUntyped`) prefix every+  `onLog` message of a run with `[<agName>] `. An empty name adds no+  prefix. **Behaviour change** for log output.+- `LLM.Agent.GenerateObject`, `LLM.Agent.Tools.HistoryTool`,+  `LLM.Load.FsTools`, `LLM.Load.ModelCatalog`, `LLM.Load.Types` and+  `LLM.Load.Utils` have explicit export lists. They export the same names+  as before; new helpers in them no longer become public by accident.++### Deprecated++- The `FsConfig` data constructor: build an `FsConfig` with `mkFsConfig`,+  which canonicalizes the base path. From 0.5 the constructor is not+  exported (the type and `fsBasePath` stay). GHC 9.10 and later warn about+  uses of the constructor; GHC 9.6 and 9.8 cannot deprecate a constructor+  without also deprecating the type of the same name, so they do not.+- `readfileToolTyped` (`LLM.Tools`, `LLM.Tools.Readfile`): `fsTools` does+  not register it. Use `readFilePaginatedToolTyped`. It is removed in 0.5.+- `MessageUpdated` (`GenerateEventDetail`): the agent loop never emits it.+  It is removed in 0.5; streamed text arrives through the `streamText`+  callback.++### Fixed++- Stream assembly, history paging and context windowing take linear time.+  Before, a stream split into many small reads or many fragments (one+  long SSE line, streamed tool arguments or reasoning for Claude and+  OpenAI-compatible providers, Gemini parts), and a long conversation in+  `windowOffset` or `get_history`, took quadratic time. No change in+  results.+- The example executable (`cabal run llm-simple`) loads only the model it+  uses (`deepseek4flash`), so it needs only `DEEPSEEK_API_KEY`. It loaded+  six models, and so needed every cloud provider's key.+- `onLLMRequest` (and so `onRequest` and the JSON dumps) now sees a Gemini+  request body as it is sent. It included the `_model` key that the+  provider uses to build the URL and removes before sending. A top-level+  `_model` key is now documented as routing data for any `LLMProvider`,+  and the request hooks never see it.+- `imageBase64Part` and `mkImageBase64` reject `=` anywhere but in the+  last one or two characters (`====`, `A===` and `ab=c` were accepted).+  **Behaviour change** for malformed input only.+- `validateTurn` is now applied: every generation entry point checks the+  request's messages once, before trying the first model, and logs each+  invalid turn (a user turn with a thinking or tool-call part, an+  assistant turn with an image) as `onLog Warn "turn <n>: <reason>"`, `n`+  counting from 0 in `grMessages`. The request is still sent unchanged.+  In an agent run the check runs once per model call. **0.5 will reject+  such a request** with an error instead.+- Loading the configuration rejects ambiguous or invalid values.+  **Behaviour change:** a catalog that loaded before can now fail to load.+  - `loadModelCatalog` (and every model loader) fails with+    `LoadModelCatalogError` naming the entry for a `modelConfigName` used+    twice (the last one silently won), `maxTokens <= 0`, or a negative+    `requestTimeout`, `throttleDelay`, `retryCount`, `jitterBackoff` or+    price. The whole catalog is rejected, not just the entry.+  - `loadProviderCatalog` fails with `LoadProviderCatalogError` for a+    `providerName` used twice in one file. Overriding a built-in provider+    is still allowed.+  - An API key variable that is set but empty or only whitespace counts as+    missing (`MissingApiKey`, "env var X is not set or is empty"). Before,+    the provider was available and sent the blank key, and an empty key+    also skipped the plain-HTTP base URL check.+- The agent checks its tool configuration. **Behaviour change:**+  - A name repeated in `agTools` is sent to the model once. Before, each+    copy was sent, a duplicate tool definition.+  - A name in `agTools` that the tool map lacks is logged as a warning+    (`onLog Warn`) once at the start of the run, as is a repeated name. It+    was dropped silently.+  - While `agContextWindow` is set, a caller tool named `get_history` is+    dropped with a warning, and only the built-in one is sent. Before, both+    were sent under one name.+  - A model call to an unknown tool fires `onToolError` (it already got+    the result "Unknown tool: <name>").+  - `agContextWindow = Just n` with `n <= 0` means no windowing, with a+    warning. A negative `n` sent an empty message list, and `windowOffset`+    returned the length of the conversation; it now returns 0.+- After the last allowed tool round, the agent makes one more model call+  instead of returning `GErrToolExceeded` with tool results the model never+  saw. **Behaviour change:** runs that ended in `GErrToolExceeded` mostly+  return an answer now, and a run makes up to `agMaxToolRounds + 1` model+  calls.+  - The final call is a normal request (the tools are still declared) with+    `toolBudgetUsedUpPrompt` appended to the system prompt.+  - A text reply is returned as a success. Tool calls in the reply are not+    run: each gets the result "Not run: tool round limit reached", and the+    run returns `GErrToolExceeded` with that assistant turn and tool turn+    in `gerPartialNewMessages`, so the history stays valid.+  - `agMaxToolRounds <= 0` makes only the final call.+- Invalid tool arguments are reported instead of silently replaced.+  **Behaviour change** for invalid arguments only: `find_files` returns an+  error for an unknown `type` (it searched for any kind) and for+  `maxResults <= 0`; `grep` for `maxResults <= 0`; `read_file_paginated`+  for `offset < 1` or `limit < 1` (all were clamped to 1). Values above a+  tool's hard cap are still lowered to the cap.+- `file_info` reports a symbolic link as a link. It resolved the path+  first, so it described the target and never said "symlink". It now+  shows `=== <path> | symbolic link ===` and the target relative to the+  workspace, with its kind (file, directory, or does not exist); a target+  outside the workspace is shown as "outside the workspace", not by its+  host path. **Behaviour change.**+- A path in which `..` would step back out of a symbolic link (`link/..`,+  `link/sub/../..`) is now refused with an error naming the link. The+  sandbox resolved `..` by name before following links, so such a path+  named a different file than the operating system would open.+  **Behaviour change** for such paths only. A surplus `..` at the+  filesystem root no longer turns the path into a relative one.+- `move_file` no longer overwrites its destination silently. If anything+  exists there, a symbolic link included (even a dangling one), it returns+  "Error: destination already exists: <dst>; remove it first" and changes+  nothing. **Behaviour change.** The check and the rename are not atomic,+  so another process can still create the destination in between.+- An exception thrown by a hook no longer fails a run whose side effects+  (a tool call, a paid model call) already happened. **Behaviour change:**+  every entry point (`generateTextLLM`, `streamTextLLM`, the+  `*WithFallbacks` functions, `genObject`, `genObjectUntyped`, and the+  agent's `generateText`, `streamText` and `generateObject*`) now wraps+  `Hooks` with `safeHooks` and `LLMHooks` with `safeLLMHooks`, which drop+  synchronous exceptions. A hook that throws to stop a run no longer stops+  it; use an `AbortSignal`. Asynchronous exceptions still propagate.+- An `HttpException` thrown by the caller's own stream callback (for+  example from an HTTP call it makes) is no longer reported as the+  provider's `NetworkError` and retried, which repeated the callback's+  effects. It now propagates from `streamTextLLM` (and the functions built+  on it) unchanged, after one attempt, like any other exception from the+  callback.+- Provider response bodies are now bounded. **Behaviour change:**+  - An error body (non-200) is read up to 64 KiB and cut there, with `...`+    appended, for both streaming and non-streaming calls. `readAll` does+    the same.+  - A 200 body of a non-streaming call larger than 32 MiB is a+    `ParseError "response body exceeds 33554432 bytes"`, as is a single+    stream event (or line) larger than 8 MiB. Before, either was read+    into memory in full.+  - The bundled providers read bodies with `readResponseBody`. Custom+    providers that read with `bsResponse` keep working, unbounded.+- `writefile`, `replace_in_file` and `multi_replace_in_file` no longer+  leave a partial or empty file when a write fails, and two edits of one+  file at the same time no longer lose one of them. **Behaviour change:**+  - The file is written to a temporary file next to it, then renamed over+    it. An existing file keeps its mode bits; a new file gets the default+    mode (`0666` minus the umask), as before. The data is flushed but not+    `fsync`ed.+  - The file gets a new inode. A hard link to it keeps the old content, so+    a write no longer changes a file outside the workspace through a hard+    link (a read still can). The new file is owned by the user running the+    process; ACLs and extended attributes are not copied.+  - The edit tools hold a per-file lock from the read to the write. It+    covers threads of the same process only; edits from other processes+    can still be lost.+- The search and listing tools now bound their total work, not just their+  output. **Behaviour change:**+  - `find_files`, `grep` and `directory_tree` look at no more than+    `maxVisitedEntries` directory entries per call. A walk that runs out+    stops and says so in its header ("stopped after visiting 20000+    entries; narrow the path or pattern"). Before, a large tree with no+    match was walked in full.+  - `grep` searches files as it walks and stops at `maxResults`, instead of+    collecting every candidate first and reading on to count files. When it+    stops early, the header shows the file count as `N+`, and "stopped at+    maxResults" replaces "truncated".+  - `readdir` lists at most 2,000 entries and ends with a line saying how+    many there are. `find_files`, `grep`, `readdir` and `directory_tree`+    cut their output at `maxOutputBytes` and say so.+  - `file_info` stops counting a directory's entries at its 10,000 cap.+  - A `read_file_paginated` page holds at most `maxOutputBytes` of text. A+    page ends before a line that would go over; a single longer line is cut+    and marked. Lines before `offset` are skipped without being decoded.+  - `read_file_paginated` no longer reports a file that grew past its+    10 MiB cap during the read as ending at the cap; it returns an error.+ ## [0.4.1.0] - 2026-11-02  ### Added@@ -541,6 +740,7 @@   DeepSeek), single-shot generation with fallbacks, agent tool loops, structured   output, JSON model catalog loading, and workspace-scoped filesystem tools. +[0.4.2.0]: https://github.com/aische/llm-simple/compare/v0.4.1.0...v0.4.2.0 [0.4.1.0]: https://github.com/aische/llm-simple/compare/v0.4.0.1...v0.4.1.0 [0.4.0.1]: https://github.com/aische/llm-simple/compare/v0.4.0.0...v0.4.0.1 [0.4.0.0]: https://github.com/aische/llm-simple/compare/v0.3.0.0...v0.4.0.0

@@ -10,7 +10,7 @@  - **Providers:** OpenAI, Claude, Gemini, Ollama, DeepSeek - **Generate:** single-request text, streaming, and structured object generation with model fallbacks, timeouts, retries, and throttling-- **Agent:** multi-round tool loops (`generateText`, `streamText`, `generateObject`)+- **Agent:** multi-round tool loops (`generateText`, `streamText`), plus `generateObject` / `generateObjectUntyped` for a single structured-output call with the agent's system prompt and context window (no tools are sent or run) - **Tools:** filesystem tool suite with workspace path sandboxing - **Load:** JSON model and provider catalogs, API-key gateway initialization - **Observability:** hooks, logging, and generation lifecycle events@@ -55,10 +55,12 @@ cabal run llm-simple ``` -The example loads `.env`, loads models from the catalog, wires up filesystem tools, and runs a small agent that asks about files in the workspace.+The example loads `.env`, loads one model from the catalog (`deepseek4flash`, so only `DEEPSEEK_API_KEY` is needed; change the name in `app/Main.hs` to use another, e.g. `llama_3_2` for a local Ollama), wires up filesystem tools, and runs a small agent that asks about files in the workspace.  ## Configuration +The model and provider catalogs are **trusted input**, like code: they decide where requests and API keys are sent (`baseUrl`, `baseUrlEnv`) and which environment variables are read. Do not load catalogs from an untrusted source. The same holds for `getSystemPrompt` (`LLM.Load.Utils`), which reads any file named by a `file:` value, outside any sandbox.+ ### Model catalog  Models are defined in a JSON array. Each entry maps a logical config name to a provider and model, plus runtime settings:@@ -78,8 +80,10 @@ | `thinking`        | Extended thinking effort level (optional, provider-dependent)            | | `capabilities`    | Optional object: `thinking`, `vision`, `promptCaching` (default `false`) | -A provider is only available if its API key is set (except Ollama, which is always available).+A provider is only available if its API key is set and not empty or only whitespace (except Ollama, which is always available). +Each `modelConfigName` must be unique, `maxTokens` must be positive, and `requestTimeout`, `throttleDelay`, `retryCount`, `jitterBackoff` and the prices must not be negative. Otherwise loading the catalog fails with a `LoadModelCatalogError` that names the entry, whichever model you ask for.+ Capability flags are declarations used before each fallback candidate is called: image parts require `vision`; enabled thinking requires `thinking`. Unsupported candidates fail with `UnsupportedCapability` and the next@@ -126,7 +130,8 @@ reference). Built-in providers are always available. When you load a model catalog, the loader looks for `providers.json` in the same directory; if present, its entries are merged on top of the built-ins — adding new providers or-overriding built-ins with the same `providerName`.+overriding built-ins with the same `providerName`. Within the file, each+`providerName` must be unique (`LoadProviderCatalogError` otherwise).  | Field         | Description                                                                 | | ------------- | --------------------------------------------------------------------------- |@@ -173,8 +178,10 @@  ### Agent with tools -An agent runs a loop: the model may call tools, results are fed back, and the loop continues until the model finishes or `agMaxToolRounds` is reached.+An agent runs a loop: the model may call tools, results are fed back, and the loop continues until the model finishes or `agMaxToolRounds` is reached. After the last allowed round, the agent makes one more model call that asks for a text answer; if the model still calls tools, they are not run and the result is `GErrToolExceeded`. +Configuration mistakes are logged as warnings (`onLog`) at the start of a run instead of failing it: a name in `agTools` that the tool map lacks, a repeated name, a tool named `get_history` while `agContextWindow` is set (the built-in one wins), or a non-positive `agContextWindow` (no windowing). `validateAgent` returns the same warnings.+ ```haskell import Configuration.Dotenv (defaultConfig, loadFile) import Control.Exception (IOException, catch)@@ -220,6 +227,12 @@  Set `rtReadonly = True` to omit mutating tools from the schema sent to the model and to block them at execution time. +Every request's messages are checked with `validateTurn` (for example, no tool-call parts in a user turn); an invalid turn is logged as a warning and the request is still sent. From 0.5 it will be an error.++Log messages of an agent run (`onLog`) start with `[<agName>] `; leave `agName` empty for no prefix.++Hooks are for observation only. An exception a hook throws is caught and dropped (asynchronous exceptions still propagate), so a hook cannot stop a run.+ For local debugging, `defaultDebugHooks` enables stderr logging and writes request/response JSON to `./dumps` — avoid that in production or shared environments. Each dump is a new file readable only by its owner; dumps hold prompts, tool arguments and results, and model output, and are never deleted by the library.  ### Single request (no agent loop)@@ -250,7 +263,7 @@ | `file_info`             | File metadata                           | | `find_files`            | Find files by pattern                   | | `grep`                  | Search file contents                    |-| `move_file`             | Move/rename a file                      |+| `move_file`             | Move/rename a file (never overwrites)   | | `multi_replace_in_file` | Multiple search-and-replace in one file | | `readdir`               | List directory contents                 | | `read_file_paginated`   | Read a file in pages                    |@@ -263,7 +276,7 @@  ### Filesystem sandbox -Filesystem tools enforce **workspace-relative path containment**: `..` escapes, absolute paths outside the workspace, and symlinks pointing outside are rejected. A symlink is judged by where it points, including when its target does not exist yet: writing through a dangling link that leads out of the workspace is refused and does not create the target. A link that resolves inside the workspace is followed, and the operation lands on its target. Recursive tools skip symlinks rather than following them. A path that cannot be checked for being a symlink (for example, permission denied) is treated as one.+Filesystem tools enforce **workspace-relative path containment**: `..` escapes, absolute paths outside the workspace, and symlinks pointing outside are rejected. A symlink is judged by where it points, including when its target does not exist yet: writing through a dangling link that leads out of the workspace is refused and does not create the target. A link that resolves inside the workspace is followed, and the operation lands on its target. Recursive tools skip symlinks rather than following them. A `..` that would step back out of a symlink (`link/..`) is refused, since it names a different file by name than the operating system would open. A path that cannot be checked for being a symlink (for example, permission denied) is treated as one.  Errors that reach the model name paths relative to the workspace, so the model does not learn where the workspace lives on the host. For any tool, the library drops an absolute file name from an `IOException` before it shows the error to the model. @@ -271,12 +284,14 @@  The sandbox does **not** protect against *other processes* that write to the workspace while the agent runs. A path is checked and then opened. A process that swaps a directory for a symlink between those two steps (a time-of-check/time-of-use race) can make a tool read or write outside the workspace. Hard links to files outside the workspace are not detected either. Such a process usually runs as the same user and can reach those files directly, so this only matters if it has less access than the agent. If a less-trusted process can write to the workspace, isolate the agent at the OS level (a container, or a separate user). -**Limitations (0.1.x):**+**Limitations (pre-1.0):**  - The sandbox is **path-scoped**, not kernel-level isolation. Use a dedicated, disposable workspace directory — not your home directory or a production tree. - There is no denylist for sensitive in-workspace files (`.env`, `.git/config`, etc.). Anything inside the workspace is accessible to tools the model can call.-- Read tools enforce byte caps: whole-file and edit tools use a 1 MiB limit; `read_file_paginated` accepts source files up to 10 MiB.+- Read tools enforce byte caps: whole-file and edit tools use a 1 MiB limit; `read_file_paginated` accepts source files up to 10 MiB and returns at most 100 KiB per page.+- Search and listing tools bound their work: `find_files`, `grep` and `directory_tree` look at no more than 20,000 entries per call and say so when they stop; tool output is capped at 100 KiB. - `rtReadonly` omits mutating tools from the model schema and blocks them at execution time if they are invoked anyway.+- `writefile` and the replace tools replace the file as a whole (a temporary file renamed over it), so a failed write leaves the old content. The file keeps its mode bits but gets a new inode, so hard links to it keep the old content. Concurrent edits of one file from the same process are serialized; edits from other processes are not.  ## Module layout @@ -286,11 +301,11 @@ | `LLM.Core`      | Types, gateways, provider interface, usage tracking                                                            | | `LLM.Providers` | Provider implementations (OpenAI, Claude, Gemini, Ollama, DeepSeek)                                            | | `LLM.Generate`  | Single-request generation with fallbacks (`generateTextWithFallbacks`, `streamTextWithFallbacks`, `genObject`) |-| `LLM.Agent`     | Agent loops with tool execution (`generateText`, `streamText`)                                                 |+| `LLM.Agent`     | Agent loops with tool execution (`generateText`, `streamText`); structured output without tools (`generateObject`) | | `LLM.Tools`     | Built-in filesystem tool definitions                                                                           | | `LLM.Load`      | Model and provider catalog loading, gateway init, `fsTools`                                                    | -Import `LLM` for the common surface, or import sub-modules directly for agent loops, providers, and advanced configuration. Sub-module APIs are exposed but considered experimental in 0.1.x.+Import `LLM` for the common surface, or import sub-modules directly for agent loops, providers, and advanced configuration. Sub-module APIs are exposed but considered experimental before 1.0.  **Note:** Workflow support was removed from this repo and moved elsewhere. 

@@ -1,5 +1,3 @@-{-# LANGUAGE ImpredicativeTypes #-}- module Main where  import Configuration.Dotenv (defaultConfig, loadFile)@@ -21,21 +19,17 @@   ) import LLM.Load   ( fsTools,-    loadModelsOrThrow,+    loadModelOrThrow,   )  main :: IO () main = do   loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()-  (_gpt, llama, _haiku, gemini, mistral, deepseek) <--    loadModelsOrThrow-      "./model-catalog.json"-      ("gpt_4_1", "llama_3_2", "haiku_4_5", "gemini_lite", "mistral", "deepseek4flash")--  let _models1 = ModelWithFallbacks {mwfModel = llama, mwfFallbacks = []}-      _models2 = ModelWithFallbacks {mwfModel = mistral, mwfFallbacks = []}-      _models3 = ModelWithFallbacks {mwfModel = gemini, mwfFallbacks = []}-      _models4 = ModelWithFallbacks {mwfModel = deepseek, mwfFallbacks = []}+  -- Load only the model this example uses, so only its provider's API key+  -- (here DEEPSEEK_API_KEY) must be set. Any name from model-catalog.json+  -- works, e.g. "llama_3_2" for a local Ollama with no key.+  model <- loadModelOrThrow "./model-catalog.json" "deepseek4flash"+  let models = ModelWithFallbacks {mwfModel = model, mwfFallbacks = []}    toolMap <-     fsTools "./user-workspace/"@@ -58,7 +52,7 @@             rtReadonly = False           } -  r <- generateText agent _models4 toolMap rt [UserTurn "are there any files in the current workspace?"]+  r <- generateText agent models toolMap rt [UserTurn "are there any files in the current workspace?"]   case r of     Left err -> putStrLn $ "Error: " <> show err     Right resp -> putStrLn $ "Response: " <> show resp

@@ -2,7 +2,7 @@  name:               llm-simple -version:            0.4.1.0+version:            0.4.2.0  synopsis:     Multi-provider LLM library with agent tool loops and filesystem tools@@ -139,8 +139,12 @@         LLM.Load.FsTools      other-modules:+        LLM.Core.Internal.Body         LLM.Core.SSE+        LLM.Tools.Internal.PathLock+        LLM.Tools.Internal.TextEdit         LLM.Tools.Internal.TextFile+        LLM.Tools.Internal.WalkBudget     hs-source-dirs:     src     build-depends:         aeson          >=2.0   && <2.3,@@ -239,6 +243,7 @@                         LLM.GenerateObjectSpec                         LLM.ToolUtilsSpec                         LLM.CrossProviderSpec+                        LLM.ScaleSpec                         LLM.TestKit                         LLM.WeatherTool     hs-source-dirs:     test@@ -264,4 +269,6 @@         scientific     >=0.3   && <0.4,         uuid-types     >=1.0.4 && <1.1,         vector         >=0.13  && <0.14+    if !os(windows)+        build-depends: unix >=2.8 && <2.9     build-tool-depends: hspec-discover:hspec-discover

@@ -27,6 +27,8 @@     toTool,     createGenRequest,     createGenRequestNoTools,+    validateAgent,+    toolBudgetUsedUpPrompt,   ) where 

@@ -2,6 +2,7 @@ module LLM.Agent.Generate   ( streamText,     generateText,+    toolBudgetUsedUpPrompt,   ) where @@ -14,9 +15,11 @@     executeToolsWithAbort,     ToolRoundOutcome (..),     getResolvedTools,+    agentRuntimeArgs,+    validateAgent,   ) import LLM.Agent.Types-  ( Agent (agMaxToolRounds),+  ( Agent (agMaxToolRounds, agSystemPrompt),     GenerateEventDetail (..),     RuntimeArgs (..),     ToolMap,@@ -32,6 +35,7 @@   ( generateTextWithFallbacksRotated,     streamTextWithFallbacksRotated,   )+import LLM.Generate.Logger (Hooks (..), LogLevel (Warn)) import LLM.Generate.ModelConfig   ( ModelWithFallbacks (..),   )@@ -48,7 +52,12 @@ -- On success, 'gtrNewMessages' contains only the turns produced during this -- call (assistant and tool turns), not the input conversation. -- Tool rounds continue until the model responds without tool calls or--- 'Agent.agMaxToolRounds' is exceeded.+-- 'Agent.agMaxToolRounds' rounds have run. Then one final model call asks+-- for a text answer ('toolBudgetUsedUpPrompt'); tool calls in that reply+-- are not run, and the run ends with 'GErrToolExceeded'.+--+-- The warnings of 'LLM.Agent.ToolUtils.validateAgent' go to 'onLog' at+-- the start of the run. generateText ::   Agent ->   ModelWithFallbacks ->@@ -87,6 +96,16 @@     rt     initialTurns +-- | The line appended to the system prompt for the final model call, made+-- once 'Agent.agMaxToolRounds' tool rounds have run.+toolBudgetUsedUpPrompt :: Text+toolBudgetUsedUpPrompt =+  "The tool budget for this run is used up. Answer in text; do not call tools."++-- | Result text for a tool call in the final reply, which is not run.+toolNotRunText :: Text+toolNotRunText = "Not run: tool round limit reached"+ -- | 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@@ -100,47 +119,56 @@   RuntimeArgs ->   [Turn] ->   IO (Either GenerateErrorResult GenerateTextResult)-agentLoop call agent models toolMap rt initialTurns = do+agentLoop call agent models toolMap rt0 initialTurns = do+  mapM_ (rt.rtHooks.onLog Warn) (validateAgent agent toolMap)   emitEvent rt GenerationStarted   go models initialTurns [] emptyUsage 0   where+    rt = agentRuntimeArgs agent rt0+    finalAgent =+      agent+        { agSystemPrompt =+            Just (maybe toolBudgetUsedUpPrompt (<> "\n\n" <> toolBudgetUsedUpPrompt) agent.agSystemPrompt)+        }+    -- New turns are collected newest first and reversed once at the end.+    failWith err newRev usage = do+      let errResult = GenerateErrorResult err (reverse newRev) usage+      emitEvent rt (GenerationFailed err errResult)+      pure $ Left errResult     go :: ModelWithFallbacks -> [Turn] -> [Turn] -> Usage -> Int -> IO (Either GenerateErrorResult GenerateTextResult)-    go chain currentTurns newTurnsAcc currentUsage loopCount = do+    go chain currentTurns newRev currentUsage loopCount = do       aborted <- isAbortedMaybe rt.rtAbortSignal+      let finalCall = loopCount >= agent.agMaxToolRounds       if aborted-        then do-          let errResult = GenerateErrorResult GErrAborted newTurnsAcc currentUsage-          emitEvent rt (GenerationFailed GErrAborted errResult)-          pure $ Left errResult-        else-          if loopCount >= agent.agMaxToolRounds-            then do-              let errResult = GenerateErrorResult GErrToolExceeded newTurnsAcc currentUsage-              emitEvent rt (GenerationFailed GErrToolExceeded errResult)-              pure $ Left errResult-            else do-              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 (nextChain, resp) -> do-                  let txt = resp.respText-                      toolCalls = getToolCalls resp-                      roundUsage = fromMaybe emptyUsage resp.respUsage-                      newUsage = currentUsage <> roundUsage-                      -- Authoritative ordered parts from the provider response.-                      assistantMsg = AssistantMessage resp.respContent+        then failWith GErrAborted newRev currentUsage+        else do+          result <- call (if finalCall then finalAgent else agent) chain rt currentTurns+          case result of+            Left err -> failWith err newRev currentUsage+            Right (nextChain, resp) -> do+              let txt = resp.respText+                  toolCalls = getToolCalls resp+                  roundUsage = fromMaybe emptyUsage resp.respUsage+                  newUsage = currentUsage <> roundUsage+                  -- Authoritative ordered parts from the provider response.+                  assistantMsg = AssistantMessage resp.respContent -                  case toolCalls of-                    [] -> do-                      let finalTurnsAcc = newTurnsAcc ++ [assistantMsg]-                          successResult = GenerateTextResult rt.rtGenerationId finalTurnsAcc txt newUsage-                      emitEvent rt (MessageFinalized assistantMsg)-                      emitEvent rt (GenerationFinished successResult)-                      pure $ Right successResult-                    _ -> do+              case toolCalls of+                [] -> do+                  let finalTurnsAcc = reverse (assistantMsg : newRev)+                      successResult = GenerateTextResult rt.rtGenerationId finalTurnsAcc txt newUsage+                  emitEvent rt (MessageFinalized assistantMsg)+                  emitEvent rt (GenerationFinished successResult)+                  pure $ Right successResult+                _+                  | finalCall -> do+                      -- The tool budget is used up: answer every call with a+                      -- placeholder so the history stays valid, run none.+                      let toolTurn = ToolTurn (map (`toolResult` toolNotRunText) toolCalls)+                      emitEvent rt (MessageCreated assistantMsg)+                      emitEvent rt (MessageCreated toolTurn)+                      failWith GErrToolExceeded (toolTurn : assistantMsg : newRev) newUsage+                  | otherwise -> do                       let toolContext = createToolContext agent currentTurns newUsage rt                           tools = getResolvedTools id agent toolMap rt                       emitEvent rt (MessageCreated assistantMsg)@@ -155,13 +183,11 @@                           -- that ran (they may have had side effects), a                           -- placeholder for the rest.                           let toolTurn = ToolTurn (done ++ map (`toolResult` "Aborted before execution") notRun)-                              errResult = GenerateErrorResult GErrAborted (newTurnsAcc ++ [assistantMsg, toolTurn]) newUsage                           emitEvent rt (MessageCreated toolTurn)-                          emitEvent rt (GenerationFailed GErrAborted errResult)-                          pure $ Left errResult+                          failWith GErrAborted (toolTurn : assistantMsg : newRev) newUsage                         ToolRoundCompleted toolResults -> do                           let toolTurn = ToolTurn toolResults                           emitEvent rt (MessageCreated toolTurn)                           emitEvent rt (ToolRoundFinished loopCount)                           let turnsToAdd = [assistantMsg, toolTurn]-                          go nextChain (currentTurns ++ turnsToAdd) (newTurnsAcc ++ turnsToAdd) newUsage (loopCount + 1)+                          go nextChain (currentTurns ++ turnsToAdd) (toolTurn : assistantMsg : newRev) newUsage (loopCount + 1)

@@ -1,7 +1,11 @@-module LLM.Agent.GenerateObject where+module LLM.Agent.GenerateObject+  ( generateObject,+    generateObjectUntyped,+  )+where  import Data.Aeson (Value)-import LLM.Agent.ToolUtils (createGenRequestNoTools)+import LLM.Agent.ToolUtils (agentRuntimeArgs, createGenRequestNoTools) import LLM.Agent.Types   ( Agent (..),     RuntimeArgs (..),@@ -27,7 +31,7 @@   RuntimeArgs ->   [Turn] ->   IO (Either GenerateErrorResult (t, Usage))-generateObject a m r t = genObject (createGenRequestNoTools a r t) m+generateObject a m r t = genObject (createGenRequestNoTools a (agentRuntimeArgs a r) t) m  -- | Generate a JSON 'Value' from the model using a caller-supplied schema. --@@ -40,4 +44,4 @@   [Turn] ->   Value ->   IO (Either GenerateErrorResult (Value, Usage))-generateObjectUntyped a m r t = genObjectUntyped (createGenRequestNoTools a r t) m+generateObjectUntyped a m r t = genObjectUntyped (createGenRequestNoTools a (agentRuntimeArgs a r) t) m

@@ -12,6 +12,9 @@     createGenRequest,     createGenRequestNoTools,     embedTextTool,+    safeRuntimeArgs,+    agentRuntimeArgs,+    validateAgent,   ) where @@ -19,13 +22,15 @@ import Autodocodec.Schema (jsonSchemaVia) import Control.Exception (IOException, SomeException, fromException) import Control.Monad (mfilter)+import Data.Containers.ListUtils (nubOrd)+import Data.List (nub) import Data.Aeson (FromJSON) import Data.Aeson qualified as AE import Data.Map qualified as Map import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T-import LLM.Agent.Tools.HistoryTool (historyToolTyped)+import LLM.Agent.Tools.HistoryTool (findNthUserBack, historyToolTyped) import LLM.Agent.Types   ( Agent (..),     RuntimeArgs (..),@@ -43,7 +48,7 @@   ) import LLM.Core.Usage (Usage) import LLM.Core.Utils (interruptOnAbort, toolResult, trySync)-import LLM.Generate.Logger (Hooks (..))+import LLM.Generate.Logger (Hooks (..), safeHooks, safeLLMHooks) import LLM.Generate.Types (GenRequest (..)) import LLM.Tools.FsConfig (SandboxViolation, formatSandboxViolation) import GHC.IO.Exception (IOException (ioe_filename))@@ -59,7 +64,10 @@ -- Returns 'Nothing' if it was; 'onToolError' then reports @\"Aborted\"@. executeToolInterruptible :: Maybe AbortSignal -> Hooks -> ToolContext -> [Tool Text] -> ToolCall -> IO (Maybe ToolResult) executeToolInterruptible mSig hooks ctx tools tc = case lookup tc.tcName toolMap of-  Nothing -> pure $ Just $ toolResult tc ("Unknown tool: " <> tc.tcName)+  Nothing -> do+    let msg = "Unknown tool: " <> tc.tcName+    hooks.onToolError tc.tcName msg+    pure $ Just $ toolResult tc msg   Just tool -> do     if ctx.tcRuntimeArgs.rtReadonly && not tool.toolDef.toolReadonly       then do@@ -158,24 +166,18 @@ -- | Compute the index where the visible window starts. -- The window includes the last @n@ user messages and all turns that follow -- each of them (assistant replies, tool rounds, etc.).--- Returns 0 (no windowing) when the window is 'Nothing' or the conversation--- contains fewer than @n@ user messages.+-- Returns 0 (no windowing) when the window is 'Nothing' or @'Just' n@ with+-- @n <= 0@, or when the conversation contains fewer than @n@ user messages. windowOffset :: Maybe Int -> [Turn] -> Int windowOffset Nothing _ = 0 windowOffset (Just n) conv = findNthUserFromEnd n conv  -- | Find the index of the Nth 'UserTurn' from the end of a conversation.--- Returns 0 if there are fewer than @n@ user messages.+-- Returns 0 if there are fewer than @n@ user messages, or if @n <= 0@. findNthUserFromEnd :: Int -> [Turn] -> Int-findNthUserFromEnd 0 _conv = 0-findNthUserFromEnd n conv = go (length conv - 1) n-  where-    go idx remaining-      | idx < 0 = 0-      | remaining <= 0 = idx + 1-      | otherwise = case conv !! idx of-          UserMessage _ -> go (idx - 1) (remaining - 1)-          _ -> go (idx - 1) remaining+findNthUserFromEnd n conv+  | n <= 0 = 0+  | otherwise = findNthUserBack n conv  -- | Build a 'GenRequest' from agent configuration and runtime state. --@@ -212,21 +214,75 @@           grHooks = rt.rtHooks         } +-- | The tools sent to the model: the 'Agent.agTools' names found in the+-- 'ToolMap', each once (the first occurrence counts), read-only ones only+-- when 'rtReadonly' is set, followed by the built-in @get_history@ when+-- windowing is on. A caller tool named @get_history@ is dropped while+-- windowing is on. Names missing from the map are skipped;+-- 'validateAgent' reports them. getResolvedTools :: (Text -> result) -> Agent -> ToolMap result -> RuntimeArgs -> [Tool result]-getResolvedTools embed agent toolMap rt = filterReadonlyTools rt.rtReadonly (getToolsFromMap toolMap agent.agTools) ++ fmap (embedTextTool embed) (getHistoryTool agent)+getResolvedTools embed agent toolMap rt =+  filterReadonlyTools rt.rtReadonly (getToolsFromMap toolMap callerNames)+    ++ fmap (embedTextTool embed) historyTools+  where+    historyTools = getHistoryTool agent+    callerNames+      | null historyTools = agent.agTools+      | otherwise = filter (/= historyToolName) agent.agTools  getToolsFromMap :: ToolMap result -> [Text] -> [Tool result]-getToolsFromMap toolMap toolNames = toolNames >>= lookupTool+getToolsFromMap toolMap toolNames = nubOrd toolNames >>= lookupTool   where     lookupTool name = case Map.lookup name toolMap of       Just tool -> [tool]       Nothing -> []  getHistoryTool :: Agent -> [Tool Text]-getHistoryTool agent = case agent.agContextWindow of-  Just n | n > 0 -> [toTool historyToolTyped]-  _ -> []+getHistoryTool agent+  | windowingOn agent = [toTool historyToolTyped]+  | otherwise = [] +windowingOn :: Agent -> Bool+windowingOn agent = case agent.agContextWindow of+  Just n -> n > 0+  Nothing -> False++historyToolName :: Text+historyToolName = "get_history"++-- | Warnings about an agent configuration that the agent loop works around:+--+-- * a name listed more than once in 'agTools' (only the first counts);+-- * a name in 'agTools' that the 'ToolMap' lacks (it is not sent);+-- * a caller tool named @get_history@ while windowing is on (the built-in+--   one is sent instead);+-- * @'agContextWindow' = 'Just' n@ with @n <= 0@ (no windowing).+--+-- 'LLM.Agent.generateText' and 'LLM.Agent.streamText' send each warning+-- to 'onLog' at 'LLM.Generate.Logger.Warn' once at the start of a run.+-- An empty list means none apply.+validateAgent :: Agent -> ToolMap result -> [Text]+validateAgent agent toolMap =+  [ "agTools lists " <> name <> " more than once; only the first is used"+  | name <- nub (duplicates agent.agTools)+  ]+    ++ [ "agTools lists " <> name <> ", which is not in the tool map; it is not sent to the model"+       | name <- nubOrd agent.agTools,+         not (Map.member name toolMap),+         not (name == historyToolName && windowingOn agent)+       ]+    ++ [ "agTools lists " <> historyToolName <> ", which is built in while agContextWindow is set; the caller's tool of that name is not used"+       | windowingOn agent,+         historyToolName `elem` agent.agTools,+         Map.member historyToolName toolMap+       ]+    ++ [ "agContextWindow = Just " <> T.pack (show n) <> " is not positive; the whole conversation is sent"+       | Just n <- [agent.agContextWindow],+         n <= 0+       ]+  where+    duplicates names = [n | (i, n) <- zip [0 :: Int ..] names, n `elem` take i names]+ embedTextTool :: (Text -> result) -> Tool Text -> Tool result embedTextTool embed tool =   tool@@ -249,3 +305,26 @@   | Just (ioe :: IOException) <- fromException e =       T.pack (show ioe {ioe_filename = mfilter isRelative (ioe_filename ioe)})   | otherwise = T.pack (show e)++-- | The runtime arguments with their hooks wrapped by 'safeHooks' and+-- 'safeLLMHooks', so an exception thrown by a hook cannot fail a run whose+-- side effects (a tool call, say) already happened. Applied by the agent+-- entry points.+safeRuntimeArgs :: RuntimeArgs -> RuntimeArgs+safeRuntimeArgs rt =+  rt+    { rtHooks = safeHooks rt.rtHooks,+      rtLLMHooks = safeLLMHooks rt.rtLLMHooks+    }++-- | The runtime arguments the agent entry points ('LLM.Agent.generateText',+-- 'LLM.Agent.streamText', 'LLM.Agent.generateObject',+-- 'LLM.Agent.generateObjectUntyped') run with: 'safeRuntimeArgs', and every+-- 'onLog' message prefixed with @[\<agName\>] @. An empty 'agName' adds+-- no prefix.+agentRuntimeArgs :: Agent -> RuntimeArgs -> RuntimeArgs+agentRuntimeArgs agent rt = safeRuntimeArgs rt {rtHooks = named rt.rtHooks}+  where+    named hooks+      | T.null agent.agName = hooks+      | otherwise = hooks {onLog = \lvl msg -> hooks.onLog lvl ("[" <> agent.agName <> "] " <> msg)}

@@ -1,4 +1,16 @@-module LLM.Agent.Tools.HistoryTool where+module LLM.Agent.Tools.HistoryTool+  ( HistoryToolArgs (..),+    getHistoryExecTyped,+    historyToolTyped,+    countUserTurns,+    isUserTurn,+    chunkBackward,+    findNthUserBack,+    slice,+    formatChunk,+    formatTurn,+  )+where  import Autodocodec qualified as AC import Data.Aeson (FromJSON)@@ -72,32 +84,38 @@ -- When @n <= 0@ (e.g. the visible window has no user turns), paging is -- disabled and the whole conversation is returned as a single chunk. -- This avoids an infinite loop in the page walker when @start == end@.+--+-- Turns before the first user message belong to the oldest page, or form a+-- page of their own when the user messages divide into whole pages. chunkBackward :: Int -> [Turn] -> [[Turn]] chunkBackward _ [] = [] chunkBackward n conv   | n <= 0 = [conv]-  | otherwise = reverse (go (length conv) [])+  | otherwise = reverse (oldestPage ++ map concat (chunksOf newer))   where-    go 0 acc = acc-    go end acc =-      let start = findNthUserBack n (take end conv)-          page = slice start end conv-       in if start >= end-            then page : acc -- should not happen for n > 0; refuse to loop-            else go start (page : acc)+    (leading, rest) = break isUserTurn conv+    -- Each segment is a user message and the turns up to the next one.+    segments = userSegments rest+    (oldest, newer) = splitAt (length segments `mod` n) segments+    oldestPage+      | null oldest = [leading | not (null leading)]+      | otherwise = [leading ++ concat oldest]+    chunksOf [] = []+    chunksOf xs = let (page, more) = splitAt n xs in page : chunksOf more+    userSegments [] = []+    userSegments (t : ts) = let (body, more) = break isUserTurn ts in (t : body) : userSegments more  -- | Find the start index for a page containing @n@ user messages, -- scanning backward from the end of the given prefix. -- Returns 0 if fewer than @n@ user messages remain. findNthUserBack :: Int -> [Turn] -> Int-findNthUserBack n conv = go (length conv - 1) n+findNthUserBack n conv = go (reverse (zip [0 ..] conv)) n   where-    go idx remaining-      | idx < 0 = 0+    go [] _ = 0+    go ((idx, turn) : older) remaining       | remaining <= 0 = idx + 1-      | otherwise = case conv !! idx of-          UserMessage _ -> go (idx - 1) (remaining - 1)-          _ -> go (idx - 1) remaining+      | isUserTurn turn = go older (remaining - 1)+      | otherwise = go older remaining  -- | Extract a slice [start, end) from a list. slice :: Int -> Int -> [a] -> [a]

@@ -26,21 +26,32 @@  -- | Static agent configuration shared across requests. data Agent = Agent-  { -- | Display name used in logs and debug hooks.+  { -- | Name of the agent. The agent entry points prefix every 'onLog'+    -- message of a run with @[\<agName\>] @; an empty name adds no prefix.+    -- It is not sent to the model.     agName :: Text,     -- | Optional system prompt prepended to every provider request.     agSystemPrompt :: Maybe Text,     -- | Tool names from the 'ToolMap' that may be sent to the model.     -- Only these names are exposed; the map may contain additional tools.+    -- A repeated name is sent once; a name missing from the map is not sent+    -- and logged as a warning at the start of the run.     agTools :: [Text],-    -- | Maximum number of model→tool rounds before returning 'GErrToolExceeded'.-    -- The tools of the last round run, and their results are in-    -- 'gerPartialNewMessages', but no further model call is made, so the-    -- model never sees them.+    -- | Maximum number of model→tool rounds. Once that many rounds have+    -- run, the agent makes one final model call with the tools still+    -- declared and a line appended to the system prompt asking for a text+    -- answer ('LLM.Agent.Generate.toolBudgetUsedUpPrompt'). A text reply+    -- ends the run successfully. Tool calls in that reply are not run: each+    -- gets the result @\"Not run: tool round limit reached\"@ and the run+    -- returns 'GErrToolExceeded'. So every tool that runs has its result+    -- seen by the model, and a run makes at most @agMaxToolRounds + 1@+    -- model calls. A value @<= 0@ makes only the final call.     agMaxToolRounds :: Int,     -- | When 'Just', only the last @n@ user messages (and their follow-on     -- turns) are sent to the provider. Older turns remain in 'ToolContext' and-    -- can be retrieved via the auto-injected @get_history@ tool.+    -- can be retrieved via the auto-injected @get_history@ tool, which+    -- replaces a caller tool of that name. @'Just' n@ with @n <= 0@ means no+    -- windowing (as 'Nothing'), with a warning at the start of the run.     agContextWindow :: Maybe Int   } @@ -104,7 +115,7 @@     GenerationFailed GenerateError GenerateErrorResult   | -- | A new turn was appended (assistant tool-call round or tool results).     MessageCreated Turn-  | -- | Streaming update to an in-flight assistant message (unused by default loop).+  | -- | Never emitted. Deprecated; removed in 0.5.     MessageUpdated UUID Text   | -- | The final assistant turn for a successful run.     MessageFinalized Turn@@ -113,6 +124,8 @@   | -- | Tool execution for round @n@ finished.     ToolRoundFinished Int   deriving (Show, Eq)++{-# DEPRECATED MessageUpdated "Never emitted by the agent loop; removed in 0.5. Streamed text arrives through the streamText callback." #-}  -- | Callback invoked for each 'GenerateEvent' during a run. type EventObserver = GenerateEvent -> IO ()

@@ -32,6 +32,7 @@     conversationHasImages,     coalesceAdjacentTextParts,     validateTurn,+    validateTurns,     ToolCall (..),     ToolResult (..),     LLMHooks (..),

@@ -0,0 +1,69 @@+-- | Bounded reading of provider response bodies.+--+-- A 200 body larger than 'maxResponseBodyBytes' (or a stream event larger+-- than 'maxStreamEventBytes') is signalled with 'ResponseTooLarge', which+-- is not exported from any public module. The @generic*@ functions in+-- 'LLM.Core.LLMProvider' catch it and return a 'ParseError'; the type of+-- 'LLM.Core.LLMProvider.sendRequest' stays unchanged.+module LLM.Core.Internal.Body+  ( ResponseTooLarge (..),+    responseTooLargeMessage,+    maxErrorBodyBytes,+    maxResponseBodyBytes,+    maxStreamEventBytes,+    readBodyPrefix,+    readErrorBody,+  )+where++import Control.Exception (Exception)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T++-- | A response body or stream event exceeded the given number of bytes.+newtype ResponseTooLarge = ResponseTooLarge Int+  deriving (Show)++instance Exception ResponseTooLarge++-- | The 'ParseError' text for 'ResponseTooLarge'.+responseTooLargeMessage :: ResponseTooLarge -> Text+responseTooLargeMessage (ResponseTooLarge n) =+  "response body exceeds " <> T.pack (show n) <> " bytes"++-- | Bytes of a non-200 body kept for the 'HttpError' message.+maxErrorBodyBytes :: Int+maxErrorBodyBytes = 64 * 1024++-- | Largest 200 body a non-streaming call accepts.+maxResponseBodyBytes :: Int+maxResponseBodyBytes = 32 * 1024 * 1024++-- | Largest single stream event (one SSE event, or one line of one).+maxStreamEventBytes :: Int+maxStreamEventBytes = 8 * 1024 * 1024++-- | Read at most @cap@ bytes from a body reader (empty chunk = end). Returns+-- the bytes read and whether the body went on past @cap@. Stops reading at+-- the cap, so an endless body costs at most @cap@ plus one chunk.+readBodyPrefix :: Int -> IO ByteString -> IO (ByteString, Bool)+readBodyPrefix cap readChunk = go 0 []+  where+    go n acc = do+      chunk <- readChunk+      if BS.null chunk+        then pure (BS.concat (reverse acc), False)+        else do+          let n' = n + BS.length chunk+          if n' > cap+            then pure (BS.concat (reverse (BS.take (cap - n) chunk : acc)), True)+            else go n' (chunk : acc)++-- | Read an error body up to 'maxErrorBodyBytes', with @...@ appended when+-- it was cut.+readErrorBody :: IO ByteString -> IO ByteString+readErrorBody readChunk = do+  (bs, cut) <- readBodyPrefix maxErrorBodyBytes readChunk+  pure (if cut then bs <> "..." else bs)

@@ -3,16 +3,19 @@     toGateway,     genericGenerateText,     genericStreamText,+    withoutRoutingFields,   ) where -import Control.Exception (try)-import Data.Aeson (Value, eitherDecodeStrict')+import Control.Exception (Exception, Handler (..), SomeAsyncException, SomeException, catch, catches, fromException, throwIO, try)+import Data.Aeson (Value (Object), eitherDecodeStrict')+import Data.Aeson.KeyMap qualified as KM import Data.ByteString (ByteString) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8With) import Data.Text.Encoding.Error (lenientDecode)+import LLM.Core.Internal.Body (ResponseTooLarge, responseTooLargeMessage) import LLM.Core.Types   ( ChatRequest (reqTools),     LLMError (HttpError, NetworkError, ParseError),@@ -33,7 +36,12 @@     providerImageMediaTypes :: [Text],     -- | Whether the provider accepts URL images (see 'gwImageUrlSupport').     providerImageUrlSupport :: Bool,-    -- | Build the JSON request body. Bool indicates whether streaming is requested.+    -- | Build the JSON request body. Bool indicates whether streaming is+    -- requested. A top-level @_model@ key is routing data for+    -- 'sendRequest' and 'openStream' (the Gemini provider puts the model+    -- name there, since its URL contains it); they must remove it before+    -- sending, and 'onLLMRequest' sees the body without it+    -- ('withoutRoutingFields').     buildBody :: Bool -> ChatRequest -> Value,     -- | Make a non-streaming HTTP call, returning (status code, raw response     -- body). Must not throw on a non-2xx status.@@ -57,15 +65,19 @@   }  -- | Generic streaming chat via the LLMProvider.+--+-- An exception thrown by the stream callback propagates unchanged, even an+-- 'HttpException' (the caller's own HTTP call, say): it is not the+-- provider's failure, so it is neither a 'NetworkError' nor retried. genericStreamText :: LLMProvider -> LLMHooks -> ChatRequest -> (StreamEvent -> IO ()) -> IO LLMTextResult genericStreamText p hooks r callback = do   let body = p.buildBody True r-  hooks.onLLMRequest p.providerName body-  result <- try (p.openStream body (\readChunk -> p.parseStream body readChunk callback))+  hooks.onLLMRequest p.providerName (withoutRoutingFields body)+  result <-+    unwrapCallbackFailure $+      providerCall p hooks (p.openStream body (\readChunk -> p.parseStream body readChunk (wrapCallback callback)))   case result of-    Left e -> do-      hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))-      pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+    Left e -> pure (Left e)     Right r' -> do       case r' of         Right resp -> do@@ -79,25 +91,71 @@ genericGenerateText :: LLMProvider -> LLMHooks -> ChatRequest -> IO LLMTextResult genericGenerateText p hooks r = do   let body = p.buildBody False r-  hooks.onLLMRequest p.providerName body-  result <- try (p.sendRequest body)+  hooks.onLLMRequest p.providerName (withoutRoutingFields body)+  result <- providerCall p hooks (p.sendRequest body)   case result of-    Left e -> do-      hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))-      pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+    Left e -> pure (Left e)     Right resp -> handleResponse p hooks p.parseResponse resp  -- | Generic object generation via the LLMProvider. genericGenerateObject :: LLMProvider -> LLMHooks -> Value -> ChatRequest -> IO LLMObjectResult genericGenerateObject p hooks schema r = do   let body = p.buildObjectBody r {reqTools = []} schema-  hooks.onLLMRequest p.providerName body-  result <- try (p.sendObjectRequest body)+  hooks.onLLMRequest p.providerName (withoutRoutingFields body)+  result <- providerCall p hooks (p.sendObjectRequest body)   case result of-    Left e -> do-      hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))-      pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+    Left e -> pure (Left e)     Right resp -> handleResponse p hooks p.parseObjectResponse resp++-- | The request body as it is sent: without the top-level @_model@ routing+-- key (see 'buildBody'). Other values are returned unchanged.+withoutRoutingFields :: Value -> Value+withoutRoutingFields (Object o) = Object (KM.delete "_model" o)+withoutRoutingFields v = v++-- | An exception thrown by the caller's stream callback, carried past the+-- provider's exception handlers.+newtype CallbackFailure = CallbackFailure SomeException+  deriving (Show)++instance Exception CallbackFailure++-- | Wrap whatever the callback throws in 'CallbackFailure'. Asynchronous+-- exceptions (an abort, a timeout) are thrown to the thread, not by the+-- callback, and pass through unwrapped.+wrapCallback :: (a -> IO ()) -> a -> IO ()+wrapCallback callback ev =+  callback ev `catch` \(e :: SomeException) ->+    case fromException e of+      Just (_ :: SomeAsyncException) -> throwIO e+      Nothing -> throwIO (CallbackFailure e)++-- | Rethrow the callback's own exception unchanged.+unwrapCallbackFailure :: IO a -> IO a+unwrapCallbackFailure act = do+  r <- try act+  case r of+    Left (CallbackFailure e) -> throwIO e+    Right a -> pure a++-- | Run a provider's HTTP call. An 'HttpException' becomes a 'NetworkError'+-- and a response body over the size cap a 'ParseError'; both are reported+-- to 'onLLMResponseError'. Other exceptions propagate.+providerCall :: LLMProvider -> LLMHooks -> IO a -> IO (Either LLMError a)+providerCall p hooks act = do+  r <-+    (Right <$> act)+      `catches` [ Handler $ \(e :: HttpException) ->+                    pure (Left (T.pack (show e), NetworkError (T.pack (show e)))),+                  Handler $ \(e :: ResponseTooLarge) ->+                    let msg = responseTooLargeMessage e+                     in pure (Left (msg, ParseError msg))+                ]+  case r of+    Right a -> pure (Right a)+    Left (msg, err) -> do+      hooks.onLLMResponseError p.providerName msg+      pure (Left err)  -- | Turn a non-streaming (status, raw body) into a result. A non-200 status -- is an 'HttpError' carrying the body as text, whether or not it is JSON

@@ -2,6 +2,7 @@   ( lenientConfig,     mkLenientConfig,     readAll,+    readResponseBody,     handleStreamResponse,     normalizeSchemaOpenAI,     stripJsonFences,@@ -13,6 +14,7 @@   ) where +import Control.Exception (throwIO) import Control.Retry (limitRetries) import Data.Aeson (ToJSON (toJSON), Value (..), decodeStrict', eitherDecodeStrict', encode, object) import Data.Aeson.KeyMap qualified as KM@@ -23,6 +25,12 @@ import Data.Text.Encoding.Error (lenientDecode) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TLE+import LLM.Core.Internal.Body+  ( ResponseTooLarge (..),+    maxResponseBodyBytes,+    readBodyPrefix,+    readErrorBody,+  ) import LLM.Core.Types (LLMError (EmptyResponse, HttpError, ParseError), LLMResult, LLMTextResult) import Network.HTTP.Client qualified as HC import Network.HTTP.Client.TLS (tlsManagerSettings)@@ -58,11 +66,32 @@     HC.newManager tlsManagerSettings {HC.managerResponseTimeout = HC.responseTimeoutNone} {-# NOINLINE sharedManager #-} --- | Accumulate all chunks from a BodyReader for error messages+-- | Read an error body for its message: at most 64 KiB, with @...@ as a+-- last chunk when the body went on. Reading stops there, so an endless+-- error body cannot exhaust memory. readAll :: HC.BodyReader -> IO [BS.ByteString]-readAll br = do-  chunk <- HC.brRead br-  if BS.null chunk then pure [] else (chunk :) <$> readAll br+readAll br = pure <$> readErrorBody (HC.brRead br)++-- | Read a non-streaming response as @(status, body)@, for+-- 'LLM.Core.LLMProvider.sendRequest'. Use it with req's @reqBr@ instead of+-- @bsResponse@:+--+-- > reqBr POST url (ReqBodyJson body) opts readResponseBody+--+-- A non-200 body is cut to 64 KiB (see 'readAll'). A 200 body over 32 MiB+-- throws an exception that the @generic*@ functions in+-- "LLM.Core.LLMProvider" turn into a 'ParseError'.+readResponseBody :: HC.Response HC.BodyReader -> IO (Int, BS.ByteString)+readResponseBody resp = do+  let status = statusCode (HC.responseStatus resp)+      br = HC.responseBody resp+  if status /= 200+    then (status,) <$> readErrorBody (HC.brRead br)+    else do+      (bs, cut) <- readBodyPrefix maxResponseBodyBytes (HC.brRead br)+      if cut+        then throwIO (ResponseTooLarge maxResponseBodyBytes)+        else pure (status, bs)  -- | 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

@@ -7,7 +7,8 @@ where  import Control.Applicative ((<|>))-import Control.Monad (unless)+import Control.Exception (throwIO)+import Control.Monad (unless, when) import Data.ByteString (ByteString) import Data.ByteString qualified as BS import Data.ByteString.Char8 qualified as BC@@ -15,6 +16,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE+import LLM.Core.Internal.Body (ResponseTooLarge (..), maxStreamEventBytes) import LLM.Core.Types (LLMError (..))  data SSEEvent = SSEEvent@@ -29,6 +31,10 @@ -- An event whose name or data is not valid UTF-8 is skipped, and reading -- continues so the caller can still tell whether the stream ended properly. -- The result describes the first such event, if any.+--+-- An event (or a line) larger than 'maxStreamEventBytes' throws+-- 'ResponseTooLarge', which the @generic*@ functions turn into a+-- 'ParseError'. readSSEEvents :: IO ByteString -> (SSEEvent -> IO ()) -> IO (Maybe Text) readSSEEvents readChunk callback = do   bufRef <- newIORef BS.empty@@ -46,20 +52,39 @@             writeIORef bufRef (BS.drop 1 rest)             pure (Just line')           Nothing -> do-            chunk <- readChunk-            if BS.null chunk+            -- Read until a chunk holds a newline (or the stream ends), then+            -- concatenate once, so a line split into many chunks is copied+            -- once rather than once per chunk.+            (pending, ended) <- readUntilNewline [buf] (BS.length buf)+            let buf' = BS.concat (reverse pending)+            if ended               then-                if BS.null buf+                if BS.null buf'                   then pure Nothing                   else do                     writeIORef bufRef BS.empty-                    pure (Just buf)+                    pure (Just buf')               else do-                writeIORef bufRef (buf <> chunk)+                writeIORef bufRef buf'                 readLine -      loop :: Maybe ByteString -> [ByteString] -> IO ()-      loop eventType dataLines = do+      -- Chunks read so far (newest first) and whether the stream ended.+      readUntilNewline :: [ByteString] -> Int -> IO ([ByteString], Bool)+      readUntilNewline acc size = do+        chunk <- readChunk+        if BS.null chunk+          then pure (acc, True)+          else do+            let size' = size + BS.length chunk+            when (size' > maxStreamEventBytes) $+              throwIO (ResponseTooLarge maxStreamEventBytes)+            if BC.elem '\n' chunk+              then pure (chunk : acc, False)+              else readUntilNewline (chunk : acc) size'++      -- dataSize: bytes of data collected for the current event.+      loop :: Maybe ByteString -> [ByteString] -> Int -> IO ()+      loop eventType dataLines dataSize = do         mLine <- readLine         case mLine of           Nothing ->@@ -69,15 +94,19 @@             | BS.null line -> do                 unless (null dataLines) $                   fireEvent eventType dataLines-                loop Nothing []-            | "data:" `BS.isPrefixOf` line ->-                loop eventType (stripField 5 line : dataLines)+                loop Nothing [] 0+            | "data:" `BS.isPrefixOf` line -> do+                let d = stripField 5 line+                    dataSize' = dataSize + BS.length d + 1+                when (dataSize' > maxStreamEventBytes) $+                  throwIO (ResponseTooLarge maxStreamEventBytes)+                loop eventType (d : dataLines) dataSize'             | "event:" `BS.isPrefixOf` line ->-                loop (Just (stripField 6 line)) dataLines+                loop (Just (stripField 6 line)) dataLines dataSize             | ":" `BS.isPrefixOf` line ->-                loop eventType dataLines -- comment, skip+                loop eventType dataLines dataSize -- comment, skip             | otherwise ->-                loop eventType dataLines+                loop eventType dataLines dataSize        stripField :: Int -> ByteString -> ByteString       stripField n bs =@@ -95,7 +124,7 @@         where           invalid err =             modifyIORef' badRef (<|> Just ("stream event is not valid UTF-8: " <> T.pack (show err)))-  loop Nothing []+  loop Nothing [] 0   readIORef badRef  -- | Message for a data event that should be JSON but is not, with a short

@@ -27,6 +27,7 @@     conversationHasImages,     coalesceAdjacentTextParts,     validateTurn,+    validateTurns,     opaqueForProvider,     stripForeignOpaque, @@ -236,20 +237,22 @@   where     cleaned = T.filter (not . isSpace) rawData +-- | Standard base64: a non-empty multiple of four characters from+-- @A-Z a-z 0-9 + /@, where @=@ may appear only as the last one or two. isBase64Text :: Text -> Bool isBase64Text t =-  let n = T.length t-   in n > 0-        && n `mod` 4 == 0-        && T.all isBase64Char t+  T.length t `mod` 4 == 0+    && not (T.null body)+    && T.length t - T.length body <= 2+    && T.all isBase64Char body   where+    body = T.dropWhileEnd (== '=') t     isBase64Char c =       isAsciiUpper c         || isAsciiLower c         || isDigit c         || c == '+'         || c == '/'-        || c == '='  -- | Body of one ordered content part. data PartBody@@ -467,6 +470,10 @@ -- User messages may contain text and image parts; assistant messages may -- contain text, thinking, and tool-call parts. Returns 'Left' with an error -- message when the combination is invalid. Cache hints do not affect validity.+--+-- Every generation entry point checks the request's messages with+-- 'validateTurns' and logs each invalid turn as a warning, then sends the+-- request unchanged. From 0.5 an invalid turn will be an error instead. validateTurn :: Turn -> Either Text () validateTurn (UserMessage parts) =   mapM_ userPart parts@@ -486,6 +493,11 @@     assistantPart (ContentPart (ImagePart _) _) =       Left "assistant messages may not contain image parts" validateTurn (ToolTurn _) = Right ()++-- | The invalid turns of a conversation ('validateTurn'), as (index from 0,+-- reason). Empty when every turn is valid.+validateTurns :: [Turn] -> [(Int, Text)]+validateTurns turns = [(i, reason) | (i, turn) <- zip [0 ..] turns, Left reason <- [validateTurn turn]]  -- | Keep opaque metadata only when it belongs to @provider@. opaqueForProvider :: Text -> Maybe ProviderOpaque -> Maybe ProviderOpaque

@@ -34,6 +34,7 @@     noLogger,     stderrLogger,     safeHooks,+    safeLLMHooks,     debugHooks,     defaultDebugHooks,     llmHooks,

@@ -29,6 +29,7 @@     callWithRetryTimeout,     mkRequest,     usageWithModelCost,+    safeGenRequest,     withModelFallbacksRotated,   ) import LLM.Generate.ModelConfig@@ -51,7 +52,7 @@   ModelWithFallbacks ->   IO (GenerateResult ChatResponse) generateTextWithFallbacks gr models =-  fmap snd <$> generateTextWithFallbacksRotated gr models+  fmap snd <$> generateTextWithFallbacksRotated (safeGenRequest gr) models  -- | Like 'generateTextWithFallbacks', but also returns the chain rotated so -- the model that answered comes first (see 'withModelFallbacksRotated').@@ -59,7 +60,7 @@   GenRequest ->   ModelWithFallbacks ->   IO (GenerateResult (ModelWithFallbacks, ChatResponse))-generateTextWithFallbacksRotated gr models =+generateTextWithFallbacksRotated gr0 models =   withModelFallbacksRotated gr models $ \mc -> do     r <- generateTextLLM gr mc     case r of@@ -67,6 +68,8 @@       Right resp ->         let usage = usageWithModelCost mc (fromMaybe emptyUsage resp.respUsage)          in pure $ Right resp {respUsage = Just usage}+  where+    gr = safeGenRequest gr0  -- | Like 'generateTextWithFallbacks', but streams 'StreamChunk' values -- through @onChunk@ as the provider responds.@@ -76,7 +79,7 @@   ModelWithFallbacks ->   IO (GenerateResult ChatResponse) streamTextWithFallbacks onChunk gr models =-  fmap snd <$> streamTextWithFallbacksRotated onChunk gr models+  fmap snd <$> streamTextWithFallbacksRotated onChunk (safeGenRequest gr) models  -- | Like 'streamTextWithFallbacks', but also returns the rotated chain -- (see 'withModelFallbacksRotated').@@ -85,7 +88,8 @@   GenRequest ->   ModelWithFallbacks ->   IO (GenerateResult (ModelWithFallbacks, ChatResponse))-streamTextWithFallbacksRotated onChunk gr models = do+streamTextWithFallbacksRotated onChunk gr0 models = do+  let gr = safeGenRequest gr0   emittedRef <- newIORef False   withModelFallbacksRotated gr models $ \mc -> do     r <- streamTextAttempts emittedRef onChunk gr mc@@ -96,10 +100,12 @@          in pure $ Right resp {respUsage = Just usage}  generateTextLLM :: GenRequest -> ModelConfig -> IO LLMTextResult-generateTextLLM gr mc =+generateTextLLM gr0 mc =   callWithRetryTimeout gr mc $     let request = mkRequest gr mc      in mc.mcGateway.gwGenerateText gr.grLLMHooks request+  where+    gr = safeGenRequest gr0  -- | Stream one model call with retries. 'mcRequestTimeout' bounds the time -- until the first stream event of each attempt, not the whole stream.@@ -109,7 +115,7 @@ streamTextLLM :: (StreamChunk -> IO ()) -> GenRequest -> ModelConfig -> IO LLMTextResult streamTextLLM onChunk gr mc = do   emittedRef <- newIORef False-  streamTextAttempts emittedRef onChunk gr mc+  streamTextAttempts emittedRef onChunk (safeGenRequest 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.

@@ -18,6 +18,7 @@   ( callWithRetryTimeout,     mkRequest,     usageWithModelCost,+    safeGenRequest,     withModelFallbacks,   ) import LLM.Generate.ModelConfig (ModelConfig (mcGateway), ModelWithFallbacks)@@ -44,8 +45,9 @@   GenRequest ->   ModelWithFallbacks ->   IO (Either GenerateErrorResult (t, Usage))-genObjectInternal codec gr models = do-  let jsonschema = stripBoundsAndComments $ AE.toJSON $ jsonSchemaVia codec+genObjectInternal codec gr0 models = do+  let gr = safeGenRequest gr0+      jsonschema = stripBoundsAndComments $ AE.toJSON $ jsonSchemaVia codec   res <- genObjectUntyped gr models jsonschema   case res of     Left e -> pure (Left e)@@ -67,7 +69,8 @@   ModelWithFallbacks ->   Value ->   IO (Either GenerateErrorResult (Value, Usage))-genObjectUntyped gr models schema = do+genObjectUntyped gr0 models schema = do+  let gr = safeGenRequest gr0   aborted <- isAbortedMaybe gr.grAbortSignal   if aborted     then do

@@ -8,6 +8,7 @@     withModelFallbacksRotated,     validateModelCapabilities,     llmHooks,+    safeGenRequest,   ) where @@ -29,10 +30,11 @@     ThinkingMode (..),     Turn (..),     conversationHasImages,+    validateTurns,   ) import LLM.Core.Usage (Usage (..), estimateCost) import LLM.Core.Utils (interruptOnAbort, withRetry, withTimeout)-import LLM.Generate.Logger (Hooks (..), LogLevel (..))+import LLM.Generate.Logger (Hooks (..), LogLevel (..), safeHooks, safeLLMHooks) import LLM.Generate.ModelConfig   ( ModelCapabilities (..),     ModelConfig (..),@@ -214,12 +216,19 @@ -- | Shared loop of 'withModelFallbacks' and 'withModelFallbacksRotated'. -- On success, returns whether the chain was rotated, the rotated chain and -- the result.+--+-- Before the first model is tried, each invalid turn in 'grMessages'+-- ('validateTurns') is logged at 'Warn' as @turn <n>: <reason>@ (@n@+-- counts from 0). The request is sent unchanged. runModelFallbacks ::   GenRequest ->   ModelWithFallbacks ->   (ModelConfig -> IO (Either LLMError a)) ->   IO (GenerateResult (Bool, ModelWithFallbacks, a))-runModelFallbacks gr models invokePerModel =+runModelFallbacks gr models invokePerModel = do+  mapM_+    (\(i, reason) -> gr.grHooks.onLog Warn ("turn " <> T.pack (show i) <> ": " <> reason))+    (validateTurns gr.grMessages)   case mfwToModelConfigs models of     [] -> pure $ Left GErrAllModelsFailed     modelConfigs -> loop [] modelConfigs Nothing@@ -279,4 +288,14 @@     { onLLMRequest = hooks.onRequest,       onLLMResponse = hooks.onResponse,       onLLMResponseError = hooks.onResponseError+    }++-- | The request with its hooks wrapped by 'safeHooks' and 'safeLLMHooks',+-- so an exception thrown by a hook cannot fail a call whose side effects+-- already happened. Applied by every public generation entry point.+safeGenRequest :: GenRequest -> GenRequest+safeGenRequest gr =+  gr+    { grHooks = safeHooks gr.grHooks,+      grLLMHooks = safeLLMHooks gr.grLLMHooks     }

@@ -8,6 +8,7 @@     noLogger,     stderrLogger,     safeHooks,+    safeLLMHooks,     debugHooks,     defaultDebugHooks,   )@@ -23,6 +24,7 @@ import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time.Clock.POSIX (getPOSIXTime)+import LLM.Core.Types (LLMHooks (..)) import LLM.Core.Utils (trySync) import System.Directory (createDirectoryIfMissing) import System.IO (hClose, openBinaryTempFile, stderr)@@ -132,6 +134,15 @@       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))+    }++-- | 'safeHooks' for the provider wire hooks.+safeLLMHooks :: LLMHooks -> LLMHooks+safeLLMHooks h =+  LLMHooks+    { onLLMRequest = \p v -> void (trySync (h.onLLMRequest p v)),+      onLLMResponse = \p v -> void (trySync (h.onLLMResponse p v)),+      onLLMResponseError = \p v -> void (trySync (h.onLLMResponseError p v))     }  debugHooks :: FilePath -> Hooks

@@ -79,9 +79,10 @@ data GenerateError   = -- | Provider-level failure (HTTP, network, parse, etc.).     GErrLLM LLMError-  | -- | 'Agent.agMaxToolRounds' exhausted without a final text reply. The-    -- last round's tool results are in 'gerPartialNewMessages' but were not-    -- sent to the model.+  | -- | 'Agent.agMaxToolRounds' exhausted, and the model still called tools+    -- in the final call that followed. Those calls were not run;+    -- 'gerPartialNewMessages' ends with that assistant turn and a tool turn+    -- answering each call with a placeholder, so it can be sent again as is.     GErrToolExceeded   | -- | Every model in the fallback chain failed.     GErrAllModelsFailed

@@ -1,8 +1,10 @@-module LLM.Load.FsTools where+module LLM.Load.FsTools+  ( fsTools,+    fsTools',+  )+where  import Data.Map qualified as Map--- import LLM.Tools.Readfile (readfileToolTyped)- import Data.Text (Text) import LLM.Agent.ToolUtils (embedTextTool, toTool) import LLM.Agent.Types (ToolMap)@@ -42,7 +44,6 @@         ("move_file", toTool $ moveFileToolTyped cfg),         ("multi_replace_in_file", toTool $ multiReplaceInFileToolTyped cfg),         ("readdir", toTool $ readdirToolTyped cfg),-        -- ("readfile", toTool $ readfileToolTyped cfg),         ("read_file_paginated", toTool $ readFilePaginatedToolTyped cfg),         ("remove_directory", toTool $ removeDirectoryToolTyped cfg),         ("remove_file", toTool $ removeFileToolTyped cfg),

@@ -117,7 +117,8 @@  -- | Why a provider in the catalog has no gateway. data ProviderUnavailable-  = -- | The provider's API key environment variable is not set.+  = -- | The provider's API key environment variable is not set, or is+    -- empty or only whitespace.     MissingApiKey Text   | -- | The provider's base URL cannot be parsed (the parse error).     InvalidBaseUrl Text@@ -126,12 +127,15 @@ -- | Describe why a provider is unavailable, e.g. "env var X is not set". describeProviderUnavailable :: ProviderUnavailable -> Text describeProviderUnavailable = \case-  MissingApiKey envVar -> "env var " <> envVar <> " is not set"+  MissingApiKey envVar -> "env var " <> envVar <> " is not set or is empty"   InvalidBaseUrl err -> "it has an " <> err  -- | Build the gateway for a provider, or say why it is unavailable. Never -- throws. --+-- An API key variable that is set but empty or only whitespace counts as+-- missing ('MissingApiKey').+-- -- A provider that sends an API key must use @https://@, or @http://@ to a -- loopback host (@localhost@, @127.0.0.0/8@, @::1@); otherwise the key would -- cross the network unencrypted. Such a base URL is reported as@@ -140,7 +144,11 @@ resolveGateway item = do   apiKey <- case item.apiKeyEnv of     Nothing -> pure (Right "")-    Just envVar -> maybe (Left (MissingApiKey envVar)) (Right . T.pack) <$> lookupEnv (T.unpack envVar)+    Just envVar -> do+      value <- lookupEnv (T.unpack envVar)+      pure $ case T.pack <$> value of+        Just key | not (T.null (T.strip key)) -> Right key+        _ -> Left (MissingApiKey envVar)   baseUrlText <- resolveBaseUrl item   pure $ do     key <- apiKey

@@ -1,13 +1,18 @@-module LLM.Load.ModelCatalog where+module LLM.Load.ModelCatalog+  ( ModelCatalogItem (..),+    ModelCatalogMap,+    loadModelCatalog,+  )+where -import Control.Monad.Except (ExceptT)+import Control.Monad.Except (ExceptT, liftEither) import Data.Aeson (FromJSON, ToJSON) import Data.Map (Map) import Data.Map qualified as Map import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic)-import LLM.Core.Usage (PricingInfo)+import LLM.Core.Usage (PricingInfo (..)) import LLM.Generate.ModelConfig (ModelCapabilities) import LLM.Load.Types (LoadConfigError (..)) import LLM.Load.Utils (decodeJsonFile)@@ -31,7 +36,38 @@  type ModelCatalogMap = Map Text ModelCatalogItem +-- | Read a model catalog file. Fails with 'LoadModelCatalogError' if the+-- file cannot be read or parsed, or if an entry is invalid: a+-- @modelConfigName@ used twice, @maxTokens <= 0@, or a negative+-- @requestTimeout@, @throttleDelay@, @retryCount@, @jitterBackoff@ or price.+-- The message names the entry. loadModelCatalog :: FilePath -> ExceptT LoadConfigError IO ModelCatalogMap-loadModelCatalog filePath =-  Map.fromList . fmap (\item -> (item.modelConfigName, item))-    <$> decodeJsonFile filePath (LoadModelCatalogError . T.pack)+loadModelCatalog filePath = do+  items <- decodeJsonFile filePath (LoadModelCatalogError . T.pack)+  liftEither (checkItems items)+  pure (Map.fromList [(item.modelConfigName, item) | item <- items])+  where+    checkItems :: [ModelCatalogItem] -> Either LoadConfigError ()+    checkItems items = case duplicates (map (.modelConfigName) items) of+      name : _ -> Left (LoadModelCatalogError ("duplicate modelConfigName: " <> name))+      [] -> mapM_ checkItem items+    duplicates names = [n | (i, n) <- zip [0 :: Int ..] names, n `elem` take i names]+    checkItem item = case problems item of+      [] -> Right ()+      problem : _ -> Left (LoadModelCatalogError ("model " <> item.modelConfigName <> ": " <> problem))+    problems item =+      [ "maxTokens must be positive, got " <> showT item.maxTokens+      | item.maxTokens <= 0+      ]+        ++ negativeInt "requestTimeout" item.requestTimeout+        ++ negativeInt "throttleDelay" item.throttleDelay+        ++ negativeInt "retryCount" (Just item.retryCount)+        ++ negativeInt "jitterBackoff" (Just item.jitterBackoff)+        ++ negativePrice "pricePerMillionInput" (Just item.pricing.pricePerMillionInput)+        ++ negativePrice "pricePerMillionOutput" (Just item.pricing.pricePerMillionOutput)+        ++ negativePrice "pricePerMillionCacheRead" item.pricing.pricePerMillionCacheRead+        ++ negativePrice "pricePerMillionCacheWrite" item.pricing.pricePerMillionCacheWrite+    negativeInt field v = [field <> " must not be negative, got " <> showT n | Just n <- [v], n < 0]+    negativePrice field v = [field <> " must not be negative, got " <> showT p | Just p <- [v], p < 0]+    showT :: (Show a) => a -> Text+    showT = T.pack . show

@@ -8,7 +8,7 @@   ) where -import Control.Monad.Except (ExceptT (..))+import Control.Monad.Except (ExceptT (..), throwError) import Control.Monad.IO.Class (liftIO) import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON), withText) import Data.Map (Map)@@ -112,10 +112,17 @@           baseUrlEnv = Just "OLLAMA_BASE_URL"         } +-- | Read a provider catalog file. Fails with 'LoadProviderCatalogError' if+-- the file cannot be read or parsed, or if two entries share a+-- @providerName@. loadProviderCatalog :: FilePath -> ExceptT LoadConfigError IO ProviderCatalogMap-loadProviderCatalog filePath =-  Map.fromList . fmap (\item -> (item.providerName, item))-    <$> decodeJsonFile filePath (LoadProviderCatalogError . T.pack)+loadProviderCatalog filePath = do+  items <- decodeJsonFile filePath (LoadProviderCatalogError . T.pack)+  case duplicates (map (.providerName) items) of+    name : _ -> throwError (LoadProviderCatalogError ("duplicate providerName: " <> name))+    [] -> pure (Map.fromList [(item.providerName, item) | item <- items])+  where+    duplicates names = [n | (i, n) <- zip [0 :: Int ..] names, n `elem` take i names]  -- | Load providers for a model catalog path. --

@@ -1,13 +1,19 @@-module LLM.Load.Types where+module LLM.Load.Types+  ( LoadConfigError (..),+  )+where  import Control.Exception (Exception) import Data.Text (Text)  -- | Errors raised while loading model catalogs or resolving configurations. data LoadConfigError-  = -- | The catalog file is missing or contains invalid JSON.+  = -- | The catalog file is missing, contains invalid JSON, or has an+    -- invalid entry (a repeated name, a non-positive @maxTokens@, a+    -- negative limit or price).     LoadModelCatalogError Text-  | -- | The provider catalog file is missing or contains invalid JSON.+  | -- | The provider catalog file is missing, contains invalid JSON, or+    -- has two entries with the same @providerName@.     LoadProviderCatalogError Text   | -- | A catalog entry references an unknown model or provider.     LoadModelConfigError Text

@@ -1,4 +1,8 @@-module LLM.Load.Utils where+module LLM.Load.Utils+  ( decodeJsonFile,+    getSystemPrompt,+  )+where  import Control.Exception (IOException, try) import Control.Monad.Except (ExceptT (..), MonadError (throwError))@@ -20,6 +24,13 @@     either (Left . tag) Right       <$> liftIO (eitherDecodeFileStrict filePath) +-- | Resolve a configured system prompt: a value starting with @file:@ is+-- replaced by the UTF-8 contents of the file it names, any other value is+-- returned as is.+--+-- The value is trusted input, like the model catalog: the file is read with+-- the process's permissions, from any path, outside the filesystem tools'+-- sandbox. Do not pass it text from a model or another untrusted source. getSystemPrompt :: Maybe Text -> ExceptT LoadConfigError IO (Maybe Text) getSystemPrompt mbSystemPrompt =   case mbSystemPrompt of

@@ -40,7 +40,7 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, unexpectedResponse)+import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, readResponseBody, unexpectedResponse) import LLM.Core.SSE (SSEEvent (sseData, sseEvent), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( commonImageMediaTypes,@@ -86,11 +86,7 @@     Url,     header,     https,-    bsResponse,-    req,     reqBr,-    responseBody,-    responseStatusCode,     runReq,     (/:),   )@@ -159,8 +155,7 @@       runReq lenientConfig $ do         let url = baseUrl /: "v1" /: "messages"             opts = baseOpts <> claudeAuthOpts apiKey-        resp <- req POST url (ReqBodyJson body) bsResponse opts-        pure (responseStatusCode resp, responseBody resp)+        reqBr POST url (ReqBodyJson body) opts readResponseBody  claudeAuthOpts :: Text -> Option scheme claudeAuthOpts apiKey =@@ -481,8 +476,9 @@ parseClaudeStream modelHint readChunk callback = do   blocksRef <- newIORef ([] :: [StreamBlock])   usageRef <- newIORef emptyUsage-  toolAccRef <- newIORef (Nothing :: Maybe (Text, Text, Text))-  thinkingAccRef <- newIORef (Nothing :: Maybe (Text, Maybe Text)) -- text, signature+  -- Fragments are kept newest first and joined once at content_block_stop.+  toolAccRef <- newIORef (Nothing :: Maybe (Text, Text, [Text]))+  thinkingAccRef <- newIORef (Nothing :: Maybe ([Text], Maybe Text)) -- text, signature   redactedRef <- newIORef (Nothing :: Maybe Text)   modelRef <- newIORef modelHint   errorRef <- newIORef (Nothing :: Maybe LLMError)@@ -517,8 +513,8 @@       Just "content_block_start" ->         case mv of           Just v -> case parseMaybe parseContentBlockStart v of-            Just (StartTool cid name) -> writeIORef toolAccRef (Just (cid, name, ""))-            Just StartThinking -> writeIORef thinkingAccRef (Just ("", Nothing))+            Just (StartTool cid name) -> writeIORef toolAccRef (Just (cid, name, []))+            Just StartThinking -> writeIORef thinkingAccRef (Just ([], Nothing))             Just (StartRedacted data_) -> writeIORef redactedRef (Just data_)             Just StartText -> pure ()             Nothing -> pure ()@@ -533,7 +529,7 @@               Nothing -> pure ()             case parseMaybe parseThinkingDelta v of               Just txt -> do-                modifyIORef' thinkingAccRef $ fmap (\(acc, sig) -> (acc <> txt, sig))+                modifyIORef' thinkingAccRef $ fmap (\(acc, sig) -> (txt : acc, sig))                 callback (StreamReasoningDelta txt)               Nothing -> pure ()             case parseMaybe parseSignatureDelta v of@@ -542,14 +538,14 @@               Nothing -> pure ()             case parseMaybe parseInputJsonDelta v of               Just fragment ->-                modifyIORef' toolAccRef $ fmap (\(cid, name, acc) -> (cid, name, acc <> fragment))+                modifyIORef' toolAccRef $ fmap (\(cid, name, acc) -> (cid, name, fragment : acc))               Nothing -> pure ()           Nothing -> pure ()       Just "content_block_stop" -> do         mThinking <- readIORef thinkingAccRef         case mThinking of-          Just (txt, mSig) -> do-            modifyIORef' blocksRef (StreamThinking txt mSig :)+          Just (fragments, mSig) -> do+            modifyIORef' blocksRef (StreamThinking (T.concat (reverse fragments)) mSig :)             writeIORef thinkingAccRef Nothing           Nothing -> pure ()         mRedacted <- readIORef redactedRef@@ -560,8 +556,8 @@           Nothing -> pure ()         mTool <- readIORef toolAccRef         case mTool of-          Just (cid, name, jsonStr) -> do-            case decodeToolArguments jsonStr of+          Just (cid, name, fragments) -> do+            case decodeToolArguments (T.concat (reverse fragments)) of               Just args -> do                 modifyIORef' blocksRef (StreamTool cid name args :)                 callback (StreamToolCall (mkToolCall cid name args))

@@ -18,7 +18,7 @@ import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding qualified as TLE import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, readResponseBody) import LLM.Core.Types   ( commonImageMediaTypes,     ChatRequest@@ -49,11 +49,7 @@     ReqBodyJson (ReqBodyJson),     Url,     https,-    bsResponse,-    req,     reqBr,-    responseBody,-    responseStatusCode,     runReq,     (/:),   )@@ -105,8 +101,7 @@       runReq lenientConfig $ do         let url = baseUrl /: "v1" /: "chat" /: "completions"             opts = baseOpts <> authHeader apiKey-        resp <- req POST url (ReqBodyJson body) bsResponse opts-        pure (responseStatusCode resp, responseBody resp)+        reqBr POST url (ReqBodyJson body) opts readResponseBody  -- | OpenAI-compatible body; DeepSeek uses @max_tokens@ (not @max_completion_tokens@). deepSeekBuildBody :: Bool -> ChatRequest -> Value

@@ -35,8 +35,8 @@ import Data.Text.Encoding (encodeUtf8) import Data.UUID.Types (UUID) import Data.UUID.Types qualified as UUID-import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (decodeObjectText, handleStreamResponse, lenientConfig, stripBoundsAndComments)+import LLM.Core.LLMProvider (LLMProvider (..), toGateway, withoutRoutingFields)+import LLM.Core.ProviderUtils (decodeObjectText, handleStreamResponse, lenientConfig, readResponseBody, stripBoundsAndComments) import LLM.Core.SSE (SSEEvent (sseData), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( supportedImageMediaTypes,@@ -80,11 +80,7 @@     Url,     header,     https,-    bsResponse,-    req,     reqBr,-    responseBody,-    responseStatusCode,     runReq,     (/:),     (=:),@@ -126,7 +122,7 @@                   /: "models"                   /: (model <> ":streamGenerateContent")               opts = baseOpts <> geminiAuthOpts apiKey <> "alt" =: ("sse" :: Text)-          reqBr POST url (ReqBodyJson (stripModel body)) opts $ \resp ->+          reqBr POST url (ReqBodyJson (withoutRoutingFields body)) opts $ \resp ->             handleStreamResponse resp k,       parseStream = const parseGeminiStream,       parseResponse = parseGeminiResponse,@@ -165,8 +161,7 @@                 /: "models"                 /: (model <> ":generateContent")             opts = baseOpts <> geminiAuthOpts apiKey-        resp <- req POST url (ReqBodyJson (stripModel body)) bsResponse opts-        pure (responseStatusCode resp, responseBody resp)+        reqBr POST url (ReqBodyJson (withoutRoutingFields body)) opts readResponseBody  geminiAuthOpts :: Text -> Option scheme geminiAuthOpts apiKey = header "x-goog-api-key" (encodeUtf8 apiKey)@@ -174,13 +169,9 @@ extractModel :: Value -> Text extractModel v = fromMaybe "gemini-2.0-flash" (parseMaybe (withObject "body" (.: "_model")) v) -stripModel :: Value -> Value-stripModel (Object o) = Object (KM.delete "_model" o)-stripModel v = v- parseGeminiStream :: HC.BodyReader -> (StreamEvent -> IO ()) -> IO LLMTextResult parseGeminiStream reader callback = do-  partsRef <- newIORef ([] :: [ContentPart])+  partsRef <- newIORef ([] :: [ContentPart]) -- newest first   usageRef <- newIORef Nothing   errorRef <- newIORef (Nothing :: Maybe LLMError)   stopRef <- newIORef (Nothing :: Maybe GeminiStop)@@ -200,12 +191,12 @@         case parseMaybe (parseChunkParts modelVer) v of           Just parts -> do             newParts <- mapM (assignToolId callback) parts-            modifyIORef' partsRef (++ newParts)+            modifyIORef' partsRef (reverse newParts ++)           Nothing -> pure ()         case parseMaybe parseUsageMetadata v of           Just u -> writeIORef usageRef (Just u)           Nothing -> pure ()-  parts <- readIORef partsRef+  parts <- reverse <$> readIORef partsRef   usage <- readIORef usageRef   mError <- readIORef errorRef   stop <- readIORef stopRef

@@ -13,7 +13,7 @@ import Data.Aeson.Types (Pair) import Data.Text (Text) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, readResponseBody, normalizeSchemaOpenAI) import LLM.Core.Types   ( commonImageMediaTypes,     ChatRequest@@ -32,12 +32,8 @@     ReqBodyJson (ReqBodyJson),     Url,     http,-    bsResponse,     port,-    req,     reqBr,-    responseBody,-    responseStatusCode,     runReq,     (/:),   )@@ -92,8 +88,7 @@     sendRequest body =       runReq lenientConfig $ do         let url = baseUrl /: "v1" /: "chat" /: "completions"-        resp <- req POST url (ReqBodyJson body) bsResponse baseOpts-        pure (responseStatusCode resp, responseBody resp)+        reqBr POST url (ReqBodyJson body) baseOpts readResponseBody  -- | Request body for Ollama's OpenAI-compatible endpoint. Like OpenAI's, but -- the token limit is @max_tokens@: Ollama ignores @max_completion_tokens@

@@ -45,7 +45,7 @@ import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, normalizeSchemaOpenAI, unexpectedResponse)+import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, normalizeSchemaOpenAI, readResponseBody, unexpectedResponse) import LLM.Core.SSE (SSEEvent (sseData), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( commonImageMediaTypes,@@ -91,11 +91,7 @@     Url,     header,     https,-    bsResponse,-    req,     reqBr,-    responseBody,-    responseStatusCode,     runReq,     (/:),   )@@ -160,8 +156,7 @@       runReq lenientConfig $ do         let url = baseUrl /: "v1" /: "chat" /: "completions"             opts = baseOpts <> authHeader apiKey-        resp <- req POST url (ReqBodyJson body) bsResponse opts-        pure (responseStatusCode resp, responseBody resp)+        reqBr POST url (ReqBodyJson body) opts readResponseBody  authHeader :: Text -> Option scheme authHeader apiKey@@ -417,17 +412,19 @@ parseOpenAIStream :: HC.BodyReader -> (StreamEvent -> IO ()) -> IO LLMTextResult parseOpenAIStream reader callback = do   blocksRef <- newIORef ([] :: [ContentPart])-  reasoningRef <- newIORef Nothing+  -- Reasoning fragments, newest first; joined once at the end.+  reasoningRef <- newIORef ([] :: [Text])   usageRef <- newIORef Nothing-  -- Tool calls being assembled, keyed by index: (id, name, argument text).-  toolAccRef <- newIORef (Map.empty :: Map.Map Int (Text, Text, Text))+  -- Tool calls being assembled, keyed by index: (id, name, argument+  -- fragments newest first).+  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+        forM_ (Map.elems tools) $ \(cid, name, fragments) ->+          case decodeToolArguments (T.concat (reverse fragments)) of             Just args -> do               let tc = mkToolCall cid name args               modifyIORef' blocksRef (toolCallPart tc :)@@ -451,7 +448,7 @@             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))+              modifyIORef' reasoningRef (txt :)               callback (StreamReasoningDelta txt)             _ -> pure ()           case parseMaybe parseStreamTextDelta v of@@ -472,12 +469,11 @@             Nothing -> pure ()   flushTools   textBlocks <- reverse <$> readIORef blocksRef-  mReasoning <- readIORef reasoningRef+  reasoning <- T.concat . reverse <$> readIORef reasoningRef   usage <- readIORef usageRef   let thinkingBlocks =-        [ thinkingPart (ThinkingContent (Just rc) Nothing)-          | Just rc <- [mReasoning],-            not (T.null rc)+        [ thinkingPart (ThinkingContent (Just reasoning) Nothing)+          | not (T.null reasoning)         ]       parts = thinkingBlocks ++ textBlocks   mError <- readIORef errorRef@@ -532,16 +528,16 @@ -- | 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 :: 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+          Map.insert idx (fromMaybe cid mId, fromMaybe n mName, argChunk : a) acc       | otherwise -> Map.insert (nextIndex acc) new acc     Nothing -> Map.insert idx new acc   where-    new = (fromMaybe "" mId, fromMaybe "" mName, argChunk)+    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

@@ -10,6 +10,7 @@     moveFileToolTyped,     multiReplaceInFileToolTyped,     readdirToolTyped,+    readFilePaginatedToolTyped,     readfileToolTyped,     removeDirectoryToolTyped,     removeFileToolTyped,@@ -31,6 +32,7 @@ import LLM.Tools.Grep (grepToolTyped) import LLM.Tools.MoveFile (moveFileToolTyped) import LLM.Tools.MultiReplaceInFile (multiReplaceInFileToolTyped)+import LLM.Tools.ReadFilePaginated (readFilePaginatedToolTyped) import LLM.Tools.Readdir (readdirToolTyped) import LLM.Tools.Readfile (readfileToolTyped) import LLM.Tools.RemoveDirectory (removeDirectoryToolTyped)

@@ -7,7 +7,8 @@ import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths)-import LLM.Tools.FsLimits (cheapWalkDepth, maxTreeEntries)+import LLM.Tools.FsLimits (cheapWalkDepth, maxOutputBytes, maxTreeEntries, maxVisitedEntries)+import LLM.Tools.Internal.WalkBudget (WalkBudget, budgetExhausted, budgetNote, capLines, newWalkBudget, takeEntries, utf8Length) import System.Directory   ( doesDirectoryExist,     listDirectory,@@ -38,7 +39,11 @@           <> T.pack (show cheapWalkDepth)           <> " and "           <> T.pack (show maxTreeEntries)-          <> " entries; truncation is reported in the header.",+          <> " entries shown, "+          <> T.pack (show maxVisitedEntries)+          <> " entries looked at, and "+          <> T.pack (show maxOutputBytes)+          <> " bytes of output; truncation is reported in the header.",       ttoolReadonly = True,       ttoolExecute = const (withWorkspacePaths fsConfig . directoryTreeExecTyped fsConfig)     }@@ -63,14 +68,20 @@ drawTree :: FilePath -> FilePath -> IO Text drawTree path displayRoot = do   let rootName = T.pack displayRoot-  result <- walkDir "" 0 0 path-  let header = renderHeader result.wsEntries result.wsTruncated result.wsDepthCut-  pure $ T.unlines (header ++ rootName : result.wsLines)+  budget <- newWalkBudget maxVisitedEntries+  result <- walkDir budget "" 0 0 path+  stopped <- budgetExhausted budget+  let (shown, cut) = capLines (maxOutputBytes - utf8Length rootName - 1) result.wsLines+      budgetNotes = [budgetNote budget | stopped]+      header = renderHeader (length shown) result.wsTruncated cut result.wsDepthCut budgetNotes+  pure $ T.unlines (header ++ rootName : shown)   where-    renderHeader n trunc depthCut =+    renderHeader n trunc cut depthCut extra =       let notes =             ([T.pack ("truncated at " ++ show maxTreeEntries ++ " entries") | trunc])+              ++ ([T.pack ("output truncated at " ++ show maxOutputBytes ++ " bytes") | cut])               ++ ([T.pack ("depth cut at " ++ show cheapWalkDepth) | depthCut])+              ++ extra        in ( [ "=== directory_tree | "                 <> T.pack (show n)                 <> " entr"@@ -86,8 +97,8 @@ -- emits lines for visible children, recursing into subdirectories until -- either depth or entry caps are hit. Both caps are global to the whole -- walk (entries is a running total across siblings).-walkDir :: Text -> Int -> Int -> FilePath -> IO WalkState-walkDir prefix depth entriesSoFar path+walkDir :: WalkBudget -> Text -> Int -> Int -> FilePath -> IO WalkState+walkDir budget prefix depth entriesSoFar path   | depth > cheapWalkDepth =       pure (WalkState [] entriesSoFar False True)   | entriesSoFar >= maxTreeEntries =@@ -99,12 +110,14 @@         then pure (WalkState [] entriesSoFar False False)         else do           contents <- listDirectory path-          let validContents =-                filter (\n -> n `notElem` [".", ".."] && not (isFileHidden n)) contents-              count = length validContents-          stepChildren prefix depth entriesSoFar path (zip [1 .. count] validContents) count+          validContents <-+            takeEntries budget $+              filter (\n -> n `notElem` [".", ".."] && not (isFileHidden n)) contents+          let count = length validContents+          stepChildren budget prefix depth entriesSoFar path (zip [1 .. count] validContents) count  stepChildren ::+  WalkBudget ->   Text ->   Int ->   Int ->@@ -112,9 +125,9 @@   [(Int, FilePath)] ->   Int ->   IO WalkState-stepChildren _ _ entries _ [] _ =+stepChildren _ _ _ entries _ [] _ =   pure (WalkState [] entries False False)-stepChildren prefix depth entries dir ((idx, name) : rest) count+stepChildren budget prefix depth entries dir ((idx, name) : rest) count   | entries >= maxTreeEntries =       pure (WalkState [] entries True False)   | otherwise = do@@ -124,8 +137,8 @@           currentLine = prefix <> connector <> textName           newPrefix = prefix <> if isLast then "    " else "│   "           entries' = entries + 1-      sub <- walkDir newPrefix (depth + 1) entries' (dir </> name)-      siblings <- stepChildren prefix depth sub.wsEntries dir rest count+      sub <- walkDir budget newPrefix (depth + 1) entries' (dir </> name)+      siblings <- stepChildren budget prefix depth sub.wsEntries dir rest count       pure         WalkState           { wsLines = currentLine : sub.wsLines ++ siblings.wsLines,

@@ -13,7 +13,7 @@ import Data.Time.Clock (UTCTime) import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths)+import LLM.Tools.FsConfig (FsConfig (..), SandboxViolation, sandboxPath, sandboxSymlink, withWorkspacePaths) import LLM.Tools.Internal.TextFile (readLenient, withTextHandle) import System.Directory   ( Permissions (..),@@ -24,8 +24,8 @@     getModificationTime,     getPermissions,     listDirectory,-    pathIsSymbolicLink,   )+import System.FilePath (dropTrailingPathSeparator, equalFilePath, makeRelative) import System.IO (Handle, IOMode (ReadMode), withBinaryFile)  -- | Skip line-counting on files larger than this (bytes). For large text@@ -60,7 +60,8 @@       ttoolDescription =         "Get metadata about a file or directory at a workspace-relative path. "           <> "For files: kind (text/binary), size in bytes, line count (text files up to 5 MB), "-          <> "permissions, modification time, and whether it is a symbolic link. "+          <> "permissions, modification time. "+          <> "For a symbolic link: the link and where it points (it is not followed). "           <> "For directories: entry count (visible vs. total), permissions, modification time. "           <> "Reports clearly if the path does not exist. "           <> "Use this before read_file_paginated to decide whether a file is worth reading.",@@ -71,20 +72,51 @@ execute :: FsConfig -> FileInfoToolArgs -> IO Text execute cfg args = do   let rel = args._fiPath-  resolved <- sandboxPath cfg (T.unpack rel)-  exists <- doesPathExist resolved-  if not exists-    then pure $ "Error: path does not exist: " <> rel-    else do+  -- 'sandboxPath' follows links, so look for one first, as remove_file does.+  link <- sandboxSymlink cfg (T.unpack rel)+  case link of+    Just _ -> renderLinkInfo cfg rel+    Nothing -> do+      resolved <- sandboxPath cfg (T.unpack rel)+      exists <- doesPathExist resolved+      if not exists+        then pure $ "Error: path does not exist: " <> rel+        else do+          isDir <- doesDirectoryExist resolved+          isFile <- doesFileExist resolved+          perms <- safeGetPermissions resolved+          mtime <- safeGetModificationTime resolved+          case (isDir, isFile) of+            (True, _) -> renderDirInfo rel resolved perms mtime+            (_, True) -> renderFileInfo rel resolved perms mtime+            _ -> pure $ "Error: path is neither a regular file nor a directory: " <> rel++-- | A symbolic link and where it points, without following it further.+-- The target is shown relative to the workspace; a target outside it is+-- not named, so no host path is shown.+renderLinkInfo :: FsConfig -> Text -> IO Text+renderLinkInfo cfg rel = do+  target <- try (sandboxPath cfg (T.unpack rel))+  targetText <- case target of+    Left (_ :: SandboxViolation) -> pure "outside the workspace"+    Right resolved -> do       isDir <- doesDirectoryExist resolved       isFile <- doesFileExist resolved-      isLink <- safePathIsSymbolicLink resolved-      perms <- safeGetPermissions resolved-      mtime <- safeGetModificationTime resolved-      case (isDir, isFile) of-        (True, _) -> renderDirInfo rel resolved isLink perms mtime-        (_, True) -> renderFileInfo rel resolved isLink perms mtime-        _ -> pure $ "Error: path is neither a regular file nor a directory: " <> rel+      let kind+            | isDir = "directory"+            | isFile = "file"+            | otherwise = "does not exist"+      pure $ T.pack (workspaceRelative resolved) <> " (" <> kind <> ")"+  pure $+    T.unlines+      [ "=== " <> rel <> " | symbolic link ===",+        "target: " <> targetText+      ]+  where+    base = dropTrailingPathSeparator cfg.fsBasePath+    workspaceRelative p+      | equalFilePath base p = "."+      | otherwise = makeRelative base p  -- --------------------------------------------------------------------------- -- File rendering@@ -93,11 +125,10 @@ renderFileInfo ::   Text ->   FilePath ->-  Bool ->   Maybe Permissions ->   Maybe Text ->   IO Text-renderFileInfo rel resolved isLink perms mtime = do+renderFileInfo rel resolved perms mtime = do   size <- safeGetFileSize resolved   -- 'Nothing' if the file looks binary or cannot be read.   sniffed <-@@ -110,9 +141,7 @@       header =         "=== "           <> rel-          <> " | file"-          <> (if isLink then " (symlink)" else "")-          <> " ==="+          <> " | file ==="       lns =         [ "kind: " <> if isBin then "binary" else "text",           "size: " <> maybe "unknown" (\n -> T.pack (show n) <> " bytes") size,@@ -136,23 +165,22 @@ renderDirInfo ::   Text ->   FilePath ->-  Bool ->   Maybe Permissions ->   Maybe Text ->   IO Text-renderDirInfo rel resolved isLink perms mtime = do+renderDirInfo rel resolved perms mtime = do+  -- Listing the directory is unavoidable (streaming it needs a POSIX-only+  -- API), but counting stops at the cap.   entries <- safeListDirectory resolved-  let total = length entries-      visible = length (filter (not . isHidden) entries)+  let total = length (take maxDirEntriesCounted entries)+      visible = length (take maxDirEntriesCounted (filter (not . isHidden) entries))       countText n         | n >= maxDirEntriesCounted = T.pack (show maxDirEntriesCounted) <> "+"         | otherwise = T.pack (show n)       header =         "=== "           <> rel-          <> " | directory"-          <> (if isLink then " (symlink)" else "")-          <> " ==="+          <> " | directory ==="       lns =         [ "entries (visible): " <> countText visible,           "entries (total):   " <> countText total,@@ -199,13 +227,6 @@ safeGetPermissions p = do   r <- try (getPermissions p) :: IO (Either IOException Permissions)   pure (eitherToMaybe r)--safePathIsSymbolicLink :: FilePath -> IO Bool-safePathIsSymbolicLink p = do-  r <- try (pathIsSymbolicLink p) :: IO (Either IOException Bool)-  pure $ case r of-    Right b -> b-    Left _ -> False  safeListDirectory :: FilePath -> IO [FilePath] safeListDirectory p = do

@@ -14,7 +14,8 @@ import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths)-import LLM.Tools.FsLimits (cheapWalkDepth)+import LLM.Tools.FsLimits (cheapWalkDepth, maxOutputBytes, maxVisitedEntries)+import LLM.Tools.Internal.WalkBudget (WalkBudget, budgetExhausted, budgetNote, capLines, newWalkBudget, takeEntries) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>)) @@ -36,12 +37,15 @@ data EntryFilter = AnyEntry | FileOnly | DirectoryOnly   deriving (Eq, Show) -parseEntryFilter :: Text -> EntryFilter+-- | 'Nothing' for an unknown kind.+parseEntryFilter :: Text -> Maybe EntryFilter parseEntryFilter t = case T.toLower (T.strip t) of-  "file" -> FileOnly-  "directory" -> DirectoryOnly-  "dir" -> DirectoryOnly-  _ -> AnyEntry+  "file" -> Just FileOnly+  "directory" -> Just DirectoryOnly+  "dir" -> Just DirectoryOnly+  "any" -> Just AnyEntry+  "" -> Just AnyEntry+  _ -> Nothing  data FindFilesToolArgs = FindFilesToolArgs   { _ffPattern :: Text,@@ -94,7 +98,10 @@           <> "Skips hidden entries unless 'includeHidden' is true. "           <> "Use 'type' to restrict to files or directories. "           <> "Output is capped at 'maxResults' (default 200, hard cap 2000); "-          <> "the header reports whether results were truncated and how many entries were scanned.",+          <> "the header reports whether results were truncated and how many entries were scanned. "+          <> "A search looks at most "+          <> T.pack (show maxVisitedEntries)+          <> " entries and says so if it stopped there.",       ttoolReadonly = True,       ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }@@ -103,20 +110,26 @@ execute cfg args = do   let rel = T.unpack args._ffPath       pat = args._ffPattern-      kind = parseEntryFilter args._ffType       includeHidden = args._ffIncludeHidden-      cap = max 1 (min maxResultsCap args._ffMaxResults)-  if T.null pat-    then pure "Error: pattern must be non-empty"-    else do+      cap = min maxResultsCap args._ffMaxResults+  case parseEntryFilter args._ffType of+    _ | T.null pat -> pure "Error: pattern must be non-empty"+    Nothing ->+      pure $ "Error: unknown type " <> T.pack (show args._ffType) <> "; use 'file', 'directory' or 'any'"+    _ | args._ffMaxResults <= 0 ->+      pure $ "Error: maxResults must be positive, got " <> T.pack (show args._ffMaxResults)+    Just kind -> do       resolved <- sandboxPath cfg rel       isDir <- doesDirectoryExist resolved       if not isDir         then pure $ "Error: path is not a directory: " <> args._ffPath         else do           let segs = splitGlob pat-          (matches, scanned, truncated) <- walk resolved includeHidden kind segs cap-          pure $ renderResults args._ffPath pat matches scanned truncated+          budget <- newWalkBudget maxVisitedEntries+          (matches, scanned, truncated) <- walk budget resolved includeHidden kind segs cap+          stopped <- budgetExhausted budget+          let note = if stopped then Just (budgetNote budget) else Nothing+          pure $ renderResults args._ffPath pat matches scanned truncated note  -- --------------------------------------------------------------------------- -- Filesystem walk@@ -125,13 +138,14 @@ -- | Result of the walk: matched relative paths (sorted within each directory), -- count of entries inspected, and whether the cap truncated the output. walk ::+  WalkBudget ->   FilePath ->   Bool ->   EntryFilter ->   [Text] ->   Int ->   IO ([FilePath], Int, Bool)-walk root includeHidden kind pat cap = do+walk budget root includeHidden kind pat cap = do   WalkState acc _ scanned truncated <- go root [] 0 (WalkState [] 0 0 False)   pure (reverse acc, scanned, truncated)   where@@ -146,7 +160,8 @@                 if includeHidden                   then entries                   else filter (not . isFileHidden) entries-          step visible dir relSegs depth st+          allowed <- takeEntries budget visible+          step allowed dir relSegs depth st      step [] _ _ _ st = pure st     step (name : rest) dir relSegs depth (WalkState acc n scanned truncated)@@ -234,9 +249,12 @@ -- Rendering -- --------------------------------------------------------------------------- -renderResults :: Text -> Text -> [FilePath] -> Int -> Bool -> Text-renderResults rootDisplay pat matches scanned truncated =-  let header =+renderResults :: Text -> Text -> [FilePath] -> Int -> Bool -> Maybe Text -> Text+renderResults rootDisplay pat allMatches scanned truncated0 note =+  let (body, cut) = capLines maxOutputBytes (map T.pack allMatches)+      matches = body+      truncated = truncated0 || cut+      header =         "=== find_files "           <> T.pack (show pat)           <> " in "@@ -247,7 +265,10 @@           <> T.pack (show scanned)           <> " entr"           <> (if scanned == 1 then "y" else "ies")-          <> (if truncated then " | truncated (raise maxResults to see more)" else "")+          <> ( if cut+                 then " | output truncated at " <> T.pack (show maxOutputBytes) <> " bytes"+                 else if truncated then " | truncated (raise maxResults to see more)" else ""+             )+          <> maybe "" (" | " <>) note           <> " ==="-      body = map T.pack matches    in T.unlines (header : body)

@@ -1,3 +1,6 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ExplicitNamespaces #-}+ module LLM.Tools.FsConfig   ( FsConfig (..),     SandboxViolation (..),@@ -14,23 +17,32 @@ where  import Control.Exception (Exception, IOException, handle, throwIO, try)-import Control.Monad (when)-import Data.List (foldl')+import Control.Monad (foldM, when) import Data.Text (Text) import Data.Text qualified as T import System.Directory (canonicalizePath, createDirectoryIfMissing, doesPathExist, pathIsSymbolicLink) import Foreign.C.Error (Errno (..), eNOTDIR) import GHC.IO.Exception (IOException (ioe_errno, ioe_filename))-import System.IO.Error (isDoesNotExistError)-import System.FilePath (addTrailingPathSeparator, dropTrailingPathSeparator, equalFilePath, isRelative, joinPath, normalise, splitDirectories, splitFileName, takeDirectory, (</>))+import System.IO.Error (ioeSetErrorString, isDoesNotExistError, mkIOError)+import GHC.IO.Exception (IOErrorType (InvalidArgument))+import System.FilePath (addTrailingPathSeparator, dropTrailingPathSeparator, equalFilePath, isAbsolute, isRelative, joinPath, normalise, splitDirectories, splitFileName, takeDirectory, (</>))  -- | Configuration for file-system tools. -- 'fsBasePath' must be a canonical absolute path (use 'mkFsConfig').+--+-- The @FsConfig@ data constructor is deprecated: build the configuration+-- with 'mkFsConfig', which canonicalizes the path. From 0.5 the constructor+-- is no longer exported. GHC 9.10 and later warn about its use; the type+-- itself is not deprecated. newtype FsConfig = FsConfig   { fsBasePath :: FilePath   }   deriving (Show) +#if __GLASGOW_HASKELL__ >= 910+{-# DEPRECATED data FsConfig "Use mkFsConfig, which canonicalizes the base path. The FsConfig constructor is not exported from 0.5 on." #-}+#endif+ data SandboxViolation = SandboxViolation   { svAttempted :: FilePath,     svBasePath :: FilePath@@ -86,11 +98,12 @@ -- A symlink counts as existing even when its target does not, so a -- dangling link is resolved to that target and judged by where it -- points rather than appended as if it were an ordinary new file.--- Throws 'SandboxViolation' on escape attempts.+-- Throws 'SandboxViolation' on escape attempts, and an 'IOException' for a+-- @..@ that would step back out of a symbolic link (see 'collapseDots'). sandboxPath :: FsConfig -> FilePath -> IO FilePath sandboxPath cfg relPath = do   let base = cfg.fsBasePath-      candidate = collapseDots (normalise (base </> relPath))+  candidate <- collapseDots (normalise (base </> relPath))   canonical <- canonicalizeExisting candidate   let baseComps = splitDirectories (dropTrailingPathSeparator base)       canonComps = splitDirectories canonical@@ -121,8 +134,8 @@ -- lie anywhere, since acting on the link itself never touches it. sandboxSymlink :: FsConfig -> FilePath -> IO (Maybe FilePath) sandboxSymlink cfg relPath = do-  let candidate = collapseDots (normalise (cfg.fsBasePath </> relPath))-      (parentRaw, name) = splitFileName candidate+  candidate <- collapseDots (normalise (cfg.fsBasePath </> relPath))+  let (parentRaw, name) = splitFileName candidate   isLink <- if null name then pure False else isSymlink candidate   if not isLink     then pure Nothing@@ -213,15 +226,33 @@   createDirectoryIfMissing True (takeDirectory resolved)   pure resolved --- | Resolve @.@ and @..@ in a normalized absolute path--- without touching the filesystem.-collapseDots :: FilePath -> FilePath-collapseDots = joinPath . reverse . foldl' step [] . splitDirectories+-- | Resolve @.@ and @..@ in a normalized absolute path.+--+-- @..@ is resolved by name: @a/b/..@ becomes @a@. That matches the+-- operating system only while @b@ is not a symbolic link; for a link the+-- OS goes to the parent of the link's target instead. So a @..@ that would+-- remove a symbolic link component throws an 'IOException' naming the link+-- (one @lstat@ per @..@). A @..@ at the root is ignored.+collapseDots :: FilePath -> IO FilePath+collapseDots path = case splitDirectories path of+  root : comps | isAbsolute root -> (root </>) . joinPath . reverse <$> foldM (step root) [] comps+  comps -> joinPath . reverse <$> foldM (step "") [] comps   where-    step acc "." = acc-    step (_ : rest) ".." = rest-    step acc ".." = acc -- at root, ignore-    step acc x = x : acc+    step _ acc "." = pure acc+    step _ [] ".." = pure []+    step root acc@(_ : rest) ".." = do+      let current = root </> joinPath (reverse acc)+      link <- isSymlink current+      when link $ throwIO (dotDotAfterLink current)+      pure rest+    step _ acc x = pure (x : acc)++-- | The error for a @..@ that follows a symbolic link.+dotDotAfterLink :: FilePath -> IOException+dotDotAfterLink link =+  ioeSetErrorString+    (mkIOError InvalidArgument "sandboxPath" Nothing (Just link))+    "'..' after a symbolic link is ambiguous; use a path without it"  isFileHidden :: [Char] -> Bool isFileHidden path = case path of

@@ -21,16 +21,20 @@     maxReadBytes,     maxPaginatedFileBytes,     maxTreeEntries,+    maxVisitedEntries,+    maxOutputBytes,     binarySniffBytes,     detectBinary,     readBoundedTextFile,     readBoundedUtf8File,     readTextFileLenient,     writeUtf8File,+    atomicWriteWith,   ) where -import Control.Exception (IOException, try)+import Control.Exception (IOException, bracketOnError, try)+import Control.Monad (when) import Data.ByteString qualified as BS import Data.Text (Text) import Data.Text.Encoding (decodeUtf8With, encodeUtf8)@@ -40,7 +44,15 @@     readBoundedTextWith,     readBoundedUtf8With,   )-import System.IO (IOMode (ReadMode), withBinaryFile)+import System.Directory (copyPermissions, doesFileExist, removeFile, renameFile)+import System.FilePath (splitFileName)+import System.IO+  ( Handle,+    IOMode (ReadMode),+    hClose,+    openBinaryTempFileWithDefaultPermissions,+    withBinaryFile,+  )  -- | Maximum directory depth for traversals that only stat entries. cheapWalkDepth :: Int@@ -70,6 +82,19 @@ maxTreeEntries :: Int maxTreeEntries = 2000 +-- | Budget of directory entries one call of a walking tool (@find_files@,+-- @grep@, @directory_tree@) may look at, counted as directories are+-- listed. A walk that runs out stops and says so in its output, so a large+-- tree costs a bounded amount of work even when nothing matches.+maxVisitedEntries :: Int+maxVisitedEntries = 20000++-- | Cap on the bytes of text one filesystem tool result returns (a page of+-- @read_file_paginated@, the lines of a listing or search). Output past it+-- is cut and the cut is reported.+maxOutputBytes :: Int+maxOutputBytes = 100 * 1024 -- 100 KiB+ -- | A NUL byte in the first 'binarySniffBytes' is a robust, cheap binary -- heuristic. On I/O failure the file is treated as binary (the caller -- should fail closed rather than read an unreadable file as text).@@ -98,6 +123,45 @@ readTextFileLenient :: FilePath -> IO Text readTextFileLenient path = decodeUtf8With lenientDecode <$> BS.readFile path --- | Write text as UTF-8, independent of the locale.+-- | Write text as UTF-8, independent of the locale. The file is replaced+-- atomically ('atomicWriteWith'). writeUtf8File :: FilePath -> Text -> IO ()-writeUtf8File path = BS.writeFile path . encodeUtf8+writeUtf8File path t = atomicWriteWith path (`BS.hPut` encodeUtf8 t)++-- | Replace the file at @path@ with what the action writes, so that readers+-- see either the old content or the new content, never a partial file.+--+-- The action writes to a temporary file in the same directory, which is+-- then closed and renamed over @path@. If @path@ already exists, its mode+-- is copied to the new file first ('copyPermissions': the full mode on+-- POSIX, the read-only attribute on Windows); a new file gets the default+-- mode (@0666@ minus the umask). On any exception the temporary file is+-- removed and the exception rethrown, leaving @path@ unchanged.+--+-- Limits:+--+-- * The data is flushed to the operating system but not @fsync@ed, so a+--   power loss shortly after the write can still lose it.+-- * The file gets a new inode. A hard link to the old file keeps the old+--   content, and ACLs and extended attributes are not copied. The new file+--   is owned by the user running the process.+-- * On Windows, the rename fails while another process has @path@ open.+atomicWriteWith :: FilePath -> (Handle -> IO ()) -> IO ()+atomicWriteWith path write =+  bracketOnError+    (openBinaryTempFileWithDefaultPermissions dir ("." <> name <> ".tmp"))+    ( \(tmp, h) -> do+        _ <- try @IOException (hClose h)+        _ <- try @IOException (removeFile tmp)+        pure ()+    )+    ( \(tmp, h) -> do+        write h+        hClose h+        exists <- doesFileExist path+        when exists $ copyPermissions path tmp+        renameFile tmp path+    )+  where+    (dirRaw, name) = splitFileName path+    dir = if null dirRaw then "." else dirRaw

@@ -6,6 +6,8 @@  import Autodocodec qualified as AC import Control.Exception (IOException, try)+import Control.Monad (unless)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef) import Data.Aeson (FromJSON) import Data.List (sort) import Data.Text (Text)@@ -13,8 +15,9 @@ import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths)-import LLM.Tools.FsLimits (expensiveWalkDepth)+import LLM.Tools.FsLimits (expensiveWalkDepth, maxOutputBytes, maxVisitedEntries) import LLM.Tools.Internal.TextFile (readLenient, withTextHandle)+import LLM.Tools.Internal.WalkBudget (WalkBudget, budgetExhausted, budgetNote, capLines, newWalkBudget, takeEntries) import System.Directory   ( doesDirectoryExist,     doesFileExist,@@ -98,7 +101,10 @@           <> "Skips hidden files, binary files, and files larger than 1 MB. "           <> "Use 'extensions' to restrict by file type (e.g. [\"hs\"]). "           <> "Output is capped at 'maxResults' lines (default 50, hard cap 500); "-          <> "the header reports whether results were truncated and how many files were scanned.",+          <> "the header reports whether results were truncated and how many files were scanned. "+          <> "A search looks at most "+          <> T.pack (show maxVisitedEntries)+          <> " entries and stops at maxResults; then the file count is shown as 'N+'.",       ttoolReadonly = True,       ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }@@ -109,9 +115,11 @@       pat = args._grepPattern       ci = args._grepCaseInsensitive       exts = normalizeExtensions args._grepExtensions-      cap = max 1 (min maxResultsCap args._grepMaxResults)+      cap = min maxResultsCap args._grepMaxResults   if T.null pat     then pure "Error: pattern must be non-empty"+    else if args._grepMaxResults <= 0+    then pure $ "Error: maxResults must be positive, got " <> T.pack (show args._grepMaxResults)     else do       resolved <- sandboxPath cfg rel       isDir <- doesDirectoryExist resolved@@ -130,49 +138,73 @@                   <> T.pack (show maxFileSizeBytes)                   <> "-byte cap for grep."             else do-              files <--                if isFile-                  then pure [(resolved, takeFileName resolved)]-                  else collectFiles resolved "" 0 exts-              (matches, scanned, truncated) <- searchFiles files pat ci cap-              pure $ renderResults args._grepPath pat matches scanned truncated+              budget <- newWalkBudget maxVisitedEntries+              st <- newIORef (GrepState [] 0 0 False)+              let search = searchFile st pat ci cap+              if isFile+                then search resolved (takeFileName resolved)+                else walkDir budget st search exts resolved "" 0+              GrepState matches _ scanned capHit <- readIORef st+              stopped <- budgetExhausted budget+              pure $+                renderResults+                  args._grepPath+                  pat+                  (reverse matches)+                  scanned+                  ((capHit && not isFile) || stopped)+                  capHit+                  (if stopped then Just (budgetNote budget) else Nothing)  -- | Lowercase and strip leading dots so callers can pass "hs" or ".hs". normalizeExtensions :: [Text] -> [Text] normalizeExtensions = map (T.toLower . T.dropWhile (== '.')) --- | Recursively collect candidate files under a directory, respecting--- depth, hidden-file, extension, and size limits. Order is stable--- (directories sorted) so output is deterministic. Each file comes with--- its path relative to the search root, built from the names walked, so--- no host path is shown.-collectFiles :: FilePath -> FilePath -> Int -> [Text] -> IO [(FilePath, FilePath)]-collectFiles _ _ depth _ | depth > maxDepth = pure []-collectFiles dir display depth exts = do-  entries <- sort <$> safeListDirectory dir-  let visible = filter (not . isFileHidden) entries-  results <- mapM (visit dir display depth exts) visible-  pure (concat results)+-- | Matches so far (newest first), their count, files searched, and+-- whether the walk stopped because 'maxResults' was reached.+data GrepState = GrepState [Match] Int Int Bool -visit :: FilePath -> FilePath -> Int -> [Text] -> FilePath -> IO [(FilePath, FilePath)]-visit parent display depth exts name = do-  let full = parent </> name-      fullDisplay = display </> name-  -- Skip symlinks to prevent traversal out of the sandbox.-  isLink <- isSymlink full-  if isLink-    then pure []-    else do-      isDir <- doesDirectoryExist full-      if isDir-        then collectFiles full fullDisplay (depth + 1) exts-        else do-          isFile <- doesFileExist full-          if isFile && extensionAllowed exts name-            then do-              ok <- isSizeOk full-              pure [(full, fullDisplay) | ok]-            else pure []+-- | Walk a directory and search each candidate file as it is found,+-- respecting depth, hidden-file, extension and size limits and the entry+-- budget. Stops once 'maxResults' is reached. Order is stable (entries+-- sorted) so output is deterministic. Each file is shown by its path+-- relative to the search root, built from the names walked, so no host+-- path is shown.+walkDir ::+  WalkBudget ->+  IORef GrepState ->+  (FilePath -> FilePath -> IO ()) ->+  [Text] ->+  FilePath ->+  FilePath ->+  Int ->+  IO ()+walkDir budget st search exts = go+  where+    go dir display depth+      | depth > maxDepth = pure ()+      | otherwise = do+          entries <- sort <$> safeListDirectory dir+          allowed <- takeEntries budget (filter (not . isFileHidden) entries)+          mapM_ (visit dir display depth) allowed+    visit parent display depth name = do+      GrepState _ _ _ capHit <- readIORef st+      unless capHit $ do+        let full = parent </> name+            fullDisplay = display </> name+        -- Skip symlinks to prevent traversal out of the sandbox.+        isLink <- isSymlink full+        unless isLink $ do+          isDir <- doesDirectoryExist full+          if isDir+            then go full fullDisplay (depth + 1)+            else do+              isFile <- doesFileExist full+              ok <-+                if isFile && extensionAllowed exts name+                  then isSizeOk full+                  else pure False+              if ok then search full fullDisplay else pure ()  extensionAllowed :: [Text] -> FilePath -> Bool extensionAllowed [] _ = True@@ -197,35 +229,23 @@     Right xs -> pure xs     Left _ -> pure [] --- | Search the given files for a literal pattern. Stops collecting matches--- once the cap is reached but keeps scanning the remaining files so the--- 'scanned' count reflects the full sweep. Returns (matches, files scanned,--- truncated?).-searchFiles ::-  [(FilePath, FilePath)] ->-  Text ->-  Bool ->-  Int ->-  IO ([Match], Int, Bool)-searchFiles files pat ci cap = go files [] 0 False+-- | Search one file and add its matches, up to the cap. Binary and+-- unreadable files count as searched but give no matches.+searchFile :: IORef GrepState -> Text -> Bool -> Int -> FilePath -> FilePath -> IO ()+searchFile st pat ci cap f display = do+  r <-+    try (withTextHandle (withBinaryFile f ReadMode) readLenient) ::+      IO (Either IOException (Maybe Text))+  let ms = case r of+        Right (Just content) -> matchLines display content needle ci+        _ -> []+  modifyIORef' st $ \(GrepState acc n scanned _) ->+    let remaining = cap - n+        taken = take remaining ms+        n' = n + length taken+     in GrepState (reverse taken ++ acc) n' (scanned + 1) (n' >= cap)   where     needle = if ci then T.toLower pat else pat-    go [] acc scanned truncated = pure (reverse acc, scanned, truncated)-    go ((f, display) : rest) acc scanned truncated-      | length acc >= cap = go rest acc (scanned + 1) True-      | otherwise = do-          -- Binary and unreadable files are skipped.-          r <--            try (withTextHandle (withBinaryFile f ReadMode) readLenient) ::-              IO (Either IOException (Maybe Text))-          case r of-            Right (Just content) -> do-              let ms = matchLines display content needle ci-                  remaining = cap - length acc-                  taken = take remaining ms-                  truncated' = truncated || length ms > remaining-              go rest (reverse taken ++ acc) (scanned + 1) truncated'-            _ -> go rest acc (scanned + 1) truncated  data Match = Match   { mPath :: FilePath,@@ -246,21 +266,28 @@   | T.length t <= maxLineLength = t   | otherwise = T.take maxLineLength t <> "…" -renderResults :: Text -> Text -> [Match] -> Int -> Bool -> Text-renderResults rootDisplay pat matches scanned truncated =-  let header =+-- | Render the results. @partial@: the walk stopped early, so the file+-- count is a lower bound. @capHit@: 'maxResults' was reached.+renderResults :: Text -> Text -> [Match] -> Int -> Bool -> Bool -> Maybe Text -> Text+renderResults rootDisplay pat allMatches scanned partial capHit note =+  let (body, cut) = capLines maxOutputBytes (map fmtMatch allMatches)+      header =         "=== grep "           <> T.pack (show pat)           <> " in "           <> rootDisplay           <> " | "-          <> T.pack (show (length matches))+          <> T.pack (show (length body))           <> " match(es) across "           <> T.pack (show scanned)+          <> (if partial then "+" else "")           <> " file(s)"-          <> (if truncated then " | truncated (raise maxResults to see more)" else "")+          <> ( if cut+                 then " | output truncated at " <> T.pack (show maxOutputBytes) <> " bytes"+                 else if capHit then " | stopped at maxResults (raise it to see more)" else ""+             )+          <> maybe "" (" | " <>) note           <> " ==="-      body = map fmtMatch matches    in T.unlines (header : body)   where     fmtMatch m =

@@ -0,0 +1,34 @@+-- | An in-process lock per file path, so that the file tools' read, modify+-- and write steps on one file do not interleave.+--+-- It only covers threads of this process. Edits made by other processes at+-- the same time are not seen and can still be lost.+module LLM.Tools.Internal.PathLock+  ( withPathLock,+  )+where++import Control.Concurrent.STM (TVar, atomically, modifyTVar', newTVarIO, readTVar, retry, writeTVar)+import Control.Exception (bracket_)+import Data.Set (Set)+import Data.Set qualified as Set+import System.IO.Unsafe (unsafePerformIO)++-- | Paths currently held by some thread.+lockedPaths :: TVar (Set FilePath)+lockedPaths = unsafePerformIO (newTVarIO Set.empty)+{-# NOINLINE lockedPaths #-}++-- | Run an action while holding the lock for @path@, waiting until no+-- other thread holds it. Use the resolved (canonical) path as the key, so+-- two spellings of one file share a lock. Not reentrant: taking the lock+-- for a path this thread already holds blocks forever.+withPathLock :: FilePath -> IO a -> IO a+withPathLock path = bracket_ acquire release+  where+    acquire = atomically $ do+      held <- readTVar lockedPaths+      if Set.member path held+        then retry+        else writeTVar lockedPaths (Set.insert path held)+    release = atomically (modifyTVar' lockedPaths (Set.delete path))

@@ -0,0 +1,26 @@+-- | Text edits shared by @replace_in_file@ and @multi_replace_in_file@.+module LLM.Tools.Internal.TextEdit+  ( countOccurrences,+    replaceFirst,+  )+where++import Data.Text (Text)+import Data.Text qualified as T++-- | Count non-overlapping occurrences of needle in haystack.+countOccurrences :: Text -> Text -> Int+countOccurrences needle haystack+  | T.null needle = 0+  | otherwise = go 0 haystack+  where+    go !n hay = case T.breakOn needle hay of+      (_, rest)+        | T.null rest -> n+        | otherwise -> go (n + 1) (T.drop (T.length needle) rest)++-- | Replace the first occurrence of needle with replacement.+replaceFirst :: Text -> Text -> Text -> Text+replaceFirst needle replacement haystack =+  let (before, after) = T.breakOn needle haystack+   in before <> replacement <> T.drop (T.length needle) after

@@ -0,0 +1,62 @@+-- | Bounds on the total work of one filesystem tool call: a budget of+-- directory entries a walk may look at, and a byte cap on the lines a tool+-- returns. Shared by the walking and listing tools.+module LLM.Tools.Internal.WalkBudget+  ( WalkBudget,+    newWalkBudget,+    takeEntries,+    budgetExhausted,+    budgetNote,+    capLines,+    utf8Length,+  )+where++import Data.ByteString qualified as BS+import Data.IORef (IORef, atomicModifyIORef', newIORef, readIORef)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)++-- | How many more directory entries a walk may look at, and whether it was+-- denied any.+data WalkBudget = WalkBudget Int (IORef (Int, Bool))++-- | A budget of @n@ entries.+newWalkBudget :: Int -> IO WalkBudget+newWalkBudget n = WalkBudget n <$> newIORef (n, False)++-- | Charge the budget for a directory's entries. Returns the entries the+-- walk may look at: all of them while the budget lasts, then a prefix,+-- then none. Once an entry is refused, 'budgetExhausted' is true.+takeEntries :: WalkBudget -> [a] -> IO [a]+takeEntries (WalkBudget _ ref) xs = atomicModifyIORef' ref $ \(left, cut) ->+  let allowed = take left xs+      n = length allowed+      cut' = cut || n < length (take (left + 1) xs)+   in ((left - n, cut'), allowed)++-- | True once the walk was refused entries because the budget ran out.+budgetExhausted :: WalkBudget -> IO Bool+budgetExhausted (WalkBudget _ ref) = snd <$> readIORef ref++-- | The note a tool adds to its output when the budget ran out.+budgetNote :: WalkBudget -> Text+budgetNote (WalkBudget n _) =+  "stopped after visiting " <> T.pack (show n) <> " entries; narrow the path or pattern"++-- | Keep lines while their UTF-8 size (each plus a newline) stays within+-- @cap@ bytes. Also says whether any line was dropped.+capLines :: Int -> [Text] -> ([Text], Bool)+capLines cap = go 0 []+  where+    go _ acc [] = (reverse acc, False)+    go used acc (l : ls)+      | used + size > cap = (reverse acc, True)+      | otherwise = go (used + size) (l : acc) ls+      where+        size = utf8Length l + 1++-- | Size of a text in UTF-8 bytes.+utf8Length :: Text -> Int+utf8Length = BS.length . encodeUtf8

@@ -30,7 +30,8 @@     { ttoolName = "move_file",       ttoolDescription =         "Move (rename) a file from source to destination (both paths relative to the workspace). "-          <> "Creates parent directories at the destination as needed.",+          <> "Creates parent directories at the destination as needed. "+          <> "Refuses to overwrite: if anything exists at the destination, remove it first.",       ttoolReadonly = False,       ttoolExecute = const (withWorkspacePaths cfg . moveFileExecTyped cfg)     }@@ -61,6 +62,20 @@                 (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+                  -- Anything at the destination counts, a link included+                  -- (even a dangling one, which 'sandboxPath' would follow+                  -- to a missing target). Checked before 'sandboxWritePath'+                  -- creates parent directories. The check and the rename+                  -- are not atomic; another process can still create the+                  -- destination in between.+                  dstLink <- sandboxSymlink cfg (T.unpack dst)+                  dstExists <-+                    if isJust dstLink+                      then pure True+                      else sandboxPath cfg (T.unpack dst) >>= doesPathExist+                  if dstExists+                    then pure $ "Error: destination already exists: " <> dst <> "; remove it first"+                    else do+                      dstResolved <- sandboxWritePath cfg (T.unpack dst)+                      renameFile srcResolved dstResolved+                      pure $ "Successfully moved " <> src <> " to " <> dst

@@ -8,6 +8,8 @@ import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (maxReadBytes, readBoundedUtf8File, writeUtf8File)+import LLM.Tools.Internal.PathLock (withPathLock)+import LLM.Tools.Internal.TextEdit (countOccurrences, replaceFirst)  data Replacement = Replacement   { _repOld :: Text,@@ -55,21 +57,23 @@     }  replaceExecTyped :: FsConfig -> MultiReplaceInFileToolArgs -> IO Text-replaceExecTyped cfg args = do-  let MultiReplaceInFileToolArgs {_mrifPath, _mrifReplacements} = args+replaceExecTyped cfg MultiReplaceInFileToolArgs {_mrifPath, _mrifReplacements} = do   resolved <- sandboxPath cfg (T.unpack _mrifPath)-  contentE <- readBoundedUtf8File resolved _mrifPath maxReadBytes-  case contentE of-    Left err -> pure $ "Error: " <> err-    Right content -> case applyReplacements _mrifReplacements content of-      Left err -> pure err-      Right result -> do-        writeUtf8File resolved result-        pure $-          "Successfully applied "-            <> T.pack (show (length _mrifReplacements))-            <> " replacement(s) in "-            <> _mrifPath+  -- Hold the lock from the read to the write, so a concurrent edit of the+  -- same file cannot be lost.+  withPathLock resolved $ do+    contentE <- readBoundedUtf8File resolved _mrifPath maxReadBytes+    case contentE of+      Left err -> pure $ "Error: " <> err+      Right content -> case applyReplacements _mrifReplacements content of+        Left err -> pure err+        Right result -> do+          writeUtf8File resolved result+          pure $+            "Successfully applied "+              <> T.pack (show (length _mrifReplacements))+              <> " replacement(s) in "+              <> _mrifPath  -- | Apply a list of replacements sequentially, failing on the first error. applyReplacements :: [Replacement] -> Text -> Either Text Text@@ -84,20 +88,3 @@           <> T.pack (show n)           <> " times (must appear exactly once): "           <> _repOld---- | Count non-overlapping occurrences of needle in haystack.-countOccurrences :: Text -> Text -> Int-countOccurrences needle haystack-  | T.null needle = 0-  | otherwise = go 0 haystack-  where-    go !n hay = case T.breakOn needle hay of-      (_, rest)-        | T.null rest -> n-        | otherwise -> go (n + 1) (T.drop (T.length needle) rest)---- | Replace the first occurrence of needle with replacement.-replaceFirst :: Text -> Text -> Text -> Text-replaceFirst needle replacement haystack =-  let (before, after) = T.breakOn needle haystack-   in before <> replacement <> T.drop (T.length needle) after

@@ -14,11 +14,10 @@ import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths)-import LLM.Tools.FsLimits (maxPaginatedFileBytes)+import LLM.Tools.FsLimits (maxOutputBytes, maxPaginatedFileBytes) import LLM.Tools.Internal.TextFile (withTextHandle) import System.IO-  ( Handle,-    IOMode (ReadMode),+  ( IOMode (ReadMode),     hFileSize,     withBinaryFile,   )@@ -66,7 +65,9 @@           <> "Use 'offset' (1-based line number, default 1) and 'limit' (default 200, max 2000) "           <> "to walk through large files one page at a time. Source files larger than "           <> T.pack (show maxPaginatedFileBytes)-          <> " bytes are refused. The response header reports the "+          <> " bytes are refused. A page holds at most "+          <> T.pack (show maxOutputBytes)+          <> " bytes of text; a longer line is cut and marked. The response header reports the "           <> "file's byte size, the line range returned, and whether more lines remain along "           <> "with the next offset to use. The tool is stateless: pass the next offset on the "           <> "following call. Binary files are refused.",@@ -75,43 +76,110 @@     }  execute :: FsConfig -> ReadFilePaginatedArgs -> IO Text-execute cfg args = do-  let rel = T.unpack args._rfpPath-      offset = max 1 args._rfpOffset-      limit = max 1 (min maxLimit args._rfpLimit)-  resolved <- sandboxPath cfg rel-  result <- withTextHandle (withBinaryFile resolved ReadMode) $ \h -> do-    size <- hFileSize h-    if size > maxPaginatedFileBytes-      then pure (Left size)-      else do-        (lns, hasMore) <- readPage h offset limit-        pure (Right (size, lns, hasMore))-  pure $ case result of-    Nothing ->-      "Error: "-        <> args._rfpPath-        <> " appears to be a binary file; read_file_paginated only supports text files."-    Just (Left size) ->-      "Error: "-        <> args._rfpPath-        <> " is "-        <> T.pack (show size)-        <> " bytes, which exceeds the "-        <> T.pack (show maxPaginatedFileBytes)-        <> "-byte cap for read_file_paginated."-    Just (Right (size, lns, hasMore)) ->-      renderPage args._rfpPath size offset lns hasMore+execute cfg args+  | args._rfpOffset < 1 =+      pure $ "Error: offset is a 1-based line number and must be at least 1, got " <> T.pack (show args._rfpOffset)+  | args._rfpLimit < 1 =+      pure $ "Error: limit must be positive, got " <> T.pack (show args._rfpLimit)+  | otherwise = do+      let rel = T.unpack args._rfpPath+          offset = args._rfpOffset+          limit = min maxLimit args._rfpLimit+          path = args._rfpPath+          capText = T.pack (show maxPaginatedFileBytes)+      resolved <- sandboxPath cfg rel+      result <- withTextHandle (withBinaryFile resolved ReadMode) $ \h -> do+        size <- hFileSize h+        if size > maxPaginatedFileBytes+          then+            pure . Left $+              path+                <> " is "+                <> T.pack (show size)+                <> " bytes, which exceeds the "+                <> capText+                <> "-byte cap for read_file_paginated."+          else do+            -- Read one byte past the cap, so a file that grew past it since+            -- the size check is reported instead of looking like it ended.+            bytes <- BS.hGet h (fromIntegral maxPaginatedFileBytes + 1)+            pure $+              if fromIntegral (BS.length bytes) > maxPaginatedFileBytes+                then+                  Left $+                    path+                      <> " grew past the "+                      <> capText+                      <> "-byte cap for read_file_paginated during the read."+                else+                  let (lns, hasMore) = takePage offset limit bytes+                   in Right (size, lns, hasMore)+      pure $ case result of+        Nothing ->+          "Error: "+            <> path+            <> " appears to be a binary file; read_file_paginated only supports text files."+        Just (Left err) -> "Error: " <> err+        Just (Right (size, lns, hasMore)) ->+          renderPage path size offset lns hasMore  -- | Take up to @limit@ lines starting at line @offset@, and report whether--- more lines follow. Reads at most 'maxPaginatedFileBytes' (the file may--- have grown since the size check) and decodes leniently, so invalid UTF-8--- bytes show as U+FFFD instead of failing the read.-readPage :: Handle -> Int -> Int -> IO ([Text], Bool)-readPage h offset limit = do-  bytes <- BS.hGet h (fromIntegral maxPaginatedFileBytes)-  let rest = drop (offset - 1) (T.lines (decodeUtf8With lenientDecode bytes))-  pure (take limit rest, not (null (drop limit rest)))+-- more lines follow.+--+-- Lines are found on the raw bytes (a newline byte never occurs inside a+-- UTF-8 sequence), so the lines before @offset@ are skipped without being+-- decoded. Only the page is decoded, leniently: invalid UTF-8 bytes show+-- as U+FFFD instead of failing the read.+--+-- The page holds at most 'maxOutputBytes' bytes of line text. It ends+-- before a line that would go over, unless that line is the first one;+-- then it is cut and marked, and the next page starts at the next line.+takePage :: Int -> Int -> BS.ByteString -> ([Text], Bool)+takePage offset limit = go 0 0 [] . dropLines (offset - 1)+  where+    go :: Int -> Int -> [Text] -> BS.ByteString -> ([Text], Bool)+    go n used acc bs+      | BS.null bs = (reverse acc, False)+      | n >= limit = (reverse acc, True)+      | used + len > maxOutputBytes =+          if null acc+            then ([cutLine line], not (BS.null rest))+            else (reverse acc, True)+      | otherwise = go (n + 1) (used + len) (decode line : acc) rest+      where+        (line, rest0) = BS.break (== newline) bs+        rest = BS.drop 1 rest0+        len = BS.length line++    dropLines :: Int -> BS.ByteString -> BS.ByteString+    dropLines k bs+      | k <= 0 = bs+      | otherwise = case BS.elemIndex newline bs of+          Nothing -> BS.empty+          Just i -> dropLines (k - 1) (BS.drop (i + 1) bs)++    cutLine line =+      decode (utf8Prefix maxOutputBytes line)+        <> " [line cut: "+        <> T.pack (show (BS.length line))+        <> " bytes, first "+        <> T.pack (show maxOutputBytes)+        <> " shown]"++    decode = decodeUtf8With lenientDecode+    newline = 10++-- | At most @n@ bytes from the start, without splitting a UTF-8 sequence.+utf8Prefix :: Int -> BS.ByteString -> BS.ByteString+utf8Prefix n bs+  | BS.length bs <= n = bs+  | otherwise = BS.take (boundary n) bs+  where+    -- Back up while the byte at the cut is a continuation byte (10xxxxxx),+    -- so the cut falls before the lead byte of its sequence.+    boundary i+      | i > 0 && BS.index bs i >= 0x80 && BS.index bs i < 0xC0 = boundary (i - 1)+      | otherwise = i  renderPage :: Text -> Integer -> Int -> [Text] -> Bool -> Text renderPage path size offset lns hasMore =

@@ -8,6 +8,8 @@ import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths)+import LLM.Tools.FsLimits (maxOutputBytes, maxTreeEntries)+import LLM.Tools.Internal.WalkBudget (capLines) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>)) @@ -31,7 +33,10 @@         "List the contents of a directory (relative to the workspace). "           <> "Returns one entry per line. Directories are suffixed with '/', "           <> "symbolic links with '@' (links are not followed). "-          <> "Use path '.' to list the workspace root.",+          <> "Use path '.' to list the workspace root. "+          <> "At most "+          <> T.pack (show maxTreeEntries)+          <> " entries are listed; a final line says if more were left out.",       ttoolReadonly = True,       ttoolExecute = const (withWorkspacePaths fsConfig . readdirExecTyped fsConfig)     }@@ -40,9 +45,21 @@ readdirExecTyped cfg args = do   let relPath = T.unpack args._rdPath   resolved <- sandboxPath cfg relPath-  entries <- sort <$> listDirectory resolved-  annotated <- mapM (annotateEntry resolved) $ filter (not . isFileHidden) entries-  pure $ T.intercalate "\n" annotated+  visible <- sort . filter (not . isFileHidden) <$> listDirectory resolved+  annotated <- mapM (annotateEntry resolved) (take maxTreeEntries visible)+  -- Leave room for the note line.+  let (shown, _) = capLines (maxOutputBytes - 200) annotated+      total = length visible+      note+        | length shown < total =+            [ "[showing "+                <> T.pack (show (length shown))+                <> " of "+                <> T.pack (show total)+                <> " entries; use find_files to search the rest]"+            ]+        | otherwise = []+  pure $ T.intercalate "\n" (shown ++ note)  -- | Annotate a directory entry without following symlinks. -- Symbolic links are tagged with '@' and never treated as directories,

@@ -20,6 +20,9 @@     AC.object "read a file" $       ReadfileToolArgs <$> AC.requiredField "path" "Relative file path to read" AC..= (._rfPath) +-- | Deprecated: 'LLM.Load.fsTools' does not register this tool. Use+-- 'LLM.Tools.ReadFilePaginated.readFilePaginatedToolTyped'+-- (@read_file_paginated@), which reads large files in pages. readfileToolTyped :: FsConfig -> TypedTool ctx ReadfileToolArgs readfileToolTyped cfg =   TypedTool@@ -33,6 +36,8 @@       ttoolReadonly = True,       ttoolExecute = const (withWorkspacePaths cfg . readfileExecTyped cfg)     }++{-# DEPRECATED readfileToolTyped "Use readFilePaginatedToolTyped (read_file_paginated), the reader fsTools registers. readfileToolTyped is removed in 0.5." #-}  readfileExecTyped :: FsConfig -> ReadfileToolArgs -> IO Text readfileExecTyped cfg args = do

@@ -8,6 +8,8 @@ import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (maxReadBytes, readBoundedUtf8File, writeUtf8File)+import LLM.Tools.Internal.PathLock (withPathLock)+import LLM.Tools.Internal.TextEdit (countOccurrences, replaceFirst)  data ReplaceInFileToolArgs = ReplaceInFileToolArgs   { _rifPath :: Text,@@ -42,38 +44,22 @@     }  replaceExecTyped :: FsConfig -> ReplaceInFileToolArgs -> IO Text-replaceExecTyped cfg args = do-  let ReplaceInFileToolArgs {_rifPath, _rifOld, _rifNew} = args-      p = _rifPath+replaceExecTyped cfg ReplaceInFileToolArgs {_rifPath = p, _rifOld, _rifNew} = do   resolved <- sandboxPath cfg (T.unpack p)-  contentE <- readBoundedUtf8File resolved p maxReadBytes-  case contentE of-    Left err -> pure $ "Error: " <> err-    Right content -> case countOccurrences _rifOld content of-      0 -> pure "Error: the 'old' string was not found in the file"-      1 -> do-        let replaced = replaceFirst _rifOld _rifNew content-        writeUtf8File resolved replaced-        pure $ "Successfully replaced text in " <> p-      n ->-        pure $-          "Error: the 'old' string was found "-            <> T.pack (show n)-            <> " times; it must appear exactly once"---- | Count non-overlapping occurrences of needle in haystack.-countOccurrences :: Text -> Text -> Int-countOccurrences needle haystack-  | T.null needle = 0-  | otherwise = go 0 haystack-  where-    go !n hay = case T.breakOn needle hay of-      (_, rest)-        | T.null rest -> n-        | otherwise -> go (n + 1) (T.drop (T.length needle) rest)---- | Replace the first occurrence of needle with replacement.-replaceFirst :: Text -> Text -> Text -> Text-replaceFirst needle replacement haystack =-  let (before, after) = T.breakOn needle haystack-   in before <> replacement <> T.drop (T.length needle) after+  -- Hold the lock from the read to the write, so a concurrent edit of the+  -- same file cannot be lost.+  withPathLock resolved $ do+    contentE <- readBoundedUtf8File resolved p maxReadBytes+    case contentE of+      Left err -> pure $ "Error: " <> err+      Right content -> case countOccurrences _rifOld content of+        0 -> pure "Error: the 'old' string was not found in the file"+        1 -> do+          let replaced = replaceFirst _rifOld _rifNew content+          writeUtf8File resolved replaced+          pure $ "Successfully replaced text in " <> p+        n ->+          pure $+            "Error: the 'old' string was found "+              <> T.pack (show n)+              <> " times; it must appear exactly once"

@@ -8,6 +8,7 @@ import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (FsConfig, sandboxWritePath, withWorkspacePaths) import LLM.Tools.FsLimits (writeUtf8File)+import LLM.Tools.Internal.PathLock (withPathLock)  data WritefileToolArgs = WritefileToolArgs   { _wfPath :: Text,@@ -31,7 +32,8 @@       ttoolDescription =         "Write content to a file at the given path (relative to the workspace). "           <> "Creates the file if it doesn't exist, overwrites if it does. "-          <> "Automatically creates parent directories as needed.",+          <> "Automatically creates parent directories as needed. "+          <> "The file is replaced as a whole, so a failed write leaves the old content.",       ttoolReadonly = False,       ttoolExecute = const (withWorkspacePaths cfg . writefileExecTyped cfg)     }@@ -41,5 +43,5 @@   let p = args._wfPath       c = args._wfContent   resolved <- sandboxWritePath cfg (T.unpack p)-  writeUtf8File resolved c+  withPathLock resolved $ writeUtf8File resolved c   pure $ "Successfully wrote " <> T.pack (show (T.length c)) <> " characters to " <> p

@@ -8,9 +8,12 @@ import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.Map qualified as Map import Data.Text (Text)+import Data.Text qualified as T import Heptapod (generate) import LLM.Agent.Events (noEventObserver)-import LLM.Agent.Generate (generateText, streamText)+import LLM.Agent.Generate (generateText, streamText, toolBudgetUsedUpPrompt)+import LLM.Agent.GenerateObject (generateObjectUntyped)+import LLM.Agent.ToolUtils (validateAgent) import LLM.Agent.Types   ( Agent (..),     RuntimeArgs (..),@@ -35,11 +38,15 @@     LLMGateway (..),     LLMHooks (..),     ToolDef (ToolDef, toolDescription, toolName, toolParameters, toolReadonly),+    ToolCall (..),     ToolResult (..),     mkToolCall,   )+import LLM.Core.Utils (getToolCalls) import LLM.Core.Usage (PricingInfo (..), defaultPricingInfo, mkUsage)-import LLM.Generate.Logger (Hooks (..), noHooks)+import LLM.Generate.Generate (generateTextWithFallbacks, streamTextWithFallbacks)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (Hooks (..), LogLevel (..), noHooks) import LLM.Generate.ModelConfig   ( ModelCapabilities (..),     ModelConfig (..),@@ -47,7 +54,8 @@     defaultModelCapabilities,   ) import LLM.Generate.Types-  ( GenerateError (..),+  ( GenRequest (..),+    GenerateError (..),     GenerateErrorResult (..),     GenerateTextResult (..),   )@@ -57,6 +65,7 @@     expectationFailure,     it,     shouldBe,+    shouldContain,     shouldReturn,     shouldSatisfy,   )@@ -294,6 +303,60 @@ alwaysFail :: ChatRequest -> IO (Either LLMError ChatResponse) alwaysFail _ = pure $ Left (HttpError 503 "down") +-- | Gateway that records every request, then answers with @respond@.+recordingGateway :: IORef [ChatRequest] -> (ChatRequest -> IO (Either LLMError ChatResponse)) -> LLMGateway+recordingGateway reqs respond =+  let call req = modifyIORef' reqs (++ [req]) >> respond req+   in LLMGateway+        { gwName = "recording",+          gwImageMediaTypes = supportedImageMediaTypes,+          gwImageUrlSupport = True,+          gwGenerateText = \_ -> call,+          gwStreamText = \_ req _onEvent -> call req,+          gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)+        }++-- | Always one call of @get_weather@, numbered by the tool turns so far.+alwaysTool :: ChatRequest -> IO (Either LLMError ChatResponse)+alwaysTool req =+  let n = length [() | ToolTurn _ <- req.reqConversation]+      tc = mkToolCall ("call_" <> T.pack (show n)) "get_weather" (object [])+   in pure $ Right (ChatResponse "" [toolCallPart tc] Nothing Nothing)++-- | Calls a tool until the final-call line is in the system prompt, then+-- answers in text.+toolsUntilFinalCall :: ChatRequest -> IO (Either LLMError ChatResponse)+toolsUntilFinalCall req+  | isFinalCall req = pure $ Right (ChatResponse "Done." [textPart "Done."] Nothing Nothing)+  | otherwise = alwaysTool req++isFinalCall :: ChatRequest -> Bool+isFinalCall req = maybe False (toolBudgetUsedUpPrompt `T.isInfixOf`) req.reqSystem++-- | Every tool call in a history has a result with its id in the next turn.+everyCallAnswered :: [Turn] -> Bool+everyCallAnswered turns = and (zipWith answered turns (drop 1 turns ++ [UserTurn ""]))+  where+    answered (AssistantMessage parts) next =+      let ids = map (.tcId) (getToolCalls (ChatResponse "" parts Nothing Nothing))+       in null ids || case next of+            ToolTurn rs -> map (.trCallId) rs == ids+            _ -> False+    answered _ _ = True++-- | A runtime whose hooks record log lines and tool errors.+recordingRuntime :: IO (RuntimeArgs, IORef [(LogLevel, Text)], IORef [(Text, Text)])+recordingRuntime = do+  logs <- newIORef []+  toolErrors <- newIORef []+  rt0 <- mkRuntime Nothing+  let hooks =+        noHooks+          { onLog = \lvl msg -> modifyIORef' logs (++ [(lvl, msg)]),+            onToolError = \name msg -> modifyIORef' toolErrors (++ [(name, msg)])+          }+  pure (rt0 {rtHooks = hooks}, logs, toolErrors)+ -- | Shared sticky-fallback checks, run for both 'runGenerate' and 'runStreamGenerate'. stickyFallbackSpec ::   (Agent -> ModelWithFallbacks -> ToolMap Text -> Maybe AbortSignal -> [Turn] -> IO (Either GenerateErrorResult GenerateTextResult)) ->@@ -399,29 +462,6 @@           mapM_ (`shouldSatisfy` hasCachedUserPrefix) convs         Left err -> expectationFailure $ show err -    it "respects maxToolRounds" $ do-      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),-                gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),-                gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)-              }-          agent = defaultAgent {agMaxToolRounds = 2, agTools = ["get_weather"]}-          models = ModelWithFallbacks (mockModel infiniteToolGateway) []-      result <- runGenerate agent models toolMap Nothing [UserTurn "test"]-      case result of-        Left GenerateErrorResult {gerError = GErrToolExceeded, gerPartialNewMessages = msgs} ->-          -- The last round's results are returned, though the model never saw them.-          case reverse msgs of-            ToolTurn [_] : AssistantMessage _ : _ -> length msgs `shouldBe` 4-            _ -> expectationFailure $ "Expected the last round's ToolTurn last, got: " <> show msgs-        other -> expectationFailure $ "Expected GErrToolExceeded, got: " <> show other-     it "falls back to next model on retryable error" $ do       let failGw = mockErrorGateway (HttpError 503 "service unavailable")           okGw = mockGateway (ChatResponse "Fallback worked!" [textPart "Fallback worked!"] (Just (mkUsage 10 5)) Nothing)@@ -618,3 +658,255 @@           length convs `shouldBe` 2           mapM_ (`shouldSatisfy` hasCachedUserPrefix) convs         Left err -> expectationFailure $ show err++  describe "throwing hooks" $ do+    it "an onToolResult that throws does not fail the run after a mutating tool ran" $ do+      ran <- newIORef (0 :: Int)+      let tool = constTool "get_weather" (modifyIORef' ran (+ 1) >> pure "done")+          agent = defaultAgent {agTools = ["get_weather"]}+          models = ModelWithFallbacks (mockModel mockToolGateway) []+      rt0 <- mkRuntime Nothing+      let rt = rt0 {rtHooks = noHooks {onToolResult = \_ _ -> ioError (userError "hook failed")}}+      result <- generateText agent models (Map.fromList [("get_weather", tool)]) rt [UserTurn "weather?"]+      readIORef ran `shouldReturn` 1+      case result of+        Right r -> do+          r.gtrText `shouldBe` "The weather is sunny."+          lastToolResults (init r.gtrNewMessages) `shouldBe` Just [("call_1", "done")]+        Left err -> expectationFailure $ show err++    it "an onLog that throws does not stop a model fallback" $ do+      let gr =+            GenRequest+              { grSystemPrompt = Nothing,+                grMessages = [UserTurn "hi"],+                grTools = [],+                grAbortSignal = Nothing,+                grLLMHooks = llmHooks noHooks,+                grHooks = noHooks {onLog = \_ _ -> ioError (userError "log failed")}+              }+          ok = ChatResponse "fallback answer" [textPart "fallback answer"] Nothing Nothing+          models = ModelWithFallbacks (mockModel (mockErrorGateway (HttpError 503 "down"))) [mockModel (mockGateway ok)]+      result <- generateTextWithFallbacks gr models+      fmap (.respText) result `shouldBe` Right "fallback answer"++    it "an LLM wire hook that throws does not fail the call" $ do+      let gw = (mockGateway (ChatResponse "x" [textPart "x"] Nothing Nothing))+            { gwGenerateText = \hooks _ -> do+                hooks.onLLMRequest "mock" (object [])+                pure (Right (ChatResponse "x" [textPart "x"] Nothing Nothing))+            }+          throwing = (llmHooks noHooks) {onLLMRequest = \_ _ -> ioError (userError "wire hook failed")}+      rt0 <- mkRuntime Nothing+      result <- generateText defaultAgent (ModelWithFallbacks (mockModel gw) []) Map.empty rt0 {rtLLMHooks = throwing} [UserTurn "hi"]+      fmap (.gtrText) result `shouldBe` Right "x"++  describe "tool round limit (final call)" $ do+    let countingTool ref = Map.fromList [("get_weather", constTool "get_weather" (modifyIORef' ref (+ 1) >> pure "Sunny"))]+        limited n = defaultAgent {agMaxToolRounds = n, agTools = ["get_weather"], agSystemPrompt = Just "Be brief."}++    it "runs tools exactly N times, then makes one final call that runs none" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      result <- runGenerate (limited 2) (ModelWithFallbacks (mockModel (recordingGateway reqs alwaysTool)) []) (countingTool ran) Nothing [UserTurn "go"]+      readIORef ran `shouldReturn` 2+      sent <- readIORef reqs+      map isFinalCall sent `shouldBe` [False, False, True]+      fmap (.reqSystem) (drop 2 sent) `shouldBe` [Just ("Be brief.\n\n" <> toolBudgetUsedUpPrompt)]+      -- The final call still declares the tools.+      map (map (.toolName) . (.reqTools)) sent `shouldBe` replicate 3 ["get_weather"]+      case result of+        Left GenerateErrorResult {gerError = GErrToolExceeded, gerPartialNewMessages = msgs} -> do+          length msgs `shouldBe` 6+          msgs `shouldSatisfy` everyCallAnswered+          lastToolResults msgs `shouldBe` Just [("call_2", "Not run: tool round limit reached")]+        other -> expectationFailure $ "Expected GErrToolExceeded, got: " <> show other++    it "returns the final call's text answer as a success" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      result <- runGenerate (limited 1) (ModelWithFallbacks (mockModel (recordingGateway reqs toolsUntilFinalCall)) []) (countingTool ran) Nothing [UserTurn "go"]+      readIORef ran `shouldReturn` 1+      case result of+        Right r -> do+          r.gtrText `shouldBe` "Done."+          length r.gtrNewMessages `shouldBe` 3+          r.gtrNewMessages `shouldSatisfy` everyCallAnswered+        Left err -> expectationFailure $ show err++    it "adds the line as the whole system prompt when the agent has none" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      _ <- runGenerate (limited 0) {agSystemPrompt = Nothing} (ModelWithFallbacks (mockModel (recordingGateway reqs toolsUntilFinalCall)) []) (countingTool ran) Nothing [UserTurn "go"]+      map (.reqSystem) <$> readIORef reqs `shouldReturn` [Just toolBudgetUsedUpPrompt]++    it "agMaxToolRounds = 0 makes exactly one call and runs no tool" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      result <- runGenerate (limited 0) (ModelWithFallbacks (mockModel (recordingGateway reqs alwaysTool)) []) (countingTool ran) Nothing [UserTurn "go"]+      readIORef ran `shouldReturn` 0+      length <$> readIORef reqs `shouldReturn` 1+      case result of+        Left GenerateErrorResult {gerError = GErrToolExceeded, gerPartialNewMessages = msgs} -> do+          length msgs `shouldBe` 2+          msgs `shouldSatisfy` everyCallAnswered+        other -> expectationFailure $ "Expected GErrToolExceeded, got: " <> show other++    it "a negative agMaxToolRounds behaves like 0" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      _ <- runGenerate (limited (-3)) (ModelWithFallbacks (mockModel (recordingGateway reqs alwaysTool)) []) (countingTool ran) Nothing [UserTurn "go"]+      readIORef ran `shouldReturn` 0+      map isFinalCall <$> readIORef reqs `shouldReturn` [True]++    it "streamText makes the same final call" $ do+      reqs <- newIORef []+      ran <- newIORef (0 :: Int)+      result <- runStreamGenerate (limited 1) (ModelWithFallbacks (mockModel (recordingGateway reqs alwaysTool)) []) (countingTool ran) Nothing [UserTurn "go"]+      readIORef ran `shouldReturn` 1+      map isFinalCall <$> readIORef reqs `shouldReturn` [False, True]+      fmap (const ()) result `shouldSatisfy` either (\e -> e.gerError == GErrToolExceeded) (const False)++  describe "agent configuration checks" $ do+    let warnings logs = [m | (Warn, m) <- logs]++    it "sends a tool listed twice once, with a warning" $ do+      reqs <- newIORef []+      (rt, logs, _) <- recordingRuntime+      let agent = defaultAgent {agTools = ["get_weather", "get_weather"]}+      _ <- generateText agent (ModelWithFallbacks (mockModel (recordingGateway reqs toolThenText)) []) toolMap rt [UserTurn "go"]+      sent <- readIORef reqs+      map (map (.toolName) . (.reqTools)) sent `shouldBe` [["get_weather"], ["get_weather"]]+      ws <- warnings <$> readIORef logs+      length (filter ("more than once" `T.isInfixOf`) ws) `shouldBe` 1++    it "logs an unknown tool name once per run, not once per round" $ do+      reqs <- newIORef []+      (rt, logs, _) <- recordingRuntime+      let agent = defaultAgent {agTools = ["no_such_tool", "get_weather"]}+      result <- generateText agent (ModelWithFallbacks (mockModel (recordingGateway reqs toolThenText)) []) toolMap rt [UserTurn "go"]+      fmap (.gtrText) result `shouldBe` Right "The weather is sunny."+      length <$> readIORef reqs `shouldReturn` 2+      ws <- warnings <$> readIORef logs+      filter ("no_such_tool" `T.isInfixOf`) ws+        `shouldBe` ["[test] agTools lists no_such_tool, which is not in the tool map; it is not sent to the model"]++    it "uses the built-in get_history over a caller tool of that name when windowing is on" $ do+      reqs <- newIORef []+      (rt, logs, _) <- recordingRuntime+      let callerHistory = constTool "get_history" (pure "caller history")+          tm = Map.insert "get_history" callerHistory toolMap+          agent = defaultAgent {agTools = ["get_weather", "get_history"], agContextWindow = Just 2}+          gw = mockGateway (ChatResponse "ok" [textPart "ok"] Nothing Nothing)+      _ <- generateText agent (ModelWithFallbacks (mockModel (recordingGateway reqs (gw.gwGenerateText (llmHooks noHooks)))) []) tm rt [UserTurn "go"]+      [req] <- readIORef reqs+      let histories = [d | d <- req.reqTools, d.toolName == "get_history"]+      map (.toolDescription) histories `shouldSatisfy` \ds -> length ds == 1 && ds /= ["test tool"]+      ws <- warnings <$> readIORef logs+      length (filter ("get_history" `T.isInfixOf`) ws) `shouldBe` 1++    it "keeps a caller tool named get_history when windowing is off" $ do+      reqs <- newIORef []+      (rt, logs, _) <- recordingRuntime+      let tm = Map.insert "get_history" (constTool "get_history" (pure "caller history")) toolMap+          agent = defaultAgent {agTools = ["get_history"]}+          gw = mockGateway (ChatResponse "ok" [textPart "ok"] Nothing Nothing)+      _ <- generateText agent (ModelWithFallbacks (mockModel (recordingGateway reqs (gw.gwGenerateText (llmHooks noHooks)))) []) tm rt [UserTurn "go"]+      [req] <- readIORef reqs+      map (.toolDescription) req.reqTools `shouldBe` ["test tool"]+      warnings <$> readIORef logs `shouldReturn` []++    it "fires onToolError for a call to an unknown tool" $ do+      (rt, _, toolErrors) <- recordingRuntime+      let gw = twoToolCallGateway "no_such_tool"+          agent = defaultAgent {agMaxToolRounds = 1}+      _ <- generateText agent (ModelWithFallbacks (mockModel gw) []) toolMap rt [UserTurn "go"]+      errs <- readIORef toolErrors+      errs `shouldContain` [("no_such_tool", "Unknown tool: no_such_tool")]+      length errs `shouldBe` 2++    it "treats a non-positive context window as no windowing, with one warning" $ do+      let conv = [UserTurn "one", AssistantMessage [textPart "a"], UserTurn "two"]+      mapM_+        ( \n -> do+            reqs <- newIORef []+            (rt, logs, _) <- recordingRuntime+            let agent = defaultAgent {agTools = ["get_weather"], agContextWindow = Just n}+            _ <- generateText agent (ModelWithFallbacks (mockModel (recordingGateway reqs toolThenText)) []) toolMap rt conv+            sent <- readIORef reqs+            -- The whole conversation is sent and no get_history is added.+            map (take 3 . (.reqConversation)) sent `shouldBe` replicate (length sent) conv+            map (map (.toolName) . (.reqTools)) sent `shouldBe` replicate (length sent) ["get_weather"]+            ws <- warnings <$> readIORef logs+            filter ("agContextWindow" `T.isInfixOf`) ws+              `shouldBe` ["[test] agContextWindow = Just " <> T.pack (show n) <> " is not positive; the whole conversation is sent"]+        )+        [0, -1]++    it "validateAgent reports nothing for a valid agent" $ do+      validateAgent defaultAgent {agTools = ["get_weather"], agContextWindow = Just 3} toolMap `shouldBe` []++  describe "turn validation (warning only)" $ do+    let invalidHistory =+          [ UserTurn "look at this",+            AssistantMessage [textPart "here"],+            UserMessage [textPart "and now?", toolCallPart (mkToolCall "c1" "get_weather" (object []))]+          ]+        request logs turns =+          GenRequest+            { grSystemPrompt = Nothing,+              grMessages = turns,+              grTools = [],+              grAbortSignal = Nothing,+              grLLMHooks = llmHooks noHooks,+              grHooks = noHooks {onLog = \lvl msg -> modifyIORef' logs (++ [(lvl, msg)])}+            }+        answer _ = pure $ Right (ChatResponse "ok" [textPart "ok"] Nothing Nothing)++    it "logs one warning per invalid turn and still sends the request" $ do+      logs <- newIORef []+      calls <- newIORef []+      result <- generateTextWithFallbacks (request logs invalidHistory) (ModelWithFallbacks (mockModel (loggingGateway calls "m" answer)) [])+      fmap (.respText) result `shouldBe` Right "ok"+      readIORef calls `shouldReturn` ["m"]+      ws <- (\ls -> [m | (Warn, m) <- ls]) <$> readIORef logs+      ws `shouldBe` ["turn 2: user messages may not contain tool-call parts"]++    it "logs once per request, not once per fallback model" $ do+      logs <- newIORef []+      calls <- newIORef []+      let models = ModelWithFallbacks (mockModel (loggingGateway calls "a" alwaysFail)) [mockModel (loggingGateway calls "b" answer)]+      _ <- streamTextWithFallbacks (\_ -> pure ()) (request logs invalidHistory) models+      readIORef calls `shouldReturn` ["a", "b"]+      ws <- (\ls -> [m | (Warn, m) <- ls, "turn " `T.isPrefixOf` m]) <$> readIORef logs+      ws `shouldBe` ["turn 2: user messages may not contain tool-call parts"]++    it "logs nothing for a valid history" $ do+      logs <- newIORef []+      calls <- newIORef []+      _ <- generateTextWithFallbacks (request logs [UserTurn "hi", AssistantMessage [textPart "hello"], UserTurn "bye"]) (ModelWithFallbacks (mockModel (loggingGateway calls "m" answer)) [])+      ws <- (\ls -> [m | (Warn, m) <- ls]) <$> readIORef logs+      ws `shouldBe` []++  describe "agent name in log messages" $ do+    it "prefixes every onLog message of a run with [agName]" $ do+      (rt, logs, _) <- recordingRuntime+      let agent = defaultAgent {agName = "helper", agTools = ["get_weather", "no_such_tool"]}+      _ <- generateText agent (ModelWithFallbacks (mockModel mockToolGateway) []) toolMap rt [UserTurn "go"]+      msgs <- map snd <$> readIORef logs+      msgs `shouldSatisfy` (not . null)+      msgs `shouldSatisfy` all ("[helper] " `T.isPrefixOf`)+      msgs `shouldSatisfy` any ("Trying model" `T.isInfixOf`)++    it "prefixes the log messages of generateObjectUntyped" $ do+      (rt, logs, _) <- recordingRuntime+      _ <- generateObjectUntyped defaultAgent {agName = "helper"} (ModelWithFallbacks (mockModel mockToolGateway) []) rt [UserTurn "go"] (object [])+      msgs <- map snd <$> readIORef logs+      msgs `shouldSatisfy` (not . null)+      msgs `shouldSatisfy` all ("[helper] " `T.isPrefixOf`)++    it "adds no prefix for an empty name" $ do+      (rt, logs, _) <- recordingRuntime+      _ <- generateText defaultAgent {agName = ""} (ModelWithFallbacks (mockModel mockToolGateway) []) toolMap rt [UserTurn "go"]+      msgs <- map snd <$> readIORef logs+      msgs `shouldSatisfy` any ("Trying model" `T.isPrefixOf`)

@@ -1,27 +1,37 @@+{-# LANGUAGE CPP #-}+ module LLM.FsLimitsSpec (spec) where +import Control.Exception (ErrorCall (..), throwIO, try) import Data.ByteString qualified as BS import Data.Text qualified as T import LLM.Core.Types (TypedTool (..)) import LLM.Tools.FsConfig (mkFsConfig) import LLM.Tools.FsLimits-  ( maxPaginatedFileBytes,+  ( atomicWriteWith,+    maxPaginatedFileBytes,     maxReadBytes,     readBoundedTextFile,+    writeUtf8File,   ) import LLM.Tools.ReadFilePaginated   ( ReadFilePaginatedArgs (..),     readFilePaginatedToolTyped,   )-import System.Directory (createDirectory)+import System.Directory (createDirectory, listDirectory) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory)+#if !defined(mingw32_HOST_OS)+import System.Posix.Files (fileMode, getFileStatus, setFileMode)+import System.Posix.Types (FileMode)+#endif import Test.Hspec   ( Spec,     describe,     it,     shouldBe,     shouldContain,+    shouldReturn,     shouldSatisfy,   ) @@ -42,6 +52,39 @@         Left err -> "exceeds the" `T.isInfixOf` err         Right _ -> False +  describe "atomicWriteWith" $ do+    it "leaves the original unchanged and no temp file when the action throws" $ withTempFile $ \dir -> do+      let path = dir </> "f.txt"+      BS.writeFile path "original"+      r <- try $ atomicWriteWith path $ \h -> do+        BS.hPut h "partial"+        throwIO (ErrorCall "boom")+      r `shouldBe` Left (ErrorCall "boom")+      BS.readFile path `shouldReturn` "original"+      listDirectory dir `shouldReturn` ["f.txt"]++    it "replaces the content and leaves no temp file" $ withTempFile $ \dir -> do+      let path = dir </> "f.txt"+      BS.writeFile path "original"+      writeUtf8File path "new"+      BS.readFile path `shouldReturn` "new"+      listDirectory dir `shouldReturn` ["f.txt"]++#if !defined(mingw32_HOST_OS)+    it "keeps the exact mode of an existing 0644 file" $ withTempFile $ \dir ->+      modeAfterWrite dir 0o644 `shouldReturn` 0o644++    it "keeps the exact mode of an existing 0755 file" $ withTempFile $ \dir ->+      modeAfterWrite dir 0o755 `shouldReturn` 0o755++    it "gives a new file the default mode, not 0600" $ withTempFile $ \dir -> do+      -- A file created the ordinary way gets 0666 minus the umask.+      BS.writeFile (dir </> "plain.txt") ""+      expected <- modeOf (dir </> "plain.txt")+      writeUtf8File (dir </> "new.txt") "x"+      modeOf (dir </> "new.txt") `shouldReturn` expected+#endif+   describe "read_file_paginated" $ do     it "rejects source files larger than maxPaginatedFileBytes before reading" $       withSandbox $ \sb -> do@@ -67,3 +110,16 @@   let sb = root </> "sandbox"   createDirectory sb   act sb++#if !defined(mingw32_HOST_OS)+modeOf :: FilePath -> IO FileMode+modeOf p = (`mod` 0o1000) . fileMode <$> getFileStatus p++modeAfterWrite :: FilePath -> FileMode -> IO FileMode+modeAfterWrite dir mode = do+  let path = dir </> "f.txt"+  BS.writeFile path "old"+  setFileMode path mode+  writeUtf8File path "new"+  modeOf path+#endif

@@ -1,6 +1,9 @@ module LLM.FsToolsSpec (spec) where +import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar) import Control.Exception (IOException, bracket_, evaluate, try)+import Control.Monad (forM, forM_) import Data.Aeson (Value, object, (.=)) import Data.ByteString qualified as BS import Data.Map qualified as Map@@ -16,6 +19,7 @@ import LLM.Generate.Logger (noHooks) import LLM.Load.FsTools (fsTools) import LLM.Tools.FsConfig (SandboxViolation (..))+import LLM.Tools.FsLimits (maxOutputBytes, maxTreeEntries, maxVisitedEntries) import System.Directory   ( createDirectory,     createDirectoryLink,@@ -32,6 +36,7 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec   ( Spec,+    aroundAll,     describe,     expectationFailure,     it,@@ -86,6 +91,26 @@       readBack <- runTool tm "read_file_paginated" (object ["path" .= ("code.hs" :: Text)])       T.unpack readBack `shouldContain` "foo = 2" +    it "lands every edit when many run on one file at once" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      -- A large file makes each edit slow enough that the threads would+      -- interleave between read and write without the per-path lock.+      let n = 40 :: Int+          tok i = "<tok " <> T.pack (show i) <> ">"+          done i = "<done " <> T.pack (show i) <> ">"+          padding = T.replicate 95000 "0123456789"+      runTool_ tm "writefile" (object ["path" .= ("big.txt" :: Text), "content" .= (padding <> T.concat (map tok [1 .. n]))])+      dones <- forM [1 .. n] $ \i -> do+        mv <- newEmptyMVar+        _ <- forkIO $ do+          r <- try (runTool tm "replace_in_file" (object ["path" .= ("big.txt" :: Text), "old" .= tok i, "new" .= done i]))+          putMVar mv (r :: Either IOException Text)+        pure mv+      results <- mapM takeMVar dones+      forM_ results $ \r -> r `shouldSatisfy` either (const False) ("Successfully" `T.isPrefixOf`)+      final <- BS.readFile (sb </> "big.txt")+      forM_ [1 .. n] $ \i -> encodeUtf8 (done i) `shouldSatisfy` (`BS.isInfixOf` final)+   describe "grep" $ do     it "finds a literal substring" $ withSandbox $ \sb -> do       tm <- fsTools sb@@ -154,6 +179,25 @@       doesFileExist (sb </> "moved.txt") `shouldReturn` True       doesFileExist (sb </> "copy.txt") `shouldReturn` False +    it "move_file refuses to overwrite an existing file and changes neither" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      BS.writeFile (sb </> "a.txt") "A"+      BS.writeFile (sb </> "b.txt") "B"+      result <- runTool tm "move_file" (object ["source" .= ("a.txt" :: Text), "destination" .= ("b.txt" :: Text)])+      result `shouldBe` "Error: destination already exists: b.txt; remove it first"+      BS.readFile (sb </> "a.txt") `shouldReturn` "A"+      BS.readFile (sb </> "b.txt") `shouldReturn` "B"++    it "move_file refuses to move onto a dangling link" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      BS.writeFile (sb </> "a.txt") "A"+      createFileLink (sb </> "missing.txt") (sb </> "link.txt")+      result <- runTool tm "move_file" (object ["source" .= ("a.txt" :: Text), "destination" .= ("link.txt" :: Text)])+      result `shouldBe` "Error: destination already exists: link.txt; remove it first"+      BS.readFile (sb </> "a.txt") `shouldReturn` "A"+      doesPathExist (sb </> "missing.txt") `shouldReturn` False+      pathIsSymbolicLink (sb </> "link.txt") `shouldReturn` True+   describe "multi_replace_in_file" $ do     it "applies ordered replacements" $ withSandbox $ \sb -> do       tm <- fsTools sb@@ -211,6 +255,44 @@       out `shouldNotContain` "llm-simple-fstools"    describe "symbolic links" $ do+    it "refuses a '..' that steps back out of a symbolic link" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      createDirectory (sb </> "real")+      createDirectory (sb </> "real" </> "sub")+      BS.writeFile (sb </> "x.txt") "root copy"+      BS.writeFile (sb </> "real" </> "x.txt") "real copy"+      createDirectoryLink (sb </> "real" </> "sub") (sb </> "lnk")+      -- By name, lnk/../x.txt is the root's x.txt; the OS reads real/x.txt.+      forM_ ["lnk/../x.txt", "lnk/a/../../x.txt"] $ \p -> do+        out <- toolErrorText tm "read_file_paginated" (object ["path" .= (p :: Text)])+        T.unpack out `shouldContain` "'..' after a symbolic link"+        T.unpack out `shouldContain` "lnk"+        T.unpack out `shouldNotContain` "copy"++    it "file_info reports a link inside the workspace as a link, with its target" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      createDirectory (sb </> "real")+      BS.writeFile (sb </> "real" </> "f.txt") "x"+      createFileLink (sb </> "real" </> "f.txt") (sb </> "lnk")+      createFileLink (sb </> "real" </> "gone.txt") (sb </> "dangling")+      out <- runTool tm "file_info" (object ["path" .= ("lnk" :: Text)])+      T.lines out `shouldBe` ["=== lnk | symbolic link ===", "target: " <> T.pack ("real" </> "f.txt") <> " (file)"]+      dangling <- runTool tm "file_info" (object ["path" .= ("dangling" :: Text)])+      T.unpack dangling `shouldContain` "(does not exist)"++    it "file_info does not name a link target outside the workspace" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      createFileLink (takeDirectory sb </> "secret.txt") (sb </> "out")+      out <- runTool tm "file_info" (object ["path" .= ("out" :: Text)])+      T.lines out `shouldBe` ["=== out | symbolic link ===", "target: outside the workspace"]++    it "still resolves '..' after an ordinary directory" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      createDirectory (sb </> "dir")+      BS.writeFile (sb </> "x.txt") "root copy"+      out <- runTool tm "read_file_paginated" (object ["path" .= ("dir/../x.txt" :: Text)])+      T.unpack out `shouldContain` "root copy"+     it "remove_file removes the link and leaves its target intact" $ withSandbox $ \sb -> do       tm <- fsTools sb       writeFile (sb </> "real.txt") "keep"@@ -350,6 +432,111 @@       T.unpack result `shouldContain` "0 match(es)"       (t1 - t0) `shouldSatisfy` (< 1) +  describe "work bounds" $ aroundAll withBigTree $ do+    it "find_files stops at the entry budget when nothing matches" $ \sb -> do+      tm <- fsTools sb+      result <- runTool tm "find_files" (object ["pattern" .= ("**/*.nomatch" :: Text)])+      T.unpack result `shouldContain` "0 match(es)"+      T.unpack result `shouldContain` ("stopped after visiting " <> show maxVisitedEntries <> " entries")++    it "grep stops at the entry budget when nothing matches" $ \sb -> do+      tm <- fsTools sb+      result <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text)])+      T.unpack result `shouldContain` "0 match(es)"+      T.unpack result `shouldContain` ("stopped after visiting " <> show maxVisitedEntries <> " entries")++    it "directory_tree stops at the entry budget" $ \sb -> do+      tm <- fsTools sb+      result <- runTool tm "directory_tree" (object ["path" .= ("." :: Text)])+      T.unpack result `shouldContain` ("stopped after visiting " <> show maxVisitedEntries <> " entries")++    it "readdir lists at most maxTreeEntries entries and says how many there are" $ \sb -> do+      tm <- fsTools sb+      result <- runTool tm "readdir" (object ["path" .= ("." :: Text)])+      length (T.lines result) `shouldBe` maxTreeEntries + 1+      last (T.lines result) `shouldBe` "[showing 2000 of 20001 entries; use find_files to search the rest]"++  describe "work bounds (small trees)" $ do+    it "grep stops at maxResults and reports a lower bound on files" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      mapM_ (\i -> BS.writeFile (sb </> ("f" <> show i <> ".txt")) "needle\n") [1 .. 5 :: Int]+      result <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text), "maxResults" .= (2 :: Int)])+      T.unpack result `shouldContain` "2 match(es) across 2+ file(s)"+      T.unpack result `shouldContain` "stopped at maxResults"++    it "grep reports an exact file count when it searched everything" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      mapM_ (\i -> BS.writeFile (sb </> ("f" <> show i <> ".txt")) "needle\n") [1 .. 3 :: Int]+      result <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text)])+      T.unpack result `shouldContain` "3 match(es) across 3 file(s) ==="++    it "find_files cuts output at maxOutputBytes" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      -- 1500 names of ~100 bytes is ~150 KB of output, over the cap.+      let name i = replicate 90 'x' <> show (i :: Int) <> ".txt"+      mapM_ (\i -> BS.writeFile (sb </> name i) "") [1000 .. 2499]+      result <- runTool tm "find_files" (object ["pattern" .= ("*.txt" :: Text), "maxResults" .= (2000 :: Int)])+      BS.length (encodeUtf8 result) `shouldSatisfy` (< maxOutputBytes + 1000)+      T.unpack result `shouldContain` "output truncated at"++    it "read_file_paginated cuts a line longer than a page and marks it" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      BS.writeFile (sb </> "long.txt") ("short\n" <> BS.replicate (maxOutputBytes * 3) 0x61 <> "\nlast\n")+      result <- runTool tm "read_file_paginated" (object ["path" .= ("long.txt" :: Text), "offset" .= (2 :: Int)])+      BS.length (encodeUtf8 result) `shouldSatisfy` (< maxOutputBytes + 1000)+      T.unpack result `shouldContain` ("[line cut: " <> show (maxOutputBytes * 3) <> " bytes")+      T.unpack result `shouldContain` "next offset: 3"++    it "read_file_paginated ends a page before the byte cap" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      let line = BS.replicate (maxOutputBytes `div` 2 + 10) 0x62+      BS.writeFile (sb </> "two.txt") (line <> "\n" <> line <> "\n")+      result <- runTool tm "read_file_paginated" (object ["path" .= ("two.txt" :: Text)])+      T.unpack result `shouldContain` "lines 1-1"+      T.unpack result `shouldContain` "next offset: 2"+      T.unpack result `shouldNotContain` "line cut"++    it "read_file_paginated does not split a UTF-8 character when cutting" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      -- "ä" is two bytes; an odd prefix byte puts the cap inside one.+      BS.writeFile (sb </> "u.txt") ("x" <> encodeUtf8 (T.replicate maxOutputBytes "ä"))+      result <- runTool tm "read_file_paginated" (object ["path" .= ("u.txt" :: Text)])+      T.unpack result `shouldNotContain` "\xFFFD"++    it "read_file_paginated skips lines before the offset" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      BS.writeFile (sb </> "n.txt") (BS.concat [encodeUtf8 (T.pack ("l" <> show i <> "\n")) | i <- [1 .. 10 :: Int]])+      result <- runTool tm "read_file_paginated" (object ["path" .= ("n.txt" :: Text), "offset" .= (9 :: Int)])+      filter (not . T.isPrefixOf "===") (T.lines result) `shouldBe` ["     9| l9", "    10| l10"]+      T.unpack result `shouldContain` "end of file"++  describe "argument checks" $ do+    it "find_files rejects an unknown type" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      out <- runTool tm "find_files" (object ["pattern" .= ("*" :: Text), "type" .= ("files" :: Text)])+      out `shouldBe` "Error: unknown type \"files\"; use 'file', 'directory' or 'any'"++    it "find_files still accepts file, directory, dir and any" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      forM_ ["file", "directory", "dir", "any", "File"] $ \t -> do+        out <- runTool tm "find_files" (object ["pattern" .= ("*" :: Text), "type" .= (t :: Text)])+        T.unpack out `shouldNotContain` "Error"++    it "find_files and grep reject a non-positive maxResults" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      ff <- runTool tm "find_files" (object ["pattern" .= ("*" :: Text), "maxResults" .= (0 :: Int)])+      ff `shouldBe` "Error: maxResults must be positive, got 0"+      g <- runTool tm "grep" (object ["pattern" .= ("x" :: Text), "maxResults" .= (-3 :: Int)])+      g `shouldBe` "Error: maxResults must be positive, got -3"++    it "read_file_paginated rejects a non-positive offset or limit" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      BS.writeFile (sb </> "f.txt") "a\n"+      o <- runTool tm "read_file_paginated" (object ["path" .= ("f.txt" :: Text), "offset" .= (0 :: Int)])+      T.unpack o `shouldContain` "Error: offset is a 1-based line number"+      l <- runTool tm "read_file_paginated" (object ["path" .= ("f.txt" :: Text), "limit" .= (0 :: Int)])+      l `shouldBe` "Error: limit must be positive, got 0"+   describe "workspace root guard" $ do     let rootPaths = [".", "", "./", "sub/.."] :: [Text]     it "remove_directory refuses the workspace root" $ withSandbox $ \sb -> do@@ -400,6 +587,12 @@   old <- getLocaleEncoding   bracket_ (setLocaleEncoding enc) (setLocaleEncoding old) act +-- | A sandbox with one more entry than 'maxVisitedEntries', none matching.+withBigTree :: (FilePath -> IO ()) -> IO ()+withBigTree act = withSandbox $ \sb -> do+  mapM_ (\i -> BS.writeFile (sb </> ("e" <> show i)) "") [0 .. maxVisitedEntries]+  act sb+ withSandbox :: (FilePath -> IO a) -> IO a withSandbox act = withSystemTempDirectory "llm-simple-fstools" $ \root -> do   let sb = root </> "sandbox"@@ -412,6 +605,14 @@   case Map.lookup name tm of     Nothing -> error ("tool not found: " <> T.unpack name)     Just tool -> tool.toolExecute ctx args++-- | Run a tool the way the agent does and return what the model sees.+toolErrorText :: Map.Map Text (Tool Text) -> Text -> Value -> IO Text+toolErrorText tm name args = do+  ctx <- mkToolContext+  let call = ToolCall {tcId = "1", tcName = name, tcArguments = args, tcProviderMeta = Nothing}+  res <- executeTool noHooks ctx (Map.elems tm) call+  pure res.trContent  runTool_ :: Map.Map Text (Tool Text) -> Text -> Value -> IO () runTool_ tm name args = runTool tm name args >> pure ()

@@ -7,14 +7,14 @@ import Data.Aeson.KeyMap qualified as KM import Data.ByteString qualified as BS import Data.Char (isAsciiLower, isAsciiUpper, isDigit)-import Data.IORef (newIORef, readIORef, writeIORef)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Maybe (isJust) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as TE import Data.UUID.Types qualified as UUID import Data.Vector qualified as V-import LLM.Core.LLMProvider (LLMProvider (..))+import LLM.Core.LLMProvider (LLMProvider (..), genericGenerateText) import LLM.Core.ProviderUtils (normalizeSchemaOpenAI, stripBoundsAndComments) import LLM.Core.Types   ( ChatRequest (..),@@ -33,6 +33,8 @@     imageUrlPart,     imageBase64Part,     cacheEphemeral,+    LLMHooks (..),+    pattern UserTurn,   ) import LLM.Core.Usage (Usage (..), mkUsage) import LLM.Core.Utils (getToolCalls, hasToolCalls)@@ -109,6 +111,31 @@             "additionalProperties" .= False,             "required" .= (["type"] :: [Text])           ]++  describe "request hook" $ do+    it "sees the body as sent, without the _model routing key" $ do+      hooked <- newIORef []+      sent <- newIORef []+      okBody <- BS.readFile "test/fixtures/gemini-text.json"+      let provider = (geminiProvider "") {sendRequest = \b -> modifyIORef' sent (++ [b]) >> pure (200, okBody)}+          hooks =+            LLMHooks+              { onLLMRequest = \_ b -> modifyIORef' hooked (++ [b]),+                onLLMResponse = \_ _ -> pure (),+                onLLMResponseError = \_ _ -> pure ()+              }+          req = ChatRequest "gemini-2.5-flash" [UserTurn "hi"] Nothing 100 Nothing [] Nothing+      result <- genericGenerateText provider hooks req+      fmap (.respText) result `shouldBe` Right "Hello! How can I help you today?"+      [hookBody] <- readIORef hooked+      [sendBody] <- readIORef sent+      let keys = \case+            Object o -> map K.toText (KM.keys o)+            _ -> []+      keys hookBody `shouldSatisfy` notElem "_model"+      keys hookBody `shouldSatisfy` elem "contents"+      -- sendRequest still gets the model, for the URL.+      keys sendBody `shouldSatisfy` elem "_model"    describe "request body schema stripping" $ do     it "strips bounds from tool parameters but not from conversation content" $ do

@@ -33,6 +33,10 @@     it "returns 0 when the conversation has fewer user messages than N" $ do       windowOffset (Just 5) [UserTurn "only"] `shouldBe` 0 +    it "returns 0 for a non-positive window (no windowing)" $ do+      windowOffset (Just 0) sampleConversation `shouldBe` 0+      windowOffset (Just (-1)) sampleConversation `shouldBe` 0+   describe "get_history" $ do     it "reports no earlier history when nothing is hidden" $ do       result <- runHistory noWindowAgent sampleConversation 0

@@ -6,12 +6,19 @@ import Data.Aeson (Value, object) import Data.ByteString qualified as BS import Data.IORef (atomicModifyIORef', newIORef, readIORef)+import Data.Text qualified as T+import System.Timeout (timeout)+import LLM.Core.LLMProvider (genericGenerateText, genericStreamText) import LLM.Core.ProviderUtils (mkLenientConfig)+import LLM.Core.Types (ChatRequest (..), LLMError (..), pattern UserTurn)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import LLM.Providers.Ollama (ollamaProviderWith) import Network.HTTP.Client qualified as HC import Network.HTTP.Req (POST (..), ReqBodyJson (..), http, ignoreResponse, port, req, runReq, (/:)) import Network.Socket qualified as N import Network.Socket.ByteString qualified as NB-import Test.Hspec (Spec, describe, it, shouldBe)+import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe, shouldSatisfy)  spec :: Spec spec = describe "HTTP config" $ do@@ -28,6 +35,78 @@         Left (_ :: SomeException) -> pure ()         Right _ -> fail "expected the request to time out"       readIORef posts >>= (`shouldBe` 1)++  describe "response body limits" $ do+    it "cuts an endless error body and returns HttpError" $+      withEndlessServer "500 Internal Server Error" "" $ \p -> do+        r <- within $ genericGenerateText (ollamaProviderWith (http "127.0.0.1") (port p)) (llmHooks noHooks) request+        case r of+          Left (HttpError 500 body) -> do+            T.length body `shouldSatisfy` (<= 64 * 1024 + 3)+            T.takeEnd 3 body `shouldBe` "..."+          other -> expectationFailure ("expected HttpError 500, got " <> take 200 (show other))++    it "cuts an endless error body of a stream and returns HttpError" $+      withEndlessServer "503 Service Unavailable" "" $ \p -> do+        r <- within $ genericStreamText (ollamaProviderWith (http "127.0.0.1") (port p)) (llmHooks noHooks) request (const (pure ()))+        case r of+          Left (HttpError 503 body) -> T.length body `shouldSatisfy` (<= 64 * 1024 + 3)+          other -> expectationFailure ("expected HttpError 503, got " <> take 200 (show other))++    it "turns an endless 200 body into a ParseError" $+      withEndlessServer "200 OK" "" $ \p -> do+        r <- within $ genericGenerateText (ollamaProviderWith (http "127.0.0.1") (port p)) (llmHooks noHooks) request+        case r of+          Left (ParseError msg) -> T.unpack msg `shouldBe` "response body exceeds 33554432 bytes"+          other -> expectationFailure ("expected ParseError, got " <> take 200 (show other))++    it "turns an endless stream event into a ParseError" $+      withEndlessServer "200 OK" "data: " $ \p -> do+        r <- within $ genericStreamText (ollamaProviderWith (http "127.0.0.1") (port p)) (llmHooks noHooks) request (const (pure ()))+        case r of+          Left (ParseError msg) -> T.unpack msg `shouldBe` "response body exceeds 8388608 bytes"+          other -> expectationFailure ("expected ParseError, got " <> take 200 (show other))++-- | Fail instead of hanging when a body is read without a bound.+within :: IO a -> IO a+within act = timeout 20_000_000 act >>= maybe (fail "timed out: the body was read without a bound") pure++request :: ChatRequest+request =+  ChatRequest+    { reqModel = "test",+      reqConversation = [UserTurn "hi"],+      reqSystem = Nothing,+      reqTools = [],+      reqMaxTokens = 10,+      reqTemperature = Nothing,+      reqThinking = Nothing+    }++-- | A TCP server on a free local port that answers every POST with the+-- given status line, then the prefix, then @x@ bytes until the client+-- hangs up.+withEndlessServer :: BS.ByteString -> BS.ByteString -> (Int -> IO a) -> IO a+withEndlessServer status prefix action =+  bracket open N.close $ \sock -> do+    p <- fromIntegral <$> N.socketPort sock+    tid <- forkIO $ forever $ do+      (conn, _) <- N.accept sock+      void $ forkIO $ flip finally (N.close conn) $ do+        chunk <- NB.recv conn 4096+        if "POST" `BS.isPrefixOf` chunk+          then do+            NB.sendAll conn ("HTTP/1.1 " <> status <> "\r\nContent-Length: 1000000000000\r\n\r\n" <> prefix)+            -- Stops when the client closes the connection and a send fails.+            void (try @SomeException (forever (NB.sendAll conn (BS.replicate 65536 0x78))))+          else pure ()+    action p `finally` killThread tid+  where+    open = do+      sock <- N.socket N.AF_INET N.Stream N.defaultProtocol+      N.bind sock (N.SockAddrInet 0 (N.tupleToHostAddress (127, 0, 0, 1)))+      N.listen sock 16+      pure sock  -- | A TCP server on a free local port that counts each request it receives -- and answers it only after the given delay.

@@ -3,7 +3,10 @@ import Control.Exception (IOException, SomeException, catch, displayException, fromException, try) import Control.Monad (forM_) import Control.Monad.Except (runExceptT)-import Data.Aeson (Value (Array), eitherDecodeFileStrict')+import Data.Aeson (Value (Array, Object), eitherDecodeFileStrict', encode, object, toJSON, (.=))+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy qualified as BSL import Data.ByteString qualified as BS import Data.List (find) import Data.Map qualified as Map@@ -26,6 +29,7 @@ import LLM.Load.Utils (getSystemPrompt) import System.Directory (createDirectory, withCurrentDirectory) import System.Environment (setEnv)+import System.Environment.Blank qualified as Blank import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec@@ -35,6 +39,7 @@     it,     shouldBe,     shouldContain,+    shouldReturn,     shouldSatisfy,     shouldThrow,     anyErrorCall,@@ -295,6 +300,70 @@         Left other -> expectationFailure $ "expected LoadModelCatalogError, got: " <> show other         Right _ -> expectationFailure "expected failure" +  describe "invalid catalog entries" $ do+    let expectCatalogError path name needles = do+          result <- try @LoadConfigError (loadModelOrThrow path name)+          case result of+            Left (LoadModelCatalogError msg) -> mapM_ (\n -> T.unpack msg `shouldContain` n) needles+            Left other -> expectationFailure $ "expected LoadModelCatalogError, got: " <> show other+            Right _ -> expectationFailure "expected failure"++    it "rejects a modelConfigName used twice" $+      withModelCatalog [modelEntry "twice" [], modelEntry "twice" [("maxTokens", 2048)]] $ \path ->+        expectCatalogError path "twice" ["duplicate modelConfigName", "twice"]++    it "rejects maxTokens <= 0, naming the entry" $+      forM_ [0, -5] $ \n ->+        withModelCatalog [modelEntry "ok" [], modelEntry "bad_tokens" [("maxTokens", n)]] $ \path ->+          -- The whole catalog is rejected, not only the bad entry.+          expectCatalogError path "ok" ["bad_tokens", "maxTokens"]++    it "rejects a negative limit, naming the entry and the field" $+      forM_ ["requestTimeout", "throttleDelay", "retryCount", "jitterBackoff"] $ \field ->+        withModelCatalog [modelEntry "bad_limit" [(field, -1)]] $ \path ->+          expectCatalogError path "bad_limit" ["bad_limit", T.unpack field]++    it "rejects a negative price, naming the entry and the field" $+      forM_ ["pricePerMillionInput", "pricePerMillionOutput", "pricePerMillionCacheRead", "pricePerMillionCacheWrite"] $ \field ->+        withModelCatalog [modelEntryWithPricing "bad_price" [(field, -0.5)]] $ \path ->+          expectCatalogError path "bad_price" ["bad_price", T.unpack field]++    it "accepts zero limits and prices" $+      withModelCatalog [modelEntry "zeros" [("requestTimeout", 0), ("throttleDelay", 0), ("retryCount", 0), ("jitterBackoff", 0)]] $ \path -> do+        cfg <- loadModelOrThrow path "zeros"+        cfg.mcMaxTokens `shouldBe` 1024++    it "rejects a providerName used twice in providers.json" $ do+      let provider url = "{\"providerName\":\"dup\",\"protocol\":\"ollama\",\"baseUrl\":\"" <> url <> "\"}"+      withCatalogs "[]" ("[" <> provider "http://localhost:1" <> "," <> provider "http://localhost:2" <> "]") $ \path -> do+        result <- try @LoadConfigError (loadModelOrThrow path "x")+        case result of+          Left (LoadProviderCatalogError msg) -> do+            T.unpack msg `shouldContain` "duplicate providerName"+            T.unpack msg `shouldContain` "dup"+          Left other -> expectationFailure $ "expected LoadProviderCatalogError, got: " <> show other+          Right _ -> expectationFailure "expected failure"++  describe "empty API keys" $ do+    let item =+          ProviderCatalogItem+            { providerName = "custom",+              protocol = OpenAIProtocol,+              baseUrl = "https://example.com",+              apiKeyEnv = Just "LLM_SIMPLE_TEST_BLANK_KEY",+              baseUrlEnv = Nothing+            }+        resolveWith value = do+          Blank.setEnv "LLM_SIMPLE_TEST_BLANK_KEY" value True+          either Left (const (Right ())) <$> resolveGateway item++    it "treats an empty or whitespace-only key as missing" $+      forM_ ["", "   ", "\t\n"] $ \value ->+        resolveWith value `shouldReturn` Left (MissingApiKey "LLM_SIMPLE_TEST_BLANK_KEY")++    it "accepts a non-empty key" $+      resolveWith "secret" `shouldReturn` Right ()+   describe "getSystemPrompt" $ do     it "reports a file that is not valid UTF-8" $       withSystemTempDirectory "llm-simple-prompt" $ \root -> do@@ -307,6 +376,46 @@             T.unpack msg `shouldContain` "UTF-8"           Left other -> expectationFailure $ "expected LoadSystemPromptError, got: " <> show other           Right p -> expectationFailure $ "expected failure, got: " <> show p++-- | A model catalog entry for Ollama (no key) with integer fields+-- overridden.+modelEntry :: Text -> [(Text, Int)] -> Value+modelEntry name overrides = withFields (baseModelEntry name) [(f, toJSON v) | (f, v) <- overrides]++-- | A model catalog entry with pricing fields overridden.+modelEntryWithPricing :: Text -> [(Text, Double)] -> Value+modelEntryWithPricing name overrides =+  case baseModelEntry name of+    Object o+      | Just pricing <- KM.lookup "pricing" o ->+          Object (KM.insert "pricing" (withFields pricing [(f, toJSON v) | (f, v) <- overrides]) o)+    other -> other++baseModelEntry :: Text -> Value+baseModelEntry name =+  object+    [ "modelConfigName" .= name,+      "providerName" .= ("ollama" :: Text),+      "modelName" .= ("llama3.2:latest" :: Text),+      "pricing" .= object ["pricePerMillionInput" .= (0 :: Double), "pricePerMillionOutput" .= (0 :: Double)],+      "maxTokens" .= (1024 :: Int),+      "retryCount" .= (0 :: Int),+      "jitterBackoff" .= (0 :: Int)+    ]++withFields :: Value -> [(Text, Value)] -> Value+withFields (Object o) fields = Object (foldr (\(f, v) -> KM.insert (K.fromText f) v) o fields)+withFields v _ = v++-- | Write a model catalog (and an empty @providers.json@) to a temporary+-- directory.+withModelCatalog :: [Value] -> (FilePath -> IO a) -> IO a+withModelCatalog entries act =+  withSystemTempDirectory "llm-simple-catalog-entries" $ \root -> do+    let catalogPath = root </> "model-catalog.json"+    BSL.writeFile catalogPath (encode entries)+    writeFile (root </> "providers.json") "[]"+    act catalogPath  withTempCatalog :: String -> (FilePath -> IO a) -> IO a withTempCatalog contents act =

@@ -1,13 +1,38 @@+{-# LANGUAGE MultiWayIf #-}+ module LLM.RecordedConversationSpec (spec) where +import Data.Aeson (Value (Object, String), encode)+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString.Lazy qualified as BSL+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Map qualified as Map+import Heptapod (generate)+import LLM.Agent.Events (noEventObserver)+import LLM.Agent.Generate (generateText, toolBudgetUsedUpPrompt)+import LLM.Agent.ToolUtils (toTool)+import LLM.Agent.Types (Agent (..), RuntimeArgs (..))+import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Core.Types (pattern UserTurn)+import LLM.Core.Usage (defaultPricingInfo) import LLM.GenericConversationTest (GenericConversationTextOps (..), createSpec)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig (ModelConfig (..), ModelWithFallbacks (..), defaultModelCapabilities)+import LLM.Generate.Types (GenerateTextResult (..)) 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 (recordedDeepSeekThinking)-import Test.Hspec (SpecWith, describe)+import LLM.TestKit+  ( MockRequestResponse (..),+    readMockRequestResponse,+    recordedConversationSystemPrompt,+    recordedDeepSeekThinking,+  )+import LLM.WeatherTool (weatherToolTyped)+import Test.Hspec (SpecWith, describe, expectationFailure, it, shouldBe)  ollamaConversationGeneratedFilePath :: String ollamaConversationGeneratedFilePath = "./test/fixtures/ollama-conversation-generated.json"@@ -82,3 +107,73 @@         (Just recordedDeepSeekThinking)         deepSeekConversationGeneratedFilePath         deepSeekConversationStreamedFilePath++    describe "Claude final call after the tool round limit" $+      it "is the recorded follow-up request with the extra system-prompt line" $+        claudeFinalCallSpec++-- | With @agMaxToolRounds = 1@, the call after the first tool round is the+-- final call (1.16). It must be exactly the recorded second request, which+-- Claude accepted (tools declared, tool blocks in the history), except for+-- the system prompt, which gets 'toolBudgetUsedUpPrompt' appended.+claudeFinalCallSpec :: IO ()+claudeFinalCallSpec = do+  recorded <- readMockRequestResponse claudeConversationGeneratedFilePath+  case recorded of+    Just (first : second : _) -> do+      let withFinalLine = \case+            Object o+              | Just (String sys) <- KM.lookup "system" o ->+                  Object (KM.insert "system" (String (sys <> "\n\n" <> toolBudgetUsedUpPrompt)) o)+            v -> v+          expectedFinal = withFinalLine second.request+      sent <- newIORef []+      let provider =+            (claudeProvider "")+              { sendRequest = \body -> do+                  modifyIORef' sent (++ [body])+                  if+                    | body == first.request -> pure (200, BSL.toStrict (encode first.response))+                    | body == expectedFinal -> pure (200, BSL.toStrict (encode second.response))+                    | otherwise -> pure (400, "unexpected request")+              }+          model =+            ModelConfig+              { mcGateway = toGateway provider,+                mcModel = "claude-haiku-4-5-20251001",+                mcPricing = defaultPricingInfo 0 0,+                mcMaxTokens = 1024,+                mcTemperature = Nothing,+                mcThinking = Nothing,+                mcCapabilities = defaultModelCapabilities,+                mcRequestTimeout = Nothing,+                mcThrottleDelay = Nothing,+                mcRetryCount = 0,+                mcJitterBackoff = 0+              }+          agent =+            Agent+              { agName = "test",+                agSystemPrompt = Just recordedConversationSystemPrompt,+                agTools = ["get_weather"],+                agMaxToolRounds = 1,+                agContextWindow = Nothing+              }+      genId <- generate+      let rt =+            RuntimeArgs+              { rtGenerationId = genId,+                rtAbortSignal = Nothing,+                rtLLMHooks = llmHooks noHooks,+                rtHooks = noHooks,+                rtOnEvent = noEventObserver,+                rtReadonly = False+              }+          toolMap = Map.fromList [("get_weather", toTool weatherToolTyped)]+      result <- generateText agent (ModelWithFallbacks model []) toolMap rt [UserTurn "how's the weather in london?"]+      bodies <- readIORef sent+      bodies `shouldBe` [first.request, expectedFinal]+      case result of+        Right r -> length r.gtrNewMessages `shouldBe` 3+        Left err -> expectationFailure (show err)+    _ -> expectationFailure "fixture needs at least two recorded calls"

@@ -0,0 +1,200 @@+-- | Large inputs that used to take quadratic time (C12, C20). Each check,+-- assertions included (results may be lazy), runs under a timeout that the+-- linear code meets with a wide margin and the quadratic code does not.+module LLM.ScaleSpec (spec) where++import Control.Monad (forM_, replicateM)+import Data.Aeson (object, (.=))+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.ByteString.Char8 qualified as BC+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text qualified as T+import LLM.Agent.ToolUtils (windowOffset)+import LLM.Agent.Tools.HistoryTool (chunkBackward, findNthUserBack)+import LLM.Core.LLMProvider (LLMProvider (..))+import LLM.Core.Types+  ( ChatResponse (..),+    LLMTextResult,+    ToolCall (..),+    Turn (..),+    projectText,+    textPart,+    pattern UserTurn,+  )+import LLM.Core.Utils (getToolCalls)+import LLM.Providers.Claude (claudeProvider)+import LLM.Providers.Gemini (geminiProvider)+import LLM.Providers.OpenAI (openAIProvider)+import System.Timeout (timeout)+import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe)++-- | Seconds a scaled-up check may take.+limitSeconds :: Int+limitSeconds = 10++within :: IO a -> IO a+within act = do+  r <- timeout (limitSeconds * 1_000_000) act+  case r of+    Just a -> pure a+    Nothing -> expectationFailure ("took longer than " <> show limitSeconds <> " s") >> fail "timeout"++-- | A reader that returns @bytes@ in pieces of @n@ bytes.+chunkedReader :: Int -> ByteString -> IO (IO ByteString)+chunkedReader n bytes = do+  ref <- newIORef bytes+  pure $ do+    rest <- readIORef ref+    let (chunk, rest') = BS.splitAt n rest+    writeIORef ref rest'+    pure chunk++parseWith :: LLMProvider -> ByteString -> IO LLMTextResult+parseWith = parseInChunksOf 4096++parseInChunksOf :: Int -> LLMProvider -> ByteString -> IO LLMTextResult+parseInChunksOf n p bytes = do+  reader <- chunkedReader n bytes+  p.parseStream (object []) reader (\_ -> pure ())++-- | How many fragments the stream tests send, and their size.+fragments :: Int+fragments = 40_000++fragment :: ByteString+fragment = BC.replicate 100 'a'++expectedArg :: T.Text+expectedArg = T.replicate (fragments * 100) "a"++claudeEvent :: ByteString -> ByteString -> ByteString+claudeEvent name dat = "event: " <> name <> "\ndata: " <> dat <> "\n\n"++claudeStart :: ByteString+claudeStart = claudeEvent "message_start" "{\"type\":\"message_start\",\"message\":{\"model\":\"claude-test\",\"usage\":{\"input_tokens\":1,\"output_tokens\":0}}}"++claudeEnd :: ByteString+claudeEnd =+  claudeEvent "message_delta" "{\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\"},\"usage\":{\"output_tokens\":1}}"+    <> claudeEvent "message_stop" "{\"type\":\"message_stop\"}"++-- | The old paging code, kept as the reference for the rewrite.+oldChunkBackward :: Int -> [Turn] -> [[Turn]]+oldChunkBackward _ [] = []+oldChunkBackward n conv+  | n <= 0 = [conv]+  | otherwise = reverse (go (length conv) [])+  where+    go 0 acc = acc+    go end acc =+      let start = oldFindNthUserBack n (take end conv)+          page = take (end - start) (drop start conv)+       in if start >= end then page : acc else go start (page : acc)++oldFindNthUserBack :: Int -> [Turn] -> Int+oldFindNthUserBack n conv = go (length conv - 1) n+  where+    go idx remaining+      | idx < 0 = 0+      | remaining <= 0 = idx + 1+      | otherwise = case conv !! idx of+          UserMessage _ -> go (idx - 1) (remaining - 1)+          _ -> go (idx - 1) remaining++-- | Every conversation of up to @len@ turns over user, assistant and tool+-- turns, each turn numbered so pages can be told apart.+allConversations :: Int -> [[Turn]]+allConversations len = concatMap shapes [0 .. len]+  where+    shapes k = map (zipWith mk [0 :: Int ..]) (replicateM k "uat")+    mk i 'u' = UserTurn (T.pack (show i))+    mk i 'a' = AssistantMessage [textPart (T.pack (show i))]+    mk _ _ = ToolTurn []++-- | Alternating user and assistant turns.+longConversation :: Int -> [Turn]+longConversation pairs = concat [[UserTurn "q", AssistantMessage [textPart "a"]] | _ <- [1 .. pairs]]++spec :: Spec+spec = describe "Scale (linear time)" $ do+  describe "SSE" $+    it "reads a long line that arrives one byte at a time" $ do+      let size = 1024 * 1024+          body =+            "data: {\"choices\":[{\"index\":0,\"delta\":{\"content\":\"" <> BC.replicate size 'x' <> "\"},\"finish_reason\":null}]}\n\n"+              <> "data: {\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"stop\"}]}\n\ndata: [DONE]\n\n"+      within $ do+        result <- parseInChunksOf 1 (openAIProvider "key") body+        fmap (T.length . (.respText)) result `shouldBe` Right size++  describe "stream assembly" $ do+    it "Claude: joins many tool-argument and thinking fragments" $ do+      let toolStart = claudeEvent "content_block_start" "{\"type\":\"content_block_start\",\"index\":0,\"content_block\":{\"type\":\"tool_use\",\"id\":\"t1\",\"name\":\"f\",\"input\":{}}}"+          jsonDelta s = claudeEvent "content_block_delta" ("{\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"input_json_delta\",\"partial_json\":\"" <> s <> "\"}}")+          stop i = claudeEvent "content_block_stop" ("{\"type\":\"content_block_stop\",\"index\":" <> i <> "}")+          thinkStart = claudeEvent "content_block_start" "{\"type\":\"content_block_start\",\"index\":1,\"content_block\":{\"type\":\"thinking\",\"thinking\":\"\"}}"+          thinkDelta = claudeEvent "content_block_delta" ("{\"type\":\"content_block_delta\",\"index\":1,\"delta\":{\"type\":\"thinking_delta\",\"thinking\":\"" <> fragment <> "\"}}")+          body =+            claudeStart+              <> toolStart+              <> jsonDelta "{\\\"k\\\":\\\""+              <> BS.concat (replicate fragments (jsonDelta fragment))+              <> jsonDelta "\\\"}"+              <> stop "0"+              <> thinkStart+              <> BS.concat (replicate fragments thinkDelta)+              <> stop "1"+              <> claudeEnd+      within $ do+        result <- parseWith (claudeProvider "key") body+        case result of+          Right resp -> do+            map (.tcArguments) (getToolCalls resp) `shouldBe` [object ["k" .= expectedArg]]+            resp.respReasoning `shouldBe` Just expectedArg+          Left err -> expectationFailure (show err)++    it "OpenAI: joins many tool-argument and reasoning fragments" $ do+      let chunk delta = "data: {\"choices\":[{\"index\":0,\"delta\":" <> delta <> ",\"finish_reason\":null}]}\n\n"+          toolDelta s = chunk ("{\"tool_calls\":[{\"index\":0,\"id\":\"t1\",\"function\":{\"name\":\"f\",\"arguments\":\"" <> s <> "\"}}]}")+          reasoning = chunk ("{\"reasoning_content\":\"" <> fragment <> "\"}")+          body =+            BS.concat (replicate fragments reasoning)+              <> toolDelta "{\\\"k\\\":\\\""+              <> BS.concat (replicate fragments (toolDelta fragment))+              <> toolDelta "\\\"}"+              <> "data: {\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"tool_calls\"}]}\n\ndata: [DONE]\n\n"+      within $ do+        result <- parseWith (openAIProvider "key") body+        case result of+          Right resp -> do+            map (.tcArguments) (getToolCalls resp) `shouldBe` [object ["k" .= expectedArg]]+            resp.respReasoning `shouldBe` Just expectedArg+          Left err -> expectationFailure (show err)++    it "Gemini: collects the parts of many chunks in order" $ do+      let chunk i = "data: {\"candidates\":[{\"content\":{\"role\":\"model\",\"parts\":[{\"text\":\"" <> BC.pack (show i) <> ",\"}]}}]}\n\n"+          body = BS.concat (map chunk [1 .. fragments]) <> "data: {\"candidates\":[{\"finishReason\":\"STOP\"}]}\n\n"+      within $ do+        result <- parseWith (geminiProvider "key") body+        case result of+          Right resp -> resp.respText `shouldBe` T.concat [T.pack (show i) <> "," | i <- [1 .. fragments]]+          Left err -> expectationFailure (show err)++  describe "history paging and windowing" $ do+    it "chunkBackward and findNthUserBack match the old code on every short conversation" $+      forM_ (allConversations 8) $ \conv ->+        forM_ [0 .. 4] $ \n -> do+          chunkBackward n conv `shouldBe` oldChunkBackward n conv+          findNthUserBack n conv `shouldBe` oldFindNthUserBack n conv++    it "pages a long hidden history" $ do+      let conv = longConversation 50_000+      within $ do+        let pages = chunkBackward 1 conv+        length pages `shouldBe` 50_000+        map projectText [p | UserMessage p <- concat (take 1 pages)] `shouldBe` ["q"]++    it "finds a large window in a long conversation" $ do+      let conv = longConversation 50_000+      within $ windowOffset (Just 25_000) conv `shouldBe` 50_000

@@ -3,7 +3,7 @@ module LLM.StreamingSpec (spec) where  import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay)-import Control.Exception (finally)+import Control.Exception (finally, throwIO, try) import Control.Monad (when) import Control.Retry (RetryPolicyM (getRetryPolicyM), RetryStatus (rsIterNumber), defaultRetryStatus) import Data.Aeson (object, (.=))@@ -11,6 +11,10 @@ import Data.Text (Text) import GHC.Clock (getMonotonicTime) import LLM.Core.Abort (AbortSignal, abort, newAbortSignal)+import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Providers.OpenAI (openAIProvider)+import Network.HTTP.Client qualified as HC+import Network.HTTP.Req (HttpException (..)) import LLM.Core.Types   ( ChatResponse (..),     LLMError (..),@@ -130,6 +134,46 @@           mc = (testModelConfig gw) {mcRequestTimeout = Just 100}       r <- streamTextLLM (\_ -> pure ()) (testGenRequest []) mc       fmap (.respText) r `shouldBe` Left TimeoutError++  describe "stream callback exceptions" $ do+    it "rethrows the callback's own HttpException after one attempt" $ do+      attempts <- newIORef (0 :: Int)+      let provider =+            (openAIProvider "key")+              { openStream = \_ k -> do+                  modifyIORef' attempts (+ 1)+                  chunks <- newIORef ["data: {\"choices\":[{\"delta\":{\"content\":\"hi\"}}]}\n\n", "data: [DONE]\n\n"]+                  k (atomicModifyIORef' chunks (\case [] -> ([], ""); c : cs -> (cs, c)))+              }+          mc = (testModelConfig (toGateway provider)) {mcRetryCount = 3}+          callerFailure = VanillaHttpException (HC.HttpExceptionRequest HC.defaultRequest HC.ConnectionClosed)+          -- Throw only for text, not for the 'StreamAttemptReset' a retry+          -- would emit first, so a retry would show as a second attempt.+          onChunk = \case+            TextDelta _ -> throwIO callerFailure+            _ -> pure ()+      r <- try (streamTextLLM onChunk (testGenRequest [UserTurn "q"]) mc)+      case r of+        Left (VanillaHttpException (HC.HttpExceptionRequest _ HC.ConnectionClosed)) -> pure ()+        Left e -> fail ("unexpected exception: " <> show e)+        Right res -> fail ("expected the exception, got " <> show res)+      readIORef attempts `shouldReturn` 1++    it "still ends a provider stream with Aborted when the signal fires in the callback" $ do+      sig <- newAbortSignal+      let provider =+            (openAIProvider "key")+              { openStream = \_ k -> do+                  chunks <-+                    newIORef+                      [ "data: {\"choices\":[{\"delta\":{\"content\":\"a\"}}]}\n\n",+                        "data: {\"choices\":[{\"delta\":{\"content\":\"b\"}}]}\n\n",+                        "data: [DONE]\n\n"+                      ]+                  k (atomicModifyIORef' chunks (\case [] -> ([], ""); c : cs -> (cs, c)))+              }+      r <- streamTextLLM (\_ -> abort sig) (testGenRequest [UserTurn "q"]) {grAbortSignal = Just sig} (testModelConfig (toGateway provider))+      fmap (.respText) r `shouldBe` Left Aborted    describe "abort signal" $ do     it "does not call the model when the signal fired before the call" $ do

@@ -33,7 +33,7 @@ import LLM.Agent.Generate (generateText, streamText) import LLM.Agent.ToolUtils (toTool) import LLM.Agent.Types (Agent (..), RuntimeArgs (..), ToolMap)-import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Core.LLMProvider (LLMProvider (..), toGateway, withoutRoutingFields) import LLM.Core.Types (LLMGateway, ThinkingMode (..), Turn (..), pattern UserTurn) import LLM.Core.Usage (addUsage, defaultPricingInfo, emptyUsage) import LLM.Core.Utils (streamResponseJson)@@ -88,7 +88,9 @@   case s of     Nothing -> error "can't read conversation"     Just rrs ->-      let pairs = map (\rr -> (rr.request, rr)) rrs+      -- Keyed by the body as sent: recordings made through the request+      -- hook have no @_model@ routing key, older ones do.+      let pairs = map (\rr -> (withoutRoutingFields rr.request, rr)) rrs           rrMap = M.fromList pairs           prompts = rrs >>= \rsp -> case rsp.prompt of Nothing -> []; Just p -> [p]        in pure (rrMap, prompts)@@ -106,12 +108,12 @@ mockProvider mp adapter =   adapter     { sendRequest = \val -> do-        case M.lookup val mp of+        case M.lookup (withoutRoutingFields val) mp of           Nothing ->             error (show val <> "\n" <> show (fst $ head $ M.toList mp))           Just rr -> pure (200, BSL.toStrict (encode rr.response)),       openStream = \body k -> do-        case M.lookup body mp of+        case M.lookup (withoutRoutingFields body) mp of           Nothing -> error ("value not found for:" <> show body)           Just rr -> case rr.sse of             Nothing -> error "recorded streaming call has no raw SSE body; re-record the fixture"

@@ -1,5 +1,6 @@ module LLM.TypesSpec (spec) where +import Control.Monad (forM_) import Data.Aeson (eitherDecode, encode, object, (.=)) import Data.Text qualified as T import LLM.Core.Types@@ -210,6 +211,12 @@      it "rejects invalid base64 characters" $ do       imageBase64Part "image/png" "!!!!" `shouldBe` Left "image data is not valid base64"++    it "allows '=' only as the last one or two characters" $ do+      forM_ ["====", "A===", "ab=c", "=abc", "ab==cdef"] $ \bad ->+        imageBase64Part "image/png" bad `shouldBe` Left "image data is not valid base64"+      forM_ ["aGVsbG8=", "aGVsbA==", "aGVs", "aGVs\nbG8="] $ \good ->+        imageBase64Part "image/png" good `shouldSatisfy` either (const False) (const True)    describe "isRetryable" $ do     it "retries on 429" $ do