llm-simple 0.4.0.1 → 0.4.1.0

raw patch · 51 files changed

+1439/−430 lines, 51 filesdep +stmPVP ok

version bump matches the API change (PVP)

Dependencies added: stm

API changes (from Hackage documentation)

Files

• CHANGELOG.md +115/−0
• Readme.md +21/−9
• app/Main.hs +2/−2
• app/RecordConversation.hs +2/−2
• llm-simple.cabal +6/−1
• src/LLM/Agent/ToolUtils.hs +49/−22
• src/LLM/Agent/Types.hs +2/−1
• src/LLM/Core.hs +1/−0
• src/LLM/Core/Abort.hs +13/−7
• src/LLM/Core/ProviderUtils.hs +35/−2
• src/LLM/Core/SSE.hs +52/−11
• src/LLM/Core/Utils.hs +38/−0
• src/LLM/Generate/Generate.hs +3/−2
• src/LLM/Generate/GenerateUtils.hs +15/−3
• src/LLM/Generate/Logger.hs +26/−5
• src/LLM/Generate/ModelConfig.hs +2/−1
• src/LLM/Generate/Types.hs +7/−5
• src/LLM/Load/LoadGateways.hs +41/−2
• src/LLM/Providers/Claude.hs +30/−22
• src/LLM/Providers/DeepSeek.hs +4/−17
• src/LLM/Providers/Gemini.hs +18/−11
• src/LLM/Providers/Ollama.hs +4/−18
• src/LLM/Providers/OpenAI.hs +41/−17
• src/LLM/Tools/CopyFile.hs +2/−2
• src/LLM/Tools/CreateDirectory.hs +2/−2
• src/LLM/Tools/DirectoryTree.hs +2/−2
• src/LLM/Tools/FileInfo.hs +16/−30
• src/LLM/Tools/FindFiles.hs +2/−2
• src/LLM/Tools/FsConfig.hs +37/−7
• src/LLM/Tools/FsLimits.hs +9/−73
• src/LLM/Tools/Grep.hs +34/−63
• src/LLM/Tools/Internal/TextFile.hs +124/−0
• src/LLM/Tools/MoveFile.hs +2/−2
• src/LLM/Tools/MultiReplaceInFile.hs +2/−2
• src/LLM/Tools/ReadFilePaginated.hs +31/−29
• src/LLM/Tools/Readdir.hs +2/−2
• src/LLM/Tools/Readfile.hs +2/−2
• src/LLM/Tools/RemoveDirectory.hs +2/−2
• src/LLM/Tools/RemoveFile.hs +2/−2
• src/LLM/Tools/ReplaceInFile.hs +2/−2
• src/LLM/Tools/Writefile.hs +2/−2
• test/LLM/ChatSpec.hs +75/−36
• test/LLM/FsConfigSpec.hs +31/−1
• test/LLM/FsToolsSpec.hs +34/−1
• test/LLM/GeminiSpec.hs +6/−1
• test/LLM/LoadSpec.hs +76/−1
• test/LLM/LoggerSpec.hs +33/−0
• test/LLM/StreamCompletenessSpec.hs +213/−0
• test/LLM/StreamingSpec.hs +77/−3
• test/LLM/StructuredOutputSpec.hs +79/−0
• test/LLM/ToolUtilsSpec.hs +13/−1

@@ -5,6 +5,120 @@ 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.1.0] - 2026-11-02++### Added++- `waitAborted :: AbortSignal -> IO ()` (in `LLM.Core.Abort` and+  `LLM.Core`) blocks until the signal fires.+- `LLM.Core.Utils.interruptOnAbort` runs an action and interrupts it when+  the signal fires.+- `LLM.Tools.FsConfig.withWorkspacePaths` runs a filesystem action so that+  an `IOException` it throws names its file relative to the workspace.+- `LLM.Core.ProviderUtils.decodeObjectText` and `unexpectedResponse`, and+  `LLM.Providers.OpenAI.parseOpenAIObjectResponse`: the structured-output+  parsing the bundled providers use, for custom providers.++### Fixed++- An abort now interrupts work in flight. Before, the signal was only+  checked between steps, so it could not stop a non-streaming call that was+  waiting for its response, a stream that stalled after its first event, a+  throttle or backoff sleep, or a running tool. **Behaviour change:**+  - When `grAbortSignal` / `rtAbortSignal` fires, the model call in flight+    is interrupted wherever it is, its HTTP connection is closed, and the+    call returns `GErrAborted`.+  - A tool call that is running when the signal fires is interrupted. It+    counts as not run: it gets the result "Aborted before execution", like+    the calls after it, and `onToolError` reports `"Aborted"`. Its side+    effects may have partly happened.+  - The interrupt is an asynchronous exception thrown to the calling thread.+    Tool code that catches every exception, asynchronous ones included, can+    swallow it and keep running.+  - A stream that stalls after its first event still blocks until it is+    aborted: there is no idle timeout yet.+- A truncated or corrupt stream is no longer reported as success.+  **Behaviour change:** some streams that used to return `Right` with a+  partial answer, or throw, now return `Left`.+  - The stream parsers did not check for the end-of-stream marker, so a+    connection that closed cleanly partway through returned the text received+    so far as a complete answer. Each protocol now needs its marker:+    `[DONE]` or a `finish_reason` (OpenAI-compatible: OpenAI, DeepSeek,+    Ollama), a `finishReason` or `blockReason` (Gemini), or `message_stop`+    (Claude). A stream that ends without its marker is+    `NetworkError "stream ended before <marker>"`. It is retried and then+    falls back like any other network error.+  - A data event that is not valid JSON was skipped. It is now a+    `ParseError` quoting the start of the event.+  - A stream event that is not valid UTF-8 threw a `UnicodeException`, which+    escaped the typed error path, so fallback models were never tried. It is+    now a `ParseError`.+  - An in-band provider error event (for example Claude's `overloaded_error`)+    still takes precedence over these checks.+- API keys are no longer sent over plain HTTP. A provider that sends a key+  with a base URL (or `*_BASE_URL` override) of `http://` to a non-loopback+  host is now unavailable, with `InvalidBaseUrl` saying the URL is insecure;+  `loadGatewaysFromCatalogOrThrow` throws for it. `http://` to `localhost`,+  `127.0.0.0/8` or `::1` is still allowed, as is any `http://` host for+  Ollama and other keyless providers. **Behaviour change:** a catalog that+  pointed a keyed provider at a remote `http://` proxy no longer loads that+  provider; use `https://`.+- `mcThrottleDelay` (`throttleDelay`) now applies before every attempt,+  retries included. It was slept once before the first attempt, so retries+  ran after their backoff alone and could hit the rate limit the throttle+  was meant to avoid. Before a retry, throttle and backoff add up.+  **Behaviour change:** a call that retries with a throttle set now takes+  longer.+- `loadGatewaysWithDotenv` no longer swallows cancellation. It ignored every+  exception from loading `.env`, including `ThreadKilled`, `UserInterrupt`+  and timeouts, so a cancellation that arrived during loading was lost. It+  now ignores only `IOException` (a missing or unreadable `.env`). The+  example executables and the README examples do the same.+  **Behaviour change:** a `.env` that dotenv cannot parse used to be ignored+  silently; its parse error is now thrown.+- JSON dumps (`withJsonDump`, `debugHooks`, `defaultDebugHooks`) stay in+  their directory and no longer overwrite each other. The provider name,+  which for a custom provider comes from `providers.json`, was used in the+  file name as is, so a name like `../leak` wrote outside the dump+  directory. Dumps written in the same millisecond had the same name, and+  the later one replaced the earlier. In the provider name, every character+  other than an ASCII letter, digit, `-` or `_` now becomes `_`, and each+  dump is created as a new file with a unique suffix:+  `{provider}-{request|response}-{timestamp}-{unique}.json`. **Behaviour+  change:** dump file names have the extra suffix, and dump files are now+  readable only by their owner (mode 0600).+- Structured-output responses that cannot be parsed are no longer reported+  as `EmptyResponse`. OpenAI, Ollama, DeepSeek and Claude reported model+  text that is not valid JSON, and a response body without the expected+  fields, as `EmptyResponse`, dropping the reason; Gemini did the same for+  text that is not valid JSON. These are now `ParseError`s with the JSON+  decoder's message and the first 200 characters of the text or body.+  `EmptyResponse` is kept for content that is actually empty: no choice or+  text block, or text that is empty once code fences are stripped.+  **Behaviour change:** code that matched `EmptyResponse` for these cases+  gets `ParseError`. Neither is retried, and both still fall back to the+  next model.+- Tool errors no longer show the model absolute host paths. An+  `IOException` from a filesystem tool (a missing file, a permission error)+  was shown to the model with its absolute path, revealing where the+  workspace lives on the host. The bundled filesystem tools now name the+  file relative to the workspace (`sub/missing.txt: removeLink: does not+  exist ...`), or leave it out if it is outside the workspace. For any tool,+  the model-facing error drops an absolute file name from an+  `IOException`. **Behaviour change:** the `IOException`s the filesystem+  tools throw carry the relative path, and `onToolError` gets the same+  redacted text as the model.+- `isSymlink` (`LLM.Tools.FsConfig`) no longer fails open. When the lookup+  failed for any reason, it answered `False` ("not a link"), so the sandbox+  checks and the recursive tools treated a path they could not inspect as a+  regular file or directory. It still answers `False` when nothing exists+  at the path (missing, or a component is not a directory), so new paths+  can be written. Any other failure (permission denied, a symlink loop) now+  answers `True`, so the path is refused or skipped like a symlink.+  **Behaviour change:** such a path now fails the sandbox check, is skipped+  by `grep`, `find_files` and `directory_tree`, and is listed with `@` by+  `readdir`.+ ## [0.4.0.1] - 2026-10-27  ### Fixed@@ -427,6 +541,7 @@   DeepSeek), single-shot generation with fallbacks, agent tool loops, structured   output, JSON model catalog loading, and workspace-scoped filesystem tools. +[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 [0.3.0.0]: https://github.com/aische/llm-simple/compare/v0.2.0.0...v0.3.0.0

@@ -23,6 +23,8 @@  Requires GHC 9.6–9.12 with `GHC2021` (see `tested-with` in `llm-simple.cabal`). +Tested on Linux and macOS. Windows is not supported and not tested.+ ## Quick start  1. Create a `.env` file with API keys for the providers you use:@@ -70,8 +72,8 @@ | `maxTokens`       | Max tokens per request                                                   | | `temperature`     | Sampling temperature (optional)                                          | | `requestTimeout`  | Timeout in ms per attempt (optional); for streaming, time until the first event; timeouts are retried |-| `throttleDelay`   | Delay between requests in ms (optional)                                  |-| `retryCount`      | Number of retries on retryable errors (429, 500, 502, 503, 504, 529, network errors, timeouts) |+| `throttleDelay`   | Delay in ms before each request attempt, retries included; added to the retry backoff (optional) |+| `retryCount`      | Number of retries on retryable errors (429, 500, 502, 503, 504, 529, network errors including streams that end early, timeouts) | | `jitterBackoff`   | Base backoff in ms between retries; full jitter, exponential, each delay capped at 30 s. `Retry-After` is not honoured, so raise this for providers that often rate-limit you | | `thinking`        | Extended thinking effort level (optional, provider-dependent)            | | `capabilities`    | Optional object: `thinking`, `vision`, `promptCaching` (default `false`) |@@ -142,6 +144,11 @@ `CLAUDE_BASE_URL`, `GEMINI_BASE_URL`, `DEEPSEEK_BASE_URL`, `OLLAMA_BASE_URL`. Do not include the protocol path (`/v1/...` or `/v1beta/...`) in `baseUrl`; the library appends it.+A provider that sends an API key must use an `https://` base URL, or `http://`+to a loopback host (`localhost`, `127.0.0.0/8`, `::1`); any other `http://`+base URL makes the provider unavailable, so the key is never sent unencrypted.+Keyless providers (Ollama, or entries without `apiKeyEnv`) may use any+`http://` host. `loadGateways` and `loadGatewaysWithDotenv` always use built-in provider defaults. Custom providers from a co-located `providers.json` apply when loading models via `loadModelOrThrow` or `loadModelsOrThrow`.@@ -150,11 +157,11 @@  ```haskell import Configuration.Dotenv (defaultConfig, loadFile)-import Control.Exception (SomeException, catch)+import Control.Exception (IOException, catch) import LLM.Load (loadModelsOrThrow)  main = do-  loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+  loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()   (gemini, deepseek) <-     loadModelsOrThrow "./model-catalog.json" ("gemini_lite", "deepseek4flash")   ...@@ -170,7 +177,7 @@  ```haskell import Configuration.Dotenv (defaultConfig, loadFile)-import Control.Exception (SomeException, catch)+import Control.Exception (IOException, catch) import Heptapod (generate) import LLM.Agent (Agent (..), RuntimeArgs (..), generateText, noEventObserver) import LLM.Core (pattern UserTurn)@@ -179,7 +186,7 @@  main :: IO () main = do-  loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+  loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()    (gemini, deepseek) <-     loadModelsOrThrow "./model-catalog.json" ("gemini_lite", "deepseek4flash")@@ -213,7 +220,7 @@  Set `rtReadonly = True` to omit mutating tools from the schema sent to the model and to block them at execution time. -For local debugging, `defaultDebugHooks` enables stderr logging and writes request/response JSON to `./dumps` — avoid that in production or shared environments.+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) @@ -256,12 +263,17 @@  ### 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.+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. +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.++**Threat model.** The sandbox keeps the *model* inside the workspace. Through the tools, a model can only reach paths inside it: `..`, absolute paths and symlinks are checked as described above. The tools cannot create symlinks, and an agent runs its tool calls one at a time, so a model cannot change the workspace while a check it relies on is in progress.++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):**  - The sandbox is **path-scoped**, not kernel-level isolation. Use a dedicated, disposable workspace directory — not your home directory or a production tree.-- A **time-of-check/time-of-use (TOCTOU)** window exists between path validation and file open; a concurrent process inside the workspace could theoretically plant a symlink between those steps. - 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. - `rtReadonly` omits mutating tools from the model schema and blocks them at execution time if they are invoked anyway.

