llm-simple (empty) → 0.1.0.1
raw patch · 80 files changed
+9034/−0 lines, 80 filesdep +aesondep +aeson-prettydep +autodocodec
Dependencies added: aeson, aeson-pretty, autodocodec, autodocodec-schema, base, bytestring, containers, directory, dotenv, filepath, heptapod, hspec, http-client, http-types, lens, llm-simple, mtl, optparse-applicative, req, retry, temporary, text, time, unordered-containers, uuid-types, vector
Files
- CHANGELOG.md +46/−0
- LICENSE +29/−0
- Readme.md +221/−0
- app/Main.hs +64/−0
- app/RecordConversation.hs +194/−0
- llm-simple.cabal +243/−0
- model-catalog.json +107/−0
- src/LLM.hs +183/−0
- src/LLM/Agent.hs +36/−0
- src/LLM/Agent/Events.hs +23/−0
- src/LLM/Agent/Generate.hs +155/−0
- src/LLM/Agent/GenerateObject.hs +40/−0
- src/LLM/Agent/ToolUtils.hs +201/−0
- src/LLM/Agent/Tools/HistoryTool.hs +107/−0
- src/LLM/Agent/Types.hs +114/−0
- src/LLM/Core.hs +44/−0
- src/LLM/Core/Abort.hs +31/−0
- src/LLM/Core/LLMProvider.hs +109/−0
- src/LLM/Core/ProviderUtils.hs +89/−0
- src/LLM/Core/SSE.hs +82/−0
- src/LLM/Core/Types.hs +187/−0
- src/LLM/Core/Usage.hs +50/−0
- src/LLM/Core/Utils.hs +137/−0
- src/LLM/Generate.hs +46/−0
- src/LLM/Generate/Generate.hs +129/−0
- src/LLM/Generate/GenerateObject.hs +108/−0
- src/LLM/Generate/GenerateUtils.hs +107/−0
- src/LLM/Generate/Logger.hs +119/−0
- src/LLM/Generate/ModelConfig.hs +54/−0
- src/LLM/Generate/Types.hs +106/−0
- src/LLM/Load.hs +67/−0
- src/LLM/Load/FsTools.hs +60/−0
- src/LLM/Load/LoadGateways.hs +46/−0
- src/LLM/Load/LoadModels.hs +97/−0
- src/LLM/Load/ModelCatalog.hs +34/−0
- src/LLM/Load/Types.hs +16/−0
- src/LLM/Load/Utils.hs +34/−0
- src/LLM/Providers.hs +29/−0
- src/LLM/Providers/Claude.hs +329/−0
- src/LLM/Providers/DeepSeek.hs +144/−0
- src/LLM/Providers/Gemini.hs +405/−0
- src/LLM/Providers/Ollama.hs +120/−0
- src/LLM/Providers/OpenAI.hs +415/−0
- src/LLM/Tools.hs +39/−0
- src/LLM/Tools/CopyFile.hs +62/−0
- src/LLM/Tools/CreateDirectory.hs +44/−0
- src/LLM/Tools/DirectoryTree.hs +135/−0
- src/LLM/Tools/FileInfo.hs +240/−0
- src/LLM/Tools/FindFiles.hs +242/−0
- src/LLM/Tools/FsConfig.hs +169/−0
- src/LLM/Tools/FsLimits.hs +138/−0
- src/LLM/Tools/Grep.hs +290/−0
- src/LLM/Tools/MoveFile.hs +61/−0
- src/LLM/Tools/MultiReplaceInFile.hs +104/−0
- src/LLM/Tools/ReadFilePaginated.hs +172/−0
- src/LLM/Tools/Readdir.hs +61/−0
- src/LLM/Tools/Readfile.hs +44/−0
- src/LLM/Tools/RemoveDirectory.hs +76/−0
- src/LLM/Tools/RemoveFile.hs +39/−0
- src/LLM/Tools/ReplaceInFile.hs +80/−0
- src/LLM/Tools/Writefile.hs +45/−0
- test/LLM/ChatSpec.hs +288/−0
- test/LLM/ClaudeSpec.hs +50/−0
- test/LLM/DeepSeekSpec.hs +106/−0
- test/LLM/FsConfigSpec.hs +151/−0
- test/LLM/FsLimitsSpec.hs +69/−0
- test/LLM/FsToolsSpec.hs +200/−0
- test/LLM/GeminiSpec.hs +43/−0
- test/LLM/GenerateObjectSpec.hs +163/−0
- test/LLM/GenericConversationTest.hs +111/−0
- test/LLM/HistoryToolSpec.hs +98/−0
- test/LLM/LoadSpec.hs +82/−0
- test/LLM/OpenAISpec.hs +45/−0
- test/LLM/RecordedConversationSpec.hs +84/−0
- test/LLM/StreamingSpec.hs +111/−0
- test/LLM/TestKit.hs +244/−0
- test/LLM/ToolUtilsSpec.hs +74/−0
- test/LLM/TypesSpec.hs +78/−0
- test/LLM/WeatherTool.hs +38/−0
- test/Spec.hs +1/−0
+ CHANGELOG.md view
@@ -0,0 +1,46 @@+# Changelog++All notable changes to this project are documented in this file.++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.1.0.1] - 2026-07-11++### Changed++- `loadModelsOrThrow` and `loadModelOrThrow` now throw catchable `LoadConfigError`+ exceptions via `throwIO` instead of calling `error`.+- Gateway loading no longer reads a `.env` file implicitly: `loadGateways` reads the+ process environment only; use `loadGatewaysWithDotenv` for local-dev convenience.+- Sandbox violation errors shown to the model omit absolute workspace paths.+- Streaming tool-call phase detection uses conversation context instead of stream+ ordering heuristics.+- Top-level `LLM` module export surface refined.+- `replace_in_file` and `multi_replace_in_file` refuse files larger than 1 MiB.+- `read_file_paginated` refuses source files larger than 10 MiB before line skipping.+- `rtReadonly` now blocks mutating tools at execution time, not only in the tool schema.++### Added++- `loadGatewaysWithDotenv` for explicit `.env` loading.+- `formatSandboxViolation` for workspace-relative sandbox error messages.+- `readBoundedTextFile` and `maxPaginatedFileBytes` filesystem resource limits.+- DeepSeek recorded conversation fixtures and `record-conversation` executable.+- Filesystem sandbox tests (`FsConfigSpec`, `FsLimitsSpec`, `FsToolsSpec`, `ToolUtilsSpec`).+- Load, streaming, history, and structured-output tests (`LoadSpec`, `StreamingSpec`, `HistoryToolSpec`, `GenerateObjectSpec`).++### Removed++- Weather tool moved from the library to test helpers.++## [0.1.0.0] - 2026-07-10++### Added++- Initial release: multi-provider LLM gateways (OpenAI, Claude, Gemini, Ollama,+ DeepSeek), single-shot generation with fallbacks, agent tool loops, structured+ output, JSON model catalog loading, and workspace-scoped filesystem tools.++[0.1.0.1]: https://github.com/aische/llm-simple/compare/v0.1.0.0...v0.1.0.1+[0.1.0.0]: https://github.com/aische/llm-simple/releases/tag/v0.1.0.0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2026, Daniel van den Eijkel+++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of the copyright holder nor the names of its+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Readme.md view
@@ -0,0 +1,221 @@+# llm-simple++An experimental Haskell **LLM toolbox** for trying out providers, tool loops, and workspace agents locally. It is meant to get you from zero to a working agent quickly — not to be a production agent platform.++The API stays small on purpose: a JSON model catalog, bundled filesystem tools, and a straight line from `loadModelOrThrow` to `generateText`. Under that surface you still get multi-provider gateways, fallbacks, streaming, structured output, and sandboxed workspace tools — enough to prototype and compare ideas without assembling the pieces yourself.++**Status:** early 0.1.x release. APIs may change.++## Features++- **Providers:** OpenAI, Claude, Gemini, Ollama, DeepSeek+- **Generate:** single-request text, streaming, and structured object generation with model fallbacks, timeouts, retries, and throttling+- **Agent:** multi-round tool loops (`generateText`, `streamText`, `generateObject`)+- **Tools:** filesystem tool suite with workspace path sandboxing+- **Load:** JSON model catalog and API-key gateway initialization+- **Observability:** hooks, logging, and generation lifecycle events++## Install++```bash+cabal build+```++Requires GHC 9.6+ with `GHC2021` (see `llm-simple.cabal`).++## Quick start++1. Create a `.env` file with API keys for the providers you use:++```env+OPENAI_API_KEY=...+CLAUDE_API_KEY=...+GEMINI_API_KEY=...+DEEPSEEK_API_KEY=...+```++Ollama needs no API key. The library reads keys from the **process environment**.+Load `.env` yourself in `main` (the example executable does this), or call+`loadGatewaysWithDotenv` when building gateways manually.++2. Configure models in `model-catalog.json` (an example is included in the repository and source distribution).++3. Create a workspace directory for filesystem tools (the example uses `./user-workspace/`).++4. Run the example executable:++```bash+cabal run llm-simple+```++The example loads `.env`, loads models from the catalog, wires up filesystem tools, and runs a small agent that asks about files in the workspace.++## Configuration++### Model catalog++Models are defined in a JSON array. Each entry maps a logical config name to a provider and model, plus runtime settings:++| Field | Description |+| ----------------- | ------------------------------------------------------------------------ |+| `modelConfigName` | Name used in code to look up this config |+| `providerName` | `"openai"`, `"claude"`, `"gemini"`, `"ollama"`, or `"deepseek"` |+| `modelName` | Provider-specific model identifier |+| `pricing` | `pricePerMillionInput` / `pricePerMillionOutput` for usage cost tracking |+| `maxTokens` | Max tokens per request |+| `temperature` | Sampling temperature (optional) |+| `requestTimeout` | Request timeout in ms (optional) |+| `throttleDelay` | Delay between requests in ms (optional) |+| `retryCount` | Number of retries on failure |+| `jitterBackoff` | Backoff jitter in ms between retries |+| `thinking` | Extended thinking effort level (optional, provider-dependent) |++A provider is only available if its API key is set (except Ollama, which is always available).++### Loading models++```haskell+import Configuration.Dotenv (defaultConfig, loadFile)+import Control.Exception (SomeException, catch)+import LLM.Load (loadModelsOrThrow)++main = do+ loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+ (gemini, deepseek) <-+ loadModelsOrThrow "./model-catalog.json" ("gemini_2_5_flash", "deepseek4flash")+ ...+```++`loadModelsOrThrow` takes a filepath and a tuple of config names, returning a tuple of `ModelConfig` values. Use `loadModelOrThrow` for a single model. On failure it throws a catchable `LoadConfigError`.++## Usage++### Agent with tools++An agent runs a loop: the model may call tools, results are fed back, and the loop continues until the model finishes or `agMaxToolRounds` is reached.++```haskell+import Configuration.Dotenv (defaultConfig, loadFile)+import Control.Exception (SomeException, catch)+import Heptapod (generate)+import LLM.Agent (Agent (..), RuntimeArgs (..), generateText, noEventObserver)+import LLM.Core (Turn (UserTurn))+import LLM.Generate (ModelWithFallbacks (..), Hooks (..), llmHooks, noHooks)+import LLM.Load (fsTools, loadModelsOrThrow)++main :: IO ()+main = do+ loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()++ (gemini, deepseek) <-+ loadModelsOrThrow "./model-catalog.json" ("gemini_2_5_flash", "deepseek4flash")++ let models = ModelWithFallbacks { mwfModel = gemini, mwfFallbacks = [deepseek] }++ toolMap <- fsTools "./user-workspace/"+ genId <- generate++ let agent =+ Agent+ { agName = "friendly-assistant",+ agSystemPrompt = Nothing,+ agTools = ["directory_tree"],+ agMaxToolRounds = 10,+ agContextWindow = Nothing+ }+ rt =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks noHooks,+ rtHooks = noHooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }++ r <- generateText agent models toolMap rt [UserTurn "what files are here?"]+ print r+```++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.++### Single request (no agent loop)++For one-shot generation without a tool loop, use the Generate layer directly:++```haskell+import LLM.Generate (GenRequest (..), generateTextWithFallbacks)++result <- generateTextWithFallbacks genRequest models+```++Also available: `streamTextWithFallbacks`, `genObject`, and `genObjectUntyped`.++### Custom tools++Define a `Tool` with a `ToolDef` (sent to the model) and an execution function, then add it to a `ToolMap`. Use `toTool` to convert typed tool definitions. See `LLM.Agent.ToolUtils` and the modules under `LLM.Tools`.++## Built-in filesystem tools++`fsTools` registers these tools, all scoped to a workspace root:++| Tool name | Purpose |+| ----------------------- | --------------------------------------- |+| `copy_file` | Copy a file |+| `create_directory` | Create a directory |+| `directory_tree` | Show directory tree |+| `file_info` | File metadata |+| `find_files` | Find files by pattern |+| `grep` | Search file contents |+| `move_file` | Move/rename a file |+| `multi_replace_in_file` | Multiple search-and-replace in one file |+| `readdir` | List directory contents |+| `read_file_paginated` | Read a file in pages |+| `remove_directory` | Remove a directory |+| `remove_file` | Remove a file |+| `replace_in_file` | Search-and-replace in a file |+| `writefile` | Write or overwrite a file |++Use `fsTools'` to map tool results through a custom embedding function.++### Filesystem sandbox++Filesystem tools enforce **workspace-relative path containment**: `..` escapes, absolute paths outside the workspace, and symlinks pointing outside are rejected. Recursive tools skip symlinks rather than following them.++**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.++## Module layout++| Module | Purpose |+| --------------- | -------------------------------------------------------------------------------------------------------------- |+| `LLM` | Convenience re-exports for common types, generation, loaders, and tool wiring |+| `LLM.Core` | Types, gateways, provider interface, usage tracking |+| `LLM.Providers` | Provider implementations (OpenAI, Claude, Gemini, Ollama, DeepSeek) |+| `LLM.Generate` | Single-request generation with fallbacks (`generateTextWithFallbacks`, `streamTextWithFallbacks`, `genObject`) |+| `LLM.Agent` | Agent loops with tool execution (`generateText`, `streamText`) |+| `LLM.Tools` | Built-in filesystem tool definitions |+| `LLM.Load` | Model catalog loading, gateway init, `fsTools` |++Import `LLM` for the common surface, or import sub-modules directly for agent loops, providers, and advanced configuration. Sub-module APIs are exposed but considered experimental in 0.1.x.++**Note:** Workflow support was removed from this repo and moved elsewhere.++## Testing++```bash+cabal test+```++Tests replay recorded provider responses from `test/fixtures/` so they run without live API calls.++## License++BSD-3-Clause. See [LICENSE](LICENSE).
+ app/Main.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ImpredicativeTypes #-}++module Main where++import Configuration.Dotenv (defaultConfig, loadFile)+import Control.Exception (SomeException, catch)+import Heptapod (generate)+import LLM.Agent+ ( Agent (..),+ RuntimeArgs (..),+ generateText,+ noEventObserver,+ )+import LLM.Core+ ( Turn (UserTurn),+ )+import LLM.Generate+ ( ModelWithFallbacks (..),+ defaultDebugHooks,+ llmHooks,+ )+import LLM.Load+ ( fsTools,+ loadModelsOrThrow,+ )++main :: IO ()+main = do+ loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+ (_gpt, llama, _haiku, gemini, mistral, deepseek) <-+ loadModelsOrThrow+ "./model-catalog.json"+ ("gpt_4_1", "llama_3_2", "haiku_4_5", "gemini_2_5_flash", "mistral", "deepseek4flash")++ let _models1 = ModelWithFallbacks {mwfModel = llama, mwfFallbacks = []}+ _models2 = ModelWithFallbacks {mwfModel = mistral, mwfFallbacks = []}+ _models3 = ModelWithFallbacks {mwfModel = gemini, mwfFallbacks = []}+ _models4 = ModelWithFallbacks {mwfModel = deepseek, mwfFallbacks = []}++ toolMap <-+ fsTools "./user-workspace/"+ genId <- generate+ let agent =+ Agent+ { agName = "friendly-assistant",+ agSystemPrompt = Nothing,+ agTools = ["directory_tree"],+ agMaxToolRounds = 10,+ agContextWindow = Nothing+ }+ rt =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks defaultDebugHooks,+ rtHooks = defaultDebugHooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }++ r <- generateText agent _models4 toolMap rt [UserTurn "are there any files in the current workspace?"]+ case r of+ Left err -> putStrLn $ "Error: " <> show err+ Right resp -> putStrLn $ "Response: " <> show resp
+ app/RecordConversation.hs view
@@ -0,0 +1,194 @@+module Main where++import Configuration.Dotenv (defaultConfig, loadFile)+import Control.Exception (SomeException, catch)+import Control.Monad (unless, void, when)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.Types (LLMGateway, ThinkingMode (..))+import LLM.Providers.Claude (claudeGateway)+import LLM.Providers.DeepSeek (deepSeekGateway)+import LLM.Providers.Gemini (geminiGateway)+import LLM.Providers.Ollama (ollamaGateway)+import LLM.Providers.OpenAI (openAIGateway)+import LLM.TestKit (recordConversation, recordedConversationPrompts)+import Options.Applicative+ ( Parser,+ ParserInfo,+ auto,+ execParser,+ fullDesc,+ header,+ help,+ helper,+ info,+ long,+ metavar,+ optional,+ option,+ progDesc,+ strOption,+ switch,+ value,+ (<**>),+ )+import System.Environment (lookupEnv)+import System.Exit (die)++data Options = Options+ { optProvider :: ProviderName,+ optModel :: Maybe Text,+ optThinking :: Bool,+ optNoThinking :: Bool,+ optThinkingEffort :: Maybe Text,+ optGeneratedOut :: FilePath,+ optStreamedOut :: FilePath,+ optGeneratedOnly :: Bool,+ optStreamedOnly :: Bool+ }++data ProviderName = Ollama | OpenAI | Claude | Gemini | DeepSeek+ deriving (Show, Read, Eq)++providerParser :: Parser ProviderName+providerParser =+ option auto $+ mconcat+ [ long "provider",+ metavar "PROVIDER",+ value DeepSeek,+ help "Provider to record (Ollama, OpenAI, Claude, Gemini, DeepSeek)"+ ]++optionsParser :: Parser Options+optionsParser =+ Options+ <$> providerParser+ <*> optional+ ( fmap T.pack $+ strOption $+ mconcat+ [ long "model",+ metavar "MODEL",+ help "Provider model name (defaults per provider when omitted)"+ ]+ )+ <*> switch+ ( mconcat+ [ long "thinking",+ help "Enable thinking mode (default for DeepSeek)"+ ]+ )+ <*> switch+ ( mconcat+ [ long "no-thinking",+ help "Disable thinking mode (overrides DeepSeek default)"+ ]+ )+ <*> optional+ ( fmap T.pack $+ strOption $+ mconcat+ [ long "thinking-effort",+ metavar "LEVEL",+ help "Thinking effort level (e.g. high, max)"+ ]+ )+ <*> strOption+ ( mconcat+ [ long "generated-out",+ metavar "PATH",+ help "Output path for non-streaming fixture"+ ]+ )+ <*> strOption+ ( mconcat+ [ long "streamed-out",+ metavar "PATH",+ help "Output path for streaming fixture"+ ]+ )+ <*> switch+ ( mconcat+ [ long "generated-only",+ help "Record only the non-streaming fixture"+ ]+ )+ <*> switch+ ( mconcat+ [ long "streamed-only",+ help "Record only the streaming fixture"+ ]+ )++main :: IO ()+main = do+ loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+ opts <- execParser optionsInfo+ when (opts.optGeneratedOnly && opts.optStreamedOnly) $+ die "--generated-only and --streamed-only are mutually exclusive"+ when (opts.optThinking && opts.optNoThinking) $+ die "--thinking and --no-thinking are mutually exclusive"+ gateway <- loadGateway opts.optProvider+ let modelName = fromMaybe (defaultModel opts.optProvider) opts.optModel+ thinking = resolveThinking opts+ putStrLn $+ unlines+ [ "Recording conversation fixtures",+ " provider: " <> show opts.optProvider,+ " model: " <> T.unpack modelName,+ " thinking: " <> show thinking,+ " prompts: " <> show (map T.unpack recordedConversationPrompts)+ ]+ unless opts.optStreamedOnly $+ void $ recordConversation False gateway modelName thinking opts.optGeneratedOut+ unless opts.optGeneratedOnly $+ void $ recordConversation True gateway modelName thinking opts.optStreamedOut+ putStrLn "Done."++optionsInfo :: ParserInfo Options+optionsInfo =+ info+ (optionsParser <**> helper)+ ( mconcat+ [ fullDesc,+ progDesc "Record live LLM conversation fixtures for replay tests.",+ header "record-conversation - capture provider request/response fixtures"+ ]+ )++loadGateway :: ProviderName -> IO LLMGateway+loadGateway = \case+ Ollama -> pure ollamaGateway+ OpenAI -> requireEnv "OPENAI_API_KEY" >>= pure . openAIGateway . T.pack+ Claude -> requireEnv "CLAUDE_API_KEY" >>= pure . claudeGateway . T.pack+ Gemini -> requireEnv "GEMINI_API_KEY" >>= pure . geminiGateway . T.pack+ DeepSeek -> requireEnv "DEEPSEEK_API_KEY" >>= pure . deepSeekGateway . T.pack++requireEnv :: String -> IO String+requireEnv name = do+ mVal <- lookupEnv name+ case mVal of+ Nothing -> die $ name <> " is not set"+ Just val | null val -> die $ name <> " is empty"+ Just val -> pure val++defaultModel :: ProviderName -> Text+defaultModel = \case+ Ollama -> "llama3.2:latest"+ OpenAI -> "gpt-4.1-2025-04-14"+ Claude -> "claude-haiku-4-5-20251001"+ Gemini -> "gemini-2.5-flash"+ DeepSeek -> "deepseek-v4-flash"++resolveThinking :: Options -> Maybe ThinkingMode+resolveThinking opts+ | opts.optNoThinking = Nothing+ | opts.optThinking || opts.optProvider == DeepSeek =+ Just+ ThinkingMode+ { tmEnabled = True,+ tmEffort = opts.optThinkingEffort+ }+ | otherwise = Nothing
+ llm-simple.cabal view
@@ -0,0 +1,243 @@+cabal-version: 3.0++name: llm-simple++version: 0.1.0.1++synopsis:+ Multi-provider LLM library with agent tool loops and filesystem tools++-- Note: 'description' is free-form Markdown.+description:+ Experimental Haskell library for talking to LLMs.+ .+ Features multi-provider gateways (OpenAI, Claude, Gemini, Ollama, DeepSeek),+ single-shot text/stream/object generation with model fallbacks, agent tool+ loops, structured output via Autodocodec, JSON model-catalog loading, and+ workspace-scoped filesystem tools.+ .+ Status: early 0.1.x release — APIs may change.++license: BSD-3-Clause++license-file: LICENSE++author: Daniel van den Eijkel++maintainer: 1515314+aische@users.noreply.github.com++category: AI++homepage: https://github.com/aische/llm-simple#readme++bug-reports: https://github.com/aische/llm-simple/issues++build-type: Simple++extra-doc-files:+ CHANGELOG.md+ Readme.md++extra-source-files:+ model-catalog.json++tested-with:+ GHC ==9.6.7++source-repository head+ type: git+ location: https://github.com/aische/llm-simple++common opts+ default-language: GHC2021+ default-extensions:+ ConstraintKinds+ DataKinds+ DeriveAnyClass+ DerivingStrategies+ DerivingVia+ LambdaCase+ OverloadedStrings+ OverloadedRecordDot+ DuplicateRecordFields+ NoFieldSelectors+ StrictData+ GADTs+ TypeFamilies+ ScopedTypeVariables+ ghc-options: + -Wall + -Wunused-imports+ -Werror=missing-fields++library+ import: opts+ exposed-modules:+ LLM+ LLM.Core+ LLM.Core.Abort+ LLM.Core.Types+ LLM.Core.LLMProvider+ LLM.Core.Usage+ LLM.Core.Utils+ LLM.Core.ProviderUtils++ LLM.Providers+ LLM.Providers.Gemini+ LLM.Providers.Claude+ LLM.Providers.OpenAI+ LLM.Providers.Ollama+ LLM.Providers.DeepSeek++ LLM.Agent+ LLM.Agent.Events+ LLM.Agent.Generate+ LLM.Agent.GenerateObject+ LLM.Agent.Tools.HistoryTool+ LLM.Agent.ToolUtils+ LLM.Agent.Types++ LLM.Generate+ LLM.Generate.Generate+ LLM.Generate.GenerateObject+ LLM.Generate.GenerateUtils+ LLM.Generate.ModelConfig+ LLM.Generate.Logger+ LLM.Generate.Types++ LLM.Tools+ LLM.Tools.DirectoryTree+ LLM.Tools.FileInfo+ LLM.Tools.FindFiles+ LLM.Tools.Grep+ LLM.Tools.MultiReplaceInFile+ LLM.Tools.Readfile+ LLM.Tools.ReadFilePaginated+ LLM.Tools.Writefile+ LLM.Tools.ReplaceInFile+ LLM.Tools.Readdir+ LLM.Tools.FsConfig+ LLM.Tools.FsLimits+ LLM.Tools.MoveFile+ LLM.Tools.CopyFile+ LLM.Tools.RemoveFile+ LLM.Tools.CreateDirectory+ LLM.Tools.RemoveDirectory++ LLM.Load+ LLM.Load.LoadGateways+ LLM.Load.ModelCatalog+ LLM.Load.LoadModels+ LLM.Load.Types+ LLM.Load.Utils+ LLM.Load.FsTools++ other-modules:+ LLM.Core.SSE+ hs-source-dirs: src+ build-depends:+ aeson >=2.0 && <2.3,+ aeson-pretty >=0.8 && <0.9,+ autodocodec >=0.5 && < 0.6,+ autodocodec-schema >=0.2 && <0.3,+ base ^>=4.18,+ bytestring >=0.11 && <0.12,+ containers ^>=0.6.7,+ directory >=1.3 && <1.4,+ dotenv >=0.9 && <0.13,+ filepath >=1.4 && <1.6,+ http-client >=0.7 && <0.8,+ http-types >=0.12 && <0.13,+ lens >=5.3 && <5.4,+ mtl >=2.3 && <2.4,+ req >=3.13.4 && <3.14,+ retry >=0.9 && <0.10,+ text >=1.2 && <2.2,+ time >=1.11 && <1.15,+ unordered-containers >=0.2 && < 0.3,+ uuid-types >=1.0 && <1.1,+ vector >=0.13 && <0.14,++executable llm-simple+ import: opts+ main-is: Main.hs+ other-modules: + hs-source-dirs: app+ build-depends:+ aeson >=2.0 && <2.3,+ autodocodec >=0.5 && < 0.6,+ autodocodec-schema >=0.2 && <0.3,+ base ^>=4.18,+ bytestring >=0.11 && <0.12,+ containers ^>=0.6.7,+ dotenv >=0.9 && <0.13,+ directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ heptapod >=1.1 && <1.2,+ llm-simple,+ mtl >=2.3 && <2.4,+ optparse-applicative >= 0.16 && <0.19,+ retry >=0.9 && <0.10,+ text >=1.2 && <2.2++executable record-conversation+ import: opts+ main-is: RecordConversation.hs+ other-modules: LLM.TestKit+ LLM.WeatherTool+ hs-source-dirs: app+ test+ build-depends:+ aeson >=2.0 && <2.3,+ aeson-pretty >=0.8 && <0.9,+ autodocodec >=0.5 && < 0.6,+ base ^>=4.18,+ bytestring >=0.11 && <0.12,+ containers ^>=0.6.7,+ dotenv >=0.9 && <0.13,+ directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ heptapod >=1.1 && <1.2,+ llm-simple,+ optparse-applicative >= 0.16 && <0.19,+ text >=1.2 && <2.2++test-suite llm-simple-test+ import: opts+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules: LLM.ClaudeSpec+ LLM.GeminiSpec+ LLM.GenericConversationTest+ LLM.RecordedConversationSpec+ LLM.OpenAISpec+ LLM.TypesSpec+ LLM.ChatSpec+ LLM.DeepSeekSpec+ LLM.FsConfigSpec+ LLM.FsLimitsSpec+ LLM.FsToolsSpec+ LLM.LoadSpec+ LLM.StreamingSpec+ LLM.HistoryToolSpec+ LLM.GenerateObjectSpec+ LLM.ToolUtilsSpec+ LLM.TestKit+ LLM.WeatherTool+ hs-source-dirs: test+ build-depends:+ base ^>=4.18,+ containers ^>=0.6.7,+ directory >=1.3 && <1.4,+ filepath >=1.4 && <1.6,+ temporary >=1.3 && <1.4,+ text >=1.2 && <2.2,+ aeson >=2.0 && <2.3,+ aeson-pretty >=0.8 && <0.9,+ autodocodec >=0.5 && < 0.6,+ bytestring >=0.11 && <0.12,+ hspec >=2.10 && <2.12,+ heptapod >=1.1 && <1.2,+ llm-simple,+ retry >=0.9 && <0.10+ build-tool-depends: hspec-discover:hspec-discover
+ model-catalog.json view
@@ -0,0 +1,107 @@+[+ {+ "modelConfigName": "gpt_4_1",+ "providerName": "openai",+ "modelName": "gpt-4.1-2025-04-14",+ "pricing": {+ "pricePerMillionInput": 2.0,+ "pricePerMillionOutput": 8.0+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 10000,+ "throttleDelay": 1000,+ "retryCount": 3,+ "jitterBackoff": 1000+ },+ {+ "modelConfigName": "llama_3_2",+ "providerName": "ollama",+ "modelName": "llama3.2:latest",+ "pricing": {+ "pricePerMillionInput": 0.0,+ "pricePerMillionOutput": 0.0+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 3000,+ "throttleDelay": 1000,+ "retryCount": 3,+ "jitterBackoff": 1000+ },+ {+ "modelConfigName": "mistral",+ "providerName": "ollama",+ "modelName": "mistral:latest",+ "pricing": {+ "pricePerMillionInput": 0.0,+ "pricePerMillionOutput": 0.0+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 30000,+ "throttleDelay": 1000,+ "retryCount": 3,+ "jitterBackoff": 1000+ },+ {+ "modelConfigName": "gemini_2_5_flash",+ "providerName": "gemini",+ "modelName": "gemini-2.5-flash",+ "pricing": {+ "pricePerMillionInput": 0.1,+ "pricePerMillionOutput": 0.4+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 10000,+ "throttleDelay": 1000,+ "retryCount": 3,+ "jitterBackoff": 1000+ },+ {+ "modelConfigName": "gemini_lite",+ "providerName": "gemini",+ "modelName": "gemini-3.1-flash-lite",+ "pricing": {+ "pricePerMillionInput": 0.1,+ "pricePerMillionOutput": 0.4+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 10000,+ "throttleDelay": 1000,+ "retryCount": 3,+ "jitterBackoff": 1000+ },+ {+ "modelConfigName": "haiku_4_5",+ "providerName": "claude",+ "modelName": "claude-haiku-4-5-20251001",+ "pricing": {+ "pricePerMillionInput": 1,+ "pricePerMillionOutput": 5+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 30000,+ "throttleDelay": 5000,+ "retryCount": 3,+ "jitterBackoff": 5000+ },+ {+ "modelConfigName": "deepseek4flash",+ "providerName": "deepseek",+ "modelName": "deepseek-v4-flash",+ "pricing": {+ "pricePerMillionInput": 0.14,+ "pricePerMillionOutput": 0.28+ },+ "maxTokens": 1024,+ "temperature": 0.5,+ "requestTimeout": 20000,+ "throttleDelay": 3000,+ "retryCount": 3,+ "jitterBackoff": 1000+ }+]
+ src/LLM.hs view
@@ -0,0 +1,183 @@+-- | Convenience re-exports for the most common integration path.+--+-- == Quick start+--+-- A typical agent application wires four pieces together:+--+-- 1. __Models__ — load a 'ModelConfig' (and optional fallbacks) from a JSON+-- catalog via 'loadModelOrThrow' or 'loadModelsOrThrow'. See 'LLM.Load' for+-- catalog format, provider names, and environment variables.+-- 2. __Tools__ — build a 'ToolMap' of implementations the model may call. Use+-- 'fsTools' for the bundled workspace-scoped filesystem tools, or define+-- custom tools with 'TypedTool' and 'toTool'.+-- 3. __Agent__ — configure an 'Agent' (system prompt, tool allow-list, optional+-- context window) and per-request 'RuntimeArgs' (hooks, abort signal,+-- readonly mode, lifecycle events).+-- 4. __Run__ — call 'generateText' or 'streamText' from 'LLM.Agent' with the+-- conversation so far as a list of 'Turn's.+--+-- @+-- import LLM+-- import LLM.Agent (generateText)+--+-- main = do+-- model <- loadModelOrThrow \"./model-catalog.json\" \"llama_3_2\"+-- tools <- fsTools \"./workspace\"+-- let agent = Agent { agName = \"demo\", agSystemPrompt = Nothing,+-- agTools = Map.keys tools, agMaxToolRounds = 10,+-- agContextWindow = Nothing }+-- rt <- mkRuntime -- your RuntimeArgs+-- result <- generateText agent (ModelWithFallbacks model []) tools rt+-- [UserTurn \"hello\"]+-- ...+-- @+--+-- == Two layers+--+-- * __Agent layer__ ('LLM.Agent') — multi-round tool loop, context windowing,+-- automatic @get_history@ injection, lifecycle events, and readonly enforcement.+-- Prefer this for chat agents and coding assistants.+-- * __Generate layer__ ('LLM.Generate') — single provider request with retries+-- and model fallbacks ('generateTextWithFallbacks', 'streamTextWithFallbacks',+-- 'genObject'). Use directly when you control the conversation loop yourself,+-- or via 'createGenRequest' to share agent configuration.+--+-- == Observability+--+-- * 'Hooks' — application-level callbacks (logging, request/response dumps,+-- tool call tracing). Passed through 'RuntimeArgs' / 'GenRequest'.+-- * 'LLMHooks' — provider wire logging. Set on 'RuntimeArgs' and bridged via+-- 'llmHooks'.+module LLM+ ( -- * Core conversation types+ Turn (..),+ ToolCall (..),+ ToolResult (..),+ ToolDef (..),+ TypedTool (..),+ ChatResponse (..),+ ContentBlock (..),+ LLMGateway (..),+ LLMError (..),+ Usage (..),+ PricingInfo (..),+ emptyUsage,+ addUsage,+ estimateCost,+ ThinkingMode (..),+ LLMHooks (..),+ AbortSignal,+ getToolCalls,++ -- * Single-shot generation+ generateTextWithFallbacks,+ streamTextWithFallbacks,+ genObject,+ genObjectUntyped,+ ModelConfig (..),+ ModelWithFallbacks (..),+ GenRequest (..),+ GenerateResult,+ GenerateError (..),+ GenerateErrorResult (..),+ GenerateTextResult (..),+ StreamChunk (..),+ RoundTextRole (..),+ GeneratableObject,+ Hooks (..),+ noHooks,+ llmHooks,+ defaultDebugHooks,+ debugHooks,++ -- * Agent and tool building blocks+ generateText,+ streamText,+ Agent (..),+ RuntimeArgs (..),+ Tool (..),+ ToolContext (..),+ createGenRequest,+ toTool,+ GenerateEvent (..),+ GenerateEventDetail (..),+ EventObserver,+ noEventObserver,++ -- * Model catalog and filesystem tool wiring+ loadModelOrThrow,+ loadModelsOrThrow,+ LoadConfigError (..),+ loadModelCatalog,+ ModelCatalogItem (..),+ ModelCatalogMap,+ fsTools,+ fsTools',+ )+where++import LLM.Agent+ ( Agent (..),+ EventObserver,+ GenerateEvent (..),+ GenerateEventDetail (..),+ RuntimeArgs (..),+ Tool (..),+ ToolContext (..),+ createGenRequest,+ generateText,+ noEventObserver,+ streamText,+ toTool,+ )+import LLM.Core+ ( AbortSignal,+ ChatResponse (..),+ ContentBlock (..),+ LLMError (..),+ LLMGateway (..),+ LLMHooks (..),+ PricingInfo (..),+ ThinkingMode (..),+ ToolCall (..),+ ToolDef (..),+ ToolResult (..),+ Turn (..),+ TypedTool (..),+ Usage (..),+ addUsage,+ emptyUsage,+ estimateCost,+ getToolCalls,+ )+import LLM.Generate+ ( GenRequest (..),+ GenerateError (..),+ GenerateErrorResult (..),+ GenerateResult,+ GenerateTextResult (..),+ GeneratableObject,+ Hooks (..),+ ModelConfig (..),+ ModelWithFallbacks (..),+ StreamChunk (..),+ RoundTextRole (..),+ debugHooks,+ defaultDebugHooks,+ genObject,+ genObjectUntyped,+ generateTextWithFallbacks,+ llmHooks,+ noHooks,+ streamTextWithFallbacks,+ )+import LLM.Load+ ( LoadConfigError (..),+ ModelCatalogItem (..),+ ModelCatalogMap,+ fsTools,+ fsTools',+ loadModelCatalog,+ loadModelOrThrow,+ loadModelsOrThrow,+ )
+ src/LLM/Agent.hs view
@@ -0,0 +1,36 @@+-- | Multi-round agent loop with tool execution.+--+-- 'generateText' and 'streamText' call the model, execute any returned tool+-- calls, append 'ToolTurn' results, and repeat until the model replies with+-- plain text or a limit is hit ('Agent.agMaxToolRounds', abort signal).+--+-- Tool implementations live in a separate 'ToolMap'; 'Agent.agTools' is the+-- allow-list of names exposed to the model. When 'Agent.agContextWindow' is+-- set, older turns are dropped from the provider request and a @get_history@+-- tool is injected automatically so the model can page through hidden history.+--+-- For structured output without tools, see 'generateObject' and+-- 'generateObjectUntyped'.+module LLM.Agent+ ( generateText,+ streamText,+ generateObject,+ generateObjectUntyped,+ Agent (..),+ RuntimeArgs (..),+ Tool (..),+ ToolContext (..),+ GenerateEvent (..),+ GenerateEventDetail (..),+ EventObserver,+ noEventObserver,+ toTool,+ createGenRequest,+ )+where++import LLM.Agent.Events+import LLM.Agent.Generate+import LLM.Agent.GenerateObject+import LLM.Agent.ToolUtils+import LLM.Agent.Types
+ src/LLM/Agent/Events.hs view
@@ -0,0 +1,23 @@+module LLM.Agent.Events+ ( emitEvent,+ noEventObserver,+ )+where++import Control.Exception (SomeException, try)+import Control.Monad (void)+import LLM.Agent.Types+ ( EventObserver,+ GenerateEvent (..),+ GenerateEventDetail,+ RuntimeArgs (..),+ )++-- | Emit a lifecycle event, attaching 'rtGenerationId' from runtime.+-- Observer exceptions are swallowed so observers cannot abort the loop.+emitEvent :: RuntimeArgs -> GenerateEventDetail -> IO ()+emitEvent rt detail =+ void (try (rt.rtOnEvent (GenerateEvent rt.rtGenerationId detail)) :: IO (Either SomeException ()))++noEventObserver :: EventObserver+noEventObserver _ = pure ()
+ src/LLM/Agent/Generate.hs view
@@ -0,0 +1,155 @@+{- HLINT ignore "Eta reduce" -}+module LLM.Agent.Generate+ ( streamText,+ generateText,+ )+where++import Data.Maybe (fromMaybe)+import Data.Text (Text)+import LLM.Agent.Events (emitEvent)+import LLM.Agent.ToolUtils+ ( createGenRequest,+ createToolContext,+ executeToolsWithAbort,+ getResolvedTools,+ )+import LLM.Agent.Types+ ( Agent (agMaxToolRounds),+ GenerateEventDetail (..),+ RuntimeArgs (..),+ ToolMap,+ )+import LLM.Core.Abort (isAbortedMaybe)+import LLM.Core.Types+ ( ChatResponse (..),+ Turn (..),+ )+import LLM.Core.Usage (Usage (..), emptyUsage)+import LLM.Core.Utils (getToolCalls)+import LLM.Generate.Generate+ ( generateTextWithFallbacks,+ streamTextWithFallbacks,+ )+import LLM.Generate.ModelConfig+ ( ModelWithFallbacks (..),+ )+import LLM.Generate.Types+ ( GenerateError (..),+ GenerateErrorResult (..),+ GenerateResult,+ GenerateTextResult (..),+ StreamChunk (..),+ )++-- | Run the agent loop until the model returns final text or the run fails.+--+-- On success, 'gtrNewMessages' contains only the turns produced during this+-- call (assistant and tool turns), not the input conversation.+-- Tool rounds continue until the model responds without tool calls or+-- 'Agent.agMaxToolRounds' is exceeded.+generateText ::+ Agent ->+ ModelWithFallbacks ->+ ToolMap Text ->+ RuntimeArgs ->+ [Turn] ->+ IO (Either GenerateErrorResult GenerateTextResult)+generateText agent models toolMap rt initialTurns =+ agentLoop+ (\a m r t -> generateTextWithFallbacks (createGenRequest id a toolMap r t) m)+ agent+ models+ toolMap+ rt+ initialTurns++-- | Like 'generateText', but streams token deltas via the callback.+--+-- The callback receives 'StreamChunk' values as the provider responds.+-- Tool rounds still run to completion; streaming applies to each model call.+-- Returns the same 'GenerateTextResult' / 'GenerateErrorResult' as 'generateText'.+streamText ::+ (StreamChunk -> IO ()) ->+ Agent ->+ ModelWithFallbacks ->+ ToolMap Text ->+ RuntimeArgs ->+ [Turn] ->+ IO (Either GenerateErrorResult GenerateTextResult)+streamText onChunk agent models toolMap rt initialTurns =+ agentLoop+ (\a m r t -> streamTextWithFallbacks onChunk (createGenRequest id a toolMap r t) m)+ agent+ models+ toolMap+ rt+ initialTurns++agentLoop ::+ (Agent -> ModelWithFallbacks -> RuntimeArgs -> [Turn] -> IO (GenerateResult ChatResponse)) ->+ Agent ->+ ModelWithFallbacks ->+ ToolMap Text ->+ RuntimeArgs ->+ [Turn] ->+ IO (Either GenerateErrorResult GenerateTextResult)+agentLoop call agent models toolMap rt initialTurns = do+ emitEvent rt GenerationStarted+ go initialTurns [] emptyUsage 0+ where+ go :: [Turn] -> [Turn] -> Usage -> Int -> IO (Either GenerateErrorResult GenerateTextResult)+ go currentTurns newTurnsAcc currentUsage loopCount = do+ aborted <- isAbortedMaybe rt.rtAbortSignal+ if aborted+ then do+ let errResult = GenerateErrorResult GErrAborted newTurnsAcc currentUsage+ emitEvent rt (GenerationFailed GErrAborted errResult)+ pure $ Left errResult+ else+ if loopCount >= agent.agMaxToolRounds+ then do+ let errResult = GenerateErrorResult GErrToolExceeded newTurnsAcc currentUsage+ emitEvent rt (GenerationFailed GErrToolExceeded errResult)+ pure $ Left errResult+ else do+ result <- call agent models rt currentTurns+ case result of+ Left err -> do+ let errResult = GenerateErrorResult err newTurnsAcc currentUsage+ emitEvent rt (GenerationFailed err errResult)+ pure $ Left errResult+ Right resp -> do+ let txt = resp.respText+ toolCalls = getToolCalls resp+ roundUsage = fromMaybe emptyUsage resp.respUsage+ newUsage = currentUsage <> roundUsage++ case toolCalls of+ [] -> do+ let finalTurn = AssistantTurn txt resp.respReasoning []+ finalTurnsAcc = newTurnsAcc ++ [finalTurn]+ successResult = GenerateTextResult rt.rtGenerationId finalTurnsAcc txt newUsage+ emitEvent rt (MessageFinalized finalTurn)+ emitEvent rt (GenerationFinished successResult)+ pure $ Right successResult+ _ -> do+ let assistantTurn = AssistantTurn txt resp.respReasoning toolCalls+ toolContext = createToolContext agent currentTurns newUsage rt+ tools = getResolvedTools id agent toolMap rt+ emitEvent rt (MessageCreated assistantTurn)+ emitEvent rt (ToolRoundStarted loopCount)++ toolResultsE <- executeToolsWithAbort rt.rtAbortSignal rt.rtHooks toolContext tools toolCalls++ case toolResultsE of+ Left err -> do+ let errResult = GenerateErrorResult err (newTurnsAcc ++ [assistantTurn]) newUsage+ emitEvent rt (GenerationFailed err errResult)+ pure $ Left errResult+ Right toolResults -> do+ let toolTurn = ToolTurn toolResults+ emitEvent rt (MessageCreated toolTurn)+ emitEvent rt (ToolRoundFinished loopCount)+ let turnsToAdd = [assistantTurn, toolTurn]+ go (currentTurns ++ turnsToAdd) (newTurnsAcc ++ turnsToAdd) newUsage (loopCount + 1)
+ src/LLM/Agent/GenerateObject.hs view
@@ -0,0 +1,40 @@+module LLM.Agent.GenerateObject where++import Data.Aeson (Value)+import Data.Map qualified as Map+import LLM.Agent.ToolUtils (createGenRequest)+import LLM.Agent.Types+ ( Agent (..),+ RuntimeArgs (..),+ )+import LLM.Core.Types+ ( Turn (..),+ )+import LLM.Core.Usage (Usage (..))+import LLM.Generate.GenerateObject+import LLM.Generate.ModelConfig+ ( ModelWithFallbacks (..),+ )+import LLM.Generate.Types (GeneratableObject, GenerateErrorResult)++-- | Generate a typed Haskell value from the model via Autodocodec.+--+-- Tools are not used; conversation context is taken from @turns@ only.+generateObject ::+ (GeneratableObject t) =>+ Agent ->+ ModelWithFallbacks ->+ RuntimeArgs ->+ [Turn] ->+ IO (Either GenerateErrorResult (t, Usage))+generateObject a m r t = genObject (createGenRequest id a Map.empty r t) m++-- | Generate a JSON 'Value' from the model using a caller-supplied schema.+generateObjectUntyped ::+ Agent ->+ ModelWithFallbacks ->+ RuntimeArgs ->+ [Turn] ->+ Value ->+ IO (Either GenerateErrorResult (Value, Usage))+generateObjectUntyped a m r t = genObjectUntyped (createGenRequest id a Map.empty r t) m
+ src/LLM/Agent/ToolUtils.hs view
@@ -0,0 +1,201 @@+module LLM.Agent.ToolUtils+ ( executeTool,+ executeTools,+ executeToolsWithAbort,+ createToolContext,+ getSchema,+ toTool,+ filterReadonlyTools,+ getResolvedTools,+ windowOffset,+ createGenRequest,+ embedTextTool,+ )+where++import Autodocodec qualified as AC+import Autodocodec.Schema (jsonSchemaVia)+import Control.Exception (SomeException, fromException, try)+import Data.Aeson (FromJSON)+import Data.Aeson qualified as AE+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Agent.Tools.HistoryTool (historyToolTyped)+import LLM.Agent.Types+ ( Agent (..),+ RuntimeArgs (..),+ Tool (Tool, toolDef, toolExecute),+ ToolContext (..),+ ToolMap,+ )+import LLM.Core.Abort (AbortSignal, isAborted)+import LLM.Core.Types+ ( ToolCall (..),+ ToolDef (..),+ ToolResult (..),+ Turn (..),+ TypedTool (TypedTool),+ )+import LLM.Core.Usage (Usage)+import LLM.Core.Utils (toolResult)+import LLM.Generate.Logger (Hooks (..))+import LLM.Generate.Types+ ( GenRequest (..),+ GenerateError (..),+ GenerateResult,+ )+import LLM.Tools.FsConfig (SandboxViolation, formatSandboxViolation)++-- | 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)+ 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+ else do+ hooks.onToolCall tc.tcName (AE.toJSON tc.tcArguments)+ result <- try (tool.toolExecute ctx tc.tcArguments)+ case result of+ Right text -> do+ hooks.onToolResult tc.tcName text+ pure $ toolResult tc text+ Left (e :: SomeException) -> do+ let msg = formatToolException e+ hooks.onToolError tc.tcName msg+ pure $ toolResult tc ("Tool error: " <> msg)+ where+ toolMap = [(t.toolDef.toolName, t) | t <- tools]++-- | Execute all tool calls from a response+executeTools :: Hooks -> ToolContext -> [Tool Text] -> [ToolCall] -> IO [ToolResult]+executeTools hooks ctx tools = mapM (executeTool hooks ctx tools)++-- | Execute tool calls one at a time, checking the abort signal between each.+-- Returns @Left Aborted@ if the signal fires before all calls finish.+executeToolsWithAbort :: Maybe AbortSignal -> Hooks -> ToolContext -> [Tool Text] -> [ToolCall] -> IO (GenerateResult [ToolResult])+executeToolsWithAbort Nothing hooks ctx tools tcs = Right <$> executeTools hooks ctx tools tcs+executeToolsWithAbort (Just sig) hooks ctx tools tcs = go [] tcs+ where+ go acc [] = pure (Right (reverse acc))+ go acc (tc : rest) = do+ aborted <- isAborted sig+ if aborted+ then pure (Left GErrAborted)+ else do+ r <- executeTool hooks ctx tools tc+ go (r : acc) rest++createToolContext ::+ Agent ->+ [Turn] ->+ Usage ->+ RuntimeArgs ->+ ToolContext+createToolContext agent messages roundUsage rt =+ ToolContext+ { tcConversation = messages,+ tcUsage = roundUsage,+ tcWindowOffset = windowOffset agent.agContextWindow messages,+ tcRuntimeArgs = rt+ }++getSchema :: (AC.HasCodec t, FromJSON t) => m ToolContext t -> AC.JSONCodec t+getSchema _ = AC.codec++-- | Convert a 'TypedTool' into a 'Tool' with JSON Schema parameters.+--+-- The executor receives parsed arguments (Autodocodec 'FromJSON'); invalid+-- JSON from the model returns an error string to the model without throwing.+toTool :: (AC.HasCodec args, FromJSON args) => TypedTool ToolContext args -> Tool Text+toTool t@(TypedTool name descr readonly exec) =+ Tool+ { toolDef =+ ToolDef+ { toolName = name,+ toolDescription = descr,+ toolReadonly = readonly,+ toolParameters = AE.toJSON $ jsonSchemaVia $ getSchema t+ },+ toolExecute = \ctx argsvalue ->+ case AE.fromJSON argsvalue of+ AE.Error e -> pure $ "Error: Parsing arguments failed " <> T.pack (show e)+ AE.Success args -> exec ctx args+ }++filterReadonlyTools :: Bool -> [Tool result] -> [Tool result]+filterReadonlyTools False tools = tools+filterReadonlyTools True tools = filter (\x -> x.toolDef.toolReadonly) tools++-- | Compute the index where the visible window starts.+-- The window includes the last @n@ user messages and all turns that follow+-- each of them (assistant replies, tool rounds, etc.).+-- Returns 0 (no windowing) when the window is 'Nothing' or the conversation+-- contains fewer than @n@ user messages.+windowOffset :: Maybe Int -> [Turn] -> Int+windowOffset Nothing _ = 0+windowOffset (Just n) conv = findNthUserFromEnd n conv++-- | Find the index of the Nth 'UserTurn' from the end of a conversation.+-- Returns 0 if there are fewer than @n@ user messages.+findNthUserFromEnd :: Int -> [Turn] -> Int+findNthUserFromEnd 0 _conv = 0+findNthUserFromEnd n conv = go (length conv - 1) n+ where+ go idx remaining+ | idx < 0 = 0+ | remaining <= 0 = idx + 1+ | otherwise = case conv !! idx of+ UserTurn _ -> go (idx - 1) (remaining - 1)+ _ -> go (idx - 1) remaining++-- | Build a 'GenRequest' from agent configuration and runtime state.+--+-- Applies context windowing ('windowOffset'), resolves tools from the+-- 'ToolMap' (including auto-injected @get_history@ when windowed), and+-- respects 'RuntimeArgs.rtReadonly' when selecting tool definitions.+createGenRequest :: (Text -> result) -> Agent -> ToolMap result -> RuntimeArgs -> [Turn] -> GenRequest+createGenRequest embed agent toolMap rt messages =+ let offset = windowOffset agent.agContextWindow messages+ tools = getResolvedTools embed agent toolMap rt+ in GenRequest+ { grSystemPrompt = agent.agSystemPrompt,+ grTools = map (\x -> x.toolDef) tools,+ grMessages = drop offset messages,+ grAbortSignal = rt.rtAbortSignal,+ grLLMHooks = rt.rtLLMHooks,+ grHooks = rt.rtHooks+ }++getResolvedTools :: (Text -> result) -> Agent -> ToolMap result -> RuntimeArgs -> [Tool result]+getResolvedTools embed agent toolMap rt = filterReadonlyTools rt.rtReadonly (getToolsFromMap toolMap agent.agTools) ++ fmap (embedTextTool embed) (getHistoryTool agent)++getToolsFromMap :: ToolMap result -> [Text] -> [Tool result]+getToolsFromMap toolMap toolNames = toolNames >>= lookupTool+ where+ lookupTool name = case Map.lookup name toolMap of+ Just tool -> [tool]+ Nothing -> []++getHistoryTool :: Agent -> [Tool Text]+getHistoryTool agent = case agent.agContextWindow of+ Just n | n > 0 -> [toTool historyToolTyped]+ _ -> []++embedTextTool :: (Text -> result) -> Tool Text -> Tool result+embedTextTool embed tool =+ tool+ { toolExecute = \ctx args -> do+ result <- tool.toolExecute ctx args+ pure $ embed result+ }++formatToolException :: SomeException -> Text+formatToolException e =+ case fromException e of+ Just (sv :: SandboxViolation) -> formatSandboxViolation sv+ Nothing -> T.pack (show e)
+ src/LLM/Agent/Tools/HistoryTool.hs view
@@ -0,0 +1,107 @@+module LLM.Agent.Tools.HistoryTool where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Agent.Types (ToolContext (..))+import LLM.Core.Types (ToolCall (tcName), ToolResult (trContent, trName), Turn (..), TypedTool (..))++newtype HistoryToolArgs = HistoryToolArgs+ { _historyChunk :: Int+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec HistoryToolArgs)++instance AC.HasCodec HistoryToolArgs where+ codec :: AC.JSONCodec HistoryToolArgs+ codec =+ AC.object "get conversation history" $+ HistoryToolArgs <$> AC.requiredField "chunk" "0 = most recent hidden chunk, 1 = the one before that, etc." AC..= (\x -> x._historyChunk)++getHistoryExecTyped :: ToolContext -> HistoryToolArgs -> IO Text+getHistoryExecTyped ctx args = do+ let chunkIdx = args._historyChunk+ hidden = take ctx.tcWindowOffset ctx.tcConversation+ if null hidden+ then pure "(no earlier history)"+ else do+ let -- Count user messages in the visible window to determine page size+ nUserMessages = countUserTurns (drop ctx.tcWindowOffset ctx.tcConversation)+ -- Chunk the hidden prefix into pages of N user messages each+ chunks = chunkBackward nUserMessages hidden+ if chunkIdx < 0 || chunkIdx >= length chunks+ then pure "(no more history)"+ else pure $ formatChunk (chunks !! chunkIdx)++historyToolTyped :: TypedTool ToolContext HistoryToolArgs+historyToolTyped =+ TypedTool+ { ttoolName = "get_history",+ ttoolDescription =+ "Retrieve earlier conversation history that is not in your current context window. "+ <> "Pass chunk=0 for the most recent hidden history, chunk=1 for the one before that, etc. "+ <> "Returns an empty result when there is no more history.",+ ttoolReadonly = True,+ ttoolExecute = getHistoryExecTyped+ }++-- | Count the number of 'UserTurn's in a conversation.+countUserTurns :: [Turn] -> Int+countUserTurns = length . filter isUserTurn++isUserTurn :: Turn -> Bool+isUserTurn (UserTurn _) = True+isUserTurn _ = False++-- | Split a conversation into pages of @n@ user messages each, working+-- backward from the end. Each page starts at a 'UserTurn'.+-- Chunk 0 is the most recent page, chunk 1 the one before, etc.+-- The oldest chunk (highest index) may contain fewer than @n@ user messages.+chunkBackward :: Int -> [Turn] -> [[Turn]]+chunkBackward _ [] = []+chunkBackward n conv = reverse (go (length conv) [])+ where+ go 0 acc = acc+ go end acc =+ let start = findNthUserBack n (take end conv)+ page = slice start end conv+ in go start (page : acc)++-- | Find the start index for a page containing @n@ user messages,+-- scanning backward from the end of the given prefix.+-- Returns 0 if fewer than @n@ user messages remain.+findNthUserBack :: Int -> [Turn] -> Int+findNthUserBack n conv = go (length conv - 1) n+ where+ go idx remaining+ | idx < 0 = 0+ | remaining <= 0 = idx + 1+ | otherwise = case conv !! idx of+ UserTurn _ -> go (idx - 1) (remaining - 1)+ _ -> go (idx - 1) remaining++-- | Extract a slice [start, end) from a list.+slice :: Int -> Int -> [a] -> [a]+slice start end = take (end - start) . drop start++-- | Format a chunk of conversation turns as readable text.+formatChunk :: [Turn] -> Text+formatChunk = T.intercalate "\n" . map formatTurn++formatTurn :: Turn -> Text+formatTurn (UserTurn t) = "[User] " <> t+formatTurn (AssistantTurn t mReasoning calls) =+ "[Assistant] "+ <> t+ <> maybe "" (\r -> " [reasoning: " <> T.take 200 r <> "]") mReasoning+ <> if null calls+ then ""+ else " [called: " <> T.intercalate ", " (map (\x -> x.tcName) calls) <> "]"+formatTurn (ToolTurn results) =+ "[Tool results] "+ <> T.intercalate ", " [r.trName <> ": " <> T.take 200 r.trContent | r <- results]++-- parseChunk :: Value -> Parser Int+-- parseChunk = withObject "args" (.: "chunk")
+ src/LLM/Agent/Types.hs view
@@ -0,0 +1,114 @@+module LLM.Agent.Types+ ( Agent (..),+ RuntimeArgs (..),+ Tool (..),+ ToolMap,+ ToolContext (..),+ GenerateEvent (..),+ GenerateEventDetail (..),+ EventObserver,+ )+where++import Data.Aeson (Value)+import Data.Map (Map)+import Data.Text (Text)+import Data.UUID.Types (UUID)+import LLM.Core.Abort (AbortSignal)+import LLM.Core.Types+ ( LLMHooks,+ ToolDef (..),+ Turn,+ )+import LLM.Core.Usage (Usage)+import LLM.Generate.Logger (Hooks)+import LLM.Generate.Types (GenerateError, GenerateErrorResult, GenerateTextResult)++-- | Static agent configuration shared across requests.+data Agent = Agent+ { -- | Display name used in logs and debug hooks.+ agName :: Text,+ -- | Optional system prompt prepended to every provider request.+ agSystemPrompt :: Maybe Text,+ -- | Tool names from the 'ToolMap' that may be sent to the model.+ -- Only these names are exposed; the map may contain additional tools.+ agTools :: [Text],+ -- | Maximum number of model→tool rounds before returning 'GErrToolExceeded'.+ agMaxToolRounds :: Int,+ -- | When 'Just', only the last @n@ user messages (and their follow-on+ -- turns) are sent to the provider. Older turns remain in 'ToolContext' and+ -- can be retrieved via the auto-injected @get_history@ tool.+ agContextWindow :: Maybe Int+ }++-- | Per-generation runtime state and callbacks.+data RuntimeArgs = RuntimeArgs+ { -- | Correlates lifecycle events and result records for one run.+ rtGenerationId :: UUID,+ -- | When fired, in-flight generation and tool execution stop cooperatively.+ rtAbortSignal :: Maybe AbortSignal,+ -- | Provider wire hooks (request/response JSON). See 'LLMHooks'.+ rtLLMHooks :: LLMHooks,+ -- | Application hooks: logging, tool tracing, JSON dumps. See 'Hooks'.+ rtHooks :: Hooks,+ -- | Observer for 'GenerateEvent' lifecycle notifications (UI, telemetry).+ rtOnEvent :: EventObserver,+ -- | When 'True', mutating tools are rejected at execution time even if+ -- they appear in 'Agent.agTools'. Read-only tools still run.+ rtReadonly :: Bool+ }++-- | A tool: its definition (sent to the model) paired with its implementation.+--+-- 'toolExecute' receives a 'ToolContext' (full conversation + usage) and+-- the JSON arguments from the model.+data Tool result = Tool+ { toolDef :: ToolDef,+ toolExecute :: ToolContext -> Value -> IO result+ }++-- | Map from tool name to implementation. Built manually or via 'fsTools'.+type ToolMap result = Map Text (Tool result)++-- | Context passed to tool implementations during execution.+data ToolContext = ToolContext+ { -- | Full conversation history (not windowed), one message per turn+ tcConversation :: [Turn],+ -- | Accumulated token usage so far+ tcUsage :: Usage,+ -- | Index into 'tcConversation' where the visible window starts.+ -- Everything before this index is hidden from the model.+ -- The @get_history@ tool uses this to serve paginated history.+ tcWindowOffset :: Int,+ tcRuntimeArgs :: RuntimeArgs+ }++-- | Generation lifecycle event tagged with the run's 'rtGenerationId'.+data GenerateEvent = GenerateEvent+ { geGenerationId :: UUID,+ geDetail :: GenerateEventDetail+ }+ deriving (Show, Eq)++-- | Details carried by a 'GenerateEvent'.+data GenerateEventDetail+ = -- | The agent loop has started.+ GenerationStarted+ | -- | Final assistant text is ready.+ GenerationFinished GenerateTextResult+ | -- | The run failed; partial turns and usage are in the 'GenerateErrorResult'.+ GenerationFailed GenerateError GenerateErrorResult+ | -- | A new turn was appended (assistant tool-call round or tool results).+ MessageCreated Turn+ | -- | Streaming update to an in-flight assistant message (unused by default loop).+ MessageUpdated UUID Text+ | -- | The final assistant turn for a successful run.+ MessageFinalized Turn+ | -- | Tool execution for round @n@ is about to start.+ ToolRoundStarted Int+ | -- | Tool execution for round @n@ finished.+ ToolRoundFinished Int+ deriving (Show, Eq)++-- | Callback invoked for each 'GenerateEvent' during a run.+type EventObserver = GenerateEvent -> IO ()
+ src/LLM/Core.hs view
@@ -0,0 +1,44 @@+-- | Core types and functions for LLM operations+module LLM.Core+ ( LLMGateway (..),+ ChatRequest (..),+ ChatResponse (..),+ LLMTextResult,+ LLMObjectResult,+ LLMResult,+ LLMError (..),+ Turn (..),+ ToolCall (..),+ ToolResult (..),+ LLMHooks (..),+ TypedTool (..),+ ToolDef (..),+ ContentBlock (..),+ StreamEvent (..),+ ThinkingMode (..),+ MessageEncodeOptions (..),+ defaultMessageEncodeOptions,+ deepSeekMessageEncodeOptions,+ assistantTurn,+ Usage (..),+ PricingInfo (..),+ emptyUsage,+ addUsage,+ estimateCost,+ AbortSignal,+ newAbortSignal,+ abort,+ isAborted,+ isAbortedMaybe,+ LLMProvider (..),+ hasToolCalls,+ getToolCalls,+ toolResult,+ )+where++import LLM.Core.Abort+import LLM.Core.LLMProvider+import LLM.Core.Types+import LLM.Core.Usage+import LLM.Core.Utils
+ src/LLM/Core/Abort.hs view
@@ -0,0 +1,31 @@+module LLM.Core.Abort+ ( AbortSignal,+ newAbortSignal,+ abort,+ isAborted,+ isAbortedMaybe,+ )+where++import Data.IORef (IORef, newIORef, readIORef, writeIORef)++-- | A cooperative 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)++-- | Create a fresh signal (not yet aborted).+newAbortSignal :: IO AbortSignal+newAbortSignal = AbortSignal <$> newIORef False++-- | Fire the signal. Idempotent — calling it more than once is harmless.+abort :: AbortSignal -> IO ()+abort (AbortSignal ref) = writeIORef ref True++-- | Check whether the signal has been fired.+isAborted :: AbortSignal -> IO Bool+isAborted (AbortSignal ref) = readIORef ref++isAbortedMaybe :: Maybe AbortSignal -> IO Bool+isAbortedMaybe Nothing = pure False+isAbortedMaybe (Just sig) = isAborted sig
+ src/LLM/Core/LLMProvider.hs view
@@ -0,0 +1,109 @@+module LLM.Core.LLMProvider+ ( LLMProvider (..),+ toGateway,+ genericGenerateText,+ genericStreamText,+ )+where++import Control.Exception (try)+import Data.Aeson (Value)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.Types+ ( ChatRequest (reqTools),+ LLMError (HttpError, NetworkError),+ LLMGateway (..),+ LLMHooks (..),+ LLMObjectResult,+ LLMTextResult,+ StreamEvent,+ )+import LLM.Core.Utils (streamResponseJson)+import Network.HTTP.Req (HttpException)++data LLMProvider = LLMProvider+ { -- | Provider name for logging/hooks (e.g. "claude", "gemini", "openai")+ providerName :: Text,+ -- | Build the JSON request body. Bool indicates whether streaming is requested.+ buildBody :: Bool -> ChatRequest -> Value,+ -- | Make a non-streaming HTTP call, returning (status code, response JSON).+ sendRequest :: Value -> IO (Int, Value),+ -- | Make a streaming HTTP call. The handler receives the raw response+ -- and should parse it (checking status, reading body, etc.).+ sendStreamRequest :: Value -> (StreamEvent -> IO ()) -> IO LLMTextResult,+ -- | Parse a complete (non-streaming) JSON response body.+ parseResponse :: Value -> IO LLMTextResult,+ -- | Build the JSON request body for object generation.+ buildObjectBody :: ChatRequest -> Value -> Value,+ -- | Make a non-streaming HTTP call for object generation, returning (status code, response JSON).+ sendObjectRequest :: Value -> IO (Int, Value),+ -- | Parse a complete JSON response body for object generation.+ parseObjectResponse :: Value -> IO LLMObjectResult+ }++-- | Generic streaming chat via the LLMProvider.+genericStreamText :: LLMProvider -> LLMHooks -> ChatRequest -> (StreamEvent -> IO ()) -> IO LLMTextResult+genericStreamText p hooks r callback = do+ let body = p.buildBody True r+ hooks.onLLMRequest p.providerName body+ result <- try (p.sendStreamRequest body callback)+ case result of+ Left e -> do+ hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))+ pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+ Right r' -> do+ case r' of+ Right resp -> do+ hooks.onLLMResponse p.providerName (streamResponseJson resp)+ pure r'+ Left e -> do+ hooks.onLLMResponseError p.providerName (T.pack (show e))+ pure $ Left e++-- | Generic non-streaming chat via the LLMProvider.+genericGenerateText :: LLMProvider -> LLMHooks -> ChatRequest -> IO LLMTextResult+genericGenerateText p hooks r = do+ let body = p.buildBody False r+ hooks.onLLMRequest p.providerName body+ result <- try (p.sendRequest body)+ case result of+ Left e -> do+ hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))+ pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+ Right (status, respBody) -> do+ hooks.onLLMResponse p.providerName respBody+ if status == 200+ then p.parseResponse respBody+ else do+ hooks.onLLMResponseError p.providerName ("HTTP error: " <> T.pack (show status) <> " " <> T.pack (show respBody))+ pure $ Left $ HttpError status (T.pack $ show respBody)++-- | Generic object generation via the LLMProvider.+genericGenerateObject :: LLMProvider -> LLMHooks -> Value -> ChatRequest -> IO LLMObjectResult+genericGenerateObject p hooks schema r = do+ let body = p.buildObjectBody r {reqTools = []} schema+ hooks.onLLMRequest p.providerName body+ result <- try (p.sendObjectRequest body)+ case result of+ Left e -> do+ hooks.onLLMResponseError p.providerName (T.pack (show (e :: HttpException)))+ pure $ Left $ NetworkError (T.pack (show (e :: HttpException)))+ Right (status, respBody) -> do+ hooks.onLLMResponse p.providerName respBody+ if status == 200+ then p.parseObjectResponse respBody+ else do+ hooks.onLLMResponseError p.providerName ("HTTP error: " <> T.pack (show status) <> " " <> T.pack (show respBody))+ pure $ Left $ HttpError status (T.pack $ show respBody)++-- | Convert any LLMProvider instance into a LLMGateway.+-- LLMHooks are not baked in — they are passed at call time.+toGateway :: LLMProvider -> LLMGateway+toGateway p =+ LLMGateway+ { gwName = p.providerName,+ gwGenerateText = genericGenerateText p,+ gwStreamText = genericStreamText p,+ gwGenerateObject = genericGenerateObject p+ }
+ src/LLM/Core/ProviderUtils.hs view
@@ -0,0 +1,89 @@+module LLM.Core.ProviderUtils+ ( lenientConfig,+ readAll,+ handleStreamResponse,+ normalizeSchemaOpenAI,+ stripJsonFences,+ stripBoundsAndComments,+ )+where++import Data.Aeson (ToJSON (toJSON), Value (..))+import Data.Aeson.KeyMap qualified as KM+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8)+import LLM.Core.Types (LLMError (HttpError), LLMTextResult)+import Network.HTTP.Client qualified as HC+import Network.HTTP.Req (HttpConfig, defaultHttpConfig, httpConfigCheckResponse)+import Network.HTTP.Types.Status (statusCode)++-- | Don't let req throw on non-2xx; we handle errors ourselves+lenientConfig :: HttpConfig+lenientConfig =+ defaultHttpConfig+ { httpConfigCheckResponse = \_ _ _ -> Nothing+ }++-- | Accumulate all chunks from a BodyReader for error messages+readAll :: HC.BodyReader -> IO [BS.ByteString]+readAll br = do+ chunk <- HC.brRead br+ if BS.null chunk then pure [] else (chunk :) <$> readAll br++-- | Handle streaming response: check status, read error body or delegate+-- to the provider-specific stream parser.+handleStreamResponse :: HC.Response HC.BodyReader -> (HC.BodyReader -> IO LLMTextResult) -> IO LLMTextResult+handleStreamResponse resp handler = do+ let status = statusCode (HC.responseStatus resp)+ if status /= 200+ then do+ chunks <- readAll (HC.responseBody resp)+ pure $ Left $ HttpError status (decodeUtf8 (BS.concat chunks))+ else handler (HC.responseBody resp)++-- | Recursively enforce OpenAI structured output constraints:+-- every object node gets additionalProperties:false and all keys in required.+normalizeSchemaOpenAI :: Value -> Value+normalizeSchemaOpenAI (Object o) =+ let o' = fmap normalizeSchemaOpenAI o+ fixed = case KM.lookup "type" o' of+ Just (String "object") ->+ let propKeys = case KM.lookup "properties" o' of+ Just (Object p) -> KM.keys p+ _ -> []+ withAP = KM.insert "additionalProperties" (Bool False) o'+ withReq = KM.insert "required" (toJSON propKeys) withAP+ in withReq+ _ -> o'+ in Object fixed+normalizeSchemaOpenAI (Array a) = Array (fmap normalizeSchemaOpenAI a)+normalizeSchemaOpenAI v = v++stripJsonFences :: Text -> Text+stripJsonFences t =+ let t' = T.strip t+ t'' =+ if "```" `T.isPrefixOf` t'+ then T.strip . T.drop 1 . T.dropWhile (/= '\n') $ t'+ else t'+ t''' =+ if "```" `T.isSuffixOf` t''+ then T.strip $ T.dropEnd 3 t''+ else t''+ in t'''++-- | Recursively removes "minimum" and "maximum" keys from a JSON Value, also $comment fields+stripBoundsAndComments :: Value -> Value+stripBoundsAndComments (Object obj) =+ Object $+ KM.fromList+ [ (k, stripBoundsAndComments v)+ | (k, v) <- KM.toList obj,+ k /= "minimum",+ k /= "maximum",+ k /= "$comment"+ ]+stripBoundsAndComments (Array arr) = Array (fmap stripBoundsAndComments arr)+stripBoundsAndComments other = other
+ src/LLM/Core/SSE.hs view
@@ -0,0 +1,82 @@+module LLM.Core.SSE (SSEEvent (..), readSSEEvents) where++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.Text (Text)+import Data.Text.Encoding qualified as TE++data SSEEvent = SSEEvent+ { sseEvent :: Maybe Text,+ sseData :: Text+ }+ deriving (Show)++-- | 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 ()+readSSEEvents readChunk callback = do+ bufRef <- newIORef BS.empty+ let readLine :: IO (Maybe ByteString)+ readLine = do+ buf <- readIORef bufRef+ case BC.elemIndex '\n' buf of+ Just i -> do+ let (line, rest) = BS.splitAt i buf+ line' =+ if not (BS.null line) && BC.last line == '\r'+ then BS.init line+ else line+ writeIORef bufRef (BS.drop 1 rest)+ pure (Just line')+ Nothing -> do+ chunk <- readChunk+ if BS.null chunk+ then+ if BS.null buf+ then pure Nothing+ else do+ writeIORef bufRef BS.empty+ pure (Just buf)+ else do+ writeIORef bufRef (buf <> chunk)+ readLine++ loop :: Maybe Text -> [ByteString] -> IO ()+ loop eventType dataLines = do+ mLine <- readLine+ case mLine of+ Nothing ->+ unless (null dataLines) $+ fireEvent eventType dataLines+ Just line+ | BS.null line -> do+ unless (null dataLines) $+ fireEvent eventType dataLines+ loop Nothing []+ | "data:" `BS.isPrefixOf` line ->+ loop eventType (stripField 5 line : dataLines)+ | "event:" `BS.isPrefixOf` line ->+ loop (Just (TE.decodeUtf8 (stripField 6 line))) dataLines+ | ":" `BS.isPrefixOf` line ->+ loop eventType dataLines -- comment, skip+ | otherwise ->+ loop eventType dataLines++ stripField :: Int -> ByteString -> ByteString+ stripField n bs =+ let rest = BS.drop n bs+ in if not (BS.null rest) && BC.head rest == ' '+ then BS.tail rest+ else rest++ fireEvent :: Maybe Text -> [ByteString] -> IO ()+ fireEvent eventType dataLines =+ callback+ SSEEvent+ { sseEvent = eventType,+ sseData = TE.decodeUtf8 (BS.intercalate "\n" (reverse dataLines))+ }+ loop Nothing []
+ src/LLM/Core/Types.hs view
@@ -0,0 +1,187 @@+module LLM.Core.Types+ ( Turn (..),+ assistantTurn,+ ContentBlock (..),+ ChatRequest (..),+ ChatResponse (..),+ LLMError (..),+ LLMTextResult,+ LLMObjectResult,+ LLMResult,+ ToolDef (..),+ ToolCall (..),+ mkToolCall,+ LLMGateway (..),+ ToolResult (..),+ StreamEvent (..),+ TypedTool (..),+ LLMHooks (..),+ ThinkingMode (..),+ MessageEncodeOptions (..),+ defaultMessageEncodeOptions,+ deepSeekMessageEncodeOptions,+ )+where++import Data.Aeson (FromJSON, ToJSON, Value)+import Data.Text (Text)+import GHC.Generics (Generic)+import LLM.Core.Usage (Usage)++-- | Provider adapter for one LLM backend.+--+-- Implement the three callbacks to add a custom provider, or use the+-- bundled constructors in 'LLM.Providers'.+data LLMGateway = LLMGateway+ { -- | Short name used in logs and hooks (e.g. @openai@).+ gwName :: Text,+ -- | Non-streaming chat completion.+ gwGenerateText :: LLMHooks -> ChatRequest -> IO LLMTextResult,+ -- | Streaming chat; invoke the callback for each 'StreamEvent'.+ gwStreamText :: LLMHooks -> ChatRequest -> (StreamEvent -> IO ()) -> IO LLMTextResult,+ -- | Structured JSON output against a caller-supplied schema.+ gwGenerateObject :: LLMHooks -> Value -> ChatRequest -> IO LLMObjectResult+ }++-- | Result of an LLM operation: either an error, a chat response, or a generated object+type LLMResult a = Either LLMError a++type LLMTextResult = LLMResult ChatResponse++type LLMObjectResult = LLMResult (Value, Maybe Usage)++-- | Hooks for observing raw provider request and response JSON on the wire.+--+-- Distinct from 'LLM.Generate.Logger.Hooks', which covers application-level+-- logging and tool tracing. Bridge to this type via 'llmHooks'.+data LLMHooks = LLMHooks+ { onLLMRequest :: Text -> Value -> IO (),+ onLLMResponse :: Text -> Value -> IO (),+ onLLMResponseError :: Text -> Text -> IO ()+ }++-- | DeepSeek thinking mode configuration.+data ThinkingMode = ThinkingMode+ { tmEnabled :: Bool,+ tmEffort :: Maybe Text -- e.g. @high@ or @max@+ }+ deriving (Show, Eq)++-- | Controls how conversation turns are encoded for provider APIs.+newtype MessageEncodeOptions = MessageEncodeOptions+ { meoIncludeReasoning :: Bool+ }+ deriving (Show, Eq)++defaultMessageEncodeOptions :: MessageEncodeOptions+defaultMessageEncodeOptions = MessageEncodeOptions {meoIncludeReasoning = False}++deepSeekMessageEncodeOptions :: MessageEncodeOptions+deepSeekMessageEncodeOptions = MessageEncodeOptions {meoIncludeReasoning = True}++-- | A single turn in a conversation+data Turn+ = UserTurn Text+ | AssistantTurn Text (Maybe Text) [ToolCall] -- content, reasoning_content, tool calls+ | ToolTurn [ToolResult]+ deriving (Show, Eq, Generic, FromJSON, ToJSON)++assistantTurn :: Text -> Maybe Text -> [ToolCall] -> Turn+assistantTurn = AssistantTurn++-- | A tool definition sent to the model+data ToolDef = ToolDef+ { toolName :: Text,+ toolDescription :: Text,+ toolParameters :: Value, -- JSON Schema object+ -- | When 'True', the tool is advertised as read-only and remains available+ -- when 'RuntimeArgs.rtReadonly' is set. Mutating tools should use 'False'.+ toolReadonly :: Bool+ }+ deriving (Show, Eq)++-- | Typed tool definition before conversion to 'Tool' via 'toTool'.+--+-- Define one with an Autodocodec argument type; 'toTool' derives the JSON+-- Schema for 'ToolDef.toolParameters' automatically.+data TypedTool c a = TypedTool+ { ttoolName :: Text,+ ttoolDescription :: Text,+ ttoolReadonly :: Bool,+ ttoolExecute :: c -> a -> IO Text+ }++-- | A tool invocation returned by the model.+--+-- 'tcProviderMeta' is an opaque, provider-owned JSON bag that must round-trip+-- back to the provider on subsequent requests when this tool call is replayed+-- as part of the conversation history. It exists because some providers+-- (currently Gemini 2.5 thinking models, with their @thoughtSignature@) bind+-- internal state to a specific tool-call part and reject the request if it+-- isn't echoed back verbatim. Each provider is responsible for the shape of+-- its own metadata; consumers should treat it as opaque.+data ToolCall = ToolCall+ { tcId :: Text, -- provider-specific call id+ tcName :: Text,+ tcArguments :: Value,+ tcProviderMeta :: Maybe Value+ }+ deriving (Show, Eq, Generic, FromJSON, ToJSON)++-- | Smart constructor for a 'ToolCall' with no provider metadata. Use this+-- everywhere except when a provider parser is attaching its own metadata.+mkToolCall :: Text -> Text -> Value -> ToolCall+mkToolCall cid name args = ToolCall cid name args Nothing++-- | The result of executing a tool, sent back to the model+data ToolResult = ToolResult+ { trCallId :: Text, -- unique call id (matches tcId)+ trName :: Text, -- function name (matches tcName)+ trContent :: Text+ }+ deriving (Show, Eq, Generic, FromJSON, ToJSON)++-- | Errors from LLM operations+data LLMError+ = HttpError Int Text -- status code + raw body+ | NetworkError Text -- connection / DNS / TLS failure+ | TimeoutError -- request timed out+ | ParseError Text -- JSON we couldn't make sense of+ | EmptyResponse -- valid JSON, but no content in it+ | ToolLoopExceeded Int -- hit the max tool rounds limit+ | Aborted -- user cancelled the request+ deriving (Show, Eq, Generic, ToJSON, FromJSON)++-- | A request to an LLM provider+data ChatRequest = ChatRequest+ { reqModel :: Text,+ reqConversation :: [Turn],+ reqSystem :: Maybe Text,+ reqMaxTokens :: Int,+ reqTemperature :: Maybe Double,+ reqTools :: [ToolDef],+ reqThinking :: Maybe ThinkingMode+ }+ deriving (Show, Eq)++-- | A content block in a response — either text or a tool call+data ContentBlock+ = TextBlock Text+ | ToolCallBlock ToolCall+ deriving (Show, Eq)++-- | A response from an LLM provider+data ChatResponse = ChatResponse+ { respText :: Text,+ respContent :: [ContentBlock],+ respUsage :: Maybe Usage,+ respReasoning :: Maybe Text+ }+ deriving (Show, Eq)++-- | Events emitted during streaming+data StreamEvent+ = StreamReasoningDelta Text -- incremental chain-of-thought chunk+ | StreamDelta Text -- incremental answer text chunk+ | StreamToolCall ToolCall -- complete tool call+ deriving (Show, Eq)
+ src/LLM/Core/Usage.hs view
@@ -0,0 +1,50 @@+module LLM.Core.Usage+ ( Usage (..),+ PricingInfo (..),+ emptyUsage,+ addUsage,+ estimateCost,+ )+where++import Data.Aeson (FromJSON, ToJSON)+import GHC.Generics (Generic)++-- | Token usage from a single API call+data Usage = Usage+ { usageInputTokens :: !Int,+ usageOutputTokens :: !Int,+ usageTotalCost :: !Double+ }+ deriving (Show, Eq, Generic, ToJSON, FromJSON)++instance Semigroup Usage where+ (<>) :: Usage -> Usage -> Usage+ (<>) = addUsage++instance Monoid Usage where+ mempty :: Usage+ mempty = emptyUsage++emptyUsage :: Usage+emptyUsage = Usage {usageInputTokens = 0, usageOutputTokens = 0, usageTotalCost = 0}++addUsage :: Usage -> Usage -> Usage+addUsage a b =+ Usage+ { usageInputTokens = a.usageInputTokens + b.usageInputTokens,+ usageOutputTokens = a.usageOutputTokens + b.usageOutputTokens,+ usageTotalCost = a.usageTotalCost + b.usageTotalCost+ }++-- | Pricing in dollars per million tokens+data PricingInfo = PricingInfo+ { pricePerMillionInput :: Double,+ pricePerMillionOutput :: Double+ }+ deriving (Eq, Ord, Show, Generic, FromJSON, ToJSON)++estimateCost :: PricingInfo -> Usage -> Double+estimateCost p u =+ fromIntegral u.usageInputTokens * p.pricePerMillionInput / 1_000_000+ + fromIntegral u.usageOutputTokens * p.pricePerMillionOutput / 1_000_000
+ src/LLM/Core/Utils.hs view
@@ -0,0 +1,137 @@+module LLM.Core.Utils+ ( hasToolCalls,+ getToolCalls,+ toolResult,+ isRetryable,+ withRetry,+ withTimeout,+ streamResponseJson,+ printValue,+ parseChatResponse,+ )+where++import Control.Retry (RetryPolicyM, RetryStatus (rsIterNumber), retrying)+import Data.Aeson (Value, encode, object, (.=))+import Data.Aeson qualified as AE+import Data.Aeson.Types (Parser)+import Data.ByteString.Lazy.Char8 qualified as L8+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.Types+ ( ChatResponse (..),+ ContentBlock (..),+ LLMError (..),+ LLMResult,+ ToolCall (..),+ ToolResult (..),+ )+import LLM.Core.Usage (Usage (..))+import System.Timeout (timeout)++-- | Smart constructor for tool results+toolResult :: ToolCall -> Text -> ToolResult+toolResult tc = ToolResult tc.tcId tc.tcName++-- | Check whether a response contains tool calls+hasToolCalls :: ChatResponse -> Bool+hasToolCalls = not . null . getToolCalls++-- | Extract tool calls from a response+getToolCalls :: ChatResponse -> [ToolCall]+getToolCalls r = concatMap go r.respContent+ where+ go (ToolCallBlock tc) = [tc]+ go _ = []++-- | Whether an error is worth retrying+isRetryable :: LLMError -> Bool+isRetryable (HttpError status _) = status `elem` [429, 503, 529]+isRetryable (NetworkError _) = True+isRetryable _ = False++-- | Wrap an action with a timeout (ms). Returns 'TimeoutError' on expiry.+withTimeout :: Maybe Int -> IO (LLMResult a) -> IO (LLMResult a)+withTimeout Nothing action = action+withTimeout (Just us) action = do+ result <- timeout (us * 1000) action+ pure $ fromMaybe (Left TimeoutError) result++-- | Retry an action using the retry package's policy (exponential backoff + jitter).+-- The policy controls max attempts, delays, and jitter.+withRetry :: RetryPolicyM IO -> (Text -> IO ()) -> IO (LLMResult a) -> IO (LLMResult a)+withRetry policy logRetryableError action =+ retrying+ policy+ ( \status result -> case result of+ Left err | isRetryable err -> do+ logRetryableError $+ "Retryable error (attempt "+ <> T.pack (show (rsIterNumber status + 1))+ <> "): "+ <> T.pack (show err)+ pure True+ _ -> pure False+ )+ (const action)++-- | Build a synthetic JSON summary from a streamed ChatResponse,+-- used by providers to fire 'onResponse' after streaming completes.+streamResponseJson :: ChatResponse -> Value+streamResponseJson r =+ object+ [ "text" .= r.respText,+ "content" .= map blockToJson r.respContent,+ "usage" .= fmap usageToJson r.respUsage,+ "reasoning" .= r.respReasoning+ ]+ where+ blockToJson (TextBlock t) = object ["type" .= ("text" :: Text), "text" .= t]+ blockToJson (ToolCallBlock tc) =+ object $+ [ "type" .= ("tool_call" :: Text),+ "id" .= tc.tcId,+ "name" .= tc.tcName,+ "arguments" .= tc.tcArguments+ ]+ ++ ["provider_meta" .= m | Just m <- [tc.tcProviderMeta]]+ usageToJson u =+ object+ [ "input_tokens" .= u.usageInputTokens,+ "output_tokens" .= u.usageOutputTokens+ ]++parseChatResponse :: Value -> Parser ChatResponse+parseChatResponse = AE.withObject "ChatResponse" $ \v -> do+ text <- v AE..: "text"+ content <- v AE..: "content" >>= mapM parseContentBlock+ usage <- v AE..:? "usage" >>= mapM parseUsage+ reasoning <- v AE..:? "reasoning"+ pure+ ChatResponse+ { respText = text,+ respContent = content,+ respUsage = usage,+ respReasoning = reasoning+ }+ where+ parseContentBlock = AE.withObject "ContentBlock" $ \o -> do+ t <- o AE..: "type"+ case (t :: Text) of+ "text" -> TextBlock <$> o AE..: "text"+ "tool_call" -> do+ tcId <- o AE..: "id"+ tcName <- o AE..: "name"+ tcArgs <- o AE..: "arguments"+ tcMeta <- o AE..:? "provider_meta"+ pure $ ToolCallBlock $ ToolCall tcId tcName tcArgs tcMeta+ _ -> fail "Unknown content block type"++ parseUsage = AE.withObject "Usage" $ \o -> do+ input <- o AE..: "input_tokens"+ output <- o AE..: "output_tokens"+ pure $ Usage input output 0.0++printValue :: Value -> IO ()+printValue val = L8.putStrLn (encode val)
+ src/LLM/Generate.hs view
@@ -0,0 +1,46 @@+-- | Single provider requests with retries and model fallbacks.+--+-- These functions perform one logical LLM call (possibly retried, possibly+-- falling through 'ModelWithFallbacks') but do __not__ run a tool loop.+-- For automatic tool execution use 'LLM.Agent.generateText' instead.+--+-- Lower-level entry points 'generateTextLLM' and 'streamTextLLM' target a+-- single 'ModelConfig' without fallback orchestration.+module LLM.Generate+ ( generateTextLLM,+ streamTextLLM,+ generateTextWithFallbacks,+ streamTextWithFallbacks,+ genObject,+ genObjectUntyped,+ ModelConfig (..),+ ModelWithFallbacks (..),+ GenRequest (..),+ GenerateResult,+ GenerateError (..),+ GenerateErrorResult (..),+ GenerateTextResult (..),+ StreamChunk (..),+ RoundTextRole (..),+ GeneratableObject,+ Hooks (..),+ Logger,+ LogLevel (..),+ noHooks,+ withStderrLogger,+ withJsonDump,+ noLogger,+ stderrLogger,+ safeHooks,+ debugHooks,+ defaultDebugHooks,+ llmHooks,+ )+where++import LLM.Generate.Generate+import LLM.Generate.GenerateObject+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger+import LLM.Generate.ModelConfig+import LLM.Generate.Types
+ src/LLM/Generate/Generate.hs view
@@ -0,0 +1,129 @@+module LLM.Generate.Generate+ ( usageWithModelCost,+ generateTextLLM,+ streamTextLLM,+ generateTextWithFallbacks,+ streamTextWithFallbacks,+ )+where++import Control.Monad (unless, when)+import Data.IORef (newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import LLM.Core.Types+ ( ChatResponse (..),+ LLMGateway (..),+ LLMTextResult,+ StreamEvent (..),+ Turn (..),+ )+import LLM.Core.Usage (emptyUsage)+import LLM.Generate.GenerateUtils+ ( callWithRetryTimeout,+ mkRequest,+ usageWithModelCost,+ withModelFallbacks,+ )+import LLM.Generate.ModelConfig+ ( ModelConfig (..),+ ModelWithFallbacks (..),+ )+import LLM.Generate.Types+ ( GenRequest (..),+ GenerateResult,+ RoundTextRole (..),+ StreamChunk (..),+ )++-- | Generate text with retries and model fallbacks.+--+-- Tries 'mwfModel' first, then each fallback in order. Returns a provider+-- 'ChatResponse' on success; does not execute tools.+generateTextWithFallbacks ::+ GenRequest ->+ ModelWithFallbacks ->+ IO (GenerateResult ChatResponse)+generateTextWithFallbacks gr models =+ withModelFallbacks gr models $ \mc -> do+ r <- generateTextLLM gr mc+ case r of+ Left err -> pure $ Left err+ Right resp ->+ let usage = usageWithModelCost mc (fromMaybe emptyUsage resp.respUsage)+ in pure $ Right resp {respUsage = Just usage}++-- | Like 'generateTextWithFallbacks', but streams 'StreamChunk' values+-- through @onChunk@ as the provider responds.+streamTextWithFallbacks ::+ (StreamChunk -> IO ()) ->+ GenRequest ->+ ModelWithFallbacks ->+ IO (GenerateResult ChatResponse)+streamTextWithFallbacks onChunk gr models =+ withModelFallbacks gr models $ \mc -> do+ r <- streamTextLLM onChunk gr mc+ case r of+ Left err -> pure $ Left err+ Right resp ->+ let usage = usageWithModelCost mc (fromMaybe emptyUsage resp.respUsage)+ in pure $ Right resp {respUsage = Just usage}++generateTextLLM :: GenRequest -> ModelConfig -> IO LLMTextResult+generateTextLLM gr mc =+ callWithRetryTimeout gr mc $+ let request = mkRequest gr mc+ in mc.mcGateway.gwGenerateText gr.grLLMHooks request++streamTextLLM :: (StreamChunk -> IO ()) -> GenRequest -> ModelConfig -> IO LLMTextResult+streamTextLLM onChunk gr mc =+ callWithRetryTimeout gr mc $+ let request = mkRequest gr mc+ in do+ ProviderStreamCallback {pscOnEvent, pscFinalize} <-+ mkProviderStreamCallback gr onChunk+ result <- mc.mcGateway.gwStreamText gr.grLLMHooks request pscOnEvent+ case result of+ Right _ -> pscFinalize >> pure result+ Left err -> pure (Left err)++data RoundPhase = Unclassified | Preamble | Answer+ deriving (Eq)++data ProviderStreamCallback = ProviderStreamCallback+ { pscOnEvent :: StreamEvent -> IO (),+ pscFinalize :: IO ()+ }++initialPhase :: [Turn] -> RoundPhase+initialPhase turns =+ case reverse turns of+ ToolTurn _ : _ -> Answer+ _ -> Unclassified++mkProviderStreamCallback ::+ GenRequest ->+ (StreamChunk -> IO ()) ->+ IO ProviderStreamCallback+mkProviderStreamCallback gr onChunk = do+ phaseRef <- newIORef (initialPhase gr.grMessages)+ pure+ ProviderStreamCallback+ { pscOnEvent = \case+ StreamReasoningDelta txt -> onChunk (ReasoningDelta txt)+ StreamDelta txt -> do+ phase <- readIORef phaseRef+ case phase of+ Answer -> onChunk (AnswerDelta txt)+ Preamble -> onChunk (PreambleDelta txt)+ Unclassified -> onChunk (TextDelta txt)+ StreamToolCall tc -> do+ phase <- readIORef phaseRef+ unless (phase == Preamble) $+ onChunk (RoundTextRoleCommitted PreambleRole)+ writeIORef phaseRef Preamble+ onChunk (StreamToolCallChunk tc),+ pscFinalize = do+ phase <- readIORef phaseRef+ when (phase == Unclassified) $+ onChunk (RoundTextRoleCommitted AnswerRole)+ }
+ src/LLM/Generate/GenerateObject.hs view
@@ -0,0 +1,108 @@+module LLM.Generate.GenerateObject+ ( genObject,+ genObjectUntyped,+ )+where++import Autodocodec qualified as AC+import Autodocodec.Schema (jsonSchemaVia)+import Data.Aeson (Value)+import Data.Aeson qualified as AE+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import LLM.Core.Abort (isAbortedMaybe)+import LLM.Core.ProviderUtils (stripBoundsAndComments)+import LLM.Core.Types (LLMGateway (..), LLMObjectResult)+import LLM.Core.Usage (Usage (..), emptyUsage)+import LLM.Generate.GenerateUtils+ ( callWithRetryTimeout,+ mkRequest,+ usageWithModelCost,+ withModelFallbacks,+ )+import LLM.Generate.ModelConfig (ModelConfig (mcGateway), ModelWithFallbacks)+import LLM.Generate.Types+ ( GenRequest (grAbortSignal, grLLMHooks),+ GeneratableObject,+ GenerateError (..),+ GenerateErrorResult (..),+ GenerateResult,+ )++-- | Generate an object.+-- Tools are not supported, make sure to set grTools = [] in the GenRequest.+genObject ::+ (GeneratableObject t) =>+ GenRequest ->+ ModelWithFallbacks ->+ IO (Either GenerateErrorResult (t, Usage))+genObject = genObjectInternal AC.codec++genObjectInternal ::+ (GeneratableObject t) =>+ AC.JSONCodec t ->+ GenRequest ->+ ModelWithFallbacks ->+ IO (Either GenerateErrorResult (t, Usage))+genObjectInternal codec gr models = do+ let jsonschema = stripBoundsAndComments $ AE.toJSON $ jsonSchemaVia codec+ res <- genObjectUntyped gr models jsonschema+ case res of+ Left e -> pure (Left e)+ Right (v, u) -> do+ case AE.fromJSON v of+ AE.Error e ->+ pure $+ Left $+ GenerateErrorResult+ (GErrParseObjectError $ "Can't decode object returned from generateObjectUntyped" <> T.pack (show e))+ []+ u+ AE.Success a -> pure $ Right (a, u)++-- | Generate an object, using the provided schema.+-- Tools are not supported, make sure to set grTools = [] in the GenRequest.+genObjectUntyped ::+ GenRequest ->+ ModelWithFallbacks ->+ Value ->+ IO (Either GenerateErrorResult (Value, Usage))+genObjectUntyped gr models schema = do+ aborted <- isAbortedMaybe gr.grAbortSignal+ if aborted+ then do+ let errResult = GenerateErrorResult GErrAborted [] emptyUsage+ pure $ Left errResult+ else do+ result <- callObjectWithFallbacks gr models schema+ case result of+ Left err -> do+ let errResult = GenerateErrorResult err [] emptyUsage+ pure $ Left errResult+ Right (value, usage) -> do+ pure $ Right (value, usage)++callObject ::+ GenRequest ->+ ModelConfig ->+ Value ->+ IO LLMObjectResult+callObject gr mc schema =+ callWithRetryTimeout gr mc $+ mc.mcGateway.gwGenerateObject+ gr.grLLMHooks+ schema+ (mkRequest gr mc)++callObjectWithFallbacks ::+ GenRequest ->+ ModelWithFallbacks ->+ Value ->+ IO (GenerateResult (Value, Usage))+callObjectWithFallbacks gr models schema =+ withModelFallbacks gr models $ \mc -> do+ r <- callObject gr mc schema+ case r of+ Left err -> pure $ Left err+ Right (v, mbu) ->+ pure $ Right (v, usageWithModelCost mc (fromMaybe emptyUsage mbu))
+ src/LLM/Generate/GenerateUtils.hs view
@@ -0,0 +1,107 @@+module LLM.Generate.GenerateUtils+ ( maybeThrottle,+ mkRequest,+ usageWithModelCost,+ callWithRetryTimeout,+ withModelFallbacks,+ llmHooks,+ )+where++import Control.Concurrent (threadDelay)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.Types+ ( ChatRequest (..),+ LLMError (..),+ LLMGateway (gwName),+ LLMHooks (..),+ )+import LLM.Core.Usage (Usage (..), estimateCost)+import LLM.Core.Utils (withRetry, withTimeout)+import LLM.Generate.Logger (Hooks (..), LogLevel (..), onLog)+import LLM.Generate.ModelConfig+ ( ModelConfig (..),+ ModelWithFallbacks (..),+ mfwToModelConfigs,+ modelRetryPolicy,+ )+import LLM.Generate.Types (GenRequest (..), GenerateError (..), GenerateResult)++maybeThrottle :: Maybe Int -> IO a -> IO a+maybeThrottle Nothing io = io+maybeThrottle (Just ms) io = threadDelay (ms * 1000) >> io++mkRequest :: GenRequest -> ModelConfig -> ChatRequest+mkRequest gr mc =+ ChatRequest+ { reqModel = mc.mcModel,+ reqConversation = gr.grMessages,+ reqSystem = gr.grSystemPrompt,+ reqMaxTokens = mc.mcMaxTokens,+ reqTemperature = mc.mcTemperature,+ reqTools = gr.grTools,+ reqThinking = mc.mcThinking+ }++usageWithModelCost :: ModelConfig -> Usage -> Usage+usageWithModelCost mc u = u {usageTotalCost = estimateCost mc.mcPricing u}++callWithRetryTimeout ::+ GenRequest ->+ ModelConfig ->+ IO (Either LLMError a) ->+ IO (Either LLMError a)+callWithRetryTimeout gr mc invoke =+ maybeThrottle mc.mcThrottleDelay $+ withTimeout mc.mcRequestTimeout $+ withRetry (modelRetryPolicy mc) (gr.grHooks.onLog Warn) invoke++withModelFallbacks ::+ GenRequest ->+ ModelWithFallbacks ->+ (ModelConfig -> IO (Either LLMError a)) ->+ IO (GenerateResult a)+withModelFallbacks gr models invokePerModel =+ case mfwToModelConfigs models of+ [] -> pure $ Left GErrAllModelsFailed+ modelConfigs -> loop modelConfigs Nothing+ where+ loop [] mLast =+ pure $+ Left $+ maybe GErrAllModelsFailed GErrLLM mLast+ loop (mc : rest) _ = do+ gr.grHooks.onLog Info (formatTryingModel mc)+ r <- invokePerModel mc+ case r of+ Left Aborted -> pure $ Left GErrAborted+ Left err ->+ case rest of+ [] -> pure $ Left (GErrLLM err)+ _ -> do+ gr.grHooks.onLog Warn (formatModelFallback mc err)+ loop rest (Just err)+ Right a -> pure $ Right a++formatTryingModel :: ModelConfig -> Text+formatTryingModel mc =+ "Trying model: "+ <> mc.mcModel+ <> " via "+ <> mc.mcGateway.gwName++formatModelFallback :: ModelConfig -> LLMError -> Text+formatModelFallback mc err =+ "Falling back from "+ <> mc.mcModel+ <> ": "+ <> T.pack (show err)++llmHooks :: Hooks -> LLMHooks+llmHooks hooks =+ LLMHooks+ { onLLMRequest = hooks.onRequest,+ onLLMResponse = hooks.onResponse,+ onLLMResponseError = hooks.onResponseError+ }
+ src/LLM/Generate/Logger.hs view
@@ -0,0 +1,119 @@+module LLM.Generate.Logger+ ( Hooks (..),+ Logger,+ LogLevel (..),+ noHooks,+ withStderrLogger,+ withJsonDump,+ noLogger,+ stderrLogger,+ safeHooks,+ debugHooks,+ defaultDebugHooks,+ )+where++import Control.Exception (SomeException, try)+import Control.Monad (void)+import Data.Aeson (Value)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.ByteString.Lazy qualified as BSL+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time.Clock.POSIX (getPOSIXTime)+import System.Directory (createDirectoryIfMissing)+import System.FilePath ((</>))+import System.IO (stderr)++-- | Log verbosity levels, ordered from most to least verbose+data LogLevel = Debug | Info | Warn | Error+ deriving (Show, Eq, Ord)++-- | A logger callback. The library calls it; the consumer decides what to do.+type Logger = LogLevel -> Text -> IO ()++-- | No-op logger (default)+noLogger :: Logger+noLogger _ _ = pure ()++-- | Simple stderr logger that filters by minimum level+stderrLogger :: LogLevel -> Logger+stderrLogger minLevel level msg+ | level >= minLevel = TIO.hPutStrLn stderr $ "[" <> T.pack (show level) <> "] " <> msg+ | otherwise = pure ()++-- | Hooks for observing library behaviour. All callbacks are no-ops by default.+data Hooks = Hooks+ { -- | Log messages at various levels+ onLog :: Logger,+ -- | Called with (provider, request body JSON)+ onRequest :: Text -> Value -> IO (),+ -- | Called with (provider, response body JSON)+ onResponse :: Text -> Value -> IO (),+ onResponseError :: Text -> Text -> IO (),+ -- | Called with (tool call name, tool call arguments)+ onToolCall :: Text -> Value -> IO (),+ -- | Called with (tool call name, tool call result)+ onToolResult :: Text -> Text -> IO (),+ -- | Called with (tool call name, tool call error)+ onToolError :: Text -> Text -> IO ()+ }++-- | No-op hooks (default)+noHooks :: Hooks+noHooks =+ Hooks+ { onLog = noLogger,+ onRequest = \_ _ -> pure (),+ onResponse = \_ _ -> pure (),+ onResponseError = \_ _ -> pure (),+ onToolCall = \_ _ -> pure (),+ onToolResult = \_ _ -> pure (),+ onToolError = \_ _ -> pure ()+ }++-- | Add a stderr logger to existing hooks+withStderrLogger :: LogLevel -> Hooks -> Hooks+withStderrLogger minLvl h = h {onLog = stderrLogger minLvl}++-- | Add JSON request/response dumping to a directory.+-- Files are named @{provider}-{request|response}-{timestamp}.json@.+withJsonDump :: FilePath -> Hooks -> Hooks+withJsonDump dir h =+ h+ { onRequest = \provider body -> do+ h.onRequest provider body+ dumpJson dir provider "request" body,+ onResponse = \provider body -> do+ h.onResponse provider body+ dumpJson dir provider "response" body+ }++dumpJson :: FilePath -> Text -> Text -> Value -> IO ()+dumpJson dir provider label val = do+ 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)++-- | Wrap all hook callbacks so exceptions are silently caught.+-- Hooks are observability-only and should never abort control flow.+safeHooks :: Hooks -> Hooks+safeHooks h =+ Hooks+ { onLog = \level msg -> void (try (h.onLog level msg) :: IO (Either SomeException ())),+ onRequest = \p v -> void (try (h.onRequest p v) :: IO (Either SomeException ())),+ onResponse = \p v -> void (try (h.onResponse p v) :: IO (Either SomeException ())),+ onResponseError = \p v -> void (try (h.onResponseError p v) :: IO (Either SomeException ())),+ onToolCall = \p v -> void (try (h.onToolCall p v) :: IO (Either SomeException ())),+ onToolResult = \p v -> void (try (h.onToolResult p v) :: IO (Either SomeException ())),+ onToolError = \p v -> void (try (h.onToolError p v) :: IO (Either SomeException ()))+ }++debugHooks :: FilePath -> Hooks+debugHooks dir = withJsonDump dir . withStderrLogger Debug $ noHooks++defaultDebugHooks :: Hooks+defaultDebugHooks = debugHooks "./dumps"
+ src/LLM/Generate/ModelConfig.hs view
@@ -0,0 +1,54 @@+module LLM.Generate.ModelConfig+ ( ModelConfig (..),+ ModelWithFallbacks (..),+ mfwToModelConfigs,+ modelRetryPolicy,+ )+where++import Control.Retry (RetryPolicyM, fullJitterBackoff, limitRetries)+import Data.Text (Text)+import LLM.Core.Types (LLMGateway, ThinkingMode)+import LLM.Core.Usage (PricingInfo)++-- | Provider connection and per-model tuning parameters.+--+-- Usually constructed via 'LLM.Load.loadModelOrThrow' from a JSON catalog entry,+-- or manually when wiring a custom 'LLMGateway'.+data ModelConfig = ModelConfig+ { -- | Provider implementation (OpenAI, Claude, Ollama, etc.).+ mcGateway :: LLMGateway,+ -- | Provider-specific model identifier (e.g. @gpt-4.1-2025-04-14@).+ mcModel :: Text,+ -- | Per-million-token pricing used to populate 'Usage.usageTotalCost'.+ mcPricing :: PricingInfo,+ -- | Maximum tokens requested from the provider.+ mcMaxTokens :: Int,+ -- | Sampling temperature, when supported by the provider.+ mcTemperature :: Maybe Double,+ -- | Thinking / reasoning mode (DeepSeek, etc.), when supported.+ mcThinking :: Maybe ThinkingMode,+ -- | Whole-request timeout in milliseconds ('Nothing' = no timeout).+ mcRequestTimeout :: Maybe Int,+ -- | Delay in milliseconds before each API call (rate limiting).+ mcThrottleDelay :: Maybe Int,+ -- | Number of retries on retryable 'LLMError's before giving up on this model.+ mcRetryCount :: Int,+ -- | Base backoff in milliseconds between retries (jittered).+ mcJitterBackoff :: Int+ }++-- | Primary model plus an ordered fallback chain.+--+-- On failure the library tries 'mwfModel' first, then each entry in+-- 'mwfFallbacks' in order. Aborts ('GErrAborted') do not fall through.+data ModelWithFallbacks = ModelWithFallbacks+ { mwfModel :: ModelConfig,+ mwfFallbacks :: [ModelConfig]+ }++mfwToModelConfigs :: ModelWithFallbacks -> [ModelConfig]+mfwToModelConfigs mwf = mwf.mwfModel : mwf.mwfFallbacks++modelRetryPolicy :: ModelConfig -> RetryPolicyM IO+modelRetryPolicy mc = limitRetries mc.mcRetryCount <> fullJitterBackoff (mc.mcJitterBackoff * 1000)
+ src/LLM/Generate/Types.hs view
@@ -0,0 +1,106 @@+module LLM.Generate.Types+ ( GenRequest (..),+ GenerateResult,+ GenerateError (..),+ GenerateErrorResult (..),+ GenerateTextResult (..),+ StreamChunk (..),+ RoundTextRole (..),+ GeneratableObject,+ )+where++import Autodocodec (HasCodec)+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.UUID.Types (UUID)+import LLM.Core.Abort (AbortSignal)+import LLM.Core.Types+ ( LLMError,+ LLMHooks,+ ToolCall,+ ToolDef (..),+ Turn,+ )+import LLM.Core.Usage (Usage)+import LLM.Generate.Logger (Hooks)++-- | A single provider request. Built manually or via 'createGenRequest'.+--+-- For structured output ('genObject', 'genObjectUntyped'), leave 'grTools' empty.+data GenRequest = GenRequest+ { -- | System prompt override (also available on 'Agent.agSystemPrompt').+ grSystemPrompt :: Maybe Text,+ -- | Conversation turns sent to the provider (may already be windowed).+ grMessages :: [Turn],+ -- | Tool definitions included in the provider request.+ grTools :: [ToolDef],+ -- | Cooperative cancellation checked before and during the call.+ grAbortSignal :: Maybe AbortSignal,+ -- | Provider wire hooks for raw request/response JSON.+ grLLMHooks :: LLMHooks,+ -- | Application hooks (logging, dumps, tool tracing).+ grHooks :: Hooks+ }++-- | Outcome of a generation call at the provider/fallback layer.+type GenerateResult a = Either GenerateError a++-- | Successful result from the agent loop or a single-shot text generation.+data GenerateTextResult = GenerateTextResult+ { -- | Matches 'RuntimeArgs.rtGenerationId' for this run.+ gtrGenerationId :: UUID,+ -- | New turns produced during this call (assistant and tool turns only).+ gtrNewMessages :: [Turn],+ -- | Final assistant text from the last model response.+ gtrText :: Text,+ -- | Accumulated token usage including cost estimates.+ gtrUsage :: Usage+ }+ deriving (Show, Eq)++-- | Failure result preserving partial progress from the current run.+data GenerateErrorResult = GenerateErrorResult+ { gerError :: GenerateError,+ -- | Turns produced before the failure (may include an in-progress tool round).+ gerPartialNewMessages :: [Turn],+ gerUsage :: Usage+ }+ deriving (Show, Eq)++-- | Errors surfaced by the generate and agent layers.+data GenerateError+ = -- | Provider-level failure (HTTP, network, parse, etc.).+ GErrLLM LLMError+ | -- | 'Agent.agMaxToolRounds' exhausted without a final text reply.+ GErrToolExceeded+ | -- | Every model in the fallback chain failed.+ GErrAllModelsFailed+ | -- | 'AbortSignal' fired before completion.+ GErrAborted+ | -- | Provider JSON did not decode into the requested typed object.+ GErrParseObjectError Text+ deriving (Show, Eq)++-- | Role assigned to streamed text for a single model round.+data RoundTextRole = AnswerRole | PreambleRole+ deriving (Show, Eq)++data StreamChunk+ = -- | Final answer text for the pre-allocated assistant message.+ AnswerDelta Text+ | -- | Chain-of-thought text from thinking mode.+ ReasoningDelta Text+ | -- | Text from an LLM round that also issued tool calls.+ PreambleDelta Text+ | -- | Unclassified text while the round role is still unknown.+ TextDelta Text+ | -- | Signals that prior 'TextDelta' chunks (or misclassified deltas) belong+ -- to the given role for this round.+ RoundTextRoleCommitted RoundTextRole+ | -- | A complete tool call from the provider stream.+ StreamToolCallChunk ToolCall+ deriving (Show, Eq)++-- | Constraint for typed structured output via Autodocodec.+type GeneratableObject t = (FromJSON t, HasCodec t)
+ src/LLM/Load.hs view
@@ -0,0 +1,67 @@+-- | Load models from a json file+--+-- @+--+-- [{+-- "modelConfigName": "llama_3_2",+-- "providerName": "ollama",+-- "modelName": "llama3.2:latest",+-- "pricing": {+-- "pricePerMillionInput": 0.0,+-- "pricePerMillionOutput": 0.0+-- },+-- "maxTokens": 1024,+-- "temperature": 0.5,+-- "requestTimeout": 10000,+-- "throttleDelay": 1000,+-- "retryCount": 3,+-- "jitterBackoff": 1000+-- },+-- ... more models ...+-- ]+--+-- @+--+-- available providers:+--+-- * "openai"+--+-- * "claude"+--+-- * "gemini"+--+-- * "ollama"+--+-- * "deepseek"+--+--+-- If a model (resp. its provider) requires an API key, it must be set in the+-- process environment. This module does not load a @.env@ file automatically;+-- use @Configuration.Dotenv.loadFile@ in your @main@ or call+-- 'loadGatewaysWithDotenv' when building gateways yourself.+--+-- @+-- GEMINI_API_KEY=...+-- CLAUDE_API_KEY=...+-- OPENAI_API_KEY=...+-- DEEPSEEK_API_KEY=...+-- @+module LLM.Load+ ( loadModelsOrThrow,+ loadModelOrThrow,+ LoadConfigError (..),+ loadGateways,+ loadGatewaysWithDotenv,+ loadModelCatalog,+ ModelCatalogItem (..),+ ModelCatalogMap,+ fsTools,+ fsTools',+ )+where++import LLM.Load.FsTools (fsTools, fsTools')+import LLM.Load.LoadGateways (loadGateways, loadGatewaysWithDotenv)+import LLM.Load.LoadModels (loadModelOrThrow, loadModelsOrThrow)+import LLM.Load.ModelCatalog (ModelCatalogItem (..), ModelCatalogMap, loadModelCatalog)+import LLM.Load.Types (LoadConfigError (..))
+ src/LLM/Load/FsTools.hs view
@@ -0,0 +1,60 @@+module LLM.Load.FsTools where++import Data.Map qualified as Map+-- import LLM.Tools.Readfile (readfileToolTyped)++import Data.Text (Text)+import LLM.Agent.ToolUtils (embedTextTool, toTool)+import LLM.Agent.Types (ToolMap)+import LLM.Tools.CopyFile (copyFileToolTyped)+import LLM.Tools.CreateDirectory (createDirectoryToolTyped)+import LLM.Tools.DirectoryTree (directoryTreeToolTyped)+import LLM.Tools.FileInfo (fileInfoToolTyped)+import LLM.Tools.FindFiles (findFilesToolTyped)+import LLM.Tools.FsConfig (mkFsConfig)+import LLM.Tools.Grep (grepToolTyped)+import LLM.Tools.MoveFile (moveFileToolTyped)+import LLM.Tools.MultiReplaceInFile (multiReplaceInFileToolTyped)+import LLM.Tools.ReadFilePaginated (readFilePaginatedToolTyped)+import LLM.Tools.Readdir (readdirToolTyped)+import LLM.Tools.RemoveDirectory (removeDirectoryToolTyped)+import LLM.Tools.RemoveFile (removeFileToolTyped)+import LLM.Tools.ReplaceInFile (replaceInFileToolTyped)+import LLM.Tools.Writefile (writefileToolTyped)++-- | Build the bundled filesystem 'ToolMap' rooted at @filePath@.+--+-- All paths are resolved inside a canonical sandbox ('LLM.Tools.FsConfig').+-- Mutating tools refuse paths that escape the workspace; reads are bounded+-- (1 MiB for edits, 10 MiB for paginated reads). Include desired names in+-- 'Agent.agTools' to expose them to the model.+fsTools :: FilePath -> IO (ToolMap Text)+fsTools filePath = do+ cfg <- mkFsConfig filePath+ pure $+ Map.fromList+ [ ("copy_file", toTool $ copyFileToolTyped cfg),+ ("create_directory", toTool $ createDirectoryToolTyped cfg),+ ("directory_tree", toTool $ directoryTreeToolTyped cfg),+ ("file_info", toTool $ fileInfoToolTyped cfg),+ ("find_files", toTool $ findFilesToolTyped cfg),+ ("grep", toTool $ grepToolTyped cfg),+ ("move_file", toTool $ moveFileToolTyped cfg),+ ("multi_replace_in_file", toTool $ multiReplaceInFileToolTyped cfg),+ ("readdir", toTool $ readdirToolTyped cfg),+ -- ("readfile", toTool $ readfileToolTyped cfg),+ ("read_file_paginated", toTool $ readFilePaginatedToolTyped cfg),+ ("remove_directory", toTool $ removeDirectoryToolTyped cfg),+ ("remove_file", toTool $ removeFileToolTyped cfg),+ ("replace_in_file", toTool $ replaceInFileToolTyped cfg),+ ("writefile", toTool $ writefileToolTyped cfg)+ ]++-- | Like 'fsTools', but embed each tool's 'Text' result via @embed@.+--+-- Use when your 'ToolMap' carries a custom result type (e.g. structured+-- tool outcomes) instead of plain 'Text'.+fsTools' :: (Text -> result) -> FilePath -> IO (ToolMap result)+fsTools' embed filePath = do+ m <- fsTools filePath+ pure $ Map.map (embedTextTool embed) m
+ src/LLM/Load/LoadGateways.hs view
@@ -0,0 +1,46 @@+module LLM.Load.LoadGateways+ ( GatewayMap,+ loadGateways,+ loadGatewaysWithDotenv,+ )+where++import Configuration.Dotenv (defaultConfig, loadFile)+import Control.Exception (SomeException, catch)+import Control.Lens ((<&>))+import Data.Map qualified as Map+import Data.Maybe (catMaybes)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Core.Types (LLMGateway)+import LLM.Providers.Claude (claudeGateway)+import LLM.Providers.DeepSeek (deepSeekGateway)+import LLM.Providers.Gemini (geminiGateway)+import LLM.Providers.Ollama (ollamaGateway)+import LLM.Providers.OpenAI (openAIGateway)+import System.Environment (lookupEnv)++type GatewayMap = Map.Map Text LLMGateway++-- | Build a gateway map from the current process environment.+-- Does not read a @.env@ file; set variables yourself or use+-- 'loadGatewaysWithDotenv'.+loadGateways :: IO GatewayMap+loadGateways = loadGatewaysFromEnv++-- | Load @.env@ (if present) and then build a gateway map from the+-- environment. Convenience for local development; prefer explicit env+-- injection in production.+loadGatewaysWithDotenv :: IO GatewayMap+loadGatewaysWithDotenv = do+ loadFile defaultConfig `catch` \(_ :: SomeException) -> pure ()+ loadGatewaysFromEnv++loadGatewaysFromEnv :: IO GatewayMap+loadGatewaysFromEnv = do+ let ollama = Just ("ollama", ollamaGateway)+ openai <- lookupEnv "OPENAI_API_KEY" <&> fmap (("openai",) . openAIGateway . T.pack)+ claude <- lookupEnv "CLAUDE_API_KEY" <&> fmap (("claude",) . claudeGateway . T.pack)+ gemini <- lookupEnv "GEMINI_API_KEY" <&> fmap (("gemini",) . geminiGateway . T.pack)+ deepseek <- lookupEnv "DEEPSEEK_API_KEY" <&> fmap (("deepseek",) . deepSeekGateway . T.pack)+ pure $ Map.fromList $ catMaybes [openai, claude, gemini, deepseek, ollama]
+ src/LLM/Load/LoadModels.hs view
@@ -0,0 +1,97 @@+module LLM.Load.LoadModels+ ( ModelConfigMap,+ loadModelConfigMap,+ loadModels,+ loadModel,+ loadModelsOrThrow,+ loadModelOrThrow,+ loadModelsOrThrow_,+ loadModelOrThrow_,+ )+where++import Control.Exception (throwIO)+import Control.Lens (Each (each), mapMOf)+import Control.Monad (forM)+import Control.Monad.Except (ExceptT, MonadError (throwError), liftEither, runExceptT)+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import LLM.Core.Types (ThinkingMode (..))+import LLM.Generate.ModelConfig (ModelConfig (..))+import LLM.Load.LoadGateways (GatewayMap, loadGateways)+import LLM.Load.ModelCatalog (ModelCatalogItem (..), loadModelCatalog)+import LLM.Load.Types (LoadConfigError (LoadModelConfigError))++type ModelConfigMap = Map Text ModelConfig++loadModelConfigMap :: FilePath -> ExceptT LoadConfigError IO (ModelConfigMap, GatewayMap)+loadModelConfigMap filePath = do+ gatewayMap <- liftIO loadGateways+ modelCatalogMap <- loadModelCatalog filePath+ modelConfigs <- forM (Map.toList modelCatalogMap) $ \(modelConfigName, item) -> do+ case Map.lookup item.providerName gatewayMap of+ Nothing -> throwError $ LoadModelConfigError $ "Provider not found: " <> item.providerName+ Just gateway ->+ pure+ ( modelConfigName,+ ModelConfig+ { mcGateway = gateway,+ mcModel = item.modelName,+ mcPricing = item.pricing,+ mcMaxTokens = item.maxTokens,+ mcTemperature = item.temperature,+ mcThinking = fmap (\x -> ThinkingMode {tmEnabled = True, tmEffort = Just x}) item.thinking,+ mcRequestTimeout = item.requestTimeout,+ mcThrottleDelay = item.throttleDelay,+ mcRetryCount = item.retryCount,+ mcJitterBackoff = item.jitterBackoff+ }+ )+ pure (Map.fromList modelConfigs, gatewayMap)++loadModels :: (Each s t Text ModelConfig) => FilePath -> s -> ExceptT LoadConfigError IO (t, ModelConfigMap, GatewayMap)+loadModels filePath s = do+ (modelConfigMap, gatewayMap) <- loadModelConfigMap filePath+ r <- liftEither $ maybe (Left $ LoadModelConfigError "Model not found") Right $ mapMOf each (`Map.lookup` modelConfigMap) s+ pure (r, modelConfigMap, gatewayMap)++loadModel :: FilePath -> Text -> ExceptT LoadConfigError IO (ModelConfig, ModelConfigMap, GatewayMap)+loadModel filePath modelConfigName = do+ (modelConfigMap, gatewayMap) <- loadModelConfigMap filePath+ case Map.lookup modelConfigName modelConfigMap of+ Nothing -> throwError $ LoadModelConfigError $ "Model not found: " <> modelConfigName+ Just modelConfig -> pure (modelConfig, modelConfigMap, gatewayMap)++-- | Load models from a json file and throw an error if any model is not found+--+-- > (gpt, llama, haiku) <- loadModelsOrThrow "./model-catalog.json" ("gpt_4_1", "llama_3_2", "haiku_4_5")+loadModelsOrThrow :: (Each s t Text ModelConfig) => FilePath -> s -> IO t+loadModelsOrThrow filepath s =+ (\(x, _, _) -> x) <$> loadModelsOrThrow_ filepath s++loadModelsOrThrow_ :: (Each s t Text ModelConfig) => FilePath -> s -> IO (t, ModelConfigMap, GatewayMap)+loadModelsOrThrow_ filePath s = do+ r <- runExceptT $ loadModels filePath s+ case r of+ Left err -> throwIO err+ Right result -> pure result++-- | Load a single model from a json file and throw an error if the model is not found+loadModelOrThrow :: FilePath -> Text -> IO ModelConfig+loadModelOrThrow filePath modelConfigName = do+ (\(x, _, _) -> x) <$> loadModelOrThrow_ filePath modelConfigName++loadModelOrThrow_ :: FilePath -> Text -> IO (ModelConfig, ModelConfigMap, GatewayMap)+loadModelOrThrow_ filePath modelConfigName = do+ r <- runExceptT $ loadModelConfigMap filePath+ case r of+ Left err -> throwIO err+ Right (modelConfigMap, gatewayMap) -> do+ case Map.lookup modelConfigName modelConfigMap of+ Nothing ->+ throwIO $+ LoadModelConfigError $+ "Model not found: " <> modelConfigName+ Just modelConfig -> pure (modelConfig, modelConfigMap, gatewayMap)
+ src/LLM/Load/ModelCatalog.hs view
@@ -0,0 +1,34 @@+module LLM.Load.ModelCatalog where++import Control.Monad.Except (ExceptT)+import Data.Aeson (FromJSON, ToJSON)+import Data.Map (Map)+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Usage (PricingInfo)+import LLM.Load.Types (LoadConfigError (..))+import LLM.Load.Utils (decodeJsonFile)++data ModelCatalogItem = ModelCatalogItem+ { modelConfigName :: Text,+ providerName :: Text, -- provider name: "openai", "claude", "gemini", "ollama"+ modelName :: Text,+ pricing :: PricingInfo,+ maxTokens :: Int,+ temperature :: Maybe Double,+ requestTimeout :: Maybe Int,+ thinking :: Maybe Text,+ throttleDelay :: Maybe Int,+ retryCount :: Int,+ jitterBackoff :: Int+ }+ deriving (Show, Eq, Ord, Generic, FromJSON, ToJSON)++type ModelCatalogMap = Map Text ModelCatalogItem++loadModelCatalog :: FilePath -> ExceptT LoadConfigError IO ModelCatalogMap+loadModelCatalog filePath =+ Map.fromList . fmap (\item -> (item.modelConfigName, item))+ <$> decodeJsonFile filePath (LoadModelCatalogError . T.pack)
+ src/LLM/Load/Types.hs view
@@ -0,0 +1,16 @@+module LLM.Load.Types where++import Control.Exception (Exception)+import Data.Text (Text)++-- | Errors raised while loading model catalogs or resolving configurations.+data LoadConfigError+ = -- | The catalog file is missing or contains invalid JSON.+ LoadModelCatalogError Text+ | -- | A catalog entry references an unknown model or provider.+ LoadModelConfigError Text+ | -- | A @file:@ system prompt path could not be read.+ LoadSystemPromptError Text+ deriving (Show)++instance Exception LoadConfigError
+ src/LLM/Load/Utils.hs view
@@ -0,0 +1,34 @@+module LLM.Load.Utils where++import Control.Exception (IOException, try)+import Control.Monad.Except (ExceptT (..), MonadError (throwError))+import Control.Monad.IO.Class (MonadIO (liftIO))+import Data.Aeson (FromJSON, eitherDecodeFileStrict)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import LLM.Load.Types (LoadConfigError (..))++decodeJsonFile ::+ (FromJSON a, MonadIO m) =>+ FilePath ->+ (String -> err) ->+ ExceptT err m a+decodeJsonFile filePath tag =+ ExceptT $+ either (Left . tag) Right+ <$> liftIO (eitherDecodeFileStrict filePath)++getSystemPrompt :: Maybe Text -> ExceptT LoadConfigError IO (Maybe Text)+getSystemPrompt mbSystemPrompt =+ case mbSystemPrompt of+ Nothing -> pure Nothing+ Just t -> do+ if T.isPrefixOf "file:" t+ then do+ let filePath = drop 5 (T.unpack t)+ result <- liftIO (try (TIO.readFile filePath) :: IO (Either IOException Text))+ case result of+ Left (e :: IOException) -> throwError (LoadSystemPromptError (T.pack (show e)))+ Right content -> pure (Just content)+ else pure $ Just t
+ src/LLM/Providers.hs view
@@ -0,0 +1,29 @@+-- | Collection of LLM providers+module LLM.Providers+ ( -- * OpenAI+ openAIProvider,+ openAIGateway,++ -- * Gemini+ geminiProvider,+ geminiGateway,++ -- * Claude+ claudeProvider,+ claudeGateway,++ -- * Ollama+ ollamaProvider,+ ollamaGateway,++ -- * DeepSeek+ deepSeekProvider,+ deepSeekGateway,+ )+where++import LLM.Providers.Claude (claudeGateway, claudeProvider)+import LLM.Providers.DeepSeek (deepSeekGateway, deepSeekProvider)+import LLM.Providers.Gemini (geminiGateway, geminiProvider)+import LLM.Providers.Ollama (ollamaGateway, ollamaProvider)+import LLM.Providers.OpenAI (openAIGateway, openAIProvider)
+ src/LLM/Providers/Claude.hs view
@@ -0,0 +1,329 @@+module LLM.Providers.Claude+ ( claudeGateway,+ claudeProvider,+ parseClaudeResponse,+ parseClaudeUsage,+ )+where++import Data.Aeson+ ( KeyValue ((.=)),+ Value (String),+ decodeStrict',+ encode,+ object,+ withObject,+ (.:),+ )+import Data.Aeson.Types (Parser, parseMaybe)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+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 (handleStreamResponse, lenientConfig, stripJsonFences)+import LLM.Core.SSE (SSEEvent (sseData, sseEvent), readSSEEvents)+import LLM.Core.Types+ ( ChatRequest+ ( reqConversation,+ reqMaxTokens,+ reqModel,+ reqSystem,+ reqTemperature,+ reqTools+ ),+ ChatResponse (ChatResponse),+ ContentBlock (..),+ LLMError (EmptyResponse),+ LLMGateway,+ LLMResult,+ LLMTextResult,+ StreamEvent (..),+ ToolCall (..),+ mkToolCall,+ ToolDef (toolDescription, toolName, toolParameters),+ ToolResult (trCallId, trContent),+ Turn (..),+ )+import LLM.Core.Usage (Usage (..), emptyUsage)+import Network.HTTP.Client qualified as HC+import Network.HTTP.Req+ ( Option,+ POST (POST),+ ReqBodyJson (ReqBodyJson),+ Scheme (Https),+ Url,+ header,+ https,+ jsonResponse,+ req,+ reqBr,+ responseBody,+ responseStatusCode,+ runReq,+ (/:),+ )++-- | Create a LLMGateway for the Claude provider. Takes the API key as a parameter.+claudeGateway :: Text -> LLMGateway+claudeGateway apiKey = toGateway $ claudeProvider apiKey++-- | Create a LLMProvider for the Claude provider. Takes the API key as a parameter.+claudeProvider :: Text -> LLMProvider+claudeProvider apiKey =+ LLMProvider+ { providerName = "claude",+ buildBody = claudeBuildBody,+ sendRequest = sendRequest,+ sendStreamRequest = \body callback ->+ runReq lenientConfig $+ reqBr POST claudeUrl (ReqBodyJson body) (claudeOpts apiKey) $ \resp ->+ handleStreamResponse resp (`parseClaudeStream` callback),+ parseResponse = pure . parseClaudeResponse,+ -- buildObjectBody _ r schema = claudeBuildBody False (r {reqConversation = reqConversation r <> Conversation [UserTurn ("Generate a JSON object matching this schema: " <> T.pack (show schema))]})+ buildObjectBody = \r schema ->+ let schemaText = TL.toStrict . decodeUtf8 $ encode schema+ instruction = "Respond with a raw JSON object matching this schema. No markdown, no explanation, no code fences:\n" <> schemaText+ conv' = r.reqConversation <> [UserTurn instruction]+ in claudeBuildBody False (r {reqConversation = conv'}),+ sendObjectRequest = sendRequest,+ -- parseObjectResponse _ = parseClaudeObjectResponse+ parseObjectResponse = parseClaudeObjectResponse+ }+ where+ sendRequest body =+ runReq lenientConfig $ do+ resp <- req POST claudeUrl (ReqBodyJson body) jsonResponse (claudeOpts apiKey)+ pure (responseStatusCode resp, responseBody resp)++-- Internal helpers++claudeUrl :: Url 'Https+claudeUrl = https "api.anthropic.com" /: "v1" /: "messages"++claudeOpts :: Text -> Option 'Https+claudeOpts apiKey =+ header "x-api-key" (encodeUtf8 apiKey)+ <> header "anthropic-version" "2023-06-01"++-- | Create an LLMClient from Claude credentials+-- claudeGateway :: Text -> LLMGateway+-- claudeGateway apiKey = toGateway (Claude apiKey)+parseClaudeStream :: HC.BodyReader -> (StreamEvent -> IO ()) -> IO LLMTextResult+parseClaudeStream reader callback = do+ blocksRef <- newIORef ([] :: [ContentBlock])+ usageRef <- newIORef emptyUsage+ -- For accumulating tool_use input JSON across deltas+ toolAccRef <- newIORef (Nothing :: Maybe (Text, Text, Text)) -- (id, name, json_so_far)+ readSSEEvents (HC.brRead reader) $ \sse -> do+ case sse.sseEvent of+ Just "message_start" ->+ -- Extract input token count from message.usage+ case decodeStrict' (encodeUtf8 sse.sseData) of+ Just v -> case parseMaybe parseMessageStartUsage v of+ Just inputToks -> modifyIORef' usageRef $ \u -> u {usageInputTokens = inputToks}+ Nothing -> pure ()+ Nothing -> pure ()+ Just "content_block_start" ->+ case decodeStrict' (encodeUtf8 sse.sseData) of+ Just v -> case parseMaybe parseContentBlockStart v of+ Just (cid, name) -> writeIORef toolAccRef (Just (cid, name, ""))+ Nothing -> pure () -- text block start, nothing to do+ Nothing -> pure ()+ Just "content_block_delta" ->+ case decodeStrict' (encodeUtf8 sse.sseData) of+ Just v -> do+ -- Try text delta+ case parseMaybe parseTextDelta v of+ Just txt -> do+ modifyIORef' blocksRef (TextBlock txt :)+ callback (StreamDelta txt)+ Nothing -> pure ()+ -- Try tool input delta+ case parseMaybe parseInputJsonDelta v of+ Just fragment ->+ modifyIORef' toolAccRef $ fmap (\(cid, name, acc) -> (cid, name, acc <> fragment))+ Nothing -> pure ()+ Nothing -> pure ()+ Just "content_block_stop" -> do+ mTool <- readIORef toolAccRef+ case mTool of+ Just (cid, name, jsonStr) | not (T.null jsonStr) -> do+ let args = case decodeStrict' (encodeUtf8 jsonStr) of+ Just v -> v+ Nothing -> String jsonStr+ tc = mkToolCall cid name args+ modifyIORef' blocksRef (ToolCallBlock tc :)+ callback (StreamToolCall tc)+ writeIORef toolAccRef Nothing+ _ -> writeIORef toolAccRef Nothing+ Just "message_delta" ->+ case decodeStrict' (encodeUtf8 sse.sseData) of+ Just v -> case parseMaybe parseMessageDeltaUsage v of+ Just outputToks -> modifyIORef' usageRef $ \u -> u {usageOutputTokens = outputToks}+ Nothing -> pure ()+ Nothing -> pure ()+ _ -> pure () -- message_stop, ping, etc.+ blocks <- reverse <$> readIORef blocksRef+ usage <- readIORef usageRef+ let text = T.concat [t | TextBlock t <- blocks]+ if null blocks+ then pure $ Left EmptyResponse+ else pure $ Right (ChatResponse text blocks (Just usage) Nothing)++-- Parsers for streaming events+parseMessageStartUsage :: Value -> Parser Int+parseMessageStartUsage = withObject "message_start" $ \o -> do+ msg <- o .: "message"+ withObject "message" (\mo -> do u <- mo .: "usage"; withObject "usage" (.: "input_tokens") u) msg++parseMessageDeltaUsage :: Value -> Parser Int+parseMessageDeltaUsage = withObject "message_delta" $ \o -> do+ u <- o .: "usage"+ withObject "usage" (.: "output_tokens") u++parseContentBlockStart :: Value -> Parser (Text, Text)+parseContentBlockStart = withObject "content_block_start" $ \o -> do+ cb <- o .: "content_block"+ withObject+ "content_block"+ ( \cbo -> do+ typ <- cbo .: "type" :: Parser Text+ case typ of+ "tool_use" -> (,) <$> cbo .: "id" <*> cbo .: "name"+ _ -> fail "not tool_use"+ )+ cb++parseTextDelta :: Value -> Parser Text+parseTextDelta = withObject "delta_event" $ \o -> do+ d <- o .: "delta"+ withObject+ "delta"+ ( \d' -> do+ typ <- d' .: "type" :: Parser Text+ case typ of+ "text_delta" -> d' .: "text"+ _ -> fail "not text_delta"+ )+ d++parseInputJsonDelta :: Value -> Parser Text+parseInputJsonDelta = withObject "delta_event" $ \o -> do+ d <- o .: "delta"+ withObject+ "delta"+ ( \d' -> do+ typ <- d' .: "type" :: Parser Text+ case typ of+ "input_json_delta" -> d' .: "partial_json"+ _ -> fail "not input_json_delta"+ )+ d++claudeBuildBody :: Bool -> ChatRequest -> Value+claudeBuildBody stream r =+ object $+ [ "model" .= r.reqModel,+ "max_tokens" .= r.reqMaxTokens,+ "messages" .= concatMap encodeTurn r.reqConversation+ ]+ ++ ["system" .= sys | Just sys <- [r.reqSystem]]+ ++ ["temperature" .= t | Just t <- [r.reqTemperature]]+ ++ ["tools" .= map encodeToolDef r.reqTools | not (null r.reqTools)]+ ++ ["stream" .= True | stream]++encodeTurn :: Turn -> [Value]+encodeTurn (UserTurn content) =+ [ object+ [ "role" .= ("user" :: Text),+ "content" .= content+ ]+ ]+encodeTurn (AssistantTurn text _mReasoning calls) =+ [ object+ [ "role" .= ("assistant" :: Text),+ "content" .= (textBlocks ++ toolBlocks)+ ]+ ]+ where+ textBlocks = [object ["type" .= ("text" :: Text), "text" .= text] | not (T.null text)]+ toolBlocks = map encodeToolUseBlock calls+encodeTurn (ToolTurn results) =+ [ object+ [ "role" .= ("user" :: Text),+ "content" .= map encodeToolResult results+ ]+ ]++encodeToolDef :: ToolDef -> Value+encodeToolDef td =+ object+ [ "name" .= td.toolName,+ "description" .= td.toolDescription,+ "input_schema" .= td.toolParameters+ ]++encodeToolUseBlock :: ToolCall -> Value+encodeToolUseBlock tc =+ object+ [ "type" .= ("tool_use" :: Text),+ "id" .= tc.tcId,+ "name" .= tc.tcName,+ "input" .= tc.tcArguments+ ]++encodeToolResult :: ToolResult -> Value+encodeToolResult tr =+ object+ [ "type" .= ("tool_result" :: Text),+ "tool_use_id" .= tr.trCallId,+ "content" .= tr.trContent+ ]++parseClaudeResponse :: Value -> LLMTextResult+parseClaudeResponse v = case parseMaybe go v of+ Nothing -> Left EmptyResponse+ Just blocks -> case blocks of+ [] -> Left EmptyResponse+ _ ->+ let text = T.concat [t | TextBlock t <- blocks]+ in Right (ChatResponse text blocks (parseClaudeUsage v) Nothing)+ where+ go :: Value -> Parser [ContentBlock]+ go = withObject "ClaudeResponse" $ \o -> do+ content <- o .: "content" :: Parser [Value]+ mapM parseBlock content++ parseBlock :: Value -> Parser ContentBlock+ parseBlock = withObject "content_block" $ \o -> do+ typ <- o .: "type" :: Parser Text+ case typ of+ "text" -> TextBlock <$> o .: "text"+ "tool_use" -> do+ cid <- o .: "id"+ name <- o .: "name"+ args <- o .: "input"+ pure $ ToolCallBlock (mkToolCall cid name args)+ _ -> fail $ "Unknown content block type: " <> T.unpack typ++parseClaudeUsage :: Value -> Maybe Usage+parseClaudeUsage = parseMaybe $ withObject "ClaudeResponse" $ \o -> do+ u <- o .: "usage"+ withObject "usage" (\uo -> Usage <$> uo .: "input_tokens" <*> uo .: "output_tokens" <*> pure 0) u++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)+ where+ go :: Value -> Parser Text+ go = withObject "ClaudeResponse" $ \o -> do+ content <- o .: "content" :: Parser [Value]+ case content of+ (block : _) -> withObject "content_block" (.: "text") block+ _ -> fail "No content"
+ src/LLM/Providers/DeepSeek.hs view
@@ -0,0 +1,144 @@+module LLM.Providers.DeepSeek+ ( deepSeekGateway,+ deepSeekGatewayWith,+ deepSeekProvider,+ deepSeekProviderWith,+ deepSeekBuildBodyPairs,+ )+where++import Data.Aeson+ ( KeyValue ((.=)),+ Value,+ decodeStrict',+ encode,+ object,+ withObject,+ (.:),+ )+import Data.Aeson.Types (Pair, Parser, parseMaybe)+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.Types+ ( ChatRequest+ ( reqConversation,+ reqMaxTokens,+ reqModel,+ reqTemperature,+ reqThinking,+ reqTools+ ),+ LLMError (EmptyResponse),+ LLMGateway,+ ThinkingMode (..),+ Turn (UserTurn),+ deepSeekMessageEncodeOptions,+ )+import LLM.Providers.OpenAI+ ( authHeader,+ buildMessages,+ encodeToolDef,+ parseOpenAIResponse,+ parseOpenAIStream,+ parseOpenAIUsage,+ )+import Network.HTTP.Req+ ( Option,+ POST (POST),+ ReqBodyJson (ReqBodyJson),+ Url,+ https,+ jsonResponse,+ req,+ reqBr,+ responseBody,+ responseStatusCode,+ runReq,+ (/:),+ )++-- | Create a LLMGateway for the DeepSeek provider. Takes the API key as a parameter.+deepSeekGateway :: Text -> LLMGateway+deepSeekGateway apiKey = toGateway $ deepSeekProvider apiKey++-- | Create a LLMGateway for the DeepSeek provider with a custom base URL. Takes the API key and base URL as parameters.+deepSeekGatewayWith :: Url scheme -> Option scheme -> Text -> LLMGateway+deepSeekGatewayWith baseUrl baseOpts apiKey = toGateway (deepSeekProviderWith baseUrl baseOpts apiKey)++-- | DeepSeek provider at api.deepseek.com.+deepSeekProvider :: Text -> LLMProvider+deepSeekProvider = deepSeekProviderWith (https "api.deepseek.com") mempty++-- | DeepSeek-compatible provider with a custom base URL.+deepSeekProviderWith :: Url scheme -> Option scheme -> Text -> LLMProvider+deepSeekProviderWith baseUrl baseOpts apiKey =+ LLMProvider+ { providerName = "deepseek",+ buildBody = deepSeekBuildBody,+ sendRequest = sendRequest,+ sendStreamRequest = \body callback ->+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ opts = baseOpts <> authHeader apiKey+ reqBr POST url (ReqBodyJson body) opts $ \resp ->+ handleStreamResponse resp (`parseOpenAIStream` callback),+ parseResponse = pure . parseOpenAIResponse,+ buildObjectBody = \r schema ->+ let schemaText = TL.toStrict . TLE.decodeUtf8 $ encode schema+ instruction =+ "Respond with a raw JSON object matching this JSON schema. "+ <> "No markdown, no code fences, no explanation:\n"+ <> schemaText+ r' = r {reqConversation = r.reqConversation <> [UserTurn instruction]}+ in object $+ 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)+ }+ where+ sendRequest body =+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ opts = baseOpts <> authHeader apiKey+ resp <- req POST url (ReqBodyJson body) jsonResponse 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+deepSeekBuildBody stream r = object $ deepSeekBuildBodyPairs stream r++deepSeekBuildBodyPairs :: Bool -> ChatRequest -> [Pair]+deepSeekBuildBodyPairs stream r =+ [ "model" .= r.reqModel,+ "max_tokens" .= r.reqMaxTokens,+ "messages" .= buildMessages deepSeekMessageEncodeOptions r+ ]+ ++ thinkingPairs r+ ++ ["temperature" .= t | Just t <- [r.reqTemperature]]+ ++ ["tools" .= map encodeToolDef r.reqTools | not (null r.reqTools)]+ ++ ["stream" .= True | stream]+ ++ ["stream_options" .= object ["include_usage" .= True] | stream]++thinkingPairs :: ChatRequest -> [Pair]+thinkingPairs r =+ case r.reqThinking of+ Just tm+ | not tm.tmEnabled ->+ ["thinking" .= object ["type" .= ("disabled" :: Text)]]+ Just tm ->+ ("thinking" .= object ["type" .= ("enabled" :: Text)]) : ["reasoning_effort" .= e | Just e <- [tm.tmEffort]]+ Nothing ->+ ["thinking" .= object ["type" .= ("disabled" :: Text)]]
+ src/LLM/Providers/Gemini.hs view
@@ -0,0 +1,405 @@+module LLM.Providers.Gemini+ ( geminiGateway,+ geminiProvider,+ parseGeminiResponse,+ parseGeminiUsage,+ )+where++import Control.Applicative ((<|>))+import Data.Aeson+ ( KeyValue ((.=)),+ Value (Object, String),+ decodeStrict',+ object,+ withObject,+ (.!=),+ (.:),+ (.:?),+ )+import Data.Aeson.KeyMap qualified as KM+import Data.Aeson.Types (Pair, Parser, parseMaybe)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (encodeUtf8)+import Data.Unique (hashUnique, newUnique)+import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, stripBoundsAndComments, stripJsonFences)+import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents)+import LLM.Core.Types+ ( ChatRequest+ ( reqConversation,+ reqMaxTokens,+ reqModel,+ reqSystem,+ reqTemperature,+ reqTools+ ),+ ChatResponse (ChatResponse),+ ContentBlock (..),+ LLMError (EmptyResponse),+ LLMGateway,+ LLMObjectResult,+ LLMTextResult,+ StreamEvent (..),+ ToolCall (..),+ ToolDef (toolDescription, toolName, toolParameters),+ ToolResult (trContent, trName),+ Turn (..),+ mkToolCall,+ )+import LLM.Core.Usage (Usage (..))+import Network.HTTP.Client qualified as HC+import Network.HTTP.Req+ ( POST (POST),+ ReqBodyJson (ReqBodyJson),+ header,+ https,+ jsonResponse,+ req,+ reqBr,+ responseBody,+ responseStatusCode,+ runReq,+ (/:),+ (=:),+ )++-- | Create a LLMGateway for the Gemini provider. Takes the API key as a parameter.+geminiGateway :: Text -> LLMGateway+geminiGateway apiKey = toGateway (geminiProvider apiKey)++-- | Create a LLMProvider for the Gemini provider. Takes the API key as a parameter.+geminiProvider :: Text -> LLMProvider+geminiProvider apiKey =+ LLMProvider+ { providerName = "gemini",+ buildBody = const geminiBuildBody,+ sendRequest = sendRequest,+ sendStreamRequest = \body callback ->+ runReq lenientConfig $ do+ let model = extractModel body+ url =+ https "generativelanguage.googleapis.com"+ /: "v1beta"+ /: "models"+ /: (model <> ":streamGenerateContent")+ reqBr POST url (ReqBodyJson (stripBoundsAndComments $ stripModel body)) (header "x-goog-api-key" (encodeUtf8 apiKey) <> "alt" =: ("sse" :: Text)) $ \resp ->+ handleStreamResponse resp (`parseGeminiStream` callback),+ parseResponse = parseGeminiResponse,+ buildObjectBody = \r schema ->+ object $+ [ "_model" .= r.reqModel,+ "contents" .= concatMap (encodeTurn r.reqModel) r.reqConversation,+ "generationConfig"+ .= object+ ( [ "maxOutputTokens" .= r.reqMaxTokens,+ "responseMimeType" .= ("application/json" :: Text),+ "responseSchema" .= schema+ ]+ ++ ["temperature" .= t | Just t <- [r.reqTemperature]]+ )+ ]+ ++ [ "system_instruction" .= object ["parts" .= [object ["text" .= sys]]]+ | Just sys <- [r.reqSystem]+ ]+ ++ [ "tools" .= [object ["function_declarations" .= map encodeToolDef r.reqTools]]+ | not (null r.reqTools)+ ],+ sendObjectRequest = sendRequest,+ parseObjectResponse = parseGeminiObjectResponse+ }+ where+ sendRequest body =+ runReq lenientConfig $ do+ -- For non-streaming we need the model name from the body to construct the URL.+ -- We extract it from the request body JSON since the LLMProvider only passes Value.+ let model = extractModel body+ url =+ https "generativelanguage.googleapis.com"+ /: "v1beta"+ /: "models"+ /: (model <> ":generateContent")+ resp <- req POST url (ReqBodyJson (stripBoundsAndComments $ stripModel body)) jsonResponse (header "x-goog-api-key" (encodeUtf8 apiKey))+ pure (responseStatusCode resp, responseBody resp)++-- | Extract model name stashed in the request body by geminiBuildBody.+extractModel :: Value -> Text+extractModel v = fromMaybe "gemini-2.0-flash" (parseMaybe (withObject "body" (.: "_model")) v)++-- | Remove the internal '_model' field before sending to the API.+stripModel :: Value -> Value+stripModel (Object o) = Object (KM.delete "_model" o)+stripModel v = v++parseGeminiStream :: HC.BodyReader -> (StreamEvent -> IO ()) -> IO LLMTextResult+parseGeminiStream reader callback = do+ blocksRef <- newIORef ([] :: [ContentBlock])+ usageRef <- newIORef Nothing+ readSSEEvents (HC.brRead reader) $ \sse -> do+ case decodeStrict' (encodeUtf8 sse.sseData) of+ Nothing -> pure ()+ Just v -> do+ -- modelVersion is needed so we can later guard against replaying+ -- thought signatures into a different model than the one that+ -- produced them.+ let modelVer = parseMaybe parseModelVersion v+ case parseMaybe (parseChunkParts modelVer) v of+ Just parts -> do+ newBlocks <- mapM (assignToolId callback) parts+ modifyIORef' blocksRef (++ newBlocks)+ Nothing -> pure ()+ case parseMaybe parseUsageMetadata v of+ Just u -> writeIORef usageRef (Just u)+ Nothing -> pure ()+ blocks <- readIORef blocksRef+ usage <- readIORef usageRef+ let text = T.concat [t | TextBlock t <- blocks]+ if null blocks+ then pure $ Left EmptyResponse+ else pure $ Right (ChatResponse text blocks usage Nothing)+ where+ assignToolId :: (StreamEvent -> IO ()) -> ContentBlock -> IO ContentBlock+ assignToolId cb (TextBlock t) = do+ cb (StreamDelta t)+ pure (TextBlock t)+ assignToolId cb (ToolCallBlock tc) = do+ tc' <- normalizeToolCallId tc+ cb (StreamToolCall tc')+ pure (ToolCallBlock tc')++ parseChunkParts :: Maybe Text -> Value -> Parser [ContentBlock]+ parseChunkParts modelVer = withObject "GeminiChunk" $ \o -> do+ (cand : _) <- o .: "candidates" :: Parser [Value]+ withObject+ "candidate"+ ( \co -> do+ cont <- co .: "content"+ withObject "content" (\cco -> cco .: "parts" >>= mapM (parsePartBlock modelVer)) cont+ )+ cand++ parsePartBlock :: Maybe Text -> Value -> Parser ContentBlock+ parsePartBlock modelVer = withObject "part" $ \o -> do+ mSig <- o .:? "thoughtSignature" :: Parser (Maybe Text)+ let tryText = TextBlock <$> (o .: "text")+ tryFunctionCall = do+ fc <- o .: "functionCall"+ withObject+ "functionCall"+ ( \fco -> do+ name <- fco .: "name"+ args <- fco .:? "args" .!= object []+ pure $ ToolCallBlock (attachGeminiMeta modelVer mSig (mkToolCall name name args))+ )+ fc+ tryText <|> tryFunctionCall++ parseUsageMetadata :: Value -> Parser Usage+ parseUsageMetadata = withObject "GeminiChunk" $ \o -> do+ u <- o .: "usageMetadata"+ withObject+ "usageMetadata"+ (\uo -> Usage <$> uo .: "promptTokenCount" <*> uo .: "candidatesTokenCount" <*> pure 0)+ u++geminiBuildBody :: ChatRequest -> Value+geminiBuildBody r = object $ geminiBuildBodyPairs r++geminiBuildBodyPairs :: ChatRequest -> [Pair]+geminiBuildBodyPairs r =+ [ "_model" .= r.reqModel,+ "contents" .= concatMap (encodeTurn r.reqModel) r.reqConversation,+ "generationConfig" .= genConfig r+ ]+ ++ [ "system_instruction" .= object ["parts" .= [object ["text" .= sys]]]+ | Just sys <- [r.reqSystem]+ ]+ ++ [ "tools" .= [object ["function_declarations" .= map encodeToolDef r.reqTools]]+ | not (null r.reqTools)+ ]++-- | Encode a turn for Gemini. The current request model is threaded through+-- so that thought signatures captured from a previous response can be+-- replayed only when the receiving model matches the one that emitted them.+encodeTurn :: Text -> Turn -> [Value]+encodeTurn _ (UserTurn content) =+ [ object+ [ "role" .= ("user" :: Text),+ "parts" .= [object ["text" .= content]]+ ]+ ]+encodeTurn currentModel (AssistantTurn text _mReasoning calls) =+ [ object+ [ "role" .= ("model" :: Text),+ "parts" .= (textParts ++ callParts)+ ]+ ]+ where+ textParts = [object ["text" .= text] | not (T.null text)]+ callParts = map (encodeFunctionCall currentModel) calls+encodeTurn _ (ToolTurn results) =+ [ object+ [ "role" .= ("user" :: Text),+ "parts" .= map encodeFunctionResponse results+ ]+ ]++encodeToolDef :: ToolDef -> Value+encodeToolDef td =+ object+ [ "name" .= td.toolName,+ "description" .= td.toolDescription,+ "parameters" .= td.toolParameters+ ]++-- | Encode an assistant tool call back to a Gemini @functionCall@ part.+--+-- Gemini 2.5 thinking models attach an opaque 'thoughtSignature' to each+-- function-call part. That signature must be replayed verbatim on subsequent+-- requests against the same model, or the API rejects the request with a+-- @function call is missing a thought_signature@ error. We stored the+-- signature plus the emitting model name in 'tcProviderMeta' at parse time;+-- here we re-emit it only when 'currentModel' matches, because signatures+-- are bound to the model that produced them.+encodeFunctionCall :: Text -> ToolCall -> Value+encodeFunctionCall currentModel tc =+ object $+ ( "functionCall"+ .= object+ [ "name" .= tc.tcName,+ "args" .= tc.tcArguments+ ]+ )+ : ["thoughtSignature" .= s | Just s <- [signatureForModel currentModel tc.tcProviderMeta]]++encodeFunctionResponse :: ToolResult -> Value+encodeFunctionResponse tr =+ object+ [ "functionResponse"+ .= object+ [ "name" .= tr.trName,+ "response" .= object ["result" .= tr.trContent]+ ]+ ]++-- | Generate a unique call ID for Gemini tool calls (which lack native IDs)+normalizeToolCallId :: ToolCall -> IO ToolCall+normalizeToolCallId tc = do+ u <- newUnique+ let callId = "call_" <> T.pack (show (hashUnique u))+ pure tc {tcId = callId}++normalizeBlock :: ContentBlock -> IO ContentBlock+normalizeBlock (ToolCallBlock tc) = ToolCallBlock <$> normalizeToolCallId tc+normalizeBlock b = pure b++genConfig :: ChatRequest -> Value+genConfig r =+ object $+ ("maxOutputTokens" .= r.reqMaxTokens)+ : ["temperature" .= t | Just t <- [r.reqTemperature]]++parseGeminiResponse :: Value -> IO LLMTextResult+parseGeminiResponse v = case parseMaybe (go modelVer) v of+ Nothing -> pure $ Left EmptyResponse+ Just blocks -> do+ blocks' <- mapM normalizeBlock blocks+ case blocks' of+ [] -> pure $ Left EmptyResponse+ _ ->+ let text = T.concat [t | TextBlock t <- blocks']+ in pure $ Right (ChatResponse text blocks' (parseGeminiUsage v) Nothing)+ where+ modelVer = parseMaybe parseModelVersion v++ go :: Maybe Text -> Value -> Parser [ContentBlock]+ go mv = withObject "GeminiResponse" $ \o -> do+ (cand : _) <- o .: "candidates" :: Parser [Value]+ withObject+ "candidate"+ ( \co -> do+ cont <- co .: "content"+ withObject+ "content"+ ( \cco -> do+ parts <- cco .: "parts" :: Parser [Value]+ mapM (parsePart mv) parts+ )+ cont+ )+ cand++ parsePart :: Maybe Text -> Value -> Parser ContentBlock+ parsePart mv = withObject "part" $ \o -> do+ mSig <- o .:? "thoughtSignature" :: Parser (Maybe Text)+ let tryText = TextBlock <$> (o .: "text")+ tryFunctionCall = do+ fc <- o .: "functionCall"+ withObject+ "functionCall"+ ( \fco -> do+ name <- fco .: "name"+ args <- fco .:? "args" .!= object []+ -- Gemini doesn't provide a call id; use the function name.+ -- normalizeBlock replaces it with a unique id later.+ pure $ ToolCallBlock (attachGeminiMeta mv mSig (mkToolCall name name args))+ )+ fc+ tryText <|> tryFunctionCall++-- | Extract @modelVersion@ from a Gemini response or chunk. This is the+-- canonical model name (e.g. @gemini-2.5-pro-001@) used as the binding key+-- for thought signatures.+parseModelVersion :: Value -> Parser Text+parseModelVersion = withObject "GeminiResponse" (.: "modelVersion")++-- | Build the provider-metadata bag stored on a 'ToolCall' for Gemini.+-- Returns the original tool call unchanged when there's no signature to+-- preserve, so we don't pollute logs with empty metadata.+attachGeminiMeta :: Maybe Text -> Maybe Text -> ToolCall -> ToolCall+attachGeminiMeta _ Nothing tc = tc+attachGeminiMeta mModel (Just sig) tc =+ tc {tcProviderMeta = Just (object (("thoughtSignature" .= sig) : modelField))}+ where+ modelField = ["model" .= m | Just m <- [mModel]]++-- | Pull a thought signature out of 'tcProviderMeta' iff it was emitted by+-- the model we're currently calling. Cross-model replay is unsafe — Gemini+-- treats the signature as an opaque per-model token and will reject it.+signatureForModel :: Text -> Maybe Value -> Maybe Text+signatureForModel currentModel (Just (Object o)) = do+ String sig <- KM.lookup "thoughtSignature" o+ case KM.lookup "model" o of+ Just (String m) | not (modelsMatch currentModel m) -> Nothing+ _ -> Just sig+signatureForModel _ _ = Nothing++-- | A signature emitted by @gemini-2.5-pro-001@ is safe to replay against+-- @gemini-2.5-pro@ (and vice-versa): the response carries the resolved+-- version string while requests typically use an alias. We accept either+-- direction being a prefix of the other.+modelsMatch :: Text -> Text -> Bool+modelsMatch a b = a == b || T.isPrefixOf a b || T.isPrefixOf b a++parseGeminiUsage :: Value -> Maybe Usage+parseGeminiUsage = parseMaybe $ withObject "GeminiResponse" $ \o -> do+ u <- o .: "usageMetadata"+ withObject+ "usageMetadata"+ (\uo -> Usage <$> uo .: "promptTokenCount" <*> uo .: "candidatesTokenCount" <*> pure 0)+ u++parseGeminiObjectResponse :: Value -> IO LLMObjectResult+parseGeminiObjectResponse 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, parseGeminiUsage v)+ where+ go :: Value -> Parser Text+ go = withObject "GeminiObjectResponse" $ \o -> do+ (cand : _) <- o .: "candidates" :: Parser [Value]+ withObject "candidate" (\co -> co .: "content" >>= withObject "content" (\cco -> cco .: "parts" >>= \case (p : _) -> withObject "part" (.: "text") p; _ -> fail "No parts")) cand
+ src/LLM/Providers/Ollama.hs view
@@ -0,0 +1,120 @@+module LLM.Providers.Ollama+ ( ollamaProvider,+ ollamaProviderWith,+ ollamaGateway,+ ollamaGatewayWith,+ )+where++import Data.Aeson+ ( KeyValue ((.=)),+ Value,+ decodeStrict',+ object,+ withObject,+ (.:),+ )+import Data.Aeson.Types (Parser, parseMaybe)+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.Types+ ( ChatRequest+ ( reqMaxTokens,+ reqModel,+ reqTemperature,+ reqTools+ ),+ LLMError (EmptyResponse),+ LLMGateway,+ defaultMessageEncodeOptions,+ )+import LLM.Providers.OpenAI (buildMessages, encodeToolDef, openAIBuildBodyPairs, parseOpenAIResponse, parseOpenAIStream, parseOpenAIUsage)+import Network.HTTP.Req+ ( Option,+ POST (POST),+ ReqBodyJson (ReqBodyJson),+ Scheme (Http),+ Url,+ http,+ jsonResponse,+ port,+ req,+ reqBr,+ responseBody,+ responseStatusCode,+ runReq,+ (/:),+ )++-- | Create a LLMGateway for the default Ollama instance (localhost:11434).+ollamaGateway :: LLMGateway+ollamaGateway = toGateway ollamaProvider++-- | Create a LLMGateway for a custom Ollama instance.+ollamaGatewayWith :: Url 'Http -> Option 'Http -> LLMGateway+ollamaGatewayWith baseUrl baseOpts = toGateway (ollamaProviderWith baseUrl baseOpts)++-- | Default Ollama provider at localhost:11434.+ollamaProvider :: LLMProvider+ollamaProvider = ollamaProviderWith (http "localhost") (port 11434)++ollamaProviderWith :: Url scheme -> Option scheme -> LLMProvider+ollamaProviderWith baseUrl baseOpts =+ LLMProvider+ { providerName = "ollama",+ -- Ollama uses the same request format as OpenAI, but without stream_options+ -- (Ollama doesn't support include_usage in streaming).+ buildBody = ollamaBuildBody,+ sendRequest = sendRequest,+ sendStreamRequest = \body callback ->+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ reqBr POST url (ReqBodyJson body) baseOpts $ \resp ->+ handleStreamResponse resp (`parseOpenAIStream` callback),+ parseResponse = pure . parseOpenAIResponse,+ buildObjectBody = \r schema ->+ object $+ openAIBuildBodyPairs False r+ <> [ "response_format"+ .= object+ [ "type" .= ("json_schema" :: Text),+ "json_schema"+ .= object+ [ "name" .= ("response" :: Text),+ "schema" .= normalizeSchemaOpenAI schema,+ "strict" .= True+ ]+ ]+ ],+ 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)+ }+ where+ sendRequest body =+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ resp <- req POST url (ReqBodyJson body) jsonResponse 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++-- | Build request body — same as OpenAI but without stream_options+-- since Ollama doesn't support include_usage.+ollamaBuildBody :: Bool -> ChatRequest -> Value+ollamaBuildBody stream r =+ object $+ [ "model" .= r.reqModel,+ "messages" .= buildMessages defaultMessageEncodeOptions r+ ]+ ++ ["num_predict" .= r.reqMaxTokens]+ ++ ["temperature" .= t | Just t <- [r.reqTemperature]]+ ++ ["tools" .= map encodeToolDef r.reqTools | not (null r.reqTools)]+ ++ ["stream" .= True | stream]
+ src/LLM/Providers/OpenAI.hs view
@@ -0,0 +1,415 @@+module LLM.Providers.OpenAI+ ( openAIGateway,+ openAIGatewayWith,+ openAIProvider,+ openAIProviderWith,+ parseOpenAIResponse,+ parseOpenAIUsage,+ buildMessages,+ encodeTurn,+ encodeToolDef,+ parseOpenAIStream,+ openAIBuildBody,+ openAIBuildBodyPairs,+ authHeader,+ )+where++import Data.Aeson+ ( KeyValue ((.=)),+ Object,+ Value (String),+ decodeStrict',+ encode,+ object,+ withObject,+ (.!=),+ (.:),+ (.:?),+ )+import Data.Aeson.Types (Pair, Parser, parseMaybe)+import Data.ByteString.Lazy qualified as BSL+import Data.Foldable (forM_)+import Data.IORef (modifyIORef', newIORef, readIORef, writeIORef)+import Data.Maybe (fromMaybe, isNothing)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import LLM.Core.LLMProvider (LLMProvider (..), toGateway)+import LLM.Core.ProviderUtils (handleStreamResponse, lenientConfig, normalizeSchemaOpenAI, stripJsonFences)+import LLM.Core.SSE (SSEEvent (sseData), readSSEEvents)+import LLM.Core.Types+ ( ChatRequest+ ( reqConversation,+ reqMaxTokens,+ reqModel,+ reqSystem,+ reqTemperature,+ reqTools+ ),+ ChatResponse (ChatResponse, respContent, respReasoning, respText, respUsage),+ ContentBlock (..),+ LLMError (EmptyResponse),+ LLMGateway,+ LLMTextResult,+ MessageEncodeOptions (..),+ StreamEvent (..),+ ToolCall (..),+ mkToolCall,+ ToolDef (toolDescription, toolName, toolParameters),+ ToolResult (trCallId, trContent),+ Turn (..),+ defaultMessageEncodeOptions,+ )+import LLM.Core.Usage (Usage (..))+import Network.HTTP.Client qualified as HC+import Network.HTTP.Req+ ( Option,+ POST (POST),+ ReqBodyJson (ReqBodyJson),+ Url,+ header,+ https,+ jsonResponse,+ req,+ reqBr,+ responseBody,+ responseStatusCode,+ runReq,+ (/:),+ )++-- | Create an OpenAI client for api.openai.com. Takes the API key as a parameter.+openAIGateway :: Text -> LLMGateway+openAIGateway apiKey = toGateway $ openAIProvider apiKey++-- | Create an OpenAI-compatible client with a custom base URL.+openAIGatewayWith :: Url scheme -> Option scheme -> Text -> LLMGateway+openAIGatewayWith baseUrl baseOpts apiKey = toGateway (openAIProviderWith baseUrl baseOpts apiKey)++-- | Create an OpenAI provider. Takes the API key as a parameter.+openAIProvider :: Text -> LLMProvider+openAIProvider = openAIProviderWith (https "api.openai.com") mempty++openAIProviderWith :: Url scheme -> Option scheme -> Text -> LLMProvider+openAIProviderWith baseUrl baseOpts apiKey =+ LLMProvider+ { providerName = "openai",+ buildBody = openAIBuildBody,+ sendRequest = sendRequest,+ sendStreamRequest = \body callback ->+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ opts = baseOpts <> authHeader apiKey+ reqBr POST url (ReqBodyJson body) opts $ \resp ->+ handleStreamResponse resp (`parseOpenAIStream` callback),+ parseResponse = pure . parseOpenAIResponse,+ buildObjectBody = \r schema ->+ object $+ openAIBuildBodyPairs False r+ <> [ "response_format"+ .= object+ [ "type" .= ("json_schema" :: Text),+ "json_schema"+ .= object+ [ "name" .= ("response" :: Text),+ "schema" .= normalizeSchemaOpenAI schema,+ "strict" .= True+ ]+ ]+ ],+ 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)+ }+ where+ sendRequest body =+ runReq lenientConfig $ do+ let url = baseUrl /: "v1" /: "chat" /: "completions"+ opts = baseOpts <> authHeader apiKey+ resp <- req POST url (ReqBodyJson body) jsonResponse opts+ pure (responseStatusCode resp, responseBody resp)++authHeader :: Text -> Option scheme+authHeader apiKey+ | T.null apiKey = mempty+ | otherwise = header "Authorization" ("Bearer " <> encodeUtf8 apiKey)++-- Request body++openAIBuildBody :: Bool -> ChatRequest -> Value+openAIBuildBody stream r = object $ openAIBuildBodyPairs stream r++openAIBuildBodyPairs :: Bool -> ChatRequest -> [Pair]+openAIBuildBodyPairs stream r =+ [ "model" .= r.reqModel,+ "max_completion_tokens" .= r.reqMaxTokens,+ "messages" .= buildMessages defaultMessageEncodeOptions r+ ]+ ++ ["temperature" .= t | Just t <- [r.reqTemperature]]+ ++ ["tools" .= map encodeToolDef r.reqTools | not (null r.reqTools)]+ ++ ["stream" .= True | stream]+ ++ ["stream_options" .= object ["include_usage" .= True] | stream]++buildMessages :: MessageEncodeOptions -> ChatRequest -> [Value]+buildMessages opts r =+ maybe [] (\sys -> [object ["role" .= ("system" :: Text), "content" .= sys]]) r.reqSystem+ ++ concatMap (encodeTurn opts) r.reqConversation++encodeTurn :: MessageEncodeOptions -> Turn -> [Value]+encodeTurn _ (UserTurn content) =+ [ object+ [ "role" .= ("user" :: Text),+ "content" .= content+ ]+ ]+encodeTurn opts (AssistantTurn text mReasoning calls) =+ [ object $+ ["role" .= ("assistant" :: Text)]+ ++ ["content" .= text | not (T.null text)]+ ++ [ "reasoning_content" .= rc+ | opts.meoIncludeReasoning,+ Just rc <- [mReasoning],+ not (T.null rc)+ ]+ ++ ["tool_calls" .= map encodeToolCall calls | not (null calls)]+ ]+encodeTurn _ (ToolTurn results) =+ map encodeToolResult results++encodeToolDef :: ToolDef -> Value+encodeToolDef td =+ object+ [ "type" .= ("function" :: Text),+ "function"+ .= object+ [ "name" .= td.toolName,+ "description" .= td.toolDescription,+ "parameters" .= td.toolParameters+ ]+ ]++encodeToolCall :: ToolCall -> Value+encodeToolCall tc =+ object+ [ "id" .= tc.tcId,+ "type" .= ("function" :: Text),+ "function"+ .= object+ [ "name" .= tc.tcName,+ "arguments" .= decodeUtf8 (BSL.toStrict (encode tc.tcArguments))+ ]+ ]++encodeToolResult :: ToolResult -> Value+encodeToolResult tr =+ object+ [ "role" .= ("tool" :: Text),+ "tool_call_id" .= tr.trCallId,+ "content" .= tr.trContent+ ]++-- Response parsing++parseOpenAIResponse :: Value -> LLMTextResult+parseOpenAIResponse v = case parseMaybe go v of+ Nothing -> Left EmptyResponse+ Just (mReasoning, blocks) ->+ if null blocks && isNothing mReasoning+ then Left EmptyResponse+ else+ let text = T.concat [t | TextBlock t <- blocks]+ in Right+ ChatResponse+ { respText = text,+ respContent = blocks,+ respUsage = parseOpenAIUsage v,+ respReasoning = mReasoning+ }+ where+ go :: Value -> Parser (Maybe Text, [ContentBlock])+ go = withObject "OpenAIResponse" $ \o -> do+ (choice : _) <- o .: "choices" :: Parser [Value]+ withObject+ "choice"+ ( \co -> do+ msg <- co .: "message"+ withObject "message" parseMessage msg+ )+ choice++ parseMessage :: Object -> Parser (Maybe Text, [ContentBlock])+ parseMessage mo = do+ mReasoning <- mo .:? "reasoning_content" :: Parser (Maybe Text)+ contentBlocks <- do+ mc <- mo .:? "content" :: Parser (Maybe Text)+ pure [TextBlock t | Just t <- [mc], not (T.null t)]+ toolBlocks <- do+ tcs <- mo .:? "tool_calls" .!= [] :: Parser [Value]+ mapM parseToolCall tcs+ pure (mReasoning, contentBlocks ++ toolBlocks)++ parseToolCall :: Value -> Parser ContentBlock+ parseToolCall = withObject "tool_call" $ \tc -> do+ cid <- tc .: "id"+ fn <- tc .: "function"+ withObject+ "function"+ ( \f -> do+ name <- f .: "name"+ argsStr <- f .: "arguments" :: Parser Text+ let args = case decodeStrict' (encodeUtf8 argsStr) of+ Just v' -> v'+ Nothing -> String argsStr+ pure $ ToolCallBlock (mkToolCall cid name args)+ )+ fn++parseOpenAIUsage :: Value -> Maybe Usage+parseOpenAIUsage = parseMaybe $ withObject "OpenAIResponse" $ \o -> do+ u <- o .: "usage"+ withObject "usage" (\uo -> Usage <$> uo .: "prompt_tokens" <*> uo .: "completion_tokens" <*> pure 0) u++-- Streaming++parseOpenAIStream :: HC.BodyReader -> (StreamEvent -> IO ()) -> IO LLMTextResult+parseOpenAIStream reader callback = do+ blocksRef <- newIORef ([] :: [ContentBlock])+ reasoningRef <- newIORef Nothing+ usageRef <- newIORef Nothing+ -- Track in-flight tool calls: index -> (id, name, accumulated args)+ toolAccRef <- newIORef ([] :: [(Int, Text, Text, Text)])+ readSSEEvents (HC.brRead reader) $ \sse -> do+ let raw = sse.sseData+ if raw == "[DONE]"+ then pure ()+ else case decodeStrict' (encodeUtf8 raw) of+ Nothing -> pure ()+ Just v -> do+ -- Reasoning deltas+ case parseMaybe parseStreamReasoningDelta v of+ Just (Just txt) | not (T.null txt) -> do+ modifyIORef' reasoningRef (Just . maybe txt (<> txt))+ callback (StreamReasoningDelta txt)+ _ -> pure ()+ -- Text deltas+ case parseMaybe parseStreamTextDelta v of+ Just txt | not (T.null txt) -> do+ modifyIORef' blocksRef (TextBlock txt :)+ callback (StreamDelta txt)+ _ -> pure ()+ -- Tool call deltas+ case parseMaybe parseStreamToolDelta v of+ Just (idx, mId, mName, argChunk) -> do+ modifyIORef' toolAccRef $ \acc ->+ case lookup idx [(i, (i, cid, n, a)) | (i, cid, n, a) <- acc] of+ Nothing ->+ -- New tool call+ let cid = fromMaybe "" mId+ n = fromMaybe "" mName+ in acc ++ [(idx, cid, n, argChunk)]+ Just (_, cid, n, a) ->+ -- Accumulate arguments+ [(if i == idx then (i, cid, n, a <> argChunk) else entry) | entry@(i, _, _, _) <- acc]+ Nothing -> pure ()+ -- Finish reason: emit accumulated tool calls+ case parseMaybe parseFinishReason v of+ Just "tool_calls" -> do+ tools <- readIORef toolAccRef+ forM_ tools $ \(_, cid, name, argsStr) -> do+ let args = case decodeStrict' (encodeUtf8 argsStr) of+ Just a -> a+ Nothing -> String argsStr+ tc = mkToolCall cid name args+ modifyIORef' blocksRef (ToolCallBlock tc :)+ callback (StreamToolCall tc)+ writeIORef toolAccRef []+ _ -> pure ()+ -- Usage (in the final chunk when stream_options.include_usage is set)+ case parseMaybe parseStreamUsage v of+ Just u -> writeIORef usageRef (Just u)+ Nothing -> pure ()+ -- Flush any remaining tool calls+ tools <- readIORef toolAccRef+ forM_ tools $ \(_, cid, name, argsStr) -> do+ let args = case decodeStrict' (encodeUtf8 argsStr) of+ Just a -> a+ Nothing -> String argsStr+ tc = mkToolCall cid name args+ modifyIORef' blocksRef (ToolCallBlock tc :)+ callback (StreamToolCall tc)+ blocks <- reverse <$> readIORef blocksRef+ mReasoning <- readIORef reasoningRef+ usage <- readIORef usageRef+ let text = T.concat [t | TextBlock t <- blocks]+ if null blocks && isNothing mReasoning+ then pure $ Left EmptyResponse+ else+ pure $+ Right+ ChatResponse+ { respText = text,+ respContent = blocks,+ respUsage = usage,+ respReasoning = mReasoning+ }++parseStreamReasoningDelta :: Value -> Parser (Maybe Text)+parseStreamReasoningDelta = withObject "chunk" $ \o -> do+ (c : _) <- o .: "choices" :: Parser [Value]+ withObject "choice" (\co -> do d <- co .: "delta"; withObject "delta" (.:? "reasoning_content") d) c++parseStreamTextDelta :: Value -> Parser Text+parseStreamTextDelta = withObject "chunk" $ \o -> do+ (c : _) <- o .: "choices" :: Parser [Value]+ withObject "choice" (\co -> do d <- co .: "delta"; withObject "delta" (.: "content") d) c++parseStreamToolDelta :: Value -> Parser (Int, Maybe Text, Maybe Text, Text)+parseStreamToolDelta = withObject "chunk" $ \o -> do+ (c : _) <- o .: "choices" :: Parser [Value]+ withObject+ "choice"+ ( \co -> do+ d <- co .: "delta"+ withObject+ "delta"+ ( \d' -> do+ (tc : _) <- d' .: "tool_calls" :: Parser [Value]+ withObject+ "tool_call"+ ( \tco -> do+ idx <- tco .: "index"+ mId <- tco .:? "id"+ fn <- tco .:? "function" .!= object []+ withObject+ "function"+ ( \f -> do+ mName <- f .:? "name"+ args <- f .:? "arguments" .!= ""+ pure (idx, mId, mName, args)+ )+ fn+ )+ tc+ )+ d+ )+ c++parseFinishReason :: Value -> Parser Text+parseFinishReason = withObject "chunk" $ \o -> do+ (c : _) <- o .: "choices" :: Parser [Value]+ withObject "choice" (.: "finish_reason") c++parseStreamUsage :: Value -> Parser Usage+parseStreamUsage = withObject "chunk" $ \o -> do+ u <- o .: "usage"+ withObject "usage" (\uo -> Usage <$> uo .: "prompt_tokens" <*> uo .: "completion_tokens" <*> pure 0) u
+ src/LLM/Tools.hs view
@@ -0,0 +1,39 @@+-- | Collection of tools for LLM operations+module LLM.Tools+ ( -- * File system tools+ copyFileToolTyped,+ createDirectoryToolTyped,+ directoryTreeToolTyped,+ fileInfoToolTyped,+ findFilesToolTyped,+ grepToolTyped,+ moveFileToolTyped,+ multiReplaceInFileToolTyped,+ readdirToolTyped,+ readfileToolTyped,+ removeDirectoryToolTyped,+ removeFileToolTyped,+ replaceInFileToolTyped,+ writefileToolTyped,++ -- * FsConfig+ mkFsConfig,+ FsConfig (..),+ )+where++import LLM.Tools.CopyFile (copyFileToolTyped)+import LLM.Tools.CreateDirectory (createDirectoryToolTyped)+import LLM.Tools.DirectoryTree (directoryTreeToolTyped)+import LLM.Tools.FileInfo (fileInfoToolTyped)+import LLM.Tools.FindFiles (findFilesToolTyped)+import LLM.Tools.FsConfig (FsConfig (..), mkFsConfig)+import LLM.Tools.Grep (grepToolTyped)+import LLM.Tools.MoveFile (moveFileToolTyped)+import LLM.Tools.MultiReplaceInFile (multiReplaceInFileToolTyped)+import LLM.Tools.Readdir (readdirToolTyped)+import LLM.Tools.Readfile (readfileToolTyped)+import LLM.Tools.RemoveDirectory (removeDirectoryToolTyped)+import LLM.Tools.RemoveFile (removeFileToolTyped)+import LLM.Tools.ReplaceInFile (replaceInFileToolTyped)+import LLM.Tools.Writefile (writefileToolTyped)
+ src/LLM/Tools/CopyFile.hs view
@@ -0,0 +1,62 @@+module LLM.Tools.CopyFile (copyFileToolTyped, CopyFileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, isSymlink, sandboxPath, sandboxWritePath)+import System.Directory (copyFile, doesDirectoryExist, doesFileExist, doesPathExist)++data CopyFileToolArgs = CopyFileToolArgs+ { _cfSrc :: Text,+ _cfDst :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec CopyFileToolArgs)++instance AC.HasCodec CopyFileToolArgs where+ codec =+ AC.object "copy source to destination" $+ CopyFileToolArgs+ <$> AC.requiredField "source" "Relative path of the file to copy" AC..= (._cfSrc)+ <*> AC.requiredField "destination" "Relative destination path (including filename)" AC..= (._cfDst)++copyFileToolTyped :: FsConfig -> TypedTool ctx CopyFileToolArgs+copyFileToolTyped cfg =+ TypedTool+ { ttoolName = "copy_file",+ ttoolDescription =+ "Copy a file from source to destination (both paths relative to the workspace). "+ <> "Overwrites the destination if it already exists. "+ <> "Creates parent directories at the destination as needed.",+ ttoolReadonly = False,+ ttoolExecute = const (copyFileExecTyped cfg)+ }++copyFileExecTyped :: FsConfig -> CopyFileToolArgs -> IO Text+copyFileExecTyped cfg args = do+ let src = args._cfSrc+ dst = args._cfDst+ srcResolved <- sandboxPath cfg (T.unpack src)+ -- Refuse symbolic-link sources: copying would either dereference the+ -- link (potentially pulling content from outside the sandbox) or be+ -- ambiguous about whether the link itself should be reproduced.+ srcIsLink <- isSymlink srcResolved+ if srcIsLink+ then pure $ "Error: refusing to copy symbolic link source: " <> src+ else do+ srcExists <- doesPathExist srcResolved+ if not srcExists+ then pure $ "Error: source does not exist: " <> src+ else do+ srcIsFile <- doesFileExist srcResolved+ srcIsDir <- doesDirectoryExist srcResolved+ case (srcIsFile, srcIsDir) of+ (False, True) -> pure $ "Error: source is a directory, not a regular file: " <> src+ (False, False) -> pure $ "Error: source is not a regular file: " <> src+ _ -> do+ dstResolved <- sandboxWritePath cfg (T.unpack dst)+ copyFile srcResolved dstResolved+ pure $ "Successfully copied " <> src <> " to " <> dst
+ src/LLM/Tools/CreateDirectory.hs view
@@ -0,0 +1,44 @@+module LLM.Tools.CreateDirectory (createDirectoryToolTyped, CreateDirectoryToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import System.Directory (createDirectoryIfMissing)++data CreateDirectoryToolArgs = CreateDirectoryToolArgs+ { _cdPath :: Text,+ _cdParents :: Bool+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec CreateDirectoryToolArgs)++instance AC.HasCodec CreateDirectoryToolArgs where+ codec =+ AC.object "create a directory" $+ CreateDirectoryToolArgs+ <$> AC.requiredField "path" "Relative path of the directory to create" AC..= (._cdPath)+ <*> AC.optionalFieldWithDefault "parents" True "Create intermediate parent directories as needed" AC..= (._cdParents)++createDirectoryToolTyped :: FsConfig -> TypedTool ctx CreateDirectoryToolArgs+createDirectoryToolTyped cfg =+ TypedTool+ { ttoolName = "create_directory",+ ttoolDescription =+ "Create a directory at the given path (relative to the workspace). "+ <> "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)+ }++createDirectoryExecTyped :: FsConfig -> CreateDirectoryToolArgs -> IO Text+createDirectoryExecTyped cfg args = do+ let p = args._cdPath+ parents = args._cdParents+ resolved <- sandboxPath cfg (T.unpack p)+ createDirectoryIfMissing parents resolved+ pure $ "Successfully created directory " <> p
+ src/LLM/Tools/DirectoryTree.hs view
@@ -0,0 +1,135 @@+module LLM.Tools.DirectoryTree (directoryTreeToolTyped, DirectoryTreeToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+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 (cheapWalkDepth, maxTreeEntries)+import System.Directory+ ( doesDirectoryExist,+ listDirectory,+ )+import System.FilePath ((</>))++newtype DirectoryTreeToolArgs = DirectoryTreeToolArgs+ { _dtPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec DirectoryTreeToolArgs)++instance AC.HasCodec DirectoryTreeToolArgs where+ codec :: AC.JSONCodec DirectoryTreeToolArgs+ codec =+ AC.object "show a directory tree and its subdirectories" $+ DirectoryTreeToolArgs <$> AC.requiredField "path" "Relative directory path to show the tree of" AC..= (._dtPath)++directoryTreeToolTyped :: FsConfig -> TypedTool ctx DirectoryTreeToolArgs+directoryTreeToolTyped fsConfig =+ TypedTool+ { ttoolName = "directory_tree",+ ttoolDescription =+ "Show the directory tree (and its subdirectories) of a directory (relative to the workspace). "+ <> "Returns the directory tree as a string. "+ <> "Use path '.' or omit it to list the workspace root. "+ <> "Traversal is capped at depth "+ <> T.pack (show cheapWalkDepth)+ <> " and "+ <> T.pack (show maxTreeEntries)+ <> " entries; truncation is reported in the header.",+ ttoolReadonly = True,+ ttoolExecute = const (directoryTreeExecTyped fsConfig)+ }++directoryTreeExecTyped :: FsConfig -> DirectoryTreeToolArgs -> IO Text+directoryTreeExecTyped cfg args = do+ let relPath = T.unpack args._dtPath+ resolved <- sandboxPath cfg relPath+ let displayRoot = if null relPath then "." else relPath+ drawTree resolved displayRoot++-- | Result of a (sub)tree walk: rendered lines, total entries consumed+-- so far (against the global cap), and whether the global caps cut+-- the walk short.+data WalkState = WalkState+ { wsLines :: [Text],+ wsEntries :: Int,+ wsTruncated :: Bool,+ wsDepthCut :: Bool+ }++drawTree :: FilePath -> FilePath -> IO Text+drawTree path displayRoot = do+ let rootName = T.pack displayRoot+ result <- walkDir "" 0 0 path+ let header = renderHeader result.wsEntries result.wsTruncated result.wsDepthCut+ pure $ T.unlines (header ++ rootName : result.wsLines)+ where+ renderHeader n trunc depthCut =+ let notes =+ ([T.pack ("truncated at " ++ show maxTreeEntries ++ " entries") | trunc])+ ++ ([T.pack ("depth cut at " ++ show cheapWalkDepth) | depthCut])+ in ( [ "=== directory_tree | "+ <> T.pack (show n)+ <> " entr"+ <> (if n == 1 then "y" else "ies")+ <> " | "+ <> T.intercalate ", " notes+ <> " ==="+ | not (null notes)+ ]+ )++-- | Walk a directory non-recursively in the outer caller's sense:+-- emits lines for visible children, recursing into subdirectories until+-- either depth or entry caps are hit. Both caps are global to the whole+-- walk (entries is a running total across siblings).+walkDir :: Text -> Int -> Int -> FilePath -> IO WalkState+walkDir prefix depth entriesSoFar path+ | depth > cheapWalkDepth =+ pure (WalkState [] entriesSoFar False True)+ | entriesSoFar >= maxTreeEntries =+ pure (WalkState [] entriesSoFar True False)+ | otherwise = do+ isLink <- isSymlink path+ isDir <- doesDirectoryExist path+ if not (isDir && not isLink)+ then pure (WalkState [] entriesSoFar False False)+ else do+ contents <- listDirectory path+ let validContents =+ filter (\n -> n `notElem` [".", ".."] && not (isFileHidden n)) contents+ count = length validContents+ stepChildren prefix depth entriesSoFar path (zip [1 .. count] validContents) count++stepChildren ::+ Text ->+ Int ->+ Int ->+ FilePath ->+ [(Int, FilePath)] ->+ Int ->+ IO WalkState+stepChildren _ _ entries _ [] _ =+ pure (WalkState [] entries False False)+stepChildren prefix depth entries dir ((idx, name) : rest) count+ | entries >= maxTreeEntries =+ pure (WalkState [] entries True False)+ | otherwise = do+ let isLast = idx == count+ textName = T.pack name+ connector = if isLast then "└── " else "├── "+ currentLine = prefix <> connector <> textName+ newPrefix = prefix <> if isLast then " " else "│ "+ entries' = entries + 1+ sub <- walkDir newPrefix (depth + 1) entries' (dir </> name)+ siblings <- stepChildren prefix depth sub.wsEntries dir rest count+ pure+ WalkState+ { wsLines = currentLine : sub.wsLines ++ siblings.wsLines,+ wsEntries = siblings.wsEntries,+ wsTruncated = sub.wsTruncated || siblings.wsTruncated,+ wsDepthCut = sub.wsDepthCut || siblings.wsDepthCut+ }
+ src/LLM/Tools/FileInfo.hs view
@@ -0,0 +1,240 @@+module LLM.Tools.FileInfo+ ( fileInfoToolTyped,+ FileInfoToolArgs (..),+ )+where++import Autodocodec qualified as AC+import Control.Exception (IOException, try)+import Data.Aeson (FromJSON)+import Data.ByteString qualified as BS+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import Data.Time.Clock (UTCTime)+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import System.Directory+ ( Permissions (..),+ doesDirectoryExist,+ doesFileExist,+ doesPathExist,+ getFileSize,+ getModificationTime,+ getPermissions,+ listDirectory,+ pathIsSymbolicLink,+ )+import System.IO (IOMode (ReadMode), withBinaryFile)++-- | Number of leading bytes inspected when sniffing for binary content.+binarySniffBytes :: Int+binarySniffBytes = 8192++-- | 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+-- tool stays cheap regardless of input.+maxLineCountBytes :: Integer+maxLineCountBytes = 5 * 1024 * 1024 -- 5 MB++-- | Cap on directory entry counts in the summary, so listing a huge+-- directory doesn't itself burn the context window.+maxDirEntriesCounted :: Int+maxDirEntriesCounted = 10000++newtype FileInfoToolArgs = FileInfoToolArgs+ { _fiPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec FileInfoToolArgs)++instance AC.HasCodec FileInfoToolArgs where+ codec :: AC.JSONCodec FileInfoToolArgs+ codec =+ AC.object "get metadata about a file or directory" $+ FileInfoToolArgs+ <$> AC.requiredField "path" "Relative path to inspect"+ AC..= (._fiPath)++fileInfoToolTyped :: FsConfig -> TypedTool ctx FileInfoToolArgs+fileInfoToolTyped cfg =+ TypedTool+ { ttoolName = "file_info",+ ttoolDescription =+ "Get metadata about a file or directory at a workspace-relative path. "+ <> "For files: kind (text/binary), size in bytes, line count (text files up to 5 MB), "+ <> "permissions, modification time, and whether it is a symbolic link. "+ <> "For directories: entry count (visible vs. total), permissions, modification time. "+ <> "Reports clearly if the path does not exist. "+ <> "Use this before read_file_paginated to decide whether a file is worth reading.",+ ttoolReadonly = True,+ ttoolExecute = const (execute cfg)+ }++execute :: FsConfig -> FileInfoToolArgs -> IO Text+execute cfg args = do+ let rel = args._fiPath+ resolved <- sandboxPath cfg (T.unpack rel)+ exists <- doesPathExist resolved+ if not exists+ then pure $ "Error: path does not exist: " <> rel+ else do+ isDir <- doesDirectoryExist resolved+ isFile <- doesFileExist resolved+ isLink <- safePathIsSymbolicLink resolved+ perms <- safeGetPermissions resolved+ mtime <- safeGetModificationTime resolved+ case (isDir, isFile) of+ (True, _) -> renderDirInfo rel resolved isLink perms mtime+ (_, True) -> renderFileInfo rel resolved isLink perms mtime+ _ -> pure $ "Error: path is neither a regular file nor a directory: " <> rel++-- ---------------------------------------------------------------------------+-- File rendering+-- ---------------------------------------------------------------------------++renderFileInfo ::+ Text ->+ FilePath ->+ Bool ->+ Maybe Permissions ->+ Maybe Text ->+ 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+ _ -> pure Nothing+ let header =+ "=== "+ <> rel+ <> " | file"+ <> (if isLink then " (symlink)" else "")+ <> " ==="+ lns =+ [ "kind: " <> if isBin then "binary" else "text",+ "size: " <> maybe "unknown" (\n -> T.pack (show n) <> " bytes") size,+ "lines: "+ <> case (isBin, lineCount, size) of+ (True, _, _) -> "n/a (binary)"+ (False, Just n, _) -> T.pack (show n)+ (False, Nothing, Just n)+ | n > maxLineCountBytes ->+ "unknown (file larger than " <> T.pack (show maxLineCountBytes) <> " bytes)"+ _ -> "unknown",+ permsLine perms,+ "modified: " <> fromMaybeText "unknown" mtime+ ]+ pure $ T.unlines (header : lns)++-- ---------------------------------------------------------------------------+-- Directory rendering+-- ---------------------------------------------------------------------------++renderDirInfo ::+ Text ->+ FilePath ->+ Bool ->+ Maybe Permissions ->+ Maybe Text ->+ IO Text+renderDirInfo rel resolved isLink perms mtime = do+ entries <- safeListDirectory resolved+ let total = length entries+ visible = length (filter (not . isHidden) entries)+ countText n+ | n >= maxDirEntriesCounted = T.pack (show maxDirEntriesCounted) <> "+"+ | otherwise = T.pack (show n)+ header =+ "=== "+ <> rel+ <> " | directory"+ <> (if isLink then " (symlink)" else "")+ <> " ==="+ lns =+ [ "entries (visible): " <> countText visible,+ "entries (total): " <> countText total,+ permsLine perms,+ "modified: " <> fromMaybeText "unknown" mtime+ ]+ pure $ T.unlines (header : lns)++isHidden :: FilePath -> Bool+isHidden ('.' : _) = True+isHidden _ = False++permsLine :: Maybe Permissions -> Text+permsLine Nothing = "permissions: unknown"+permsLine (Just p) =+ let bit b c = if b then T.singleton c else "-"+ in "permissions: "+ <> bit (readable p) 'r'+ <> bit (writable p) 'w'+ <> bit (executable p) 'x'+ <> (if searchable p then " (searchable)" else "")++fromMaybeText :: Text -> Maybe Text -> Text+fromMaybeText d Nothing = d+fromMaybeText _ (Just t) = t++-- ---------------------------------------------------------------------------+-- Safe IO wrappers+-- ---------------------------------------------------------------------------++safeGetFileSize :: FilePath -> IO (Maybe Integer)+safeGetFileSize p = do+ r <- try (getFileSize p) :: IO (Either IOException Integer)+ pure (eitherToMaybe r)++safeGetModificationTime :: FilePath -> IO (Maybe Text)+safeGetModificationTime p = do+ r <- try (getModificationTime p) :: IO (Either IOException UTCTime)+ pure $ case r of+ Right t -> Just (T.pack (show t))+ Left _ -> Nothing++safeGetPermissions :: FilePath -> IO (Maybe Permissions)+safeGetPermissions p = do+ r <- try (getPermissions p) :: IO (Either IOException Permissions)+ pure (eitherToMaybe r)++safePathIsSymbolicLink :: FilePath -> IO Bool+safePathIsSymbolicLink p = do+ r <- try (pathIsSymbolicLink p) :: IO (Either IOException Bool)+ pure $ case r of+ Right b -> b+ Left _ -> False++safeListDirectory :: FilePath -> IO [FilePath]+safeListDirectory p = do+ r <- try (listDirectory p) :: IO (Either IOException [FilePath])+ pure $ case r of+ Right xs -> xs+ Left _ -> []++safeLineCount :: FilePath -> IO (Maybe Int)+safeLineCount p = do+ r <- try (TIO.readFile p) :: IO (Either IOException Text)+ pure $ case r of+ Right content -> Just (length (T.lines content))+ Left _ -> Nothing++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
+ src/LLM/Tools/FindFiles.hs view
@@ -0,0 +1,242 @@+module LLM.Tools.FindFiles+ ( findFilesToolTyped,+ FindFilesToolArgs (..),+ )+where++import Autodocodec qualified as AC+import Control.Exception (IOException, try)+import Data.Aeson (FromJSON)+import Data.List (sort)+import Data.Maybe (fromMaybe)+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 (cheapWalkDepth)+import System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath ((</>))++-- | Default cap on returned paths.+defaultMaxResults :: Int+defaultMaxResults = 200++-- | Hard cap to protect the model's context window.+maxResultsCap :: Int+maxResultsCap = 2000++-- | Maximum directory depth from the search root. Sourced from+-- 'LLM.Tools.FsLimits.cheapWalkDepth' because @find_files@ only stats+-- entries, so it can afford a deeper walk than @grep@.+maxDepth :: Int+maxDepth = cheapWalkDepth++-- | What kind of filesystem entries to return.+data EntryFilter = AnyEntry | FileOnly | DirectoryOnly+ deriving (Eq, Show)++parseEntryFilter :: Text -> EntryFilter+parseEntryFilter t = case T.toLower (T.strip t) of+ "file" -> FileOnly+ "directory" -> DirectoryOnly+ "dir" -> DirectoryOnly+ _ -> AnyEntry++data FindFilesToolArgs = FindFilesToolArgs+ { _ffPattern :: Text,+ _ffPath :: Text,+ _ffType :: Text,+ _ffIncludeHidden :: Bool,+ _ffMaxResults :: Int+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec FindFilesToolArgs)++instance AC.HasCodec FindFilesToolArgs where+ codec :: AC.JSONCodec FindFilesToolArgs+ codec =+ AC.object "find files by glob pattern" $+ FindFilesToolArgs+ <$> AC.requiredField+ "pattern"+ "Glob pattern matched against paths relative to 'path'. Supports '**' (any number of path segments, including zero), '*' (any chars except '/'), and '?' (any single char except '/'). Examples: '**/*.hs', 'src/**/Tools/*.hs', '*.cabal'."+ AC..= (._ffPattern)+ <*> AC.optionalFieldWithDefault+ "path"+ "."+ "Relative directory to search under (default '.')"+ AC..= (._ffPath)+ <*> AC.optionalFieldWithDefault+ "type"+ "any"+ "Entry kind to return: 'file', 'directory', or 'any' (default 'any')"+ AC..= (._ffType)+ <*> AC.optionalFieldWithDefault+ "includeHidden"+ False+ "Include dotfiles and dot-directories (default false)"+ AC..= (._ffIncludeHidden)+ <*> AC.optionalFieldWithDefault+ "maxResults"+ defaultMaxResults+ "Maximum number of paths to return (default 200, hard cap 2000)"+ AC..= (._ffMaxResults)++findFilesToolTyped :: FsConfig -> TypedTool ctx FindFilesToolArgs+findFilesToolTyped cfg =+ TypedTool+ { ttoolName = "find_files",+ ttoolDescription =+ "Find files and directories by glob pattern under a workspace-relative root. "+ <> "Supports '**' (any number of path segments, including zero), '*' (any chars except '/'), and '?'. "+ <> "Returns one path per line, relative to the search root, sorted. "+ <> "Skips hidden entries unless 'includeHidden' is true. "+ <> "Use 'type' to restrict to files or directories. "+ <> "Output is capped at 'maxResults' (default 200, hard cap 2000); "+ <> "the header reports whether results were truncated and how many entries were scanned.",+ ttoolReadonly = True,+ ttoolExecute = const (execute cfg)+ }++execute :: FsConfig -> FindFilesToolArgs -> IO Text+execute cfg args = do+ let rel = T.unpack args._ffPath+ pat = args._ffPattern+ kind = parseEntryFilter args._ffType+ includeHidden = args._ffIncludeHidden+ cap = max 1 (min maxResultsCap args._ffMaxResults)+ if T.null pat+ then pure "Error: pattern must be non-empty"+ else do+ resolved <- sandboxPath cfg rel+ isDir <- doesDirectoryExist resolved+ if not isDir+ then pure $ "Error: path is not a directory: " <> args._ffPath+ else do+ let segs = splitGlob pat+ (matches, scanned, truncated) <- walk resolved includeHidden kind segs cap+ pure $ renderResults args._ffPath pat matches scanned truncated++-- ---------------------------------------------------------------------------+-- Filesystem walk+-- ---------------------------------------------------------------------------++-- | Result of the walk: matched relative paths (sorted within each directory),+-- count of entries inspected, and whether the cap truncated the output.+walk ::+ FilePath ->+ Bool ->+ EntryFilter ->+ [Text] ->+ Int ->+ IO ([FilePath], Int, Bool)+walk root includeHidden kind pat cap = go root [] 0 0 [] False+ where+ -- relSegs is the path from root to current dir, in reverse order+ -- depth is current directory depth (0 = root)+ go dir relSegs depth scanned acc truncated+ | length acc >= cap = pure (reverse acc, scanned, True)+ | depth > maxDepth = pure (reverse acc, scanned, truncated)+ | otherwise = do+ entries <- sort <$> safeListDirectory dir+ let visible =+ if includeHidden+ then entries+ else filter (not . isFileHidden) entries+ step visible dir relSegs depth scanned acc truncated++ step [] _ _ _ scanned acc truncated = pure (reverse acc, scanned, truncated)+ step (name : rest) dir relSegs depth scanned acc truncated+ | length acc >= cap = pure (reverse acc, scanned + 1, True)+ | otherwise = do+ let full = dir </> name+ entryRel = reverse (T.pack name : relSegs)+ relPath = T.unpack (T.intercalate "/" entryRel)+ -- Skip symlinks: they could point outside the sandbox.+ isLink <- isSymlink full+ if isLink+ then step rest dir relSegs depth (scanned + 1) acc truncated+ else do+ isDir <- doesDirectoryExist full+ let entryKind = if isDir then DirectoryOnly else FileOnly+ kindOk = case kind of+ AnyEntry -> True+ FileOnly -> entryKind == FileOnly+ DirectoryOnly -> entryKind == DirectoryOnly+ matched = kindOk && matchGlob pat entryRel+ acc' = if matched then relPath : acc else acc+ (descendAcc, descendScanned, descendTrunc) <-+ if isDir+ then go full (T.pack name : relSegs) (depth + 1) (scanned + 1) acc' truncated+ else pure (reverse acc', scanned + 1, truncated)+ step rest dir relSegs depth descendScanned (reverse descendAcc) descendTrunc++safeListDirectory :: FilePath -> IO [FilePath]+safeListDirectory path = do+ r <- try (listDirectory path) :: IO (Either IOException [FilePath])+ case r of+ Right xs -> pure xs+ Left _ -> pure []++-- ---------------------------------------------------------------------------+-- Glob matcher+-- ---------------------------------------------------------------------------++-- | Split a glob into path segments. Leading "./" is dropped so callers+-- can write either "**/*.hs" or "./**/*.hs".+splitGlob :: Text -> [Text]+splitGlob pat =+ let stripped = fromMaybe pat (T.stripPrefix "./" pat)+ in filter (not . T.null) (T.splitOn "/" stripped)++-- | Match a list of glob segments against a list of path segments.+-- '**' may match zero or more path segments; other segments must match+-- exactly one segment via 'matchSegment'.+matchGlob :: [Text] -> [Text] -> Bool+matchGlob [] [] = True+matchGlob [] _ = False+matchGlob ("**" : ps) ss =+ -- '**' matches zero segments, or one+ segments then continues+ matchGlob ps ss+ || case ss of+ [] -> False+ (_ : rest) -> matchGlob ("**" : ps) rest+matchGlob _ [] = False+matchGlob (p : ps) (s : ss) = matchSegment (T.unpack p) (T.unpack s) && matchGlob ps ss++-- | Match a single glob segment (no '/' allowed in either side).+-- Supports '*' (any run of chars, possibly empty) and '?' (one char).+matchSegment :: String -> String -> Bool+matchSegment [] [] = True+matchSegment ('*' : ps) ss =+ -- '*' matches zero or more chars; try each split+ matchSegment ps ss+ || case ss of+ [] -> False+ (_ : rest) -> matchSegment ('*' : ps) rest+matchSegment ('?' : ps) (_ : ss) = matchSegment ps ss+matchSegment (p : ps) (s : ss) = p == s && matchSegment ps ss+matchSegment _ _ = False++-- ---------------------------------------------------------------------------+-- Rendering+-- ---------------------------------------------------------------------------++renderResults :: Text -> Text -> [FilePath] -> Int -> Bool -> Text+renderResults rootDisplay pat matches scanned truncated =+ let header =+ "=== find_files "+ <> T.pack (show pat)+ <> " in "+ <> rootDisplay+ <> " | "+ <> T.pack (show (length matches))+ <> " match(es) across "+ <> T.pack (show scanned)+ <> " entr"+ <> (if scanned == 1 then "y" else "ies")+ <> (if truncated then " | truncated (raise maxResults to see more)" else "")+ <> " ==="+ body = map T.pack matches+ in T.unlines (header : body)
+ src/LLM/Tools/FsConfig.hs view
@@ -0,0 +1,169 @@+module LLM.Tools.FsConfig+ ( FsConfig (..),+ SandboxViolation (..),+ formatSandboxViolation,+ mkFsConfig,+ sandboxPath,+ sandboxWritePath,+ isFileHidden,+ isSymlink,+ )+where++import Control.Exception (Exception, IOException, 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, (</>))++-- | Configuration for file-system tools.+-- 'fsBasePath' must be a canonical absolute path (use 'mkFsConfig').+newtype FsConfig = FsConfig+ { fsBasePath :: FilePath+ }+ deriving (Show)++data SandboxViolation = SandboxViolation+ { svAttempted :: FilePath,+ svBasePath :: FilePath+ }+ deriving (Show)++instance Exception SandboxViolation++-- | Model-facing message for a sandbox escape attempt. Paths are shown+-- relative to the workspace root so host layout is not leaked.+formatSandboxViolation :: SandboxViolation -> Text+formatSandboxViolation (SandboxViolation attempted base) =+ case stripPathPrefix+ (splitDirectories (dropTrailingPathSeparator base))+ (splitDirectories attempted) of+ Just [] -> "Sandbox violation: path is outside the workspace"+ Just relComps ->+ "Sandbox violation: path is outside the workspace: "+ <> T.pack (joinPath relComps)+ Nothing ->+ "Sandbox violation: path is outside the workspace"++-- | Create an 'FsConfig' by canonicalizing the given base directory.+-- The directory must already exist.+mkFsConfig :: FilePath -> IO FsConfig+mkFsConfig dir =+ FsConfig . addTrailingPathSeparator <$> canonicalizePath dir++-- | Resolve a (possibly relative) path against the sandbox base,+-- canonicalize it, and verify it stays within the sandbox.+-- If the path doesn't exist yet (e.g. for writes), the longest+-- existing ancestor is canonicalized (so symlinks in the parent+-- chain are resolved) and the missing tail is appended verbatim.+-- Throws 'SandboxViolation' on escape attempts.+sandboxPath :: FsConfig -> FilePath -> IO FilePath+sandboxPath cfg relPath = do+ let base = cfg.fsBasePath+ candidate = collapseDots (normalise (base </> relPath))+ canonical <- canonicalizeExisting candidate+ let baseComps = splitDirectories (dropTrailingPathSeparator base)+ canonComps = splitDirectories canonical+ case stripPathPrefix baseComps canonComps of+ Nothing -> throwIO (SandboxViolation canonical base)+ Just tailComps -> do+ -- TOCTOU mitigation: the canonical path has symlinks resolved as of+ -- the moment of 'canonicalizeExisting'. Between that check and the+ -- tool's subsequent open, an attacker (or a concurrent process+ -- inside the sandbox) could replace a path component with a symlink+ -- pointing outside. Re-walk the live chain from 'base' to+ -- '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.+ verifyNoSymlinksInChain base (joinPath baseComps) tailComps+ pure canonical++-- | Element-wise path-prefix comparison.+-- Returns the trailing components of @full@ after stripping @prefix@,+-- or 'Nothing' if @prefix@ is not a path-prefix of @full@.+-- Uses 'equalFilePath' so the comparison respects platform conventions+-- (case-insensitive on Windows, trailing-separator-insensitive, etc.).+-- This avoids the @\"\/sandbox\"@ vs @\"\/sandbox2\"@ string-prefix+-- foot-gun of 'Data.List.isPrefixOf'.+stripPathPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]+stripPathPrefix [] ys = Just ys+stripPathPrefix _ [] = Nothing+stripPathPrefix (p : ps) (y : ys)+ | equalFilePath p y = stripPathPrefix ps ys+ | otherwise = Nothing++-- | Walk every path component of @target@ that lies beneath @base@ and+-- throw 'SandboxViolation' if any component is a symbolic link.+-- @baseJoined@ is the canonical base directory (without trailing+-- separator); @tailComps@ are the components below it that must be+-- traversed.+verifyNoSymlinksInChain :: FilePath -> FilePath -> [FilePath] -> IO ()+verifyNoSymlinksInChain base = walk+ where+ walk _ [] = pure ()+ walk acc (c : cs) = do+ let next = acc </> c+ exists <- doesPathExist next+ when exists $ do+ sym <- isSymlink next+ when sym $ throwIO (SandboxViolation next base)+ walk next cs++-- | Canonicalize the longest existing prefix of a path, then append+-- any missing trailing components. This ensures that even when the+-- final target doesn't exist yet, symlinks in the parent chain are+-- resolved before the containment check.+--+-- Uses 'splitFileName' to peel the trailing component instead of a+-- character-level @drop (length parent)@, which is brittle across+-- trailing-separator and platform-separator variations.+canonicalizeExisting :: FilePath -> IO FilePath+canonicalizeExisting path = do+ exists <- doesPathExist path+ if exists+ then canonicalizePath path+ else do+ let (parentRaw, name) = splitFileName path+ parent = dropTrailingPathSeparator parentRaw+ if null name || equalFilePath parent path+ then pure path+ else do+ parentCanon <- canonicalizeExisting parent+ pure (parentCanon </> name)++-- | Like 'sandboxPath', but also creates parent directories+-- inside the sandbox as needed (for write operations).+sandboxWritePath :: FsConfig -> FilePath -> IO FilePath+sandboxWritePath cfg relPath = do+ resolved <- sandboxPath cfg relPath+ createDirectoryIfMissing True (takeDirectory resolved)+ pure resolved++-- | Resolve @.@ and @..@ in a normalized absolute path+-- without touching the filesystem.+collapseDots :: FilePath -> FilePath+collapseDots = joinPath . reverse . foldl' step [] . splitDirectories+ where+ step acc "." = acc+ step (_ : rest) ".." = rest+ step acc ".." = acc -- at root, ignore+ step acc x = x : acc++isFileHidden :: [Char] -> Bool+isFileHidden path = case path of+ ('.' : _) -> True+ _ -> False++-- | 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.+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
+ src/LLM/Tools/FsLimits.hs view
@@ -0,0 +1,138 @@+-- | Shared limits and helpers for filesystem tools.+--+-- Centralizing these constants prevents drift between tools (e.g. one tool+-- having a higher binary-sniff threshold than another) and makes it+-- straightforward to retune the sandbox's resource posture in a single+-- place.+--+-- Two walk depths are exposed deliberately:+--+-- * 'cheapWalkDepth' for traversals that only stat directories+-- (@find_files@, @directory_tree@).+-- * 'expensiveWalkDepth' for traversals that read every encountered file+-- (@grep@). The lower bound bounds the worst-case I/O fan-out.+--+-- Collapsing the two into a single constant would either make @grep@ pay+-- for very deep vendored trees or make @find_files@ miss legitimate+-- matches; keeping both behind named helpers preserves the intent.+module LLM.Tools.FsLimits+ ( cheapWalkDepth,+ expensiveWalkDepth,+ maxReadBytes,+ maxPaginatedFileBytes,+ maxTreeEntries,+ binarySniffBytes,+ detectBinary,+ readBoundedTextFile,+ )+where++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 (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import System.IO (IOMode (ReadMode), hFileSize, withBinaryFile)++-- | Maximum directory depth for traversals that only stat entries.+cheapWalkDepth :: Int+cheapWalkDepth = 20++-- | Maximum directory depth for traversals that read every encountered+-- file (e.g. @grep@). Lower than 'cheapWalkDepth' because the per-dir+-- work is dominated by file I/O rather than @readdir@.+expensiveWalkDepth :: Int+expensiveWalkDepth = 12++-- | Hard cap on the number of bytes a single @readfile@-style tool may+-- materialize into memory. Paginated readers should use their own+-- per-page limits; this is the ceiling for "give me the whole thing"+-- tools that have no pagination story.+maxReadBytes :: Int+maxReadBytes = 1024 * 1024 -- 1 MiB++-- | Maximum source-file size for @read_file_paginated@. Higher than+-- 'maxReadBytes' because pagination exists to walk large files; this cap+-- still bounds worst-case line-skipping work.+maxPaginatedFileBytes :: Integer+maxPaginatedFileBytes = 10 * 1024 * 1024 -- 10 MiB++-- | Hard cap on the number of entries a @directory_tree@-style tool may+-- emit. Output is truncated past this point with a marker in the header.+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).+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++-- | Read a text file up to @cap@ bytes. Refuses binary files, checks size+-- before reading, and performs a bounded read to mitigate TOCTOU growth.+readBoundedTextFile :: FilePath -> Text -> Int -> IO (Either Text Text)+readBoundedTextFile 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 (decodeUtf8With lenientDecode bs))
+ src/LLM/Tools/Grep.hs view
@@ -0,0 +1,290 @@+module LLM.Tools.Grep+ ( grepToolTyped,+ GrepToolArgs (..),+ )+where++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 Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, isFileHidden, isSymlink, sandboxPath)+import LLM.Tools.FsLimits (binarySniffBytes, expensiveWalkDepth)+import System.Directory+ ( doesDirectoryExist,+ doesFileExist,+ getFileSize,+ listDirectory,+ )+import System.FilePath (takeExtension, takeFileName, (</>))+import System.IO+ ( IOMode (ReadMode),+ withBinaryFile,+ )++-- | Default cap on the number of match lines returned.+defaultMaxResults :: Int+defaultMaxResults = 50++-- | Hard cap on results to protect the model's context window.+maxResultsCap :: Int+maxResultsCap = 500++-- | Skip files larger than this (bytes). Big files are usually generated+-- artifacts (lock files, fixtures) that aren't useful to grep through.+maxFileSizeBytes :: Integer+maxFileSizeBytes = 1024 * 1024 -- 1 MB++-- | Maximum directory depth from the search root. Sourced from+-- 'LLM.Tools.FsLimits.expensiveWalkDepth' because @grep@ reads every+-- encountered file.+maxDepth :: Int+maxDepth = expensiveWalkDepth++-- | Truncate matched line text in output to keep results compact.+maxLineLength :: Int+maxLineLength = 240++data GrepToolArgs = GrepToolArgs+ { _grepPattern :: Text,+ _grepPath :: Text,+ _grepCaseInsensitive :: Bool,+ _grepExtensions :: [Text],+ _grepMaxResults :: Int+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec GrepToolArgs)++instance AC.HasCodec GrepToolArgs where+ codec :: AC.JSONCodec GrepToolArgs+ codec =+ AC.object "search files for a literal substring" $+ GrepToolArgs+ <$> AC.requiredField "pattern" "Literal substring to search for (not a regex)"+ AC..= (._grepPattern)+ <*> AC.optionalFieldWithDefault+ "path"+ "."+ "Relative directory or file to search under (default '.')"+ AC..= (._grepPath)+ <*> AC.optionalFieldWithDefault+ "caseInsensitive"+ False+ "Match case-insensitively (default false)"+ AC..= (._grepCaseInsensitive)+ <*> AC.optionalFieldWithDefault+ "extensions"+ []+ "Restrict to files with these extensions, without the dot, e.g. [\"hs\", \"cabal\"]. Empty means all text files."+ AC..= (._grepExtensions)+ <*> AC.optionalFieldWithDefault+ "maxResults"+ defaultMaxResults+ "Maximum number of match lines to return (default 50, hard cap 500)"+ AC..= (._grepMaxResults)++grepToolTyped :: FsConfig -> TypedTool ctx GrepToolArgs+grepToolTyped cfg =+ TypedTool+ { ttoolName = "grep",+ ttoolDescription =+ "Recursively search files for a literal substring (not a regex). "+ <> "Returns matches as 'relative/path:line: snippet', sorted by file. "+ <> "Skips hidden files, binary files, and files larger than 1 MB. "+ <> "Use 'extensions' to restrict by file type (e.g. [\"hs\"]). "+ <> "Output is capped at 'maxResults' lines (default 50, hard cap 500); "+ <> "the header reports whether results were truncated and how many files were scanned.",+ ttoolReadonly = True,+ ttoolExecute = const (execute cfg)+ }++execute :: FsConfig -> GrepToolArgs -> IO Text+execute cfg args = do+ let rel = T.unpack args._grepPath+ pat = args._grepPattern+ ci = args._grepCaseInsensitive+ exts = normalizeExtensions args._grepExtensions+ cap = max 1 (min maxResultsCap args._grepMaxResults)+ if T.null pat+ then pure "Error: pattern must be non-empty"+ else do+ resolved <- sandboxPath cfg rel+ isDir <- doesDirectoryExist resolved+ isFile <- doesFileExist resolved+ if not (isDir || isFile)+ then pure $ "Error: path does not exist: " <> args._grepPath+ else do+ files <-+ if isFile+ then pure [resolved]+ else collectFiles resolved 0 exts+ (matches, scanned, truncated) <- searchFiles resolved files pat ci cap+ pure $ renderResults args._grepPath pat matches scanned truncated++-- | Lowercase and strip leading dots so callers can pass "hs" or ".hs".+normalizeExtensions :: [Text] -> [Text]+normalizeExtensions = map (T.toLower . T.dropWhile (== '.'))++-- | Recursively collect candidate files under a directory, respecting+-- depth, hidden-file, extension, and size limits. Order is stable+-- (directories sorted) so output is deterministic.+collectFiles :: FilePath -> Int -> [Text] -> IO [FilePath]+collectFiles _ depth _ | depth > maxDepth = pure []+collectFiles dir depth exts = do+ entries <- sort <$> safeListDirectory dir+ let visible = filter (not . isFileHidden) entries+ results <- mapM (visit dir depth exts) visible+ pure (concat results)++visit :: FilePath -> Int -> [Text] -> FilePath -> IO [FilePath]+visit parent depth exts name = do+ let full = parent </> name+ -- Skip symlinks to prevent traversal out of the sandbox.+ isLink <- isSymlink full+ if isLink+ then pure []+ else do+ isDir <- doesDirectoryExist full+ if isDir+ then collectFiles full (depth + 1) exts+ else do+ isFile <- doesFileExist full+ if isFile && extensionAllowed exts name+ then do+ ok <- isSizeOk full+ pure [full | ok]+ else pure []++extensionAllowed :: [Text] -> FilePath -> Bool+extensionAllowed [] _ = True+extensionAllowed exts name =+ let ext = T.toLower (T.pack (dropDot (takeExtension name)))+ in ext `elem` exts+ where+ dropDot ('.' : rest) = rest+ dropDot s = s++isSizeOk :: FilePath -> IO Bool+isSizeOk path = do+ r <- try (getFileSize path) :: IO (Either IOException Integer)+ case r of+ Right sz -> pure (sz <= maxFileSizeBytes)+ Left _ -> pure False++safeListDirectory :: FilePath -> IO [FilePath]+safeListDirectory path = do+ r <- try (listDirectory path) :: IO (Either IOException [FilePath])+ case r of+ Right xs -> pure xs+ Left _ -> pure []++-- | Search the given files for a literal pattern. Stops collecting matches+-- once the cap is reached but keeps scanning the remaining files so the+-- 'scanned' count reflects the full sweep. Returns (matches, files scanned,+-- truncated?).+searchFiles ::+ FilePath ->+ [FilePath] ->+ Text ->+ Bool ->+ Int ->+ IO ([Match], Int, Bool)+searchFiles root 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+ | 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 (TIO.readFile 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'++data Match = Match+ { mPath :: FilePath,+ mLine :: Int,+ mText :: Text+ }++matchLines :: FilePath -> Text -> Text -> Bool -> [Match]+matchLines path content needle ci =+ [ Match path n (truncateLine line)+ | (n, line) <- zip [1 ..] (T.lines content),+ let hay = if ci then T.toLower line else line,+ needle `T.isInfixOf` hay+ ]++truncateLine :: Text -> Text+truncateLine t+ | 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 =+ "=== grep "+ <> T.pack (show pat)+ <> " in "+ <> rootDisplay+ <> " | "+ <> T.pack (show (length matches))+ <> " match(es) across "+ <> T.pack (show scanned)+ <> " file(s)"+ <> (if truncated then " | truncated (raise maxResults to see more)" else "")+ <> " ==="+ body = map fmtMatch matches+ in T.unlines (header : body)+ where+ fmtMatch m =+ T.pack m.mPath+ <> ":"+ <> 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
+ src/LLM/Tools/MoveFile.hs view
@@ -0,0 +1,61 @@+module LLM.Tools.MoveFile (moveFileToolTyped, MoveFileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, isSymlink, sandboxPath, sandboxWritePath)+import System.Directory (doesDirectoryExist, doesFileExist, doesPathExist, renameFile)++data MoveFileToolArgs = MoveFileToolArgs+ { _mfSrc :: Text,+ _mfDst :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec MoveFileToolArgs)++instance AC.HasCodec MoveFileToolArgs where+ codec =+ AC.object "move source to destination" $+ MoveFileToolArgs+ <$> AC.requiredField "source" "Relative path of the file to move" AC..= (._mfSrc)+ <*> AC.requiredField "destination" "Relative destination path (including filename)" AC..= (._mfDst)++moveFileToolTyped :: FsConfig -> TypedTool ctx MoveFileToolArgs+moveFileToolTyped cfg =+ TypedTool+ { ttoolName = "move_file",+ ttoolDescription =+ "Move (rename) a file from source to destination (both paths relative to the workspace). "+ <> "Creates parent directories at the destination as needed.",+ ttoolReadonly = False,+ ttoolExecute = const (moveFileExecTyped cfg)+ }++moveFileExecTyped :: FsConfig -> MoveFileToolArgs -> IO Text+moveFileExecTyped cfg args = do+ let src = args._mfSrc+ dst = args._mfDst+ srcResolved <- sandboxPath cfg (T.unpack src)+ -- Refuse to operate on symbolic-link sources: this would either move+ -- the link itself (surprising) or, after `sandboxPath` resolution,+ -- potentially target a file outside the sandbox.+ srcIsLink <- isSymlink srcResolved+ if srcIsLink+ then pure $ "Error: refusing to move symbolic link source: " <> src+ else do+ srcExists <- doesPathExist srcResolved+ if not srcExists+ then pure $ "Error: source does not exist: " <> src+ else do+ srcIsFile <- doesFileExist srcResolved+ srcIsDir <- doesDirectoryExist srcResolved+ case (srcIsFile, srcIsDir) of+ (False, True) -> pure $ "Error: source is a directory, not a regular file: " <> src+ (False, False) -> pure $ "Error: source is not a regular file: " <> src+ _ -> do+ dstResolved <- sandboxWritePath cfg (T.unpack dst)+ renameFile srcResolved dstResolved+ pure $ "Successfully moved " <> src <> " to " <> dst
+ src/LLM/Tools/MultiReplaceInFile.hs view
@@ -0,0 +1,104 @@+module LLM.Tools.MultiReplaceInFile (multiReplaceInFileToolTyped, MultiReplaceInFileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsLimits (maxReadBytes, readBoundedTextFile)++data Replacement = Replacement+ { _repOld :: Text,+ _repNew :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec Replacement)++instance AC.HasCodec Replacement where+ codec :: AC.JSONCodec Replacement+ codec =+ AC.object "Replacement" $+ Replacement+ <$> AC.requiredField "old" "The text content to be replaced" AC..= (._repOld)+ <*> AC.requiredField "new" "The replacement text content" AC..= (._repNew)++data MultiReplaceInFileToolArgs = MultiReplaceInFileToolArgs+ { _mrifPath :: Text,+ _mrifReplacements :: [Replacement]+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec MultiReplaceInFileToolArgs)++instance AC.HasCodec MultiReplaceInFileToolArgs where+ codec :: AC.JSONCodec MultiReplaceInFileToolArgs+ codec =+ AC.object "apply multiple replacements to a file" $+ MultiReplaceInFileToolArgs+ <$> AC.requiredField "path" "Relative file path to edit" AC..= (._mrifPath)+ <*> AC.requiredField "replacements" "List of replacements to apply in order" AC..= (._mrifReplacements)++multiReplaceInFileToolTyped :: FsConfig -> TypedTool ctx MultiReplaceInFileToolArgs+multiReplaceInFileToolTyped cfg =+ TypedTool+ { ttoolName = "multi_replace_in_file",+ ttoolDescription =+ "Apply multiple text replacements to a file in order. "+ <> "Each 'old' string must appear exactly once in the file at the time it is applied. "+ <> "Returns an error if any string is not found or appears more than once. "+ <> "Files larger than "+ <> T.pack (show maxReadBytes)+ <> " bytes are refused.",+ ttoolReadonly = False,+ ttoolExecute = const (replaceExecTyped cfg)+ }++replaceExecTyped :: FsConfig -> MultiReplaceInFileToolArgs -> IO Text+replaceExecTyped cfg args = do+ let MultiReplaceInFileToolArgs {_mrifPath, _mrifReplacements} = args+ resolved <- sandboxPath cfg (T.unpack _mrifPath)+ contentE <- readBoundedTextFile resolved _mrifPath maxReadBytes+ case contentE of+ Left err -> pure $ "Error: " <> err+ Right content -> case applyReplacements _mrifReplacements content of+ Left err -> pure err+ Right result -> do+ TIO.writeFile resolved result+ pure $+ "Successfully applied "+ <> T.pack (show (length _mrifReplacements))+ <> " replacement(s) in "+ <> _mrifPath++-- | Apply a list of replacements sequentially, failing on the first error.+applyReplacements :: [Replacement] -> Text -> Either Text Text+applyReplacements [] content = Right content+applyReplacements (Replacement {_repOld, _repNew} : rest) content =+ case countOccurrences _repOld content of+ 0 -> Left $ "Error: 'old' string not found in file: " <> _repOld+ 1 -> applyReplacements rest (replaceFirst _repOld _repNew content)+ n ->+ Left $+ "Error: 'old' string found "+ <> T.pack (show n)+ <> " times (must appear exactly once): "+ <> _repOld++-- | Count non-overlapping occurrences of needle in haystack.+countOccurrences :: Text -> Text -> Int+countOccurrences needle haystack+ | T.null needle = 0+ | otherwise = go 0 haystack+ where+ go !n hay = case T.breakOn needle hay of+ (_, rest)+ | T.null rest -> n+ | otherwise -> go (n + 1) (T.drop (T.length needle) rest)++-- | Replace the first occurrence of needle with replacement.+replaceFirst :: Text -> Text -> Text -> Text+replaceFirst needle replacement haystack =+ let (before, after) = T.breakOn needle haystack+ in before <> replacement <> T.drop (T.length needle) after
+ src/LLM/Tools/ReadFilePaginated.hs view
@@ -0,0 +1,172 @@+module LLM.Tools.ReadFilePaginated+ ( readFilePaginatedToolTyped,+ ReadFilePaginatedArgs (..),+ )+where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsLimits (detectBinary, maxPaginatedFileBytes)+import System.IO+ ( Handle,+ IOMode (ReadMode),+ hFileSize,+ hIsEOF,+ hSetEncoding,+ utf8,+ withBinaryFile,+ withFile,+ )++-- | Default number of lines returned per page when the caller omits 'limit'.+defaultLimit :: Int+defaultLimit = 200++-- | Hard cap on the number of lines returned per page, to protect the+-- model's context window from runaway responses on pathological inputs.+maxLimit :: Int+maxLimit = 2000++data ReadFilePaginatedArgs = ReadFilePaginatedArgs+ { _rfpPath :: Text,+ _rfpOffset :: Int,+ _rfpLimit :: Int+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec ReadFilePaginatedArgs)++instance AC.HasCodec ReadFilePaginatedArgs where+ codec =+ AC.object "read a page of a text file" $+ ReadFilePaginatedArgs+ <$> AC.requiredField "path" "Relative file path to read"+ AC..= (._rfpPath)+ <*> AC.optionalFieldWithDefault+ "offset"+ 1+ "1-based line number to start reading from (default 1)"+ AC..= (._rfpOffset)+ <*> AC.optionalFieldWithDefault+ "limit"+ defaultLimit+ "Maximum number of lines to return in this page (default 200, hard cap 2000)"+ AC..= (._rfpLimit)++readFilePaginatedToolTyped :: FsConfig -> TypedTool ctx ReadFilePaginatedArgs+readFilePaginatedToolTyped cfg =+ TypedTool+ { ttoolName = "read_file_paginated",+ ttoolDescription =+ "Read a slice of a text file by line range (path relative to the workspace). "+ <> "Use 'offset' (1-based line number, default 1) and 'limit' (default 200, max 2000) "+ <> "to walk through large files one page at a time. Source files larger than "+ <> T.pack (show maxPaginatedFileBytes)+ <> " bytes are refused. The response header reports the "+ <> "file's byte size, the line range returned, and whether more lines remain along "+ <> "with the next offset to use. The tool is stateless: pass the next offset on the "+ <> "following call. Binary files are refused.",+ ttoolReadonly = True,+ ttoolExecute = const (execute cfg)+ }++execute :: FsConfig -> ReadFilePaginatedArgs -> IO Text+execute cfg args = do+ let rel = T.unpack args._rfpPath+ offset = max 1 args._rfpOffset+ limit = max 1 (min maxLimit args._rfpLimit)+ resolved <- sandboxPath cfg rel+ 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++-- | Skip @offset - 1@ lines, take up to @limit@ lines, then probe one+-- past the last returned line to determine whether more content remains.+-- Reads strictly within 'withFile' so the handle is released eagerly.+readPage :: FilePath -> Int -> Int -> IO ([Text], Bool)+readPage path offset limit = withFile path ReadMode $ \h -> do+ hSetEncoding h utf8+ skipLines h (offset - 1)+ collected <- takeLines h limit+ more <- not <$> hIsEOF h+ pure (collected, more)++skipLines :: Handle -> Int -> IO ()+skipLines _ 0 = pure ()+skipLines h n = do+ eof <- hIsEOF h+ if eof+ then pure ()+ else do+ _ <- TIO.hGetLine h+ skipLines h (n - 1)++takeLines :: Handle -> Int -> IO [Text]+takeLines h n0 = go n0 id+ where+ go 0 acc = pure (acc [])+ go k acc = do+ eof <- hIsEOF h+ if eof+ then pure (acc [])+ else do+ line <- TIO.hGetLine h+ go (k - 1) (acc . (line :))++renderPage :: Text -> Integer -> Int -> [Text] -> Bool -> Text+renderPage path size offset lns hasMore =+ let count = length lns+ lastNo = offset + count - 1+ rangePart =+ if count == 0+ then "no lines at offset " <> T.pack (show offset)+ else "lines " <> T.pack (show offset) <> "-" <> T.pack (show lastNo)+ tailPart =+ if hasMore+ then "more (next offset: " <> T.pack (show (lastNo + 1)) <> ")"+ else "end of file"+ header =+ "=== "+ <> path+ <> " | "+ <> rangePart+ <> " | "+ <> T.pack (show size)+ <> " bytes | "+ <> tailPart+ <> " ==="+ numbered = zipWith fmtLine [offset ..] lns+ in T.unlines (header : numbered)++-- | Right-align the line number in a 6-char gutter for readability and+-- so the model can reliably reference specific lines back to other tools.+fmtLine :: Int -> Text -> Text+fmtLine n line =+ let s = T.pack (show n)+ pad = T.replicate (max 0 (6 - T.length s)) " "+ in pad <> s <> "| " <> line+
+ src/LLM/Tools/Readdir.hs view
@@ -0,0 +1,61 @@+module LLM.Tools.Readdir (readdirToolTyped, ReaddirToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+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 System.Directory (doesDirectoryExist, listDirectory)+import System.FilePath ((</>))++newtype ReaddirToolArgs = ReaddirToolArgs+ { _rdPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec ReaddirToolArgs)++instance AC.HasCodec ReaddirToolArgs where+ codec :: AC.JSONCodec ReaddirToolArgs+ codec =+ AC.object "list a directory" $+ ReaddirToolArgs <$> AC.requiredField "path" "Relative directory path to list" AC..= (._rdPath)++readdirToolTyped :: FsConfig -> TypedTool ctx ReaddirToolArgs+readdirToolTyped fsConfig =+ TypedTool+ { ttoolName = "readdir",+ ttoolDescription =+ "List the contents of a directory (relative to the workspace). "+ <> "Returns one entry per line. Directories are suffixed with '/', "+ <> "symbolic links with '@' (links are not followed). "+ <> "Use path '.' to list the workspace root.",+ ttoolReadonly = True,+ ttoolExecute = const (readdirExecTyped fsConfig)+ }++readdirExecTyped :: FsConfig -> ReaddirToolArgs -> IO Text+readdirExecTyped cfg args = do+ let relPath = T.unpack args._rdPath+ resolved <- sandboxPath cfg relPath+ entries <- sort <$> listDirectory resolved+ annotated <- mapM (annotateEntry resolved) $ filter (not . isFileHidden) entries+ pure $ T.intercalate "\n" annotated++-- | Annotate a directory entry without following symlinks.+-- Symbolic links are tagged with '@' and never treated as directories,+-- even if they happen to point at one (possibly outside the sandbox).+annotateEntry :: FilePath -> FilePath -> IO Text+annotateEntry parent name = do+ let full = parent </> name+ link <- isSymlink full+ if link+ then pure $ T.pack name <> "@"+ else do+ isDir <- doesDirectoryExist full+ pure $+ if isDir+ then T.pack name <> "/"+ else T.pack name
+ src/LLM/Tools/Readfile.hs view
@@ -0,0 +1,44 @@+module LLM.Tools.Readfile (readfileToolTyped, ReadfileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsLimits (maxReadBytes, readBoundedTextFile)++newtype ReadfileToolArgs = ReadfileToolArgs+ { _rfPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec ReadfileToolArgs)++instance AC.HasCodec ReadfileToolArgs where+ codec =+ AC.object "read a file" $+ ReadfileToolArgs <$> AC.requiredField "path" "Relative file path to read" AC..= (._rfPath)++readfileToolTyped :: FsConfig -> TypedTool ctx ReadfileToolArgs+readfileToolTyped cfg =+ TypedTool+ { ttoolName = "readfile",+ ttoolDescription =+ "Read the contents of a text file at the given path (relative to the workspace). "+ <> "Returns the full file content as text. Binary files are refused. "+ <> "Files larger than "+ <> T.pack (show maxReadBytes)+ <> " bytes are refused; use read_file_paginated instead.",+ ttoolReadonly = True,+ ttoolExecute = const (readfileExecTyped cfg)+ }++readfileExecTyped :: FsConfig -> ReadfileToolArgs -> IO Text+readfileExecTyped cfg args = do+ let p = args._rfPath+ resolved <- sandboxPath cfg (T.unpack p)+ result <- readBoundedTextFile resolved p maxReadBytes+ pure $ case result of+ Left err -> "Error: " <> err+ Right content -> content
+ src/LLM/Tools/RemoveDirectory.hs view
@@ -0,0 +1,76 @@+module LLM.Tools.RemoveDirectory (removeDirectoryToolTyped, RemoveDirectoryToolArgs (..)) where++import Autodocodec qualified as AC+import Control.Monad (forM_)+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, isSymlink, sandboxPath)+import System.Directory+ ( doesDirectoryExist,+ listDirectory,+ removeDirectory,+ removeFile,+ )+import System.FilePath ((</>))++newtype RemoveDirectoryToolArgs = RemoveDirectoryToolArgs+ { _rdPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec RemoveDirectoryToolArgs)++instance AC.HasCodec RemoveDirectoryToolArgs where+ codec =+ AC.object "remove a directory" $+ RemoveDirectoryToolArgs+ <$> AC.requiredField "path" "Relative path of the directory to remove" AC..= (._rdPath)++removeDirectoryToolTyped :: FsConfig -> TypedTool ctx RemoveDirectoryToolArgs+removeDirectoryToolTyped cfg =+ TypedTool+ { ttoolName = "remove_directory",+ ttoolDescription =+ "Recursively delete a directory and all its contents at the given path (relative to the workspace). "+ <> "Use with caution — this operation is irreversible.",+ ttoolReadonly = False,+ ttoolExecute = const (removeDirectoryExecTyped cfg)+ }++removeDirectoryExecTyped :: FsConfig -> RemoveDirectoryToolArgs -> IO Text+removeDirectoryExecTyped cfg args = do+ let p = args._rdPath+ resolved <- sandboxPath cfg (T.unpack p)+ safeRemoveDirectoryRecursive resolved+ pure $ "Successfully removed directory " <> p++-- | Like 'System.Directory.removeDirectoryRecursive', but refuses to+-- follow directory symlinks. A symbolic link encountered during the+-- walk is unlinked (its target is left intact), so a symlink inside+-- the sandbox pointing at an external directory cannot be used to+-- delete files outside the sandbox.+--+-- Note: the top-level argument has already been resolved through+-- 'sandboxPath', so it is guaranteed to be a real directory inside+-- the sandbox at the moment of the call. We still re-check it+-- defensively in case of an unusual TOCTOU race.+safeRemoveDirectoryRecursive :: FilePath -> IO ()+safeRemoveDirectoryRecursive dir = do+ topIsLink <- isSymlink dir+ if topIsLink+ then removeFile dir+ else do+ entries <- listDirectory dir+ forM_ entries $ \entry -> do+ let child = dir </> entry+ childIsLink <- isSymlink child+ if childIsLink+ then removeFile child+ else do+ childIsDir <- doesDirectoryExist child+ if childIsDir+ then safeRemoveDirectoryRecursive child+ else removeFile child+ removeDirectory dir
+ src/LLM/Tools/RemoveFile.hs view
@@ -0,0 +1,39 @@+module LLM.Tools.RemoveFile (removeFileToolTyped, RemoveFileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import System.Directory (removeFile)++newtype RemoveFileToolArgs = RemoveFileToolArgs+ { _rftPath :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec RemoveFileToolArgs)++instance AC.HasCodec RemoveFileToolArgs where+ codec =+ AC.object "remove a file" $+ RemoveFileToolArgs <$> AC.requiredField "path" "Relative path of the file to remove" AC..= (._rftPath)++removeFileToolTyped :: FsConfig -> TypedTool ctx RemoveFileToolArgs+removeFileToolTyped cfg =+ TypedTool+ { ttoolName = "remove_file",+ ttoolDescription =+ "Delete a file at the given path (relative to the workspace). "+ <> "Fails if the path does not exist or is a directory.",+ ttoolReadonly = False,+ ttoolExecute = const (removeFileExecTyped cfg)+ }++removeFileExecTyped :: FsConfig -> RemoveFileToolArgs -> IO Text+removeFileExecTyped cfg args = do+ let p = args._rftPath+ resolved <- sandboxPath cfg (T.unpack p)+ removeFile resolved+ pure $ "Successfully removed " <> p
+ src/LLM/Tools/ReplaceInFile.hs view
@@ -0,0 +1,80 @@+module LLM.Tools.ReplaceInFile (replaceInFileToolTyped, ReplaceInFileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxPath)+import LLM.Tools.FsLimits (maxReadBytes, readBoundedTextFile)++data ReplaceInFileToolArgs = ReplaceInFileToolArgs+ { _rifPath :: Text,+ _rifOld :: Text,+ _rifNew :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec ReplaceInFileToolArgs)++instance AC.HasCodec ReplaceInFileToolArgs where+ codec :: AC.JSONCodec ReplaceInFileToolArgs+ codec =+ AC.object "replace a string in a file" $+ ReplaceInFileToolArgs+ <$> AC.requiredField "path" "Relative file path to write to" AC..= (._rifPath)+ <*> AC.requiredField "old" "The text content to be replaced in the file" AC..= (._rifOld)+ <*> AC.requiredField "new" "The replacement text content to write to the file" AC..= (._rifNew)++replaceInFileToolTyped :: FsConfig -> TypedTool ctx ReplaceInFileToolArgs+replaceInFileToolTyped cfg =+ TypedTool+ { ttoolName = "replace_in_file",+ ttoolDescription =+ "Replace the first occurrence of a string in a file. "+ <> "The 'old' string must appear exactly once in the file. "+ <> "Returns an error if the string is not found or appears more than once. "+ <> "Files larger than "+ <> T.pack (show maxReadBytes)+ <> " bytes are refused.",+ ttoolReadonly = False,+ ttoolExecute = const (replaceExecTyped cfg)+ }++replaceExecTyped :: FsConfig -> ReplaceInFileToolArgs -> IO Text+replaceExecTyped cfg args = do+ let ReplaceInFileToolArgs {_rifPath, _rifOld, _rifNew} = args+ p = _rifPath+ resolved <- sandboxPath cfg (T.unpack p)+ contentE <- readBoundedTextFile resolved p maxReadBytes+ case contentE of+ Left err -> pure $ "Error: " <> err+ Right content -> case countOccurrences _rifOld content of+ 0 -> pure "Error: the 'old' string was not found in the file"+ 1 -> do+ let replaced = replaceFirst _rifOld _rifNew content+ TIO.writeFile resolved replaced+ pure $ "Successfully replaced text in " <> p+ n ->+ pure $+ "Error: the 'old' string was found "+ <> T.pack (show n)+ <> " times; it must appear exactly once"++-- | Count non-overlapping occurrences of needle in haystack.+countOccurrences :: Text -> Text -> Int+countOccurrences needle haystack+ | T.null needle = 0+ | otherwise = go 0 haystack+ where+ go !n hay = case T.breakOn needle hay of+ (_, rest)+ | T.null rest -> n+ | otherwise -> go (n + 1) (T.drop (T.length needle) rest)++-- | Replace the first occurrence of needle with replacement.+replaceFirst :: Text -> Text -> Text -> Text+replaceFirst needle replacement haystack =+ let (before, after) = T.breakOn needle haystack+ in before <> replacement <> T.drop (T.length needle) after
+ src/LLM/Tools/Writefile.hs view
@@ -0,0 +1,45 @@+module LLM.Tools.Writefile (writefileToolTyped, WritefileToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (FsConfig, sandboxWritePath)++data WritefileToolArgs = WritefileToolArgs+ { _wfPath :: Text,+ _wfContent :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec WritefileToolArgs)++instance AC.HasCodec WritefileToolArgs where+ codec :: AC.JSONCodec WritefileToolArgs+ codec =+ AC.object "write content to a file" $+ WritefileToolArgs+ <$> AC.requiredField "path" "Relative file path to write to" AC..= (._wfPath)+ <*> AC.requiredField "content" "The text content to write to the file" AC..= (._wfContent)++writefileToolTyped :: FsConfig -> TypedTool ctx WritefileToolArgs+writefileToolTyped cfg =+ TypedTool+ { ttoolName = "writefile",+ ttoolDescription =+ "Write content to a file at the given path (relative to the workspace). "+ <> "Creates the file if it doesn't exist, overwrites if it does. "+ <> "Automatically creates parent directories as needed.",+ ttoolReadonly = False,+ ttoolExecute = const (writefileExecTyped cfg)+ }++writefileExecTyped :: FsConfig -> WritefileToolArgs -> IO Text+writefileExecTyped cfg args = do+ let p = args._wfPath+ c = args._wfContent+ resolved <- sandboxWritePath cfg (T.unpack p)+ TIO.writeFile resolved c+ pure $ "Successfully wrote " <> T.pack (show (T.length c)) <> " characters to " <> p
+ test/LLM/ChatSpec.hs view
@@ -0,0 +1,288 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module LLM.ChatSpec (spec) where++import Data.Aeson (object, (.=))+import Data.Map qualified as Map+import Data.Text (Text)+import Heptapod (generate)+import LLM.Agent.Events (noEventObserver)+import LLM.Agent.Generate (generateText)+import LLM.Agent.Types+ ( Agent (..),+ RuntimeArgs (..),+ Tool (..),+ ToolMap,+ )+import LLM.Core.Abort (AbortSignal, abort, newAbortSignal)+import LLM.Core.Types+ ( ChatRequest (..),+ ChatResponse (..),+ ContentBlock (TextBlock, ToolCallBlock),+ LLMError (..),+ LLMGateway (..),+ LLMHooks (..),+ ToolDef (ToolDef, toolDescription, toolName, toolParameters, toolReadonly),+ Turn (..),+ mkToolCall,+ )+import LLM.Core.Usage (PricingInfo (..), Usage (Usage))+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig+ ( ModelConfig (..),+ ModelWithFallbacks (..),+ )+import LLM.Generate.Types+ ( GenerateError (..),+ GenerateErrorResult (..),+ GenerateTextResult (..),+ )+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ )++-- | A mock gateway that returns a fixed response+mockGateway :: ChatResponse -> LLMGateway+mockGateway resp =+ LLMGateway+ { gwName = "mock",+ gwGenerateText = \_ _ -> pure (Right resp),+ gwStreamText = \_ _ _ -> pure (Right resp),+ gwGenerateObject = \_ _ _ -> pure (Right (object [], Nothing))+ }++-- | A mock gateway that returns an error+mockErrorGateway :: LLMError -> LLMGateway+mockErrorGateway err =+ LLMGateway+ { gwName = "mock-error",+ gwGenerateText = \_ _ -> pure (Left err),+ gwStreamText = \_ _ _ -> pure (Left err),+ gwGenerateObject = \_ _ _ -> pure (Left err)+ }++-- | A mock gateway that calls a tool, then responds with text+mockToolGateway :: LLMGateway+mockToolGateway =+ LLMGateway+ { gwName = "mock-tool",+ gwGenerateText = \_ req ->+ if any isToolTurn req.reqConversation+ then pure $ Right (ChatResponse "The weather is sunny." [TextBlock "The weather is sunny."] (Just (Usage 80 15 0)) Nothing)+ else+ let tc = mkToolCall "call_1" "get_weather" (object ["location" .= ("London" :: Text)])+ in pure $ Right (ChatResponse "" [ToolCallBlock tc] (Just (Usage 50 10 0)) Nothing),+ gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),+ gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)+ }+ where+ isToolTurn (ToolTurn _) = True+ isToolTurn _ = False++zeroPricing :: PricingInfo+zeroPricing = PricingInfo 0 0++-- | Wrap a gateway in a ModelConfig with test defaults+mockModel :: LLMGateway -> ModelConfig+mockModel gw =+ ModelConfig+ { mcGateway = gw,+ mcModel = "test-model",+ mcPricing = zeroPricing,+ mcMaxTokens = 1024,+ mcTemperature = Nothing,+ mcThinking = Nothing,+ mcRequestTimeout = Nothing,+ mcThrottleDelay = Nothing,+ mcRetryCount = 0,+ mcJitterBackoff = 0+ }++weatherTool :: Tool Text+weatherTool =+ Tool+ { toolDef =+ ToolDef+ { toolName = "get_weather",+ toolDescription = "Get weather",+ toolReadonly = True,+ toolParameters = object ["type" .= ("object" :: Text)]+ },+ toolExecute = \_ _ -> pure "Sunny, 22°C"+ }++defaultAgent :: Agent+defaultAgent =+ Agent+ { agName = "test",+ agSystemPrompt = Nothing,+ agTools = [],+ agMaxToolRounds = 10,+ agContextWindow = Nothing+ }++mkRuntime :: Maybe AbortSignal -> IO RuntimeArgs+mkRuntime mSig = do+ uuid <- generate+ pure+ RuntimeArgs+ { rtGenerationId = uuid,+ rtAbortSignal = mSig,+ rtLLMHooks =+ LLMHooks+ { onLLMRequest = \_ _ -> pure (),+ onLLMResponse = \_ _ -> pure (),+ onLLMResponseError = \_ _ -> pure ()+ },+ rtHooks = noHooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }++runGenerate ::+ Agent ->+ ModelWithFallbacks ->+ ToolMap Text ->+ Maybe AbortSignal ->+ [Turn] ->+ IO (Either GenerateErrorResult GenerateTextResult)+runGenerate agent models toolMap mSig turns = do+ rt <- mkRuntime mSig+ generateText agent models toolMap rt turns++spec :: Spec+spec = describe "Chat" $ do+ let toolMap = Map.fromList [("get_weather", weatherTool)]+ describe "generateText" $ do+ it "returns text for a simple response" $ do+ let gw = mockGateway (ChatResponse "Hi there!" [TextBlock "Hi there!"] (Just (Usage 10 5 0)) Nothing)+ models = ModelWithFallbacks (mockModel gw) []+ result <- runGenerate defaultAgent models toolMap Nothing [UserTurn "hello"]+ case result of+ Right r -> do+ r.gtrText `shouldBe` "Hi there!"+ length r.gtrNewMessages `shouldBe` 1 -- AssistantTurn+ r.gtrUsage `shouldBe` Usage 10 5 0+ Left err -> expectationFailure $ show err++ it "propagates errors" $ do+ let gw = mockErrorGateway (HttpError 500 "internal error")+ models = ModelWithFallbacks (mockModel gw) []+ result <- runGenerate defaultAgent models toolMap Nothing [UserTurn "hello"]+ case result of+ Left GenerateErrorResult {gerError = GErrLLM (HttpError 500 _)} -> pure ()+ other -> expectationFailure $ "Expected HttpError 500, got: " <> show other++ it "handles tool call loop" $ do+ let agent = defaultAgent {agTools = ["get_weather"]}+ models = ModelWithFallbacks (mockModel mockToolGateway) []+ result <- runGenerate agent models toolMap Nothing [UserTurn "weather in london?"]+ case result of+ Right r -> do+ r.gtrText `shouldBe` "The weather is sunny."+ -- AssistantTurn(tool call) + ToolTurn + AssistantTurn(final)+ length r.gtrNewMessages `shouldBe` 3+ r.gtrUsage `shouldBe` Usage 130 25 0 -- 50+80 input, 10+15 output+ Left err -> expectationFailure $ show err++ it "respects maxToolRounds" $ do+ let infiniteToolGateway =+ LLMGateway+ { gwName = "mock-infinite",+ gwGenerateText = \_ _ ->+ let tc = mkToolCall "call_1" "get_weather" (object [])+ in pure $ Right (ChatResponse "" [ToolCallBlock tc] Nothing Nothing),+ gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),+ gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)+ }+ agent = defaultAgent {agMaxToolRounds = 2, agTools = ["get_weather"]}+ models = ModelWithFallbacks (mockModel infiniteToolGateway) []+ result <- runGenerate agent models toolMap Nothing [UserTurn "test"]+ case result of+ Left GenerateErrorResult {gerError = GErrToolExceeded} -> pure ()+ other -> expectationFailure $ "Expected GErrToolExceeded, got: " <> show other++ it "falls back to next model on retryable error" $ do+ let failGw = mockErrorGateway (HttpError 503 "service unavailable")+ okGw = mockGateway (ChatResponse "Fallback worked!" [TextBlock "Fallback worked!"] (Just (Usage 10 5 0)) Nothing)+ models = ModelWithFallbacks (mockModel failGw) [mockModel okGw]+ result <- runGenerate defaultAgent models toolMap Nothing [UserTurn "hello"]+ case result of+ Right r -> r.gtrText `shouldBe` "Fallback worked!"+ Left err -> expectationFailure $ "Expected fallback success, got: " <> show err++ it "falls back on non-retryable error too" $ do+ let failGw = mockErrorGateway (HttpError 400 "bad request")+ okGw = mockGateway (ChatResponse "Fallback worked!" [TextBlock "Fallback worked!"] (Just (Usage 10 5 0)) Nothing)+ models = ModelWithFallbacks (mockModel failGw) [mockModel okGw]+ result <- runGenerate defaultAgent models toolMap Nothing [UserTurn "hello"]+ case result of+ Right r -> r.gtrText `shouldBe` "Fallback worked!"+ Left err -> expectationFailure $ "Expected fallback success, got: " <> show err++ it "returns error from last model when all fail" $ do+ let failGw1 = mockErrorGateway (HttpError 503 "service unavailable")+ failGw2 = mockErrorGateway (HttpError 400 "bad request")+ models = ModelWithFallbacks (mockModel failGw1) [mockModel failGw2]+ result <- runGenerate defaultAgent models toolMap Nothing [UserTurn "hello"]+ case result of+ Left GenerateErrorResult {gerError = GErrLLM (HttpError 400 _)} -> pure ()+ other -> expectationFailure $ "Expected HttpError 400 from last model, got: " <> show other++ it "returns Aborted when signal is fired before the call" $ do+ let gw = mockGateway (ChatResponse "Hi!" [TextBlock "Hi!"] Nothing Nothing)+ models = ModelWithFallbacks (mockModel gw) []+ sig <- newAbortSignal+ abort sig+ result <- runGenerate defaultAgent models toolMap (Just sig) [UserTurn "hello"]+ case result of+ Left GenerateErrorResult {gerError = GErrAborted} -> pure ()+ other -> expectationFailure $ "Expected GErrAborted, got: " <> show other++ it "returns Aborted during tool execution" $ 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",+ gwGenerateText = \_ _ ->+ let tc1 = mkToolCall "c1" "slow" (object [])+ tc2 = mkToolCall "c2" "slow" (object [])+ in pure $ Right (ChatResponse "" [ToolCallBlock tc1, ToolCallBlock tc2] Nothing Nothing),+ gwStreamText = \_ _ _ -> pure $ Right (ChatResponse "" [] Nothing Nothing),+ gwGenerateObject = \_ _ _ -> pure $ Right (object [], Nothing)+ }+ tm = Map.fromList [("slow", slowTool)]+ agent = defaultAgent {agTools = ["slow"]}+ models = ModelWithFallbacks (mockModel twoCallGw) []+ result <- runGenerate agent models tm (Just sig) [UserTurn "go"]+ case result of+ Left GenerateErrorResult {gerError = GErrAborted} -> pure ()+ other -> expectationFailure $ "Expected GErrAborted during tools, got: " <> show other++ it "does not fall back on Aborted" $ do+ let gw = mockGateway (ChatResponse "Hi!" [TextBlock "Hi!"] Nothing Nothing)+ okGw = mockGateway (ChatResponse "Fallback" [TextBlock "Fallback"] Nothing Nothing)+ models = ModelWithFallbacks (mockModel gw) [mockModel okGw]+ sig <- newAbortSignal+ abort sig+ result <- runGenerate defaultAgent models Map.empty (Just sig) [UserTurn "hello"]+ case result of+ Left GenerateErrorResult {gerError = GErrAborted} -> pure ()+ other -> expectationFailure $ "Expected GErrAborted (no fallback), got: " <> show other
+ test/LLM/ClaudeSpec.hs view
@@ -0,0 +1,50 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module LLM.ClaudeSpec (spec) where++import Data.Aeson (eitherDecodeFileStrict')+import LLM.Core.Types+ ( ChatResponse (respText),+ ToolCall (tcId, tcName),+ )+import LLM.Core.Usage (Usage (Usage))+import LLM.Core.Utils (getToolCalls, hasToolCalls)+import LLM.Providers.Claude (parseClaudeResponse, parseClaudeUsage)+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ )++spec :: Spec+spec = describe "Claude" $ do+ describe "parseClaudeResponse" $ do+ it "parses a text response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/claude-text.json"+ case parseClaudeResponse val of+ Right resp -> do+ resp.respText `shouldBe` "Hello! How can I help you today?"+ hasToolCalls resp `shouldBe` False+ Left err -> expectationFailure $ "Parse failed: " <> show err++ it "parses a tool_use response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/claude-tool-use.json"+ case parseClaudeResponse val of+ Right resp -> do+ resp.respText `shouldBe` "Let me check the weather for you."+ hasToolCalls resp `shouldBe` True+ let [tc] = getToolCalls resp+ tc.tcName `shouldBe` "get_weather"+ tc.tcId `shouldBe` "toolu_01A09q90qw90lq917835lq9"+ Left err -> expectationFailure $ "Parse failed: " <> show err++ describe "parseClaudeUsage" $ do+ it "extracts token counts" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/claude-text.json"+ parseClaudeUsage val `shouldBe` Just (Usage 25 10 0)++ it "extracts token counts from tool_use response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/claude-tool-use.json"+ parseClaudeUsage val `shouldBe` Just (Usage 50 35 0)
+ test/LLM/DeepSeekSpec.hs view
@@ -0,0 +1,106 @@+module LLM.DeepSeekSpec (spec) where++import Data.Aeson (Value (Object, String), object, (.=))+import Data.Aeson.Key qualified as K+import Data.Aeson.KeyMap qualified as KM+import Data.Text (Text)+import LLM.Core.Types+ ( ChatRequest (..),+ ChatResponse (respReasoning, respText),+ ThinkingMode (..),+ Turn (..),+ deepSeekMessageEncodeOptions,+ defaultMessageEncodeOptions,+ mkToolCall,+ )+import LLM.Providers.DeepSeek (deepSeekBuildBodyPairs)+import LLM.Providers.OpenAI (encodeTurn, parseOpenAIResponse)+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec = describe "DeepSeek thinking mode" $ do+ describe "message encoding" $ do+ it "includes reasoning_content when replaying assistant tool turns" $ do+ let turn =+ AssistantTurn+ "Let me check."+ (Just "I should call the weather tool.")+ [mkToolCall "call_1" "get_weather" (object ["location" .= ("London" :: Text)])]+ msg = head (encodeTurn deepSeekMessageEncodeOptions turn)+ lookupText "reasoning_content" msg `shouldBe` Just "I should call the weather tool."++ it "omits reasoning_content for OpenAI-compatible default encoding" $ do+ let turn = AssistantTurn "Hello" (Just "thinking") []+ msg = head (encodeTurn defaultMessageEncodeOptions turn)+ lookupText "reasoning_content" msg `shouldBe` Nothing++ describe "request body" $ do+ it "disables thinking by default" $ do+ let body = object (deepSeekBuildBodyPairs False sampleRequest)+ nestedText ["thinking", "type"] body `shouldBe` Just "disabled"++ it "supports explicit thinking configuration" $ do+ let req =+ sampleRequest+ { reqThinking = Just ThinkingMode {tmEnabled = True, tmEffort = Just "max"}+ }+ body = object (deepSeekBuildBodyPairs False req)+ nestedText ["thinking", "type"] body `shouldBe` Just "enabled"+ lookupText "reasoning_effort" body `shouldBe` Just "max"++ it "can disable thinking explicitly" $ do+ let req =+ sampleRequest+ { reqThinking = Just ThinkingMode {tmEnabled = False, tmEffort = Nothing}+ }+ body = object (deepSeekBuildBodyPairs False req)+ nestedText ["thinking", "type"] body `shouldBe` Just "disabled"++ describe "response parsing" $ do+ it "extracts reasoning_content from provider responses" $ do+ let response =+ object+ [ "choices"+ .= [ object+ [ "message"+ .= object+ [ "role" .= ("assistant" :: Text),+ "reasoning_content" .= ("Let me think." :: Text),+ "content" .= ("The answer is 42." :: Text)+ ]+ ]+ ]+ ]+ case parseOpenAIResponse response of+ Right resp -> do+ resp.respReasoning `shouldBe` Just "Let me think."+ resp.respText `shouldBe` "The answer is 42."+ Left err -> fail $ show err++sampleRequest :: ChatRequest+sampleRequest =+ ChatRequest+ { reqModel = "deepseek-v4-pro",+ reqConversation =+ [ AssistantTurn "Hi" (Just "CoT") [mkToolCall "c1" "get_date" (object [])],+ ToolTurn []+ ],+ reqSystem = Nothing,+ reqMaxTokens = 1024,+ reqTemperature = Nothing,+ reqTools = [],+ reqThinking = Nothing+ }++lookupText :: Text -> Value -> Maybe Text+lookupText key (Object o) =+ KM.lookup (K.fromText key) o >>= \case+ String t -> Just t+ _ -> Nothing+lookupText _ _ = Nothing++nestedText :: [Text] -> Value -> Maybe Text+nestedText [key] v = lookupText key v+nestedText (key : rest) (Object o) =+ KM.lookup (K.fromText key) o >>= nestedText rest+nestedText _ _ = Nothing
+ test/LLM/FsConfigSpec.hs view
@@ -0,0 +1,151 @@+module LLM.FsConfigSpec (spec) where++import Control.Exception (try)+import LLM.Tools.FsConfig+ ( SandboxViolation (..),+ mkFsConfig,+ sandboxPath,+ sandboxWritePath,+ )+import System.Directory+ ( createDirectory,+ createDirectoryIfMissing,+ createDirectoryLink,+ createFileLink,+ doesFileExist,+ )+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+ ( Expectation,+ Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ shouldSatisfy,+ )++-- | Run an IO action expected to throw 'SandboxViolation'.+shouldViolate :: IO a -> Expectation+shouldViolate act = do+ r <- try act+ case r of+ Left (SandboxViolation _ _) -> pure ()+ Right _ -> expectationFailure "expected SandboxViolation but action succeeded"++-- | Run an IO action with a fresh sandbox directory.+-- The directory itself is the sandbox root (canonical path).+withSandbox :: (FilePath -> IO a) -> IO a+withSandbox act = withSystemTempDirectory "llm-simple-fsconfig" $ \root -> do+ let sb = root </> "sandbox"+ createDirectory sb+ act sb++spec :: Spec+spec = describe "FsConfig sandbox" $ do+ describe "sandboxPath: relative paths" $ do+ it "resolves a plain relative path inside the sandbox" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ writeFile (sb </> "a.txt") "hello"+ resolved <- sandboxPath cfg "a.txt"+ resolved `shouldBe` (sb </> "a.txt")++ it "rejects '..' that escapes the sandbox" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ shouldViolate (sandboxPath cfg "../outside.txt")++ it "rejects deep '..' that escapes via existing parents" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ createDirectory (sb </> "sub")+ shouldViolate (sandboxPath cfg "sub/../../escape.txt")++ it "allows '..' that stays inside the sandbox" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ createDirectory (sb </> "sub")+ resolved <- sandboxPath cfg "sub/../sub"+ resolved `shouldBe` (sb </> "sub")++ describe "sandboxPath: absolute paths" $ do+ it "accepts an absolute path inside the sandbox" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ writeFile (sb </> "f.txt") "x"+ resolved <- sandboxPath cfg (sb </> "f.txt")+ resolved `shouldBe` (sb </> "f.txt")++ it "rejects an absolute path outside the sandbox" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ shouldViolate (sandboxPath cfg "/etc/passwd")++ it "rejects a similarly-named sibling directory (no string-prefix foot-gun)" $+ withSystemTempDirectory "llm-simple-fsconfig" $ \root -> do+ let sb = root </> "sandbox"+ sibling = root </> "sandbox2"+ createDirectory sb+ createDirectory sibling+ writeFile (sibling </> "secret.txt") "x"+ cfg <- mkFsConfig sb+ shouldViolate (sandboxPath cfg (sibling </> "secret.txt"))++ describe "sandboxPath: symlinks" $ do+ it "rejects a symlink in the path chain pointing outside the sandbox" $+ withSystemTempDirectory "llm-simple-fsconfig" $ \root -> do+ let sb = root </> "sandbox"+ outside = root </> "outside"+ createDirectory sb+ createDirectory outside+ writeFile (outside </> "secret.txt") "secret"+ createDirectoryLink outside (sb </> "link")+ cfg <- mkFsConfig sb+ shouldViolate (sandboxPath cfg "link/secret.txt")++ it "rejects a final-component symlink pointing outside" $+ withSystemTempDirectory "llm-simple-fsconfig" $ \root -> do+ let sb = root </> "sandbox"+ outside = root </> "outside"+ createDirectory sb+ createDirectory outside+ writeFile (outside </> "target.txt") "x"+ createFileLink (outside </> "target.txt") (sb </> "alias")+ cfg <- mkFsConfig sb+ shouldViolate (sandboxPath cfg "alias")++ it "rejects writes through a symlinked parent pointing outside" $+ withSystemTempDirectory "llm-simple-fsconfig" $ \root -> do+ let sb = root </> "sandbox"+ outside = root </> "outside"+ createDirectory sb+ createDirectory outside+ createDirectoryLink outside (sb </> "link")+ cfg <- mkFsConfig sb+ shouldViolate (sandboxWritePath cfg "link/new.txt")+ doesFileExist (outside </> "new.txt") >>= (`shouldBe` False)++ it "allows a symlink pointing to a path inside the sandbox" $+ withSandbox $ \sb -> do+ createDirectory (sb </> "real")+ writeFile (sb </> "real" </> "f.txt") "hi"+ createDirectoryLink (sb </> "real") (sb </> "link")+ cfg <- mkFsConfig sb+ -- The link is resolved by 'canonicalizeExisting', the canonical+ -- target lives under the sandbox, and the live-chain walk goes+ -- through the canonical (symlink-free) path. So the access is+ -- permitted and the resolved path points at the real file.+ resolved <- sandboxPath cfg "link/f.txt"+ resolved `shouldBe` (sb </> "real" </> "f.txt")++ describe "sandboxWritePath: non-existent targets" $ do+ it "resolves a write path under a not-yet-existing nested dir" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ resolved <- sandboxWritePath cfg "a/b/c/new.txt"+ resolved `shouldBe` (sb </> "a" </> "b" </> "c" </> "new.txt")++ it "rejects a write path that would escape via '..' in the tail" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ createDirectoryIfMissing True (sb </> "a")+ shouldViolate (sandboxWritePath cfg "a/../../evil.txt")++ it "resolved path always starts with the sandbox base" $ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ resolved <- sandboxPath cfg "./x/./y"+ resolved `shouldSatisfy` \p -> take (length sb) p == sb
+ test/LLM/FsLimitsSpec.hs view
@@ -0,0 +1,69 @@+module LLM.FsLimitsSpec (spec) where++import Data.ByteString qualified as BS+import Data.Text qualified as T+import LLM.Core.Types (TypedTool (..))+import LLM.Tools.FsConfig (mkFsConfig)+import LLM.Tools.FsLimits+ ( maxPaginatedFileBytes,+ maxReadBytes,+ readBoundedTextFile,+ )+import LLM.Tools.ReadFilePaginated+ ( ReadFilePaginatedArgs (..),+ readFilePaginatedToolTyped,+ )+import System.Directory (createDirectory)+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+ ( Spec,+ describe,+ it,+ shouldBe,+ shouldContain,+ shouldSatisfy,+ )++spec :: Spec+spec = describe "FsLimits" $ do+ describe "readBoundedTextFile" $ do+ it "reads a file within the cap" $ withTempFile $ \dir -> do+ let path = dir </> "small.txt"+ writeFile path "hello"+ result <- readBoundedTextFile path "test.txt" maxReadBytes+ result `shouldBe` Right "hello"++ it "rejects a file larger than the cap" $ withTempFile $ \dir -> do+ let path = dir </> "big.txt"+ BS.writeFile path (BS.replicate (maxReadBytes + 1) 0x61)+ result <- readBoundedTextFile path "big.txt" maxReadBytes+ result `shouldSatisfy` \case+ Left err -> "exceeds the" `T.isInfixOf` err+ Right _ -> False++ describe "read_file_paginated" $ do+ it "rejects source files larger than maxPaginatedFileBytes before reading" $+ withSandbox $ \sb -> do+ cfg <- mkFsConfig sb+ let path = sb </> "huge.txt"+ BS.writeFile path (BS.replicate (fromIntegral maxPaginatedFileBytes + 1) 0x61)+ let TypedTool {ttoolExecute = exec} = readFilePaginatedToolTyped cfg+ result <-+ exec+ ()+ ReadFilePaginatedArgs+ { _rfpPath = "huge.txt",+ _rfpOffset = 1,+ _rfpLimit = 10+ }+ T.unpack result `shouldContain` "exceeds the"++withTempFile :: (FilePath -> IO a) -> IO a+withTempFile = withSystemTempDirectory "llm-simple-fslimits"++withSandbox :: (FilePath -> IO a) -> IO a+withSandbox act = withSystemTempDirectory "llm-simple-fslimits" $ \root -> do+ let sb = root </> "sandbox"+ createDirectory sb+ act sb
+ test/LLM/FsToolsSpec.hs view
@@ -0,0 +1,200 @@+module LLM.FsToolsSpec (spec) where++import Data.Aeson (Value, object, (.=))+import Data.Map qualified as Map+import Data.Text (Text)+import Data.Text qualified as T+import Heptapod (generate)+import LLM.Agent.Types (RuntimeArgs (..), Tool (..), ToolContext (..))+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import LLM.Load.FsTools (fsTools)+import System.Directory+ ( createDirectory,+ doesDirectoryExist,+ doesFileExist,+ )+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+ ( Spec,+ describe,+ it,+ shouldBe,+ shouldContain,+ shouldNotContain,+ shouldReturn,+ )++spec :: Spec+spec = describe "FsTools" $ do+ describe "fsTools registration" $ do+ it "registers the expected tool names" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ Map.keys tm+ `shouldBe`+ [ "copy_file",+ "create_directory",+ "directory_tree",+ "file_info",+ "find_files",+ "grep",+ "move_file",+ "multi_replace_in_file",+ "read_file_paginated",+ "readdir",+ "remove_directory",+ "remove_file",+ "replace_in_file",+ "writefile"+ ]++ describe "writefile / read_file_paginated" $ do+ it "writes and reads back text" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ _ <- runTool tm "writefile" (object ["path" .= ("notes.txt" :: Text), "content" .= ("line1\nline2\n" :: Text)])+ result <- runTool tm "read_file_paginated" (object ["path" .= ("notes.txt" :: Text), "offset" .= (1 :: Int), "limit" .= (10 :: Int)])+ T.unpack result `shouldContain` "line1"+ T.unpack result `shouldContain` "line2"++ describe "replace_in_file" $ do+ it "replaces a unique occurrence" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("code.hs" :: Text), "content" .= ("foo = 1\n" :: Text)])+ result <-+ runTool+ tm+ "replace_in_file"+ (object ["path" .= ("code.hs" :: Text), "old" .= ("foo = 1" :: Text), "new" .= ("foo = 2" :: Text)])+ T.unpack result `shouldContain` "Successfully replaced"+ readBack <- runTool tm "read_file_paginated" (object ["path" .= ("code.hs" :: Text)])+ T.unpack readBack `shouldContain` "foo = 2"++ describe "grep" $ do+ it "finds a literal substring" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("src/main.hs" :: Text), "content" .= ("main = putStrLn \"hello\"\n" :: Text)])+ result <-+ runTool+ tm+ "grep"+ ( object+ [ "pattern" .= ("putStrLn" :: Text),+ "path" .= ("." :: Text),+ "extensions" .= (["hs"] :: [Text])+ ]+ )+ T.unpack result `shouldContain` "main.hs"++ describe "find_files" $ do+ it "matches a glob pattern" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("src/A.hs" :: Text), "content" .= ("x" :: Text)])+ runTool_ tm "writefile" (object ["path" .= ("src/B.txt" :: Text), "content" .= ("y" :: Text)])+ result <- runTool tm "find_files" (object ["pattern" .= ("**/*.hs" :: Text), "path" .= ("." :: Text)])+ T.unpack result `shouldContain` "src/A.hs"+ T.unpack result `shouldNotContain` "B.txt"++ describe "readdir" $ do+ it "lists directory entries" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("visible.txt" :: Text), "content" .= ("x" :: Text)])+ result <- runTool tm "readdir" (object ["path" .= ("." :: Text)])+ T.unpack result `shouldContain` "visible.txt"++ describe "directory_tree" $ do+ it "renders a tree under the workspace" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "create_directory" (object ["path" .= ("pkg" :: Text)])+ runTool_ tm "writefile" (object ["path" .= ("pkg/mod.hs" :: Text), "content" .= ("x" :: Text)])+ result <- runTool tm "directory_tree" (object ["path" .= ("." :: Text)])+ T.unpack result `shouldContain` "pkg"+ T.unpack result `shouldContain` "mod.hs"++ describe "file_info" $ do+ it "reports file metadata" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("data.txt" :: Text), "content" .= ("abc\n" :: Text)])+ result <- runTool tm "file_info" (object ["path" .= ("data.txt" :: Text)])+ T.unpack result `shouldContain` "kind: text"++ describe "copy_file / move_file" $ do+ it "copies then moves a file" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("orig.txt" :: Text), "content" .= ("payload" :: Text)])+ runTool_ tm "copy_file" (object ["source" .= ("orig.txt" :: Text), "destination" .= ("copy.txt" :: Text)])+ runTool_ tm "move_file" (object ["source" .= ("copy.txt" :: Text), "destination" .= ("moved.txt" :: Text)])+ doesFileExist (sb </> "moved.txt") `shouldReturn` True+ doesFileExist (sb </> "copy.txt") `shouldReturn` False++ describe "multi_replace_in_file" $ do+ it "applies ordered replacements" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "writefile" (object ["path" .= ("multi.txt" :: Text), "content" .= ("aaa bbb\n" :: Text)])+ result <-+ runTool+ tm+ "multi_replace_in_file"+ ( object+ [ "path" .= ("multi.txt" :: Text),+ "replacements"+ .= [ object ["old" .= ("aaa" :: Text), "new" .= ("AAA" :: Text)],+ object ["old" .= ("bbb" :: Text), "new" .= ("BBB" :: Text)]+ ]+ ]+ )+ T.unpack result `shouldContain` "Successfully applied 2"+ readBack <- runTool tm "read_file_paginated" (object ["path" .= ("multi.txt" :: Text)])+ T.unpack readBack `shouldContain` "AAA BBB"++ describe "create_directory" $ do+ it "creates nested directories" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ result <- runTool tm "create_directory" (object ["path" .= ("a/b/c" :: Text), "parents" .= True])+ T.unpack result `shouldContain` "Successfully created"+ doesDirectoryExist (sb </> "a" </> "b" </> "c") `shouldReturn` True++ describe "remove_file / remove_directory" $ do+ it "removes files and directories" $ withSandbox $ \sb -> do+ tm <- fsTools sb+ runTool_ tm "create_directory" (object ["path" .= ("tmp" :: Text)])+ runTool_ tm "writefile" (object ["path" .= ("tmp/x.txt" :: Text), "content" .= ("z" :: Text)])+ runTool_ tm "remove_file" (object ["path" .= ("tmp/x.txt" :: Text)])+ doesFileExist (sb </> "tmp" </> "x.txt") `shouldReturn` False+ runTool_ tm "remove_directory" (object ["path" .= ("tmp" :: Text)])+ doesDirectoryExist (sb </> "tmp") `shouldReturn` False++withSandbox :: (FilePath -> IO a) -> IO a+withSandbox act = withSystemTempDirectory "llm-simple-fstools" $ \root -> do+ let sb = root </> "sandbox"+ createDirectory sb+ act sb++runTool :: Map.Map Text (Tool Text) -> Text -> Value -> IO Text+runTool tm name args = do+ ctx <- mkToolContext+ case Map.lookup name tm of+ Nothing -> error ("tool not found: " <> T.unpack name)+ Just tool -> tool.toolExecute ctx args++runTool_ :: Map.Map Text (Tool Text) -> Text -> Value -> IO ()+runTool_ tm name args = runTool tm name args >> pure ()++mkToolContext :: IO ToolContext+mkToolContext = do+ genId <- generate+ pure+ ToolContext+ { tcConversation = [],+ tcUsage = mempty,+ tcWindowOffset = 0,+ tcRuntimeArgs =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks noHooks,+ rtHooks = noHooks,+ rtOnEvent = \_ -> pure (),+ rtReadonly = False+ }+ }
+ test/LLM/GeminiSpec.hs view
@@ -0,0 +1,43 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module LLM.GeminiSpec (spec) where++import Data.Aeson (eitherDecodeFileStrict')+import LLM.Core.Types (ChatResponse (respText), ToolCall (tcName))+import LLM.Core.Usage (Usage (Usage))+import LLM.Core.Utils (getToolCalls, hasToolCalls)+import LLM.Providers.Gemini (parseGeminiResponse, parseGeminiUsage)+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ )++spec :: Spec+spec = describe "Gemini" $ do+ describe "parseGeminiResponse" $ do+ it "parses a text response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/gemini-text.json"+ resp <- parseGeminiResponse val+ case resp of+ Right r -> do+ r.respText `shouldBe` "Hello! How can I help you today?"+ hasToolCalls r `shouldBe` False+ Left err -> expectationFailure $ "Parse failed: " <> show err++ it "parses a function call response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/gemini-tool-use.json"+ resp <- parseGeminiResponse val+ case resp of+ Right r -> do+ hasToolCalls r `shouldBe` True+ let [tc] = getToolCalls r+ tc.tcName `shouldBe` "get_weather"+ Left err -> expectationFailure $ "Parse failed: " <> show err++ describe "parseGeminiUsage" $ do+ it "extracts token counts" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/gemini-text.json"+ parseGeminiUsage val `shouldBe` Just (Usage 20 8 0)
+ test/LLM/GenerateObjectSpec.hs view
@@ -0,0 +1,163 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module LLM.GenerateObjectSpec (spec) where++import Data.Aeson (Value, object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Heptapod (generate)+import LLM.Agent.GenerateObject (generateObject, generateObjectUntyped)+import LLM.Agent.Types (Agent (..), RuntimeArgs (..))+import LLM.Core.Abort (AbortSignal, abort, newAbortSignal)+import LLM.Core.Types (ChatResponse (..), LLMError (..), LLMGateway (..), LLMHooks (..), Turn (..))+import LLM.Core.Usage (PricingInfo (..), Usage (..))+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig+ ( ModelConfig (..),+ ModelWithFallbacks (..),+ )+import LLM.Generate.Types (GenerateError (..), GenerateErrorResult (..))+import LLM.WeatherTool (WeatherToolArgs (..))+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ shouldContain,+ )++spec :: Spec+spec = describe "GenerateObject" $ do+ describe "generateObjectUntyped" $ do+ it "returns the provider JSON and usage" $ do+ let gw = objectGateway (object ["location" .= ("Paris" :: Text)]) (Usage 12 3 0)+ models = ModelWithFallbacks (mockModel gw) []+ result <- runUntyped models (object ["type" .= ("object" :: Text)])+ case result of+ Right (value, usage) -> do+ value `shouldBe` object ["location" .= ("Paris" :: Text)]+ usage `shouldBe` Usage 12 3 0+ Left err -> expectationFailure $ show err++ it "propagates provider errors" $ do+ let gw = errorObjectGateway (HttpError 503 "unavailable")+ models = ModelWithFallbacks (mockModel gw) []+ result <- runUntyped models (object ["type" .= ("object" :: Text)])+ case result of+ Left GenerateErrorResult {gerError = GErrLLM (HttpError 503 _)} -> pure ()+ other -> expectationFailure $ "expected HttpError 503, got: " <> show other++ it "returns Aborted when the signal is already set" $ do+ sig <- newAbortSignal+ abort sig+ let gw = objectGateway (object []) (Usage 0 0 0)+ models = ModelWithFallbacks (mockModel gw) []+ rt <- mkRuntime (Just sig)+ result <- generateObjectUntyped defaultAgent models rt [UserTurn "go"] (object ["type" .= ("object" :: Text)])+ case result of+ Left GenerateErrorResult {gerError = GErrAborted} -> pure ()+ other -> expectationFailure $ "expected GErrAborted, got: " <> show other++ it "falls back to the next model on failure" $ do+ let failGw = errorObjectGateway (HttpError 500 "boom")+ okGw = objectGateway (object ["ok" .= True]) (Usage 1 1 0)+ models = ModelWithFallbacks (mockModel failGw) [mockModel okGw]+ result <- runUntyped models (object ["type" .= ("object" :: Text)])+ case result of+ Right (value, _) -> value `shouldBe` object ["ok" .= True]+ Left err -> expectationFailure $ show err++ describe "generateObject" $ do+ it "decodes a typed object from provider JSON" $ do+ let gw = objectGateway (object ["location" .= ("London" :: Text)]) (Usage 4 2 0)+ models = ModelWithFallbacks (mockModel gw) []+ result <- runTyped models+ case result of+ Right (WeatherToolArgs loc, usage) -> do+ loc `shouldBe` "London"+ usage `shouldBe` Usage 4 2 0+ Left err -> expectationFailure $ show err++ it "reports a parse error when provider JSON does not match the codec" $ do+ let gw = objectGateway (object ["wrong" .= (1 :: Int)]) (Usage 0 0 0)+ models = ModelWithFallbacks (mockModel gw) []+ result <- runTyped models+ case result of+ Left GenerateErrorResult {gerError = GErrParseObjectError msg} ->+ T.unpack msg `shouldContain` "Can't decode object"+ _ -> expectationFailure "expected GErrParseObjectError"++objectGateway :: Value -> Usage -> LLMGateway+objectGateway value usage =+ LLMGateway+ { gwName = "object-mock",+ gwGenerateText = \_ _ -> pure (Right (ChatResponse "" [] Nothing Nothing)),+ gwStreamText = \_ _ _ -> pure (Right (ChatResponse "" [] Nothing Nothing)),+ gwGenerateObject = \_ _ _ -> pure (Right (value, Just usage))+ }++errorObjectGateway :: LLMError -> LLMGateway+errorObjectGateway err =+ LLMGateway+ { gwName = "object-error",+ gwGenerateText = \_ _ -> pure (Left err),+ gwStreamText = \_ _ _ -> pure (Left err),+ gwGenerateObject = \_ _ _ -> pure (Left err)+ }++mockModel :: LLMGateway -> ModelConfig+mockModel gw =+ ModelConfig+ { mcGateway = gw,+ mcModel = "test-model",+ mcPricing = zeroPricing,+ mcMaxTokens = 256,+ mcTemperature = Nothing,+ mcThinking = Nothing,+ mcRequestTimeout = Nothing,+ mcThrottleDelay = Nothing,+ mcRetryCount = 0,+ mcJitterBackoff = 0+ }++zeroPricing :: PricingInfo+zeroPricing = PricingInfo 0 0++defaultAgent :: Agent+defaultAgent =+ Agent+ { agName = "test",+ agSystemPrompt = Nothing,+ agTools = [],+ agMaxToolRounds = 3,+ agContextWindow = Nothing+ }++mkRuntime :: Maybe AbortSignal -> IO RuntimeArgs+mkRuntime mSig = do+ genId <- generate+ pure+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = mSig,+ rtLLMHooks =+ LLMHooks+ { onLLMRequest = \_ _ -> pure (),+ onLLMResponse = \_ _ -> pure (),+ onLLMResponseError = \_ _ -> pure ()+ },+ rtHooks = noHooks,+ rtOnEvent = \_ -> pure (),+ rtReadonly = False+ }++runUntyped :: ModelWithFallbacks -> Value -> IO (Either GenerateErrorResult (Value, Usage))+runUntyped models schema = do+ rt <- mkRuntime Nothing+ generateObjectUntyped defaultAgent models rt [UserTurn "extract"] schema++runTyped :: ModelWithFallbacks -> IO (Either GenerateErrorResult (WeatherToolArgs, Usage))+runTyped models = do+ rt <- mkRuntime Nothing+ generateObject defaultAgent models rt [UserTurn "weather?"]
+ test/LLM/GenericConversationTest.hs view
@@ -0,0 +1,111 @@+module LLM.GenericConversationTest (createSpec, GenericConversationTextOps (..)) where++import Data.Map qualified as Map+import Data.Text qualified as T+import Heptapod (generate)+import LLM (LLMHooks (..))+import LLM.Agent.Events (noEventObserver)+import LLM.Agent.ToolUtils (toTool)+import LLM.Agent.Types (Agent (..), RuntimeArgs (..))+import LLM.Core.LLMProvider (LLMProvider, toGateway)+import LLM.Core.Types (LLMGateway, ThinkingMode (..))+import LLM.Core.Usage (PricingInfo (..))+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig (ModelConfig (..), ModelWithFallbacks (ModelWithFallbacks))+import LLM.TestKit+ ( loadRecordedConversation,+ mockProvider,+ recordedConversationSystemPrompt,+ streamChatLoop,+ )+import LLM.WeatherTool (weatherToolTyped)+import Test.Hspec (Spec, describe, it, shouldBe)++data GenericConversationTextOps = GenericConversationTextOps+ { specTitle :: String,+ specProvider :: LLMProvider,+ modelName :: String,+ specThinking :: Maybe ThinkingMode,+ filePathGenerated :: String,+ filePathStreamed :: String+ }++mkModelConfig :: GenericConversationTextOps -> LLMGateway -> ModelConfig+mkModelConfig opts provider =+ ModelConfig+ { mcGateway = provider,+ mcModel = T.pack opts.modelName,+ mcPricing = PricingInfo {pricePerMillionInput = 0.0, pricePerMillionOutput = 0.0},+ mcMaxTokens = 1024,+ mcTemperature = Nothing,+ mcThinking = opts.specThinking,+ mcRequestTimeout = Nothing,+ mcThrottleDelay = Nothing,+ mcRetryCount = 3,+ mcJitterBackoff = 1_000+ }++createSpec :: GenericConversationTextOps -> Spec+createSpec opts = describe opts.specTitle $ do+ let toolMap = Map.fromList [("get_weather", toTool weatherToolTyped)]++ it "generateText" $ do+ (m, p) <- loadRecordedConversation opts.filePathGenerated+ uuid1 <- generate+ let provider = toGateway $ mockProvider m opts.specProvider+ modelConf = mkModelConfig opts provider+ systemPrompt = recordedConversationSystemPrompt+ agent :: Agent =+ Agent+ { agName = "test",+ agSystemPrompt = Just systemPrompt,+ agTools =+ [ "get_weather"+ ],+ agMaxToolRounds = 3,+ agContextWindow = Nothing+ }+ models = ModelWithFallbacks modelConf []+ rt =+ RuntimeArgs+ { rtGenerationId = uuid1,+ rtAbortSignal = Nothing,+ rtLLMHooks = LLMHooks {onLLMRequest = \_ _ -> pure (), onLLMResponse = \_ _ -> pure (), onLLMResponseError = \_ _ -> pure ()},+ rtHooks = noHooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }+ turns <- streamChatLoop False (agent, models, toolMap, rt) p+ length turns `shouldBe` 8++ it "streamText" $ do+ (m, p) <- loadRecordedConversation opts.filePathStreamed+ uuid1 <- generate+ let provider = toGateway $ mockProvider m opts.specProvider+ modelConf = mkModelConfig opts provider+ systemPrompt = recordedConversationSystemPrompt+ models = ModelWithFallbacks modelConf []+ agent =+ Agent+ { agName = "test",+ agSystemPrompt = Just systemPrompt,+ agTools = ["get_weather"],+ agMaxToolRounds = 3,+ agContextWindow = Nothing+ }+ runtime =+ RuntimeArgs+ { rtGenerationId = uuid1,+ rtAbortSignal = Nothing,+ rtLLMHooks =+ LLMHooks+ { onLLMRequest = \_ _ -> pure (),+ onLLMResponse = \_ _ -> pure (),+ onLLMResponseError = \_ _ -> pure ()+ },+ rtHooks = noHooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }+ turns <- streamChatLoop True (agent, models, toolMap, runtime) p+ length turns `shouldBe` 8
+ test/LLM/HistoryToolSpec.hs view
@@ -0,0 +1,98 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module LLM.HistoryToolSpec (spec) where++import Data.Aeson (object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Heptapod (generate)+import LLM.Agent.ToolUtils (toTool, windowOffset)+import LLM.Agent.Tools.HistoryTool (historyToolTyped)+import LLM.Agent.Types (Agent (..), RuntimeArgs (..), Tool (..), ToolContext (..))+import LLM.Core.Types (Turn (..))+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import Test.Hspec+ ( Spec,+ describe,+ it,+ shouldBe,+ shouldContain,+ shouldNotContain,+ )++spec :: Spec+spec = describe "HistoryTool" $ do+ describe "windowOffset" $ do+ it "returns 0 when no context window is configured" $ do+ windowOffset Nothing sampleConversation `shouldBe` 0++ it "hides all but the last N user messages" $ do+ windowOffset (Just 1) sampleConversation `shouldBe` 4++ it "returns 0 when the conversation has fewer user messages than N" $ do+ windowOffset (Just 5) [UserTurn "only"] `shouldBe` 0++ describe "get_history" $ do+ it "reports no earlier history when nothing is hidden" $ do+ result <- runHistory noWindowAgent sampleConversation 0+ result `shouldBe` "(no earlier history)"++ it "returns the most recent hidden chunk at chunk 0" $ do+ result <- runHistory windowedAgent sampleConversation 0+ T.unpack result `shouldContain` "[User] second question"+ T.unpack result `shouldNotContain` "first question"++ it "returns older hidden chunks at higher indices" $ do+ result <- runHistory windowedAgent sampleConversation 1+ T.unpack result `shouldContain` "[User] first question"+ T.unpack result `shouldNotContain` "second question"++ it "reports no more history for out-of-range chunk indices" $ do+ result <- runHistory windowedAgent sampleConversation 9+ result `shouldBe` "(no more history)"++sampleConversation :: [Turn]+sampleConversation =+ [ UserTurn "first question",+ AssistantTurn "first answer" Nothing [],+ UserTurn "second question",+ AssistantTurn "second answer" Nothing [],+ UserTurn "third question",+ AssistantTurn "third answer" Nothing []+ ]++noWindowAgent :: Agent+noWindowAgent =+ Agent+ { agName = "test",+ agSystemPrompt = Nothing,+ agTools = ["get_history"],+ agMaxToolRounds = 3,+ agContextWindow = Nothing+ }++windowedAgent :: Agent+windowedAgent = noWindowAgent {agContextWindow = Just 1}++runHistory :: Agent -> [Turn] -> Int -> IO Text+runHistory agent conv chunk = do+ genId <- generate+ let offset = windowOffset agent.agContextWindow conv+ ctx =+ ToolContext+ { tcConversation = conv,+ tcUsage = mempty,+ tcWindowOffset = offset,+ tcRuntimeArgs =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks noHooks,+ rtHooks = noHooks,+ rtOnEvent = \_ -> pure (),+ rtReadonly = False+ }+ }+ tool = toTool historyToolTyped+ tool.toolExecute ctx (object ["chunk" .= chunk])
+ test/LLM/LoadSpec.hs view
@@ -0,0 +1,82 @@+module LLM.LoadSpec (spec) where++import Control.Exception (IOException, SomeException, catch, displayException, fromException, try)+import Data.Aeson (Value (Array), eitherDecodeFileStrict')+import Data.Map qualified as Map+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text qualified as T+import LLM.Generate.ModelConfig (ModelConfig (..))+import LLM.Load.LoadGateways (loadGateways)+import LLM.Load.LoadModels (loadModelOrThrow, loadModelOrThrow_, loadModelsOrThrow)+import LLM.Load.Types (LoadConfigError (..))+import System.FilePath ((</>))+import System.IO.Temp (withSystemTempDirectory)+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ shouldContain,+ shouldSatisfy,+ )++ollamaCatalog :: FilePath+ollamaCatalog = "./test/fixtures/ollama-catalog.json"++spec :: Spec+spec = describe "Load" $ do+ describe "model catalog JSON" $ do+ it "parses the bundled model catalog" $ do+ result <- eitherDecodeFileStrict' "./model-catalog.json"+ case result of+ Right (Array xs) -> length xs `shouldSatisfy` (> 0)+ _ -> expectationFailure "expected a JSON array"++ it "fails on missing catalog file" $ do+ result <- try @SomeException (loadModelOrThrow "./no-such-catalog.json" "llama_3_2")+ case result of+ Left err+ | isJust (fromException err :: Maybe IOException) -> pure ()+ | isJust (fromException err :: Maybe LoadConfigError) -> pure ()+ | otherwise ->+ expectationFailure $ "expected missing-file failure, got: " <> displayException err+ Right _ -> expectationFailure "expected failure"++ describe "loadModelsOrThrow" $ do+ it "loads a known model config" $ do+ cfg <- loadModelOrThrow ollamaCatalog "llama_3_2"+ cfg.mcModel `shouldBe` "llama3.2:latest"++ it "throws when a model config is missing" $ do+ result <- try @LoadConfigError (loadModelsOrThrow ollamaCatalog ("llama_3_2" :: Text, "missing_model" :: Text))+ case result of+ Left (LoadModelConfigError msg) -> T.unpack msg `shouldContain` "Model not found"+ Left other -> expectationFailure $ "expected LoadModelConfigError, got: " <> show other+ Right _ -> expectationFailure "expected failure"++ it "loads the full catalog map from an ollama-only fixture" $ do+ (_, catalog, _) <- loadModelOrThrow_ ollamaCatalog "llama_3_2"+ Map.member "llama_3_2" catalog `shouldBe` True+ Map.member "mistral" catalog `shouldBe` True++ describe "loadGateways" $ do+ it "always includes ollama" $ do+ gateways <- loadGateways+ Map.member "ollama" gateways `shouldBe` True++ describe "invalid catalog JSON" $ do+ it "reports a catalog parse/load error" $ withTempCatalog "[not valid json" $ \path -> do+ result <- try @LoadConfigError (loadModelOrThrow path "x")+ case result of+ Left (LoadModelCatalogError _) -> pure ()+ Left other -> expectationFailure $ "expected LoadModelCatalogError, got: " <> show other+ Right _ -> expectationFailure "expected failure"++withTempCatalog :: String -> (FilePath -> IO a) -> IO a+withTempCatalog contents act =+ withSystemTempDirectory "llm-simple-load" $ \root -> do+ let path = root </> "catalog.json"+ writeFile path contents+ act path `catch` \(_ :: IOException) -> act path
+ test/LLM/OpenAISpec.hs view
@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module LLM.OpenAISpec (spec) where++import Data.Aeson (eitherDecodeFileStrict')+import LLM.Core.Types+ ( ChatResponse (respText),+ ToolCall (tcId, tcName),+ )+import LLM.Core.Usage (Usage (Usage))+import LLM.Core.Utils (getToolCalls, hasToolCalls)+import LLM.Providers.OpenAI (parseOpenAIResponse, parseOpenAIUsage)+import Test.Hspec+ ( Spec,+ describe,+ expectationFailure,+ it,+ shouldBe,+ )++spec :: Spec+spec = describe "OpenAI" $ do+ describe "parseOpenAIResponse" $ do+ it "parses a text response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/openai-text.json"+ case parseOpenAIResponse val of+ Right resp -> do+ resp.respText `shouldBe` "Hello! How can I help you today?"+ hasToolCalls resp `shouldBe` False+ Left err -> expectationFailure $ "Parse failed: " <> show err++ it "parses a tool_calls response" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/openai-tool-use.json"+ case parseOpenAIResponse val of+ Right resp -> do+ hasToolCalls resp `shouldBe` True+ let [tc] = getToolCalls resp+ tc.tcName `shouldBe` "get_weather"+ tc.tcId `shouldBe` "call_abc123"+ Left err -> expectationFailure $ "Parse failed: " <> show err++ describe "parseOpenAIUsage" $ do+ it "extracts token counts" $ do+ Right val <- eitherDecodeFileStrict' "test/fixtures/openai-text.json"+ parseOpenAIUsage val `shouldBe` Just (Usage 15 9 0)
+ test/LLM/RecordedConversationSpec.hs view
@@ -0,0 +1,84 @@+module LLM.RecordedConversationSpec (spec) where++import LLM.GenericConversationTest (GenericConversationTextOps (..), createSpec)+import LLM.Providers.Claude (claudeProvider)+import LLM.Providers.DeepSeek (deepSeekProvider)+import LLM.Providers.Gemini (geminiProvider)+import LLM.Providers.Ollama (ollamaProvider)+import LLM.Providers.OpenAI (openAIProvider)+import LLM.TestKit (recordedDeepSeekThinking)+import Test.Hspec (SpecWith, describe)++ollamaConversationGeneratedFilePath :: String+ollamaConversationGeneratedFilePath = "./test/fixtures/ollama-conversation-generated.json"++ollamaConversationStreamedFilePath :: String+ollamaConversationStreamedFilePath = "./test/fixtures/ollama-conversation-streamed.json"++claudeConversationGeneratedFilePath :: String+claudeConversationGeneratedFilePath = "./test/fixtures/claude-conversation-generated.json"++claudeConversationStreamedFilePath :: String+claudeConversationStreamedFilePath = "./test/fixtures/claude-conversation-streamed.json"++geminiConversationGeneratedFilePath :: String+geminiConversationGeneratedFilePath = "./test/fixtures/gemini-conversation-generated.json"++geminiConversationStreamedFilePath :: String+geminiConversationStreamedFilePath = "./test/fixtures/gemini-conversation-streamed.json"++openAIConversationGeneratedFilePath :: String+openAIConversationGeneratedFilePath = "./test/fixtures/openai-conversation-generated.json"++openAIConversationStreamedFilePath :: String+openAIConversationStreamedFilePath = "./test/fixtures/openai-conversation-streamed.json"++deepSeekConversationGeneratedFilePath :: String+deepSeekConversationGeneratedFilePath = "./test/fixtures/deepseek-conversation-generated.json"++deepSeekConversationStreamedFilePath :: String+deepSeekConversationStreamedFilePath = "./test/fixtures/deepseek-conversation-streamed.json"++spec :: SpecWith ()+spec =+ describe "recorded conversation" $ do+ createSpec $+ GenericConversationTextOps+ "Ollama"+ ollamaProvider+ "llama3.2:latest"+ Nothing+ ollamaConversationGeneratedFilePath+ ollamaConversationStreamedFilePath+ createSpec $+ GenericConversationTextOps+ "Claude"+ (claudeProvider "")+ "claude-haiku-4-5-20251001"+ Nothing+ claudeConversationGeneratedFilePath+ claudeConversationStreamedFilePath+ createSpec $+ GenericConversationTextOps+ "Gemini"+ (geminiProvider "")+ "gemini-2.5-flash"+ Nothing+ geminiConversationGeneratedFilePath+ geminiConversationStreamedFilePath+ createSpec $+ GenericConversationTextOps+ "OpenAI"+ (openAIProvider "")+ "gpt-4.1-2025-04-14"+ Nothing+ openAIConversationGeneratedFilePath+ openAIConversationStreamedFilePath+ createSpec $+ GenericConversationTextOps+ "DeepSeek"+ (deepSeekProvider "")+ "deepseek-v4-flash"+ (Just recordedDeepSeekThinking)+ deepSeekConversationGeneratedFilePath+ deepSeekConversationStreamedFilePath
+ test/LLM/StreamingSpec.hs view
@@ -0,0 +1,111 @@+{-# OPTIONS_GHC -Wno-missing-fields #-}++module LLM.StreamingSpec (spec) where++import Data.Aeson (object, (.=))+import Data.IORef (modifyIORef', newIORef, readIORef)+import Data.Text (Text)+import LLM.Core.Types+ ( ChatResponse (..),+ ContentBlock (TextBlock, ToolCallBlock),+ LLMGateway (..),+ StreamEvent (..),+ Turn (..),+ mkToolCall,+ )+import LLM.Core.Usage (PricingInfo (..), Usage (..))+import LLM.Generate.Generate (streamTextLLM)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import LLM.Generate.ModelConfig (ModelConfig (..))+import LLM.Generate.Types+ ( GenRequest (..),+ RoundTextRole (..),+ StreamChunk (..),+ )+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec = describe "Streaming" $ do+ describe "streamTextLLM phase routing" $ do+ it "classifies plain text as answer on finalize" $ do+ let gw =+ streamGateway+ [StreamDelta "hello"]+ (ChatResponse "hello" [TextBlock "hello"] (Just (Usage 1 1 0)) Nothing)+ chunks <- runStream gw []+ reverse chunks+ `shouldBe` [ TextDelta "hello",+ RoundTextRoleCommitted AnswerRole+ ]++ it "routes text to answer after a tool turn" $ do+ let prior = [UserTurn "q", AssistantTurn "" Nothing [mkToolCall "1" "t" (object [])], ToolTurn []]+ gw =+ streamGateway+ [StreamDelta "done"]+ (ChatResponse "done" [TextBlock "done"] (Just (Usage 1 1 0)) Nothing)+ chunks <- runStream gw prior+ reverse chunks `shouldBe` [AnswerDelta "done"]++ it "routes preamble text and tool calls before answer" $ do+ let tc = mkToolCall "c1" "grep" (object ["pattern" .= ("x" :: Text)])+ gw =+ streamGateway+ [StreamDelta "searching", StreamToolCall tc]+ (ChatResponse "" [ToolCallBlock tc] (Just (Usage 2 0 0)) Nothing)+ chunks <- runStream gw [UserTurn "find x"]+ reverse chunks+ `shouldBe` [ TextDelta "searching",+ RoundTextRoleCommitted PreambleRole,+ StreamToolCallChunk tc+ ]++ it "forwards reasoning deltas unchanged" $ do+ let gw =+ streamGateway+ [StreamReasoningDelta "think"]+ (ChatResponse "ok" [TextBlock "ok"] Nothing Nothing)+ chunks <- runStream gw []+ reverse chunks `shouldBe` [ReasoningDelta "think", RoundTextRoleCommitted AnswerRole]++streamGateway :: [StreamEvent] -> ChatResponse -> LLMGateway+streamGateway events resp =+ LLMGateway+ { gwName = "stream-mock",+ gwGenerateText = \_ _ -> pure (Right resp),+ gwStreamText = \_ _ onEvent -> mapM_ onEvent events >> pure (Right resp),+ gwGenerateObject = \_ _ _ -> pure (Right (object [], Nothing))+ }++runStream :: LLMGateway -> [Turn] -> IO [StreamChunk]+runStream gw turns = do+ ref <- newIORef []+ let onChunk c = modifyIORef' ref (c :)+ gr =+ GenRequest+ { grSystemPrompt = Nothing,+ grMessages = turns,+ grTools = [],+ grAbortSignal = Nothing,+ grLLMHooks = llmHooks noHooks,+ grHooks = noHooks+ }+ mc =+ ModelConfig+ { mcGateway = gw,+ mcModel = "test",+ mcPricing = zeroPricing,+ mcMaxTokens = 256,+ mcTemperature = Nothing,+ mcThinking = Nothing,+ mcRequestTimeout = Nothing,+ mcThrottleDelay = Nothing,+ mcRetryCount = 0,+ mcJitterBackoff = 0+ }+ _ <- streamTextLLM onChunk gr mc+ readIORef ref++zeroPricing :: PricingInfo+zeroPricing = PricingInfo 0 0
+ test/LLM/TestKit.hs view
@@ -0,0 +1,244 @@+module LLM.TestKit+ ( MockRequestResponse (..),+ MockConversation,+ MockConversationMap,+ recordedConversationPrompts,+ recordedConversationSystemPrompt,+ readMockRequestResponse,+ loadRecordedConversation,+ mockProvider,+ streamChatLoop,+ streamChatLoopMain,+ recordConversation,+ writeRecordedConversation,+ mkRecordedConversationRuntime,+ recordedDeepSeekThinking,+ )+where++import Data.Aeson (FromJSON, ToJSON, Value, decodeFileStrict)+import Data.Aeson.Encode.Pretty (encodePretty)+import Data.Aeson.Types (parseMaybe)+import Data.ByteString.Lazy qualified as BSL+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Map qualified as M+import Data.Maybe (isJust)+import Data.Text (Text)+import Data.Text.IO qualified as TIO+import GHC.Generics (Generic)+import Heptapod (generate)+import LLM.Agent.Events (noEventObserver)+import LLM.Agent.Generate (generateText, streamText)+import LLM.Agent.ToolUtils (toTool)+import LLM.Agent.Types (Agent (..), RuntimeArgs (..), ToolMap)+import LLM.Core.LLMProvider (LLMProvider (..))+import LLM.Core.Types (LLMGateway, ThinkingMode (..), Turn (..))+import LLM.Core.Usage (PricingInfo (..), addUsage, emptyUsage)+import LLM.Core.Utils (parseChatResponse)+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (Hooks (..), noHooks)+import LLM.Generate.ModelConfig (ModelConfig (..), ModelWithFallbacks (..))+import LLM.Generate.Types (GenerateErrorResult (..), GenerateTextResult (..))+import LLM.WeatherTool (weatherToolTyped)+import System.Directory (createDirectoryIfMissing)+import System.FilePath (takeDirectory)++data MockRequestResponse = MockRequestResponse+ { prompt :: Maybe Text,+ request :: Value,+ response :: Value+ }+ deriving (Show, Generic)+ deriving anyclass (FromJSON, ToJSON)++type MockConversation = [MockRequestResponse]++type MockConversationMap = M.Map Value Value++recordedConversationPrompts :: [Text]+recordedConversationPrompts =+ [ "how's the weather in london?",+ "and in paris?"+ ]++recordedConversationSystemPrompt :: Text+recordedConversationSystemPrompt =+ "You are a helpful assistant who answers questions and executes tools for the user. Always use tools when asked to, but use only the tools that are available."++recordedDeepSeekThinking :: ThinkingMode+recordedDeepSeekThinking = ThinkingMode {tmEnabled = True, tmEffort = Nothing}++readMockRequestResponse :: FilePath -> IO (Maybe MockConversation)+readMockRequestResponse = decodeFileStrict++loadRecordedConversation :: FilePath -> IO (MockConversationMap, [Text])+loadRecordedConversation filePath = do+ s <- readMockRequestResponse filePath+ case s of+ Nothing -> error "can't read conversation"+ Just rrs ->+ let pairs = map (\rr -> (rr.request, rr.response)) rrs+ rrMap = M.fromList pairs+ prompts = rrs >>= \rsp -> case rsp.prompt of Nothing -> []; Just p -> [p]+ in pure (rrMap, prompts)++writeRecordedConversation :: FilePath -> MockConversation -> IO ()+writeRecordedConversation filePath conversation = do+ createDirectoryIfMissing True (takeDirectory filePath)+ BSL.writeFile filePath (encodePretty conversation)++mockProvider :: MockConversationMap -> LLMProvider -> LLMProvider+mockProvider mp adapter =+ adapter+ { sendRequest = \val -> do+ case M.lookup val mp of+ Nothing ->+ error (show val <> "\n" <> show (fst $ head $ M.toList mp))+ Just r -> pure (200, r),+ sendStreamRequest = \body _callback -> do+ case M.lookup body mp of+ Nothing -> error ("value not found for:" <> show body)+ Just r -> case parseMaybe parseChatResponse r of+ Nothing -> error "can't parse recorded ChatResponse json"+ Just chatResponse -> pure $ Right chatResponse+ }++streamChatLoopMain :: Bool -> (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs) -> [Text] -> IO ()+streamChatLoopMain stream env prompts = do+ putStrLn "\n=== recorded conversation replay ==="+ _ <- streamChatLoop stream env prompts+ pure ()++streamChatLoop :: Bool -> (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs) -> [Text] -> IO [Turn]+streamChatLoop stream (agent, models, toolMap, rt) = aux emptyUsage []+ where+ aux _totalUsage conv [] = pure conv+ aux totalUsage conv (prompt : rest) = do+ let conv' = conv ++ [UserTurn prompt]+ result <-+ if stream+ then streamText (const (pure ())) agent models toolMap rt conv'+ else generateText agent models toolMap rt conv'+ case result of+ Left (GenerateErrorResult {gerError = err}) -> do+ print err+ pure conv+ Right (GenerateTextResult {gtrUsage = usage, gtrNewMessages = newMessages}) -> do+ let conv'' = conv' ++ newMessages+ aux (addUsage totalUsage usage) conv'' rest++mkRecordedConversationRuntime ::+ LLMGateway ->+ Text ->+ Maybe ThinkingMode ->+ IORef (Maybe Text) ->+ IORef (Maybe Value) ->+ IORef [MockRequestResponse] ->+ IO (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs)+mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef entriesRef = do+ genId <- generate+ let hooks = recordingHooks promptRef pendingRef entriesRef+ agent =+ Agent+ { agName = "test",+ agSystemPrompt = Just recordedConversationSystemPrompt,+ agTools = ["get_weather"],+ agMaxToolRounds = 3,+ agContextWindow = Nothing+ }+ modelConf =+ ModelConfig+ { mcGateway = gateway,+ mcModel = modelName,+ mcPricing = PricingInfo {pricePerMillionInput = 0.0, pricePerMillionOutput = 0.0},+ mcMaxTokens = 1024,+ mcTemperature = Nothing,+ mcThinking = thinking,+ mcRequestTimeout = Nothing,+ mcThrottleDelay = Nothing,+ mcRetryCount = 3,+ mcJitterBackoff = 1_000+ }+ models = ModelWithFallbacks modelConf []+ toolMap = M.fromList [("get_weather", toTool weatherToolTyped)]+ rt =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks hooks,+ rtHooks = hooks,+ rtOnEvent = noEventObserver,+ rtReadonly = False+ }+ pure (agent, models, toolMap, rt)++recordConversation :: Bool -> LLMGateway -> Text -> Maybe ThinkingMode -> FilePath -> IO MockConversation+recordConversation stream gateway modelName thinking outPath = do+ promptRef <- newIORef Nothing+ pendingRef <- newIORef Nothing+ entriesRef <- newIORef []+ env <- mkRecordedConversationRuntime gateway modelName thinking promptRef pendingRef entriesRef+ turns <- recordStreamChatLoop stream promptRef env recordedConversationPrompts+ entries <- readIORef entriesRef+ let conversation = reverse entries+ writeRecordedConversation outPath conversation+ putStrLn $+ unlines+ [ "Wrote " <> outPath,+ " entries: " <> show (length conversation),+ " turns: " <> show (length turns)+ ]+ pure conversation++recordStreamChatLoop ::+ Bool ->+ IORef (Maybe Text) ->+ (Agent, ModelWithFallbacks, ToolMap Text, RuntimeArgs) ->+ [Text] ->+ IO [Turn]+recordStreamChatLoop stream promptRef (agent, models, toolMap, rt) = aux emptyUsage []+ where+ aux _totalUsage conv [] = pure conv+ aux totalUsage conv (prompt : rest) = do+ writeIORef promptRef (Just prompt)+ TIO.putStrLn $ "> " <> prompt+ let conv' = conv ++ [UserTurn prompt]+ result <-+ if stream+ then streamText (const (pure ())) agent models toolMap rt conv'+ else generateText agent models toolMap rt conv'+ case result of+ Left (GenerateErrorResult {gerError = err}) -> do+ print err+ pure conv+ Right (GenerateTextResult {gtrUsage = usage, gtrNewMessages = newMessages}) -> do+ let conv'' = conv' ++ newMessages+ aux (addUsage totalUsage usage) conv'' rest++recordingHooks ::+ IORef (Maybe Text) ->+ IORef (Maybe Value) ->+ IORef [MockRequestResponse] ->+ Hooks+recordingHooks promptRef pendingRef entriesRef =+ noHooks+ { onRequest = \_ req -> writeIORef pendingRef (Just req),+ onResponse = \_ resp -> do+ mReq <- readIORef pendingRef+ mPrompt <- readIORef promptRef+ case mReq of+ Nothing -> pure ()+ Just req -> do+ let entry = MockRequestResponse mPrompt req resp+ entriesRef `modifyIORef'` (entry :)+ writeIORef pendingRef Nothing+ whenJustPrompt mPrompt $ writeIORef promptRef Nothing+ }+ where+ whenJustPrompt :: Maybe Text -> IO () -> IO ()+ whenJustPrompt mp act = if isJust mp then act else pure ()++modifyIORef' :: IORef a -> (a -> a) -> IO ()+modifyIORef' ref f = do+ v <- readIORef ref+ writeIORef ref (f v)
+ test/LLM/ToolUtilsSpec.hs view
@@ -0,0 +1,74 @@+module LLM.ToolUtilsSpec (spec) where++import Data.Aeson (Value (Null), object, (.=))+import Data.Text (Text)+import Data.Text qualified as T+import Heptapod (generate)+import LLM.Agent.ToolUtils (executeTool)+import LLM.Agent.Types (RuntimeArgs (..), Tool (..), ToolContext (..))+import LLM.Core.Types (ToolCall (..), ToolDef (..), ToolResult (..))+import LLM.Generate.GenerateUtils (llmHooks)+import LLM.Generate.Logger (noHooks)+import Test.Hspec (Spec, describe, it, shouldContain)++spec :: Spec+spec = describe "ToolUtils" $ do+ describe "executeTool" $ do+ it "refuses mutating tools when rtReadonly is True" $ do+ genId <- generate+ let writeTool =+ Tool+ { toolDef =+ ToolDef+ { toolName = "writefile",+ toolDescription = "test",+ toolReadonly = False,+ toolParameters = Null+ },+ toolExecute = \_ _ -> pure ("wrote" :: Text)+ }+ readonlyTool =+ Tool+ { toolDef =+ ToolDef+ { toolName = "grep",+ toolDescription = "test",+ toolReadonly = True,+ toolParameters = Null+ },+ toolExecute = \_ _ -> pure ("found" :: Text)+ }+ rt =+ RuntimeArgs+ { rtGenerationId = genId,+ rtAbortSignal = Nothing,+ rtLLMHooks = llmHooks noHooks,+ rtHooks = noHooks,+ rtOnEvent = \_ -> pure (),+ rtReadonly = True+ }+ ctx =+ ToolContext+ { tcConversation = [],+ tcUsage = mempty,+ tcWindowOffset = 0,+ tcRuntimeArgs = rt+ }+ writeCall =+ ToolCall+ { tcId = "1",+ tcName = "writefile",+ tcArguments = object ["path" .= ("x" :: Text), "content" .= ("y" :: Text)],+ tcProviderMeta = Nothing+ }+ readCall =+ ToolCall+ { tcId = "2",+ tcName = "grep",+ tcArguments = object ["pattern" .= ("x" :: Text)],+ tcProviderMeta = Nothing+ }+ writeResult <- executeTool noHooks ctx [writeTool] writeCall+ readResult <- executeTool noHooks ctx [readonlyTool] readCall+ T.unpack writeResult.trContent `shouldContain` "readonly mode"+ T.unpack readResult.trContent `shouldContain` "found"
+ test/LLM/TypesSpec.hs view
@@ -0,0 +1,78 @@+module LLM.TypesSpec (spec) where++import Data.Aeson (object, (.=))+import LLM.Core.Types+ ( ChatResponse (ChatResponse),+ ContentBlock (TextBlock, ToolCallBlock),+ LLMError (EmptyResponse, HttpError, NetworkError),+ mkToolCall,+ )+import LLM.Core.Usage+ ( PricingInfo (..),+ Usage (..),+ addUsage,+ emptyUsage,+ estimateCost,+ pricePerMillionInput,+ pricePerMillionOutput,+ usageInputTokens,+ usageOutputTokens,+ )+import LLM.Core.Utils+ ( getToolCalls,+ hasToolCalls,+ isRetryable,+ )+import Test.Hspec (Spec, describe, it, shouldBe)++spec :: Spec+spec = describe "Types" $ do+ describe "Usage" $ do+ it "emptyUsage has zero tokens" $ do+ emptyUsage.usageInputTokens `shouldBe` 0+ emptyUsage.usageOutputTokens `shouldBe` 0++ it "addUsage sums token counts" $ do+ let u1 = Usage 10 20 0+ u2 = Usage 30 40 0+ addUsage u1 u2 `shouldBe` Usage 40 60 0++ it "addUsage is associative" $ do+ let u1 = Usage 1 2 0+ u2 = Usage 3 4 0+ u3 = Usage 5 6 0+ addUsage (addUsage u1 u2) u3 `shouldBe` addUsage u1 (addUsage u2 u3)++ describe "estimateCost" $ do+ it "calculates cost in dollars from per-million pricing" $ do+ let pricing = PricingInfo {pricePerMillionInput = 1.0, pricePerMillionOutput = 5.0}+ usage = Usage 1_000_000 1_000_000 0+ estimateCost pricing usage `shouldBe` 6.0++ it "returns 0 for zero usage" $ do+ let pricing = PricingInfo {pricePerMillionInput = 1.0, pricePerMillionOutput = 5.0}+ estimateCost pricing emptyUsage `shouldBe` 0.0++ describe "hasToolCalls / getToolCalls" $ do+ it "returns False for text-only response" $ do+ let resp = ChatResponse "hello" [TextBlock "hello"] Nothing Nothing+ hasToolCalls resp `shouldBe` False+ getToolCalls resp `shouldBe` []++ it "returns True when tool calls present" $ do+ let tc = mkToolCall "id1" "get_weather" (object ["location" .= ("London" :: String)])+ resp = ChatResponse "" [ToolCallBlock tc] Nothing Nothing+ hasToolCalls resp `shouldBe` True+ getToolCalls resp `shouldBe` [tc]++ describe "isRetryable" $ do+ it "retries on 429" $ do+ isRetryable (HttpError 429 "rate limited") `shouldBe` True+ it "retries on 503" $ do+ isRetryable (HttpError 503 "overloaded") `shouldBe` True+ it "retries on network errors" $ do+ isRetryable (NetworkError "connection refused") `shouldBe` True+ it "does not retry on 400" $ do+ isRetryable (HttpError 400 "bad request") `shouldBe` False+ it "does not retry on empty response" $ do+ isRetryable EmptyResponse `shouldBe` False
+ test/LLM/WeatherTool.hs view
@@ -0,0 +1,38 @@+module LLM.WeatherTool (weatherToolTyped, WeatherToolArgs (..)) where++import Autodocodec qualified as AC+import Data.Aeson (FromJSON)+import Data.Text (Text, toLower)+import GHC.Generics (Generic)+import LLM.Core.Types (TypedTool (..))++newtype WeatherToolArgs = WeatherToolArgs+ { _weatherLocation :: Text+ }+ deriving (Generic)+ deriving (FromJSON) via (AC.Autodocodec WeatherToolArgs)++instance AC.HasCodec WeatherToolArgs where+ codec :: AC.JSONCodec WeatherToolArgs+ codec =+ AC.object "WeatherToolArgs" $+ WeatherToolArgs+ <$> AC.requiredField "location" "City name, e.g. London" AC..= (._weatherLocation)++weatherToolTyped :: TypedTool ctx WeatherToolArgs+weatherToolTyped =+ TypedTool+ { ttoolName = "get_weather",+ ttoolDescription = "Get the current weather for a given location",+ ttoolReadonly = False,+ ttoolExecute = const getWeather+ }++-- | Dummy implementation for recorded-conversation tests.+getWeather :: WeatherToolArgs -> IO Text+getWeather args = do+ let loc = args._weatherLocation+ case toLower loc of+ "london" -> pure "Weather in London is partly cloudy, 18°C, light breeze from the west."+ "paris" -> pure "Weather in Paris is sunny, 23°C, no wind."+ _ -> pure $ "Weather in" <> loc <> " is rainy, 12°C, strong wind from the east."
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}