diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Revision history for mcp-server +## 0.2.0.2 - 2026-09-08 + +* stdio: in-flight requests are drained at stdin EOF instead of being + cancelled. Since 0.2.0.1 made stdio requests concurrent, a client that + wrote its requests and closed stdin straight away (scripts, `echo ... | + server`, conformance replays) lost the responses to whatever was still + running when EOF arrived — most visibly the last request in the batch. + Per the lifecycle spec the client closes stdin and then waits for the + server to exit, so the server now finishes outstanding work and writes + those responses before shutting down. Subscription streams are still + closed at EOF as before, and `notifications/cancelled` still interrupts + a running request. +* A handler that throws an exception (rather than returning an error + value such as `toolError`) now yields a `-32603` internal-error response + for its request id, on both transports and in both protocol eras. + Previously the exception escaped the transport: on stdio the request's + task died silently and the client waited forever for that id; on HTTP + Warp answered a bare text/plain 500 (single-JSON responses) or dropped + the connection with an empty body (SSE responses). The exception's first + line is the error message; the full rendering (including any call + stack) is logged to stderr. Asynchronous exceptions are rethrown + untouched, so cancellation is unaffected. + ## 0.2.0.1 - 2026-08-01 (Supersedes 0.2.0.0, which is **deprecated on Hackage**: it was published diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,106 +1,209 @@ # mcp-server -A fully-featured Haskell library for building [Model Context Protocol (MCP)](https://modelcontextprotocol.io/) servers. +[![Hackage](https://img.shields.io/hackage/v/mcp-server.svg)](https://hackage.haskell.org/package/mcp-server) +[![CI](https://github.com/drshade/haskell-mcp-server/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/drshade/haskell-mcp-server/actions/workflows/haskell-ci.yml) -## Features +Build [Model Context Protocol](https://modelcontextprotocol.io/) servers in +Haskell from plain data types. Declare your tools, prompts and resources as +ADTs, write one handler per type, and the library derives the JSON schemas, +argument decoding, validation and wire protocol for you — then serves it over +stdio or Streamable HTTP to Claude Code, Codex, Claude Desktop, Cursor and any +other MCP client. -- **Complete MCP Implementation**: Dual-era server — legacy revisions `2024-11-05` through `2025-11-25` via the `initialize` handshake, and the stateless `2026-07-28` revision via per-request `_meta` (including `server/discover`, `resultType`, and cacheability fields) -- **Type-Safe API**: Leverage Haskell's type system for robust MCP servers -- **Multiple Abstractions**: Both low-level fine-grained control and high-level derived interfaces -- **Template Haskell Support**: Automatic handler derivation from data types -- **Multiple Transports**: STDIO and HTTP Streaming transport (MCP Streamable HTTP) +```haskell +{-# LANGUAGE OverloadedStrings, TemplateHaskell #-} -## Supported MCP Features +import Data.Text (Text) +import MCP.Server +import MCP.Server.Derive -- ✅ **Prompts**: User-controlled prompt templates with arguments -- ✅ **Resources**: Application-controlled readable resources -- ✅ **Resource Templates**: Parameterized resources via URI templates -- ✅ **Tools**: Model-controlled callable functions -- ✅ **Completions**: Argument autocompletion for prompts and templates -- ✅ **Change Notifications**: `listChanged`/resource-update pushes, via `subscriptions/listen` (2026-07-28) or legacy stdio delivery -- ✅ **Progress & Logging**: `notifications/progress` and `notifications/message` scoped to the requesting client -- ✅ **Cancellation**: `notifications/cancelled` (stdio) and stream closure (HTTP) interrupt in-flight handlers -- ✅ **Initialization Flow**: Complete protocol lifecycle with version negotiation -- ✅ **Error Handling**: Comprehensive error types and JSON-RPC error responses +data Units = Celsius | Fahrenheit -## Quick Start +data WeatherTool + = CurrentWeather { city :: Text, units :: Maybe Units } + | Forecast { city :: Text, days :: Int } -Add the library `mcp-server` to your cabal file: +handleTool :: ClientContext -> WeatherTool -> IO Content +handleTool _ (CurrentWeather c _) = pure $ ContentText $ "Sunny in " <> c +handleTool _ (Forecast c n) = pure $ ContentText $ "Forecast for " <> c +$(pure []) -- end the declaration group so the splice below can see the types + +main :: IO () +main = runMcpServerStdio serverInfo noHandlers + { tools = Just $(deriveToolHandler ''WeatherTool 'handleTool) } + where + serverInfo = McpServerInfo + { serverName = "weather", serverVersion = "1.0.0" + , serverInstructions = "Weather lookups" } +``` + +That is a complete, working MCP server exposing two tools, `current_weather` +and `forecast`, each with a JSON schema derived from its constructor's fields. + +## What you get for free + +The derivation reads your types, so the schema on the wire always matches the +handler that receives the arguments. Given this constructor from +[`examples/Complete`](examples/Complete/Types.hs): + +```haskell +data ShippingSpeed = Standard | Express | Overnight + +data Address = Address + { street :: Text + , city :: Text + , zipCode :: Maybe Text + } + +data MyTool + = Checkout { speed :: ShippingSpeed, shipTo :: Address } + | ... +``` + +`tools/list` returns exactly this (captured from the running example): + +```json +{ + "name": "checkout", + "description": "Checkout", + "annotations": { "destructiveHint": true }, + "inputSchema": { + "type": "object", + "required": ["speed", "shipTo"], + "properties": { + "speed": { "type": "string", "enum": ["standard", "express", "overnight"] }, + "shipTo": { + "type": "object", + "required": ["street", "city"], + "properties": { + "street": { "type": "string" }, + "city": { "type": "string" }, + "zipCode": { "type": "string" } + } + } + } + } +} +``` + +and a `tools/call` with matching arguments arrives in your handler as a fully +decoded `Checkout Express (Address "1 Main St" "Springfield" Nothing)`. +Malformed arguments never reach you; the library answers with the appropriate +JSON-RPC error. The same machinery works in reverse for typed results (see +[Structured output](#structured-output)). + +Beyond the derivation, the library handles: + +- **Both protocol eras.** Legacy revisions `2024-11-05` through `2025-11-25` + negotiated via `initialize`, and the stateless `2026-07-28` revision + declared per request in `_meta`, from one server binary. +- **Two transports.** stdio, and Streamable HTTP with bearer auth, Origin + validation, per-request SSE and a plain WAI application you can embed. +- **Long-running tools.** Progress notifications, per-request client logging, + and cancellation of in-flight requests on both transports. +- **Live servers.** `listChanged` and resource-update pushes over + `subscriptions/listen`. +- **Conformance fixtures.** A language-agnostic corpus of request/response + pairs the test suite replays against every protocol era. + +## Installation + +Add `mcp-server` to your `build-depends`: + ```cabal build-depends: - mcp-server + base, text, mcp-server ``` -Create a simple module, such as this example below: +Tested against GHC 9.6 through 9.14 in CI. The HTTP transport requires +`ghc-options: -threaded` (Warp needs the threaded runtime). -```haskell -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} +## Connecting to a client -import Data.Text (Text) -import MCP.Server -import MCP.Server.Derive +Build your server, then register it with your client of choice. The examples +below use the `simple-example` executable from this repository; substitute +your own. --- Define your data types -data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text } -data MyResource = Menu | Specials -data MyTool = Search { query :: Text } | Order { item :: Text } +### Claude Code --- Implement handlers. Every handler receives the per-request 'ClientContext' --- (the caller's bearer token and principal on the HTTP transport) first. -handlePrompt :: ClientContext -> MyPrompt -> IO Content -handlePrompt _ (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea -handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items +```bash +# stdio: everything after -- is the command Claude Code spawns +claude mcp add my-server -- "$(cabal list-bin exe:simple-example)" -handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent -handleResource _ uri Menu = pure $ ResourceText uri "text/plain" "Today's menu..." -handleResource _ uri Specials = pure $ ResourceText uri "text/plain" "Daily specials..." +# pass environment variables with --env +claude mcp add my-server --env API_KEY=secret -- /path/to/my-server -handleTool :: ClientContext -> MyTool -> IO Content -handleTool _ (Search query) = pure $ ContentText $ "Search results for " <> query -handleTool _ (Order item) = pure $ ContentText $ "Ordered " <> item +# Streamable HTTP +claude mcp add --transport http my-server http://localhost:3000/mcp +``` --- Template Haskell staging: this empty splice ends the declaration group, --- so the derive splices below can see the types above. (Alternatively, --- declare the types in a separate module, as the examples/ do.) -$(pure []) +Verify with `claude mcp list` or `/mcp` inside a session. Add +`--scope project` to write a `.mcp.json` you can commit for your team: --- Derive handlers automatically -main :: IO () -main = runMcpServerStdio serverInfo handlers - where - serverInfo = McpServerInfo - { serverName = "My MCP Server" - , serverVersion = "1.0.0" - , serverInstructions = "A sample MCP server" - } - -- Start from 'noHandlers' and record-update the features you provide: - -- constructing McpServerHandlers directly breaks (at runtime!) when a - -- field is missed, and the library grows new handler slots over time. - handlers = noHandlers - { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) - , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) - , tools = Just $(deriveToolHandler ''MyTool 'handleTool) - } +```json +{ + "mcpServers": { + "my-server": { + "type": "stdio", + "command": "/path/to/my-server", + "env": { "API_KEY": "${API_KEY}" } + } + } +} ``` -### Advanced Template Haskell Features +Cursor and several other clients read the same `mcpServers` shape. -#### Automatic Naming Conventions +### Codex -Constructor names are automatically converted to snake_case for MCP names: +```bash +codex mcp add my-server --env API_KEY=secret -- /path/to/my-server +``` -```haskell -data MyTool = GetValue | SetValue | SearchItems --- Becomes: "get_value", "set_value", "search_items" +Or in `~/.codex/config.toml`, which is also where HTTP servers go: + +```toml +[mcp_servers.my-server] +command = "/path/to/my-server" + +[mcp_servers.my-http-server] +url = "http://localhost:3000/mcp" ``` -#### Typed Tool Arguments +### Claude Desktop -Tool arguments are decoded from full JSON values, and the generated -`inputSchema` mirrors the field types: +Claude Desktop launches stdio servers from `claude_desktop_config.json`. A +Docker image is a convenient way to ship a Haskell binary to it — the +repository's [`Dockerfile`](Dockerfile) builds all three examples: +```bash +docker build -t haskell-mcp-server . +``` + +```json +{ + "mcpServers": { + "simple-example": { + "command": "docker", + "args": ["run", "-i", "--entrypoint=/usr/local/bin/simple-example", "haskell-mcp-server"] + } + } +} +``` + +### Keep stdout clean + +On stdio, `stdout` carries only JSON-RPC. The library writes nothing else +there, and your handlers must not either: log to `stderr`. + +## Defining tools + +### Naming and arguments + +Constructor names become snake_case tool names; record fields become named +arguments. The generated `inputSchema` mirrors the field types: + ```haskell data Color = Red | Green | Blue -- all-nullary type: string enum data Filters = Filters -- record: nested JSON object @@ -108,54 +211,73 @@ , maxCount :: Maybe Int -- Maybe: optional field } -data MyTool = Search - { query :: Text - , color :: Color -- "red" | "green" | "blue" - , filters :: Filters -- { "tags": [...], "maxCount": ... } - , limit :: Maybe Int - } +data MyTool + = SearchItems -- "search_items" + { query :: Text + , color :: Color -- "red" | "green" | "blue" + , filters :: Filters -- { "tags": [...], "maxCount": ... } + , limit :: Maybe Int + } ``` Primitive fields (`Int`, `Integer`, `Double`, `Float`, `Bool`, `Text`) are -parsed leniently: the native JSON type and its string representation are -both accepted (`42` or `"42"`), since many clients send numbers and -booleans as strings. +parsed leniently: `42` and `"42"` are both accepted, since many clients send +numbers and booleans as strings. -Prompt arguments are string-valued per the MCP specification, so prompt -records are limited to primitive and enumeration fields. +A constructor may also wrap a single record type, which is unwrapped +recursively until a record is found: -#### Tool Results +```haskell +data SetValueParams = SetValueParams { key :: Text, value :: Text } -Simple handlers can return plain `Content` (or `Text`). Return a full -`ToolResult` for multiple content blocks, structured content, or to report -execution failures with `isError` — which the spec prefers over protocol -errors, so the model can see what went wrong and react: +data SimpleTool + = GetValue { key :: Text } + | SetValue SetValueParams -- fields of SetValueParams are the arguments +``` +Positional (unnamed) fields are not supported, because they have no names to +put in the schema: + ```haskell +data SimpleTool = GetValue Int | SetValue Int Text -- ❌ rejected +``` + +### Results and errors + +Simple handlers return `Content` (or `Text`). Return a `ToolResult` for +multiple content blocks or to report an execution failure with `isError`, +which the spec prefers over a protocol error so the model can see what went +wrong and react: + +```haskell handleTool :: ClientContext -> MyTool -> IO ToolResult -handleTool _ (Search q _ _ _) +handleTool _ (SearchItems q _ _ _) | T.null q = pure $ toolError "query must not be empty" | otherwise = pure $ toolResult [ContentText ("Results for " <> q)] ``` -Prompt handlers can likewise return a `PromptResult` with a description and -a multi-message conversation (user and assistant roles). +Content blocks can carry annotations (`audience`, `priority`, +`lastModified`) via the `ContentAnnotated` wrapper: -#### Derived Output Schemas +```haskell +ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 } + (ContentText "important result") +``` -Tools can be typed on the way out too: give the derivation a result record -and it derives the tool's `outputSchema` (same field rules as inputs — -primitives, `Maybe`, lists, enums, nested records) and serializes your typed -values into `structuredContent`, guaranteed to match the schema. Per the -spec's recommendation, the JSON is also returned as a text content block for -clients that predate structured output: +### Structured output +Give the derivation a result type and it derives the tool's `outputSchema` +(same field rules as inputs) and serializes your value into +`structuredContent`, guaranteed to match. Per the spec's recommendation the +JSON is also returned as a text block for clients that predate structured +output: + ```haskell data WeatherReport = WeatherReport { temperature :: Int , sky :: Sky -- enum , alerts :: [Text] - , humidity :: Maybe Int -- optional, omitted when Nothing + , humidity :: Maybe Int -- omitted when Nothing } handleTool :: ClientContext -> MyTool -> IO (ToolOutput WeatherReport) @@ -168,160 +290,208 @@ `ToolOutputWith` supplies custom content blocks alongside the structured value; `ToolOutputRaw` is the escape hatch back to a plain `ToolResult`. -#### Nested Parameter Types +### Descriptions, annotations and icons -You can nest parameter types with automatic unwrapping: +Every `derive*` function has a `WithDescription` variant taking a flat list of +constructor and field descriptions, and a `WithOptions` variant taking +per-constructor `DefinitionOptions`: description, title, icons, behavioral +annotations (which drive client permission UX, such as auto-approving +read-only tools) and argument descriptions scoped to that constructor. ```haskell --- Parameter record types -data GetValueParams = GetValueParams { _gvpKey :: Text } -data SetValueParams = SetValueParams { _svpKey :: Text, _svpValue :: Text } - --- Main tool type -data SimpleTool - = GetValue GetValueParams - | SetValue SetValueParams - deriving (Show, Eq) +descriptions = + [ ("SearchItems", "Search the catalog") -- constructor + , ("query", "Search terms") -- field + ] +tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) ``` -The Template Haskell derivation recursively unwraps single-parameter constructors until it reaches a record type, then extracts all fields for the MCP schema. +```haskell +tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool + [ ("SearchItems", defaultDefinitionOptions + { optDescription = Just "Search the catalog" + , optToolAnnotations = Just defaultToolAnnotations + { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } + , optIcons = [icon "https://example.com/search.png"] + , optFieldDescriptions = [("query", "Search terms")] + }) + ]) +``` -#### Resource URI Generation +## Defining prompts -Resources automatically get `resource://` URIs based on constructor names: +Prompts derive the same way. Arguments are string-valued per the spec, so +prompt records are limited to primitive and enumeration fields: ```haskell -data MyResource = Menu | Specials --- Generates: "resource://menu", "resource://specials" +data MyPrompt = Recipe { idea :: Text } | Shopping { items :: Text } + +handlePrompt :: ClientContext -> MyPrompt -> IO Content +handlePrompt _ (Recipe idea) = pure $ ContentText $ "Recipe for " <> idea +handlePrompt _ (Shopping items) = pure $ ContentText $ "Shopping list: " <> items + +prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) ``` -#### Resource Templates +Return a `PromptResult` instead of `Content` for a description and a +multi-message conversation with user and assistant roles. -Record constructors become parameterized resource *templates* (RFC 6570 URI -templates), with one percent-decoded path segment per field: +## Defining resources +Nullary constructors become static resources with `resource://` URIs; record +constructors become resource *templates* (RFC 6570), one percent-decoded path +segment per field: + ```haskell data MyResource - = Menu -- static: resource://menu + = Menu -- resource://menu | ProductDetail { sku :: Text } -- resource://product_detail/{sku} | OrderItem { orderId :: Int, itemName :: Text } -- resource://order_item/{orderId}/{itemName} -``` -The read handler derived by `deriveResourceHandler` matches template URIs -(e.g. `resource://product_detail/ABC123`) and decodes the segments into the -constructor's fields — typed fields like `Int` are parsed, and a failing -segment yields an invalid-params error. Advertise the templates via -`resources/templates/list` with: +handleResource :: ClientContext -> URI -> MyResource -> IO ResourceContent +handleResource _ uri Menu = pure $ ResourceText uri "text/plain" "Today's menu..." +handleResource _ uri (ProductDetail sku) = pure $ ResourceText uri "text/plain" ("Details for " <> sku) +handleResource _ uri (OrderItem o i) = ... -```haskell +resources = Just $(deriveResourceHandler ''MyResource 'handleResource) resourceTemplates = Just $(deriveResourceTemplates ''MyResource) ``` -#### Argument Completion +The read handler matches template URIs such as +`resource://product_detail/ABC123` and decodes the segments into the +constructor's fields; typed fields like `Int` are parsed, and a failing +segment yields an invalid-params error. +## Argument completion + Provide a `completions` handler to serve `completion/complete` for prompt -arguments and resource-template parameters: +arguments and resource-template parameters. The capability is advertised +automatically when the handler is present: ```haskell -handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text -> IO (Either Error CompletionResult) +handleComplete :: ClientContext -> CompletionRef -> ArgumentName -> Text -> Map Text Text + -> IO (Either Error CompletionResult) handleComplete _ (CompletionRefPrompt "recipe") "idea" partial _ = pure $ Right $ completionResult $ filter (T.isPrefixOf partial) ["pancakes", "pasta", "pizza"] handleComplete _ _ _ _ _ = pure $ Right $ completionResult [] -``` -The `completions` capability is advertised automatically when the handler is -present. +handlers = noHandlers { completions = Just handleComplete, ... } +``` -#### Unsupported Patterns +## Assembling the server -We do not support positional (unnamed) parameters: +Start from `noHandlers` and record-update the features you provide. +Constructing `McpServerHandlers` directly is discouraged: the library grows +new handler slots over time, and a missed field fails at runtime rather than +compile time. ```haskell --- ❌ This won't work - no field names -data SimpleTool - = GetValue Int - | SetValue Int Text +handlers = noHandlers + { prompts = Just $(derivePromptHandler ''MyPrompt 'handlePrompt) + , resources = Just $(deriveResourceHandler ''MyResource 'handleResource) + , resourceTemplates = Just $(deriveResourceTemplates ''MyResource) + , tools = Just $(deriveToolHandler ''MyTool 'handleTool) + , completions = Just handleComplete + } ``` -All parameter types must ultimately resolve to records with named fields to generate proper MCP schemas. +Two Template Haskell details to know: -#### Tool Annotations, Icons and Titles +- A `derive*` splice can only see types declared in an earlier declaration + group. Either put the types in their own module (as the + [examples](examples/) do) or end the group with an empty `$(pure [])` + splice before the `main` that uses them. +- Every handler receives the per-request `ClientContext` first. It carries the + caller's bearer token and principal on HTTP, the protocol revision and + client identity for modern clients, and the `reportProgress` and + `logToClient` actions described below. -The `WithOptions` derivation variants take per-constructor -`DefinitionOptions` — description, title, icons, behavioral annotations -(which drive client permission UX, e.g. auto-approving read-only tools), -and argument descriptions scoped to the constructor: +### Manual handlers +The derived handlers are ordinary values, so for full control you can supply +your own instead. Prompt arguments arrive as `Map Text Text`, tool arguments +as `Map Text Value`: + ```haskell -tools = Just $(deriveToolHandlerWithOptions ''MyTool 'handleTool - [ ("Search", defaultDefinitionOptions - { optDescription = Just "Search the catalog" - , optToolAnnotations = Just defaultToolAnnotations - { toolReadOnlyHint = Just True, toolIdempotentHint = Just True } - , optIcons = [icon "https://example.com/search.png"] - , optFieldDescriptions = [("q", "Search terms")] - }) - ]) +promptListHandler :: ClientContext -> IO [PromptDefinition] +promptGetHandler :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) + +handlers = noHandlers { prompts = Just (promptListHandler, promptGetHandler) } ``` -Content blocks can carry annotations too (`audience`, `priority`, -`lastModified`), attached with the `ContentAnnotated` wrapper: +## Transports +### stdio + +`runMcpServerStdio serverInfo handlers` serves JSON-RPC over stdin and +stdout. `runMcpServerStdioWithConfig` takes a `StdioConfig` for verbose +request logging on stderr, cacheability hints for modern clients, and a +change-notification source. + +### Streamable HTTP + ```haskell -ContentAnnotated defaultAnnotations { annotationsPriority = Just 0.9 } - (ContentText "important result") +import MCP.Server.Transport.Http + +main = runMcpServerHttp serverInfo handlers -- localhost:3000/mcp + +main = runMcpServerHttpWithConfig defaultHttpConfig + { httpPort = 8080 + , httpHost = "0.0.0.0" + , httpEndpoint = "/api/mcp" + , httpVerbose = True -- request/response logging on stderr + , httpAllowedOrigins = Just ["https://app.example.com"] + } serverInfo handlers ``` -## Custom Descriptions +`httpAllowedOrigins` is DNS-rebinding protection: requests carrying an +`Origin` outside the list get 403. `Nothing` disables the check and is only +appropriate for servers unreachable from browsers. -You can provide custom descriptions for constructors and fields using the `*WithDescription` variants: +**Bearer-token authentication** is a callback. Return `Just principal` (any +JSON `Value`, such as a role) to admit the request, or `Nothing` for 401. The +principal reaches handlers as `clientPrincipal` in the `ClientContext`; token +policy lives entirely in your application. ```haskell --- Define descriptions for constructors and fields -descriptions :: [(String, String)] -descriptions = - [ ("Recipe", "Generate a recipe for a specific dish") -- Constructor description - , ("Search", "Search our menu database") -- Constructor description - , ("idea", "The dish you want a recipe for") -- Field description - , ("query", "Search terms to find menu items") -- Field description - ] - --- Use in derivation -handlers = noHandlers - { prompts = Just $(derivePromptHandlerWithDescription ''MyPrompt 'handlePrompt descriptions) - , tools = Just $(deriveToolHandlerWithDescription ''MyTool 'handleTool descriptions) - , resources = Just $(deriveResourceHandlerWithDescription ''MyResource 'handleResource descriptions) +defaultHttpConfig + { httpAuthorize = Just $ \mtoken -> case mtoken of + Just "secret-admin-token" -> pure $ Just (String "admin") + Just "secret-user-token" -> pure $ Just (String "user") + _ -> pure Nothing } ``` -## Manual Handler Implementation +The endpoint accepts POST only. Server-to-client notifications flow over the +`subscriptions/listen` POST response stream rather than the deprecated +standalone GET stream, and CORS is enabled for web clients. -For fine-grained control, implement handlers manually: +### Embedding in an existing WAI stack -```haskell -import MCP.Server +The MCP endpoint is a plain [WAI](https://hackage.haskell.org/package/wai) +application, exported as `mcpApplication`, so it can be mounted inside your +own Warp settings, TLS, middleware or router: --- Manual handler implementation. Every handler receives the per-request --- 'ClientContext' as its first argument. Prompt arguments are string-valued --- (Map Text Text); tool arguments are full JSON values (Map Text Value). -promptListHandler :: ClientContext -> IO [PromptDefinition] -promptGetHandler :: ClientContext -> PromptName -> Map Text Text -> IO (Either Error PromptResult) --- ... implement your custom logic +```haskell +import MCP.Server (mcpApplication, defaultHttpConfig) +import qualified Network.Wai.Handler.Warp as Warp -main :: IO () -main = runMcpServerStdio serverInfo handlers - where - handlers = noHandlers - { prompts = Just (promptListHandler, promptGetHandler) - } +main = Warp.runSettings mySettings $ \req respond -> + -- route /mcp to the MCP endpoint, everything else to your app + mcpApplication defaultHttpConfig serverInfo handlers req respond ``` -## Progress and Per-Request Logging +`httpPort` and `httpHost` are ignored when embedding; the endpoint path, +Origin validation, bearer auth and streaming all apply as usual. -Handlers can report progress on long-running work and send log messages to -the calling client through actions on the `ClientContext`: +## Long-running tools +### Progress and logging + +Handlers report progress and send log messages to the calling client through +actions on the `ClientContext`. Both are safe to call unconditionally: + ```haskell handleTool ctx (ImportData file) = do reportProgress ctx 0.0 (Just 1.0) (Just "starting import") @@ -330,44 +500,32 @@ reportProgress ctx 1.0 (Just 1.0) Nothing ``` -Both are safe to call unconditionally: - - `reportProgress` emits `notifications/progress` only when the request - carried a `progressToken` (progress values must increase call over call). + carried a `progressToken`. Progress values must increase call over call. - `logToClient` emits `notifications/message` only when the request declared - `io.modelcontextprotocol/logLevel` — the spec forbids it otherwise — and - drops messages below the declared level. - -Delivery is transport-appropriate: on stdio the notifications interleave -before the response; on HTTP, a request that opted in is answered with an -SSE response stream carrying the notifications followed by the final -response (requests that didn't opt in keep the single-JSON response). + `io.modelcontextprotocol/logLevel`, as the spec requires, and drops + messages below the declared level. -## Cancellation +On stdio the notifications interleave before the response. On HTTP, a request +that opted in is answered with an SSE stream carrying the notifications +followed by the final response; other requests keep the single-JSON response. -In-flight requests can be cancelled, and per the spec the server then stops -work as soon as practical and sends nothing further for that request: +### Cancellation -- **stdio**: each request runs in its own task; a `notifications/cancelled` - naming its id cancels the task (cancellations for unknown or completed ids - are ignored, as required). -- **HTTP**: closing the response stream is the cancellation signal. For SSE - responses the handler is cancelled as soon as the disconnect is detected - (within one keep-alive interval). For single-JSON responses a disconnect - is only detected at the final write — the handler runs to completion - first — so mid-handler cancellation applies to streaming requests: - clients wanting cancellable calls should opt into streaming via a - `progressToken`. +In-flight requests can be cancelled, after which the server stops work as soon +as practical and sends nothing further for that request: -A consequence of cancellable requests: **requests are now served -concurrently on both transports** (stdio previously processed them strictly -sequentially). Handlers touching shared mutable state must synchronize -(`MVar`, `STM`, ...) — as was already required for HTTP servers. +- **stdio**: each request runs in its own task, and a `notifications/cancelled` + naming its id cancels that task. Unknown or completed ids are ignored. +- **HTTP**: closing the response stream is the cancellation signal. SSE + responses detect the disconnect within one keep-alive interval. Single-JSON + responses only detect it at the final write, so clients wanting cancellable + calls should opt into streaming via a `progressToken`. -Cancellation is delivered to handler code as an asynchronous exception (the -standard GHC mechanism, as used by `timeout` and `cancel`). Handlers are -interruptible wherever they block in `IO`; a handler that acquires resources -must release them with `bracket`/`finally` so cancellation cannot leak them: +Cancellation is delivered as an asynchronous exception, the standard GHC +mechanism used by `timeout` and `cancel`. Handlers are interruptible wherever +they block in `IO`, and one that acquires resources should release them with +`bracket` or `finally`: ```haskell handleTool ctx (ImportData file) = @@ -375,18 +533,21 @@ ... ``` -Handlers that must not be interrupted mid-operation can shield critical -sections with `mask`, but should keep them short — cancellation waits for -them. +Critical sections can be shielded with `mask`, but keep them short: cancellation +waits for them. -## Change Notifications +### Concurrency -Servers whose tool/prompt/resource lists change at runtime can push change -notifications. Create a notifier, hand its source to the transport, and call -the notifier when things change: +Requests are served concurrently on both transports. Handlers touching shared +mutable state must synchronize with `MVar`, `STM` or similar. +## Change notifications + +Servers whose tool, prompt or resource lists change at runtime can push +change notifications. Create a notifier, hand its source to the transport, and +call the notifier when things change: + ```haskell -main :: IO () main = do (notifier, source) <- newMcpNotifier _ <- forkIO $ appLogic notifier -- calls notifyToolsListChanged etc. @@ -395,167 +556,76 @@ serverInfo handlers ``` -Delivery is transport- and era-aware, and the `listChanged`/`subscribe` -capabilities are advertised automatically where delivery is actually -possible: +Delivery is transport- and era-aware, and the `listChanged` and `subscribe` +capabilities are advertised only where delivery is possible: - **Modern clients (2026-07-28)** open a `subscriptions/listen` stream (a long-lived SSE response over HTTP) and receive only the notification types - they opted into, tagged with their subscription id — including + they opted into, tagged with their subscription id, including `notifications/resources/updated` for watched URIs. - **Legacy stdio clients** receive spontaneous untagged notifications once - their `notifications/initialized` arrives (the lifecycle's ready signal). -- **Legacy HTTP clients** have no delivery channel (this library does not - offer the deprecated GET SSE stream), so nothing is advertised to them. - -## HTTP Transport - -The library supports the MCP Streamable HTTP transport. Compile your -executable with `ghc-options: -threaded` — Warp requires the threaded runtime: - -```haskell -import MCP.Server.Transport.Http - --- Simple HTTP server (localhost:3000/mcp) -main = runMcpServerHttp serverInfo handlers - --- Custom configuration -main = runMcpServerHttpWithConfig customConfig serverInfo handlers - where - customConfig = defaultHttpConfig - { httpPort = 8080 - , httpHost = "0.0.0.0" - , httpEndpoint = "/api/mcp" - , httpVerbose = True -- Enable detailed logging - , httpAllowedOrigins = Just ["https://app.example.com"] - -- Origin validation (DNS-rebinding protection): requests with an - -- Origin header outside this list are rejected with 403. Nothing - -- disables the check (only for servers unreachable from browsers). - } -``` - -**Bearer-token authentication** (optional): supply an `httpAuthorize` callback -to validate the `Authorization: Bearer` token each request presents. Return -`Just principal` to authorize (the principal — any JSON `Value`, e.g. a role — -reaches your handlers as `clientPrincipal` in the `ClientContext`), or -`Nothing` to reject the request with 401. Token policy lives entirely in your -application; the library only threads the identity through: - -```haskell - customConfig = defaultHttpConfig - { httpAuthorize = Just $ \mtoken -> case mtoken of - Just "secret-admin-token" -> pure $ Just (String "admin") - Just "secret-user-token" -> pure $ Just (String "user") - _ -> pure Nothing - } -``` - -**Features:** -- CORS enabled for web clients -- POST `/mcp` for JSON-RPC messages (GET returns 405 — server-to-client - notifications flow over the `subscriptions/listen` POST response stream, - not a standalone GET stream) -- Dual-era protocol support: legacy revisions (`2024-11-05`–`2025-11-25`) - negotiate via `initialize`; the stateless `2026-07-28` revision declares its - version per request in `_meta`, with full request-metadata header - validation (`MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` including the - base64 sentinel encoding) -- Change notifications as long-lived SSE streams via `httpNotifications` - (see [Change Notifications](#change-notifications)) -- Optional pluggable bearer-token authentication via `httpAuthorize` -- Origin validation via `httpAllowedOrigins` -- Cacheability hints for modern list/read results via `httpCacheHints` - -### Embedding in an existing WAI stack - -`runMcpServerHttp` starts its own Warp server, but the MCP endpoint is a -plain [WAI](https://hackage.haskell.org/package/wai) application underneath, -and it is exported — so you can mount it inside whatever you already run -(your own Warp settings, TLS, middleware, or a larger router): - -```haskell -import MCP.Server (mcpApplication, defaultHttpConfig) -import qualified Network.Wai.Handler.Warp as Warp - -main :: IO () -main = Warp.runSettings mySettings $ \req respond -> - -- route /mcp to the MCP endpoint, everything else to your app - mcpApplication defaultHttpConfig serverInfo handlers req respond -``` - -`httpPort`/`httpHost` are ignored when embedding (they only configure the -server `runMcpServerHttp` starts); the endpoint path, Origin validation, -bearer auth and `subscriptions/listen` streaming all apply as usual. - -## Conformance corpus + their `notifications/initialized` arrives. +- **Legacy HTTP clients** have no delivery channel, so nothing is advertised. -The wire-format fixtures under -[`test/golden/`](test/golden/README.md) double as an **API-agnostic MCP -conformance corpus**: each case is a raw JSON-RPC `.request.json` and the -exact `.response.json` a reference server answers, per protocol era -(legacy `initialize`-negotiated revisions and the stateless `2026-07-28` -revision), enumerated by a `manifest.json`. Nothing in the corpus is -Haskell-specific — any MCP server implementation that reproduces the small -reference server described in the corpus README can replay the requests and -diff the responses. Contributions of new cases are welcome. +## Protocol support -## Roadmap +| Feature | Legacy (`2024-11-05` to `2025-11-25`) | Modern (`2026-07-28`) | +| --- | --- | --- | +| Version selection | `initialize` handshake | per-request `_meta`, `server/discover` | +| Prompts, resources, resource templates, tools | ✅ | ✅ | +| Argument completion | ✅ | ✅ | +| Tool annotations, icons, structured output | ✅ | ✅ | +| Progress and per-request logging | ✅ | ✅ | +| Cancellation | ✅ | ✅ | +| Change notifications | stdio only | `subscriptions/listen` (stdio and HTTP) | +| Result typing and cacheability hints | — | `resultType`, `httpCacheHints` | +| HTTP request-metadata headers | — | `MCP-Protocol-Version`, `Mcp-Method`, `Mcp-Name` validated | -Design decisions and planned work live as ADRs under +Design decisions and planned work (input-required results, OAuth resource +metadata, pagination, the tasks extension) live as ADRs under [`specs/`](specs/README.md), ordered by [`specs/ROADMAP.md`](specs/ROADMAP.md). ## Examples -The library includes several examples: - -- **`examples/Simple/`**: Basic key-value store using Template Haskell derivation (STDIO) -- **`examples/Complete/`**: Full-featured example with prompts, resources, a resource template, tools (enum/nested/list arguments, `isError`), and completions (STDIO) -- **`examples/HttpSimple/`**: HTTP version of the simple key-value store - -## Docker Usage - -I like to build and publish my MCP servers to Docker - which means that it's much easier to configure assistants such as Claude Desktop to run them. +- [`examples/Simple/`](examples/Simple/): a key-value store with two tools over stdio. +- [`examples/Complete/`](examples/Complete/): prompts, resources, a resource + template, tools with enum, nested and list arguments, `isError`, + annotations, progress and completions. +- [`examples/HttpSimple/`](examples/HttpSimple/): the key-value store over + Streamable HTTP. ```bash -# Build the image -docker build -t haskell-mcp-server . - -# Run different examples -docker run -i --entrypoint="/usr/local/bin/simple-example" haskell-mcp-server +cabal run simple-example # stdio; type JSON-RPC on stdin +cabal run http-simple-example # http://localhost:3000/mcp ``` -And then configure Claude by editing `claude_desktop_config.json`: +## Conformance corpus -```json -{ - "mcpServers": { - "simple-example": { - "command": "docker", - "args": [ - "run", - "-i", - "--entrypoint=/usr/local/bin/simple-example", - "haskell-mcp-server" - ] - } - } -} -``` +The wire-format fixtures under [`test/golden/`](test/golden/README.md) are a +language-agnostic MCP conformance corpus: each case is a raw JSON-RPC +`.request.json` and the exact `.response.json` a reference server answers, +per protocol era, enumerated by a `manifest.json`. Any MCP implementation +that reproduces the small reference server described there can replay the +requests and diff the responses. Contributions of new cases are welcome. ## Documentation +- [API documentation on Hackage](https://hackage.haskell.org/package/mcp-server) - [MCP Specification (2026-07-28)](https://modelcontextprotocol.io/specification/2026-07-28/) - [MCP Specification (2025-11-25, newest legacy revision)](https://modelcontextprotocol.io/specification/2025-11-25/) -- [API Documentation](https://hackage.haskell.org/package/mcp-server) -- [Examples](examples/) ## Contributing -Contributions are welcome! Please see the issue tracker for open issues and feature requests. +Contributions are welcome. See the issue tracker for open issues and feature +requests, and [RELEASING.md](RELEASING.md) for how versions reach Hackage. -## Disclaimer - AI Assistance +## AI assistance -I am not sure whether there is any stigma associated with this but Claude helped me write a lot of this library. I started with a very specific specification of what I wanted to achieve and worked shoulder-to-shoulder with Claude to implement and refactor the library until I was happy with it. A few of the features such as the Derive functions are a little out of my comfort zone to have manually written, so I appreciated having an expert guide me here - however I do suspect that this implementation may be sub-par and I do intend to refactor and rewrite large pieces of this through regular maintenance. +Much of this library was written with Claude, working from a specification I +wrote and iterating together until I was happy with the result. I review and +maintain all of it, but parts such as the Template Haskell derivation sit +outside what I would have written unaided, and I expect to keep refactoring +them. ## License diff --git a/mcp-server.cabal b/mcp-server.cabal --- a/mcp-server.cabal +++ b/mcp-server.cabal @@ -15,7 +15,7 @@ -- PVP summary: +-+------- breaking API changes -- | | +----- non-breaking API additions -- | | | +--- code changes with no API change -version: 0.2.0.1 +version: 0.2.0.2 -- A short (one-line) description of the package. synopsis: Library for building Model Context Protocol (MCP) servers -- A longer description of the package. @@ -185,6 +185,8 @@ Spec.DefinitionMetadata Spec.DerivedOutput Spec.GoldenWire + Spec.HandlerExceptions + Spec.HttpTransport Spec.JSONConversion Spec.ModernEra Spec.Progress @@ -217,6 +219,7 @@ containers, directory, hspec, + http-types, mcp-server, network-uri, stm, diff --git a/src/MCP/Server/Handlers.hs b/src/MCP/Server/Handlers.hs --- a/src/MCP/Server/Handlers.hs +++ b/src/MCP/Server/Handlers.hs @@ -30,6 +30,9 @@ , errorMessageFromMcpError ) where +import Control.Exception (SomeAsyncException, SomeException, + displayException, fromException, + throwIO, try) import Control.Monad (when) import Data.Aeson import qualified Data.Aeson.Key as Key @@ -123,6 +126,31 @@ , "resources/templates/list" ] +-- | Answer a request whose handler threw with a @-32603@ internal error +-- instead of letting the exception escape the transport, where it would +-- silently kill the request's task (stdio) or surface as a bare HTTP 500 +-- (Warp) — either way the client never sees a response for that id. +-- Asynchronous exceptions are rethrown untouched: they are how cancellation +-- reaches a handler, and a cancelled request must produce no response. +guardHandler :: RequestId -> IO JsonRpcResponse -> IO JsonRpcResponse +guardHandler rid action = do + outcome <- try action + case outcome of + Right resp -> pure resp + Left (e :: SomeException) -> + case fromException e :: Maybe SomeAsyncException of + Just _ -> throwIO e + Nothing -> do + -- The full rendering (which on recent GHCs includes a call stack + -- for 'error') goes to stderr; the wire carries its first line. + let rendered = displayException e + hPutStrLn stderr $ "Handler threw for request " ++ show rid ++ ": " ++ rendered + pure $ makeErrorResponse rid $ JsonRpcError + { errorCode = -32603 + , errorMessage = "Internal error: " <> T.pack (takeWhile (/= '\n') rendered) + , errorData = Nothing + } + -- | Stamp the modern-revision result envelope onto a successful response: -- @resultType: \"complete\"@, the server's identity in result @_meta@, and -- (for cacheable methods) @ttlMs@ and @cacheScope@. Error responses and @@ -187,7 +215,7 @@ , reportProgress = progressReporter emit params , logToClient = clientLogger emit params } - response <- case requestMethod req of + response <- guardHandler (requestId req) $ case requestMethod req of -- Era purity: the modern revision has neither initialize (nothing to -- negotiate statelessly) nor ping (removed) — a request declaring a -- modern revision must be served "according to this revision", so diff --git a/src/MCP/Server/Transport/Stdio.hs b/src/MCP/Server/Transport/Stdio.hs --- a/src/MCP/Server/Transport/Stdio.hs +++ b/src/MCP/Server/Transport/Stdio.hs @@ -10,7 +10,7 @@ ) where import Control.Concurrent (ThreadId, forkIO, killThread) -import Control.Concurrent.Async (Async, async, cancel) +import Control.Concurrent.Async (Async, async, cancel, waitCatch) import Control.Concurrent.MVar (modifyMVar_, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar, withMVar) @@ -232,8 +232,14 @@ eof <- hIsEOF stdin if eof then do + -- EOF means no more input, not "abandon outstanding work": per the + -- lifecycle spec the client closes stdin and then waits for the + -- server to exit, so drain in-flight requests (their responses are + -- still wanted) before tearing down the open-ended streams. + -- waitCatch, not wait: a handler that threw must not abort the + -- shutdown of everything else. inflight <- readMVar inflightVar - mapM_ (cancel . snd) inflight + mapM_ (waitCatch . snd) inflight closeAllSubscriptions logLine "stdin closed - shutting down" else do diff --git a/test/HspecMain.hs b/test/HspecMain.hs --- a/test/HspecMain.hs +++ b/test/HspecMain.hs @@ -12,6 +12,8 @@ import qualified Spec.DefinitionMetadata import qualified Spec.DerivedOutput import qualified Spec.GoldenWire +import qualified Spec.HandlerExceptions +import qualified Spec.HttpTransport import qualified Spec.ModernEra import qualified Spec.Progress import qualified Spec.ProtocolVersionNegotiation @@ -32,6 +34,8 @@ Spec.DefinitionMetadata.spec Spec.DerivedOutput.spec Spec.GoldenWire.spec + Spec.HandlerExceptions.spec + Spec.HttpTransport.spec Spec.ModernEra.spec Spec.Progress.spec Spec.ProtocolVersionNegotiation.spec diff --git a/test/Spec/HandlerExceptions.hs b/test/Spec/HandlerExceptions.hs new file mode 100644 --- /dev/null +++ b/test/Spec/HandlerExceptions.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A handler that throws (rather than returning an error value) must still +-- produce a response for its request id: a -32603 internal error. Without +-- this the exception escapes the transport and the client waits forever. +-- Asynchronous exceptions are deliberately not covered here — cancellation +-- relies on them propagating, which "Spec.Cancellation" pins down. +module Spec.HandlerExceptions (spec) where + +import Control.Exception (throwIO, ErrorCall (..)) +import Data.Aeson +import qualified Data.Text as T +import MCP.Server +import MCP.Server.Handlers (handleMcpMessage) +import MCP.Server.JsonRpc +import Test.Hspec + +throwingServer :: McpServerHandlers +throwingServer = noHandlers + { tools = Just + ( \_ -> pure [] + , \_ _ _ -> throwIO (ErrorCall "tool exploded") + ) + , prompts = Just + ( \_ -> pure [] + , \_ _ _ -> error "prompt exploded" + ) + } + +call :: T.Text -> Value -> IO (Maybe JsonRpcMessage) +call method params = + handleMcpMessage (McpServerInfo "T" "1" "") defaultCacheHints + noNotificationSupport (\_ -> pure ()) throwingServer anonymousContext + (JsonRpcMessageRequest (JsonRpcRequest "2.0" (RequestIdNumber 7) method (Just params))) + +errorOf :: Maybe JsonRpcMessage -> (RequestId, Int, T.Text) +errorOf (Just (JsonRpcMessageResponse r)) = case responseError r of + Just e -> (responseId r, errorCode e, errorMessage e) + Nothing -> error $ "expected an error response, got " ++ show (responseResult r) +errorOf other = error $ "expected a response, got " ++ show other + +spec :: Spec +spec = describe "Handler exceptions" $ do + it "a throwing tool handler yields -32603 for its request id" $ do + (rid, code, msg) <- errorOf <$> call "tools/call" (object ["name" .= ("x" :: T.Text), "arguments" .= object []]) + rid `shouldBe` RequestIdNumber 7 + code `shouldBe` (-32603) + msg `shouldSatisfy` T.isInfixOf "tool exploded" + + it "a throwing prompt handler yields -32603 (pure error, forced inside the handler)" $ do + (rid, code, msg) <- errorOf <$> call "prompts/get" (object ["name" .= ("x" :: T.Text), "arguments" .= object []]) + rid `shouldBe` RequestIdNumber 7 + code `shouldBe` (-32603) + msg `shouldSatisfy` T.isInfixOf "prompt exploded" diff --git a/test/Spec/HttpTransport.hs b/test/Spec/HttpTransport.hs new file mode 100644 --- /dev/null +++ b/test/Spec/HttpTransport.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Drive the Streamable HTTP transport in-process through the exported +-- WAI application, without Warp or a socket. The handler-level specs pin +-- what 'handleMcpMessage' answers; these pin what actually reaches an +-- HTTP client, which is the layer that used to lose a throwing handler +-- (a bare Warp 500 for single-JSON responses, a dropped connection for +-- SSE ones). +module Spec.HttpTransport (spec) where + +import Control.Exception (ErrorCall (..), throwIO) +import Data.Aeson +import qualified Data.Aeson.KeyMap as KM +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Lazy as BSL +import Data.IORef +import Data.Text (Text) +import qualified Data.Text as T +import MCP.Server +import qualified Network.HTTP.Types as HTTP +import qualified Network.Wai as Wai +import Network.Wai.Internal (ResponseReceived (..)) +import Test.Hspec + +server :: McpServerHandlers +server = noHandlers + { tools = Just + ( \_ -> pure [] + , \_ name _ -> case name of + "boom" -> throwIO (ErrorCall "tool exploded") + "ok" -> pure $ Right $ toToolResult ("fine" :: Text) + _ -> pure $ Left $ UnknownTool name + ) + } + +app :: Wai.Application +app = mcpApplication defaultHttpConfig { httpAllowedOrigins = Nothing } + (McpServerInfo "T" "1" "") server + +-- | POST a JSON body to /mcp and collect the full response, whether it was +-- sent as a single body or streamed (SSE). +post :: [HTTP.Header] -> Value -> IO (HTTP.Status, [HTTP.Header], BS.ByteString) +post extraHeaders body = do + chunks <- newIORef (BSL.toChunks (encode body)) + let nextChunk = atomicModifyIORef' chunks $ \cs -> case cs of + [] -> ([], BS.empty) + (c:cs') -> (cs', c) + req = Wai.setRequestBodyChunks nextChunk Wai.defaultRequest + { Wai.requestMethod = "POST" + , Wai.rawPathInfo = "/mcp" + , Wai.pathInfo = ["mcp"] + , Wai.requestHeaders = + ("Content-Type", "application/json") + : ("Accept", "application/json, text/event-stream") + : extraHeaders + } + out <- newIORef mempty + result <- newIORef Nothing + _ <- app req $ \resp -> do + let (status, headers, withBody) = Wai.responseToStream resp + withBody $ \streamingBody -> + streamingBody (\b -> modifyIORef' out (<> b)) (pure ()) + writeIORef result (Just (status, headers)) + pure ResponseReceived + Just (status, headers) <- readIORef result + bytes <- BSL.toStrict . B.toLazyByteString <$> readIORef out + pure (status, headers, bytes) + +toolCall :: Text -> [(Key, Value)] -> Value +toolCall name meta = object + [ "jsonrpc" .= ("2.0" :: Text) + , "id" .= (7 :: Int) + , "method" .= ("tools/call" :: Text) + , "params" .= object + ([ "name" .= name, "arguments" .= object [] ] + ++ [ "_meta" .= object meta | not (null meta) ]) + ] + +-- | The JSON-RPC error (code, message) in a response body, or in the +-- last SSE data event of a streamed one. +errorIn :: BS.ByteString -> Maybe (Int, Text) +errorIn raw = do + let payload = case [ BS.drop 6 l | l <- BS.split 10 raw, "data: " `BS.isPrefixOf` l ] of + [] -> raw + ls -> last ls + Object o <- decodeStrict payload + Object e <- KM.lookup "error" o + Number c <- KM.lookup "code" e + String m <- KM.lookup "message" e + pure (round c, m) + +spec :: Spec +spec = describe "HTTP transport (in-process WAI)" $ do + it "answers a normal tool call with 200 and a result" $ do + (status, _, body) <- post [] (toolCall "ok" []) + HTTP.statusCode status `shouldBe` 200 + body `shouldSatisfy` ("\"fine\"" `BS.isInfixOf`) + + it "answers a throwing handler with 200 and a -32603 body (legacy, single-JSON)" $ do + (status, headers, body) <- post [] (toolCall "boom" []) + HTTP.statusCode status `shouldBe` 200 + lookup "Content-Type" headers `shouldBe` Just "application/json" + fmap fst (errorIn body) `shouldBe` Just (-32603) + fmap snd (errorIn body) `shouldSatisfy` maybe False (T.isInfixOf "tool exploded") + + it "answers a throwing handler inside the SSE stream (legacy, progressToken)" $ do + (status, headers, body) <- post [] (toolCall "boom" ["progressToken" .= ("t1" :: Text)]) + HTTP.statusCode status `shouldBe` 200 + lookup "Content-Type" headers `shouldBe` Just "text/event-stream" + body `shouldSatisfy` ("data: " `BS.isPrefixOf`) + fmap fst (errorIn body) `shouldBe` Just (-32603) + + it "answers a throwing handler with a -32603 body (modern 2026-07-28)" $ do + (status, _, body) <- post + [ ("MCP-Protocol-Version", "2026-07-28") + , ("Mcp-Method", "tools/call") + , ("Mcp-Name", "boom") + ] + (toolCall "boom" ["io.modelcontextprotocol/protocolVersion" .= ("2026-07-28" :: Text)]) + HTTP.statusCode status `shouldBe` 200 + fmap fst (errorIn body) `shouldBe` Just (-32603) + -- an error carries no result envelope + body `shouldSatisfy` (not . ("resultType" `BS.isInfixOf`))