@@ -3,7 +3,7 @@ module Main where  import Configuration.Dotenv (defaultConfig, loadFile)-import Control.Exception (SomeException, catch)+import Control.Exception (IOException, catch) import Heptapod (generate) import LLM.Agent   ( Agent (..),@@ -26,7 +26,7 @@  main :: IO () main = do-  loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+  loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()   (_gpt, llama, _haiku, gemini, mistral, deepseek) <-     loadModelsOrThrow       "./model-catalog.json"

@@ -1,7 +1,7 @@ module Main where  import Configuration.Dotenv (defaultConfig, loadFile)-import Control.Exception (SomeException, catch)+import Control.Exception (IOException, catch) import Control.Monad (unless, void, when) import Data.Maybe (fromMaybe) import Data.Text (Text)@@ -125,7 +125,7 @@  main :: IO () main = do-  loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+  loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()   opts <- execParser optionsInfo   when (opts.optGeneratedOnly && opts.optStreamedOnly) $     die "--generated-only and --streamed-only are mutually exclusive"

@@ -2,7 +2,7 @@  name:               llm-simple -version:            0.4.0.1+version:            0.4.1.0  synopsis:     Multi-provider LLM library with agent tool loops and filesystem tools@@ -140,6 +140,7 @@      other-modules:         LLM.Core.SSE+        LLM.Tools.Internal.TextFile     hs-source-dirs:     src     build-depends:         aeson          >=2.0   && <2.3,@@ -160,6 +161,7 @@         random         >=1.2.1 && <1.4,         req            >=3.13.4 && <3.14,         retry          >=0.9   && <0.10,+        stm            >=2.5   && <2.6,         text           >=1.2   && <2.2,         time           >=1.11  && <1.15,         unordered-containers >=0.2 && < 0.3,@@ -227,7 +229,10 @@                         LLM.FsLimitsSpec                         LLM.FsToolsSpec                         LLM.LoadSpec+                        LLM.LoggerSpec                         LLM.StreamingSpec+                        LLM.StreamCompletenessSpec+                        LLM.StructuredOutputSpec                         LLM.HistoryToolSpec                         LLM.HttpConfigSpec                         LLM.LLMProviderSpec

@@ -17,10 +17,12 @@  import Autodocodec qualified as AC import Autodocodec.Schema (jsonSchemaVia)-import Control.Exception (SomeException, fromException)+import Control.Exception (IOException, SomeException, fromException)+import Control.Monad (mfilter) 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)@@ -40,32 +42,44 @@     TypedTool (TypedTool),   ) import LLM.Core.Usage (Usage)-import LLM.Core.Utils (toolResult, trySync)+import LLM.Core.Utils (interruptOnAbort, toolResult, trySync) import LLM.Generate.Logger (Hooks (..)) import LLM.Generate.Types (GenRequest (..)) import LLM.Tools.FsConfig (SandboxViolation, formatSandboxViolation)+import GHC.IO.Exception (IOException (ioe_filename))+import System.FilePath (isRelative)  -- | Execute a single tool call by looking it up in the tool list executeTool :: Hooks -> ToolContext -> [Tool Text] -> ToolCall -> IO ToolResult-executeTool hooks ctx tools tc = case lookup tc.tcName toolMap of-  Nothing -> pure $ toolResult tc ("Unknown tool: " <> tc.tcName)+executeTool hooks ctx tools tc =+  -- Without a signal the call cannot be interrupted, so the default is unused.+  fromMaybe (toolResult tc "Aborted") <$> executeToolInterruptible Nothing hooks ctx tools tc++-- | Like 'executeTool', but the tool is interrupted when the signal fires.+-- 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)   Just tool -> do     if ctx.tcRuntimeArgs.rtReadonly && not tool.toolDef.toolReadonly       then do         let msg = "Error: tool is not available in readonly mode: " <> tc.tcName         hooks.onToolError tc.tcName msg-        pure $ toolResult tc msg+        pure $ Just $ toolResult tc msg       else do         hooks.onToolCall tc.tcName (AE.toJSON tc.tcArguments)-        result <- trySync (tool.toolExecute ctx tc.tcArguments)+        result <- interruptOnAbort mSig (trySync (tool.toolExecute ctx tc.tcArguments))         case result of-          Right text -> do+          Nothing -> do+            hooks.onToolError tc.tcName "Aborted"+            pure Nothing+          Just (Right text) -> do             hooks.onToolResult tc.tcName text-            pure $ toolResult tc text-          Left (e :: SomeException) -> do+            pure $ Just $ toolResult tc text+          Just (Left (e :: SomeException)) -> do             let msg = formatToolException e             hooks.onToolError tc.tcName msg-            pure $ toolResult tc ("Tool error: " <> msg)+            pure $ Just $ toolResult tc ("Tool error: " <> msg)   where     toolMap = [(t.toolDef.toolName, t) | t <- tools] @@ -77,12 +91,14 @@ data ToolRoundOutcome   = -- | Every call ran.     ToolRoundCompleted [ToolResult]-  | -- | The abort signal fired: results of the calls that ran, and the calls-    -- that did not.+  | -- | The abort signal fired: results of the calls that finished, and the+    -- calls that did not. The first of those may have been interrupted while+    -- running, so its side effects may have partly happened.     ToolRoundAborted [ToolResult] [ToolCall]   deriving (Show, Eq) --- | Execute tool calls one at a time, checking the abort signal before each.+-- | Execute tool calls one at a time. The abort signal is checked before+-- each call, and a call that is running when it fires is interrupted. executeToolsWithAbort :: Maybe AbortSignal -> Hooks -> ToolContext -> [Tool Text] -> [ToolCall] -> IO ToolRoundOutcome executeToolsWithAbort Nothing hooks ctx tools tcs = ToolRoundCompleted <$> executeTools hooks ctx tools tcs executeToolsWithAbort (Just sig) hooks ctx tools tcs = go [] tcs@@ -90,11 +106,13 @@     go acc [] = pure (ToolRoundCompleted (reverse acc))     go acc remaining@(tc : rest) = do       aborted <- isAborted sig-      if aborted-        then pure (ToolRoundAborted (reverse acc) remaining)-        else do-          r <- executeTool hooks ctx tools tc-          go (r : acc) rest+      r <-+        if aborted+          then pure Nothing+          else executeToolInterruptible (Just sig) hooks ctx tools tc+      case r of+        Nothing -> pure (ToolRoundAborted (reverse acc) remaining)+        Just res -> go (res : acc) rest  createToolContext ::   Agent ->@@ -217,8 +235,17 @@         pure $ embed result     } +-- | Model-facing text for an exception a tool threw.+--+-- A 'SandboxViolation' shows its path relative to the workspace. An+-- 'IOException' keeps its file name only if that is relative: the bundled+-- filesystem tools make their paths workspace-relative+-- ('LLM.Tools.FsConfig.withWorkspacePaths'), and an absolute path, from+-- any tool, is dropped so the host's directory layout does not reach the+-- model. The operation and the error description are kept. formatToolException :: SomeException -> Text-formatToolException e =-  case fromException e of-    Just (sv :: SandboxViolation) -> formatSandboxViolation sv-    Nothing -> T.pack (show e)+formatToolException e+  | Just (sv :: SandboxViolation) <- fromException e = formatSandboxViolation sv+  | Just (ioe :: IOException) <- fromException e =+      T.pack (show ioe {ioe_filename = mfilter isRelative (ioe_filename ioe)})+  | otherwise = T.pack (show e)

@@ -48,7 +48,8 @@ data RuntimeArgs = RuntimeArgs   { -- | Correlates lifecycle events and result records for one run.     rtGenerationId :: UUID,-    -- | When fired, in-flight generation and tool execution stop cooperatively.+    -- | When fired, the model call or tool call in flight is interrupted and+    -- the run ends with 'LLM.Generate.Types.GErrAborted'.     rtAbortSignal :: Maybe AbortSignal,     -- | Provider wire hooks (request/response JSON). See 'LLMHooks'.     rtLLMHooks :: LLMHooks,

@@ -56,6 +56,7 @@     abort,     isAborted,     isAbortedMaybe,+    waitAborted,     LLMProvider (..),     hasToolCalls,     getToolCalls,

@@ -4,28 +4,34 @@     abort,     isAborted,     isAbortedMaybe,+    waitAborted,   ) where -import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Control.Concurrent.STM (TVar, atomically, check, newTVarIO, readTVar, readTVarIO, writeTVar) --- | A cooperative cancellation signal.+-- | A cancellation signal. -- Create one with 'newAbortSignal', pass it into 'RuntimeArgs' or 'GenRequest', and call--- 'abort' from any thread to request cancellation at the next checkpoint.-newtype AbortSignal = AbortSignal (IORef Bool)+-- 'abort' from any thread. A model call or tool that is running when the signal+-- fires is interrupted.+newtype AbortSignal = AbortSignal (TVar Bool)  -- | Create a fresh signal (not yet aborted). newAbortSignal :: IO AbortSignal-newAbortSignal = AbortSignal <$> newIORef False+newAbortSignal = AbortSignal <$> newTVarIO False  -- | Fire the signal. Idempotent — calling it more than once is harmless. abort :: AbortSignal -> IO ()-abort (AbortSignal ref) = writeIORef ref True+abort (AbortSignal var) = atomically (writeTVar var True)  -- | Check whether the signal has been fired. isAborted :: AbortSignal -> IO Bool-isAborted (AbortSignal ref) = readIORef ref+isAborted (AbortSignal var) = readTVarIO var  isAbortedMaybe :: Maybe AbortSignal -> IO Bool isAbortedMaybe Nothing = pure False isAbortedMaybe (Just sig) = isAborted sig++-- | Block until the signal has been fired. Returns at once if it already has.+waitAborted :: AbortSignal -> IO ()+waitAborted (AbortSignal var) = atomically (readTVar var >>= check)

@@ -5,6 +5,8 @@     handleStreamResponse,     normalizeSchemaOpenAI,     stripJsonFences,+    decodeObjectText,+    unexpectedResponse,     stripBoundsAndComments,     decodeToolArguments,     invalidToolArgumentsError,@@ -12,14 +14,16 @@ where  import Control.Retry (limitRetries)-import Data.Aeson (ToJSON (toJSON), Value (..), decodeStrict', object)+import Data.Aeson (ToJSON (toJSON), Value (..), decodeStrict', eitherDecodeStrict', encode, object) import Data.Aeson.KeyMap qualified as KM import Data.ByteString qualified as BS import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode)-import LLM.Core.Types (LLMError (HttpError, ParseError), LLMTextResult)+import Data.Text.Lazy qualified as TL+import Data.Text.Lazy.Encoding qualified as TLE+import LLM.Core.Types (LLMError (EmptyResponse, HttpError, ParseError), LLMResult, LLMTextResult) import Network.HTTP.Client qualified as HC import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Req (HttpConfig, defaultHttpConfig, httpConfigAltManager, httpConfigCheckResponse, httpConfigRetryPolicy)@@ -123,6 +127,35 @@           then T.strip $ T.dropEnd 3 t''           else t''    in t'''++-- | Decode the text a model returned for a structured-output request, after+-- 'stripJsonFences'. Text that is empty then is 'EmptyResponse'. Text that+-- is not valid JSON is a 'ParseError' with the decoder's message and the+-- start of the text.+decodeObjectText :: Text -> LLMResult Value+decodeObjectText raw+  | T.null text = Left EmptyResponse+  | otherwise = case eitherDecodeStrict' (encodeUtf8 text) of+      Left err ->+        Left $+          ParseError $+            "structured output is not valid JSON: " <> T.pack err <> "; text: " <> excerpt text+      Right v -> Right v+  where+    text = stripJsonFences raw++-- | 'ParseError' for a response body that does not have the expected+-- shape, with the parser's message and the start of the body.+unexpectedResponse :: String -> Value -> LLMError+unexpectedResponse err body =+  ParseError $+    "unexpected response: " <> T.pack err <> "; body: " <> excerpt (TL.toStrict (TLE.decodeUtf8 (encode body)))++-- | At most 200 characters of @t@, with @...@ when cut.+excerpt :: Text -> Text+excerpt t+  | T.length t > 200 = T.take 200 t <> "..."+  | otherwise = t  -- | Remove @minimum@, @maximum@ and @$comment@ keywords from a JSON Schema. --

@@ -1,12 +1,21 @@-module LLM.Core.SSE (SSEEvent (..), readSSEEvents) where+module LLM.Core.SSE+  ( SSEEvent (..),+    readSSEEvents,+    malformedEvent,+    streamFailure,+  )+where +import Control.Applicative ((<|>)) import Control.Monad (unless) 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.IORef (modifyIORef', newIORef, readIORef, writeIORef) import Data.Text (Text)+import Data.Text qualified as T import Data.Text.Encoding qualified as TE+import LLM.Core.Types (LLMError (..))  data SSEEvent = SSEEvent   { sseEvent :: Maybe Text,@@ -16,9 +25,14 @@  -- | Read Server-Sent Events from a streaming body reader. -- Calls the callback for each complete event. Returns when the stream ends.-readSSEEvents :: IO ByteString -> (SSEEvent -> IO ()) -> IO ()+--+-- 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.+readSSEEvents :: IO ByteString -> (SSEEvent -> IO ()) -> IO (Maybe Text) readSSEEvents readChunk callback = do   bufRef <- newIORef BS.empty+  badRef <- newIORef Nothing   let readLine :: IO (Maybe ByteString)       readLine = do         buf <- readIORef bufRef@@ -44,7 +58,7 @@                 writeIORef bufRef (buf <> chunk)                 readLine -      loop :: Maybe Text -> [ByteString] -> IO ()+      loop :: Maybe ByteString -> [ByteString] -> IO ()       loop eventType dataLines = do         mLine <- readLine         case mLine of@@ -59,7 +73,7 @@             | "data:" `BS.isPrefixOf` line ->                 loop eventType (stripField 5 line : dataLines)             | "event:" `BS.isPrefixOf` line ->-                loop (Just (TE.decodeUtf8 (stripField 6 line))) dataLines+                loop (Just (stripField 6 line)) dataLines             | ":" `BS.isPrefixOf` line ->                 loop eventType dataLines -- comment, skip             | otherwise ->@@ -72,11 +86,38 @@               then BS.tail rest               else rest -      fireEvent :: Maybe Text -> [ByteString] -> IO ()+      fireEvent :: Maybe ByteString -> [ByteString] -> IO ()       fireEvent eventType dataLines =-        callback-          SSEEvent-            { sseEvent = eventType,-              sseData = TE.decodeUtf8 (BS.intercalate "\n" (reverse dataLines))-            }+        case (traverse TE.decodeUtf8' eventType, TE.decodeUtf8' (BS.intercalate "\n" (reverse dataLines))) of+          (Right name, Right dat) -> callback SSEEvent {sseEvent = name, sseData = dat}+          (Left err, _) -> invalid err+          (_, Left err) -> invalid err+        where+          invalid err =+            modifyIORef' badRef (<|> Just ("stream event is not valid UTF-8: " <> T.pack (show err)))   loop Nothing []+  readIORef badRef++-- | Message for a data event that should be JSON but is not, with a short+-- excerpt of the data.+malformedEvent :: Text -> Text+malformedEvent raw =+  "stream event is not valid JSON: " <> excerpt+  where+    excerpt+      | T.length raw > 200 = T.take 200 raw <> "..."+      | otherwise = raw++-- | Stream-level failure of a parsed stream, given the name of the+-- protocol's end-of-stream marker, whether it was seen, and the first+-- malformed event (if any).+--+-- Parsers check this after in-band provider errors and before their own+-- content checks. A missing marker is a retryable 'NetworkError': the+-- connection closed early, and a malformed final event is usually just the+-- cut-off tail of that.+streamFailure :: Text -> Bool -> Maybe Text -> Maybe LLMError+streamFailure marker complete malformed+  | not complete = Just (NetworkError ("stream ended before " <> marker))+  | Just msg <- malformed = Just (ParseError msg)+  | otherwise = Nothing

@@ -6,6 +6,7 @@     withRetry,     withTimeout,     withFirstEventTimeout,+    interruptOnAbort,     trySync,     streamResponseJson,     printValue,@@ -37,6 +38,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Unique (Unique, newUnique)+import LLM.Core.Abort (AbortSignal, isAborted, waitAborted) import LLM.Core.Types   ( ChatResponse (..),     ContentPart (..),@@ -109,6 +111,42 @@     (guard . (== ex))     (\_ -> pure (Left TimeoutError))     (bracket watchdog (uninterruptibleMask_ . killThread) (\_ -> run onEvent'))++-- | Run an action, interrupting it when the abort signal fires. Returns+-- 'Nothing' if the signal had fired before the action started, or fired+-- while it ran. In the second case the action received an asynchronous+-- exception, so its 'bracket' cleanups (such as closing an HTTP connection)+-- have run. With no signal, the action runs normally.+--+-- The action stays on the calling thread. A watchdog thread waits for the+-- signal and throws to it. Code that catches every exception, asynchronous+-- ones included, can swallow the interrupt and keep running.+interruptOnAbort :: Maybe AbortSignal -> IO a -> IO (Maybe a)+interruptOnAbort Nothing act = Just <$> act+interruptOnAbort (Just sig) act = do+  aborted <- isAborted sig+  if aborted+    then pure Nothing+    else do+      caller <- myThreadId+      ex <- AbortInterrupt <$> newUnique+      let watchdog = forkIOWithUnmask $ \unmask -> unmask $ do+            waitAborted sig+            throwTo caller ex+      handleJust+        (guard . (== ex))+        (\_ -> pure Nothing)+        (bracket watchdog (uninterruptibleMask_ . killThread) (\_ -> Just <$> act))++newtype AbortInterrupt = AbortInterrupt Unique+  deriving (Eq)++instance Show AbortInterrupt where+  show _ = "<<aborted>>"++instance Exception AbortInterrupt where+  toException = asyncExceptionToException+  fromException = asyncExceptionFromException  -- | Like @try \@SomeException@, but re-throws asynchronous exceptions -- ('System.Timeout.timeout', 'Control.Concurrent.killThread', @cancel@), so

@@ -130,8 +130,9 @@             writeIORef emittedRef False           ProviderStreamCallback {pscOnEvent, pscFinalize} <-             mkProviderStreamCallback gr onChunk'-          -- Cut the stream off at the first event after the abort signal-          -- fired: the callback throws out of the provider's stream reader.+          -- Deliver no event after the abort signal fired. ('callWithRetry'+          -- also interrupts the attempt, but asynchronously, so an event+          -- could otherwise slip through first.)           let onEvent e = do                 aborted <- isAbortedMaybe gr.grAbortSignal                 if aborted then throwIO StreamAborted else pscOnEvent e

@@ -16,6 +16,7 @@ import Data.Text (Text) import Data.Text qualified as T import Data.List (nub)+import Data.Maybe (fromMaybe) import LLM.Core.Abort (isAbortedMaybe) import LLM.Core.Types   ( ChatRequest (..),@@ -30,7 +31,7 @@     conversationHasImages,   ) import LLM.Core.Usage (Usage (..), estimateCost)-import LLM.Core.Utils (withRetry, withTimeout)+import LLM.Core.Utils (interruptOnAbort, withRetry, withTimeout) import LLM.Generate.Logger (Hooks (..), LogLevel (..)) import LLM.Generate.ModelConfig   ( ModelCapabilities (..),@@ -139,14 +140,25 @@  -- | Run one model call with the model's throttle delay and retry policy. -- @attempt@ is run once per try; any per-attempt timeout must be inside it.+--+-- 'mcThrottleDelay' is slept before every try, retries included. Before a+-- retry it comes after the retry backoff, so the two delays add up.+--+-- When 'grAbortSignal' fires, the call is interrupted wherever it is (in an+-- attempt, or in the throttle or backoff sleep) and returns 'Aborted'. An+-- interrupted attempt is cancelled, which closes its HTTP connection. callWithRetry ::   GenRequest ->   ModelConfig ->   IO (Either LLMError a) ->   IO (Either LLMError a) callWithRetry gr mc attempt =-  maybeThrottle mc.mcThrottleDelay $-    withRetry (modelRetryPolicy mc) (gr.grHooks.onLog Warn) (unlessAborted gr attempt)+  fmap (fromMaybe (Left Aborted)) $+    interruptOnAbort gr.grAbortSignal $+      withRetry+        (modelRetryPolicy mc)+        (gr.grHooks.onLog Warn)+        (maybeThrottle mc.mcThrottleDelay (unlessAborted gr attempt))  -- | Run @act@ unless 'grAbortSignal' has fired, else return 'Aborted' -- (which is not retried). Checked before every attempt, so also after

@@ -13,18 +13,19 @@   ) where +import Control.Exception (bracket) import Control.Monad (void) import Data.Aeson (Value) import Data.Aeson.Encode.Pretty (encodePretty) import Data.ByteString.Lazy qualified as BSL+import Data.Char (isAlphaNum, isAscii) import Data.Text (Text) import Data.Text qualified as T import Data.Text.IO qualified as TIO import Data.Time.Clock.POSIX (getPOSIXTime) import LLM.Core.Utils (trySync) import System.Directory (createDirectoryIfMissing)-import System.FilePath ((</>))-import System.IO (stderr)+import System.IO (hClose, openBinaryTempFile, stderr)  -- | Log verbosity levels, ordered from most to least verbose data LogLevel = Debug | Info | Warn | Error@@ -78,7 +79,13 @@ withStderrLogger minLvl h = h {onLog = stderrLogger minLvl}  -- | Add JSON request/response dumping to a directory.--- Files are named @{provider}-{request|response}-{timestamp}.json@.+--+-- Files are named @{provider}-{request|response}-{timestamp}-{unique}.json@,+-- where the timestamp is in milliseconds and @{unique}@ keeps dumps written+-- in the same millisecond apart. In the provider name, every character+-- other than an ASCII letter, digit, @-@ or @_@ becomes @_@, so the file+-- always lands in @dir@. Each file is created new, readable only by its+-- owner. withJsonDump :: FilePath -> Hooks -> Hooks withJsonDump dir h =   h@@ -95,8 +102,22 @@   createDirectoryIfMissing True dir   ts <- getPOSIXTime   let tsStr = show (round (ts * 1000) :: Integer)-      name = T.unpack provider <> "-" <> T.unpack label <> "-" <> tsStr <> ".json"-  BSL.writeFile (dir </> name) (encodePretty val)+      template = safeFileNamePart provider <> "-" <> safeFileNamePart label <> "-" <> tsStr <> "-.json"+  -- Creates the file exclusively under a fresh name (template plus a+  -- unique number), so concurrent dumps never overwrite each other.+  bracket (openBinaryTempFile dir template) (hClose . snd) $ \(_, h) ->+    BSL.hPut h (encodePretty val)++-- | Keep ASCII letters, digits, @-@ and @_@; replace everything else+-- (path separators, dots, spaces, ...) with @_@.+safeFileNamePart :: Text -> FilePath+safeFileNamePart t+  | T.null t = "_"+  | otherwise = map safeChar (T.unpack t)+  where+    safeChar c+      | isAscii c && (isAlphaNum c || c == '-' || c == '_') = c+      | otherwise = '_'  -- | Wrap all hook callbacks so synchronous exceptions are silently caught. -- Hooks are observability-only and should never abort control flow.

@@ -72,7 +72,8 @@     -- retry gets the full timeout; a timeout is retryable. For streaming it     -- bounds only the time until the first stream event.     mcRequestTimeout :: Maybe Int,-    -- | Delay in milliseconds before each API call (rate limiting).+    -- | Delay in milliseconds before each API call attempt, retries+    -- included (rate limiting). Before a retry it is added to the backoff.     mcThrottleDelay :: Maybe Int,     -- | Number of retries on retryable 'LLMError's before giving up on this model.     mcRetryCount :: Int,

@@ -35,10 +35,10 @@     grMessages :: [Turn],     -- | Tool definitions included in the provider request.     grTools :: [ToolDef],-    -- | Cooperative cancellation. Checked before each model in the fallback-    -- chain and before each attempt (also after throttle and backoff-    -- sleeps); a stream is cut off at its next event. A non-streaming HTTP-    -- call already in flight is not interrupted. Yields 'GErrAborted'.+    -- | Cancellation. Checked before each model in the fallback chain. A+    -- model call in flight (streaming or not, including its throttle and+    -- backoff sleeps) is interrupted when the signal fires, and its HTTP+    -- connection is closed. Yields 'GErrAborted'.     grAbortSignal :: Maybe AbortSignal,     -- | Provider wire hooks for raw request/response JSON.     grLLMHooks :: LLMHooks,@@ -67,7 +67,9 @@   { gerError :: GenerateError,     -- | Turns produced before the failure. Safe to append to the history:     -- every tool call has a result. On an abort during a tool round, calls-    -- that did not run get the result "Aborted before execution".+    -- that did not finish get the result "Aborted before execution". A call+    -- interrupted while running counts as not finished, though its side+    -- effects may have partly happened.     gerPartialNewMessages :: [Turn],     gerUsage :: Usage   }

@@ -15,9 +15,10 @@ where  import Configuration.Dotenv (defaultConfig, loadFile)-import Control.Exception (SomeException, catch, throwIO)+import Control.Exception (IOException, catch, throwIO) import Data.Map qualified as Map import Data.ByteString.Char8 qualified as B+import Data.Char (isDigit) import Data.Text (Text) import Data.Text qualified as T import LLM.Core.Types (LLMGateway)@@ -130,6 +131,11 @@  -- | Build the gateway for a provider, or say why it is unavailable. Never -- throws.+--+-- 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+-- 'InvalidBaseUrl'. resolveGateway :: ProviderCatalogItem -> IO (Either ProviderUnavailable LLMGateway) resolveGateway item = do   apiKey <- case item.apiKeyEnv of@@ -139,8 +145,38 @@   pure $ do     key <- apiKey     baseUrl <- either (Left . InvalidBaseUrl) Right (parseProviderBaseUrl baseUrlText)+    either (Left . InvalidBaseUrl) Right (checkKeyTransport item key baseUrlText)     pure (buildGateway item baseUrl key) +-- | Refuse a plain-HTTP base URL to a non-loopback host for a provider that+-- sends a non-empty API key. Ollama gateways never send a key.+checkKeyTransport :: ProviderCatalogItem -> Text -> Text -> Either Text ()+checkKeyTransport item key urlText+  | item.protocol == OllamaProtocol || T.null key = Right ()+  | otherwise = case HC.parseRequest (T.unpack urlText) of+      Right req+        | not (HC.secure req) && not (isLoopbackHost (HC.host req)) ->+            Left $+              "insecure baseUrl: "+                <> urlText+                <> " would send the API key unencrypted; use https, or http only to a loopback host"+      _ -> Right ()++-- | @localhost@, an IPv4 address in @127.0.0.0/8@, or @::1@.+isLoopbackHost :: B.ByteString -> Bool+isLoopbackHost raw =+  host `elem` ["localhost", "[::1]", "::1"] || isIPv4Loopback+  where+    host = T.toLower (T.dropWhileEnd (== '.') (T.pack (B.unpack raw)))+    isIPv4Loopback = case T.splitOn "." host of+      [a, b, c, d] -> a == "127" && all isOctet [b, c, d]+      _ -> False+    isOctet t =+      not (T.null t)+        && T.length t <= 3+        && T.all isDigit t+        && (read (T.unpack t) :: Int) <= 255+ -- | Resolve every provider in the catalog. See 'resolveGateway'. resolveGateways :: ProviderCatalogMap -> IO (Map.Map Text (Either ProviderUnavailable LLMGateway)) resolveGateways = traverse resolveGateway@@ -171,7 +207,10 @@  -- | Load @.env@ (if present) and then build a gateway map from the bundled -- default provider catalog.+--+-- A missing or unreadable @.env@ is ignored. A @.env@ that dotenv cannot+-- parse is not: its error is rethrown, as are asynchronous exceptions. loadGatewaysWithDotenv :: IO GatewayMap loadGatewaysWithDotenv = do-  loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+  loadFile defaultConfig `catch` \(_ :: IOException) -> pure ()   loadGateways

@@ -27,19 +27,21 @@     (.:?),   ) import Data.Aeson.KeyMap qualified as KM-import Data.Aeson.Types (Object, Pair, Parser, parseMaybe)+import Data.Aeson.Types (Object, Pair, Parser, parseEither, parseMaybe) import Data.ByteString qualified as BS import Data.Foldable (for_) import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)-import Data.Maybe (catMaybes, fromMaybe, mapMaybe)+import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe)+import Control.Monad (when)+import Data.Char (isSpace) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy qualified as TL import Data.Text.Lazy.Encoding (decodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, stripJsonFences)-import LLM.Core.SSE (SSEEvent (sseData, sseEvent), readSSEEvents)+import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, unexpectedResponse)+import LLM.Core.SSE (SSEEvent (sseData, sseEvent), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( commonImageMediaTypes,     CacheHint (..),@@ -448,26 +450,24 @@         usageTotalCost = 0       } +-- | The JSON text of the first text block. No text block is+-- 'EmptyResponse'; invalid JSON text or a body without @content@ is a+-- 'ParseError' (see 'decodeObjectText' and 'unexpectedResponse'). parseClaudeObjectResponse :: Value -> IO (LLMResult (Value, Maybe Usage))-parseClaudeObjectResponse v = case parseMaybe go v of-  Nothing -> pure $ Left EmptyResponse-  Just text -> case decodeStrict' (encodeUtf8 (stripJsonFences text)) of-    Nothing -> pure $ Left EmptyResponse-    Just obj -> pure $ Right (obj, parseClaudeUsage v)+parseClaudeObjectResponse v = pure $ case parseEither go v of+  Left err -> Left (unexpectedResponse err v)+  Right [] -> Left EmptyResponse+  Right (text : _) -> (\obj -> (obj, parseClaudeUsage v)) <$> decodeObjectText text   where-    go :: Value -> Parser Text+    go :: Value -> Parser [Text]     go = withObject "ClaudeResponse" $ \o -> do       content <- o .: "content" :: Parser [Value]-      texts <- mapMaybeM textOf content-      case texts of-        (t : _) -> pure t-        _ -> fail "No content"+      pure (mapMaybe textOf content)     textOf = parseMaybe $ withObject "content_block" $ \o -> do       typ <- o .: "type" :: Parser Text       case typ of         "text" -> o .: "text"         _ -> fail "not text"-    mapMaybeM f xs = pure (mapMaybe f xs)  -- Streaming ------------------------------------------------------------------ @@ -488,13 +488,19 @@   errorRef <- newIORef (Nothing :: Maybe LLMError)   stopReasonRef <- newIORef (Nothing :: Maybe Text)   badToolRef <- newIORef (Nothing :: Maybe Text) -- first tool with invalid JSON args-  readSSEEvents readChunk $ \sse -> do+  stoppedRef <- newIORef False+  malformedRef <- newIORef (Nothing :: Maybe Text)+  badUtf8 <- readSSEEvents readChunk $ \sse -> do+    let mv = decodeStrict' (encodeUtf8 sse.sseData) :: Maybe Value+    when (isNothing mv && sse.sseEvent /= Just "error" && not (T.all isSpace sse.sseData)) $+      modifyIORef' malformedRef (<|> Just (malformedEvent sse.sseData))     case sse.sseEvent of       Just "error" -> do-        let status = maybe 500 claudeErrorStatus (parseMaybe parseErrorType =<< decodeStrict' (encodeUtf8 sse.sseData))+        let status = maybe 500 claudeErrorStatus (parseMaybe parseErrorType =<< mv)         modifyIORef' errorRef (<|> Just (HttpError status sse.sseData))+      Just "message_stop" -> writeIORef stoppedRef True       Just "message_start" ->-        case decodeStrict' (encodeUtf8 sse.sseData) of+        case mv of           Just v -> do             case parseMaybe parseMessageStartUsage v of               Just startUsage -> modifyIORef' usageRef $ \u ->@@ -509,7 +515,7 @@               (writeIORef modelRef)           Nothing -> pure ()       Just "content_block_start" ->-        case decodeStrict' (encodeUtf8 sse.sseData) of+        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))@@ -518,7 +524,7 @@             Nothing -> pure ()           Nothing -> pure ()       Just "content_block_delta" ->-        case decodeStrict' (encodeUtf8 sse.sseData) of+        case mv of           Just v -> do             case parseMaybe parseTextDelta v of               Just txt -> do@@ -563,7 +569,7 @@             writeIORef toolAccRef Nothing           Nothing -> pure ()       Just "message_delta" ->-        case decodeStrict' (encodeUtf8 sse.sseData) of+        case mv of           Just v -> do             case parseMaybe parseMessageDeltaUsage v of               Just outputToks -> modifyIORef' usageRef $ \u -> u {usageOutputTokens = outputToks}@@ -577,9 +583,11 @@   mError <- readIORef errorRef   mBadTool <- readIORef badToolRef   stopReason <- readIORef stopReasonRef+  stopped <- readIORef stoppedRef+  malformed <- (badUtf8 <|>) <$> readIORef malformedRef   let parts = map (streamBlockToPart model) rawBlocks       truncated = if stopReason == Just "max_tokens" then stopReason else Nothing-  pure $ case (mError, mBadTool) of+  pure $ case (mError <|> streamFailure "message_stop" stopped malformed, mBadTool) of     (Just err, _) -> Left err     (Nothing, Just name) -> Left (invalidToolArgumentsError name truncated)     _

@@ -10,19 +10,15 @@ import Data.Aeson   ( KeyValue ((.=)),     Value,-    decodeStrict',     encode,     object,-    withObject,-    (.:),   )-import Data.Aeson.Types (Pair, Parser, parseMaybe)+import Data.Aeson.Types (Pair) import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8) 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, stripJsonFences)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig) import LLM.Core.Types   ( commonImageMediaTypes,     ChatRequest@@ -33,7 +29,6 @@         reqThinking,         reqTools       ),-    LLMError (EmptyResponse),     LLMGateway,     MessageEncodeOptions (..),     ThinkingMode (..),@@ -44,9 +39,9 @@   ( authHeader,     buildMessages,     encodeToolDef,+    parseOpenAIObjectResponse,     parseOpenAIResponse,     parseOpenAIStream,-    parseOpenAIUsage,   ) import Network.HTTP.Req   ( Option,@@ -103,11 +98,7 @@               deepSeekBuildBodyPairs False r'                 <> ["response_format" .= object ["type" .= ("json_object" :: Text)]],       sendObjectRequest = sendRequest,-      parseObjectResponse = \v -> case parseMaybe parseObject v of-        Nothing -> pure $ Left EmptyResponse-        Just contentStr -> case decodeStrict' (encodeUtf8 (stripJsonFences contentStr)) of-          Nothing -> pure $ Left EmptyResponse-          Just obj -> pure $ Right (obj, parseOpenAIUsage v)+      parseObjectResponse = pure . parseOpenAIObjectResponse     }   where     sendRequest body =@@ -116,10 +107,6 @@             opts = baseOpts <> authHeader apiKey         resp <- req POST url (ReqBodyJson body) bsResponse opts         pure (responseStatusCode resp, responseBody resp)-    parseObject :: Value -> Parser Text-    parseObject = withObject "OpenAIObjectResponse" $ \o -> do-      (choice : _) <- o .: "choices" :: Parser [Value]-      withObject "choice" (\co -> co .: "message" >>= withObject "message" (.: "content")) choice  -- | OpenAI-compatible body; DeepSeek uses @max_tokens@ (not @max_completion_tokens@). deepSeekBuildBody :: Bool -> ChatRequest -> Value

@@ -27,8 +27,8 @@ import Data.Aeson.KeyMap qualified as KM import Data.Aeson.Types (Pair, Parser, parseMaybe) import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)-import Data.Maybe (catMaybes, fromMaybe, mapMaybe)-import Data.Char (isDigit)+import Data.Maybe (catMaybes, fromMaybe, isJust, mapMaybe)+import Data.Char (isDigit, isSpace) import Data.Foldable (for_) import Data.Text (Text) import Data.Text qualified as T@@ -36,8 +36,8 @@ import Data.UUID.Types (UUID) import Data.UUID.Types qualified as UUID import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, stripBoundsAndComments, stripJsonFences)-import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents)+import LLM.Core.ProviderUtils (decodeObjectText, handleStreamResponse, lenientConfig, stripBoundsAndComments)+import LLM.Core.SSE (SSEEvent (sseData), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( supportedImageMediaTypes,     ChatRequest@@ -184,9 +184,12 @@   usageRef <- newIORef Nothing   errorRef <- newIORef (Nothing :: Maybe LLMError)   stopRef <- newIORef (Nothing :: Maybe GeminiStop)-  readSSEEvents (HC.brRead reader) $ \sse -> do+  malformedRef <- newIORef (Nothing :: Maybe Text)+  badUtf8 <- readSSEEvents (HC.brRead reader) $ \sse -> do     case decodeStrict' (encodeUtf8 sse.sseData) of-      Nothing -> pure ()+      Nothing+        | T.all isSpace sse.sseData -> pure ()+        | otherwise -> modifyIORef' malformedRef (<|> Just (malformedEvent sse.sseData))       Just v -> do         -- The stream stays HTTP 200 when it fails midway; the error arrives         -- as a data event. Keep the first one.@@ -206,7 +209,11 @@   usage <- readIORef usageRef   mError <- readIORef errorRef   stop <- readIORef stopRef-  pure $ case mError of+  malformed <- (badUtf8 <|>) <$> readIORef malformedRef+  -- The last chunk carries a finishReason; a blocked prompt carries a+  -- blockReason instead.+  let complete = isJust stop+  pure $ case mError <|> streamFailure "finishReason" complete malformed of     Just err -> Left err     Nothing       | null parts -> Left (noContentError stop)@@ -614,12 +621,12 @@ parseGeminiObjectResponse :: Value -> IO LLMObjectResult parseGeminiObjectResponse v = case parseMaybe go v of   Nothing -> pure $ Left (noContentError stop)-  Just text -> case decodeStrict' (encodeUtf8 (stripJsonFences text)) of-    Nothing+  Just text -> case decodeObjectText text of+    Left _       | Just (GeminiFinished "MAX_TOKENS") <- stop ->           pure $ Left $ ParseError "Gemini structured output was cut off (finishReason: MAX_TOKENS); increase max tokens"-      | otherwise -> pure $ Left EmptyResponse-    Just obj -> pure $ Right (obj, parseGeminiUsage v)+    Left err -> pure $ Left err+    Right obj -> pure $ Right (obj, parseGeminiUsage v)   where     stop = parseGeminiStop v 

@@ -8,17 +8,12 @@  import Data.Aeson   ( KeyValue ((.=)),-    Value,-    decodeStrict',     object,-    withObject,-    (.:),   )-import Data.Aeson.Types (Pair, Parser, parseMaybe)+import Data.Aeson.Types (Pair) import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI, stripJsonFences)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI) import LLM.Core.Types   ( commonImageMediaTypes,     ChatRequest@@ -27,11 +22,10 @@         reqTemperature,         reqTools       ),-    LLMError (EmptyResponse),     LLMGateway,     defaultMessageEncodeOptions,   )-import LLM.Providers.OpenAI (buildMessages, encodeToolDef, parseOpenAIResponse, parseOpenAIStream, parseOpenAIUsage)+import LLM.Providers.OpenAI (buildMessages, encodeToolDef, parseOpenAIObjectResponse, parseOpenAIResponse, parseOpenAIStream) import Network.HTTP.Req   ( Option,     POST (POST),@@ -92,11 +86,7 @@                      ]                ],       sendObjectRequest = sendRequest,-      parseObjectResponse = \v -> case parseMaybe parseObject v of-        Nothing -> pure $ Left EmptyResponse-        Just contentStr -> case decodeStrict' (encodeUtf8 (stripJsonFences contentStr)) of-          Nothing -> pure $ Left EmptyResponse-          Just obj -> pure $ Right (obj, parseOpenAIUsage v)+      parseObjectResponse = pure . parseOpenAIObjectResponse     }   where     sendRequest body =@@ -104,10 +94,6 @@         let url = baseUrl /: "v1" /: "chat" /: "completions"         resp <- req POST url (ReqBodyJson body) bsResponse baseOpts         pure (responseStatusCode resp, responseBody resp)-    parseObject :: Value -> Parser Text-    parseObject = withObject "OpenAIObjectResponse" $ \o -> do-      (choice : _) <- o .: "choices" :: Parser [Value]-      withObject "choice" (\co -> co .: "message" >>= withObject "message" (.: "content")) choice  -- | Request body for Ollama's OpenAI-compatible endpoint. Like OpenAI's, but -- the token limit is @max_tokens@: Ollama ignores @max_completion_tokens@

@@ -6,6 +6,7 @@     openAIProviderWith,     openAIProviderWithName,     parseOpenAIResponse,+    parseOpenAIObjectResponse,     parseOpenAIUsage,     buildMessages,     encodeTurn,@@ -30,7 +31,7 @@     (.:),     (.:?),   )-import Data.Aeson.Types (Pair, Parser, parseMaybe)+import Data.Aeson.Types (Pair, Parser, parseEither, parseMaybe) import Data.ByteString.Lazy qualified as BSL import Control.Monad (when, zipWithM) import Data.Either (lefts, rights)@@ -39,12 +40,13 @@ import Data.Map.Strict qualified as Map import Data.Maybe (catMaybes, fromMaybe, mapMaybe) import Control.Applicative ((<|>))+import Data.Char (isSpace) import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding (decodeUtf8, encodeUtf8) import LLM.Core.LLMProvider (LLMProvider (..), toGateway)-import LLM.Core.ProviderUtils (decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, normalizeSchemaOpenAI, stripJsonFences)-import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents)+import LLM.Core.ProviderUtils (decodeObjectText, decodeToolArguments, handleStreamResponse, invalidToolArgumentsError, lenientConfig, normalizeSchemaOpenAI, unexpectedResponse)+import LLM.Core.SSE (SSEEvent (sseData), malformedEvent, readSSEEvents, streamFailure) import LLM.Core.Types   ( commonImageMediaTypes,     projectReasoning,@@ -60,6 +62,7 @@     ContentPart (..),     LLMError (EmptyResponse, HttpError),     LLMGateway,+    LLMResult,     LLMTextResult,     MessageEncodeOptions (..),     PartBody (..),@@ -150,16 +153,7 @@                      ]                ],       sendObjectRequest = sendRequest,-      parseObjectResponse = \v ->-        let parseObject :: Value -> Parser Text-            parseObject = withObject "OpenAIObjectResponse" $ \o -> do-              (choice : _) <- o .: "choices" :: Parser [Value]-              withObject "choice" (\co -> co .: "message" >>= withObject "message" (.: "content")) choice-         in case parseMaybe parseObject v of-              Nothing -> pure $ Left EmptyResponse-              Just contentStr -> case decodeStrict' (encodeUtf8 (stripJsonFences contentStr)) of-                Nothing -> pure $ Left EmptyResponse-                Just obj -> pure $ Right (obj, parseOpenAIUsage v)+      parseObjectResponse = pure . parseOpenAIObjectResponse     }   where     sendRequest body =@@ -358,6 +352,27 @@ truncationReason :: Maybe Text -> Maybe Text truncationReason r = if r == Just "length" then r else Nothing +-- | Parse a structured-output response from an OpenAI-compatible chat+-- completions API: the JSON text in the first choice's message content.+--+-- No choice, or a missing or null content, is 'EmptyResponse'; so is+-- content that is empty once code fences are stripped. Content that is not+-- valid JSON, and a body without the expected fields, are 'ParseError's+-- that quote the decoder's message and the start of the text or body.+parseOpenAIObjectResponse :: Value -> LLMResult (Value, Maybe Usage)+parseOpenAIObjectResponse v = case parseEither content v of+  Left err -> Left (unexpectedResponse err v)+  Right Nothing -> Left EmptyResponse+  Right (Just text) -> (\obj -> (obj, parseOpenAIUsage v)) <$> decodeObjectText text+  where+    content :: Value -> Parser (Maybe Text)+    content = withObject "OpenAIObjectResponse" $ \o -> do+      choices <- o .: "choices" :: Parser [Value]+      case choices of+        [] -> pure Nothing+        choice : _ ->+          withObject "choice" (\co -> co .: "message" >>= withObject "message" (.:? "content")) choice+ parseOpenAIUsage :: Value -> Maybe Usage parseOpenAIUsage = parseMaybe $ withObject "OpenAIResponse" $ \o -> do   u <- o .: "usage"@@ -419,12 +434,18 @@               callback (StreamToolCall tc)             Nothing -> modifyIORef' badToolRef (<|> Just name)         writeIORef toolAccRef Map.empty-  readSSEEvents (HC.brRead reader) $ \sse -> do+  -- Set by @[DONE]@ or a non-null @finish_reason@. Some compatible servers+  -- send only one of the two.+  doneRef <- newIORef False+  malformedRef <- newIORef (Nothing :: Maybe Text)+  badUtf8 <- readSSEEvents (HC.brRead reader) $ \sse -> do     let raw = sse.sseData     if raw == "[DONE]"-      then pure ()+      then writeIORef doneRef True       else case decodeStrict' (encodeUtf8 raw) of-        Nothing -> pure ()+        Nothing+          | T.all isSpace raw -> pure ()+          | otherwise -> modifyIORef' malformedRef (<|> Just (malformedEvent raw))         Just v -> do           for_ (parseMaybe parseStreamError v) $ \status ->             modifyIORef' errorRef (<|> Just (HttpError status raw))@@ -443,6 +464,7 @@           case parseMaybe parseFinishReason v of             Just reason -> do               writeIORef finishReasonRef (Just reason)+              writeIORef doneRef True               when (reason == "tool_calls") flushTools             Nothing -> pure ()           case parseMaybe parseStreamUsage v of@@ -461,7 +483,9 @@   mError <- readIORef errorRef   mBadTool <- readIORef badToolRef   finishReason <- readIORef finishReasonRef-  pure $ case (mError, mBadTool) of+  done <- readIORef doneRef+  malformed <- (badUtf8 <|>) <$> readIORef malformedRef+  pure $ case (mError <|> streamFailure "[DONE] or finish_reason" done malformed, mBadTool) of     (Just err, _) -> Left err     (Nothing, Just name) -> Left (invalidToolArgumentsError name (truncationReason finishReason))     _

@@ -7,7 +7,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath, sandboxSymlink, sandboxWritePath)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, sandboxSymlink, sandboxWritePath, withWorkspacePaths) import System.Directory (copyFile, doesDirectoryExist, doesFileExist, doesPathExist)  data CopyFileToolArgs = CopyFileToolArgs@@ -33,7 +33,7 @@           <> "Overwrites the destination if it already exists. "           <> "Creates parent directories at the destination as needed.",       ttoolReadonly = False,-      ttoolExecute = const (copyFileExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . copyFileExecTyped cfg)     }  copyFileExecTyped :: FsConfig -> CopyFileToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import System.Directory (createDirectoryIfMissing)  data CreateDirectoryToolArgs = CreateDirectoryToolArgs@@ -32,7 +32,7 @@           <> "When 'parents' is true (the default), intermediate directories are created as needed "           <> "and no error is raised if the directory already exists.",       ttoolReadonly = False,-      ttoolExecute = const (createDirectoryExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . createDirectoryExecTyped cfg)     }  createDirectoryExecTyped :: FsConfig -> CreateDirectoryToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (cheapWalkDepth, maxTreeEntries) import System.Directory   ( doesDirectoryExist,@@ -40,7 +40,7 @@           <> T.pack (show maxTreeEntries)           <> " entries; truncation is reported in the header.",       ttoolReadonly = True,-      ttoolExecute = const (directoryTreeExecTyped fsConfig)+      ttoolExecute = const (withWorkspacePaths fsConfig . directoryTreeExecTyped fsConfig)     }  directoryTreeExecTyped :: FsConfig -> DirectoryTreeToolArgs -> IO Text

@@ -6,15 +6,15 @@  import Autodocodec qualified as AC import Control.Exception (IOException, try)+import Control.Monad (join) import Data.Aeson (FromJSON)-import Data.ByteString qualified as BS import Data.Text (Text) import Data.Text qualified as T import Data.Time.Clock (UTCTime) import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)-import LLM.Tools.FsLimits (readTextFileLenient)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths)+import LLM.Tools.Internal.TextFile (readLenient, withTextHandle) import System.Directory   ( Permissions (..),     doesDirectoryExist,@@ -26,11 +26,7 @@     listDirectory,     pathIsSymbolicLink,   )-import System.IO (IOMode (ReadMode), withBinaryFile)---- | Number of leading bytes inspected when sniffing for binary content.-binarySniffBytes :: Int-binarySniffBytes = 8192+import System.IO (Handle, IOMode (ReadMode), withBinaryFile)  -- | Skip line-counting on files larger than this (bytes). For large text -- files the line count is reported as "unknown (file too large)" so the@@ -69,7 +65,7 @@           <> "Reports clearly if the path does not exist. "           <> "Use this before read_file_paginated to decide whether a file is worth reading.",       ttoolReadonly = True,-      ttoolExecute = const (execute cfg)+      ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }  execute :: FsConfig -> FileInfoToolArgs -> IO Text@@ -103,14 +99,15 @@   IO Text renderFileInfo rel resolved isLink perms mtime = do   size <- safeGetFileSize resolved-  isBin <- detectBinary resolved-  lineCount <--    if isBin-      then pure Nothing-      else case size of-        Just n | n <= maxLineCountBytes -> safeLineCount resolved+  -- 'Nothing' if the file looks binary or cannot be read.+  sniffed <-+    withTextHandle (withBinaryFile resolved ReadMode) $ \h ->+      case size of+        Just n | n <= maxLineCountBytes -> safeLineCount h         _ -> pure Nothing-  let header =+  let isBin = null sniffed+      lineCount = join sniffed+      header =         "=== "           <> rel           <> " | file"@@ -217,9 +214,9 @@     Right xs -> xs     Left _ -> [] -safeLineCount :: FilePath -> IO (Maybe Int)-safeLineCount p = do-  r <- try (readTextFileLenient p) :: IO (Either IOException Text)+safeLineCount :: Handle -> IO (Maybe Int)+safeLineCount h = do+  r <- try (readLenient h) :: IO (Either IOException Text)   pure $ case r of     Right content -> Just (length (T.lines content))     Left _ -> Nothing@@ -227,14 +224,3 @@ eitherToMaybe :: Either e a -> Maybe a eitherToMaybe (Right a) = Just a eitherToMaybe (Left _) = Nothing---- | NUL byte in the first few KB is a robust, cheap binary heuristic--- (the same one used by git diff and grep).-detectBinary :: FilePath -> IO Bool-detectBinary path = do-  r <--    try (withBinaryFile path ReadMode (`BS.hGet` binarySniffBytes)) ::-      IO (Either IOException BS.ByteString)-  pure $ case r of-    Right bs -> BS.elem 0 bs-    Left _ -> True

@@ -13,7 +13,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (cheapWalkDepth) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>))@@ -96,7 +96,7 @@           <> "Output is capped at 'maxResults' (default 200, hard cap 2000); "           <> "the header reports whether results were truncated and how many entries were scanned.",       ttoolReadonly = True,-      ttoolExecute = const (execute cfg)+      ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }  execute :: FsConfig -> FindFilesToolArgs -> IO Text

@@ -2,6 +2,7 @@   ( FsConfig (..),     SandboxViolation (..),     formatSandboxViolation,+    withWorkspacePaths,     mkFsConfig,     sandboxPath,     sandboxWritePath,@@ -12,13 +13,16 @@   ) where -import Control.Exception (Exception, IOException, throwIO, try)+import Control.Exception (Exception, IOException, handle, throwIO, try) import Control.Monad (when) import Data.List (foldl') import Data.Text (Text) import Data.Text qualified as T import System.Directory (canonicalizePath, createDirectoryIfMissing, doesPathExist, pathIsSymbolicLink)-import System.FilePath (addTrailingPathSeparator, dropTrailingPathSeparator, equalFilePath, joinPath, normalise, splitDirectories, splitFileName, takeDirectory, (</>))+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, (</>))  -- | Configuration for file-system tools. -- 'fsBasePath' must be a canonical absolute path (use 'mkFsConfig').@@ -49,6 +53,24 @@     Nothing ->       "Sandbox violation: path is outside the workspace" +-- | Run a filesystem tool's action so that an 'IOException' it throws names+-- its file relative to the workspace root (@.@ for the root itself)+-- instead of by its absolute host path. A file outside the workspace is+-- left out of the error. The error is rethrown; other exceptions pass+-- through unchanged. The bundled tools all run inside this, so the model+-- never sees where the workspace lives on the host.+withWorkspacePaths :: FsConfig -> IO a -> IO a+withWorkspacePaths cfg = handle $ \(e :: IOException) ->+  throwIO e {ioe_filename = ioe_filename e >>= workspaceRelative}+  where+    baseComps = splitDirectories (dropTrailingPathSeparator cfg.fsBasePath)+    workspaceRelative f+      | isRelative f = Just f+      | otherwise = case stripPathPrefix baseComps (splitDirectories f) of+          Just [] -> Just "."+          Just comps -> Just (joinPath comps)+          Nothing -> Nothing+ -- | Create an 'FsConfig' by canonicalizing the given base directory. -- The directory must already exist. mkFsConfig :: FilePath -> IO FsConfig@@ -83,9 +105,9 @@       -- 'canonical' and refuse any symlink encountered: since the       -- canonical chain should not contain symlinks by construction, any       -- symlink found here is a fresh injection. Note: this narrows but-      -- does not fully close the TOCTOU window; a complete fix requires-      -- fd-relative ('openat') APIs not available in the portable-      -- 'directory' package.+      -- does not close the TOCTOU window. That is accepted: the tools+      -- cannot create symlinks, so only another process writing to the+      -- workspace can exploit it (see the threat model in the README).       verifyNoSymlinksInChain base (joinPath baseComps) tailComps       pure canonical @@ -216,10 +238,18 @@   if exists then pure True else isSymlink p  -- | Check whether a path is a symbolic link (without following it).--- Returns 'False' if the path doesn't exist or can't be stat'd.+--+-- 'False' if nothing exists at the path: either it is missing, or a+-- component on the way is not a directory (ENOTDIR). If the lookup fails+-- for any other reason (permission denied, a symlink loop, ...), the+-- answer is 'True': the path cannot be shown to be safe, and every caller+-- refuses or skips a symlink. isSymlink :: FilePath -> IO Bool isSymlink p = do   r <- try (pathIsSymbolicLink p) :: IO (Either IOException Bool)   case r of     Right b -> pure b-    Left _ -> pure False+    Left e -> pure (not (isMissing e))+  where+    isMissing e = isDoesNotExistError e || ioe_errno e == Just enotdir+    Errno enotdir = eNOTDIR

@@ -33,10 +33,14 @@ import Control.Exception (IOException, try) import Data.ByteString qualified as BS import Data.Text (Text)-import Data.Text qualified as T-import Data.Text.Encoding (decodeUtf8', decodeUtf8With, encodeUtf8)+import Data.Text.Encoding (decodeUtf8With, encodeUtf8) import Data.Text.Encoding.Error (lenientDecode)-import System.IO (IOMode (ReadMode), hFileSize, withBinaryFile)+import LLM.Tools.Internal.TextFile+  ( binarySniffBytes,+    readBoundedTextWith,+    readBoundedUtf8With,+  )+import System.IO (IOMode (ReadMode), withBinaryFile)  -- | Maximum directory depth for traversals that only stat entries. cheapWalkDepth :: Int@@ -66,12 +70,6 @@ maxTreeEntries :: Int maxTreeEntries = 2000 --- | Number of leading bytes inspected when sniffing for binary content.--- Matches the heuristic used by @git diff@ and @grep@: any NUL byte in--- the prefix means binary.-binarySniffBytes :: Int-binarySniffBytes = 8192- -- | 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).@@ -88,18 +86,12 @@ -- become U+FFFD, so never write the result back; edit tools use -- 'readBoundedUtf8File'. readBoundedTextFile :: FilePath -> Text -> Int -> IO (Either Text Text)-readBoundedTextFile path display cap =-  fmap (decodeUtf8With lenientDecode) <$> readBoundedBytes path display cap+readBoundedTextFile path = readBoundedTextWith (withBinaryFile path ReadMode)  -- | Read a text file up to @cap@ bytes for editing. Refuses files that are -- not valid UTF-8, since writing them back would destroy their bytes. readBoundedUtf8File :: FilePath -> Text -> Int -> IO (Either Text Text)-readBoundedUtf8File path display cap = do-  r <- readBoundedBytes path display cap-  pure $-    r >>= \bs -> case decodeUtf8' bs of-      Right t -> Right t-      Left _ -> Left $ display <> " is not valid UTF-8; refusing to edit it."+readBoundedUtf8File path = readBoundedUtf8With (withBinaryFile path ReadMode)  -- | Read a whole file as UTF-8, replacing invalid bytes with U+FFFD. -- Independent of the locale. For read-only use.@@ -109,59 +101,3 @@ -- | Write text as UTF-8, independent of the locale. writeUtf8File :: FilePath -> Text -> IO () writeUtf8File path = BS.writeFile path . encodeUtf8---- | Read a file up to @cap@ bytes. Refuses binary files, checks size--- before reading, and performs a bounded read to mitigate TOCTOU growth.-readBoundedBytes :: FilePath -> Text -> Int -> IO (Either Text BS.ByteString)-readBoundedBytes path display cap = do-  isBinary <- detectBinary path-  if isBinary-    then-      pure $-        Left $-          display-            <> " appears to be a binary file; only text files are supported."-    else do-      sizeRes <--        try (withBinaryFile path ReadMode hFileSize) ::-          IO (Either IOException Integer)-      case sizeRes of-        Left e ->-          pure $-            Left $-              "could not stat "-                <> display-                <> ": "-                <> T.pack (show e)-        Right sz-          | sz > fromIntegral cap ->-              pure $-                Left $-                  display-                    <> " is "-                    <> T.pack (show sz)-                    <> " bytes, which exceeds the "-                    <> T.pack (show cap)-                    <> "-byte cap."-          | otherwise -> do-              bsRes <--                try (withBinaryFile path ReadMode (`BS.hGet` (cap + 1))) ::-                  IO (Either IOException BS.ByteString)-              case bsRes of-                Left e ->-                  pure $-                    Left $-                      "could not read "-                        <> display-                        <> ": "-                        <> T.pack (show e)-                Right bs-                  | BS.length bs > cap ->-                      pure $-                        Left $-                          display-                            <> " grew past the "-                            <> T.pack (show cap)-                            <> "-byte cap during the read."-                  | otherwise ->-                      pure (Right bs)

@@ -7,14 +7,14 @@ import Autodocodec qualified as AC import Control.Exception (IOException, try) import Data.Aeson (FromJSON)-import Data.ByteString qualified as BS import Data.List (sort) import Data.Text (Text) import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath)-import LLM.Tools.FsLimits (binarySniffBytes, expensiveWalkDepth, readTextFileLenient)+import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths)+import LLM.Tools.FsLimits (expensiveWalkDepth)+import LLM.Tools.Internal.TextFile (readLenient, withTextHandle) import System.Directory   ( doesDirectoryExist,     doesFileExist,@@ -100,7 +100,7 @@           <> "Output is capped at 'maxResults' lines (default 50, hard cap 500); "           <> "the header reports whether results were truncated and how many files were scanned.",       ttoolReadonly = True,-      ttoolExecute = const (execute cfg)+      ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }  execute :: FsConfig -> GrepToolArgs -> IO Text@@ -132,9 +132,9 @@             else do               files <-                 if isFile-                  then pure [resolved]-                  else collectFiles resolved 0 exts-              (matches, scanned, truncated) <- searchFiles resolved files pat ci cap+                  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  -- | Lowercase and strip leading dots so callers can pass "hs" or ".hs".@@ -143,18 +143,21 @@  -- | Recursively collect candidate files under a directory, respecting -- depth, hidden-file, extension, and size limits. Order is stable--- (directories sorted) so output is deterministic.-collectFiles :: FilePath -> Int -> [Text] -> IO [FilePath]-collectFiles _ depth _ | depth > maxDepth = pure []-collectFiles dir depth exts = do+-- (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 depth exts) visible+  results <- mapM (visit dir display depth exts) visible   pure (concat results) -visit :: FilePath -> Int -> [Text] -> FilePath -> IO [FilePath]-visit parent depth exts name = do+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@@ -162,13 +165,13 @@     else do       isDir <- doesDirectoryExist full       if isDir-        then collectFiles full (depth + 1) exts+        then collectFiles full fullDisplay (depth + 1) exts         else do           isFile <- doesFileExist full           if isFile && extensionAllowed exts name             then do               ok <- isSizeOk full-              pure [full | ok]+              pure [(full, fullDisplay) | ok]             else pure []  extensionAllowed :: [Text] -> FilePath -> Bool@@ -199,34 +202,30 @@ -- 'scanned' count reflects the full sweep. Returns (matches, files scanned, -- truncated?). searchFiles ::-  FilePath ->-  [FilePath] ->+  [(FilePath, FilePath)] ->   Text ->   Bool ->   Int ->   IO ([Match], Int, Bool)-searchFiles root files pat ci cap = go files [] 0 False+searchFiles files pat ci cap = go files [] 0 False   where     needle = if ci then T.toLower pat else pat     go [] acc scanned truncated = pure (reverse acc, scanned, truncated)-    go (f : rest) acc scanned truncated+    go ((f, display) : rest) acc scanned truncated       | length acc >= cap = go rest acc (scanned + 1) True       | otherwise = do-          isBin <- detectBinary f-          if isBin-            then go rest acc (scanned + 1) truncated-            else do-              r <--                try (readTextFileLenient f) ::-                  IO (Either IOException Text)-              case r of-                Left _ -> go rest acc (scanned + 1) truncated-                Right content -> do-                  let ms = matchLines (relativeTo root f) content needle ci-                      remaining = cap - length acc-                      taken = take remaining ms-                      truncated' = truncated || length ms > remaining-                  go rest (reverse taken ++ acc) (scanned + 1) truncated'+          -- 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,@@ -247,22 +246,6 @@   | T.length t <= maxLineLength = t   | otherwise = T.take maxLineLength t <> "…" --- | Make 'full' relative to 'root' for display. Falls back to 'full' if--- it isn't actually under 'root' (shouldn't happen post-sandbox).-relativeTo :: FilePath -> FilePath -> FilePath-relativeTo root full =-  let rootSlash = if null root || last root == '/' then root else root ++ "/"-   in case stripPrefixList rootSlash full of-        Just rel -> if null rel then takeFileName full else rel-        Nothing -> full--stripPrefixList :: String -> String -> Maybe String-stripPrefixList [] ys = Just ys-stripPrefixList _ [] = Nothing-stripPrefixList (x : xs) (y : ys)-  | x == y = stripPrefixList xs ys-  | otherwise = Nothing- renderResults :: Text -> Text -> [Match] -> Int -> Bool -> Text renderResults rootDisplay pat matches scanned truncated =   let header =@@ -286,15 +269,3 @@         <> T.pack (show m.mLine)         <> ": "         <> m.mText---- | NUL byte in the first few KB is a robust, cheap binary heuristic--- (the same one used by git diff and grep). Uses the shared sniff--- threshold from 'LLM.Tools.FsLimits' so all tools agree.-detectBinary :: FilePath -> IO Bool-detectBinary path = do-  r <--    try (withBinaryFile path ReadMode (`BS.hGet` binarySniffBytes)) ::-      IO (Either IOException BS.ByteString)-  case r of-    Right bs -> pure (BS.elem 0 bs)-    Left _ -> pure True

@@ -0,0 +1,124 @@+-- | Text reads on one open 'Handle': the binary sniff, the size check and+-- the read itself all use the same open file, instead of reopening the+-- path for each step. Shared by 'LLM.Tools.FsLimits' and the tools.+module LLM.Tools.Internal.TextFile+  ( Opener,+    binarySniffBytes,+    withTextHandle,+    readBoundedBytesWith,+    readBoundedTextWith,+    readBoundedUtf8With,+    readLenient,+    writeUtf8,+  )+where++import Control.Exception (IOException, throwIO, try)+import GHC.IO.Exception (IOException (ioe_filename))+import Data.ByteString qualified as BS+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8', decodeUtf8With, encodeUtf8)+import Data.Text.Encoding.Error (lenientDecode)+import System.IO (Handle, SeekMode (AbsoluteSeek), hFileSize, hSeek)++-- | Opens a file for reading and runs an action on it, e.g.+-- @withBinaryFile path ReadMode@.+type Opener = forall a. (Handle -> IO a) -> IO a++-- | Number of leading bytes inspected when sniffing for binary content.+-- Matches the heuristic used by @git diff@ and @grep@: any NUL byte in+-- the prefix means binary.+binarySniffBytes :: Int+binarySniffBytes = 8192++-- | Open a file, sniff its first 'binarySniffBytes' for a NUL byte, and run+-- the action from the start of the file if there is none.+--+-- 'Nothing' if the file looks binary, or cannot be opened or sniffed: the+-- caller fails closed rather than read an unreadable file as text. An+-- 'IOException' from the action itself is rethrown.+withTextHandle :: Opener -> (Handle -> IO r) -> IO (Maybe r)+withTextHandle open act = do+  r <- try $ open $ \h -> do+    sniff <- try (BS.hGet h binarySniffBytes)+    case sniff of+      Left (_ :: IOException) -> pure (Right Nothing)+      Right bs+        | BS.elem 0 bs -> pure (Right Nothing)+        | otherwise -> do+            hSeek h AbsoluteSeek 0+            fmap Just <$> try (act h)+  case r of+    Left (_ :: IOException) -> pure Nothing+    Right (Left (e :: IOException)) -> throwIO e+    Right (Right x) -> pure x++-- | Read a file up to @cap@ bytes. Refuses binary files, checks the size+-- before reading, and reads at most @cap + 1@ bytes so a file that grows+-- during the read is caught.+readBoundedBytesWith :: Opener -> Text -> Int -> IO (Either Text BS.ByteString)+readBoundedBytesWith open display cap = do+  r <- withTextHandle open $ \h -> do+    sizeRes <- try (hFileSize h)+    case sizeRes of+      Left (e :: IOException) ->+        pure $ Left $ "could not stat " <> display <> ": " <> describeIOError e+      Right sz+        | sz > fromIntegral cap ->+            pure $+              Left $+                display+                  <> " is "+                  <> T.pack (show sz)+                  <> " bytes, which exceeds the "+                  <> T.pack (show cap)+                  <> "-byte cap."+        | otherwise -> do+            bsRes <- try (BS.hGet h (cap + 1))+            pure $ case bsRes of+              Left (e :: IOException) ->+                Left $ "could not read " <> display <> ": " <> describeIOError e+              Right bs+                | BS.length bs > cap ->+                    Left $+                      display+                        <> " grew past the "+                        <> T.pack (show cap)+                        <> "-byte cap during the read."+                | otherwise -> Right bs+  pure $+    fromMaybe+      (Left (display <> " appears to be a binary file; only text files are supported."))+      r++-- | An 'IOException' without its file name, which for a handle is the+-- absolute path it was opened with. Callers name the file themselves.+describeIOError :: IOException -> Text+describeIOError e = T.pack (show e {ioe_filename = Nothing})++-- | 'readBoundedBytesWith', decoded for display. Invalid UTF-8 bytes become+-- U+FFFD, so never write the result back.+readBoundedTextWith :: Opener -> Text -> Int -> IO (Either Text Text)+readBoundedTextWith open display cap =+  fmap (decodeUtf8With lenientDecode) <$> readBoundedBytesWith open display cap++-- | 'readBoundedBytesWith', for editing. Refuses files that are not valid+-- UTF-8, since writing them back would destroy their bytes.+readBoundedUtf8With :: Opener -> Text -> Int -> IO (Either Text Text)+readBoundedUtf8With open display cap = do+  r <- readBoundedBytesWith open display cap+  pure $+    r >>= \bs -> case decodeUtf8' bs of+      Right t -> Right t+      Left _ -> Left $ display <> " is not valid UTF-8; refusing to edit it."++-- | Read the rest of the handle as UTF-8, replacing invalid bytes with+-- U+FFFD. Independent of the locale.+readLenient :: Handle -> IO Text+readLenient h = decodeUtf8With lenientDecode <$> BS.hGetContents h++-- | Write text as UTF-8, independent of the locale.+writeUtf8 :: Handle -> Text -> IO ()+writeUtf8 h = BS.hPut h . encodeUtf8

@@ -7,7 +7,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, sandboxPath, sandboxSymlink, sandboxWritePath)+import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, sandboxPath, sandboxSymlink, sandboxWritePath, withWorkspacePaths) import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, renameFile)  data MoveFileToolArgs = MoveFileToolArgs@@ -32,7 +32,7 @@         "Move (rename) a file from source to destination (both paths relative to the workspace). "           <> "Creates parent directories at the destination as needed.",       ttoolReadonly = False,-      ttoolExecute = const (moveFileExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . moveFileExecTyped cfg)     }  moveFileExecTyped :: FsConfig -> MoveFileToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (maxReadBytes, readBoundedUtf8File, writeUtf8File)  data Replacement = Replacement@@ -51,7 +51,7 @@           <> T.pack (show maxReadBytes)           <> " bytes are refused.",       ttoolReadonly = False,-      ttoolExecute = const (replaceExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . replaceExecTyped cfg)     }  replaceExecTyped :: FsConfig -> MultiReplaceInFileToolArgs -> IO Text

@@ -13,10 +13,12 @@ import Data.Text.Encoding.Error (lenientDecode) import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)-import LLM.Tools.FsLimits (detectBinary, maxPaginatedFileBytes)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths)+import LLM.Tools.FsLimits (maxPaginatedFileBytes)+import LLM.Tools.Internal.TextFile (withTextHandle) import System.IO-  ( IOMode (ReadMode),+  ( Handle,+    IOMode (ReadMode),     hFileSize,     withBinaryFile,   )@@ -69,7 +71,7 @@           <> "with the next offset to use. The tool is stateless: pass the next offset on the "           <> "following call. Binary files are refused.",       ttoolReadonly = True,-      ttoolExecute = const (execute cfg)+      ttoolExecute = const (withWorkspacePaths cfg . execute cfg)     }  execute :: FsConfig -> ReadFilePaginatedArgs -> IO Text@@ -78,36 +80,36 @@       offset = max 1 args._rfpOffset       limit = max 1 (min maxLimit args._rfpLimit)   resolved <- sandboxPath cfg rel-  isBinary <- detectBinary resolved-  if isBinary-    then-      pure $-        "Error: "-          <> args._rfpPath-          <> " appears to be a binary file; read_file_paginated only supports text files."-    else do-      size <- withBinaryFile resolved ReadMode hFileSize-      if size > maxPaginatedFileBytes-        then-          pure $-            "Error: "-              <> args._rfpPath-              <> " is "-              <> T.pack (show size)-              <> " bytes, which exceeds the "-              <> T.pack (show maxPaginatedFileBytes)-              <> "-byte cap for read_file_paginated."-        else do-          (lns, hasMore) <- readPage resolved offset limit-          pure $ renderPage args._rfpPath size offset lns hasMore+  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  -- | 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 :: FilePath -> Int -> Int -> IO ([Text], Bool)-readPage path offset limit = do-  bytes <- withBinaryFile path ReadMode (`BS.hGet` fromIntegral maxPaginatedFileBytes)+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))) 

@@ -7,7 +7,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath, withWorkspacePaths) import System.Directory (doesDirectoryExist, listDirectory) import System.FilePath ((</>)) @@ -33,7 +33,7 @@           <> "symbolic links with '@' (links are not followed). "           <> "Use path '.' to list the workspace root.",       ttoolReadonly = True,-      ttoolExecute = const (readdirExecTyped fsConfig)+      ttoolExecute = const (withWorkspacePaths fsConfig . readdirExecTyped fsConfig)     }  readdirExecTyped :: FsConfig -> ReaddirToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (maxReadBytes, readBoundedTextFile)  newtype ReadfileToolArgs = ReadfileToolArgs@@ -31,7 +31,7 @@           <> T.pack (show maxReadBytes)           <> " bytes are refused; use read_file_paginated instead.",       ttoolReadonly = True,-      ttoolExecute = const (readfileExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . readfileExecTyped cfg)     }  readfileExecTyped :: FsConfig -> ReadfileToolArgs -> IO Text

@@ -7,7 +7,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, isSymlink, sandboxPath, sandboxSymlink)+import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, isSymlink, sandboxPath, sandboxSymlink, withWorkspacePaths) import System.Directory   ( doesDirectoryExist,     listDirectory,@@ -37,7 +37,7 @@           <> "Use with caution — this operation is irreversible. "           <> "A symbolic link is removed itself; its target is left unchanged.",       ttoolReadonly = False,-      ttoolExecute = const (removeDirectoryExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . removeDirectoryExecTyped cfg)     }  removeDirectoryExecTyped :: FsConfig -> RemoveDirectoryToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, sandboxPath, sandboxSymlink)+import LLM.Tools.FsConfig (FsConfig, isSandboxRoot, sandboxPath, sandboxSymlink, withWorkspacePaths) import System.Directory (doesDirectoryExist, removeFile)  newtype RemoveFileToolArgs = RemoveFileToolArgs@@ -29,7 +29,7 @@           <> "Fails if the path does not exist or is a directory. "           <> "A symbolic link is removed itself; its target is left unchanged.",       ttoolReadonly = False,-      ttoolExecute = const (removeFileExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . removeFileExecTyped cfg)     }  removeFileExecTyped :: FsConfig -> RemoveFileToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsConfig (FsConfig, sandboxPath, withWorkspacePaths) import LLM.Tools.FsLimits (maxReadBytes, readBoundedUtf8File, writeUtf8File)  data ReplaceInFileToolArgs = ReplaceInFileToolArgs@@ -38,7 +38,7 @@           <> T.pack (show maxReadBytes)           <> " bytes are refused.",       ttoolReadonly = False,-      ttoolExecute = const (replaceExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . replaceExecTyped cfg)     }  replaceExecTyped :: FsConfig -> ReplaceInFileToolArgs -> IO Text

@@ -6,7 +6,7 @@ import Data.Text qualified as T import GHC.Generics (Generic) import LLM.Core.Types (TypedTool (..))-import LLM.Tools.FsConfig (FsConfig, sandboxWritePath)+import LLM.Tools.FsConfig (FsConfig, sandboxWritePath, withWorkspacePaths) import LLM.Tools.FsLimits (writeUtf8File)  data WritefileToolArgs = WritefileToolArgs@@ -33,7 +33,7 @@           <> "Creates the file if it doesn't exist, overwrites if it does. "           <> "Automatically creates parent directories as needed.",       ttoolReadonly = False,-      ttoolExecute = const (writefileExecTyped cfg)+      ttoolExecute = const (withWorkspacePaths cfg . writefileExecTyped cfg)     }  writefileExecTyped :: FsConfig -> WritefileToolArgs -> IO Text

@@ -2,8 +2,10 @@  module LLM.ChatSpec (spec) where +import Control.Concurrent (forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Exception (finally) import Data.Aeson (object, (.=))-import Data.IORef (IORef, modifyIORef', newIORef, readIORef)+import Data.IORef (IORef, modifyIORef', newIORef, readIORef, writeIORef) import Data.Map qualified as Map import Data.Text (Text) import Heptapod (generate)@@ -37,7 +39,7 @@     mkToolCall,   ) import LLM.Core.Usage (PricingInfo (..), defaultPricingInfo, mkUsage)-import LLM.Generate.Logger (noHooks)+import LLM.Generate.Logger (Hooks (..), noHooks) import LLM.Generate.ModelConfig   ( ModelCapabilities (..),     ModelConfig (..),@@ -55,8 +57,10 @@     expectationFailure,     it,     shouldBe,+    shouldReturn,     shouldSatisfy,   )+import System.Timeout (timeout)  -- | A mock gateway that returns a fixed response mockGateway :: ChatResponse -> LLMGateway@@ -174,6 +178,41 @@   rt <- mkRuntime mSig   generateText agent models toolMap rt turns +-- | A tool named @name@ that ignores its arguments and runs @act@.+constTool :: Text -> IO Text -> Tool Text+constTool name act =+  Tool+    { toolDef =+        ToolDef+          { toolName = name,+            toolDescription = "test tool",+            toolReadonly = True,+            toolParameters = object ["type" .= ("object" :: Text)]+          },+      toolExecute = \_ _ -> act+    }++-- | A gateway that always asks for two calls (@c1@, @c2@) of tool @name@.+twoToolCallGateway :: Text -> LLMGateway+twoToolCallGateway name =+  LLMGateway+    { gwName = "mock-two",+      gwImageMediaTypes = supportedImageMediaTypes,+      gwImageUrlSupport = True,+      gwGenerateText = \_ _ ->+        let tc1 = mkToolCall "c1" name (object [])+            tc2 = mkToolCall "c2" name (object [])+         in pure $ Right (ChatResponse "" [toolCallPart tc1, toolCallPart tc2] Nothing Nothing),+      gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),+      gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)+    }++-- | (call id, content) of the results in the last turn, if it is a tool turn.+lastToolResults :: [Turn] -> Maybe [(Text, Text)]+lastToolResults turns = case reverse turns of+  ToolTurn results : _ -> Just [(r.trCallId, r.trContent) | r <- results]+  _ -> Nothing+ runStreamGenerate ::   Agent ->   ModelWithFallbacks ->@@ -514,47 +553,47 @@         Left GenerateErrorResult {gerError = GErrAborted} -> pure ()         other -> expectationFailure $ "Expected GErrAborted, got: " <> show other -    it "returns Aborted during tool execution" $ do+    it "stops before the next tool call once the signal fired" $ do       sig <- newAbortSignal-      let slowTool =-            Tool-              { toolDef =-                  ToolDef-                    { toolName = "slow",-                      toolDescription = "A slow tool",-                      toolReadonly = True,-                      toolParameters = object ["type" .= ("object" :: Text)]-                    },-                toolExecute = \_ _ -> do-                  abort sig-                  pure "done"-              }-          twoCallGw =-            LLMGateway-              { gwName = "mock-two",-                gwImageMediaTypes = supportedImageMediaTypes,-                gwImageUrlSupport = True,-                gwGenerateText = \_ _ ->-                  let tc1 = mkToolCall "c1" "slow" (object [])-                      tc2 = mkToolCall "c2" "slow" (object [])-                   in pure $ Right (ChatResponse "" [toolCallPart tc1, toolCallPart tc2] Nothing Nothing),-                gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),-                gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)-              }-          tm = Map.fromList [("slow", slowTool)]+      let tm = Map.fromList [("slow", constTool "slow" (pure "done"))]           agent = defaultAgent {agTools = ["slow"]}-          models = ModelWithFallbacks (mockModel twoCallGw) []-      result <- runGenerate agent models tm (Just sig) [UserTurn "go"]+          models = ModelWithFallbacks (mockModel (twoToolCallGateway "slow")) []+      rt <- mkRuntime (Just sig)+      -- Fire the signal once the first call has finished.+      let rt' = rt {rtHooks = noHooks {onToolResult = \_ _ -> abort sig}}+      result <- generateText agent models tm rt' [UserTurn "go"]       case result of         Left GenerateErrorResult {gerError = GErrAborted, gerPartialNewMessages} ->           -- Every tool call in the history must have a result, or the next           -- request is rejected. c1 ran; c2 never did.-          case reverse gerPartialNewMessages of-            ToolTurn results : _ ->-              [(r.trCallId, r.trContent) | r <- results]-                `shouldBe` [("c1", "done"), ("c2", "Aborted before execution")]-            _ -> expectationFailure $ "Expected history to end with a ToolTurn, got: " <> show gerPartialNewMessages+          lastToolResults gerPartialNewMessages+            `shouldBe` Just [("c1", "done"), ("c2", "Aborted before execution")]         other -> expectationFailure $ "Expected GErrAborted during tools, got: " <> show other++    it "interrupts a running tool" $ do+      sig <- newAbortSignal+      started <- newEmptyMVar+      finished <- newIORef False+      errors <- newIORef []+      let hangingTool =+            constTool "hang" $+              (putMVar started () >> threadDelay 60_000_000 >> pure "done")+                `finally` writeIORef finished True+          tm = Map.fromList [("hang", hangingTool)]+          agent = defaultAgent {agTools = ["hang"]}+          models = ModelWithFallbacks (mockModel (twoToolCallGateway "hang")) []+      rt <- mkRuntime (Just sig)+      let rt' = rt {rtHooks = noHooks {onToolError = \name msg -> modifyIORef' errors ((name, msg) :)}}+      _ <- forkIO (takeMVar started >> abort sig)+      result <- timeout 5_000_000 $ generateText agent models tm rt' [UserTurn "go"]+      case result of+        Just (Left GenerateErrorResult {gerError = GErrAborted, gerPartialNewMessages}) ->+          -- The interrupted call counts as not run.+          lastToolResults gerPartialNewMessages+            `shouldBe` Just [("c1", "Aborted before execution"), ("c2", "Aborted before execution")]+        other -> expectationFailure $ "Expected GErrAborted from the running tool, got: " <> show other+      readIORef finished `shouldReturn` True+      readIORef errors `shouldReturn` [("hang", "Aborted")]      describe "sticky fallback" $ stickyFallbackSpec runGenerate toolMap 

@@ -1,8 +1,9 @@ module LLM.FsConfigSpec (spec) where -import Control.Exception (try)+import Control.Exception (IOException, try) import LLM.Tools.FsConfig   ( SandboxViolation (..),+    isSymlink,     mkFsConfig,     sandboxPath,     sandboxWritePath,@@ -24,6 +25,7 @@     expectationFailure,     it,     shouldBe,+    shouldReturn,     shouldSatisfy,   ) @@ -167,6 +169,34 @@         -- is permitted and lands on the link's target, not the link.         resolved <- sandboxWritePath cfg "dangling"         resolved `shouldBe` (sb </> "real-new.txt")++  describe "isSymlink" $ do+    it "is False when nothing exists at the path" $ withSandbox $ \sb -> do+      writeFile (sb </> "file.txt") "x"+      isSymlink (sb </> "missing") `shouldReturn` False+      isSymlink (sb </> "missing" </> "child") `shouldReturn` False+      -- ENOTDIR: a component on the way is a regular file+      isSymlink (sb </> "file.txt" </> "child") `shouldReturn` False++    it "is True for a symlink, dangling or not" $ withSandbox $ \sb -> do+      writeFile (sb </> "file.txt") "x"+      createFileLink (sb </> "file.txt") (sb </> "link")+      createFileLink (sb </> "gone") (sb </> "dangling")+      isSymlink (sb </> "link") `shouldReturn` True+      isSymlink (sb </> "dangling") `shouldReturn` True++    it "is True when the lookup fails for another reason" $ withSandbox $ \sb -> do+      -- Looking up loop/child must follow loop, which points to itself (ELOOP).+      createFileLink (sb </> "loop") (sb </> "loop")+      isSymlink (sb </> "loop" </> "child") `shouldReturn` True++    it "keeps a path under a regular file an ordinary error, not a violation" $ withSandbox $ \sb -> do+      cfg <- mkFsConfig sb+      writeFile (sb </> "file.txt") "x"+      r <- try (sandboxWritePath cfg "file.txt/new")+      case r of+        Left (_ :: IOException) -> pure ()+        Right p -> expectationFailure ("expected an IOException, got " <> p)    describe "sandboxWritePath: non-existent targets" $ do     it "resolves a write path under a not-yet-existing nested dir" $ withSandbox $ \sb -> do

@@ -1,6 +1,6 @@ module LLM.FsToolsSpec (spec) where -import Control.Exception (bracket_, evaluate, try)+import Control.Exception (IOException, bracket_, evaluate, try) import Data.Aeson (Value, object, (.=)) import Data.ByteString qualified as BS import Data.Map qualified as Map@@ -9,7 +9,9 @@ import Data.Text.Encoding (encodeUtf8) import GHC.IO.Encoding (getLocaleEncoding, setLocaleEncoding) import Heptapod (generate)+import LLM.Agent.ToolUtils (executeTool) import LLM.Agent.Types (RuntimeArgs (..), Tool (..), ToolContext (..))+import LLM.Core.Types (ToolCall (..), ToolResult (..)) import LLM.Generate.GenerateUtils (llmHooks) import LLM.Generate.Logger (noHooks) import LLM.Load.FsTools (fsTools)@@ -25,6 +27,7 @@   ) import System.FilePath (takeDirectory, (</>)) import System.IO (TextEncoding, char8)+import System.IO.Error (ioeGetFileName) import GHC.Clock (getMonotonicTime) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec@@ -99,6 +102,17 @@           )       T.unpack result `shouldContain` "main.hs" +    it "shows paths relative to the search root, never host paths" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      runTool_ tm "writefile" (object ["path" .= ("src/app/main.hs" :: Text), "content" .= ("needle\n" :: Text)])+      fromRoot <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text)])+      T.lines fromRoot `shouldContain` [T.pack ("src" </> "app" </> "main.hs") <> ":1: needle"]+      fromSub <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text), "path" .= ("src" :: Text)])+      T.lines fromSub `shouldContain` [T.pack ("app" </> "main.hs") <> ":1: needle"]+      oneFile <- runTool tm "grep" (object ["pattern" .= ("needle" :: Text), "path" .= ("src/app/main.hs" :: Text)])+      T.lines oneFile `shouldContain` ["main.hs:1: needle"]+      T.unpack (fromRoot <> fromSub <> oneFile) `shouldNotContain` sb+   describe "find_files" $ do     it "matches a glob pattern" $ withSandbox $ \sb -> do       tm <- fsTools sb@@ -176,6 +190,25 @@       doesFileExist (sb </> "tmp" </> "x.txt") `shouldReturn` False       runTool_ tm "remove_directory" (object ["path" .= ("tmp" :: Text)])       doesDirectoryExist (sb </> "tmp") `shouldReturn` False++  describe "tool errors" $ do+    it "name the file relative to the workspace in the raised IOException" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      createDirectory (sb </> "sub")+      r <- try (runTool tm "remove_file" (object ["path" .= ("sub/missing.txt" :: Text)]))+      case r of+        Left (e :: IOException) -> ioeGetFileName e `shouldBe` Just ("sub" </> "missing.txt")+        Right out -> expectationFailure ("expected an IOException, got " <> T.unpack out)++    it "do not show the workspace's host path to the model" $ withSandbox $ \sb -> do+      tm <- fsTools sb+      ctx <- mkToolContext+      let call = ToolCall {tcId = "1", tcName = "remove_file", tcArguments = object ["path" .= ("missing.txt" :: Text)], tcProviderMeta = Nothing}+      res <- executeTool noHooks ctx (Map.elems tm) call+      let out = T.unpack res.trContent+      out `shouldContain` "missing.txt"+      out `shouldContain` "does not exist"+      out `shouldNotContain` "llm-simple-fstools"    describe "symbolic links" $ do     it "remove_file removes the link and leaves its target intact" $ withSandbox $ \sb -> do

@@ -226,7 +226,12 @@               <> "\""               <> (if thought then ",\"thought\":true" else "")               <> "}]}}],\"modelVersion\":\"gemini-2.5-flash\"}\n\n"-          sse = chunk "Let me " True <> chunk "think about " True <> chunk "this." True <> chunk "Answer." False+          sse =+            chunk "Let me " True+              <> chunk "think about " True+              <> chunk "this." True+              <> chunk "Answer." False+              <> "data: {\"candidates\":[{\"finishReason\":\"STOP\"}]}\n\n"       reader <- mkBodyReader sse       result <- (geminiProvider "key").parseStream (object []) reader (\_ -> pure ())       case result of

@@ -1,6 +1,7 @@ module LLM.LoadSpec (spec) where  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.ByteString qualified as BS@@ -11,7 +12,7 @@ import Data.Text qualified as T import LLM.Core.Types (LLMGateway (..)) import LLM.Generate.ModelConfig (ModelCapabilities (..), ModelConfig (..), defaultModelCapabilities)-import LLM.Load.LoadGateways (buildGateway, loadGateways, loadGatewaysFromCatalog, parseProviderBaseUrl)+import LLM.Load.LoadGateways (ProviderUnavailable (..), buildGateway, loadGateways, loadGatewaysFromCatalog, loadGatewaysWithDotenv, loadGatewaysFromCatalogOrThrow, parseProviderBaseUrl, resolveGateway) import LLM.Load.LoadModels (loadModelOrThrow, loadModelOrThrow_, loadModelsOrThrow) import LLM.Load.ModelCatalog (ModelCatalogItem (..)) import LLM.Load.ProviderCatalog@@ -23,6 +24,8 @@   ) import LLM.Load.Types (LoadConfigError (..)) import LLM.Load.Utils (getSystemPrompt)+import System.Directory (createDirectory, withCurrentDirectory)+import System.Environment (setEnv) import System.FilePath ((</>)) import System.IO.Temp (withSystemTempDirectory) import Test.Hspec@@ -33,6 +36,8 @@     shouldBe,     shouldContain,     shouldSatisfy,+    shouldThrow,+    anyErrorCall,   )  ollamaCatalog :: FilePath@@ -126,6 +131,23 @@           Left other -> expectationFailure $ "expected LoadModelConfigError, got: " <> show other           Right _ -> expectationFailure "expected failure" +  describe "loadGatewaysWithDotenv" $ do+    it "ignores a missing .env" $+      inTempDir $ \_ -> do+        gateways <- loadGatewaysWithDotenv+        Map.member "ollama" gateways `shouldBe` True++    it "ignores a .env it cannot read" $+      inTempDir $ \dir -> do+        createDirectory (dir </> ".env")+        gateways <- loadGatewaysWithDotenv+        Map.member "ollama" gateways `shouldBe` True++    it "only swallows IO errors, not other exceptions" $+      inTempDir $ \dir -> do+        writeFile (dir </> ".env") "not a dotenv line\n"+        loadGatewaysWithDotenv `shouldThrow` anyErrorCall+   describe "loadGateways" $ do     it "always includes ollama" $ do       gateways <- loadGateways@@ -173,6 +195,52 @@           LLMGateway {gwName = name} = gateway       name `shouldBe` "gemini" +    describe "plain-HTTP base URLs" $ do+      let item proto url =+            ProviderCatalogItem+              { providerName = "custom",+                protocol = proto,+                baseUrl = url,+                apiKeyEnv = Just "LLM_SIMPLE_TEST_HTTP_KEY",+                baseUrlEnv = Nothing+              }+          resolve i = do+            setEnv "LLM_SIMPLE_TEST_HTTP_KEY" "secret"+            either Left (const (Right ())) <$> resolveGateway i+          isInsecure = \case+            Left (InvalidBaseUrl msg) -> "insecure baseUrl" `T.isInfixOf` msg+            _ -> False++      it "rejects a remote http:// base URL for a provider that sends a key" $ do+        forM_ [OpenAIProtocol, ClaudeProtocol, GeminiProtocol, DeepSeekProtocol] $ \proto -> do+          r <- resolve (item proto "http://proxy.example.com")+          r `shouldSatisfy` isInsecure+        r <- resolve (item OpenAIProtocol "http://127.example.com")+        r `shouldSatisfy` isInsecure++      it "accepts http:// to a loopback host" $ do+        forM_ ["http://localhost:8080", "http://LOCALHOST.", "http://127.0.0.1:8080/api", "http://127.9.8.7", "http://[::1]:8080"] $ \url -> do+          r <- resolve (item OpenAIProtocol url)+          (url, r) `shouldBe` (url, Right ())++      it "accepts https:// to a remote host" $ do+        r <- resolve (item ClaudeProtocol "https://proxy.example.com")+        r `shouldBe` Right ()++      it "accepts a remote http:// base URL when no key is sent" $ do+        r <- resolve (item OllamaProtocol "http://gpu-box.lan:11434")+        r `shouldBe` Right ()+        r' <- resolve (item OpenAIProtocol "http://gpu-box.lan:8000") {apiKeyEnv = Nothing}+        r' `shouldBe` Right ()++      it "makes loadGatewaysFromCatalogOrThrow throw" $ do+        setEnv "LLM_SIMPLE_TEST_HTTP_KEY" "secret"+        r <- try (loadGatewaysFromCatalogOrThrow (Map.singleton "custom" (item OpenAIProtocol "http://proxy.example.com")))+        case r of+          Left (LoadModelConfigError msg) -> T.unpack msg `shouldContain` "insecure baseUrl"+          Left other -> expectationFailure ("unexpected error: " <> show other)+          Right _ -> expectationFailure "expected LoadModelConfigError"+     it "loads gateways from a provider catalog file" $ do       result <- runExceptT $ loadProviderCatalog providersOllamaOnly       case result of@@ -285,3 +353,10 @@     providersJson <- readFile providersFixture     writeFile providersPath providersJson     act catalogPath `catch` \(_ :: IOException) -> act catalogPath++-- | Run in a fresh temporary directory as the working directory, so a+-- @.env@ in the repository is never loaded.+inTempDir :: (FilePath -> IO a) -> IO a+inTempDir act =+  withSystemTempDirectory "llm-simple-dotenv" $ \dir ->+    withCurrentDirectory dir (act dir)

@@ -0,0 +1,33 @@+module LLM.LoggerSpec (spec) where++import Control.Monad (forM_)+import Data.Aeson (object, (.=))+import Data.List (isPrefixOf, sort)+import LLM.Generate.Logger (Hooks (..), noHooks, withJsonDump)+import System.Directory (createDirectory, doesDirectoryExist, listDirectory)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)++spec :: Spec+spec = describe "Logger" $ do+  describe "withJsonDump" $ do+    it "keeps a provider name with path separators inside the dump directory" $+      withSystemTempDirectory "llm-simple-dump" $ \root -> do+        let dir = root </> "dumps"+        createDirectory dir+        let hooks = withJsonDump dir noHooks+        hooks.onRequest "../leak" (object ["a" .= (1 :: Int)])+        hooks.onRequest "a/b" (object ["a" .= (1 :: Int)])+        sort <$> listDirectory root >>= (`shouldBe` ["dumps"])+        files <- sort <$> listDirectory dir+        length files `shouldBe` 2+        files `shouldSatisfy` all (\f -> "___leak-request-" `isPrefixOf` f || "a_b-request-" `isPrefixOf` f)+        doesDirectoryExist (dir </> "a") >>= (`shouldBe` False)++    it "writes one file per dump, even within the same millisecond" $+      withSystemTempDirectory "llm-simple-dump" $ \dir -> do+        let hooks = withJsonDump dir noHooks+        forM_ [1 .. 20 :: Int] $ \i -> hooks.onResponse "openai" (object ["i" .= i])+        files <- listDirectory dir+        length files `shouldBe` 20

@@ -0,0 +1,213 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++-- | Truncated or corrupt streams must fail with a typed error (and so reach+-- a fallback model) instead of returning a partial answer or throwing.+module LLM.StreamCompletenessSpec (spec) where++import Control.Monad (forM_)+import Data.Aeson (object)+import Data.ByteString (ByteString)+import Data.ByteString qualified as BS+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Core.Types (ChatResponse (..), LLMError (..), LLMGateway, LLMTextResult)+import LLM.Core.Usage (defaultPricingInfo)+import LLM.Generate.Generate (streamTextWithFallbacks)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig (ModelConfig (..), ModelWithFallbacks (..), defaultModelCapabilities)+import LLM.Generate.Types (GenRequest (..))+import LLM.Providers.Claude (claudeProvider)+import LLM.Providers.Gemini (geminiProvider)+import LLM.Providers.OpenAI (openAIProvider)+import Test.Hspec (Spec, describe, expectationFailure, it, shouldBe)++-- | The wire shape of one streaming protocol.+data Protocol = Protocol+  { name :: String,+    provider :: LLMProvider,+    -- | Events sent before any text.+    start :: ByteString,+    -- | One event carrying a text delta.+    text :: ByteString -> ByteString,+    -- | Events sent after the text, except the end-of-stream marker.+    tailEvents :: ByteString,+    -- | The end-of-stream marker event(s).+    end :: ByteString,+    -- | How the marker is named in the error.+    markerName :: Text+  }++protocols :: [Protocol]+protocols = [openAI, gemini, claude]++openAI :: Protocol+openAI =+  Protocol+    { name = "OpenAI-compatible",+      provider = openAIProvider "key",+      start = "",+      text = \t -> "data: {\"choices\":[{\"index\":0,\"delta\":{\"content\":\"" <> t <> "\"},\"finish_reason\":null}]}\n\n",+      tailEvents = "data: {\"choices\":[],\"usage\":{\"prompt_tokens\":3,\"completion_tokens\":2,\"total_tokens\":5}}\n\n",+      end = "data: {\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"stop\"}]}\n\ndata: [DONE]\n\n",+      markerName = "[DONE] or finish_reason"+    }++gemini :: Protocol+gemini =+  Protocol+    { name = "Gemini",+      provider = geminiProvider "key",+      start = "",+      text = \t -> "data: {\"candidates\":[{\"content\":{\"role\":\"model\",\"parts\":[{\"text\":\"" <> t <> "\"}]}}]}\n\n",+      tailEvents = "data: {\"usageMetadata\":{\"promptTokenCount\":3,\"candidatesTokenCount\":2}}\n\n",+      end = "data: {\"candidates\":[{\"finishReason\":\"STOP\"}]}\n\n",+      markerName = "finishReason"+    }++claude :: Protocol+claude =+  Protocol+    { name = "Claude",+      provider = claudeProvider "key",+      start =+        "event: message_start\ndata: {\"type\":\"message_start\",\"message\":{\"model\":\"claude-test\",\"usage\":{\"input_tokens\":3,\"output_tokens\":0}}}\n\n"+          <> "event: content_block_start\ndata: {\"type\":\"content_block_start\",\"index\":0,\"content_block\":{\"type\":\"text\",\"text\":\"\"}}\n\n",+      text = \t -> "event: content_block_delta\ndata: {\"type\":\"content_block_delta\",\"index\":0,\"delta\":{\"type\":\"text_delta\",\"text\":\"" <> t <> "\"}}\n\n",+      tailEvents =+        "event: content_block_stop\ndata: {\"type\":\"content_block_stop\",\"index\":0}\n\n"+          <> "event: message_delta\ndata: {\"type\":\"message_delta\",\"delta\":{\"stop_reason\":\"end_turn\"},\"usage\":{\"output_tokens\":2}}\n\n",+      end = "event: message_stop\ndata: {\"type\":\"message_stop\"}\n\n",+      markerName = "message_stop"+    }++-- | Text, then the tail and end of a well-formed stream.+complete :: Protocol -> ByteString -> ByteString+complete p t = p.start <> p.text t <> p.tailEvents <> p.end++-- | Feed @bytes@ to the protocol's stream parser in small chunks, so event+-- boundaries fall in the middle of reads.+parseBytes :: Protocol -> ByteString -> IO LLMTextResult+parseBytes p bytes = do+  reader <- chunkedReader 7 bytes+  p.provider.parseStream (object []) reader (\_ -> pure ())++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++-- | The protocol's provider, answering every streaming call with @bytes@.+gatewayFor :: Protocol -> ByteString -> ModelConfig+gatewayFor p bytes =+  testModelConfig $+    toGateway+      p.provider+        { openStream = \_ k -> k =<< chunkedReader 7 bytes+        }++-- | Malformed streams, each paired with a check on the parser's result.+badStreams :: Protocol -> [(String, ByteString, LLMTextResult -> Bool)]+badStreams p =+  [ ( "partial text, then EOF mid-event",+      p.start <> p.text "Hel" <> BS.take 30 (p.text "lo"),+      isTruncated+    ),+    ( "every event except the end-of-stream marker",+      p.start <> p.text "Hello" <> p.tailEvents,+      isTruncated+    ),+    ( "a malformed JSON event after valid text",+      p.start <> p.text "Hel" <> malformedEvent <> p.text "lo" <> p.tailEvents <> p.end,+      isParseError "not valid JSON"+    ),+    ( "invalid UTF-8 in a data line",+      p.start <> p.text "Hel" <> p.text "\xff\xfe" <> p.tailEvents <> p.end,+      isParseError "UTF-8"+    )+  ]+  where+    isTruncated = \case+      Left (NetworkError msg) -> msg == "stream ended before " <> p.markerName+      _ -> False+    isParseError s = \case+      Left (ParseError msg) -> s `T.isInfixOf` msg+      _ -> False+    malformedEvent+      | p.name == "Claude" = "event: content_block_delta\ndata: {\"type\":\n\n"+      | otherwise = "data: {\"candidates\":\n\n"++spec :: Spec+spec = describe "Stream completeness" $ do+  forM_ protocols $ \p -> describe p.name $ do+    it "accepts a complete stream" $ do+      r <- parseBytes p (complete p "Hello")+      fmap (.respText) r `shouldBe` Right "Hello"++    forM_ (badStreams p) $ \(label, bytes, check) -> do+      it ("fails on " <> label) $ do+        r <- parseBytes p bytes+        if check r+          then pure ()+          else expectationFailure ("unexpected result: " <> show r)++      it ("falls back to the next model on " <> label) $ do+        let models = ModelWithFallbacks (gatewayFor p bytes) [gatewayFor p (complete p "Fallback")]+        r <- streamTextWithFallbacks (\_ -> pure ()) testGenRequest models+        either (Left . show) (Right . (.respText)) r `shouldBe` Right "Fallback"++  describe "OpenAI-compatible end markers" $ do+    it "accepts [DONE] without a finish_reason" $ do+      r <- parseBytes openAI (openAI.text "Hello" <> "data: [DONE]\n\n")+      fmap (.respText) r `shouldBe` Right "Hello"++    it "accepts a finish_reason without [DONE]" $ do+      r <- parseBytes openAI (openAI.text "Hello" <> "data: {\"choices\":[{\"index\":0,\"delta\":{},\"finish_reason\":\"stop\"}]}\n\n")+      fmap (.respText) r `shouldBe` Right "Hello"++  describe "Gemini end markers" $ do+    it "accepts a blocked prompt, which has a blockReason and no finishReason" $ do+      r <- parseBytes gemini "data: {\"promptFeedback\":{\"blockReason\":\"SAFETY\"}}\n\n"+      case r of+        Left (ResponseBlocked _) -> pure ()+        other -> expectationFailure ("expected ResponseBlocked, got " <> show other)++  describe "precedence" $ do+    it "reports an in-band provider error rather than the missing marker" $ do+      r <- parseBytes claude (claude.start <> claude.text "Hel" <> "event: error\ndata: {\"type\":\"error\",\"error\":{\"type\":\"overloaded_error\",\"message\":\"Overloaded\"}}\n\n")+      case r of+        Left (HttpError 529 _) -> pure ()+        other -> expectationFailure ("expected HttpError 529, got " <> show other)++testGenRequest :: GenRequest+testGenRequest =+  GenRequest+    { grSystemPrompt = Nothing,+      grMessages = [],+      grTools = [],+      grAbortSignal = Nothing,+      grLLMHooks = llmHooks noHooks,+      grHooks = noHooks+    }++testModelConfig :: LLMGateway -> ModelConfig+testModelConfig gw =+  ModelConfig+    { mcGateway = gw,+      mcModel = "test",+      mcPricing = defaultPricingInfo 0 0,+      mcMaxTokens = 256,+      mcTemperature = Nothing,+      mcThinking = Nothing,+      mcCapabilities = defaultModelCapabilities,+      mcRequestTimeout = Nothing,+      mcThrottleDelay = Nothing,+      mcRetryCount = 0,+      mcJitterBackoff = 0+    }

@@ -2,13 +2,15 @@  module LLM.StreamingSpec (spec) where -import Control.Concurrent (threadDelay)+import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar, threadDelay)+import Control.Exception (finally) import Control.Monad (when) import Control.Retry (RetryPolicyM (getRetryPolicyM), RetryStatus (rsIterNumber), defaultRetryStatus) import Data.Aeson (object, (.=))-import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef)+import Data.IORef (IORef, atomicModifyIORef', modifyIORef', newIORef, readIORef, writeIORef) import Data.Text (Text)-import LLM.Core.Abort (abort, newAbortSignal)+import GHC.Clock (getMonotonicTime)+import LLM.Core.Abort (AbortSignal, abort, newAbortSignal) import LLM.Core.Types   ( ChatResponse (..),     LLMError (..),@@ -34,6 +36,7 @@     RoundTextRole (..),     StreamChunk (..),   )+import System.Timeout (timeout) import Test.Hspec (Spec, describe, it, shouldBe, shouldReturn)  spec :: Spec@@ -173,6 +176,69 @@       fmap (.respText) r `shouldBe` Left GErrAborted       reverse <$> readIORef ref `shouldReturn` [TextDelta "a"] +    it "interrupts a stream that stalls after its first event" $ do+      sig <- newAbortSignal+      started <- newEmptyMVar+      closed <- newIORef False+      let resp = ChatResponse "a" [textPart "a"] Nothing Nothing+          gw =+            (streamGateway [] resp)+              { gwStreamText = \_ _ onEvent ->+                  (onEvent (StreamDelta "a") >> putMVar started () >> hang >> pure (Right resp))+                    `finally` writeIORef closed True+              }+          -- The first event arrives in time, so the first-event timeout is off.+          mc = (testModelConfig gw) {mcRequestTimeout = Just 1000}+      abortAfter started sig+      ref <- newIORef []+      r <- timeout 5_000_000 $ streamTextWithFallbacks (\c -> modifyIORef' ref (c :)) (testGenRequest []) {grAbortSignal = Just sig} (ModelWithFallbacks mc [])+      fmap (fmap (.respText)) r `shouldBe` Just (Left GErrAborted)+      readIORef closed `shouldReturn` True+      reverse <$> readIORef ref `shouldReturn` [TextDelta "a"]++    it "interrupts a non-streaming call in flight" $ do+      sig <- newAbortSignal+      started <- newEmptyMVar+      closed <- newIORef False+      let gw =+            (streamGateway [] (ChatResponse "" [] Nothing Nothing))+              { gwGenerateText = \_ _ ->+                  (putMVar started () >> hang >> pure (Left TimeoutError))+                    `finally` writeIORef closed True+              }+      abortAfter started sig+      r <- timeout 5_000_000 $ generateTextWithFallbacks (testGenRequest []) {grAbortSignal = Just sig} (ModelWithFallbacks (testModelConfig gw) [])+      fmap (fmap (.respText)) r `shouldBe` Just (Left GErrAborted)+      readIORef closed `shouldReturn` True++    it "interrupts the throttle sleep before a call" $ do+      sig <- newAbortSignal+      (gw, calls) <- countingGateway (Right (ChatResponse "hi" [textPart "hi"] Nothing Nothing))+      let mc = (testModelConfig gw) {mcThrottleDelay = Just 60_000}+      _ <- forkIO (threadDelay 50_000 >> abort sig)+      r <- timeout 5_000_000 $ generateTextWithFallbacks (testGenRequest []) {grAbortSignal = Just sig} (ModelWithFallbacks mc [])+      fmap (fmap (.respText)) r `shouldBe` Just (Left GErrAborted)+      readIORef calls `shouldReturn` 0++  describe "throttle" $ do+    it "sleeps the throttle delay before every attempt, retries included" $ do+      stamps <- newIORef []+      let gw =+            (streamGateway [] (ChatResponse "" [] Nothing Nothing))+              { gwGenerateText = \_ _ -> do+                  t <- getMonotonicTime+                  modifyIORef' stamps (t :)+                  pure (Left (HttpError 503 "overloaded"))+              }+          mc = (testModelConfig gw) {mcThrottleDelay = Just 100, mcRetryCount = 2}+      start <- getMonotonicTime+      _ <- generateTextLLM (testGenRequest []) mc+      ts <- reverse <$> readIORef stamps+      length ts `shouldBe` 3+      -- Backoff is 0 here, so each gap is the throttle alone.+      let gaps = zipWith (-) ts (start : ts)+      all (>= 0.1) gaps `shouldBe` True+   describe "modelRetryPolicy" $ do     it "caps the backoff delay at 30 s" $ do       let mc =@@ -228,6 +294,14 @@                      TextDelta "xyz",                      RoundTextRoleCommitted AnswerRole                    ]++-- | Block for a minute: long enough that only an abort ends it in a test.+hang :: IO ()+hang = threadDelay 60_000_000++-- | Fire @sig@ from another thread once @started@ is filled.+abortAfter :: MVar () -> AbortSignal -> IO ()+abortAfter started sig = () <$ forkIO (takeMVar started >> abort sig)  -- | First call streams @first@ (if non-empty) then fails with a retryable -- 503; later calls stream @second@ and succeed.

@@ -0,0 +1,79 @@+-- | How each provider's structured-output parser reports a response it+-- cannot use: empty content is 'EmptyResponse'; text that is not JSON, or a+-- body without the expected fields, is a 'ParseError' quoting the input.+module LLM.StructuredOutputSpec (spec) where++import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.LLMProvider (LLMProvider (..))+import LLM.Core.Types (LLMError (..))+import LLM.Providers.Claude (claudeProvider)+import LLM.Providers.DeepSeek (deepSeekProvider)+import LLM.Providers.Gemini (geminiProvider)+import LLM.Providers.Ollama (ollamaProvider)+import LLM.Providers.OpenAI (openAIProvider)+import Test.Hspec (Expectation, Spec, describe, expectationFailure, it, shouldBe)++-- | A provider, and how its API wraps the model's text in a response body.+data Case = Case+  { caseName :: String,+    caseProvider :: LLMProvider,+    caseBody :: Text -> Value,+    -- | Whether a body without the expected fields is a 'ParseError'+    -- (Gemini reports it as a missing candidate instead).+    caseShapeError :: Bool+  }++cases :: [Case]+cases =+  [ Case "OpenAI" (openAIProvider "") openAIBody True,+    Case "Ollama" ollamaProvider openAIBody True,+    Case "DeepSeek" (deepSeekProvider "") openAIBody True,+    Case "Claude" (claudeProvider "") claudeBody True,+    Case "Gemini" (geminiProvider "") geminiBody False+  ]+  where+    openAIBody t = object ["choices" .= [object ["message" .= object ["content" .= t]]]]+    claudeBody t = object ["content" .= [object ["type" .= ("text" :: Text), "text" .= t]]]+    geminiBody t =+      object+        [ "candidates"+            .= [ object+                   [ "content" .= object ["parts" .= [object ["text" .= t]]],+                     "finishReason" .= ("STOP" :: Text)+                   ]+               ]+        ]++spec :: Spec+spec = describe "Structured-output parse errors" $+  mapM_ providerSpec cases++providerSpec :: Case -> Spec+providerSpec c = describe c.caseName $ do+  it "decodes valid JSON text" $ do+    r <- c.caseProvider.parseObjectResponse (c.caseBody "{\"answer\": 42}")+    fmap fst r `shouldBe` Right (object ["answer" .= (42 :: Int)])++  it "reports text that is not JSON as a ParseError quoting the text" $ do+    r <- c.caseProvider.parseObjectResponse (c.caseBody "Sure! Here is the object: {\"answer\":")+    expectParseError r ["not valid JSON", "Sure! Here is the object"]++  it "reports empty text as EmptyResponse" $ do+    r <- c.caseProvider.parseObjectResponse (c.caseBody "  ")+    fmap fst r `shouldBe` Left EmptyResponse++  if c.caseShapeError+    then it "reports a body without the expected fields as a ParseError quoting the body" $ do+      r <- c.caseProvider.parseObjectResponse (object ["unexpected" .= True])+      expectParseError r ["unexpected response", "\"unexpected\":true"]+    else pure ()++expectParseError :: Either LLMError a -> [Text] -> Expectation+expectParseError (Left (ParseError msg)) needles =+  case filter (not . (`T.isInfixOf` msg)) needles of+    [] -> pure ()+    missing -> expectationFailure $ "ParseError " <> show msg <> " lacks " <> show missing+expectParseError (Left err) _ = expectationFailure $ "expected ParseError, got " <> show err+expectParseError (Right _) _ = expectationFailure "expected ParseError, got Right"

@@ -12,8 +12,9 @@ import LLM.Core.Types (ToolCall (..), ToolDef (..), ToolResult (..)) import LLM.Generate.GenerateUtils (llmHooks) import LLM.Generate.Logger (Hooks (..), LogLevel (..), noHooks, safeHooks)+import System.IO.Error (doesNotExistErrorType, mkIOError) import System.Timeout (timeout)-import Test.Hspec (Spec, describe, it, shouldBe, shouldContain)+import Test.Hspec (Spec, describe, it, shouldBe, shouldContain, shouldNotContain)  spec :: Spec spec = describe "ToolUtils" $ do@@ -89,6 +90,17 @@       let failing = mkTool "boom" (throwIO (userError "kaput"))       r <- executeTool noHooks ctx [failing] (mkCall "boom")       T.unpack r.trContent `shouldContain` "Tool error"++    it "executeTool drops an absolute file name from an IOException" $ do+      ctx <- mkContext (\_ -> pure ())+      let failing =+            mkTool "open" $+              throwIO (mkIOError doesNotExistErrorType "openFile" Nothing (Just "/home/someone/project/secret.txt"))+      r <- executeTool noHooks ctx [failing] (mkCall "open")+      let out = T.unpack r.trContent+      out `shouldNotContain` "/home/someone"+      out `shouldContain` "openFile"+      out `shouldContain` "does not exist"      it "emitEvent does not swallow a timeout in the observer" $ do       ctx <- mkContext (\_ -> threadDelay 1_000_000)